Add lispworks support.

buffer.lisp

@@ -116,8 +116,7 @@
 
 (defmethod get-octet-vector ((cb chunk-buffer))
   (let* ((size (buffer-size cb))
-         (vector (make-array size :element-type '(unsigned-byte 8)
-                                  :initial-element 0))
+         (vector (make-array-ubyte8 size :initial-element 0))
          (chunks (%get-chunks cb)))
     (loop for c in chunks
           for offset = 0 then (+ offset size)
@@ -141,9 +140,7 @@
   ;;  (or maybe just implement our own converter since we only need utf8?))
   (let* ((size (buffer-size cb))
          (end (or octet-end size))
-         (vector (make-array end
-                             :element-type '(unsigned-byte 8)
-                             :initial-element 0))
+         (vector (make-array-ubyte8 end :initial-element 0))
          (chunks (%get-chunks cb)))
     (loop for c in chunks
           for offset = 0 then (+ offset size)
@@ -181,12 +178,12 @@
 #++
 (flet ((test-buf ()
          (let ((foo (make-instance 'chunk-buffer))
-               (buf (babel:string-to-octets "_<continued-test>_")))
-           (add-chunk foo (babel:string-to-octets "TEST" ) 0 4)
-           (add-chunk foo (babel:string-to-octets "test2") 0 5)
+               (buf (string-to-shareable-octets "_<continued-test>_")))
+           (add-chunk foo (string-to-shareable-octets "TEST" ) 0 4)
+           (add-chunk foo (string-to-shareable-octets "test2") 0 5)
            (add-chunk foo buf 1 5)
            (add-chunk foo buf 5 (1- (length buf)))
-           (add-chunk foo (babel:string-to-octets "..test3") 2 7)
+           (add-chunk foo (string-to-shareable-octets "..test3") 2 7)
            foo)))
   (list
    (with-buffer-as-stream ((test-buf) s)
@@ -271,7 +268,7 @@
                                   (> (partial-vector-pos buffer)
                                      (- (length (partial-vector buffer)) 16)))
                           (setf (partial-vector buffer)
-                                (make-array 2048 :element-type '(unsigned-byte 8))
+                                (make-array-ubyte8 2048)
                                 (partial-vector-pos buffer) 0))
                         (multiple-value-bind (_octets count)
                             ;; fixme: decide on good max read chunk size

client.lisp

@@ -269,11 +269,10 @@ be sent to the client."
 as a WebSockets frame."
   (concatenate '(vector (unsigned-byte 8))
                '(0)
-               (babel:string-to-octets string :encoding :utf-8)
+               (string-to-shareable-octets string :encoding :utf-8)
                '(#xff)))
 
-(defparameter *close-frame* (make-array 2 :element-type '(unsigned-byte 8)
-                                          :initial-contents '(#xff #x00)))
+(defparameter *close-frame* (make-array-ubyte8 2 :initial-contents '(#xff #x00)))
 
 
 (defun %write-to-client (client octets-or-keyword)
@@ -324,7 +323,7 @@ frames once."
                         do (push c (gethash (%client-server-hook c) h nil))
                         finally (return h)))
            (utf8 (if (stringp message)
-                     (babel:string-to-octets message :encoding :utf-8)
+                     (string-to-shareable-octets message :encoding :utf-8)
                      message)))
       ;; possibly should reorder this stuff, so server thread can start
       ;; sending data while we are building frames for other protocols, or
@@ -405,11 +404,9 @@ non-blocking fashion."
                 (when (eql (client-write-buffer client) :close)
                   (client-disconnect client :close t)
                   (return-from try-write-client nil))
-
                 (when (eql (client-write-buffer client) :enable-read)
                   (client-enable-handler client :read t)
                   (setf (client-write-buffer client) nil))
-
                 (when (client-write-buffer client)
                   (let ((count (send-to (client-socket client)
                                         (client-write-buffer client)

concurrency-chanl.lisp

@@ -33,7 +33,7 @@ and secondary value."
 #+sbcl
 (defstruct atomic-place
   (val 0 :type (unsigned-byte #+x86-64 64 #+x86 32)))
-#+ccl
+#+(or ccl lispworks)
 (defun make-atomic-place (&key val)
   val)
 
@@ -54,34 +54,37 @@ and secondary value."
 
 (defun mailbox-send-message (mailbox message)
   "Adds a MESSAGE to MAILBOX. Message can be any object."
-   #- (or ccl sbcl)
+  #- (or ccl sbcl lispworks)
   (error "not implemented")
   (progn
-      #+ccl (ccl::atomic-incf (car mailbox))
-      #+sbcl (sb-ext:atomic-incf (atomic-place-val (car mailbox)))
+    #+ccl (ccl::atomic-incf (car mailbox))
+    #+sbcl (sb-ext:atomic-incf (atomic-place-val (car mailbox)))
+    #+lispworks (system:atomic-incf (car mailbox))
     (chanl:send (cdr mailbox) message)))
 
 (defun mailbox-receive-message (mailbox &key)
   "Removes the oldest message from MAILBOX and returns it as the
 primary value. If MAILBOX is empty waits until a message arrives."
-  #- (or ccl sbcl)
+  #- (or ccl sbcl lispworks)
   (error "not implemented")
   (prog1
       (chanl:recv (cdr mailbox))
     #+sbcl (sb-ext:atomic-decf (atomic-place-val (car mailbox)))
-    #+ccl(ccl::atomic-decf (car mailbox))))
+    #+ccl (ccl::atomic-decf (car mailbox))
+    #+lispworks (system:atomic-decf (car mailbox))))
 
 (defun mailbox-receive-message-no-hang (mailbox)
   "The non-blocking variant of RECEIVE-MESSAGE. Returns two values,
 the message removed from MAILBOX, and a flag specifying whether a
 message could be received."
-  #- (or ccl sbcl)
+  #- (or ccl sbcl lispworks)
   (error "not implemented")
   (multiple-value-bind (message found)
       (chanl:recv (cdr mailbox) :blockp nil)
     (when found
       #+sbcl (sb-ext:atomic-decf (atomic-place-val (car mailbox)))
-      #+ccl(ccl::atomic-decf (car mailbox)))
+      #+ccl (ccl::atomic-decf (car mailbox))
+      #+lispworks (system:atomic-decf (car mailbox)))
     (values message found)))
 
 (defun mailbox-count (mailbox)

concurrency-sbcl.lisp

@@ -26,7 +26,7 @@ and secondary value."
 ;;;;  Thread safe queue with ability to do blocking reads
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun make-mailbox (&key name initial-contents)
-  "Returns a new MAILBOX with messages in INITIAL-CONTENTS enqueued."  
+  "Returns a new MAILBOX with messages in INITIAL-CONTENTS enqueued."
   #+sbcl
   (sb-concurrency:make-mailbox :name name :initial-contents initial-contents))
 

config.lisp

@@ -45,18 +45,18 @@ to be buffered indefinitely though, so be careful with large settings.")
   "set to T to enter debugger on resource-handler errors, NIL to drop the connections and try to send a disconnect to handler.")
 
 
-(defvar *400-message* (babel:string-to-octets
+(defvar *400-message* (string-to-shareable-octets
                              "HTTP/1.1 400 Bad Request
 
 "
                              :encoding :utf-8))
 
-(defvar *403-message* (babel:string-to-octets
+(defvar *403-message* (string-to-shareable-octets
                              "HTTP/1.1 403 Forbidden
 
 "
                              :encoding :utf-8))
-(defvar *404-message* (babel:string-to-octets
+(defvar *404-message* (string-to-shareable-octets
                              "HTTP/1.1 404 Resource not found
 
 "

protocol-00.lisp

@@ -6,14 +6,13 @@
 ;;; used by firefox4/5, chrome6-13?, safari 5.0.1, opera 11
 ;;; (firefox and opera disabled by default)
 (defparameter *draft-76/00-close-frame*
-  (make-array 2 :element-type '(unsigned-byte 8)
-                :initial-contents '(#xff #x00)))
+  (make-array-ubyte8 2 :initial-contents '(#xff #x00)))
 
 #++
 (defparameter *allow-draft-75* t)
 #++
 (defun make-handshake-75 (origin location protocol)
-  (babel:string-to-octets
+  (string-to-shareable-octets
    (format nil "HTTP/1.1 101 Web Socket Protocol Handshake
 Upgrade: WebSocket
 Connection: Upgrade
@@ -28,7 +27,7 @@ WebSocket-Protocol: ~a
    :encoding :utf-8))
 
 (defun make-handshake-76 (origin location protocol)
-  (babel:string-to-octets
+  (string-to-shareable-octets
    (format nil "HTTP/1.1 101 Web Socket Protocol Handshake
 Upgrade: WebSocket
 Connection: Upgrade
@@ -67,7 +66,7 @@ client."
 ;; (extract-key "17  9 G`ZD9   2 2b 7X 3 /r90") -> 179922739
 
 (defun make-challenge-00 (k1 k2 k3)
-  (let ((b (make-array 16 :element-type '(unsigned-byte 8))))
+  (let ((b (make-array-ubyte8 16)))
     (loop for i from 0 below 4
        for j from 24 downto 0 by 8
        do (setf (aref b i) (ldb (byte 8 j) k1))

protocol-7.lisp

@@ -68,7 +68,7 @@ Test this with the example provided in the above document:
                                                (make-mailbox))
                 (client-resource client) resource)
           (%write-to-client client
-                            (babel:string-to-octets
+                            (string-to-shareable-octets
                              ;; todo: Sec-WebSocket-Protocol, Sec-WebSocket-Extension
                              (format nil "HTTP/1.1 101 Switching Protocols
 Upgrade: websocket
@@ -215,8 +215,7 @@ Sec-WebSocket-Accept: ~a
    (octet-count-matcher 4)
    (lambda (client)
      (with-buffer-as-stream (client s)
-       (let ((mask (make-array 4 :element-type '(unsigned-byte 8)
-                                 :initial-element 0)))
+       (let ((mask (make-array-ubyte8 4 :initial-element 0)))
          (loop for i below 4
                do (setf (aref mask i) (read-byte s)))
          (protocol-7+-read-frame client length mask))))))
@@ -304,4 +303,5 @@ Sec-WebSocket-Accept: ~a
 
 (push 7 *supported-protocol-versions*)
 (push 8 *supported-protocol-versions*)
-(push 13 *supported-protocol-versions*)
+(push 13 *supported-protocol-versions*)
+

protocol.lisp

@@ -63,7 +63,7 @@
   ;; when we get one we don't recognize, so do that then close the connection
   (client-enqueue-write
    client
-   (babel:string-to-octets
+   (string-to-shareable-octets
     (format nil "HTTP/1.1 400 Bad Request
 Sec-WebSocket-Version: ~{~s~^, ~}
 
@@ -139,7 +139,7 @@ Sec-WebSocket-Version: ~{~s~^, ~}
 ;;; flash 'policy file' to connect
 (defparameter *policy-file-request*
   (concatenate '(vector (unsigned-byte 8))
-               (babel:string-to-octets "<policy-file-request/>")
+               (string-to-shareable-octets "<policy-file-request/>")
                #(0)))
 
 (defun match-policy-file (buffer)
@@ -218,7 +218,7 @@ Sec-WebSocket-Version: ~{~s~^, ~}
   ;; not sure what 'protocol' should be for now... assuming protocol
   ;; version numbers (as integers) for now, with hixie-76/ietf-00 as 0
   (let ((utf8 (when message
-                (babel:string-to-octets message :encoding :utf-8)))
+                (string-to-shareable-octets message :encoding :utf-8)))
         (code (if (and (integerp code) (<= 0 code 65535)
                        ;; MUST NOT send 1005 or 1006
                        (/= code 1005)
@@ -266,9 +266,8 @@ Sec-WebSocket-Version: ~{~s~^, ~}
         for frame-octets = (min octets-left frame-size)
         for length-octets = (if (< frame-octets 126)
                                 0 (if (< frame-octets 65536) 2 8))
-        collect (let ((a (make-array (+ 2 length-octets frame-octets)
-                                     :element-type '(unsigned-byte 8)
-                                     :initial-element 0)))
+     collect (let ((a (make-array-ubyte8 (+ 2 length-octets frame-octets)
+                                         :initial-element 0)))
                   (setf (aref a 0) (logior fin op))
                   (cond
                     ((< frame-octets 126)
@@ -298,7 +297,7 @@ Sec-WebSocket-Version: ~{~s~^, ~}
 
 (defun text-message-for-protocol (protocol message &key frame-size)
   (let* ((utf8 (if (stringp message)
-                   (babel:string-to-octets message :encoding :utf-8)
+                   (string-to-shareable-octets message :encoding :utf-8)
                    message))
          (frame-size (or frame-size (1+ (length utf8)))))
     (case protocol

server.lisp

@@ -1,10 +1,10 @@
 (in-package #:ws)
 
-(defparameter *server-busy-message* (babel:string-to-octets
-                             "HTTP/1.1 503 service unavailable
+(defparameter *server-busy-message* (string-to-shareable-octets
+                                     "HTTP/1.1 503 service unavailable
 
 "
-                             :encoding :utf-8))
+                                     :encoding :utf-8))
 
 (defclass server ()
   ((event-base :initform nil :accessor server-event-base :initarg :event-base)
@@ -73,11 +73,9 @@ are thread-safe.
   (let* ((event-base (make-instance 'iolib:event-base))
          (server (make-instance 'server
                                 :event-base event-base))
-         (temp (make-array 16 :element-type '(unsigned-byte 8)))
+         (temp (make-array-ubyte8 16))
          (control-mailbox (make-queue :name "server-control"))
-         (wake-up (make-array 1 :element-type '(unsigned-byte 8)
-                              :initial-element 0)))
-
+         (wake-up (make-array-ubyte8 1 :initial-element 0)))
     ;; To be clear, there are three sockets used for a server.  The
     ;; main one is the WebSockets server (socket).  There is also a
     ;; pair of connected sockets (control-socket-1 control-socket-2)
@@ -90,8 +88,10 @@ are thread-safe.
                ;; some code, for things like enabling writers when
                ;; there is new data to write
                (enqueue thunk control-mailbox)
-               (ignore-errors
-                 (iolib:send-to control-socket-2 wake-up))))
+               (if *debug-on-server-errors*
+                   (iolib:send-to control-socket-2 wake-up)
+                   (ignore-errors
+                     (iolib:send-to control-socket-2 wake-up)))))
         (unwind-protect
              (iolib:with-open-socket (socket :connect :passive
                                              :address-family :internet

test.lisp

@@ -11,7 +11,7 @@
 
 (defun handshake (resource)
    (let ((crlf (format nil "~c~c" (code-char 13) (code-char 10))))
-     (babel:string-to-octets
+     (string-to-shareable-octets
       (print (format nil "GET ~a HTTP/1.1~a~
 Upgrade: WebSocket~a~
 Connection: Upgrade~a~
@@ -29,7 +29,7 @@ WebSocket-Protocol: ~a~a~
 
 (defun handshake-76 (resource)
    (let ((crlf (format nil "~c~c" (code-char 13) (code-char 10))))
-     (babel:string-to-octets
+     (string-to-shareable-octets
       (print (format nil "GET ~a HTTP/1.1~a~
 Upgrade: WebSocket~a~
 Connection: Upgrade~a~
@@ -227,4 +227,4 @@ WjN}|M(6"
      :name (format nil "thread ~s" i1))))
 
 
-
+

util.lisp

@@ -1,12 +1,29 @@
 (in-package #:ws)
 
+(defun string-to-shareable-octets (string &key (encoding babel:*default-character-encoding*)
+                                            (start 0) end (use-bom :default)
+                                            (errorp (not babel::*suppress-character-coding-errors*)))
+  #+lispworks
+  (sys:in-static-area
+    (babel:string-to-octets string :encoding encoding
+                            :start start
+                            :end end
+                            :use-bom use-bom
+                            :errorp errorp))
+  #-lispworks
+  (babel:string-to-octets string :encoding encoding
+                          :start start
+                          :end end
+                          :use-bom use-bom
+                          :errorp errorp))
+
 (defun make-domain-policy (&key (from "*") (to-port "*"))
   "Generates a very basic cross-domain policy file, used for the
 WebSocket emulation via Flash.
 
 For more information on what that is, see
 http://www.adobe.com/devnet/articles/crossdomain_policy_file_spec.html"
-  (babel:string-to-octets
+  (string-to-shareable-octets
    (format nil "<?xml version=\"1.0\"?>
 <!DOCTYPE cross-domain-policy SYSTEM \"http://www.macromedia.com/xml/dtds/cross-domain-policy.dtd\">
 <cross-domain-policy><allow-access-from domain=\"~a\" to-ports=\"~a\" /></cross-domain-policy>~c"
@@ -18,4 +35,18 @@ http://www.adobe.com/devnet/articles/crossdomain_policy_file_spec.html"
   (declare (special *log-level*))
   (when *log-level*
     (apply #'format t args)
-    (finish-output)))
+    (finish-output)))
+
+(defmacro make-array-ubyte8 (size &key (initial-element nil initial-element-p)
+                                    (initial-contents nil initial-contents-p))
+  (let ((body `(make-array ,size :element-type '(unsigned-byte 8)
+                           #+(and lispworks (not (or lispworks3 lispworks4 lispworks5.0)))
+                           ,@`(:allocation :static)
+                           ,@(when initial-element-p `(:initial-element ,initial-element))
+                           ,@(when initial-contents-p `(:initial-contents ,initial-contents)))))
+    #+(or lispworks3 lispworks4 lispworks5.0)
+    `(sys:in-static-area
+       ,body)
+    #-(or lispworks3 lispworks4 lispworks5.0)
+    body
+    ))