diff --git a/clx.asd b/clx.asd index 28aa580..0b79a1b 100644 --- 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 new file mode 100644 index 0000000..7450c72 --- /dev/null +++ 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 index 2f12a7e..fa77ac4 100644 --- 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 index 8b7ee1f..7204983 100644 --- 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 index 4835b04..5866dab 100644 --- 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 diff --git a/dependent.lisp b/dependent.lisp index f559ef0..4a943ef 100644 --- a/dependent.lisp +++ b/dependent.lisp @@ -986,138 +986,6 @@ fd)))))) (system:make-fd-stream stream-fd :input t :output t :element-type '(unsigned-byte 8)))) -;;; BUFFER-READ-DEFAULT for CMU Common Lisp. -;;; -;;; If timeout is 0, then we call LISTEN to see if there is any input. -;;; Timeout 0 is the only case where READ-INPUT dives into BUFFER-READ without -;;; first calling BUFFER-INPUT-WAIT-DEFAULT. -;;; -#+(or CMU sbcl) -(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 - (#+cmu system:read-n-bytes - #+sbcl sb-sys:read-n-bytes - (display-input-stream display) - vector start (- end start)) - nil))) - -#+(or ecl clisp clasp) -(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))) - -;;; 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 CMU sbcl ecl clisp clasp) -(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 - -#+CMU -(defun buffer-write-default (vector display start end) - (declare (type buffer-bytes vector) - (type display display) - (type array-index start end)) - #.(declare-buffun) - (system:output-raw-bytes (display-output-stream display) vector start end) - nil) - -#+(or sbcl ecl clisp clasp) -(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) - -;;; 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 CMU sbcl clisp ecl clasp) -(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-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 @@ -1191,27 +1059,6 @@ nil) (T :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)))) - -#+ (or) -(defun buffer-listen-default (display) - (declare (type display display)) - (let ((fd (display-input-stream display))) - (declare (type fixnum fd)) - (if (= fd -1) - t - (fd-char-avail-p fd)))) - ;;;---------------------------------------------------------------------------- ;;; System dependent speed hacks