Author: ctian
Date: Sat Feb 20 22:38:51 2010
New Revision: 521
Log:
LispWorks: code clean; remove support for LispWorks 3.
Modified:
usocket/trunk/backend/lispworks.lisp
Modified: usocket/trunk/backend/lispworks.lisp
==============================================================================
--- usocket/trunk/backend/lispworks.lisp (original)
+++ usocket/trunk/backend/lispworks.lisp Sat Feb 20 22:38:51 2010
@@ -6,12 +6,14 @@
(in-package :usocket)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (require "comm"))
+ (require "comm")
+
+ #+lispworks3
+ (error "LispWorks 3 is not supported by USOCKET."))
;;; ---------------------------------------------------------------------------
;;; Warn if multiprocessing is not running on Lispworks
-#-win32
(defun check-for-multiprocessing-started (&optional errorp)
(unless mp:*current-process*
(funcall (if errorp 'error 'warn)
@@ -21,11 +23,13 @@
'mp:initialize-multiprocessing
'wait-for-input)))
-#-win32
-(check-for-multiprocessing-started)
+(eval-when (:load-toplevel :execute)
+ (check-for-multiprocessing-started))
#+win32
-(fli:register-module "ws2_32")
+(eval-when (:load-toplevel :execute)
+ (fli:register-module "ws2_32")
+ (comm::ensure-sockets))
(fli:define-foreign-function (get-host-name-internal "gethostname" :source)
((return-string (:reference-return (:ef-mb-string :limit 257)))
@@ -359,7 +363,8 @@
:element-type '(unsigned-byte 8)
:allocation :static))
-(defvar *message-send-lock* (mp:make-lock))
+(defvar *message-send-lock*
+ (mp:make-lock :name "USOCKET message send lock"))
(defun send-message (socket-fd buffer &optional (length (length buffer)) host service)
"Send message to a socket, using sendto()/send()"
@@ -368,7 +373,7 @@
(let ((message *message-send-buffer*))
(fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in))
(len :int
- #-(or lispworks3 lispworks4 lispworks5.0)
+ #-(or lispworks4 lispworks5.0) ; <= 5.0
:initial-element
(fli:size-of '(:struct comm::sockaddr_in))))
(fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
@@ -384,14 +389,15 @@
(defmethod socket-send ((socket datagram-usocket) buffer length &key host port)
(let ((s (socket socket)))
- (send-message s buffer length (host-to-hbo host) port)))
+ (send-message s buffer length (and host (host-to-hbo host)) port)))
(defvar *message-receive-buffer*
(make-array +max-datagram-packet-size+
:element-type '(unsigned-byte 8)
:allocation :static))
-(defvar *message-receive-lock* (mp:make-lock))
+(defvar *message-receive-lock*
+ (mp:make-lock :name "USOCKET message receive lock"))
(defun receive-message (socket-fd &optional buffer (length (length buffer))
&key read-timeout (max-buffer-size +max-datagram-packet-size+))
@@ -408,7 +414,7 @@
old-timeout)
(fli:with-dynamic-foreign-objects ((client-addr (:struct comm::sockaddr_in))
(len :int
- #-(or lispworks3 lispworks4 lispworks5.0)
+ #-(or lispworks4 lispworks5.0) ; <= 5.0
:initial-element
(fli:size-of '(:struct comm::sockaddr_in))))
(fli:with-dynamic-lisp-array-pointer (ptr message :type '(:unsigned :byte))
@@ -531,7 +537,9 @@
(wait-list-waiters wait-list))))
(dolist (x (wait-list-waiters wait-list))
(mp:unnotice-fd (os-socket-handle x)))
- wait-list)))
+ wait-list))
+
+) ; end of block
;;;
@@ -551,6 +559,7 @@
;; to resort to system calls to achieve the same thing.
;; Luckily, it provides us access to the raw socket handles (as we
;; wrote the code above.
+
(defconstant fd-read 1)
(defconstant fd-read-bit 0)
(defconstant fd-write 2)
@@ -603,10 +612,12 @@
:lambda-list nil
:result-type :int
:module "ws2_32")
+
(fli:define-foreign-function (wsa-event-close "WSACloseEvent" :source)
((event-object win32-handle))
:result-type :int
:module "ws2_32")
+
(fli:define-foreign-function (wsa-enum-network-events "WSAEnumNetworkEvents" :source)
((socket ws-socket)
(event-object win32-handle)
@@ -670,7 +681,6 @@
(system:wait-for-single-object (wait-list-%wait wait-list)
"Waiting for socket activity" timeout))
(update-ready-and-state-slots (wait-list-waiters wait-list)))
-
(defun map-network-events (func network-events)
(let ((event-map (fli:foreign-slot-value network-events 'network-events))
@@ -691,7 +701,7 @@
(wsa-enum-network-events (os-socket-handle socket) 0 t)
(if (zerop rv)
(map-network-events #'(lambda (err-code)
- (if (zerop err-code)
+ (if (zerop err-code)
(setf (%ready-p socket) t
(state socket) :READ)
(raise-usock-err err-code socket)))
@@ -707,7 +717,8 @@
(unless (null (wait-list-%wait wl))
(wsa-event-close (wait-list-%wait wl)))))
- (hcl:add-special-free-action 'free-wait-list)
+ (eval-when (:load-toplevel :execute)
+ (hcl:add-special-free-action 'free-wait-list))
(defun %setup-wait-list (wait-list)
(hcl:flag-special-free-action wait-list)
@@ -716,7 +727,8 @@
(defun %add-waiter (wait-list waiter)
(let ((events (etypecase waiter
(stream-server-usocket (logior fd-connect fd-accept fd-close))
- (stream-usocket (logior fd-connect fd-read fd-oob fd-close)))))
+ (stream-usocket (logior fd-connect fd-read fd-oob fd-close))
+ (datagram-usocket (logior fd-read)))))
(maybe-wsa-error
(wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) events)
waiter)))
@@ -726,4 +738,4 @@
(wsa-event-select (os-socket-handle waiter) (wait-list-%wait wait-list) 0)
waiter))
- );; end of WIN32-block
+) ; end of WIN32-block
