Commit f42a0212 authored by mikel's avatar mikel
Browse files

Add support for modern Allegro CL. Should be good for versions >

darcs-hash:20060113053525-6497f-b5faed2ec4b18c47caa091c1dc5749c6fe16e1c1.gz
parent efac2980
......@@ -43,8 +43,9 @@
((:file "package")
(:file "depdefs")
(:file "clx")
#-(or openmcl) (:file "dependent")
#-(or openmcl allegro) (:file "dependent")
#+openmcl (:file "dep-openmcl")
#+allegro (:file "dep-allegro")
(:file "macros")
(:file "bufmac")
(:file "buffer")
......@@ -61,6 +62,8 @@
(:file "manager")
(:file "image")
(:file "resource")
#+allegro
(:file "excldep" :pathname "excldep.lisp")
(:module extensions
:pathname #.(make-pathname :directory '(:relative))
:components
......@@ -102,7 +105,6 @@
(:legacy-file "exclREADME")
(:legacy-file "exclcmac" :pathname "exclcmac.lisp")
(:legacy-file "excldepc" :pathname "excldep.c")
(:legacy-file "excldep" :pathname "excldep.lisp")
(:legacy-file "sockcl" :pathname "sockcl.lisp")
(:legacy-file "socket" :pathname "socket.c")
(:legacy-file "defsystem" :pathname "defsystem.lisp")
......
......@@ -36,11 +36,11 @@
(unless *display*
#+:cmu
(multiple-value-setq (*display* *screen*) (ext:open-clx-display))
#+sbcl
#+(or sbcl allegro)
(progn
(setf *display* (xlib::open-default-display))
(setf *screen* (xlib:display-default-screen *display*)))
#-(or cmu sbcl)
#-(or cmu sbcl allegro)
(progn
;; Portable method
(setf *display* (xlib:open-display (machine-instance)))
......
;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
;; 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)
(proclaim '(declaration array-register))
;;; The size of the output buffer. Must be a multiple of 4.
(defparameter *output-buffer-size* 8192)
;;; Number of seconds to wait for a reply to a server request
(defparameter *reply-timeout* nil)
#-(or clx-overlapping-arrays (not clx-little-endian))
(progn
(defconstant +word-0+ 0)
(defconstant +word-1+ 1)
(defconstant +long-0+ 0)
(defconstant +long-1+ 1)
(defconstant +long-2+ 2)
(defconstant +long-3+ 3))
#-(or clx-overlapping-arrays clx-little-endian)
(progn
(defconstant +word-0+ 1)
(defconstant +word-1+ 0)
(defconstant +long-0+ 3)
(defconstant +long-1+ 2)
(defconstant +long-2+ 1)
(defconstant +long-3+ 0))
;;; Set some compiler-options for often used code
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +buffer-speed+ #+clx-debugging 1 #-clx-debugging 3
"Speed compiler option for buffer code.")
(defconstant +buffer-safety+ #+clx-debugging 3 #-clx-debugging 0
"Safety compiler option for buffer code.")
(defconstant +buffer-debug+ #+clx-debugging 2 #-clx-debugging 1
"Debug compiler option for buffer code>")
(defun declare-bufmac ()
`(declare (optimize
(speed ,+buffer-speed+)
(safety ,+buffer-safety+)
(debug ,+buffer-debug+))))
;; It's my impression that in lucid there's some way to make a
;; declaration called fast-entry or something that causes a function
;; to not do some checking on args. Sadly, we have no lucid manuals
;; here. If such a declaration is available, it would be a good
;; idea to make it here when +buffer-speed+ is 3 and +buffer-safety+
;; is 0.
(defun declare-buffun ()
`(declare (optimize
(speed ,+buffer-speed+)
(safety ,+buffer-safety+)
(debug ,+buffer-debug+)))))
(declaim (inline card8->int8 int8->card8
card16->int16 int16->card16
card32->int32 int32->card32))
#-Genera
(progn
(defun card8->int8 (x)
(declare (type card8 x))
(declare (clx-values int8))
#.(declare-buffun)
(the int8 (if (logbitp 7 x)
(the int8 (- x #x100))
x)))
(defun int8->card8 (x)
(declare (type int8 x))
(declare (clx-values card8))
#.(declare-buffun)
(the card8 (ldb (byte 8 0) x)))
(defun card16->int16 (x)
(declare (type card16 x))
(declare (clx-values int16))
#.(declare-buffun)
(the int16 (if (logbitp 15 x)
(the int16 (- x #x10000))
x)))
(defun int16->card16 (x)
(declare (type int16 x))
(declare (clx-values card16))
#.(declare-buffun)
(the card16 (ldb (byte 16 0) x)))
(defun card32->int32 (x)
(declare (type card32 x))
(declare (clx-values int32))
#.(declare-buffun)
(the int32 (if (logbitp 31 x)
(the int32 (- x #x100000000))
x)))
(defun int32->card32 (x)
(declare (type int32 x))
(declare (clx-values card32))
#.(declare-buffun)
(the card32 (ldb (byte 32 0) x)))
)
(declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
#+(or excl lcl3.0 clx-overlapping-arrays)
(declaim (inline aref-card16 aref-int16 aref-card32 aref-int32 aref-card29
aset-card16 aset-int16 aset-card32 aset-int32 aset-card29))
#+(and clx-overlapping-arrays (not Genera))
(progn
(defun aref-card16 (a i)
(aref a i))
(defun aset-card16 (v a i)
(setf (aref a i) v))
(defun aref-int16 (a i)
(card16->int16 (aref a i)))
(defun aset-int16 (v a i)
(setf (aref a i) (int16->card16 v))
v)
(defun aref-card32 (a i)
(aref a i))
(defun aset-card32 (v a i)
(setf (aref a i) v))
(defun aref-int32 (a i)
(card32->int32 (aref a i)))
(defun aset-int32 (v a i)
(setf (aref a i) (int32->card32 v))
v)
(defun aref-card29 (a i)
(aref a i))
(defun aset-card29 (v a i)
(setf (aref a i) v))
)
#+excl
(progn
(defun aref-card8 (a i)
(declare (type buffer-bytes a)
(type array-index i))
(declare (clx-values card8))
#.(declare-buffun)
(the card8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:unsigned-byte)))
(defun aset-card8 (v a i)
(declare (type card8 v)
(type buffer-bytes a)
(type array-index i))
#.(declare-buffun)
(setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:unsigned-byte) v))
(defun aref-int8 (a i)
(declare (type buffer-bytes a)
(type array-index i))
(declare (clx-values int8))
#.(declare-buffun)
(the int8 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:signed-byte)))
(defun aset-int8 (v a i)
(declare (type int8 v)
(type buffer-bytes a)
(type array-index i))
#.(declare-buffun)
(setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:signed-byte) v))
(defun aref-card16 (a i)
(declare (type buffer-bytes a)
(type array-index i))
(declare (clx-values card16))
#.(declare-buffun)
(the card16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:unsigned-word)))
(defun aset-card16 (v a i)
(declare (type card16 v)
(type buffer-bytes a)
(type array-index i))
#.(declare-buffun)
(setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:unsigned-word) v))
(defun aref-int16 (a i)
(declare (type buffer-bytes a)
(type array-index i))
(declare (clx-values int16))
#.(declare-buffun)
(the int16 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:signed-word)))
(defun aset-int16 (v a i)
(declare (type int16 v)
(type buffer-bytes a)
(type array-index i))
#.(declare-buffun)
(setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:signed-word) v))
(defun aref-card32 (a i)
(declare (type buffer-bytes a)
(type array-index i))
(declare (clx-values card32))
#.(declare-buffun)
(the card32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:unsigned-long)))
(defun aset-card32 (v a i)
(declare (type card32 v)
(type buffer-bytes a)
(type array-index i))
#.(declare-buffun)
(setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:unsigned-long) v))
(defun aref-int32 (a i)
(declare (type buffer-bytes a)
(type array-index i))
(declare (clx-values int32))
#.(declare-buffun)
(the int32 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:signed-long)))
(defun aset-int32 (v a i)
(declare (type int32 v)
(type buffer-bytes a)
(type array-index i))
#.(declare-buffun)
(setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:signed-long) v))
(defun aref-card29 (a i)
(declare (type buffer-bytes a)
(type array-index i))
(declare (clx-values card29))
#.(declare-buffun)
(the card29 (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:unsigned-long)))
(defun aset-card29 (v a i)
(declare (type card29 v)
(type buffer-bytes a)
(type array-index i))
#.(declare-buffun)
(setf (sys:memref a #.(sys::mdparam 'comp::md-lvector-data0-norm) i
:unsigned-long) v))
)
(defsetf aref-card8 (a i) (v)
`(aset-card8 ,v ,a ,i))
(defsetf aref-int8 (a i) (v)
`(aset-int8 ,v ,a ,i))
(defsetf aref-card16 (a i) (v)
`(aset-card16 ,v ,a ,i))
(defsetf aref-int16 (a i) (v)
`(aset-int16 ,v ,a ,i))
(defsetf aref-card32 (a i) (v)
`(aset-card32 ,v ,a ,i))
(defsetf aref-int32 (a i) (v)
`(aset-int32 ,v ,a ,i))
(defsetf aref-card29 (a i) (v)
`(aset-card29 ,v ,a ,i))
;;; Other random conversions
(defun rgb-val->card16 (value)
;; Short floats are good enough
(declare (type rgb-val value))
(declare (clx-values card16))
#.(declare-buffun)
;; Convert VALUE from float to card16
(the card16 (values (round (the rgb-val value) #.(/ 1.0s0 #xffff)))))
(defun card16->rgb-val (value)
;; Short floats are good enough
(declare (type card16 value))
(declare (clx-values short-float))
#.(declare-buffun)
;; Convert VALUE from card16 to float
(the short-float (* (the card16 value) #.(/ 1.0s0 #xffff))))
(defun radians->int16 (value)
;; Short floats are good enough
(declare (type angle value))
(declare (clx-values int16))
#.(declare-buffun)
(the int16 (values (round (the angle value) #.(float (/ pi 180.0s0 64.0s0) 0.0s0)))))
(defun int16->radians (value)
;; Short floats are good enough
(declare (type int16 value))
(declare (clx-values short-float))
#.(declare-buffun)
(the short-float (* (the int16 value) #.(coerce (/ pi 180.0 64.0) 'short-float))))
#+(or cmu sbcl) (progn
;;; This overrides the (probably incorrect) definition in clx.lisp. Since PI
;;; is irrational, there can't be a precise rational representation. In
;;; particular, the different float approximations will always be /=. This
;;; causes problems with type checking, because people might compute an
;;; argument in any precision. What we do is discard all the excess precision
;;; in the value, and see if the protocol encoding falls in the desired range
;;; (64'ths of a degree.)
;;;
(deftype angle () '(satisfies anglep))
(defun anglep (x)
(and (typep x 'real)
(<= (* -360 64) (radians->int16 x) (* 360 64))))
)
;;-----------------------------------------------------------------------------
;; Character transformation
;;-----------------------------------------------------------------------------
;;; This stuff transforms chars to ascii codes in card8's and back.
;;; You might have to hack it a little to get it to work for your machine.
(declaim (inline char->card8 card8->char))
(macrolet ((char-translators ()
(let ((alist
`(#-lispm
;; The normal ascii codes for the control characters.
,@`((#\Return . 13)
(#\Linefeed . 10)
(#\Rubout . 127)
(#\Page . 12)
(#\Tab . 9)
(#\Backspace . 8)
(#\Newline . 10)
(#\Space . 32))
;; One the lispm, #\Newline is #\Return, but we'd really like
;; #\Newline to translate to ascii code 10, so we swap the
;; Ascii codes for #\Return and #\Linefeed. We also provide
;; mappings from the counterparts of these control characters
;; so that the character mapping from the lisp machine
;; character set to ascii is invertible.
#+lispm
,@`((#\Return . 10) (,(code-char 10) . ,(char-code #\Return))
(#\Linefeed . 13) (,(code-char 13) . ,(char-code #\Linefeed))
(#\Rubout . 127) (,(code-char 127) . ,(char-code #\Rubout))
(#\Page . 12) (,(code-char 12) . ,(char-code #\Page))
(#\Tab . 9) (,(code-char 9) . ,(char-code #\Tab))
(#\Backspace . 8) (,(code-char 8) . ,(char-code #\Backspace))
(#\Newline . 10) (,(code-char 10) . ,(char-code #\Newline))
(#\Space . 32) (,(code-char 32) . ,(char-code #\Space)))
;; The rest of the common lisp charater set with the normal
;; ascii codes for them.
(#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36)
(#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40)
(#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44)
(#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48)
(#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52)
(#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56)
(#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60)
(#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64)
(#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68)
(#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72)
(#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76)
(#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80)
(#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84)
(#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88)
(#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92)
(#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96)
(#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100)
(#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104)
(#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108)
(#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112)
(#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116)
(#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120)
(#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124)
(#\} . 125) (#\~ . 126))))
(cond ((dolist (pair alist nil)
(when (not (= (char-code (car pair)) (cdr pair)))
(return t)))
`(progn
(defconstant *char-to-card8-translation-table*
',(let ((array (make-array
(let ((max-char-code 255))
(dolist (pair alist)
(setq max-char-code
(max max-char-code
(char-code (car pair)))))
(1+ max-char-code))
:element-type 'card8)))
(dotimes (i (length array))
(setf (aref array i) (mod i 256)))
(dolist (pair alist)
(setf (aref array (char-code (car pair)))
(cdr pair)))
array))
(defconstant *card8-to-char-translation-table*
',(let ((array (make-array 256)))
(dotimes (i (length array))
(setf (aref array i) (code-char i)))
(dolist (pair alist)
(setf (aref array (cdr pair)) (car pair)))
array))
#-Genera
(progn
(defun char->card8 (char)
(declare (type base-char char))
#.(declare-buffun)
(the card8 (aref (the (simple-array card8 (*))
*char-to-card8-translation-table*)
(the array-index (char-code char)))))
(defun card8->char (card8)
(declare (type card8 card8))
#.(declare-buffun)
(the base-char
(or (aref (the simple-vector *card8-to-char-translation-table*)
card8)
(error "Invalid CHAR code ~D." card8))))
)
#+Genera
(progn
(defun char->card8 (char)
(declare lt:(side-effects reader reducible))
(aref *char-to-card8-translation-table* (char-code char)))
(defun card8->char (card8)
(declare lt:(side-effects reader reducible))
(aref *card8-to-char-translation-table* card8))
)
#-Minima
(dotimes (i 256)
(unless (= i (char->card8 (card8->char i)))
(warn "The card8->char mapping is not invertible through char->card8. Info:~%~S"
(list i
(card8->char i)
(char->card8 (card8->char i))))
(return nil)))
#-Minima
(dotimes (i (length *char-to-card8-translation-table*))
(let ((char (code-char i)))
(unless (eql char (card8->char (char->card8 char)))
(warn "The char->card8 mapping is not invertible through card8->char. Info:~%~S"
(list char
(char->card8 char)
(card8->char (char->card8 char))))
(return nil))))))
(t
`(progn
(defun char->card8 (char)
(declare (type base-char char))
#.(declare-buffun)
(the card8 (char-code char)))
(defun card8->char (card8)
(declare (type card8 card8))
#.(declare-buffun)
(the base-char (code-char card8)))
))))))
(char-translators))
;;-----------------------------------------------------------------------------
;; Process Locking
;;
;; Common-Lisp doesn't provide process locking primitives, so we define
;; our own here, based on Zetalisp primitives. Holding-Lock is very
;; similar to with-lock on The TI Explorer, and a little more efficient
;; than with-process-lock on a Symbolics.
;;-----------------------------------------------------------------------------
;;; MAKE-PROCESS-LOCK: Creating a process lock.
#+excl
(defun make-process-lock (name)
(mp:make-process-lock :name name))
;;; HOLDING-LOCK: Execute a body of code with a lock held.
;;; The holding-lock macro takes a timeout keyword argument. EVENT-LISTEN
;;; passes its timeout to the holding-lock macro, so any timeout you want to
;;; work for event-listen you should do for holding-lock.
;; If you're not sharing DISPLAY objects within a multi-processing
;; shared-memory environment, this is sufficient
;;; HOLDING-LOCK for CMU Common Lisp.
;;;
;;; We are not multi-processing, but we use this macro to try to protect
;;; against re-entering request functions. This can happen if an interrupt
;;; occurs and the handler attempts to use X over the same display connection.
;;; This can happen if the GC hooks are used to notify the user over the same
;;; display connection. We inhibit GC notifications since display of them
;;; could cause recursive entry into CLX.
;;;
;;; HOLDING-LOCK for CMU Common Lisp with multi-processes.
;;;
#+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 (sys:scheduler-running-p) ; 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