clisp patch by Pixel // pinterface

LICENSE

@@ -1,6 +1,7 @@
 Copyright (C) 2001, 2003  Eric Marsden
 Copyright (C) ????  Jochen Schmidt
 Copyright (C) 2005  David Lichteblau
+Copyright (C) 2007  Pixel // pinterface
 
 * License first changed by Eric Marsden, Jochen Schmidt, and David Lichteblau
   from plain LGPL to Lisp-LGPL in December 2005.

cl+ssl.asd

@@ -2,6 +2,7 @@
 ;;;
 ;;; Copyright (C) 2001, 2003  Eric Marsden
 ;;; Copyright (C) 2005  David Lichteblau
+;;; Copyright (C) 2007  Pixel // pinterface
 ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt."
 ;;;
 ;;; See LICENSE for details.
@@ -19,5 +20,8 @@
     (:file "reload")
     (:file "conditions")
     (:file "ffi")
+    (:file "ffi-buffer-all")
+    #-clisp (:file "ffi-buffer")
+    #+clisp (:file "ffi-buffer-clisp")
     (:file "streams")
     (:file "bio")))

ffi-buffer-all.lisp

@@ -0,0 +1,12 @@
+(in-package :cl+ssl)
+
+(defconstant +initial-buffer-size+ 2048)
+
+(declaim
+ (inline
+  make-buffer
+  buffer-length
+  buffer-elt
+  set-buffer-elt
+  v/b-replace
+  b/v-replace))

ffi-buffer-clisp.lisp

@@ -0,0 +1,29 @@
+(in-package :cl+ssl)
+
+(defun make-buffer (size)
+  (cffi-sys:%foreign-alloc size))
+
+(defun buffer-length (buf)
+  (declare (ignore buf))
+  +initial-buffer-size+)
+
+(defun buffer-elt (buf index)
+  (ffi:memory-as buf 'ffi:uint8 index))
+(defun set-buffer-elt (buf index val)
+  (setf (ffi:memory-as buf 'ffi:uint8 index) val))
+(defsetf buffer-elt set-buffer-elt)
+
+(defun v/b-replace (vec buf &key (start1 0) end1 (start2 0) (end2 +initial-buffer-size+))
+  (replace
+   vec
+   (ffi:memory-as buf (ffi:parse-c-type `(ffi:c-array ffi:uint8 ,(- end2 start2))) start2)
+   :start1 start1
+   :end1 end1))
+(defun b/v-replace (buf vec &key (start1 0) (end1 +initial-buffer-size+) (start2 0) end2)
+  (setf
+   (ffi:memory-as buf (ffi:parse-c-type `(ffi:c-array ffi:uint8 ,(- end1 start1))) start1)
+   (subseq vec start2 end2)))
+
+(defmacro with-pointer-to-vector-data ((ptr buf) &body body)
+  `(let ((,ptr ,buf))
+    ,@body))

ffi-buffer.lisp

@@ -0,0 +1,22 @@
+(in-package :cl+ssl)
+
+(defun make-buffer (size)
+  (cffi-sys::make-shareable-byte-vector size))
+
+(defun buffer-length (buf)
+  (length buf))
+
+(defun buffer-elt (buf index)
+  (elt buf index))
+(defun set-buffer-elt (buf index val)
+  (setf (elt buf index) val))
+(defsetf buffer-elt set-buffer-elt)
+
+(defun v/b-replace (vec buf &key (start1 0) end1 (start2 0) end2)
+  (replace vec buf :start1 start1 :end1 end1 :start2 start2 :end2 end2))
+(defun b/v-replace (buf vec &key (start1 0) end1 (start2 0) end2)
+  (replace buf vec :start1 start1 :end1 end1 :start2 start2 :end2 end2))
+
+(defmacro with-pointer-to-vector-data ((ptr buf) &body body)
+  `(cffi-sys::with-pointer-to-vector-data (,ptr ,buf)
+    ,@body))

index.html

@@ -16,6 +16,12 @@
     </ul>
 
     <h3>News</h3>
+    <p>
+      2007-07-07: Improved clisp support, thanks
+      to <a
+      href="http://web.kepibu.org/code/lisp/cl+ssl/#faster-clisp">Pixel
+      // pinterface</a>.
+    </p>
     <p>
       2007-01-16: CL+SSL is now available under an MIT-style license.
     </p>

streams.lisp

@@ -1,5 +1,6 @@
 ;;; Copyright (C) 2001, 2003  Eric Marsden
 ;;; Copyright (C) 2005  David Lichteblau
+;;; Copyright (C) 2007  Pixel // pinterface
 ;;; "the conditions and ENSURE-SSL-FUNCALL are by Jochen Schmidt."
 ;;;
 ;;; See LICENSE for details.
@@ -9,8 +10,6 @@
 
 (in-package :cl+ssl)
 
-(defconstant +initial-buffer-size+ 2048)
-
 (defclass ssl-stream
     (fundamental-binary-input-stream
      fundamental-binary-output-stream 
@@ -22,13 +21,13 @@
     :initform nil
     :accessor ssl-stream-handle)
    (output-buffer
-    :initform (cffi-sys::make-shareable-byte-vector +initial-buffer-size+)
+    :initform (make-buffer +initial-buffer-size+)
     :accessor ssl-stream-output-buffer)
    (output-pointer
     :initform 0
     :accessor ssl-stream-output-pointer)
    (input-buffer
-    :initform (cffi-sys::make-shareable-byte-vector +initial-buffer-size+)
+    :initform (make-buffer +initial-buffer-size+)
     :accessor ssl-stream-input-buffer)
    (peeked-byte
     :initform nil
@@ -70,7 +69,7 @@
   (or (ssl-stream-peeked-byte stream)
       (let ((buf (ssl-stream-input-buffer stream)))
         (handler-case
-            (cffi-sys::with-pointer-to-vector-data (ptr buf)
+            (with-pointer-to-vector-data (ptr buf)
               (ensure-ssl-funcall (ssl-stream-socket stream)
                                   (ssl-stream-handle stream)
                                   #'ssl-read
@@ -78,7 +77,7 @@
                                   (ssl-stream-handle stream)
                                   ptr
                                   1)
-              (elt buf 0))
+              (buffer-elt buf 0))
           (ssl-error-zero-return ()     ;SSL_read returns 0 on end-of-file
             :eof)))))
 
@@ -90,11 +89,11 @@
     (incf start))
   (let ((buf (ssl-stream-input-buffer stream)))
     (loop
-        for length = (min (- end start) (length buf))
+        for length = (min (- end start) (buffer-length buf))
         while (plusp length)
         do
           (handler-case
-              (cffi-sys::with-pointer-to-vector-data (ptr buf)
+              (with-pointer-to-vector-data (ptr buf)
                 (ensure-ssl-funcall (ssl-stream-socket stream)
                                     (ssl-stream-handle stream)
                                     #'ssl-read
@@ -102,7 +101,7 @@
                                     (ssl-stream-handle stream)
                                     ptr
                                     length)
-                (replace thing buf :start1 start :end1 (+ start length))
+                (v/b-replace thing buf :start1 start :end1 (+ start length))
                 (incf start length))
             (ssl-error-zero-return ()   ;SSL_read returns 0 on end-of-file
               (return))))
@@ -110,28 +109,28 @@
 
 (defmethod stream-write-byte ((stream ssl-stream) b)
   (let ((buf (ssl-stream-output-buffer stream)))
-    (when (eql (length buf) (ssl-stream-output-pointer stream))
+    (when (eql (buffer-length buf) (ssl-stream-output-pointer stream))
       (force-output stream))
-    (setf (elt buf (ssl-stream-output-pointer stream)) b)
+    (setf (buffer-elt buf (ssl-stream-output-pointer stream)) b)
     (incf (ssl-stream-output-pointer stream)))
   b)
 
 (defmethod stream-write-sequence ((stream ssl-stream) thing start end &key)
   (check-type thing (simple-array (unsigned-byte 8) (*)))
   (let ((buf (ssl-stream-output-buffer stream)))
-    (when (> (+ (- end start) (ssl-stream-output-pointer stream)) (length buf))
+    (when (> (+ (- end start) (ssl-stream-output-pointer stream)) (buffer-length buf))
       ;; not enough space left?  flush buffer.
       (force-output stream)
       ;; still doesn't fit?
-      (while (> (- end start) (length buf))
+      (while (> (- end start) (buffer-length buf))
-        (replace buf thing :start2 start)
+        (b/v-replace buf thing :start2 start)
-        (incf start (length buf))
+        (incf start (buffer-length buf))
-        (setf (ssl-stream-output-pointer stream) (length buf))
+        (setf (ssl-stream-output-pointer stream) (buffer-length buf))
         (force-output stream)))
-    (replace buf thing
+    (b/v-replace buf thing
-             :start1 (ssl-stream-output-pointer stream)
+                 :start1 (ssl-stream-output-pointer stream)
-             :start2 start
+                 :start2 start
-             :end2 end)
+                 :end2 end)
     (incf (ssl-stream-output-pointer stream) (- end start)))
   thing)
 
@@ -144,7 +143,7 @@
         (handle (ssl-stream-handle stream))
 	(socket (ssl-stream-socket stream)))
     (when (plusp fill-ptr)
-      (cffi-sys::with-pointer-to-vector-data (ptr buf)
+      (with-pointer-to-vector-data (ptr buf)
         (ensure-ssl-funcall socket handle #'ssl-write 0.5 handle ptr fill-ptr))
       (setf (ssl-stream-output-pointer stream) 0))))