Skip to content
Snippets Groups Projects
dependent.lisp 133 KiB
Newer Older
dan's avatar
dan committed
#+lcl3.0
(defmacro holding-lock ((locator display &optional whostate &key timeout)
			&body body)
  (declare (ignore display))
  (if timeout
      ;; Hair to support timeout.
      `(let ((.have-lock. (eq ,locator lcl:*current-process*))
	     (.timeout. ,timeout))
	 (unwind-protect
	     (when (cond (.have-lock.)
			 ((conditional-store ,locator nil lcl:*current-process*))
			 ((null .timeout.)
			  (lcl:process-lock ,locator)
			  t)
			 ((lcl:process-wait-with-timeout ,whostate .timeout.
			    #'(lambda ()
				(conditional-store ,locator nil lcl:*current-process*))))
			 ;; abort the PROCESS-UNLOCK if actually timing out
			 (t
			  (setf .have-lock. :abort)
			  nil))
	       ,@body)
	   (unless .have-lock. 
	     (lcl:process-unlock ,locator))))
    `(lcl:with-process-lock (,locator)
       ,@body)))


#+excl
(defmacro holding-lock ((locator display &optional whostate &key timeout)
			&body body)
  (declare (ignore display))
  `(let (.hl-lock. .hl-obtained-lock. .hl-curproc.)
     (unwind-protect
	 (block .hl-doit.
	   (when mp::*scheduler-stack-group* ; fast test for scheduler running
	     (setq .hl-lock. ,locator
		   .hl-curproc. mp::*current-process*)
	     (when (and .hl-curproc.	; nil if in process-wait fun
			(not (eq (mp::process-lock-locker .hl-lock.)
				 .hl-curproc.)))
	       ;; Then we need to grab the lock.
	       ,(if timeout
		    `(if (not (mp::process-lock .hl-lock. .hl-curproc.
						,whostate ,timeout))
			 (return-from .hl-doit. nil))
		  `(mp::process-lock .hl-lock. .hl-curproc.
				     ,@(when whostate `(,whostate))))
	       ;; There is an apparent race condition here.  However, there is
	       ;; no actual race condition -- our implementation of mp:process-
	       ;; lock guarantees that the lock will still be held when it
	       ;; returns, and no interrupt can happen between that and the
	       ;; execution of the next form.  -- jdi 2/27/91
	       (setq .hl-obtained-lock. t)))
	   ,@body)
       (if (and .hl-obtained-lock.
		;; Note -- next form added to allow error handler inside
		;; body to unlock the lock prematurely if it knows that
		;; the current process cannot possibly continue but will
		;; throw out (or is it throw up?).
		(eq (mp::process-lock-locker .hl-lock.) .hl-curproc.))
	   (mp::process-unlock .hl-lock. .hl-curproc.)))))

#+Minima
(defmacro holding-lock ((locator display &optional whostate &key timeout) &body body)
  `(holding-lock-1 #'(lambda () ,@body) ,locator ,display
		   ,@(and whostate `(:whostate ,whostate))
		   ,@(and timeout `(:timeout ,timeout))))

#+Minima
(defun holding-lock-1 (continuation lock display &key (whostate "Lock") timeout)
  (declare (dynamic-extent continuation))
  (declare (ignore display whostate timeout))
  (minima:with-lock (lock)
    (funcall continuation)))

;;; WITHOUT-ABORTS

;;; If you can inhibit asynchronous keyboard aborts inside the body of this
;;; macro, then it is a good idea to do this.  This macro is wrapped around
;;; request writing and reply reading to ensure that requests are atomically
;;; written and replies are atomically read from the stream.

#-(or Genera excl lcl3.0)
(defmacro without-aborts (&body body)
  `(progn ,@body))

#+Genera
(defmacro without-aborts (&body body)
  `(sys:without-aborts (clx "CLX is in the middle of an operation that should be atomic.")
     ,@body))

#+excl
(defmacro without-aborts (&body body)
  `(without-interrupts ,@body))
    
#+lcl3.0
(defmacro without-aborts (&body body)
  `(lcl:with-interruptions-inhibited ,@body))

;;; PROCESS-BLOCK: Wait until a given predicate returns a non-NIL value.
;;; Caller guarantees that PROCESS-WAKEUP will be called after the predicate's
;;; value changes.

dan's avatar
dan committed
#-(or lispm excl lcl3.0 Minima (and sb-thread sbcl) (and cmu mp))
dan's avatar
dan committed
(defun process-block (whostate predicate &rest predicate-args)
  (declare (ignore whostate))
  (or (apply predicate predicate-args)
      (error "Program tried to wait with no scheduler.")))

#+Genera
(defun process-block (whostate predicate &rest predicate-args)
  (declare (type function predicate)
	   #+clx-ansi-common-lisp
	   (dynamic-extent predicate)
	   #-clx-ansi-common-lisp
	   (sys:downward-funarg predicate))
  (apply #'process:block-process whostate predicate predicate-args))

#+(and lispm (not Genera))
(defun process-block (whostate predicate &rest predicate-args)
  (declare (type function predicate)
	   #+clx-ansi-common-lisp
	   (dynamic-extent predicate)
	   #-clx-ansi-common-lisp 
	   (sys:downward-funarg predicate))
  (apply #'global:process-wait whostate predicate predicate-args))

#+excl
(defun process-block (whostate predicate &rest predicate-args)
  (if mp::*scheduler-stack-group*
      (apply #'mp::process-wait whostate predicate predicate-args)
      (or (apply predicate predicate-args)
	  (error "Program tried to wait with no scheduler."))))

#+lcl3.0
(defun process-block (whostate predicate &rest predicate-args)
  (declare (dynamic-extent predicate-args))
  (apply #'lcl:process-wait whostate predicate predicate-args))

#+Minima
(defun process-block (whostate predicate &rest predicate-args)
  (declare (type function predicate)
	   (dynamic-extent predicate))
  (apply #'minima:process-wait whostate predicate predicate-args))

#+(and cmu mp)
(defun process-block (whostate predicate &rest predicate-args)
  (declare (type function predicate))
  (mp:process-wait whostate #'(lambda ()
				(apply predicate predicate-args))))

dan's avatar
dan committed
#+(and sbcl sb-thread)
(progn
  (declaim (inline yield))
  (defun yield ()
    (declare (optimize speed (safety 0)))
    (sb-alien:alien-funcall
     (sb-alien:extern-alien "sched_yield" (function sb-alien:int)))
    (values)))
dan's avatar
dan committed
#+(and sbcl sb-thread)
(defun process-block (whostate predicate &rest predicate-args)
  (declare (ignore whostate))
  (declare (type function predicate))
  (loop
   (when (apply predicate predicate-args)
     (return))
   (yield)))

;;; FIXME: the below implementation for threaded PROCESS-BLOCK using
;;; queues and condition variables might seem better, but in fact it
;;; turns out to make performance extremely suboptimal, at least as
;;; measured by McCLIM on linux 2.4 kernels.  -- CSR, 2003-11-10
#+(or)
(defvar *process-conditions* (make-hash-table))

#+(or)
(defun process-block (whostate predicate &rest predicate-args)
  (declare (ignore whostate))
  (declare (type function predicate))
  (let* ((pid (sb-thread:current-thread-id))
	 (last (gethash  pid *process-conditions*))
	 (lock
	  (or (car last)
	      (sb-thread:make-mutex :name (format nil "lock ~A" pid))))
	 (queue
	  (or (cdr last)
	      (sb-thread:make-waitqueue :name (format nil "queue ~A" pid)))))
    (unless last
      (setf (gethash pid *process-conditions*) (cons lock queue)))
    (sb-thread:with-mutex (lock)
      (loop
       (when (apply predicate predicate-args) (return))
       (handler-case
	   (sb-ext:with-timeout .5
	     (sb-thread:condition-wait queue lock))
	   (format *trace-output* "thread ~A, process-block timed out~%"
		   (sb-thread:current-thread-id) )))))))
dan's avatar
dan committed
;;; PROCESS-WAKEUP: Check some other process' wait function.

dan's avatar
dan committed
(declaim (inline process-wakeup))
dan's avatar
dan committed

dan's avatar
dan committed
#-(or excl Genera Minima (and sbcl sb-thread) (and cmu mp))
dan's avatar
dan committed
(defun process-wakeup (process)
  (declare (ignore process))
  nil)

#+excl
(defun process-wakeup (process)
  (let ((curproc mp::*current-process*))
    (when (and curproc process)
      (unless (mp::process-p curproc)
	(error "~s is not a process" curproc))
      (unless (mp::process-p process)
	(error "~s is not a process" process))
      (if (> (mp::process-priority process) (mp::process-priority curproc))
	  (mp::process-allow-schedule process)))))

#+Genera
(defun process-wakeup (process)
  (process:wakeup process))

#+Minima
(defun process-wakeup (process)
  (when process
    (minima:process-wakeup process)))

#+(and cmu mp)
(defun process-wakeup (process)
  (declare (ignore process))
  (mp:process-yield))

dan's avatar
dan committed
#+(and sb-thread sbcl)
(defun process-wakeup (process)
  (declare (ignore process))
  (yield))
#+(or)
(defun process-wakeup (process)
  (declare (ignore process))
  (destructuring-bind (lock . queue)
      (gethash (sb-thread:current-thread-id) *process-conditions*
	       (cons nil nil))
    (declare (ignore lock))
    (when queue
      (sb-thread:condition-notify queue))))


dan's avatar
dan committed
;;; CURRENT-PROCESS: Return the current process object for input locking and
;;; for calling PROCESS-WAKEUP.

(declaim (inline current-process))

;;; Default return NIL, which is acceptable even if there is a scheduler.

#-(or lispm excl lcl3.0 sbcl Minima (and cmu mp))
dan's avatar
dan committed
(defun current-process ()
  nil)

#+lispm
(defun current-process ()
  sys:current-process)

#+excl
(defun current-process ()
  (and mp::*scheduler-stack-group*
       mp::*current-process*))

#+lcl3.0
(defun current-process ()
  lcl:*current-process*)

#+Minima
(defun current-process ()
  (minima:current-process))

#+(and cmu mp)
(defun current-process ()
  mp:*current-process*)

#+sbcl
(defun current-process ()
  sb-thread:*current-thread*)
dan's avatar
dan committed
;;; WITHOUT-INTERRUPTS -- provide for atomic operations.

#-(or lispm excl lcl3.0 Minima cmu)
(defmacro without-interrupts (&body body)
  `(progn ,@body))

#+(and lispm (not Genera))
(defmacro without-interrupts (&body body)
  `(sys:without-interrupts ,@body))

#+Genera
(defmacro without-interrupts (&body body)
  `(process:with-no-other-processes ,@body))

#+LCL3.0
(defmacro without-interrupts (&body body)
  `(lcl:with-scheduling-inhibited ,@body))

#+Minima
(defmacro without-interrupts (&body body)
  `(minima:with-no-other-processes ,@body))

dan's avatar
dan committed
(defmacro without-interrupts (&body body)
  `(system:without-interrupts ,@body))

(defvar *without-interrupts-sic-lock*
  (sb-thread:make-mutex :name "lock simulating *without-interrupts*"))
#+sbcl
(defmacro without-interrupts (&body body)
  `(sb-thread:with-recursive-lock (*without-interrupts-sic-lock*)
    ,@body))
dan's avatar
dan committed
;;; CONDITIONAL-STORE:

;; This should use GET-SETF-METHOD to avoid evaluating subforms multiple times.
;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.
dan's avatar
dan committed
(defmacro conditional-store (place old-value new-value)
  `(without-interrupts
     (cond ((eq ,place ,old-value)
	    (setf ,place ,new-value)
	    t))))

(progn
  (defvar *conditional-store-lock*
    (sb-thread:make-mutex :name "conditional store"))
  (defmacro conditional-store (place old-value new-value)
    `(sb-thread:with-mutex (*conditional-store-lock*)
       (cond ((eq ,place ,old-value)
	      (setf ,place ,new-value)
	      t)))))
dan's avatar
dan committed
;;;----------------------------------------------------------------------------
;;; IO Error Recovery
;;;	All I/O operations are done within a WRAP-BUF-OUTPUT macro.
;;;	It prevents multiple mindless errors when the network craters.
;;;
;;;----------------------------------------------------------------------------

#-Genera
(defmacro wrap-buf-output ((buffer) &body body)
  ;; Error recovery wrapper
  `(unless (buffer-dead ,buffer)
     ,@body))

#+Genera
(defmacro wrap-buf-output ((buffer) &body body)
  ;; Error recovery wrapper
  `(let ((.buffer. ,buffer))
     (unless (buffer-dead .buffer.)
       (scl:condition-bind
	 (((sys:network-error)
	   #'(lambda (error)
	       (scl:condition-case () 
		    (funcall (buffer-close-function .buffer.) .buffer. :abort t)
		  (sys:network-error))
	       (setf (buffer-dead .buffer.) error)
	       (setf (buffer-output-stream .buffer.) nil)
	       (setf (buffer-input-stream .buffer.) nil)
	       nil)))
	 ,@body))))

#-Genera
(defmacro wrap-buf-input ((buffer) &body body)
  (declare (ignore buffer))
  ;; Error recovery wrapper
  `(progn ,@body))

#+Genera
(defmacro wrap-buf-input ((buffer) &body body)
  ;; Error recovery wrapper
  `(let ((.buffer. ,buffer))
     (scl:condition-bind
       (((sys:network-error)
	 #'(lambda (error)
	     (scl:condition-case () 
		  (funcall (buffer-close-function .buffer.) .buffer. :abort t)
		(sys:network-error))
	     (setf (buffer-dead .buffer.) error)
	     (setf (buffer-output-stream .buffer.) nil)
	     (setf (buffer-input-stream .buffer.) nil)
	     nil)))
       ,@body)))


;;;----------------------------------------------------------------------------
;;; System dependent IO primitives
;;;	Functions for opening, reading writing forcing-output and closing 
;;;	the stream to the server.
;;;----------------------------------------------------------------------------

;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
;;; server

#-(or explorer Genera lucid kcl ibcl excl Minima CMU sbcl ecl)
dan's avatar
dan committed
(defun open-x-stream (host display protocol)
  host display protocol ;; unused
  (error "OPEN-X-STREAM not implemented yet."))

;;; Genera:

;;; TCP and DNA are both layered products, so try to work with either one.

#+Genera
(when (fboundp 'tcp:add-tcp-port-for-protocol)
  (tcp:add-tcp-port-for-protocol :x-window-system 6000))

#+Genera
(when (fboundp 'dna:add-dna-contact-id-for-protocol)
  (dna:add-dna-contact-id-for-protocol :x-window-system "X$X0"))

#+Genera
(net:define-protocol :x-window-system (:x-window-system :byte-stream)
  (:invoke-with-stream ((stream :characters nil :ascii-translation nil))
    stream))

#+Genera
(eval-when (compile)
  (compiler:function-defined 'tcp:open-tcp-stream)
  (compiler:function-defined 'dna:open-dna-bidirectional-stream))

#+Genera
(defun open-x-stream (host display protocol)
  (let ((host (net:parse-host host)))
    (if (or protocol (plusp display))
	;; The protocol was specified or the display isn't 0, so we
	;; can't use the Generic Network System.  If the protocol was
	;; specified, then use that protocol, otherwise, blindly use
	;; TCP.
	(ccase protocol
	  ((:tcp nil)
	   (tcp:open-tcp-stream
	     host (+ *x-tcp-port* display) nil
	     :direction :io
	     :characters nil
	     :ascii-translation nil))
	  ((:dna)
	   (dna:open-dna-bidirectional-stream
	     host (format nil "X$X~D" display)
	     :characters nil
	     :ascii-translation nil)))
      (let ((neti:*invoke-service-automatic-retry* t))
	(net:invoke-service-on-host :x-window-system host)))))

#+explorer
(defun open-x-stream (host display protocol)
  (declare (ignore protocol))
  (net:open-connection-on-medium
    (net:parse-host host)			;Host
    :byte-stream				;Medium
    "X11"					;Logical contact name
    :stream-type :character-stream
    :direction :bidirectional
    :timeout-after-open nil
    :remote-port (+ *x-tcp-port* display)))

#+explorer
(net:define-logical-contact-name
  "X11"
  `((:local "X11")
    (:chaos "X11")
    (:nsp-stream "X11")
    (:tcp ,*x-tcp-port*)))

#+lucid
(defun open-x-stream (host display protocol)
  protocol ;; unused
  (let ((fd (connect-to-server host display)))
    (when (minusp fd)
      (error "Failed to connect to server: ~A ~D" host display))
    (user::make-lisp-stream :input-handle fd
			    :output-handle fd
			    :element-type 'unsigned-byte
			    #-lcl3.0 :stream-type #-lcl3.0 :ephemeral)))

#+(or kcl ibcl)
(defun open-x-stream (host display protocol)
  protocol ;; unused
  (let ((stream (open-socket-stream host display)))
    (if (streamp stream)
	stream
      (error "Cannot connect to server: ~A:~D" host display))))

#+excl
;;
;; Note that since we don't use the CL i/o facilities to do i/o, the display
;; input and output "stream" is really a file descriptor (fixnum).
;;
(defun open-x-stream (host display protocol)
  (declare (ignore protocol));; unused
  (let ((fd (connect-to-server (string host) display)))
    (when (minusp fd)
      (error "Failed to connect to server: ~A ~D" host display))
    fd))

#+Minima
(defun open-x-stream (host display protocol)
  (declare (ignore protocol));; unused
  (minima:open-tcp-stream :foreign-address (apply #'minima:make-ip-address
						  (cdr (host-address host)))
			  :foreign-port (+ *x-tcp-port* display)))

#+(or sbcl ecl)
(defconstant +X-unix-socket-path+
  "/tmp/.X11-unix/X"
  "The location of the X socket")

#+sbcl
(defun open-x-stream (host display protocol)  
  (declare (ignore protocol)
           (type (integer 0) display))
  (socket-make-stream 
   (if (or (string= host "") (string= host "unix")) ; AF_LOCAL domain socket
       (let ((s (make-instance 'local-socket :type :stream)))
	 (socket-connect s (format nil "~A~D" +X-unix-socket-path+ display))
	 s)
       (let ((host (car (host-ent-addresses (get-host-by-name host)))))
	 (when host
	   (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
	     (socket-connect s host (+ 6000 display))
	     s))))
   :element-type '(unsigned-byte 8)
   :input t :output t :buffering :none))

#+ecl
(defun open-x-stream (host display protocol)
  (declare (ignore protocol)
	   (type (integer 0) display))
  (let (socket)
    (if (or (string= host "") (string= host "unix")) ; AF_UNIX doamin socket
	(sys::open-unix-socket-stream
	 (format nil "~A~D" +X-unix-socket-path+ display))
	(si::open-client-stream host (+ 6000 display)))))
dan's avatar
dan committed

;;; BUFFER-READ-DEFAULT - read data from the X stream

#+(or Genera explorer)
(defun buffer-read-default (display vector start end timeout)
  ;; returns non-NIL if EOF encountered
  ;; Returns :TIMEOUT when timeout exceeded
  (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)))
    (or (cond ((null stream))
	      ((funcall stream :listen) nil)
	      ((and timeout (= timeout 0)) :timeout)
	      ((buffer-input-wait-default display timeout)))
	(multiple-value-bind (ignore eofp)
	    (funcall stream :string-in nil vector start end)
	  eofp))))


#+excl
;;
;; Rewritten 10/89 to not use foreign function interface to do I/O.
;;
(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))
	 (fd (display-input-stream display)))
    (declare (type array-index howmany)
	     (fixnum fd))
    (or (cond ((fd-char-avail-p fd) nil)
	      ((and timeout (= timeout 0)) :timeout)
	      ((buffer-input-wait-default display timeout)))
	(fd-read-bytes fd vector start howmany))))


#+lcl3.0
(defmacro with-underlying-stream ((variable stream display direction) &body body)
  `(let ((,variable
	  (or (getf (display-plist ,display) ',direction)
	      (setf (getf (display-plist ,display) ',direction)
		    (lucid::underlying-stream
		      ,stream ,(if (eq direction 'input) :input :output))))))
     ,@body))

#+lcl3.0
(defun buffer-read-default (display vector start end timeout)
  ;;Note that LISTEN must still be done on "slow stream" or the I/O system
  ;;gets confused.  But reading should be done from "fast stream" for speed.
  ;;We used to inhibit scheduling because there were races in Lucid's
  ;;multitasking system.  Empirical evidence suggests they may be gone now.
  ;;Should you decide you need to inhibit scheduling, do it around the
  ;;lcl:read-array.
  (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)))
	(with-underlying-stream (stream stream display input)
	  (eq (lcl:read-array stream vector start end nil :eof) :eof)))))

#+Minima
(defun buffer-read-default (display vector start end timeout)
  ;; returns non-NIL if EOF encountered
  ;; Returns :TIMEOUT when timeout exceeded
  (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)))
    (or (cond ((null stream))
	      ((listen stream) nil)
	      ((and timeout (= timeout 0)) :timeout)
	      ((buffer-input-wait-default display timeout)))
	(eq :eof (minima:read-vector vector stream nil start end)))))

;;; 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 fixnum) timeout))
  #.(declare-buffun)
  (cond ((and (eql timeout 0)
	      (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))
dan's avatar
dan committed
	 nil)))

#+ecl
(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)))
dan's avatar
dan committed

;;; 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 Genera explorer excl lcl3.0 Minima CMU sbcl ecl)
dan's avatar
dan committed
(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

#+(or Genera explorer)
(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) 
      (write-string vector stream :start start :end end))))

#+excl
(defun buffer-write-default (vector display start end)
  (declare (type buffer-bytes vector)
	   (type display display)
	   (type array-index start end))
  #.(declare-buffun)
  (excl::filesys-write-bytes (display-output-stream display) vector start
			     (- end start)))
  
#+lcl3.0
(defun buffer-write-default (vector display start end)
  ;;We used to inhibit scheduling because there were races in Lucid's
  ;;multitasking system.  Empirical evidence suggests they may be gone now.
  ;;Should you decide you need to inhibit scheduling, do it around the
  ;;lcl:write-array.
  (declare (type display display)
	   (type buffer-bytes vector)
	   (type array-index start end))
  #.(declare-buffun)
  (let ((stream (display-output-stream display)))
    (declare (type (or null stream) stream))
    (unless (null stream) 
      (with-underlying-stream (stream stream display output)
	(lcl:write-array stream vector start end)))))

#+Minima
(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) 
      (minima:write-vector vector stream start end))))

dan's avatar
dan committed
(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)

(defun buffer-write-default (vector display start end)
  (declare (type buffer-bytes vector)
	   (type display display)
	   (type array-index start end))
  #.(declare-buffun)
  (sb-impl::output-raw-bytes (display-output-stream display) vector start end)
#+ecl
(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)

dan's avatar
dan committed
;;; 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 Genera explorer excl lcl3.0 Minima CMU sbcl)
(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

#+excl
(defun buffer-force-output-default (display)
  ;; buffer-write-default does the actual writing.
  (declare (ignore display)))

#-(or excl)
(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

#+excl
(defun buffer-close-default (display &key abort)
  ;; The default buffer close function for use with common-lisp streams
  (declare (type display display)
	   (ignore abort))
  #.(declare-buffun)
  (excl::filesys-checking-close (display-output-stream display)))

#-(or excl)
(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
;;; :TIMEOUT if it times out, NIL otherwise.

;;; The default implementation

;; Poll for input every *buffer-read-polling-time* SECONDS.
#-(or Genera explorer excl lcl3.0 CMU sbcl)
(defparameter *buffer-read-polling-time* 0.5)

#-(or Genera explorer excl lcl3.0 CMU sbcl)
(defun buffer-input-wait-default (display timeout)
  (declare (type display display)
	   (type (or null (real 0 *)) timeout))
  (declare (clx-values timeout))
  
  (let ((stream (display-input-stream display)))
    (declare (type (or null stream) stream))
    (cond ((null stream))
	  ((listen stream) nil)
	  ((and timeout (= timeout 0)) :timeout)
	  ((not (null timeout))
	   (multiple-value-bind (npoll fraction)
	       (truncate timeout *buffer-read-polling-time*)
	     (dotimes (i npoll)			; Sleep for a time, then listen again
	       (sleep *buffer-read-polling-time*)
	       (when (listen stream)
		 (return-from buffer-input-wait-default nil)))
	     (when (plusp fraction)
	       (sleep fraction)			; Sleep a fraction of a second
	       (when (listen stream)		; and listen one last time
		 (return-from buffer-input-wait-default nil)))
	     :timeout)))))

#+(or CMU sbcl)
(defun buffer-input-wait-default (display timeout)
  (declare (type display display)
	   (type (or null number) timeout))
  (let ((stream (display-input-stream display)))
    (declare (type (or null stream) stream))
    (cond ((null stream))
	  ((listen stream) nil)
	  ((eql timeout 0) :timeout)
	  (t
	   (if #+sbcl (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd stream)
						   :input timeout)
dan's avatar
dan committed
	       #+mp (mp:process-wait-until-fd-usable
		     (system:fd-stream-fd stream) :input timeout)
	       #-(or sbcl mp) (system:wait-until-fd-usable
			       (system:fd-stream-fd stream) :input timeout)
dan's avatar
dan committed
	       nil
	       :timeout)))))

#+Genera
(defun buffer-input-wait-default (display timeout)
  (declare (type display display)
	   (type (or null (real 0 *)) timeout))
  (declare (clx-values timeout))
  (let ((stream (display-input-stream display)))
    (declare (type (or null stream) stream))
    (cond ((null stream))
	  ((scl:send stream :listen) nil)
	  ((and timeout (= timeout 0)) :timeout)
	  ((null timeout) (si:stream-input-block stream "CLX Input"))
	  (t
	   (scl:condition-bind ((neti:protocol-timeout
				  #'(lambda (error)
				      (when (eq stream (scl:send error :stream))
					(return-from buffer-input-wait-default :timeout)))))
	     (neti:with-stream-timeout (stream :input timeout)
	       (si:stream-input-block stream "CLX Input")))))
    nil))

#+explorer
(defun buffer-input-wait-default (display timeout)
  (declare (type display display)
	   (type (or null (real 0 *)) timeout))
  (declare (clx-values timeout))
  (let ((stream (display-input-stream display)))
    (declare (type (or null stream) stream))
    (cond ((null stream))
	  ((zl:send stream :listen) nil)
	  ((and timeout (= timeout 0)) :timeout)
	  ((null timeout)
	   (si:process-wait "CLX Input" stream :listen))
	  (t
	   (unless (si:process-wait-with-timeout
		       "CLX Input" (round (* timeout 60.)) stream :listen)
	     (return-from buffer-input-wait-default :timeout))))
    nil))

#+excl
;;
;; This is used so an 'eq' test may be used to find out whether or not we can
;; safely throw this process out of the CLX read loop.
;;
(defparameter *read-whostate* "waiting for input from X server")

;;
;; Note that this function returns nil on error if the scheduler is running,
;; t on error if not.  This is ok since buffer-read will detect the error.
;;
#+excl
(defun buffer-input-wait-default (display timeout)
  (declare (type display display)
	   (type (or null (real 0 *)) timeout))
  (declare (clx-values timeout))
  (let ((fd (display-input-stream display)))
    (declare (fixnum fd))
    (when (>= fd 0)
      (cond ((fd-char-avail-p fd)
	     nil)
	    
	    ;; Otherwise no bytes were available on the socket
	    ((and timeout (= timeout 0))
	     ;; If there aren't enough and timeout == 0, timeout.
	     :timeout)
	  
	    ;; If the scheduler is running let it do timeouts.
	    (mp::*scheduler-stack-group*
	     #+allegro
	     (if (not
		  (mp:wait-for-input-available fd :whostate *read-whostate*
					       :wait-function #'fd-char-avail-p
					       :timeout timeout))
		 (return-from buffer-input-wait-default :timeout))
	     #-allegro
	     (mp::wait-for-input-available fd :whostate *read-whostate*
					   :wait-function #'fd-char-avail-p))
	    
	    ;; Otherwise we have to handle timeouts by hand, and call select()
	    ;; to block until input is available.  Note we don't really handle
	    ;; the interaction of interrupts and (numberp timeout) here.  XX
	    (t
	     (let ((res 0))
	       (declare (fixnum res))
	       (with-interrupt-checking-on
		(loop
		  (setq res (fd-wait-for-input fd (if (null timeout) 0
						    (truncate timeout))))
		  (cond ((plusp res)	; success
			 (return nil))
			((eq res 0)	; timeout
			 (return :timeout))
			((eq res -1)	; error
			 (return t))
			;; Otherwise we got an interrupt -- go around again.
			)))))))))

	   
#+lcl3.0
(defun buffer-input-wait-default (display timeout)
  (declare (type display display)
	   (type (or null (real 0 *)) timeout)
	   (clx-values timeout))
  #.(declare-buffun)
  (let ((stream (display-input-stream display)))
    (declare (type (or null stream) stream))
    (cond ((null stream))
	  ((listen stream) nil)
	  ((and timeout (= timeout 0)) :timeout)