commit a3e43a0cb255ac3e759564ef8fe905d2c53472c6
parent e544123acf6db8554e1af06df0b133ea70faa9b3
Author: Tomas Hlavaty <tom@logand.com>
Date: Sat, 11 Apr 2015 11:32:03 +0200
partial allegro port
Diffstat:
3 files changed, 84 insertions(+), 39 deletions(-)
diff --git a/concurrency.lisp b/concurrency.lisp
@@ -34,35 +34,44 @@
(in-package :rw.concurrency)
(defmacro with-lock ((lock) &body body)
- #-(or ccl ecl mkcl sbcl) (error "RW.CONCURRENCY:WITH-LOCK not ported")
+ #-(or allegro ccl ecl mkcl 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)
#+sbcl `(sb-concurrency::with-mutex (,lock) ,@body))
(defun make-lock (name)
- #-(or ccl ecl mkcl sbcl) (error "RW.CONCURRENCY:MAKE-LOCK not ported")
+ #-(or allegro ccl ecl mkcl 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)
#+sbcl (sb-concurrency::make-mutex :name (string name)))
(defun make-semaphore ()
- #-(or ccl ecl mkcl sbcl) (error "RW.CONCURRENCY:MAKE-SEMAPHORE not ported")
+ #-(or allegro ccl ecl mkcl sbcl)
+ (error "RW.CONCURRENCY:MAKE-SEMAPHORE not ported")
+ #+allegro (mp:make-gate nil)
#+ccl (ccl:make-semaphore)
#+ecl (mp:make-semaphore)
#+mkcl (mt:make-semaphore)
#+sbcl (sb-concurrency::make-semaphore))
(defun signal-semaphore (x)
- #-(or ccl ecl mkcl sbcl) (error "RW.CONCURRENCY:SIGNAL-SEMAPHORE not ported")
+ #-(or allegro ccl ecl mkcl sbcl)
+ (error "RW.CONCURRENCY:SIGNAL-SEMAPHORE not ported")
+ #+allegro (mp:put-semaphore x)
#+ccl (ccl:signal-semaphore x)
#+ecl (mp:signal-semaphore x)
#+mkcl (mt:semaphore-signal x)
#+sbcl (sb-concurrency::signal-semaphore x))
(defun wait-on-semaphore (x)
- #-(or ccl ecl mkcl sbcl) (error "RW.CONCURRENCY:WAIT-ON-SEMAPHORE not ported")
+ #-(or ccl ecl mkcl sbcl)
+ (error "RW.CONCURRENCY:WAIT-ON-SEMAPHORE not ported")
#+ccl (ccl:wait-on-semaphore x)
#+ecl (mp:wait-on-semaphore x)
#+mkcl (mt:semaphore-wait x)
@@ -98,7 +107,9 @@
;; (funcall q)
(defun make-thread (name fn)
- #-(or ccl ecl mkcl sbcl) (error "RW.CONCURRENCY:MAKE-THREAD not ported")
+ #-(or allegro ccl ecl mkcl 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)
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)
- (#-ccl
+ (#-(or allegro ccl)
ipv4-integer-to-vector
- #+ccl
+ #+(or allegro ccl)
progn
(flet ((one ()
(cond
@@ -126,14 +126,14 @@
(string (%make-ipv4-address :native (parse-ipv4-address x) :string x))
(integer
(%make-ipv4-address :native
- #-ccl (ipv4-integer-to-vector x)
- #+ccl x
+ #-(or allegro ccl) (ipv4-integer-to-vector x)
+ #+(or allegro ccl) x
:string (ipv4-integer-to-dotted x)))
(vector
(assert (= 4 (length x)))
(%make-ipv4-address :native
- #-ccl x
- #+ccl (ipv4-vector-to-integer x)
+ #-(or allegro ccl) x
+ #+(or allegro ccl) (ipv4-vector-to-integer x)
:string (ipv4-vector-to-dotted x)))))
;;(make-ipv4-address "127.0.0.1")
@@ -142,9 +142,9 @@
;;(make-ipv4-address 0)
(defun next-ipv6-address (r)
- (#-ccl
+ (#-(or allegro ccl)
ipv6-integer-to-vector
- #+ccl
+ #+(or allegro ccl)
progn
(flet ((chain (n)
(loop
@@ -235,14 +235,14 @@
(string (%make-ipv6-address :native (parse-ipv6-address x) :string x))
(integer
(%make-ipv6-address :native
- #-ccl (ipv6-integer-to-vector x)
- #+ccl x
+ #-(or allegro ccl) (ipv6-integer-to-vector x)
+ #+(or allegro ccl) x
:string (ipv6-integer-to-string x)))
(vector
(assert (= 8 (length x)))
(%make-ipv6-address :native
- #-ccl x
- #+ccl (ipv6-vector-to-integer x)
+ #-(or allegro ccl) x
+ #+(or allegro ccl) (ipv6-vector-to-integer x)
:string (ipv6-vector-to-string x)))))
;;(make-ipv6-address "f:e:d:c:b:a:9:8")
@@ -258,10 +258,10 @@
(ipv6-address (ipv6-address-native x)))))
(defun close-socket (socket)
- #-(or ccl ecl mkcl sbcl)
- (error "TODO port RW.SOCKET::CLOSE-SOCKET")
+ #-(or allegro ccl ecl mkcl sbcl)
+ (error "RW.SOCKET::CLOSE-SOCKET not ported")
;; clisp socket:socket-server-close?
- #+ccl
+ #+(or allegro ccl)
(close socket)
#+(or ecl sbcl mkcl)
(sb-bsd-sockets:socket-close socket))
@@ -274,8 +274,16 @@
`(call-with-socket ,socket (lambda (,var) ,@body)))
(defun make-tcp-server-socket (local-host local-port &key backlog)
- #-(or clisp sbcl ecl mkcl ccl)
- (error "TODO port RW.SOCKET:MAKE-TCP-SERVER-SOCKET")
+ #-(or allegro clisp sbcl ecl mkcl ccl)
+ (error "RW.SOCKET:MAKE-TCP-SERVER-SOCKET not ported")
+ #+allegro
+ (socket:make-socket :connect :passive
+ :address-family :internet
+ :type :stream
+ :format :bivalent ;; TODO :binary
+ :local-host (native-ip-address local-host)
+ :local-port local-port
+ :reuse-address t)
#+clisp
(socket:socket-server local-port :interface local-host :backlog backlog)
#+(or sbcl ecl mkcl)
@@ -300,8 +308,15 @@
:reuse-address t))
(defun make-tcp-client-socket (remote-host remote-port)
- #-(or clisp sbcl ecl mkcl ccl)
- (error "TODO port RW.SOCKET:MAKE-TCP-CLIENT-SOCKET")
+ #-(or allegro clisp sbcl ecl mkcl ccl)
+ (error "RW.SOCKET:MAKE-TCP-CLIENT-SOCKET not ported")
+ #+allegro
+ (socket:make-socket :connect :active
+ :address-family :internet
+ :type :stream
+ :format :bivalent ;; TODO :binary
+ :remote-host (native-ip-address remote-host)
+ :remote-port remote-port)
#+clisp
(socket:socket-connect remote-port remote-host)
#+(or sbcl ecl mkcl)
@@ -324,8 +339,15 @@
:remote-port remote-port))
(defun make-udp-socket (&key local-host local-port remote-host remote-port)
- #-(or ccl ecl mkcl sbcl)
- (error "TODO port RW.SOCKET:MAKE-PASSIVE-UDP-SOCKET")
+ #-(or allegro ccl ecl mkcl sbcl)
+ (error "RW.SOCKET:MAKE-PASSIVE-UDP-SOCKET not ported")
+ #+allegro
+ (socket:make-socket :address-family :internet
+ :type :datagram
+ :local-host (native-ip-address local-host)
+ :local-port local-port
+ :remote-host (native-ip-address remote-host)
+ :remote-port remote-port)
;; #+clisp ;; rawsock not present by default
;; (rawsock:socket :inet :dgram 0)
#+ccl
@@ -359,8 +381,10 @@
;; fd
(defun accept (socket)
- #-(or clisp sbcl ecl mkcl ccl)
- (error "TODO port RW.SOCKET:ACCEPT")
+ #-(or allegro clisp sbcl ecl mkcl ccl)
+ (error "RW.SOCKET:ACCEPT not ported")
+ #+allegro
+ (socket:accept-connection socket)
#+clisp
(socket:socket-accept socket)
#+(or sbcl ecl mkcl)
@@ -372,8 +396,12 @@
(ccl:accept-connection socket))
(defun udp-send (socket buf len &key remote-host remote-port)
- #-(or ccl ecl mkcl sbcl)
- (error "TODO port RW.SOCKET:UDP-SEND")
+ #-(or allegro ccl ecl mkcl sbcl)
+ (error "RW.SOCKET:UDP-SEND not ported")
+ #+allegro
+ (socket:send-to socket buf len
+ :remote-host (native-ip-address remote-host)
+ :remote-port remote-port)
#+ccl
(ccl:send-to socket buf len
:remote-host (native-ip-address remote-host)
@@ -384,8 +412,10 @@
remote-port)))
(defun udp-receive (socket buf len)
- #-(or ccl ecl mkcl sbcl)
- (error "TODO port RW.SOCKET:UDP-RECEIVE")
+ #-(or allegro ccl ecl mkcl sbcl)
+ (error "RW.SOCKET:UDP-RECEIVE not ported")
+ #+allegro
+ (socket:receive-from socket len :buffer buf)
#+ccl
(ccl:receive-from socket len :buffer buf)
#+(or ecl mkcl sbcl)
diff --git a/string.lisp b/string.lisp
@@ -28,8 +28,8 @@
(in-package :rw.string)
(defun octets-to-string (x encoding)
- #-(or clisp ecl ccl sbcl)
- (error "TODO port RW.STRING:OCTETS-TO-STRING")
+ #-(or allegro clisp ecl ccl sbcl allegro)
+ (error "RW.STRING:OCTETS-TO-STRING not ported")
#+clisp
(ext:convert-string-from-bytes
x (intern (string encoding) (find-package :charset)))
@@ -39,11 +39,13 @@
#+ccl
(ccl:decode-string-from-octets x :external-format encoding)
#+sbcl
- (sb-ext:octets-to-string x :external-format encoding))
+ (sb-ext:octets-to-string x :external-format encoding)
+ #+allegro
+ (excl:octets-to-string x :external-format encoding))
(defun string-to-octets (x encoding)
- #-(or clisp ecl ccl sbcl)
- (error "TODO port RW.STRING:STRING-TO-OCTETS")
+ #-(or allegro clisp ecl ccl sbcl allegro)
+ (error "RW.STRING:STRING-TO-OCTETS not ported")
#+clisp
(ext:convert-string-to-bytes
x (intern (string encoding) (find-package :charset)))
@@ -59,4 +61,6 @@
#+ccl
(ccl:encode-string-to-octets x :external-format encoding)
#+sbcl
- (sb-ext:string-to-octets x :external-format encoding))
+ (sb-ext:string-to-octets x :external-format encoding)
+ #+allegro
+ (excl:string-to-octets x :external-format encoding))
