[MCL] improved SOCKET-CONNECT

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

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)))))
+