sbcl stuff

sbcl/.quicklisp/dists/quicklisp/software/usocket-0.8.3/backend/ecl.lisp

@@ -0,0 +1,152 @@
+;;;; -*- Mode: Lisp -*-
+
+;;;; 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 :unsigned-int)
+  (ffi:def-foreign-type ws-dword :unsigned-long)
+  (ffi:def-foreign-type ws-event :unsigned-int)
+
+  (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")
+
+  (ffi:def-function ("WSAGetLastError" wsa-get-last-error)
+    ()
+    :returning :int
+    :module "ws2_32")
+
+  (defun maybe-wsa-error (rv &optional socket)
+    (unless (zerop rv)
+      (raise-usock-err (wsa-get-last-error) socket)))
+
+  (defun bytes-available-for-read (socket)
+    (ffi:with-foreign-object (int-ptr :unsigned-long)
+      (maybe-wsa-error (wsa-ioctlsocket (socket-handle socket) fionread int-ptr)
+                       socket)
+      (let ((int (ffi:deref-pointer int-ptr :unsigned-long)))
+        (prog1 int
+          (when (plusp int)
+            (setf (state socket) :read))))))
+
+  (defun map-network-events (func network-events)
+    (let ((event-map (ffi:get-slot-value network-events 'wsa-network-events 'network-events))
+          (error-array (ffi:get-slot-pointer network-events 'wsa-network-events 'error-code)))
+      (unless (zerop event-map)
+        (dotimes (i fd-max-events)
+          (unless (zerop (ldb (byte 1 i) event-map))
+            (funcall func (ffi:deref-array error-array '(:array :int 10) i)))))))
+
+  (defun update-ready-and-state-slots (sockets)
+    (dolist (socket sockets)
+      (if (%ready-p socket)
+          (progn
+            (setf (state socket) :READ))
+        (ffi:with-foreign-object (network-events 'wsa-network-events)
+          (let ((rv (wsa-enum-network-events (socket-handle socket) 0 network-events)))
+            (if (zerop rv)
+                (map-network-events
+                 #'(lambda (err-code)
+                     (if (zerop err-code)
+                         (progn
+                           (setf (state socket) :READ)
+                           (when (stream-server-usocket-p socket)
+                             (setf (%ready-p socket) t)))
+                       (raise-usock-err err-code socket)))
+                 network-events)
+              (maybe-wsa-error rv socket)))))))
+
+  (defun os-wait-list-%wait (wait-list)
+    (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event))
+
+  (defun (setf os-wait-list-%wait) (value wait-list)
+    (setf (ffi:deref-pointer (wait-list-%wait wait-list) 'ws-event) value))
+
+  (defun free-wait-list (wl)
+    (when (wait-list-p wl)
+      (unless (null (wait-list-%wait wl))
+        (wsa-event-close (os-wait-list-%wait wl))
+        (ffi:free-foreign-object (wait-list-%wait wl))
+        (setf (wait-list-%wait wl) nil))))
+
+  (defun %setup-wait-list (wait-list)
+    (setf (wait-list-%wait wait-list)
+          (ffi:allocate-foreign-object 'ws-event))
+    (setf (os-wait-list-%wait wait-list)
+          (wsa-event-create))
+    (ext:set-finalizer wait-list #'free-wait-list))
+
+  (defun os-socket-handle (usocket)
+    (socket-handle usocket))
+
+) ; #+(and ecl-bytecmp windows)