diff --git a/backend/mcl.lisp b/backend/mcl.lisp index dcdfbc1..de7b84c 100644 --- a/backend/mcl.lisp +++ b/backend/mcl.lisp @@ -30,12 +30,12 @@ local-host local-port (protocol :stream)) (when (eq nodelay :if-supported) (setf nodelay t)) - (with-mapped-conditions () - (ecase protocol - (:stream + (ecase protocol + (:stream + (with-mapped-conditions () (let* ((socket (make-instance 'active-socket - :remote-host (when host (host-to-hostname host)) + :remote-host (when host (host-to-hostname host)) :remote-port port :local-host (when local-host (host-to-hostname local-host)) :local-port local-port @@ -44,10 +44,11 @@ :connect-timeout (and timeout (round (* timeout 60))) :element-type element-type)) (stream (socket-open-stream socket))) - (make-stream-socket :socket socket :stream stream))) - (:datagram + (make-stream-socket :socket socket :stream stream)))) + (:datagram + (with-mapped-conditions () (make-datagram-socket - (ccl::open-udp-socket :local-address (and local-host (host-to-hostname local-host)) + (ccl::open-udp-socket :local-address (and local-host (host-to-hbo local-host)) :local-port local-port)))))) (defun socket-listen (host port diff --git a/vendor/OpenTransportUDP.lisp b/vendor/OpenTransportUDP.lisp index d5822ac..f9ff360 100644 --- a/vendor/OpenTransportUDP.lisp +++ b/vendor/OpenTransportUDP.lisp @@ -52,13 +52,50 @@ (defun open-udp-socket (&key local-address local-port) (init-opentransport) - (let (endpoint + (let (endpoint ; TODO: opentransport-alloc-endpoint-from-freelist (err #$kOTNoError) (configptr (ot-cloned-configuration traps::$kUDPName))) (rlet ((errP :osstatus)) (setq endpoint #+carbon-compat (#_OTOpenEndpointInContext configptr 0 (%null-ptr) errP *null-ptr*) #-carbon-compat (#_OTOpenEndpoint configptr 0 (%null-ptr) errP) err (pref errP :osstatus)) - (unless (eql err #$kOTNoError) - (ot-error err :create)) - endpoint))) + (if (eql err #$kOTNoError) + (let* ((context (ot-make-endpoint-context endpoint nil nil)) ; no notifier, not minimal + (conn (make-ot-conn :context context :endpoint endpoint))) + (macrolet ((check-ot-error-return (error-context) + `(unless (eql (setq err (pref errP :osstatus)) #$kOTNoError) + (values (ot-error err ,error-context))))) + (setf (ot-conn-bindreq conn) + #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADDR errP) + #+carbon-compat (#_OTAllocInContext endpoint #$T_BIND #$T_ADDR errP *null-ptr*) + ) + (check-ot-error-return :alloc) + (setf (ot-conn-bindret conn) + #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADDR errP) + #+carbon-compat (#_OTAllocInContext endpoint #$T_BIND #$T_ADDR errP *null-ptr*) + ) + (check-ot-error-return :alloc) + (setf (ot-conn-options conn) + #-carbon-compat (#_OTAlloc endpoint #$T_OPTMGMT #$T_OPT errP) + #+carbon-compat (#_OTAllocInContext endpoint #$T_OPTMGMT #$T_OPT errP *null-ptr*) + ) + (check-ot-error-return :alloc)) + ;; BIND to local address (for UDP server) + (when local-port ; local-address + (let* ((host (or local-address (local-interface-ip-address))) + (port (tcp-service-port-number local-port)) + (localaddress `(:tcp ,host ,port)) + (bindreq (ot-conn-bindreq conn)) + (bindret (ot-conn-bindret conn))) + (let* ((netbuf (pref bindreq :tbind.addr))) + (declare (dynamic-extent netbuf)) + (setf (pref netbuf :tnetbuf.len) (record-length :inetaddress) + (pref bindreq :tbind.qlen) 5) ; arbitrary qlen + (#_OTInitInetAddress (pref netbuf :tnetbuf.buf) port host) + (setf (pref context :ot-context.completed) nil) + (unless (= (setq err (#_OTBind endpoint bindreq bindret)) #$kOTNoError) + (ot-error err :bind))) + (setf (ot-conn-local-address conn) localaddress))) + conn) + (ot-error err :create))))) +