commit ba99919d4db33b4eca1d91e047308b4063788eb7
parent c903f730270fb685368df4281738320bc1b7b7e9
Author: Tomas Hlavaty <tom@logand.com>
Date: Sat, 3 Oct 2015 11:49:17 +0200
try cmucl port
but still rather broken
Diffstat:
5 files changed, 58 insertions(+), 22 deletions(-)
diff --git a/concurrency.lisp b/concurrency.lisp
@@ -34,21 +34,23 @@
(in-package :rw.concurrency)
(defmacro with-lock ((lock) &body body)
- #-(or allegro ccl ecl mkcl sbcl)
+ #-(or allegro ccl ecl mkcl cmucl sbcl)
(error "RW.CONCURRENCY:WITH-LOCK not ported")
#+allegro `(mp:with-process-lock (,lock) ,@body)
#+ccl `(ccl:with-lock-grabbed (,lock) ,@body)
#+ecl `(mp:with-lock (,lock) ,@body)
#+mkcl `(mt:with-lock (,lock) ,@body)
+ #+cmucl `(mp:with-lock-held (,lock) ,@body)
#+sbcl `(sb-concurrency::with-mutex (,lock) ,@body))
(defun make-lock (name)
- #-(or allegro ccl ecl mkcl sbcl)
+ #-(or allegro ccl ecl mkcl cmucl sbcl)
(error "RW.CONCURRENCY:MAKE-LOCK not ported")
#+allegro (mp:make-process-lock :name name)
#+ccl (ccl:make-lock name)
#+ecl (mp:make-lock :name name)
#+mkcl (mt:make-lock :name name)
+ #+cmucl (mp:make-lock name :kind :error-check)
#+sbcl (sb-concurrency::make-mutex :name (string name)))
(defun make-semaphore ()
@@ -107,12 +109,13 @@
;; (funcall q)
(defun make-thread (name fn)
- #-(or allegro ccl ecl mkcl sbcl)
+ #-(or allegro ccl ecl mkcl cmucl sbcl)
(error "RW.CONCURRENCY:MAKE-THREAD not ported")
#+allegro (mp:process-run-function name fn)
#+ccl (ccl:process-run-function name fn)
#+ecl (mp:process-run-function name fn)
#+mkcl (mt:thread-run-function name fn)
+ #+cmucl (mp:make-process fn :name name)
#+sbcl (sb-concurrency::make-thread fn :name (string name)))
(defun make-program-server (command args writer reader)
diff --git a/demo-zappel.lisp b/demo-zappel.lisp
@@ -193,7 +193,7 @@
;;(start)
(defun save-image ()
- #-(or ccl sbcl)
+ #-(or ccl cmucl sbcl)
(error "TODO RW.DEMO.ZAPPEL::SAVE-IMAGE")
#+ccl ;; TODO no debug on ^C
(ccl:save-application "cl-rw-demo-zappel"
@@ -206,6 +206,20 @@
(loop (sleep 1)))
(condition ()
(ccl:quit 1)))))
+ #+cmu
+ (ext:save-lisp "cl-rw-demo-zappel"
+ :executable t
+ :batch-mode t
+ :print-herald nil
+ :process-command-line nil
+ :load-init-file nil
+ :init-function (lambda ()
+ (handler-case
+ (progn
+ (start)
+ (loop (sleep 1)))
+ (condition ()
+ (ext:quit)))))
#+sbcl
(sb-ext:save-lisp-and-die "cl-rw-demo-zappel"
:executable t
diff --git a/os.lisp b/os.lisp
@@ -42,7 +42,7 @@
(when error-plist
(or (cdr (assoc code error-plist)) ""))
args)))))
- #-(or allegro ccl ecl mkcl sbcl cmu clisp)
+ #-(or allegro ccl ecl mkcl sbcl cmucl clisp)
(error "RW.OS:MAKE-PROGRAM not ported")
#+allegro
(multiple-value-bind (stream b p)
@@ -158,24 +158,24 @@
(sb-ext:process-output p)))
(:wait (sb-ext:process-wait p))
(:close (sb-ext:process-close p)))))
- #+cmu
+ #+cmucl
(let ((p (ext:run-program cmd
args
:input input
:output output
:error nil
:wait nil)))
- (let ((status (sb-ext:process-status p)))
+ (let ((status (ext:process-status p)))
(if input
(assert (eq :running status))
(assert (member status '(:running :exited)))))
(lambda (msg)
(ecase msg
- (:fail (fail (nth-value 2 (sb-ext:process-status p))))
- (:status-and-code (sb-ext:process-status p))
- (:streams (values (sb-ext:process-input p)
- (sb-ext:process-output p)))
- (:wait (sb-ext:process-wait p))
+ (:fail (fail (nth-value 2 (ext:process-status p))))
+ (:status-and-code (ext:process-status p))
+ (:streams (values (ext:process-input p)
+ (ext:process-output p)))
+ (:wait (ext:process-wait p))
(:close (ext:process-close p)))))
#+clisp ;; TODO how to binary io? how to get exit code?
(cond
diff --git a/socket.lisp b/socket.lisp
@@ -43,9 +43,9 @@
(defstruct (ipv6-address (:constructor %make-ipv6-address)) native string)
(defun next-ipv4-address (r)
- (#-(or allegro ccl)
+ (#-(or allegro ccl cmucl)
ipv4-integer-to-vector
- #+(or allegro ccl)
+ #+(or allegro ccl cmucl)
progn
(flet ((one ()
(cond
@@ -142,9 +142,9 @@
;;(make-ipv4-address 0)
(defun next-ipv6-address (r)
- (#-(or allegro ccl)
+ (#-(or allegro ccl cmucl)
ipv6-integer-to-vector
- #+(or allegro ccl)
+ #+(or allegro ccl cmucl)
progn
(flet ((chain (n)
(loop
@@ -258,11 +258,13 @@
(ipv6-address (ipv6-address-native x)))))
(defun close-socket (socket)
- #-(or allegro ccl ecl mkcl sbcl)
+ #-(or allegro ccl ecl mkcl cmucl sbcl)
(error "RW.SOCKET::CLOSE-SOCKET not ported")
;; clisp socket:socket-server-close?
#+(or allegro ccl)
(close socket)
+ #+cmucl
+ (ext:close-socket socket)
#+(or ecl sbcl mkcl)
(sb-bsd-sockets:socket-close socket))
@@ -274,7 +276,7 @@
`(call-with-socket ,socket (lambda (,var) ,@body)))
(defun make-tcp-server-socket (local-host local-port &key backlog)
- #-(or allegro clisp sbcl ecl mkcl ccl)
+ #-(or allegro clisp sbcl ecl mkcl cmucl ccl)
(error "RW.SOCKET:MAKE-TCP-SERVER-SOCKET not ported")
#+allegro
(socket:make-socket :connect :passive
@@ -298,6 +300,9 @@
local-port)
(sb-bsd-sockets:socket-listen x (or backlog 5))
x)
+ #+cmucl
+ (ext:create-inet-listener local-port :stream
+ :host (ipv4-address-native local-host))
#+ccl
(ccl:make-socket :connect :passive
:address-family :internet
@@ -308,7 +313,7 @@
:reuse-address t))
(defun make-tcp-client-socket (remote-host remote-port)
- #-(or allegro clisp sbcl ecl mkcl ccl)
+ #-(or allegro clisp sbcl ecl mkcl cmucl ccl)
(error "RW.SOCKET:MAKE-TCP-CLIENT-SOCKET not ported")
#+allegro
(socket:make-socket :connect :active
@@ -330,6 +335,9 @@
remote-port)
(sb-bsd-sockets:socket-make-stream x :input t :output t ;;:buffering :none
:element-type :default))
+ #+cmucl
+ (let ((x (ext:connect-to-inet-socket remote-host remote-port)))
+ (sys:make-fd-stream x :input x :output x :element-type '(unsigned-byte 8)))
#+ccl
(ccl:make-socket :connect :active
:address-family :internet
@@ -381,7 +389,7 @@
;; fd
(defun accept (socket)
- #-(or allegro clisp sbcl ecl mkcl ccl)
+ #-(or allegro clisp sbcl ecl mkcl cmucl ccl)
(error "RW.SOCKET:ACCEPT not ported")
#+allegro
(socket:accept-connection socket)
@@ -392,6 +400,13 @@
:input t
:output t
:auto-close t)
+ #+cmucl
+ (ext:accept-network-stream socket)
+ #+nil
+ (let ((x (ext:accept-tcp-connection socket)))
+ (ext:accept-network-stream socket)
+ #+nil
+ (sys:make-fd-stream x :input x :output x:element-type '(unsigned-byte 8)))
#+ccl
(ccl:accept-connection socket))
diff --git a/string.lisp b/string.lisp
@@ -28,7 +28,7 @@
(in-package :rw.string)
(defun octets-to-string (x encoding)
- #-(or mkcl allegro clisp ecl ccl sbcl allegro)
+ #-(or mkcl allegro clisp ecl ccl sbcl cmucl allegro)
(error "RW.STRING:OCTETS-TO-STRING not ported")
#+mkcl
(progn
@@ -44,11 +44,13 @@
(ccl:decode-string-from-octets x :external-format encoding)
#+sbcl
(sb-ext:octets-to-string x :external-format encoding)
+ #+cmucl
+ (ext:octets-to-string x :external-format encoding)
#+allegro
(excl:octets-to-string x :external-format encoding))
(defun string-to-octets (x encoding)
- #-(or mkcl allegro clisp ecl ccl sbcl allegro)
+ #-(or mkcl allegro clisp ecl ccl sbcl cmucl allegro)
(error "RW.STRING:STRING-TO-OCTETS not ported")
#+mkcl
(progn
@@ -70,5 +72,7 @@
(ccl:encode-string-to-octets x :external-format encoding)
#+sbcl
(sb-ext:string-to-octets x :external-format encoding)
+ #+cmucl
+ (ext:string-to-octets x :external-format encoding)
#+allegro
(excl:string-to-octets x :external-format encoding :null-terminate nil))
