dependent: unify common code in a file "common"

sharplispers · Dec 7, 2023 · 73c76e3 · 73c76e3
1 parent 610f23f
commit 73c76e3
Show file tree

Hide file tree

Showing 6 changed files with 123 additions and 363 deletions.
diff --git a/clx.asd b/clx.asd
@@ -50,6 +50,7 @@ Independent FOSS developers"
    #+openmcl (:file "dep-openmcl")
    #+allegro (:file "dep-allegro")
    #+lispworks (:file "dep-lispworks")
+   (:file "common")
    (:file "macros")
    (:file "bufmac")
    (:file "buffer")

diff --git a/common.lisp b/common.lisp
@@ -0,0 +1,122 @@
+;;; This file contains code moved from "dependent" files that has been unified.
+
+(in-package :xlib)
+
+;;; BUFFER-READ-DEFAULT - read data from the X stream
+;;;
+;;; READ-SEQUENCE was not present in ANSI Common Lisp when CLX was written. This
+;;; implementation is portable and implements block transfer.
+
+(defun buffer-read-default (display vector start end timeout)
+  (declare (type display display)
+           (type buffer-bytes vector)
+           (type array-index start end)
+           (type (or null (real 0 *)) timeout))
+  #.(declare-buffun)
+  (cond ((and (not (null timeout))
+              (zerop timeout)
+              (not (listen (display-input-stream display))))
+         :timeout)
+        (t
+         (read-sequence vector
+                        (display-input-stream display)
+                        :start start
+                        :end end)
+         nil)))
+
+;;; This is a legacy and obsolete fallback implementation.
+;;;
+;;; WARNING
+;;;	CLX performance will suffer if your lisp uses read-byte for receiving
+;;;	all data from the X Window System server.  You are encouraged to write a
+;;;	specialized version of buffer-read-default that does block transfers.
+#+(or)
+(defun buffer-read-default (display vector start end timeout)
+  (declare (type display display)
+           (type buffer-bytes vector)
+           (type array-index start end)
+           (type (or null (real 0 *)) timeout))
+  #.(declare-buffun)
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (or (cond ((null stream))
+              ((listen stream) nil)
+              ((and timeout (= timeout 0)) :timeout)
+              ((buffer-input-wait-default display timeout)))
+        (do* ((index start (index1+ index)))
+             ((index>= index end) nil)
+          (declare (type array-index index))
+          (let ((c (read-byte stream nil nil)))
+            (declare (type (or null card8) c))
+            (if (null c)
+                (return t)
+                (setf (aref vector index) (the card8 c))))))))
+
+;;; BUFFER-WRITE-DEFAULT - write data to the X stream
+;;;
+;;; WRITE-SEQUENCE was not present in ANSI Common Lisp when CLX was
+;;; written. This implementation is portable and implements block transfer.
+(defun buffer-write-default (vector display start end)
+  (declare (type buffer-bytes vector)
+	   (type display display)
+	   (type array-index start end))
+  #.(declare-buffun)
+
+  (write-sequence vector (display-output-stream display) :start start :end end)
+  nil)
+
+;;; This is a legacy and obsolete fallback implementation.
+;;;
+;;; WARNING:
+;;;	CLX performance will be severely degraded if your lisp uses
+;;;	write-byte to send all data to the X Window System server.
+;;;	You are STRONGLY encouraged to write a specialized version
+;;;	of buffer-write-default that does block transfers.
+#+(or)
+(defun buffer-write-default (vector display start end)
+  ;; The default buffer write function for use with common-lisp streams
+  (declare (type buffer-bytes vector)
+           (type display display)
+           (type array-index start end))
+  #.(declare-buffun)
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream)
+      (with-vector (vector buffer-bytes)
+        (do ((index start (index1+ index)))
+            ((index>= index end))
+          (declare (type array-index index))
+          (write-byte (aref vector index) stream))))))
+
+;;; BUFFER-FORCE-OUTPUT-DEFAULT - force output to the X stream
+
+(defun buffer-force-output-default (display)
+  ;; The default buffer force-output function for use with common-lisp streams
+  (declare (type display display))
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream)
+      (force-output stream))))
+
+;;; BUFFER-CLOSE-DEFAULT - close the X stream
+
+(defun buffer-close-default (display &key abort)
+  ;; The default buffer close function for use with common-lisp streams
+  (declare (type display display))
+  #.(declare-buffun)
+  (let ((stream (display-output-stream display)))
+    (declare (type (or null stream) stream))
+    (unless (null stream)
+      (close stream :abort abort))))
+
+;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
+;;; buffer. This should never block, so it can be called from the scheduler.
+
+;;; The default implementation is to just use listen.
+(defun buffer-listen-default (display)
+  (declare (type display display))
+  (let ((stream (display-input-stream display)))
+    (declare (type (or null stream) stream))
+    (if (null stream)
+        t
+        (listen stream))))
diff --git a/dep-allegro.lisp b/dep-allegro.lisp
@@ -564,71 +564,6 @@
 	stream
       (error "Cannot connect to server: ~A:~D" host display))))
 
-
-;;; BUFFER-READ-DEFAULT - read data from the X stream
-
-(defun buffer-read-default (display vector start end timeout)
-  (declare (type display display)
-	   (type buffer-bytes vector)
-	   (type array-index start end)
-	   (type (or null (real 0 *)) timeout))
-  #.(declare-buffun)
-
-  (let* ((howmany (- end start))
-	 (stream (display-input-stream display)))
-    (declare (type array-index howmany)
-	     (type (or null stream) stream))
-    (or (cond ((stream-char-avail-p stream) nil)
-	      ((and timeout (= timeout 0)) :timeout)
-	      ((buffer-input-wait-default display timeout)))
-	(stream-read-bytes stream vector start howmany))))
-
-;;; WARNING:
-;;;	CLX performance will suffer if your lisp uses read-byte for
-;;;	receiving all data from the X Window System server.
-;;;	You are encouraged to write a specialized version of
-;;;	buffer-read-default that does block transfers.
-
-
-;;; BUFFER-WRITE-DEFAULT - write data to the X stream
-
-(defun buffer-write-default (vector display start end)
-  (declare (type buffer-bytes vector)
-	   (type display display)
-	   (type array-index start end))
-  #.(declare-buffun)
-  (let ((stream (display-output-stream display)))
-    (unless (null stream)
-      (write-sequence vector stream :start start :end end)))
-  )
-
-;;; WARNING:
-;;;	CLX performance will be severely degraded if your lisp uses
-;;;	write-byte to send all data to the X Window System server.
-;;;	You are STRONGLY encouraged to write a specialized version
-;;;	of buffer-write-default that does block transfers.
-
-;;; buffer-force-output-default - force output to the X stream
-
-(defun buffer-force-output-default (display)
-  ;; The default buffer force-output function for use with common-lisp streams
-  (declare (type display display))
-  (let ((stream (display-output-stream display)))
-    (declare (type (or null stream) stream))
-    (unless (null stream)
-      (force-output stream))))
-
-;;; BUFFER-CLOSE-DEFAULT - close the X stream
-
-(defun buffer-close-default (display &key abort)
-  ;; The default buffer close function for use with common-lisp streams
-  (declare (type display display))
-  #.(declare-buffun)
-  (let ((stream (display-output-stream display)))
-    (declare (type (or null stream) stream))
-    (unless (null stream)
-      (close stream :abort abort))))
-
 ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the
 ;;; buffer.  This is called in read-input between requests, so that a process
 ;;; waiting for input is abortable when between requests.  Should return
@@ -669,15 +604,6 @@
 	       (return-from buffer-input-wait-default :timeout))
 	   ))))
 
-;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
-;;; buffer. This should never block, so it can be called from the scheduler.
-
-(defun buffer-listen-default (display)
-  (declare (type display display))
-  (let ((stream (display-input-stream display)))
-    (declare (type (or null stream) stream))
-    (stream-char-avail-p stream)))
-
 
 ;;;----------------------------------------------------------------------------
 ;;; System dependent speed hacks

diff --git a/dep-lispworks.lisp b/dep-lispworks.lisp
@@ -667,61 +667,6 @@
                             :element-type '(unsigned-byte 8)
                             :errorp t)))
 
-;;; BUFFER-READ-DEFAULT - read data from the X stream
-
-(defun buffer-read-default (display vector start end timeout)
-  (declare (type display display)
-	   (type buffer-bytes vector)
-	   (type array-index start end)
-	   (type (or null fixnum) timeout))
-  #.(declare-buffun)
-
-  (cond ((and (eql timeout 0)
-	      (not (listen (display-input-stream display))))
-	 :timeout)
-	(t
-	 (read-sequence vector
-			(display-input-stream display)
-                        :start start
-                        :end end)
-	 nil)))
-
-;;; BUFFER-WRITE-DEFAULT - write data to the X stream
-
-(defun buffer-write-default (vector display start end)
-  (declare (type buffer-bytes vector)
-	   (type display display)
-	   (type array-index start end))
-  #.(declare-buffun)
-
-  (write-sequence vector (display-output-stream display) :start start :end end)
-  nil)
-
-;;; buffer-force-output-default - force output to the X stream
-
-(defun buffer-force-output-default (display)
-  ;; The default buffer force-output function for use with common-lisp streams
-  (declare (type display display))
-
-  (let ((stream (display-output-stream display)))
-    (declare (type (or null stream) stream))
-
-    (unless (null stream)
-      (force-output stream))))
-
-;;; BUFFER-CLOSE-DEFAULT - close the X stream
-
-(defun buffer-close-default (display &key abort)
-  ;; The default buffer close function for use with common-lisp streams
-  (declare (type display display))
-  #.(declare-buffun)
-
-  (let ((stream (display-output-stream display)))
-    (declare (type (or null stream) stream))
-
-    (unless (null stream)
-      (close stream :abort abort))))
-
 ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the
 ;;; buffer.  This is called in read-input between requests, so that a process
 ;;; waiting for input is abortable when between requests.  Should return
@@ -730,10 +675,8 @@
 (defun buffer-input-wait-default (display timeout)
   (declare (type display display)
 	   (type (or null (real 0 *)) timeout))
-
   (let ((stream (display-input-stream display)))
     (declare (type (or null stream) stream))
-
     (cond ((null stream))
 	  ((listen stream) nil)
 	  ((eql timeout 0) :timeout)
@@ -743,19 +686,6 @@
                nil
                :timeout)))))
 
-;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
-;;; buffer. This should never block, so it can be called from the scheduler.
-
-(defun buffer-listen-default (display)
-  (declare (type display display))
-
-  (let ((stream (display-input-stream display)))
-    (declare (type (or null stream) stream))
-
-    (if (null stream)
-	t
-        (listen stream))))
-
 
 ;;;----------------------------------------------------------------------------
 ;;; System dependent speed hacks

diff --git a/dep-openmcl.lisp b/dep-openmcl.lisp
@@ -579,58 +579,6 @@
                       :remote-host host
 			 :remote-port (+ 6000 display)))))
 
-;;; BUFFER-READ-DEFAULT - read data from the X stream
-
-(defun buffer-read-default (display vector start end timeout)
-  (declare (type display display)
-	   (type buffer-bytes vector)
-	   (type array-index start end)
-	   (type (or null (real 0 *)) timeout))
-  #.(declare-buffun)
-  (let ((stream (display-input-stream display)))
-    (declare (type (or null stream) stream))
-    (or (cond ((null stream))
-	      ((listen stream) nil)
-	      ((and timeout (= timeout 0)) :timeout)
-	      ((buffer-input-wait-default display timeout)))
-	(progn
-	  (ccl:stream-read-ivector stream vector start (- end start))
-	  nil))))
-
-;;; BUFFER-WRITE-DEFAULT - write data to the X stream
-
-(defun buffer-write-default (vector display start end)
-  (declare (type buffer-bytes vector)
-	   (type display display)
-	   (type array-index start end))
-  #.(declare-buffun)
-  (let ((stream (display-output-stream display)))
-    (declare (type (or null stream) stream))
-    (unless (null stream)
-      (ccl:stream-write-ivector stream vector start (- end start)))
-    nil))
-
-;;; buffer-force-output-default - force output to the X stream
-
-(defun buffer-force-output-default (display)
-  ;; The default buffer force-output function for use with common-lisp streams
-  (declare (type display display))
-  (let ((stream (display-output-stream display)))
-    (declare (type (or null stream) stream))
-    (unless (null stream)
-      (force-output stream))))
-
-;;; BUFFER-CLOSE-DEFAULT - close the X stream
-
-(defun buffer-close-default (display &key abort)
-  ;; The default buffer close function for use with common-lisp streams
-  (declare (type display display))
-  #.(declare-buffun)
-  (let ((stream (display-output-stream display)))
-    (declare (type (or null stream) stream))
-    (unless (null stream)
-      (close stream :abort abort))))
-
 ;;; BUFFER-INPUT-WAIT-DEFAULT - wait for for input to be available for the
 ;;; buffer.  This is called in read-input between requests, so that a process
 ;;; waiting for input is abortable when between requests.  Should return
@@ -651,20 +599,6 @@
                  nil
                  :timeout))))))
 
-
-;;; BUFFER-LISTEN-DEFAULT - returns T if there is input available for the
-;;; buffer. This should never block, so it can be called from the scheduler.
-
-;;; The default implementation is to just use listen.
-
-(defun buffer-listen-default (display)
-  (declare (type display display))
-  (let ((stream (display-input-stream display)))
-    (declare (type (or null stream) stream))
-    (if (null stream)
-	t
-      (listen stream))))
-
 
 ;;;----------------------------------------------------------------------------
 ;;; System dependent speed hacks