Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

694 lines (583 sloc) 23.686 kB
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
;; This file contains some of the system dependent code for CLX
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
;;;-------------------------------------------------------------------------
;;; Declarations
;;;-------------------------------------------------------------------------
;;; fix a bug in kcl's RATIONAL...
;;; redefine both the function and the type.
#+(or kcl ibcl)
(progn
(defun rational (x)
(if (rationalp x)
x
(lisp:rational x)))
(deftype rational (&optional l u) `(lisp:rational ,l ,u)))
;;; DECLAIM
#-clx-ansi-common-lisp
(defmacro declaim (&rest decl-specs)
(if (cdr decl-specs)
`(progn
,@(mapcar #'(lambda (decl-spec) `(proclaim ',decl-spec))
decl-specs))
`(proclaim ',(car decl-specs))))
;;; CLX-VALUES value1 value2 ... -- Documents the values returned by the function.
#-Genera
(declaim (declaration clx-values))
#+Genera
(setf (get 'clx-values 'si:declaration-alias) 'scl:values)
;;; ARGLIST arg1 arg2 ... -- Documents the arglist of the function. Overrides
;;; the documentation that might get generated by the real arglist of the
;;; function.
#-(or lispm lcl3.0)
(declaim (declaration arglist))
;;; DYNAMIC-EXTENT var -- Tells the compiler that the rest arg var has
;;; dynamic extent and therefore can be kept on the stack and not copied to
;;; the heap, even though the value is passed out of the function.
#-(or clx-ansi-common-lisp lcl3.0)
(declaim (declaration dynamic-extent))
;;; IGNORABLE var -- Tells the compiler that the variable might or might not be used.
#-clx-ansi-common-lisp
(declaim (declaration ignorable))
;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
;;; indent calls to the function or macro containing the declaration.
#-genera
(declaim (declaration indentation))
;;;-------------------------------------------------------------------------
;;; Declaration macros
;;;-------------------------------------------------------------------------
;;; WITH-VECTOR (variable type) &body body --- ensures the variable is a local
;;; and then does a type declaration and array register declaration
(defmacro with-vector ((var type) &body body)
`(let ((,var ,var))
(declare (type ,type ,var))
,@body))
;;; WITHIN-DEFINITION (name type) &body body --- Includes definitions for
;;; Meta-.
#+lispm
(defmacro within-definition ((name type) &body body)
`(zl:local-declare
((sys:function-parent ,name ,type))
(sys:record-source-file-name ',name ',type)
,@body))
#-lispm
(defmacro within-definition ((name type) &body body)
(declare (ignore name type))
`(progn ,@body))
;;;-------------------------------------------------------------------------
;;; CLX can maintain a mapping from X server ID's to local data types. If
;;; one takes the view that CLX objects will be instance variables of
;;; objects at the next higher level, then PROCESS-EVENT will typically map
;;; from resource-id to higher-level object. In that case, the lower-level
;;; CLX mapping will almost never be used (except in rare cases like
;;; query-tree), and only serve to consume space (which is difficult to
;;; GC), in which case always-consing versions of the make-<mumble>s will
;;; be better. Even when maps are maintained, it isn't clear they are
;;; useful for much beyond xatoms and windows (since almost nothing else
;;; ever comes back in events).
;;;--------------------------------------------------------------------------
(defconstant +clx-cached-types+
'(drawable
window
pixmap
;; gcontext
cursor
colormap
font))
(defmacro resource-id-map-test ()
#+excl '#'equal
#-excl '#'eql)
; (eq fixnum fixnum) is not guaranteed.
(defmacro atom-cache-map-test ()
#+excl '#'equal
#-excl '#'eq)
(defmacro keysym->character-map-test ()
#+excl '#'equal
#-excl '#'eql)
;;; You must define this to match the real byte order. It is used by
;;; overlapping array and image code.
#+(or lispm vax little-endian Minima)
(eval-when (eval compile load)
(pushnew :clx-little-endian *features*))
#+lcl3.0
(eval-when (compile eval load)
(ecase lucid::machine-endian
(:big nil)
(:little (pushnew :clx-little-endian *features*))))
#+cmu
(eval-when (compile eval load)
(ecase #.(c:backend-byte-order c:*backend*)
(:big-endian)
(:little-endian (pushnew :clx-little-endian *features*))))
#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
;; FIXME: Ideally, we shouldn't end up with the internal
;; :CLX-LITTLE-ENDIAN decorating user-visible *FEATURES* lists.
;; This probably wants to be split up into :compile-toplevel
;; :execute and :load-toplevel clauses, so that loading the compiled
;; code doesn't push the feature.
(ecase sb-c:*backend-byte-order*
(:big-endian)
(:little-endian (pushnew :clx-little-endian *features*))))
;;; Steele's Common-Lisp states: "It is an error if the array specified
;;; as the :displaced-to argument does not have the same :element-type
;;; as the array being created" If this is the case on your lisp, then
;;; leave the overlapping-arrays feature turned off. Lisp machines
;;; (Symbolics TI and LMI) don't have this restriction, and allow arrays
;;; with different element types to overlap. CLX will take advantage of
;;; this to do fast array packing/unpacking when the overlapping-arrays
;;; feature is enabled.
#+clisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless system::*big-endian* (pushnew :clx-little-endian *features*)))
#+(and clx-little-endian lispm)
(eval-when (eval compile load)
(pushnew :clx-overlapping-arrays *features*))
#+(and clx-overlapping-arrays genera)
(progn
(deftype overlap16 () '(unsigned-byte 16))
(deftype overlap32 () '(signed-byte 32))
)
#+(and clx-overlapping-arrays (or explorer lambda cadr))
(progn
(deftype overlap16 () '(unsigned-byte 16))
(deftype overlap32 () '(unsigned-byte 32))
)
(deftype buffer-bytes () `(simple-array (unsigned-byte 8) (*)))
#+clx-overlapping-arrays
(progn
(deftype buffer-words () `(vector overlap16))
(deftype buffer-longs () `(vector overlap32))
)
;;; This defines a type which is a subtype of the integers.
;;; This type is used to describe all variables that can be array indices.
;;; It is here because it is used below.
;;; This is inclusive because start/end can be 1 past the end.
(deftype array-index () `(integer 0 ,array-dimension-limit))
;; this is the best place to define these?
#-Genera
(progn
(defun make-index-typed (form)
(if (constantp form) form `(the array-index ,form)))
(defun make-index-op (operator args)
`(the array-index
(values
,(case (length args)
(0 `(,operator))
(1 `(,operator
,(make-index-typed (first args))))
(2 `(,operator
,(make-index-typed (first args))
,(make-index-typed (second args))))
(otherwise
`(,operator
,(make-index-op operator (subseq args 0 (1- (length args))))
,(make-index-typed (first (last args)))))))))
(defmacro index+ (&rest numbers) (make-index-op '+ numbers))
(defmacro index-logand (&rest numbers) (make-index-op 'logand numbers))
(defmacro index-logior (&rest numbers) (make-index-op 'logior numbers))
(defmacro index- (&rest numbers) (make-index-op '- numbers))
(defmacro index* (&rest numbers) (make-index-op '* numbers))
(defmacro index1+ (number) (make-index-op '1+ (list number)))
(defmacro index1- (number) (make-index-op '1- (list number)))
(defmacro index-incf (place &optional (delta 1))
(make-index-op 'incf (list place delta)))
(defmacro index-decf (place &optional (delta 1))
(make-index-op 'decf (list place delta)))
(defmacro index-min (&rest numbers) (make-index-op 'min numbers))
(defmacro index-max (&rest numbers) (make-index-op 'max numbers))
(defmacro index-floor (number divisor)
(make-index-op 'floor (list number divisor)))
(defmacro index-ceiling (number divisor)
(make-index-op 'ceiling (list number divisor)))
(defmacro index-truncate (number divisor)
(make-index-op 'truncate (list number divisor)))
(defmacro index-mod (number divisor)
(make-index-op 'mod (list number divisor)))
(defmacro index-ash (number count)
(make-index-op 'ash (list number count)))
(defmacro index-plusp (number) `(plusp (the array-index ,number)))
(defmacro index-zerop (number) `(zerop (the array-index ,number)))
(defmacro index-evenp (number) `(evenp (the array-index ,number)))
(defmacro index-oddp (number) `(oddp (the array-index ,number)))
(defmacro index> (&rest numbers)
`(> ,@(mapcar #'make-index-typed numbers)))
(defmacro index= (&rest numbers)
`(= ,@(mapcar #'make-index-typed numbers)))
(defmacro index< (&rest numbers)
`(< ,@(mapcar #'make-index-typed numbers)))
(defmacro index>= (&rest numbers)
`(>= ,@(mapcar #'make-index-typed numbers)))
(defmacro index<= (&rest numbers)
`(<= ,@(mapcar #'make-index-typed numbers)))
)
#+Genera
(progn
(defmacro index+ (&rest numbers) `(+ ,@numbers))
(defmacro index-logand (&rest numbers) `(logand ,@numbers))
(defmacro index-logior (&rest numbers) `(logior ,@numbers))
(defmacro index- (&rest numbers) `(- ,@numbers))
(defmacro index* (&rest numbers) `(* ,@numbers))
(defmacro index1+ (number) `(1+ ,number))
(defmacro index1- (number) `(1- ,number))
(defmacro index-incf (place &optional (delta 1)) `(setf ,place (index+ ,place ,delta)))
(defmacro index-decf (place &optional (delta 1)) `(setf ,place (index- ,place ,delta)))
(defmacro index-min (&rest numbers) `(min ,@numbers))
(defmacro index-max (&rest numbers) `(max ,@numbers))
(defun positive-power-of-two-p (x)
(when (symbolp x)
(multiple-value-bind (constantp value) (lt:named-constant-p x)
(when constantp (setq x value))))
(and (typep x 'fixnum) (plusp x) (zerop (logand x (1- x)))))
(defmacro index-floor (number divisor)
(cond ((eql divisor 1) number)
((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor))
`(si:%fixnum-floor ,number ,divisor))
(t `(floor ,number ,divisor))))
(defmacro index-ceiling (number divisor)
(cond ((eql divisor 1) number)
((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-ceiling))
`(si:%fixnum-ceiling ,number ,divisor))
(t `(ceiling ,number ,divisor))))
(defmacro index-truncate (number divisor)
(cond ((eql divisor 1) number)
((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-floor))
`(si:%fixnum-floor ,number ,divisor))
(t `(truncate ,number ,divisor))))
(defmacro index-mod (number divisor)
(cond ((and (positive-power-of-two-p divisor) (fboundp 'si:%fixnum-mod))
`(si:%fixnum-mod ,number ,divisor))
(t `(mod ,number ,divisor))))
(defmacro index-ash (number count)
(cond ((eql count 0) number)
((and (typep count 'fixnum) (minusp count) (fboundp 'si:%fixnum-floor))
`(si:%fixnum-floor ,number ,(expt 2 (- count))))
((and (typep count 'fixnum) (plusp count) (fboundp 'si:%fixnum-multiply))
`(si:%fixnum-multiply ,number ,(expt 2 count)))
(t `(ash ,number ,count))))
(defmacro index-plusp (number) `(plusp ,number))
(defmacro index-zerop (number) `(zerop ,number))
(defmacro index-evenp (number) `(evenp ,number))
(defmacro index-oddp (number) `(oddp ,number))
(defmacro index> (&rest numbers) `(> ,@numbers))
(defmacro index= (&rest numbers) `(= ,@numbers))
(defmacro index< (&rest numbers) `(< ,@numbers))
(defmacro index>= (&rest numbers) `(>= ,@numbers))
(defmacro index<= (&rest numbers) `(<= ,@numbers))
)
;;;; Stuff for BUFFER definition
(defconstant +replysize+ 32.)
;; used in defstruct initializations to avoid compiler warnings
(defvar *empty-bytes* (make-sequence 'buffer-bytes 0))
(declaim (type buffer-bytes *empty-bytes*))
#+clx-overlapping-arrays
(progn
(defvar *empty-words* (make-sequence 'buffer-words 0))
(declaim (type buffer-words *empty-words*))
)
#+clx-overlapping-arrays
(progn
(defvar *empty-longs* (make-sequence 'buffer-longs 0))
(declaim (type buffer-longs *empty-longs*))
)
(defstruct (reply-buffer (:conc-name reply-) (:constructor make-reply-buffer-internal)
(:copier nil) (:predicate nil))
(size 0 :type array-index) ;Buffer size
;; Byte (8 bit) input buffer
(ibuf8 *empty-bytes* :type buffer-bytes)
;; Word (16bit) input buffer
#+clx-overlapping-arrays
(ibuf16 *empty-words* :type buffer-words)
;; Long (32bit) input buffer
#+clx-overlapping-arrays
(ibuf32 *empty-longs* :type buffer-longs)
(next nil #-explorer :type #-explorer (or null reply-buffer))
(data-size 0 :type array-index)
)
(defconstant +buffer-text16-size+ 256)
(deftype buffer-text16 () `(simple-array (unsigned-byte 16) (,+buffer-text16-size+)))
;; These are here because.
(defparameter *xlib-package* (find-package :xlib))
(defun xintern (&rest parts)
(intern (apply #'concatenate 'string (mapcar #'string parts)) *xlib-package*))
(defparameter *keyword-package* (find-package :keyword))
(defun kintern (name)
(intern (string name) *keyword-package*))
;;; Pseudo-class mechanism.
(eval-when (:compile-toplevel :load-toplevel :execute)
;; FIXME: maybe we should reevaluate this?
(defvar *def-clx-class-use-defclass*
#+(or Genera allegro) t
#+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP)
#+(and cmu (not pcl)) nil
#-(or Genera cmu allegro) nil
"Controls whether DEF-CLX-CLASS uses DEFCLASS.
If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of
type names for which DEFCLASS should be used. If it is not a list,
then DEFCLASS is always used. If it is NIL, then DEFCLASS is never
used, since NIL is the empty list.")
)
(defmacro def-clx-class ((name &rest options) &body slots)
(if (or (not (listp *def-clx-class-use-defclass*))
(member name *def-clx-class-use-defclass*))
(let ((clos-package #+clx-ansi-common-lisp
(find-package :common-lisp)
#-clx-ansi-common-lisp
(or (find-package :clos)
(find-package :pcl)
(let ((lisp-pkg (find-package :lisp)))
(and (find-symbol (string 'defclass) lisp-pkg)
lisp-pkg))))
(constructor t)
(constructor-args t)
(include nil)
(print-function nil)
(copier t)
(predicate t))
(dolist (option options)
(ecase (pop option)
(:constructor
(setf constructor (pop option))
(setf constructor-args (if (null option) t (pop option))))
(:include
(setf include (pop option)))
(:print-function
(setf print-function (pop option)))
(:copier
(setf copier (pop option)))
(:predicate
(setf predicate (pop option)))))
(flet ((cintern (&rest symbols)
(intern (apply #'concatenate 'simple-string
(mapcar #'symbol-name symbols))
*package*))
(kintern (symbol)
(intern (symbol-name symbol) (find-package :keyword)))
(closintern (symbol)
(intern (symbol-name symbol) clos-package)))
(when (eq constructor t)
(setf constructor (cintern 'make- name)))
(when (eq copier t)
(setf copier (cintern 'copy- name)))
(when (eq predicate t)
(setf predicate (cintern name '-p)))
(when include
(setf slots (append (get include 'def-clx-class) slots)))
(let* ((n-slots (length slots))
(slot-names (make-list n-slots))
(slot-initforms (make-list n-slots))
(slot-types (make-list n-slots)))
(dotimes (i n-slots)
(let ((slot (elt slots i)))
(setf (elt slot-names i) (pop slot))
(setf (elt slot-initforms i) (pop slot))
(setf (elt slot-types i) (getf slot :type t))))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',name 'def-clx-class) ',slots))
;; From here down are the system-specific expansions:
(within-definition (,name def-clx-class)
(,(closintern 'defclass)
,name ,(and include `(,include))
(,@(map 'list
#'(lambda (slot-name slot-initform slot-type)
`(,slot-name
:initform ,slot-initform :type ,slot-type
:accessor ,(cintern name '- slot-name)
,@(when (and constructor
(or (eq constructor-args t)
(member slot-name
constructor-args)))
`(:initarg ,(kintern slot-name)))
))
slot-names slot-initforms slot-types)))
,(when constructor
(if (eq constructor-args t)
`(defun ,constructor (&rest args)
(apply #',(closintern 'make-instance)
',name args))
`(defun ,constructor ,constructor-args
(,(closintern 'make-instance) ',name
,@(mapcan #'(lambda (slot-name)
(and (member slot-name slot-names)
`(,(kintern slot-name) ,slot-name)))
constructor-args)))))
,(when predicate
#+allegro
`(progn
(,(closintern 'defmethod) ,predicate (object)
(declare (ignore object))
nil)
(,(closintern 'defmethod) ,predicate ((object ,name))
t))
#-allegro
`(defun ,predicate (object)
(typep object ',name)))
,(when copier
`(,(closintern 'defmethod) ,copier ((.object. ,name))
(,(closintern 'with-slots) ,slot-names .object.
(,(closintern 'make-instance) ',name
,@(mapcan #'(lambda (slot-name)
`(,(kintern slot-name) ,slot-name))
slot-names)))))
,(when print-function
`(,(closintern 'defmethod)
,(closintern 'print-object)
((object ,name) stream)
(,print-function object stream 0))))))))
`(within-definition (,name def-clx-class)
(defstruct (,name ,@options)
,@slots))))
#+Genera
(progn
(scl:defprop def-clx-class "CLX Class" si:definition-type-name)
(scl:defprop def-clx-class zwei:defselect-function-spec-finder
zwei:definition-function-spec-finder))
;; We need this here so we can define DISPLAY for CLX.
;;
;; This structure is :INCLUDEd in the DISPLAY structure.
;; Overlapping (displaced) arrays are provided for byte
;; half-word and word access on both input and output.
;;
(def-clx-class (buffer (:constructor nil) (:copier nil) (:predicate nil))
;; Lock for multi-processing systems
(lock (make-process-lock "CLX Buffer Lock"))
#-excl (output-stream nil :type (or null stream))
#+excl (output-stream -1 :type fixnum)
;; Buffer size
(size 0 :type array-index)
(request-number 0 :type (unsigned-byte 16))
;; Byte position of start of last request
;; used for appending requests and error recovery
(last-request nil :type (or null array-index))
;; Byte position of start of last flushed request
(last-flushed-request nil :type (or null array-index))
;; Current byte offset
(boffset 0 :type array-index)
;; Byte (8 bit) output buffer
(obuf8 *empty-bytes* :type buffer-bytes)
;; Word (16bit) output buffer
#+clx-overlapping-arrays
(obuf16 *empty-words* :type buffer-words)
;; Long (32bit) output buffer
#+clx-overlapping-arrays
(obuf32 *empty-longs* :type buffer-longs)
;; Holding buffer for 16-bit text
(tbuf16 (make-sequence 'buffer-text16 +buffer-text16-size+ :initial-element 0))
;; Probably EQ to Output-Stream
#-excl (input-stream nil :type (or null stream))
#+excl (input-stream -1 :type fixnum)
;; T when the host connection has gotten errors
(dead nil :type (or null (not null)))
;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited.
(flush-inhibit nil :type (or null (not null)))
;; Change these functions when using shared memory buffers to the server
;; Function to call when writing the buffer
(write-function 'buffer-write-default)
;; Function to call when flushing the buffer
(force-output-function 'buffer-force-output-default)
;; Function to call when closing a connection
(close-function 'buffer-close-default)
;; Function to call when reading the buffer
(input-function 'buffer-read-default)
;; Function to call to wait for data to be input
(input-wait-function 'buffer-input-wait-default)
;; Function to call to listen for input data
(listen-function 'buffer-listen-default)
#+Genera (debug-io nil :type (or null stream))
)
;;-----------------------------------------------------------------------------
;; Printing routines.
;;-----------------------------------------------------------------------------
#-(or clx-ansi-common-lisp Genera)
(defun print-unreadable-object-function (object stream type identity function)
(declare #+lispm
(sys:downward-funarg function))
(princ "#<" stream)
(when type
(let ((type (type-of object))
(pcl-package (find-package :pcl)))
;; Handle pcl type-of lossage
(when (and pcl-package
(symbolp type)
(eq (symbol-package type) pcl-package)
(string-equal (symbol-name type) "STD-INSTANCE"))
(setq type
(funcall (intern (symbol-name 'class-name) pcl-package)
(funcall (intern (symbol-name 'class-of) pcl-package)
object))))
(prin1 type stream)))
(when (and type function) (princ " " stream))
(when function (funcall function))
(when (and (or type function) identity) (princ " " stream))
(when identity (princ "???" stream))
(princ ">" stream)
nil)
#-(or clx-ansi-common-lisp Genera)
(defmacro print-unreadable-object
((object stream &key type identity) &body body)
(if body
`(flet ((.print-unreadable-object-body. () ,@body))
(print-unreadable-object-function
,object ,stream ,type ,identity #'.print-unreadable-object-body.))
`(print-unreadable-object-function ,object ,stream ,type ,identity nil)))
;;-----------------------------------------------------------------------------
;; Image stuff
;;-----------------------------------------------------------------------------
(defconstant +image-bit-lsb-first-p+
#+clx-little-endian t
#-clx-little-endian nil)
(defconstant +image-byte-lsb-first-p+
#+clx-little-endian t
#-clx-little-endian nil)
(defconstant +image-unit+ 32)
(defconstant +image-pad+ 32)
;;-----------------------------------------------------------------------------
;; Foreign Functions
;;-----------------------------------------------------------------------------
#+(and lucid apollo (not lcl3.0))
(lucid::define-foreign-function '(connect-to-server "connect_to_server")
'((:val host :string)
(:val display :integer32))
:integer32)
#+(and lucid (not apollo) (not lcl3.0))
(lucid::define-c-function connect-to-server (host display)
:result-type :integer)
#+lcl3.0
(lucid::def-foreign-function
(connect-to-server
(:language :c)
(:return-type :signed-32bit))
(host :simple-string)
(display :signed-32bit))
;;-----------------------------------------------------------------------------
;; Finding the server socket
;;-----------------------------------------------------------------------------
;; These are here because dep-openmcl.lisp and dependent.lisp both need them
(defconstant +X-unix-socket-path+
"/tmp/.X11-unix/X"
"The location of the X socket")
(defun unix-socket-path-from-host (host display)
"Return the name of the unix domain socket for host and display, or
nil if a network socket should be opened."
(cond ((or (string= host "") (string= host "unix"))
(format nil "~A~D" +X-unix-socket-path+ display))
#+darwin
((and (> (length host) 10) (string= host "tmp/launch" :end1 10))
(format nil "/~A:~D" host display))
(t nil)))
Jump to Line
Something went wrong with that request. Please try again.