Skip to content
Snippets Groups Projects
dependent.lisp 133 KiB
Newer Older
dan's avatar
dan committed
	  ((with-underlying-stream (stream stream display input)
	     (lucid::waiting-for-input-from-stream stream
               (lucid::with-io-unlocked
		 (if (null timeout)
		     (lcl:process-wait "CLX Input" #'listen stream)
		   (lcl:process-wait-with-timeout
		     "CLX Input" timeout #'listen stream)))))
	   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.
#-(or excl)
(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))))

#+excl 
(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
;;;----------------------------------------------------------------------------

;;
;; WITH-STACK-LIST is used by WITH-STATE as a memory saving feature.
;; If your lisp doesn't have stack-lists, and you're worried about
;; consing garbage, you may want to re-write this to allocate and
;; initialize lists from a resource.
;;
#-lispm
(defmacro with-stack-list ((var &rest elements) &body body)
  ;; SYNTAX: (WITH-STACK-LIST (var exp1 ... expN) body)
  ;; Equivalent to (LET ((var (MAPCAR #'EVAL '(exp1 ... expN)))) body)
  ;; except that the list produced by MAPCAR resides on the stack and
  ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
  `(let ((,var (list ,@elements)))
     (declare (type cons ,var)
	      #+clx-ansi-common-lisp (dynamic-extent ,var))
     ,@body))

#-lispm
(defmacro with-stack-list* ((var &rest elements) &body body)
  ;; SYNTAX: (WITH-STACK-LIST* (var exp1 ... expN) body)
  ;; Equivalent to (LET ((var (APPLY #'LIST* (MAPCAR #'EVAL '(exp1 ... expN))))) body)
  ;; except that the list produced by MAPCAR resides on the stack and
  ;; therefore DISAPPEARS when WITH-STACK-LIST is exited.
  `(let ((,var (list* ,@elements)))
     (declare (type cons ,var)
	      #+clx-ansi-common-lisp (dynamic-extent ,var))
     ,@body))

(declaim (inline buffer-replace))

#+lispm
(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
  (declare (type vector buf1 buf2)
	   (type array-index start1 end1 start2))
  (sys:copy-array-portion buf2 start2 (length buf2) buf1 start1 end1))

#+excl
(defun buffer-replace (target-sequence source-sequence target-start
				       target-end &optional (source-start 0))
  (declare (type buffer-bytes target-sequence source-sequence)
	   (type array-index target-start target-end source-start)
	   (optimize (speed 3) (safety 0)))
  
  (let ((source-end (length source-sequence)))
    (declare (type array-index source-end))
    
    (excl:if* (and (eq target-sequence source-sequence)
		   (> target-start source-start))
       then (let ((nelts (min (- target-end target-start)
			      (- source-end source-start))))
	      (do ((target-index (+ target-start nelts -1) (1- target-index))
		   (source-index (+ source-start nelts -1) (1- source-index)))
		  ((= target-index (1- target-start)) target-sequence)
		(declare (type array-index target-index source-index))
		
		(setf (aref target-sequence target-index)
		  (aref source-sequence source-index))))
       else (do ((target-index target-start (1+ target-index))
		 (source-index source-start (1+ source-index)))
		((or (= target-index target-end) (= source-index source-end))
		 target-sequence)
	      (declare (type array-index target-index source-index))

	      (setf (aref target-sequence target-index)
		(aref source-sequence source-index))))))

dan's avatar
dan committed
(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
  (declare (type buffer-bytes buf1 buf2)
	   (type array-index start1 end1 start2))
  #.(declare-buffun)
  (kernel:bit-bash-copy
   buf2 (+ (* start2 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
	   (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits))
   buf1 (+ (* start1 #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)
	   (* vm:vector-data-offset #+cmu vm:word-bits #+sbcl sb-vm:n-word-bits))
   (* (- end1 start1) #+cmu vm:byte-bits #+sbcl sb-vm:n-byte-bits)))

#+lucid
;;;The compiler is *supposed* to optimize calls to replace, but in actual
;;;fact it does not.
(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
  (declare (type buffer-bytes buf1 buf2)
	   (type array-index start1 end1 start2))
  #.(declare-buffun)
  (let ((end2 (lucid::%simple-8bit-vector-length buf2)))
    (declare (type array-index end2))
    (lucid::simple-8bit-vector-replace-internal
      buf1 buf2 start1 end1 start2 end2)))

#+(and clx-overlapping-arrays (not (or lispm excl)))
(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
  (declare (type vector buf1 buf2)
	   (type array-index start1 end1 start2))
  (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))

#-(or lispm lucid excl CMU clx-overlapping-arrays)
dan's avatar
dan committed
(defun buffer-replace (buf1 buf2 start1 end1 &optional (start2 0))
  (declare (type buffer-bytes buf1 buf2)
	   (type array-index start1 end1 start2))
  (replace buf1 buf2 :start1 start1 :end1 end1 :start2 start2))

#+ti
(defun with-location-bindings (sys:&quote bindings &rest body)
  (do ((bindings bindings (cdr bindings)))
      ((null bindings)
       (sys:eval-body-as-progn body))
    (sys:bind (sys:*eval `(sys:locf ,(caar bindings)))
	      (sys:*eval (cadar bindings)))))

#+ti
(compiler:defoptimizer with-location-bindings with-l-b-compiler nil (form)
  (let ((bindings (cadr form))
	(body (cddr form)))
    `(let ()
       ,@(loop for (accessor value) in bindings
	       collect `(si:bind (si:locf ,accessor) ,value))
       ,@body)))

#+ti
(defun (:property with-location-bindings compiler::cw-handler) (exp)
  (let* ((bindlist (mapcar #'compiler::cw-clause (second exp)))
	 (body (compiler::cw-clause (cddr exp))))
    (and compiler::cw-return-expansion-flag
	 (list* (first exp) bindlist body))))

#+(and lispm (not ti))
(defmacro with-location-bindings (bindings &body body)
  `(sys:letf* ,bindings ,@body))

#+lispm
(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
				  &body body)
  ;; don't use svref on LHS because Symbolics didn't define locf for it
  (let* ((local-state (gensym))
	 (bindings `(((aref ,local-state ,ts-index) 0))))	; will become zero anyway
    (dolist (index indexes)
      (push `((aref ,local-state ,index) (svref ,saved-state ,index))
	    bindings))
    `(let ((,local-state (gcontext-local-state ,gc)))
       (declare (type gcontext-state ,local-state))
       (unwind-protect
	   (with-location-bindings ,bindings
	     ,@body)
	 (setf (svref ,local-state ,ts-index) 0)
	 (when ,temp-gc
	   (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
	 (deallocate-gcontext-state ,saved-state)))))

#-lispm
(defmacro with-gcontext-bindings ((gc saved-state indexes ts-index temp-mask temp-gc)
				  &body body)
  (let ((local-state (gensym))
	(resets nil))
    (dolist (index indexes)
      (push `(setf (svref ,local-state ,index) (svref ,saved-state ,index))
	    resets))
    `(unwind-protect
	 (progn
	   ,@body)
       (let ((,local-state (gcontext-local-state ,gc)))
	 (declare (type gcontext-state ,local-state))
	 ,@resets
	 (setf (svref ,local-state ,ts-index) 0))
       (when ,temp-gc
	 (restore-gcontext-temp-state ,gc ,temp-mask ,temp-gc))
       (deallocate-gcontext-state ,saved-state))))

;;;----------------------------------------------------------------------------
;;; How much error detection should CLX do?
dan's avatar
dan committed
;;; Several levels are possible:
;;;
;;; 1. Do the equivalent of check-type on every argument.
;;; 
;;; 2. Simply report TYPE-ERROR.  This eliminates overhead of all the format
;;;    strings generated by check-type.
;;; 
;;; 3. Do error checking only on arguments that are likely to have errors
;;;    (like keyword names)
;;; 
;;; 4. Do error checking only where not doing so may dammage the envirnment
;;;    on a non-tagged machine (i.e. when storing into a structure that has
;;;    been passed in)
;;; 
;;; 5. No extra error detection code.  On lispm's, ASET may barf trying to
;;;    store a non-integer into a number array. 
;;; 
;;; How extensive should the error checking be?  For example, if the server
;;; expects a CARD16, is is sufficient for CLX to check for integer, or
;;; should it also check for non-negative and less than 65536?
;;;----------------------------------------------------------------------------
 
csr21's avatar
csr21 committed
;; The +TYPE-CHECK?+ constant controls how much error checking is done.
dan's avatar
dan committed
;; Possible values are:
;;    NIL      - Don't do any error checking
;;    t        - Do the equivalent of checktype on every argument
;;    :minimal - Do error checking only where errors are likely

;;; This controls macro expansion, and isn't changable at run-time You will
;;; probably want to set this to nil if you want good performance at
;;; production time.
csr21's avatar
csr21 committed
(defconstant +type-check?+
dan's avatar
dan committed
  #+(or Genera Minima CMU sbcl) nil
  #-(or Genera Minima CMU sbcl) t)

;; TYPE? is used to allow the code to do error checking at a different level from
;; the declarations.  It also does some optimizations for systems that don't have
;; good compiler support for TYPEP.  The definitions for CARD32, CARD16, INT16, etc.
;; include range checks.  You can modify TYPE? to do less extensive checking
;; for these types if you desire.

;;
;; ### This comment is a lie!  TYPE? is really also used for run-time type
;; dispatching, not just type checking.  -- Ram.

(defmacro type? (object type)
  #+(or cmu sbcl)
  `(typep ,object ,type)
  #-(or cmu sbcl)
  (if (not (constantp type))
      `(typep ,object ,type)
    (progn
      (setq type (eval type))
      #+(or Genera explorer Minima)
csr21's avatar
csr21 committed
      (if +type-check?+
dan's avatar
dan committed
	  `(locally (declare (optimize safety)) (typep ,object ',type))
	`(typep ,object ',type))
      #-(or Genera explorer Minima)
      (let ((predicate (assoc type
			      '((drawable drawable-p) (window window-p)
				(pixmap pixmap-p) (cursor cursor-p)
				(font font-p) (gcontext gcontext-p)
				(colormap colormap-p) (null null)
				(integer integerp)))))
	(cond (predicate
	       `(,(second predicate) ,object))
	      ((eq type 'generalized-boolean)
	       't)			; Everything is a generalized-boolean.
csr21's avatar
csr21 committed
	      (+type-check?+
dan's avatar
dan committed
	       `(locally (declare (optimize safety)) (typep ,object ',type)))
	      (t
	       `(typep ,object ',type)))))))

;; X-TYPE-ERROR is the function called for type errors.
;; If you want lots of checking, but are concerned about code size,
;; this can be made into a macro that ignores some parameters.

(defun x-type-error (object type &optional error-string)
  (x-error 'x-type-error
	   :datum object
	   :expected-type type
	   :type-string error-string))


;;-----------------------------------------------------------------------------
;; Error handlers
;;    Hack up KMP error signaling using zetalisp until the real thing comes 
;;    along
;;-----------------------------------------------------------------------------

(defun default-error-handler (display error-key &rest key-vals
			      &key asynchronous &allow-other-keys)
  (declare (type generalized-boolean asynchronous)
	   (dynamic-extent key-vals))
  ;; The default display-error-handler.
  ;; It signals the conditions listed in the DISPLAY file.
  (if asynchronous
      (apply #'x-cerror "Ignore" error-key :display display :error-key error-key key-vals)
      (apply #'x-error error-key :display display :error-key error-key key-vals)))

#+(and lispm (not Genera) (not clx-ansi-common-lisp))
(defun x-error (condition &rest keyargs)
  (apply #'sys:signal condition keyargs))

#+(and lispm (not Genera) (not clx-ansi-common-lisp))
(defun x-cerror (proceed-format-string condition &rest keyargs)
  (sys:signal (apply #'zl:make-condition condition keyargs)
	      :proceed-types proceed-format-string))

#+(and Genera (not clx-ansi-common-lisp))
(defun x-error (condition &rest keyargs)
  (declare (dbg:error-reporter))
  (apply #'sys:signal condition keyargs))

#+(and Genera (not clx-ansi-common-lisp))
(defun x-cerror (proceed-format-string condition &rest keyargs)
  (declare (dbg:error-reporter))
  (apply #'sys:signal condition :continue-format-string proceed-format-string keyargs))

#+(or clx-ansi-common-lisp excl lcl3.0 (and CMU mp))
(defun x-error (condition &rest keyargs)
  (declare (dynamic-extent keyargs))
  (apply #'error condition keyargs))

#+(or clx-ansi-common-lisp excl lcl3.0 CMU)
dan's avatar
dan committed
(defun x-cerror (proceed-format-string condition &rest keyargs)
  (declare (dynamic-extent keyargs))
  (apply #'cerror proceed-format-string condition keyargs))

;;; X-ERROR for CMU Common Lisp
;;;
;;; We detect a couple condition types for which we disable event handling in
;;; our system.  This prevents going into the debugger or returning to a
;;; command prompt with CLX repeatedly seeing the same condition.  This occurs
;;; because CMU Common Lisp provides for all events (that is, X, input on file
;;; descriptors, Mach messages, etc.) to come through one routine anyone can
;;; use to wait for input.
;;;
#+(and CMU (not mp)) 
dan's avatar
dan committed
(defun x-error (condition &rest keyargs)
  (let ((condx (apply #'make-condition condition keyargs)))
    (when (eq condition 'closed-display)
      (let ((disp (closed-display-display condx)))
	(warn "Disabled event handling on ~S." disp)
	(ext::disable-clx-event-handling disp)))
    (error condx)))

#-(or lispm ansi-common-lisp excl lcl3.0 CMU sbcl)
(defun x-error (condition &rest keyargs)
  (error "X-Error: ~a"
	 (princ-to-string (apply #'make-condition condition keyargs))))

#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
(defun x-cerror (proceed-format-string condition &rest keyargs)
  (cerror proceed-format-string "X-Error: ~a"
	 (princ-to-string (apply #'make-condition condition keyargs))))

;; version 15 of Pitman error handling defines the syntax for define-condition to be:
;; DEFINE-CONDITION name (parent-type) [({slot}*) {option}*]
;; Where option is one of: (:documentation doc-string) (:conc-name symbol-or-string)
;; or (:report exp)

#+lcl3.0 
(defmacro define-condition (name parent-types &optional slots &rest args)
  `(lcl:define-condition
     ,name (,(first parent-types))
     ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
	      slots)
     ,@args))

#+(and excl (not clx-ansi-common-lisp))
(defmacro define-condition (name parent-types &optional slots &rest args)
  `(excl::define-condition
     ,name (,(first parent-types))
     ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
	      slots)
     ,@args))

#+(and CMU (not clx-ansi-common-lisp))
(defmacro define-condition (name parent-types &optional slots &rest args)
  `(common-lisp:define-condition
     ,name (,(first parent-types))
     ,(mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
	      slots)
     ,@args))

#+(and lispm (not clx-ansi-common-lisp))
(defmacro define-condition (name parent-types &body options)
  (let ((slot-names
	  (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
		  (pop options)))
	(documentation nil)
	(conc-name (concatenate 'string (string name) "-"))	       
	(reporter nil))
    (dolist (item options)
      (ecase (first item)
	(:documentation (setq documentation (second item)))
	(:conc-name (setq conc-name (string (second item))))
	(:report (setq reporter (second item)))))
    `(within-definition (,name define-condition)
       (zl:defflavor ,name ,slot-names ,parent-types
	 :initable-instance-variables
	 #-Genera
	 (:accessor-prefix ,conc-name)
	 #+Genera
	 (:conc-name ,conc-name)
	 #-Genera
	 (:outside-accessible-instance-variables ,@slot-names)
	 #+Genera
	 (:readable-instance-variables ,@slot-names))
       ,(when reporter ;; when no reporter, parent's is inherited
	  `(zl:defmethod #-Genera (,name :report)
	                 #+Genera (dbg:report ,name) (stream)
	      ,(if (stringp reporter)
		   `(write-string ,reporter stream)
		 `(,reporter global:self stream))
	      global:self))
       (zl:compile-flavor-methods ,name)
       ,(when documentation
	  `(setf (documentation name 'type) ,documentation))
       ',name)))

#+(and lispm (not Genera) (not clx-ansi-common-lisp))
(zl:defflavor x-error () (global:error))

#+(and Genera (not clx-ansi-common-lisp))
(scl:defflavor x-error
	((dbg:proceed-types '(:continue))	;
	 continue-format-string)
	(sys:error)
  (:initable-instance-variables continue-format-string))

#+(and Genera (not clx-ansi-common-lisp))
(scl:defmethod (scl:make-instance x-error) (&rest ignore)
  (when (not (sys:variable-boundp continue-format-string))
    (setf dbg:proceed-types (remove :continue dbg:proceed-types))))

#+(and Genera (not clx-ansi-common-lisp))
(scl:defmethod (dbg:proceed x-error :continue) ()
  :continue)

#+(and Genera (not clx-ansi-common-lisp))
(sys:defmethod (dbg:document-proceed-type x-error :continue) (stream)
  (format stream continue-format-string))

#+(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
(define-condition x-error (error) ())

#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
(defstruct x-error
  report-function)

#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
(defmacro define-condition (name parent-types &body options)
  ;; Define a structure that when printed displays an error message
  (flet ((reporter-for-condition (name)
	   (xintern "." name '-reporter.)))
    (let ((slot-names
	    (mapcar #'(lambda (slot) (if (consp slot) (car slot) slot))
		    (pop options)))
	  (documentation nil)
	  (conc-name (concatenate 'string (string name) "-"))	       
	  (reporter nil)
	  (condition (gensym))
	  (stream (gensym))
	  (report-function (reporter-for-condition name)))
      (dolist (item options)
	(ecase (first item)
	  (:documentation (setq documentation (second item)))
	  (:conc-name (setq conc-name (string (second item))))
	  (:report (setq reporter (second item)))))
      (unless reporter
	(setq report-function (reporter-for-condition (first parent-types))))
      `(within-definition (,name define-condition)
	 (defstruct (,name (:conc-name ,(intern conc-name))
		     (:print-function condition-print)
		     (:include ,(first parent-types)
		      (report-function ',report-function)))
	   ,@slot-names)
	 ,(when documentation
	    `(setf (documentation name 'type) ,documentation))
	 ,(when reporter
	    `(defun ,report-function (,condition ,stream)
	       ,(if (stringp reporter)
		    `(write-string ,reporter ,stream)
		  `(,reporter ,condition ,stream))
	       ,condition))
	 ',name))))

#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
(defun condition-print (condition stream depth)
  (declare (type x-error condition)
	   (type stream stream)
	   (ignore depth))
  (if *print-escape*
      (print-unreadable-object (condition stream :type t))
    (funcall (x-error-report-function condition) condition stream))
  condition)
  
#-(or lispm clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
(defun make-condition (type &rest slot-initializations)
  (declare (dynamic-extent slot-initializations))
  (let ((make-function (intern (concatenate 'string (string 'make-) (string type))
			       (symbol-package type))))
    (apply make-function slot-initializations)))

#-(or clx-ansi-common-lisp excl lcl3.0 CMU sbcl)
(define-condition type-error (x-error)
  ((datum :reader type-error-datum :initarg :datum)
   (expected-type :reader type-error-expected-type :initarg :expected-type))
  (:report
    (lambda (condition stream)
      (format stream "~s isn't a ~a"
	      (type-error-datum condition)
	      (type-error-expected-type condition)))))


;;-----------------------------------------------------------------------------
;;  HOST hacking
;;-----------------------------------------------------------------------------

#-(or explorer Genera Minima Allegro CMU sbcl ecl)
dan's avatar
dan committed
(defun host-address (host &optional (family :internet))
  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
  ;; and cdr is a list of network address bytes.
  (declare (type stringable host)
	   (type (or null (member :internet :decnet :chaos) card8) family))
  (declare (clx-values list))
  host family
  (error "HOST-ADDRESS not implemented yet."))

#+explorer
(defun host-address (host &optional (family :internet))
  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
  ;; and cdr is a list of network address bytes.
  (declare (type stringable host)
	   (type (or null (member :internet :decnet :chaos) card8) family))
  (declare (clx-values list))
  (ecase family
    ((:internet nil 0)
     (let ((addr (ip:get-ip-address host)))
       (unless addr (error "~s isn't an internet host name" host))
       (list :internet
	     (ldb (byte 8 24) addr)
	     (ldb (byte 8 16) addr)
	     (ldb (byte 8 8) addr)
	     (ldb (byte 8 0) addr))))
    ((:chaos 2)
     (let ((addr (first (chaos:chaos-addresses host))))
       (unless addr (error "~s isn't a chaos host name" host))
       (list :chaos
	     (ldb (byte 8 0) addr)
	     (ldb (byte 8 8) addr))))))

#+Genera
(defun host-address (host &optional (family :internet))
  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
  ;; and cdr is a list of network address bytes.
  (declare (type stringable host)
	   (type (or null (member :internet :decnet :chaos) card8) family))
  (declare (clx-values list))
  (setf host (string host))
  (let ((net-type (ecase family
		    ((:internet nil 0) :internet)
		    ((:DECnet 1) :dna)
		    ((:chaos 2) :chaos))))
    (dolist (addr
	      (sys:send (net:parse-host host) :network-addresses)
	      (error "~S isn't a valid ~(~A~) host name" host family))
      (let ((network (car addr))
	    (address (cadr addr)))
	(when (sys:send network :network-typep net-type)
	  (return (ecase family
		    ((:internet nil 0)
		     (multiple-value-bind (a b c d) (tcp:explode-internet-address address)
		       (list :internet a b c d)))
		    ((:DECnet 1)
		     (list :DECnet (ldb (byte 8 0) address) (ldb (byte 8 8) address)))
		    ((:chaos 2)
		     (list :chaos (ldb (byte 8 0) address) (ldb (byte 8 8) address))))))))))

#+Minima
(defun host-address (host &optional (family :internet))
  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
  ;; and cdr is a list of network address bytes.
  (declare (type stringable host)
	   (type (or null (member :internet :decnet :chaos) card8) family))
  (declare (clx-values list))
  (etypecase family
    ((:internet nil 0)
      (list* :internet
	     (multiple-value-list
	       (minima:ip-address-components (minima:parse-ip-address (string host))))))))

#+Allegro
(defun host-address (host &optional (family :internet))
  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
  ;; and cdr is a list of network address bytes.
  (declare (type stringable host)
	   (type (or null (member :internet :decnet :chaos) card8) family))
  (declare (clx-values list))
  (labels ((no-host-error ()
	     (error "Unknown host ~S" host))
	   (no-address-error ()
	     (error "Host ~S has no ~S address" host family)))
    (let ((hostent 0))
      (unwind-protect
	   (progn
	     (setf hostent (ipc::gethostbyname (string host)))
	     (when (zerop hostent)
	       (no-host-error))
	     (ecase family
	       ((:internet nil 0)
		(unless (= (ipc::hostent-addrtype hostent) 2)
		  (no-address-error))
		(assert (= (ipc::hostent-length hostent) 4))
		(let ((addr (ipc::hostent-addr hostent)))
		   (when (or (member comp::.target.
				     '(:hp :sgi4d :sony :dec3100)
				     :test #'eq)
			     (probe-file "/lib/ld.so"))
		     ;; BSD 4.3 based systems require an extra indirection
		     (setq addr (si:memref-int addr 0 0 :unsigned-long)))
		  (list :internet
			(si:memref-int addr 0 0 :unsigned-byte)
			(si:memref-int addr 1 0 :unsigned-byte)
			(si:memref-int addr 2 0 :unsigned-byte)
			(si:memref-int addr 3 0 :unsigned-byte))))))
	(ff:free-cstruct hostent)))))

;#+sbcl
;(require :sockets)

dan's avatar
dan committed
(defun host-address (host &optional (family :internet))
  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
  ;; and cdr is a list of network address bytes.
  (declare (type stringable host)
	   (type (or null (member :internet :decnet :chaos) card8) family))
  (declare (clx-values list))
  (labels ((no-host-error ()
	     (error "Unknown host ~S" host))
	   (no-address-error ()
	     (error "Host ~S has no ~S address" host family)))
    (let ((hostent #+rwi-sockets(ext:lookup-host-entry (string host))
		   #+mna-sockets(net.sbcl.sockets:look-up-host-entry
				 (string host)) 
		   #+db-sockets(sockets:get-host-by-name (string host))))
      (when (not hostent)
	(no-host-error))
      (ecase family
	((:internet nil 0)
	 #+rwi-sockets(unless (= (ext::host-entry-addr-type hostent) 2)
			(no-address-error))
	 #+mna-sockets(unless (= (net.sbcl.sockets::host-entry-addr-type hostent) 2)
			(no-address-error))
	 ;; the following form is for use with SBCL and Daniel
	 ;; Barlow's socket package
	 #+db-sockets(unless (sockets:host-ent-address hostent)
	   (no-address-error))
	 (append (list :internet)
		 #+rwi-sockets
		 (let ((addr (first (ext::host-entry-addr-list hostent))))
			(list (ldb (byte 8 24) addr)
			      (ldb (byte 8 16) addr)
			      (ldb (byte 8  8) addr)
			      (ldb (byte 8  0) addr)))
		 #+mna-sockets
		 (let ((addr (first (net.sbcl.sockets::host-entry-addr-list hostent))))
				(list (ldb (byte 8 24) addr)
				      (ldb (byte 8 16) addr)
				      (ldb (byte 8  8) addr)
				      (ldb (byte 8  0) addr)))
		 ;; the following form is for use with SBCL and Daniel
		 ;; Barlow's socket package
		 #+db-sockets(coerce (sockets:host-ent-address hostent)
				     'list)))))))

#+sbcl
(defun host-address (host &optional (family :internet))
  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
  ;; and cdr is a list of network address bytes.
  (declare (type stringable host)
	   (type (or null (member :internet :decnet :chaos) card8) family))
  (declare (clx-values list))
  (let ((hostent (get-host-by-name (string host))))
    (ecase family
      ((:internet nil 0)
       (cons :internet (coerce (host-ent-address hostent) 'list))))))
dan's avatar
dan committed

#+ecl
(defun host-address (host &optional (family :internet))
  ;; Return a list whose car is the family keyword (:internet :DECnet :Chaos)
  ;; and cdr is a list of network address bytes.
  (declare (type stringable host)
	   (type (or null (member :internet :decnet :chaos) card8) family))
  (declare (clx-values list))
  (labels ((no-host-error ()
	     (error "Unknown host ~S" host)))
    (let ((addr (first (nth-value 3 (si::lookup-host-entry (string host))))))
      (unless addr
	(no-host-error))
      (list :internet
	    (ldb (byte 8 24) addr)
	    (ldb (byte 8 16) addr)
	    (ldb (byte 8  8) addr)
	    (ldb (byte 8  0) addr)))))

dan's avatar
dan committed
#+explorer ;; This isn't required, but it helps make sense of the results from access-hosts
(defun get-host (host-object)
  ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
  ;; and cdr is a list of network address bytes.
  (declare (type list host-object))
  (declare (clx-values string family))
  (let* ((family (first host-object))
	 (address (ecase family
		    (:internet
		     (dpb (second host-object)
			  (byte 8 24)
			  (dpb (third host-object)
			       (byte 8 16)
			       (dpb (fourth host-object)
				    (byte 8 8)
				    (fifth host-object)))))
		    (:chaos
		     (dpb (third host-object) (byte 8 8) (second host-object))))))
    (when (eq family :internet) (setq family :ip))
    (let ((host (si:get-host-from-address address family)))
      (values (and host (funcall host :name)) family))))

;;; This isn't required, but it helps make sense of the results from access-hosts
#+Genera
(defun get-host (host-object)
  ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
  ;; and cdr is a list of network address bytes.
  (declare (type list host-object))
  (declare (clx-values string family))
  (let ((family (first host-object)))
    (values (sys:send (net:get-host-from-address 
			(ecase family
			  (:internet
			    (apply #'tcp:build-internet-address (rest host-object)))
			  ((:chaos :DECnet)
			   (dpb (third host-object) (byte 8 8) (second host-object))))
			(net:local-network-of-type (if (eq family :DECnet)
						       :DNA
						       family)))
		      :name)
	    family)))

;;; This isn't required, but it helps make sense of the results from access-hosts
#+Minima
(defun get-host (host-object)
  ;; host-object is a list whose car is the family keyword (:internet :DECnet :Chaos)
  ;; and cdr is a list of network address bytes.
  (declare (type list host-object))
  (declare (clx-values string family))
  (let ((family (first host-object)))
    (values (ecase family
	      (:internet
		(minima:ip-address-string
		  (apply #'minima:make-ip-address (rest host-object)))))
	    family)))


;;-----------------------------------------------------------------------------
;; Whether to use closures for requests or not.
;;-----------------------------------------------------------------------------

;;; If this macro expands to non-NIL, then request and locking code is
;;; compiled in a much more compact format, as the common code is shared, and
;;; the specific code is built into a closure that is funcalled by the shared
;;; code.  If your compiler makes efficient use of closures then you probably
;;; want to make this expand to T, as it makes the code more compact.

(defmacro use-closures ()
  #+(or lispm Minima) t
  #-(or lispm Minima) nil)

#+(or Genera Minima)
(defun clx-macroexpand (form env)
  (declare (ignore env))
  form)

#-(or Genera Minima)
(defun clx-macroexpand (form env)
  (macroexpand form env))


;;-----------------------------------------------------------------------------
;; Resource stuff
;;-----------------------------------------------------------------------------


;;; Utilities 

(defun getenv (name)
  #+excl (sys:getenv name)
  #+lcl3.0 (lcl:environment-variable name)
  #+CMU (cdr (assoc name ext:*environment-list* :test #'string=))
  #+ecl (si:getenv name)
  #-(or sbcl excl lcl3.0 CMU ecl) (progn name nil))
dan's avatar
dan committed

(defun get-host-name ()
  "Return the same hostname as gethostname(3) would"
  ;; machine-instance probably works on a lot of lisps, but clisp is not
  ;; one of them
  #+(or cmu sbcl) (machine-instance)
  ;; resources-pathname was using short-site-name for this purpose
  #+excl (short-site-name)
  #+ecl (si:getenv "HOST")
  #-(or excl cmu sbcl ecl) (error "get-host-name not implemented"))
dan's avatar
dan committed
(defun homedir-file-pathname (name)
  (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
       (merge-pathnames (user-homedir-pathname) (pathname name))))

;;; DEFAULT-RESOURCES-PATHNAME - The pathname of the resources file to load if
;;; a resource manager isn't running.

(defun default-resources-pathname ()
  (homedir-file-pathname ".Xdefaults"))

;;; RESOURCES-PATHNAME - The pathname of the resources file to load after the
;;; defaults have been loaded.

(defun resources-pathname ()
  (or (let ((string (getenv "XENVIRONMENT")))
	(and string
	     (pathname string)))
      (homedir-file-pathname
       (concatenate 'string ".Xdefaults-" (get-host-name)))))
dan's avatar
dan committed

;;; AUTHORITY-PATHNAME - The pathname of the authority file.

(defun authority-pathname ()
  (or (let ((xauthority (getenv "XAUTHORITY")))
	(and xauthority
	     (pathname xauthority)))
      (homedir-file-pathname ".Xauthority")))

;;; this particular defaulting behaviour is typical to most Unices, I think
#+unix
(defun get-default-display (&optional display-name)
  "Parse the argument DISPLAY-NAME, or the environment variable $DISPLAY
if it is NIL.  Display names have the format

  [protocol/] [hostname] : [:] displaynumber [.screennumber]

There are two special cases in parsing, to match that done in the Xlib
C language bindings

 - If the hostname is ``unix'' or the empty string, any supplied
   protocol is ignored and a connection is made using the :local
   transport.

 - If a double colon separates hostname from displaynumber, the
   protocol is assumed to be decnet.

Returns a list of (host display-number screen protocol)."
  (let* ((name (or display-name
		   (getenv "DISPLAY")
		   (error "DISPLAY environment variable is not set")))
	 (slash-i (or (position #\/ name) -1))
	 (colon-i (position #\: name :start (1+ slash-i)))
	 (decnet-colon-p (eql (elt name (1+ colon-i)) #\:))
	 (host (subseq name (1+ slash-i) colon-i))
	 (dot-i (and colon-i (position #\. name :start colon-i)))
	 (display (when colon-i
		    (parse-integer name
				   :start (if decnet-colon-p
					      (+ colon-i 2)
					      (1+ colon-i))
				   :end dot-i)))
	 (screen (when dot-i
		   (parse-integer name :start (1+ dot-i))))
	 (protocol
	  (cond ((or (string= host "") (string-equal host "unix")) :local)
		(decnet-colon-p :decnet)
		((> slash-i -1) (intern
				 (string-upcase (subseq name 0 slash-i))
				 :keyword))
		(t :internet))))
    (list host (or display 0) (or screen 0) protocol)))

dan's avatar
dan committed

;;-----------------------------------------------------------------------------
;; GC stuff
;;-----------------------------------------------------------------------------

(defun gc-cleanup ()
  (declare (special *event-free-list*
		    *pending-command-free-list*
		    *reply-buffer-free-lists*
		    *gcontext-local-state-cache*
		    *temp-gcontext-cache*))
  (setq *event-free-list* nil)
  (setq *pending-command-free-list* nil)
  (when (boundp '*reply-buffer-free-lists*)
    (fill *reply-buffer-free-lists* nil))
  (setq *gcontext-local-state-cache* nil)
  (setq *temp-gcontext-cache* nil)
  nil)

#+Genera
(si:define-gc-cleanup clx-cleanup ("CLX Cleanup")
  (gc-cleanup))


;;-----------------------------------------------------------------------------
;; WITH-STANDARD-IO-SYNTAX equivalent, used in (SETF WM-COMMAND)
;;-----------------------------------------------------------------------------

#-(or clx-ansi-common-lisp Genera CMU sbcl)
(defun with-standard-io-syntax-function (function)
  (declare #+lispm
	   (sys:downward-funarg function))
  (let ((*package* (find-package :user))
	(*print-array* t)
	(*print-base* 10)
	(*print-case* :upcase)
	(*print-circle* nil)
	(*print-escape* t)
	(*print-gensym* t)
	(*print-length* nil)
	(*print-level* nil)
	(*print-pretty* nil)
	(*print-radix* nil)
	(*read-base* 10)
	(*read-default-float-format* 'single-float)
	(*read-suppress* nil)
	#+ticl (ticl:*print-structure* t)
	#+lucid (lucid::*print-structure* t))
    (funcall function)))

#-(or clx-ansi-common-lisp Genera CMU sbcl)
(defmacro with-standard-io-syntax (&body body)
  `(flet ((.with-standard-io-syntax-body. () ,@body))
     (with-standard-io-syntax-function #'.with-standard-io-syntax-body.)))


;;-----------------------------------------------------------------------------
;; DEFAULT-KEYSYM-TRANSLATE
;;-----------------------------------------------------------------------------

;;; If object is a character, char-bits are set from state.
;;;
;;; [the following isn't implemented (should it be?)]
;;; If object is a list, it is an alist with entries:
;;; (base-char [modifiers] [mask-modifiers])
;;; When MODIFIERS are specified, this character translation
;;; will only take effect when the specified modifiers are pressed.
;;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
;;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
;;; In ambiguous cases, the most specific translation is used.

#-(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl)
(defun default-keysym-translate (display state object)
  (declare (type display display)
	   (type card16 state)
	   (type t object)
	   (clx-values t)
	   (special left-meta-keysym right-meta-keysym
		    left-super-keysym right-super-keysym
		    left-hyper-keysym right-hyper-keysym))
  (when (characterp object)
csr21's avatar
csr21 committed
    (when (logbitp (position :control +state-mask-vector+) state)
dan's avatar
dan committed
      (setf (char-bit object :control) 1))
    (when (or (state-keysymp display state left-meta-keysym)
	      (state-keysymp display state right-meta-keysym))
      (setf (char-bit object :meta) 1))
    (when (or (state-keysymp display state left-super-keysym)
	      (state-keysymp display state right-super-keysym))
      (setf (char-bit object :super) 1))
    (when (or (state-keysymp display state left-hyper-keysym)
	      (state-keysymp display state right-hyper-keysym))
      (setf (char-bit object :hyper) 1)))
  object)

#+(or (and clx-ansi-common-lisp (not lispm) (not allegro)) CMU sbcl)
(defun default-keysym-translate (display state object)
  (declare (type display display)
	   (type card16 state)
	   (type t object)
	   (ignore display state)
	   (clx-values t))
  object)


;;-----------------------------------------------------------------------------
;; Image stuff