Commit b3beeb90 authored by Christian Schafmeister's avatar Christian Schafmeister Committed by Chun Tian (binghe)

Could we add clasp support to usocket (#45)

* Add support for clasp to usocket

* Fixes for clasp

* Working on clasp implementation

* Add clasp to the readme

* Use bordeaux-threads instead of portable-threads in usocket-server
parent 48ba6d48
......@@ -5,19 +5,20 @@ sockets access to the broadest of common lisp implementations as possible.
## The library currently supports:
1. Allegro CL
2. ABCL (ArmedBear)
3. Clozure CL
4. Corman Lisp
5. GNU CLISP
6. CMUCL
7. ECL
8. LispWorks (4.3 and up)
9. Digitool MCL and RMCL (5.0 and up)
10. MOCL
11. SBCL
12. Scieneer CL
13. Symbolics Genera
- Allegro CL
- ABCL (ArmedBear)
- Clasp
- Clozure CL
- Corman Lisp
- GNU CLISP
- CMUCL
- ECL
- LispWorks (4.3 and up)
- Digitool MCL and RMCL (5.0 and up)
- MOCL
- SBCL
- Scieneer CL
- Symbolics Genera
If your favorite common lisp misses in the list above, please contact
usocket-devel@common-lisp.net and submit a request. Please include
......
(in-package :usocket)
#-clasp
(progn
#-:wsock
(ffi:clines
"#include <errno.h>"
"#include <sys/socket.h>"
"#include <unistd.h>")
#+:wsock
(ffi:clines
"#ifndef FD_SETSIZE"
"#define FD_SETSIZE 1024"
"#endif"
"#include <winsock2.h>")
(ffi:clines
#+:msvc "#include <time.h>"
#-:msvc "#include <sys/time.h>"
"#include <ecl/ecl-inl.h>"))
(progn
#-clasp
(defun cerrno ()
(ffi:c-inline () () :int
"errno" :one-liner t))
#+clasp
(defun cerrno ()
(sockets-internal:errno))
#-clasp
(defun fd-setsize ()
(ffi:c-inline () () :fixnum
"FD_SETSIZE" :one-liner t))
#+clasp
(defun fd-setsize () (sockets-internal:fd-setsize))
#-clasp
(defun fdset-alloc ()
(ffi:c-inline () () :pointer-void
"ecl_alloc_atomic(sizeof(fd_set))" :one-liner t))
#+clasp (defun fdset-alloc () (sockets-internal::alloc-atomic-sizeof-fd-set))
#-clasp
(defun fdset-zero (fdset)
(ffi:c-inline (fdset) (:pointer-void) :void
"FD_ZERO((fd_set*)#0)" :one-liner t))
#+clasp(defun fdset-zero (fdset) (sockets-internal:fdset-zero fdset))
#-clasp
(defun fdset-set (fdset fd)
(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
"FD_SET(#1,(fd_set*)#0)" :one-liner t))
#+clasp(defun fdset-set (fdset fd) (sockets-internal:fdset-set fd fdset))
#-clasp
(defun fdset-clr (fdset fd)
(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :void
"FD_CLR(#1,(fd_set*)#0)" :one-liner t))
#+clasp(defun fdset-clr (fdset fd) (sockets-internal:fdset-clr fd fdset))
#-clasp
(defun fdset-fd-isset (fdset fd)
(ffi:c-inline (fdset fd) (:pointer-void :fixnum) :bool
"FD_ISSET(#1,(fd_set*)#0)" :one-liner t))
#+clasp(defun fdset-fd-isset (fdset fd) (sockets-internal:fdset-isset fd fdset))
(declaim (inline cerrno
fd-setsize
fdset-alloc
fdset-zero
fdset-set
fdset-clr
fdset-fd-isset))
#-clasp
(defun get-host-name ()
(ffi:c-inline
() () :object
"{ char *buf = (char *) ecl_alloc_atomic(257);
if (gethostname(buf,256) == 0)
@(return) = make_simple_base_string(buf);
else
@(return) = Cnil;
}" :one-liner nil :side-effects nil))
#+clasp
(defun get-host-name ()
(sockets-internal:get-host-name))
#-clasp
(defun read-select (wl to-secs &optional (to-musecs 0))
(let* ((sockets (wait-list-waiters wl))
(rfds (wait-list-%wait wl))
(max-fd (reduce #'(lambda (x y)
(let ((sy (sb-bsd-sockets:socket-file-descriptor
(socket y))))
(if (< x sy) sy x)))
(cdr sockets)
:initial-value (sb-bsd-sockets:socket-file-descriptor
(socket (car sockets))))))
(fdset-zero rfds)
(dolist (sock sockets)
(fdset-set rfds (sb-bsd-sockets:socket-file-descriptor
(socket sock))))
(let ((count
(ffi:c-inline (to-secs to-musecs rfds max-fd)
(t :unsigned-int :pointer-void :int)
:int
"
int count;
struct timeval tv;
if (#0 != Cnil) {
tv.tv_sec = fixnnint(#0);
tv.tv_usec = #1;
}
@(return) = select(#3 + 1, (fd_set*)#2, NULL, NULL,
(#0 != Cnil) ? &tv : NULL);
" :one-liner nil)))
(cond
((= 0 count)
(values nil nil))
((< count 0)
;; check for EINTR and EAGAIN; these should not err
(values nil (cerrno)))
(t
(dolist (sock sockets)
(when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
(socket sock)))
(setf (state sock) :READ))))))))
#+clasp
(defun read-select (wl to-secs &optional (to-musecs 0))
(let* ((sockets (wait-list-waiters wl))
(rfds (wait-list-%wait wl))
(max-fd (reduce #'(lambda (x y)
(let ((sy (sb-bsd-sockets:socket-file-descriptor
(socket y))))
(if (< x sy) sy x)))
(cdr sockets)
:initial-value (sb-bsd-sockets:socket-file-descriptor
(socket (car sockets))))))
(fdset-zero rfds)
(dolist (sock sockets)
(fdset-set rfds (sb-bsd-sockets:socket-file-descriptor
(socket sock))))
(let ((count (sockets-internal:do-select to-secs to-musecs rfds max-fd)))
(cond
((= 0 count)
(values nil nil))
((< count 0)
;; check for EINTR and EAGAIN; these should not err
(values nil (cerrno)))
(t
(dolist (sock sockets)
(when (fdset-fd-isset rfds (sb-bsd-sockets:socket-file-descriptor
(socket sock)))
(setf (state sock) :READ))))))))
)
......@@ -162,25 +162,25 @@
. operation-not-permitted-error)
(sb-bsd-sockets:protocol-not-supported-error
. protocol-not-supported-error)
#-ecl
#-(or ecl clasp)
(sb-bsd-sockets:unknown-protocol
. protocol-not-supported-error)
(sb-bsd-sockets:socket-type-not-supported-error
. socket-type-not-supported-error)
(sb-bsd-sockets:network-unreachable-error . network-unreachable-error)
(sb-bsd-sockets:operation-timeout-error . timeout-error)
#-ecl
#-(or ecl clasp)
(sb-sys:io-timeout . timeout-error)
#+sbcl
(sb-ext:timeout . timeout-error)
(sb-bsd-sockets:socket-error . ,#'map-socket-error)
;; Nameservice errors: mapped to unknown-error
#-ecl
#-(or ecl clasp)
(sb-bsd-sockets:no-recovery-error . ns-no-recovery-error)
#-ecl
#-(or ecl clasp)
(sb-bsd-sockets:try-again-error . ns-try-again-condition)
#-ecl
#-(or ecl clasp)
(sb-bsd-sockets:host-not-found-error . ns-host-not-found-error)))
(defun handle-condition (condition &optional (socket nil))
......@@ -264,7 +264,7 @@ happen. Use with care."
(sockopt-tcp-nodelay-p
(fboundp 'sb-bsd-sockets::sockopt-tcp-nodelay)))
(when deadline (unsupported 'deadline 'socket-connect))
#+ecl
#+(or ecl clasp)
(when timeout (unsupported 'timeout 'socket-connect))
(when (and nodelay-specified
;; 20080802: ECL added this function to its sockets
......@@ -286,7 +286,7 @@ happen. Use with care."
(socket (make-instance #+sbcl (if ipv6
'sb-bsd-sockets::inet6-socket
'sb-bsd-sockets:inet-socket)
#+ecl 'sb-bsd-sockets:inet-socket
#+(or ecl clasp) 'sb-bsd-sockets:inet-socket
:type protocol
:protocol (case protocol
(:stream :tcp)
......@@ -320,7 +320,7 @@ happen. Use with care."
(if timeout
(%with-timeout (timeout (error 'sb-ext:timeout)) (connect))
(connect)))
#+(or ecl (and sbcl win32))
#+(or ecl clasp (and sbcl win32))
(sb-bsd-sockets:socket-connect socket remote port)
;; Now that we're connected make the stream.
(setf (socket-stream usocket)
......@@ -375,11 +375,11 @@ happen. Use with care."
(ip #+sbcl (if (and local (not (eq host *wildcard-host*)))
local
(hbo-to-vector-quad sb-bsd-sockets-internal::inaddr-any))
#+ecl (host-to-vector-quad host))
#+(or ecl clasp) (host-to-vector-quad host))
(sock (make-instance #+sbcl (if ipv6
'sb-bsd-sockets::inet6-socket
'sb-bsd-sockets:inet-socket)
#+ecl 'sb-bsd-sockets:inet-socket
#+(or ecl clasp) 'sb-bsd-sockets:inet-socket
:type :stream
:protocol :tcp)))
(handler-case
......@@ -445,6 +445,15 @@ happen. Use with care."
"shutdown(#0, #1)" :one-liner t))
(error (map-errno-error (cerrno))))))
#+clasp
(defmethod socket-shutdown ((usocket stream-usocket) direction)
(let ((sock-fd (sb-bsd-sockets:socket-file-descriptor (socket usocket)))
(direction-flag (ecase direction
(:input 0)
(:output 1))))
(unless (zerop (sockets-internal:shutdown sock-fd direction-flag))
(error (map-errno-error (cerrno))))))
(defmethod socket-send ((usocket datagram-usocket) buffer size &key host port (offset 0))
(let ((remote (when host
(car (get-hosts-by-name (host-to-hostname host))))))
......@@ -751,7 +760,7 @@ happen. Use with care."
) ; progn
#+(and ecl (not win32))
#+(and (or ecl clasp) (not win32))
(progn
(defun wait-for-input-internal (wl &key timeout)
(with-mapped-conditions ()
......@@ -774,7 +783,7 @@ happen. Use with care."
(declare (ignore wl w)))
) ; progn
#+(and ecl win32 (not ecl-bytecmp))
#+(and (or ecl clasp) win32 (not ecl-bytecmp))
(progn
(defun maybe-wsa-error (rv &optional syscall)
(unless (zerop rv)
......
......@@ -52,7 +52,7 @@
(ccl:stream-input-timeout socket)
#+cmu
(lisp::fd-stream-timeout (socket-stream usocket))
#+ecl
#+(or ecl clasp)
(sb-bsd-sockets:sockopt-receive-timeout socket)
#+lispworks
(get-socket-receive-timeout socket)
......@@ -82,7 +82,7 @@
#+cmu
(setf (lisp::fd-stream-timeout (socket-stream usocket))
(coerce timeout 'integer))
#+ecl
#+(or ecl clasp)
(setf (sb-bsd-sockets:sockopt-receive-timeout socket) timeout)
#+lispworks
(set-socket-receive-timeout socket timeout)
......@@ -114,7 +114,7 @@
(ccl:stream-output-timeout socket)
#+cmu
(lisp::fd-stream-timeout (socket-stream usocket))
#+ecl
#+(or ecl clasp)
(sb-bsd-sockets:sockopt-send-timeout socket)
#+lispworks
(get-socket-send-timeout socket)
......@@ -144,7 +144,7 @@
#+cmu
(setf (lisp::fd-stream-timeout (socket-stream usocket))
(coerce timeout 'integer))
#+ecl
#+(or ecl clasp)
(setf (sb-bsd-sockets:sockopt-send-timeout socket) timeout)
#+lispworks
(set-socket-send-timeout socket timeout)
......@@ -182,7 +182,7 @@
() ; TODO
#+mocl
() ; unknown
#+(or ecl sbcl)
#+(or ecl sbcl clasp)
(sb-bsd-sockets:sockopt-reuse-address socket)
#+scl
())) ; TODO
......@@ -208,7 +208,7 @@
() ; TODO
#+mocl
() ; unknown
#+(or ecl sbcl)
#+(or ecl sbcl clasp)
(setf (sb-bsd-sockets:sockopt-reuse-address socket) new-value)
#+scl
() ; TODO
......@@ -231,7 +231,7 @@
(int->bool (get-socket-option-broadcast socket))
#+cmu
() ; TODO
#+ecl
#+(or ecl clasp)
() ; TODO
#+lispworks
() ; TODO
......@@ -259,7 +259,7 @@
(set-socket-option-broadcast socket (bool->int new-value))
#+cmu
() ; TODO
#+ecl
#+(or ecl clasp)
() ; TODO
#+lispworks
() ; TODO
......@@ -295,7 +295,7 @@
(int->bool (get-socket-option-tcp-nodelay socket))
#+cmu
()
#+ecl
#+(or ecl clasp)
(sb-bsd-sockets::sockopt-tcp-nodelay socket)
#+lispworks
(int->bool (get-socket-tcp-nodelay socket))
......@@ -328,7 +328,7 @@
(set-socket-option-tcp-nodelay socket (bool->int new-value))
#+cmu
()
#+ecl
#+(or ecl clasp)
(setf (sb-bsd-sockets::sockopt-tcp-nodelay socket) new-value)
#+lispworks
(progn
......
......@@ -33,7 +33,7 @@
:timeout timeout
:max-buffer-size max-buffer-size)))))
(if in-new-thread
(values (portable-threads:spawn-thread (or name "USOCKET Server") #'real-call) socket)
(values (bt:make-thread #'real-call :name (or name "USOCKET Server")) socket)
(progn
(setq *server* socket)
(real-call))))))
......@@ -101,7 +101,8 @@
`(,socket ,@(when element-type `(:element-type ,element-type)))))
(client-stream (socket-stream client-socket)))
(if multi-threading
(apply #'portable-threads:spawn-thread "USOCKET Client" real-function client-socket arguments)
(bt:make-thread (lambda () (apply real-function client-socket arguments))
:name "USOCKET Client")
(prog1 (apply real-function client-socket arguments)
(close client-stream)
(socket-close client-socket)))
......
......@@ -10,5 +10,5 @@
:version (:read-file-form "version.sexp")
:licence "MIT"
:description "Universal socket library for Common Lisp (server side)"
:depends-on (:usocket :portable-threads)
:depends-on (:usocket :bordeaux-threads)
:components ((:file "server")))
......@@ -37,8 +37,9 @@
(:file "openmcl")
#+clozure (:file "clozure" :depends-on ("openmcl"))
#+cmu (:file "cmucl")
#+(or sbcl ecl) (:file "sbcl")
#+(or sbcl ecl clasp) (:file "sbcl")
#+ecl (:file "ecl" :depends-on ("sbcl"))
#+clasp (:file "clasp" :depends-on ("sbcl"))
#+lispworks (:file "lispworks")
#+mcl (:file "mcl")
#+mocl (:file "mocl")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment