cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

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:
Mconcurrency.lisp | 9++++++---
Mdemo-zappel.lisp | 16+++++++++++++++-
Mos.lisp | 16++++++++--------
Msocket.lisp | 31+++++++++++++++++++++++--------
Mstring.lisp | 8++++++--
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))