X-Git-Url: http://dolda2000.com/gitweb/?p=lisp-utils.git;a=blobdiff_plain;f=net-sbcl.lisp;fp=net-sbcl.lisp;h=0ff03cf3ce32daa3befdcb80933b7248e39e189c;hp=0000000000000000000000000000000000000000;hb=dfa6197cf07772bba6cc056c35672b7f8c4d0f3b;hpb=53d1dafed1900b44f42acacfd14c3beae1c3af22

diff --git a/net-sbcl.lisp b/net-sbcl.lisp
new file mode 100644
index 0000000..0ff03cf
--- /dev/null
+++ b/net-sbcl.lisp
@@ -0,0 +1,78 @@
+(in-package :common-net)
+
+(require :sb-bsd-sockets)
+
+;;; Gray stream methods
+
+;; Redefine stream-socket with Gray superclasses. I know it's ugly,
+;; but I just don't know of a better way to do it.
+(defclass stream-socket (socket sb-gray:fundamental-input-stream sb-gray:fundamental-output-stream)
+  ((mode :initform :byte)
+   (byte-buffer :initform (make-array '(16) :element-type '(unsigned-byte 8) :adjustable t)
+		:type (array (unsigned-byte 8)))
+   (byte-read-pos :initform 0 :type integer)
+   (byte-write-pos :initform 0 :type integer)
+   (char-buffer :initform (make-array '(16) :element-type 'character :adjustable t :fill-pointer 0)
+		:type (array character))
+   (char-read-pos :initform 0 :type integer)
+   encoder decoder))
+
+(macrolet ((simple (name)
+	     `(defmethod
+		  ,(intern (symbol-name name) (find-package :sb-gray)) ((socket stream-socket))
+		(,(intern (concatenate 'string "GRAY-" (symbol-name name)) (symbol-package 'stream-socket)) socket)))
+	   (simple-null (name)
+	     `(defmethod
+		  ,(intern (symbol-name name) (find-package :sb-gray)) ((socket stream-socket))
+		nil)))
+  (simple stream-element-type)
+  (simple open-stream-p)
+  (simple stream-read-byte)
+  (simple stream-read-char)
+  (simple stream-read-char-no-hang)
+  (simple stream-peek-char)
+  (simple stream-listen)
+  (simple-null stream-line-column)
+  (simple-null stream-finish-output)
+  (simple-null stream-force-output)
+  (simple-null stream-clear-output))
+
+(defmethod sb-gray:stream-write-byte ((socket stream-socket) byte)
+  (gray-stream-write-char socket byte))
+
+(defmethod sb-gray:stream-unread-char ((socket stream-socket) char)
+  (gray-stream-unread-char socket char))
+
+(defmethod sb-gray:stream-write-char ((socket stream-socket) char)
+  (gray-stream-write-char socket char))
+
+(defmethod close ((socket stream-socket) &key abort)
+  (declare (ignore abort))
+  (prog1
+      (call-next-method)
+    (close-socket socket)))
+
+(defmethod sb-gray:stream-start-line-p ((socket stream-socket))
+  (eql (sb-gray:stream-line-column socket) 0))
+
+(defmethod sb-gray:stream-fresh-line ((socket stream-socket))
+  (unless (sb-gray:stream-start-line-p socket)
+    (sb-gray:stream-terpri socket)
+    t))
+
+(defmethod sb-gray:stream-write-string ((socket stream-socket) string &optional (start 0) (end (length string)))
+  (sb-gray:stream-write-sequence socket string start end))
+
+(defmethod sb-gray:stream-terpri ((socket stream-socket))
+  (sb-gray:stream-write-char socket #\newline))
+
+(defmethod sb-gray:stream-read-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq)))
+  (gray-stream-read-sequence socket seq start end))
+
+(defmethod sb-gray:stream-write-sequence ((socket stream-socket) seq &optional (start 0) (end (length seq)))
+  (gray-stream-write-sequence socket seq start end))
+
+;;; Necessary SBCL gray-stream extensions
+
+(defmethod sb-gray:stream-line-length ((socket stream-socket))
+  nil)