[usocket-cvs] r700 - in usocket/trunk: . backend

[ctian at common-lisp.net]

Author: ctian
Date: Sat Dec  8 08:35:12 2012
New Revision: 700

Log:
[ECL] Add the framework for ECL DFFI support

Added:
   usocket/trunk/backend/ecl.lisp   (contents, props changed)
Modified:
   usocket/trunk/backend/sbcl.lisp
   usocket/trunk/usocket.asd

Added: usocket/trunk/backend/ecl.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ usocket/trunk/backend/ecl.lisp	Sat Dec  8 08:35:12 2012	(r700)
@@ -0,0 +1,87 @@
+;;;; -*- Mode: Lisp -*-
+;;;; $Id$
+;;;; $URL$
+
+;;;; Foreign functions defined by ECL's DFFI, used for #+ecl-bytecmp only.
+;;;; See LICENSE for licensing information.
+
+(in-package :usocket)
+
+#+(and ecl-bytecmp windows)
+(eval-when (:load-toplevel :execute)
+  (ffi:load-foreign-library "ws2_32.dll" :module "ws2_32"))
+
+#+(and ecl-bytecmp windows)
+(progn
+
+(ffi:def-function ("gethostname" c-gethostname)
+  ((name (* :unsigned-char))
+   (len :int))
+  :returning :int
+  :module "ws2_32")
+
+(defun get-host-name ()
+  "Returns the hostname"
+  (ffi:with-foreign-object (name '(:array :unsigned-char 256))
+    (when (zerop (c-gethostname (ffi:char-array-to-pointer name) 256))
+      (ffi:convert-from-foreign-string name))))
+
+(ffi:def-foreign-type ws-socket :signed)
+(ffi:def-foreign-type ws-dword :unsigned-long)
+(ffi:def-foreign-type ws-event :pointer-void)
+
+(ffi:def-struct wsa-network-events
+  (network-events :long)
+  (error-code (:array :int 10)))
+
+(ffi:def-function ("WSACreateEvent" wsa-event-create)
+  ()
+  :returning ws-event
+  :module "ws2_32")
+
+(ffi:def-function ("WSACloseEvent" c-wsa-event-close)
+  ((event-object ws-event))
+  :returning :int
+  :module "ws2_32")
+
+(defun wsa-event-close (ws-event)
+  (not (zerop (c-wsa-event-close ws-event))))
+
+(ffi:def-function ("WSAEnumNetworkEvents" wsa-enum-network-events)
+  ((socket ws-socket)
+   (event-object ws-event)
+   (network-events (* wsa-network-events)))
+  :returning :int
+  :module "ws2_32")
+
+(ffi:def-function ("WSAEventSelect" wsa-event-select)
+  ((socket ws-socket)
+   (event-object ws-event)
+   (network-events :long))
+  :returning :int
+  :module "ws2_32")
+
+(ffi:def-function ("WSAWaitForMultipleEvents" c-wsa-wait-for-multiple-events)
+  ((number-of-events ws-dword)
+   (events (* ws-event))
+   (wait-all-p :int)
+   (timeout ws-dword)
+   (alertable-p :int))
+  :returning ws-dword
+  :module "ws2_32")
+
+(defun wsa-wait-for-multiple-events (number-of-events events wait-all-p timeout alertable-p)
+  (c-wsa-wait-for-multiple-events number-of-events
+                                  events
+                                  (if wait-all-p -1 0)
+                                  timeout
+                                  (if alertable-p -1 0)))
+
+(ffi:def-function ("ioctlsocket" wsa-ioctlsocket)
+  ((socket ws-socket)
+   (cmd :long)
+   (argp (* :unsigned-long)))
+  :returning :int
+  :module "ws2_32")
+
+) ; #+(and ecl-bytecmp windows)

Modified: usocket/trunk/backend/sbcl.lisp
==============================================================================
--- usocket/trunk/backend/sbcl.lisp	Sat Nov 17 17:44:09 2012	(r699)
+++ usocket/trunk/backend/sbcl.lisp	Sat Dec  8 08:35:12 2012	(r700)
@@ -1,3 +1,4 @@
+;;;; -*- Mode: Lisp -*-
 ;;;; $Id$
 ;;;; $URL$
 
@@ -26,7 +27,7 @@
          (when (= result 0)
            (sb-alien:cast buf sb-alien:c-string))))))
 
-#+ecl
+#+(and ecl (not ecl-bytecmp))
 (progn
   #-:wsock
   (ffi:clines
@@ -548,10 +549,6 @@
   (sb-alien:define-alien-routine ("WSACreateEvent" wsa-event-create)
       ws-event) ; return type only
 
-  (sb-alien:define-alien-routine ("WSAResetEvent" wsa-event-reset)
-      (boolean #.sb-vm::n-machine-word-bits)
-    (event-object ws-event))
-
   (sb-alien:define-alien-routine ("WSACloseEvent" wsa-event-close)
       (boolean #.sb-vm::n-machine-word-bits)
     (event-object ws-event))
@@ -716,7 +713,7 @@
     (declare (ignore wl w)))
 ) ; progn
 
-#+(and ecl win32)
+#+(and ecl win32 (not ecl-bytecmp))
 (progn
   (defun maybe-wsa-error (rv &optional syscall)
     (unless (zerop rv)

Modified: usocket/trunk/usocket.asd
==============================================================================
--- usocket/trunk/usocket.asd	Sat Nov 17 17:44:09 2012	(r699)
+++ usocket/trunk/usocket.asd	Sat Dec  8 08:35:12 2012	(r700)
@@ -16,20 +16,22 @@
 		 (:module "vendor" :depends-on ("package")
 		  :components ((:file "split-sequence")
 			       #+mcl (:file "kqueue")
-                               (:file "spawn-thread")))
-                 (:file "usocket" :depends-on ("vendor"))
-                 (:file "condition" :depends-on ("usocket"))
+			       (:file "spawn-thread")))
+		 (:file "usocket" :depends-on ("vendor"))
+		 (:file "condition" :depends-on ("usocket"))
 		 (:module "backend" :depends-on ("condition")
 		  :components (#+abcl		(:file "abcl")
 			       #+clisp		(:file "clisp")
 			       #+cmu		(:file "cmucl")
 			       #+scl		(:file "scl")
-			       #+(or sbcl ecl)	(:file "sbcl")
+			       #+ecl	(:file "ecl")
+			       #+(or sbcl ecl)	(:file "sbcl"
+						 :depends-on (#+ecl "ecl"))
 			       #+lispworks	(:file "lispworks")
 			       #+mcl		(:file "mcl")
 			       #+openmcl	(:file "openmcl")
 			       #+allegro	(:file "allegro")))
-                 (:file "option" :depends-on ("backend"))
+		 (:file "option" :depends-on ("backend"))
 		 (:file "server" :depends-on ("backend" "option"))))
 
 (defmethod perform ((op test-op) (c (eql (find-system :usocket))))