├── .cvsignore ├── .gitignore ├── doc ├── s01.ps.Z ├── s02.ps.Z ├── s03.ps.Z ├── s04.ps.Z ├── s05.ps.Z ├── s06.ps.Z ├── s07.ps.Z ├── s08.ps.Z ├── s09.ps.Z ├── s10.ps.Z ├── s11.ps.Z ├── s12.ps.Z ├── s13.ps.Z ├── s14.ps.Z ├── s15.ps.Z ├── s16.ps.Z ├── appa.ps.Z ├── types.ps.Z ├── contents.ps.Z ├── general.ps.Z ├── glossary.ps.Z ├── condition.ps.Z ├── functions.ps.Z └── README ├── makeclx.cl ├── demo ├── bezier.cl ├── README ├── zoid.cl ├── hello.cl ├── beziertest.cl └── menu.cl ├── provide.cl ├── MITdist ├── README ├── Makefile └── excldep.cl ├── debug ├── debug.cl ├── util.cl ├── event-test.cl ├── keytrans.cl └── trace.cl ├── test ├── trapezoid.cl └── image.cl ├── NEWCHANGES ├── excldep.c ├── generalock.cl ├── ms-patch.uu ├── README ├── sockcl.cl ├── socket.c ├── bufmac.cl ├── excldep.cl ├── Makefile ├── exclcmac.cl ├── fonts.cl ├── CHANGES └── keysyms.cl /.cvsignore: -------------------------------------------------------------------------------- 1 | *.tmp 2 | *.out 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.so 2 | *.dylib 3 | /clx.tmp 4 | /runlisp.out 5 | -------------------------------------------------------------------------------- /doc/s01.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s01.ps.Z -------------------------------------------------------------------------------- /doc/s02.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s02.ps.Z -------------------------------------------------------------------------------- /doc/s03.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s03.ps.Z -------------------------------------------------------------------------------- /doc/s04.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s04.ps.Z -------------------------------------------------------------------------------- /doc/s05.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s05.ps.Z -------------------------------------------------------------------------------- /doc/s06.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s06.ps.Z -------------------------------------------------------------------------------- /doc/s07.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s07.ps.Z -------------------------------------------------------------------------------- /doc/s08.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s08.ps.Z -------------------------------------------------------------------------------- /doc/s09.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s09.ps.Z -------------------------------------------------------------------------------- /doc/s10.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s10.ps.Z -------------------------------------------------------------------------------- /doc/s11.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s11.ps.Z -------------------------------------------------------------------------------- /doc/s12.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s12.ps.Z -------------------------------------------------------------------------------- /doc/s13.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s13.ps.Z -------------------------------------------------------------------------------- /doc/s14.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s14.ps.Z -------------------------------------------------------------------------------- /doc/s15.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s15.ps.Z -------------------------------------------------------------------------------- /doc/s16.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/s16.ps.Z -------------------------------------------------------------------------------- /doc/appa.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/appa.ps.Z -------------------------------------------------------------------------------- /doc/types.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/types.ps.Z -------------------------------------------------------------------------------- /doc/contents.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/contents.ps.Z -------------------------------------------------------------------------------- /doc/general.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/general.ps.Z -------------------------------------------------------------------------------- /doc/glossary.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/glossary.ps.Z -------------------------------------------------------------------------------- /doc/condition.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/condition.ps.Z -------------------------------------------------------------------------------- /doc/functions.ps.Z: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/franzinc/clx/HEAD/doc/functions.ps.Z -------------------------------------------------------------------------------- /doc/README: -------------------------------------------------------------------------------- 1 | This directory contains the CLX Programmer's Reference Manual, in 2 | Postscript format (roughly 230 pages). 3 | 4 | For convenience, the sections can be printed separately as follows: 5 | 6 | contents.ps ; Cover, table of contents 7 | s01.ps ; Introduction to CLX 8 | s02.ps ; Displays 9 | s03.ps ; Screens 10 | s04.ps ; Windows and pixmaps 11 | s05.ps ; Graphics contexts 12 | s06.ps ; Graphic operations 13 | s07.ps ; Images 14 | s08.ps ; Fonts and characters 15 | s09.ps ; Colors 16 | s10.ps ; Cursors 17 | s11.ps ; Atoms, properties, and selections 18 | s12.ps ; Events and input 19 | s13.ps ; Resources 20 | s14.ps ; Control functions 21 | s15.ps ; Extensions 22 | s16.ps ; Errors 23 | appa.ps ; Protocol vs CLX function cross-ref 24 | glossary.ps ; Glossary 25 | general.ps ; Index - general 26 | condition.ps ; conditions 27 | functions.ps ; functions 28 | types.ps ; types 29 | -------------------------------------------------------------------------------- /makeclx.cl: -------------------------------------------------------------------------------- 1 | (in-package :user) 2 | 3 | (pushnew :clx-ansi-common-lisp *features*) 4 | (load "defsystem") 5 | (load "package") 6 | (setq xlib::*def-clx-class-use-defclass* t) 7 | (let ((*compile-verbose* t) 8 | (*compile-print* nil)) 9 | (compile-system :clx) 10 | (compile-system :clx-debug)) 11 | 12 | ;; how to concatenate the fasls? 13 | (let ((fasls '("package" "excldep" "depdefs" "clx" "dependent" 14 | "exclcmac" "buffer" "display" "gcontext" 15 | "requests" "input" "fonts" "graphics" "text" 16 | "attributes" "translate" "keysyms" "manager" 17 | "image" "resource"))) 18 | (with-open-file (bigfasl "clxwin.fasl" 19 | :element-type '(unsigned-byte 8) 20 | :direction :output 21 | :if-exists :error :if-does-not-exist :create) 22 | (let ((buf (make-array 2048 :element-type '(unsigned-byte 8)))) 23 | (dolist (file-to-cat fasls) 24 | (let ((faslname (concatenate 'string file-to-cat ".fasl"))) 25 | (with-open-file (in faslname :element-type '(unsigned-byte 8)) 26 | (loop as x = (read-sequence buf in) 27 | until (= x 0) 28 | do (write-sequence buf bigfasl :end x)))))) 29 | bigfasl)) 30 | -------------------------------------------------------------------------------- /demo/bezier.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- 2 | 3 | ;;; CLX interface for Bezier Spline Extension. 4 | 5 | ;;; 6 | ;;; TEXAS INSTRUMENTS INCORPORATED 7 | ;;; P.O. BOX 2909 8 | ;;; AUSTIN, TEXAS 78769 9 | ;;; 10 | ;;; Copyright (C) 1987 Texas Instruments Incorporated. 11 | ;;; 12 | ;;; Permission is granted to any individual or institution to use, copy, modify, 13 | ;;; and distribute this software, provided that this complete copyright and 14 | ;;; permission notice is maintained, intact, in all copies and supporting 15 | ;;; documentation. 16 | ;;; 17 | ;;; Texas Instruments Incorporated provides this software "as is" without 18 | ;;; express or implied warranty. 19 | ;;; 20 | 21 | (in-package :xlib) 22 | 23 | (export 'draw-curves) 24 | 25 | (define-extension "bezier") 26 | 27 | (defun draw-curves (drawable gcontext points) 28 | ;; Draw Bezier splines on drawable using gcontext. 29 | ;; Points are a list of (x0 y0 x1 y1 x2 y2 x3 y3) 30 | (declare (type drawable drawable) 31 | (type gcontext gcontext) 32 | (type sequence points)) 33 | (let* ((display (drawable-display drawable)) 34 | (opcode (extension-opcode display "bezier"))) 35 | (with-buffer-request (display opcode :gc-force gcontext) 36 | ((data card8) 1) ;; X_PolyBezier - The minor_opcode for PolyBezier 37 | (drawable drawable) 38 | (gcontext gcontext) 39 | ((sequence :format int16) points)))) 40 | -------------------------------------------------------------------------------- /demo/README: -------------------------------------------------------------------------------- 1 | This directory contains some code for testing and showing off CLX. 2 | 3 | MENU.LISP: 4 | 5 | This file demonstrates a simple menu implementation described in 6 | Kimbrough, Kerry, "Windows to the Future", Lisp Pointers, Oct-Nov, 1987. 7 | Try calling 8 | 9 | (xlib::just-say-lisp "") 10 | (xlib::pop-up "" '("chocolate" "strawberry" "asparagus")) 11 | 12 | HELLO.LISP: 13 | 14 | Pops up a window displaying a string. Click on it to make it 15 | go away. Try calling 16 | 17 | (xlib::hello-world "" :string "This space for rent.") 18 | 19 | 20 | BEZIER.LISP, 21 | ZOID.LISP: 22 | 23 | Defines some extensions for drawing bezier splines and trapezoids, 24 | respectively. 25 | 26 | Bezier is a demo of how to use protocol extensions. Since this demo 27 | defines CLX stubs for the X_PolyBezier X request defined in the 28 | "bezier" extension, you have to have the macros and bufmac files 29 | loaded, which define macros needed to compile CLX stubs. The macros 30 | and bufmac files aren't normally loaded by load-clx, as they are only 31 | needed to compile CLX stubs for protocol requests, and aren't need to 32 | just use CLX. You can load them by specifying :macros-p t to 33 | load-clx. 34 | 35 | Lucid users: Remember that CLX stubs for protocol requests in lucid 36 | lisp have to be compiled with the production compiler, so this file 37 | has to be compiled with the production compiler. 38 | 39 | BEZIERTEST.LISP: 40 | Compile and load bezier.lisp, and try: 41 | 42 | (xlib::bezier-test "" "/usr/X.V11R1/extensions/test/datafile") 43 | 44 | The second argument is a file containing a picture described as 45 | a set of splines. Unfortunately, this is not currently part of the 46 | CLX release. 47 | 48 | -------------------------------------------------------------------------------- /provide.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Lowercase: Yes; Package: USER; -*- 2 | 3 | ;;;; Module definition for CLX 4 | 5 | ;;; This file is a Common Lisp Module description, but you will have to edit 6 | ;;; it to meet the needs of your site. 7 | 8 | ;;; Ideally, this file (or a file that loads this file) should be 9 | ;;; located in the system directory that REQUIRE searches. Thus a user 10 | ;;; would say 11 | ;;; (require :clx) 12 | ;;; to load CLX. If there is no such registry, then the user must 13 | ;;; put in a site specific 14 | ;;; (require :clx ) 15 | ;;; 16 | 17 | #-clx-ansi-common-lisp 18 | (in-package :user) 19 | 20 | #+clx-ansi-common-lisp 21 | (in-package :common-lisp-user) 22 | 23 | #-clx-ansi-common-lisp 24 | (provide :clx) 25 | 26 | (defvar *clx-source-pathname* 27 | (pathname "/src/local/clx/*.l")) 28 | 29 | (defvar *clx-binary-pathname* 30 | (let ((lisp 31 | (or #+lucid "lucid" 32 | #+akcl "akcl" 33 | #+kcl "kcl" 34 | #+ibcl "ibcl" 35 | (error "Can't provide CLX for this lisp."))) 36 | (architecture 37 | (or #+(or sun3 (and sun (or mc68000 mc68020))) "sun3" 38 | #+(or sun4 sparc) "sparc" 39 | #+(and hp (or mc68000 mc68020)) "hp9000s300" 40 | #+vax "vax" 41 | #+prime "prime" 42 | #+sunrise "sunrise" 43 | #+ibm-rt-pc "ibm-rt-pc" 44 | #+mips "mips" 45 | #+prism "prism" 46 | (error "Can't provide CLX for this architecture.")))) 47 | (pathname (format nil "/src/local/clx/~A.~A/" lisp architecture)))) 48 | 49 | (defvar *compile-clx* 50 | nil) 51 | 52 | (load (merge-pathnames "defsystem" *clx-source-pathname*)) 53 | 54 | (if *compile-clx* 55 | (compile-clx *clx-source-pathname* *clx-binary-pathname*) 56 | (load-clx *clx-binary-pathname*)) 57 | -------------------------------------------------------------------------------- /MITdist/README: -------------------------------------------------------------------------------- 1 | These files contain beta code, but they have been tested to some extent under 2 | Symbolics, TI, Lucid and Franz. The files have been given .l suffixes to keep 3 | them within 12 characters, to keep SysV sites happy. Please rename them with 4 | more appropriate suffixes for your system. 5 | 6 | 7 | For Franz systems, see exclREADME. 8 | 9 | 10 | For Symbolics systems, first rename all the .l files to .lisp. Then edit your 11 | sys.translations file so that sys:x11;clx; points to this directory and put a 12 | clx.system file in your sys:site;directory that has the form 13 | 14 | (si:set-system-source-file "clx" "sys:x11;clx;defsystem.lisp") 15 | 16 | in it. After that CLX can be compiled with the "Compile System CLX" command 17 | and loaded with the "Load System CLX" command. 18 | 19 | 20 | 21 | For TI systems, rename all the .l files to .lisp, and make a clx.translations 22 | file in your sys:site; directory pointing to this directory and a 23 | sys:site;clx.system file like the one described for symbolics systems above, 24 | but with the defsystem file being in the clx:clx; directory. Then CLX can be 25 | compiled with (make-system "CLX" :compile :noconfirm) and loaded with 26 | (make-system "CLX" :noconfirm). 27 | 28 | 29 | 30 | For Lucid systems, you should rename all the .l files to .lisp too (This might 31 | not be possible on SysV systems). After loading the defsystem.l file, CLX can 32 | be compiled with the (compile-clx) function and loaded with the 33 | (load-clx) form. 34 | 35 | The ms-patch.uu file is a patch to Lucid version 2 systems. You probably 36 | don't need it, as you are probably running Lucid version 3 or later, but if 37 | you are still using Lucid version 2, you need this patch. You'll need to 38 | uudecode it to produce the binary. 39 | 40 | 41 | 42 | For kcl systems, after loading the defsystem.l file, CLX can be compiled with 43 | the (compile-clx) function and loaded with the (load-clx) form. 44 | 45 | 46 | 47 | For more information, see defsystem.l and provide.l. 48 | 49 | -------------------------------------------------------------------------------- /demo/zoid.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- 2 | 3 | ;;; CLX interface for Trapezoid Extension. 4 | 5 | ;;; 6 | ;;; TEXAS INSTRUMENTS INCORPORATED 7 | ;;; P.O. BOX 2909 8 | ;;; AUSTIN, TEXAS 78769 9 | ;;; 10 | ;;; Copyright (C) 1987 Texas Instruments Incorporated. 11 | ;;; 12 | ;;; Permission is granted to any individual or institution to use, copy, modify, 13 | ;;; and distribute this software, provided that this complete copyright and 14 | ;;; permission notice is maintained, intact, in all copies and supporting 15 | ;;; documentation. 16 | ;;; 17 | ;;; Texas Instruments Incorporated provides this software "as is" without 18 | ;;; express or implied warranty. 19 | ;;; 20 | 21 | (in-package :xlib) 22 | 23 | (export '(draw-filled-trapezoids 24 | gcontext-trapezoid-alignment ;; Setf'able 25 | )) 26 | 27 | (define-extension "ZoidExtension") 28 | 29 | (defun draw-filled-trapezoids (drawable gcontext points) 30 | ;; Draw trapezoids on drawable using gcontext. 31 | ;; Points are a list of either (y1 y2 y3 y4 x1 x2) ;; x-aligned 32 | ;; or (x1 x2 x3 x4 y1 y2) ;; y-aligned 33 | ;; Alignment is determined by the GCONTEXT [see gcontext-trapezoid-alignment] 34 | ;; Alignment is set with the ALIGNMENT keyword argument, which may be 35 | ;; :X, :Y, or NIL (use previous alignment) 36 | (declare (type drawable drawable) 37 | (type gcontext gcontext) 38 | (type sequence points)) 39 | (let* ((display (drawable-display drawable)) 40 | (opcode (extension-opcode display "ZoidExtension"))) 41 | (with-buffer-request (display opcode :gc-force gcontext) 42 | ((data card8) 1) ;; X_PolyFillZoid 43 | (drawable drawable) 44 | (gcontext gcontext) 45 | ((sequence :format int16) points)))) 46 | 47 | (define-gcontext-accessor trapezoid-alignment :default :x 48 | :set-function set-trapezoid-alignment) 49 | 50 | (defun set-trapezoid-alignment (gcontext alignment) 51 | (declare (type (member :x :y) alignment)) 52 | (let* ((display (gcontext-display gcontext)) 53 | (opcode (extension-opcode display "ZoidExtension"))) 54 | (with-buffer-request (display opcode) 55 | ((data card8) 2) ;; X_SetZoidAlignment 56 | (gcontext gcontext) 57 | ((member8 %error :x :y) alignment)))) 58 | 59 | -------------------------------------------------------------------------------- /debug/debug.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; Patch-file:T -*- 2 | 3 | ;;; CLX debugging code 4 | 5 | ;;; 6 | ;;; TEXAS INSTRUMENTS INCORPORATED 7 | ;;; P.O. BOX 2909 8 | ;;; AUSTIN, TEXAS 78769 9 | ;;; 10 | ;;; Copyright (C) 1987 Texas Instruments Incorporated. 11 | ;;; 12 | ;;; Permission is granted to any individual or institution to use, copy, modify, 13 | ;;; and distribute this software, provided that this complete copyright and 14 | ;;; permission notice is maintained, intact, in all copies and supporting 15 | ;;; documentation. 16 | ;;; 17 | ;;; Texas Instruments Incorporated provides this software "as is" without 18 | ;;; express or implied warranty. 19 | ;;; 20 | 21 | ;;; Created 04/09/87 14:30:41 by LaMott G. OREN 22 | 23 | (in-package :xlib) 24 | 25 | (export '(display-listen 26 | readflush 27 | check-buffer 28 | check-finish 29 | check-force 30 | clear-next)) 31 | 32 | (defun display-listen (display) 33 | (listen (display-input-stream display))) 34 | 35 | (defun readflush (display) 36 | ;; Flushes Display's input stream, returning what was there 37 | (let ((stream (display-input-stream display))) 38 | (loop while (listen stream) collect (read-byte stream)))) 39 | 40 | ;;----------------------------------------------------------------------------- 41 | ;; The following are useful display-after functions 42 | 43 | (defun check-buffer (display) 44 | ;; Ensure the output buffer in display is correct 45 | (with-buffer-output (display :length :none :sizes (8 16)) 46 | (do* ((i 0 (+ i length)) 47 | request 48 | length) 49 | ((>= i buffer-boffset) 50 | (unless (= i buffer-boffset) 51 | (warn "Buffer size ~d Requests end at ~d" buffer-boffset i))) 52 | 53 | (let ((buffer-boffset 0) 54 | #+clx-overlapping-arrays 55 | (buffer-woffset 0)) 56 | (setq request (card8-get i)) 57 | (setq length (* 4 (card16-get (+ i 2))))) 58 | (when (zerop request) 59 | (warn "Zero request in buffer") 60 | (return nil)) 61 | (when (zerop length) 62 | (warn "Zero length in buffer") 63 | (return nil))))) 64 | 65 | (defun check-finish (display) 66 | (check-buffer display) 67 | (display-finish-output display)) 68 | 69 | (defun check-force (display) 70 | (check-buffer display) 71 | (display-force-output display)) 72 | 73 | (defun clear-next (display) 74 | ;; Never append requests 75 | (setf (display-last-request display) nil)) 76 | 77 | ;; End of file 78 | -------------------------------------------------------------------------------- /test/trapezoid.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- 2 | 3 | ;;; CLX trapezoid Extension test program 4 | 5 | ;;; 6 | ;;; TEXAS INSTRUMENTS INCORPORATED 7 | ;;; P.O. BOX 2909 8 | ;;; AUSTIN, TEXAS 78769 9 | ;;; 10 | ;;; Copyright (C) 1987 Texas Instruments Incorporated. 11 | ;;; 12 | ;;; Permission is granted to any individual or institution to use, copy, modify, 13 | ;;; and distribute this software, provided that this complete copyright and 14 | ;;; permission notice is maintained, intact, in all copies and supporting 15 | ;;; documentation. 16 | ;;; 17 | ;;; Texas Instruments Incorporated provides this software "as is" without 18 | ;;; express or implied warranty. 19 | ;;; 20 | 21 | (in-package :xlib) 22 | 23 | 24 | (defun zoid-test (host) 25 | ;; Display the part picture in /extensions/test/datafile 26 | (let* ((display (open-display host)) 27 | (width 400) 28 | (height 400) 29 | (screen (display-default-screen display)) 30 | (black (screen-black-pixel screen)) 31 | (white (screen-white-pixel screen)) 32 | (win (create-window 33 | :parent (screen-root screen) 34 | :background black 35 | :border white 36 | :border-width 1 37 | :colormap (screen-default-colormap screen) 38 | :bit-gravity :center 39 | :event-mask '(:exposure :key-press) 40 | :x 20 :y 20 41 | :width width :height height)) 42 | (gc (create-gcontext 43 | :drawable win 44 | :background black 45 | :foreground white))) 46 | (initialize-extensions display) 47 | 48 | (map-window win) ; Map the window 49 | ;; Handle events 50 | (unwind-protect 51 | (loop 52 | (event-case (display :force-output-p t) 53 | (exposure ;; Come here on exposure events 54 | (window count) 55 | (when (zerop count) ;; Ignore all but the last exposure event 56 | (clear-area window) 57 | ;; NOT VERY INTERESTING, BUT CHECKS ALL THE POSSIBILITIES 58 | (poly-fill-Trapezoids window gc '(10 20 30 40 100 200)) 59 | (setf (gcontext-trapezoid-alignment gc) :y) 60 | (poly-fill-Trapezoids window gc #(10 20 30 40 100 200)) 61 | (with-gcontext (gc :trapezoid-alignment :x) 62 | (poly-fill-Trapezoids window gc '(40 50 60 70 140 240))) 63 | (setf (gcontext-trapezoid-alignment gc) :x) 64 | (poly-fill-Trapezoids window gc #(40 50 60 70 80 90)) 65 | (with-gcontext (gc :trapezoid-alignment :y) 66 | (poly-fill-Trapezoids window gc #(40 50 60 70 140 240))) 67 | 68 | (draw-glyphs window gc 10 10 "Press any key to exit") 69 | ;; Returning non-nil causes event-case to exit 70 | t)) 71 | (key-press () (return-from zoid-test t)))) 72 | (close-display display)))) 73 | -------------------------------------------------------------------------------- /demo/hello.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- 2 | 3 | (in-package :xlib) 4 | 5 | (defun hello-world (host &rest args &key (string "Hello World") (font "fixed")) 6 | ;; CLX demo, says STRING using FONT in its own window on HOST 7 | (let ((display nil) 8 | (abort t)) 9 | (unwind-protect 10 | (progn 11 | (setq display (open-display host)) 12 | (multiple-value-prog1 13 | (let* ((screen (display-default-screen display)) 14 | (black (screen-black-pixel screen)) 15 | (white (screen-white-pixel screen)) 16 | (font (open-font display font)) 17 | (border 1) ; Minimum margin around the text 18 | (width (+ (text-width font string) (* 2 border))) 19 | (height (+ (max-char-ascent font) (max-char-descent font) (* 2 border))) 20 | (x (truncate (- (screen-width screen) width) 2)) 21 | (y (truncate (- (screen-height screen) height) 2)) 22 | (window (create-window :parent (screen-root screen) 23 | :x x :y y :width width :height height 24 | :background black 25 | :border white 26 | :border-width 1 27 | :colormap (screen-default-colormap screen) 28 | :bit-gravity :center 29 | :event-mask '(:exposure :button-press))) 30 | (gcontext (create-gcontext :drawable window 31 | :background black 32 | :foreground white 33 | :font font))) 34 | ;; Set window manager hints 35 | (set-wm-properties window 36 | :name 'hello-world 37 | :icon-name string 38 | :resource-name string 39 | :resource-class 'hello-world 40 | :command (list* 'hello-world host args) 41 | :x x :y y :width width :height height 42 | :min-width width :min-height height 43 | :input :off :initial-state :normal) 44 | (map-window window) ; Map the window 45 | ;; Handle events 46 | (event-case (display :discard-p t :force-output-p t) 47 | (exposure ;; Come here on exposure events 48 | (window count) 49 | (when (zerop count) ;; Ignore all but the last exposure event 50 | (with-state (window) 51 | (let ((x (truncate (- (drawable-width window) width) 2)) 52 | (y (truncate (- (+ (drawable-height window) 53 | (max-char-ascent font)) 54 | (max-char-descent font)) 55 | 2))) 56 | ;; Draw text centered in widnow 57 | (clear-area window) 58 | (draw-glyphs window gcontext x y string))) 59 | ;; Returning non-nil causes event-case to exit 60 | nil)) 61 | (button-press () t))) ;; Pressing any mouse-button exits 62 | (setq abort nil))) 63 | ;; Ensure display is closed when done 64 | (when display 65 | (close-display display :abort abort))))) 66 | -------------------------------------------------------------------------------- /NEWCHANGES: -------------------------------------------------------------------------------- 1 | This file describes the differences between X11 R5 CLX and the version of 2 | CLX in this directory. 3 | 4 | This CLX is different in two main areas: 5 | 1) It works only with ACL versions 3.1.10 and greater. (If you need 6 | a version of CLX that works with ACL versions < 3.1.10, please get 7 | the R5 CLX distribution from MIT). 8 | 2) It has some fixes that are too recent to be in R5 CLX. 9 | 10 | =============================================================================== 11 | 12 | General changes, applicable to all ports: 13 | ---------------------------------------- 14 | Support for 2 bit deep images. This is somewhat controversial as 2 15 | bit deep images are an extension to the X protocol (used by Pencom 16 | in their Next X11 server). 17 | -- lots 18 | 19 | Added parse-geometry and parse-color functions. See C Xlib manual, sections 20 | 10.3 and 10.4 for details 21 | -- parse-geometry manager.l 22 | -- parse-color manager.l 23 | -- export list package.l 24 | 25 | Added wm-client-window function, analagous to C's XmuClientWindow function. 26 | -- wm-client-window, try-children manager.l 27 | -- export list package.l 28 | 29 | Added perror() messages to socket code. 30 | -- socket.c 31 | 32 | Fixed bug in trace-error-print -- must provide :asynchronous keyword 33 | to make-condition 34 | -- trace-error-print trace.cl 35 | 36 | Version string updated to "MIT R5.0 (Franz ACL4.1)". 37 | -- *version* clx.l 38 | 39 | =============================================================================== 40 | Franz specific changes, applicable to Allegro and Extended Common Lisps: 41 | (note that all these changes are #+excl or #+allegro, so if you're not 42 | using our product these changes are "commented" out) 43 | ----------------------------------------------------------------------- 44 | set-case-mode removed from Makefile. Instead issue warning in package.cl 45 | if the case is non sensitive. 46 | -- Makefile 47 | -- top level form package.l 48 | 49 | Change default rule to be partial-clos, instead of no-clos. Also add hook 50 | for ACL $(XCFLAGS) variable. 51 | -- Makefile 52 | 53 | README file made correct for this version. 54 | -- README 55 | 56 | Provided :clx when loading clx interpreted. Removed patch code from excldep.cl. 57 | -- top level form excldep.cl 58 | -- lots excldep.cl 59 | 60 | Instances of excl:defcmacro changed to define-compiler-macro in exclcmac.cl. 61 | Compatibility code put in excldep.cl and package.cl. Moved type checking 62 | stuff to exclcmac, so it's loaded after types are defined. Exclcmac is 63 | also now loaded into CLX.fasl. 64 | -- lots exclcmac.cl 65 | -- define-compiler-macro excldep.cl 66 | -- import list in defpackage package.cl 67 | -- cat list Makefile 68 | 69 | New defsystem for ACL 4.1 70 | -- defsystem.cl 71 | -------------------------------------------------------------------------------- /excldep.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Allegro CL dependent C helper routines for CLX 3 | */ 4 | 5 | /* 6 | * This code requires select and interval timers. 7 | * This means you probably need BSD, or a version 8 | * of Unix with select and interval timers added. 9 | */ 10 | 11 | # ifdef __alpha 12 | # pragma pointer_size (save) 13 | # pragma pointer_size (long) 14 | # endif 15 | 16 | #include 17 | #include 18 | #include 19 | #include 20 | 21 | # ifdef __alpha 22 | # pragma pointer_size (restore) 23 | # endif 24 | 25 | #define ERROR -1 26 | #define INTERRUPT -2 27 | #define TIMEOUT 0 28 | #define SUCCESS 1 29 | 30 | #ifdef FD_SETSIZE 31 | #define NUMBER_OF_FDS FD_SETSIZE /* Highest possible file descriptor */ 32 | #else 33 | #define NUMBER_OF_FDS 32 34 | #endif 35 | 36 | /* Length of array needed to hold all file descriptor bits */ 37 | #define CHECKLEN ((NUMBER_OF_FDS+8*sizeof(int)-1) / (8 * sizeof(int))) 38 | 39 | extern int errno; 40 | 41 | /* 42 | * This function waits for input to become available on 'fd'. If timeout is 43 | * 0, wait forever. Otherwise wait 'timeout' seconds. If input becomes 44 | * available before the timer expires, return SUCCESS. If the timer expires 45 | * return TIMEOUT. If an error occurs, return ERROR. If an interrupt occurs 46 | * while waiting, return INTERRUPT. 47 | */ 48 | int fd_wait_for_input(fd, timeout) 49 | register int fd; 50 | register int timeout; 51 | { 52 | struct timeval timer; 53 | register int i; 54 | #ifdef FD_SETSIZE 55 | fd_set checkfds; 56 | #else 57 | int checkfds[CHECKLEN]; 58 | #endif 59 | 60 | if (fd < 0 || fd >= NUMBER_OF_FDS) { 61 | fprintf(stderr, "Bad file descriptor argument: %d to fd_wait_for_input\n", fd); 62 | fflush(stderr); 63 | } 64 | 65 | #ifdef FD_SETSIZE 66 | FD_ZERO(&checkfds); 67 | FD_SET(fd, &checkfds); 68 | 69 | if (timeout) { 70 | timer.tv_sec = timeout; 71 | timer.tv_usec = 0; 72 | i = select(NUMBER_OF_FDS, &checkfds, (fd_set *)0, (fd_set *)0, &timer); 73 | } else 74 | i = select(NUMBER_OF_FDS, &checkfds, (fd_set *)0, (fd_set *)0, (struct timeval *)0); 75 | #else 76 | for (i = 0; i < CHECKLEN; i++) 77 | checkfds[i] = 0; 78 | checkfds[fd / (8 * sizeof(int))] |= 1 << (fd % (8 * sizeof(int))); 79 | 80 | if (timeout) { 81 | timer.tv_sec = timeout; 82 | timer.tv_usec = 0; 83 | i = select(32, checkfds, (int *)0, (int *)0, &timer); 84 | } else 85 | i = select(32, checkfds, (int *)0, (int *)0, (struct timeval *)0); 86 | #endif 87 | 88 | 89 | if (i < 0) 90 | /* error condition */ 91 | if (errno == EINTR) 92 | return (INTERRUPT); 93 | else 94 | return (ERROR); 95 | else if (i == 0) 96 | return (TIMEOUT); 97 | else 98 | return (SUCCESS); 99 | } 100 | -------------------------------------------------------------------------------- /generalock.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: PROCESS; Base: 10; Lowercase: Yes -*- 2 | 3 | (defflavor xlib::clx-lock () (simple-recursive-normal-lock) 4 | (:init-keywords :flavor)) 5 | 6 | (defwhopper (lock-internal xlib::clx-lock) (lock-argument) 7 | (catch 'timeout 8 | (continue-whopper lock-argument))) 9 | 10 | (defmethod (lock-block-internal xlib::clx-lock) (lock-argument) 11 | (declare (dbg:locking-function describe-process-lock-for-debugger self)) 12 | (when (null waiter-queue) 13 | (setf waiter-queue (make-scheduler-queue :name name)) 14 | (setf timer (create-timer-call #'lock-timer-expired `(,self) :name name))) 15 | (let ((process (lock-argument-process lock-argument))) 16 | (unwind-protect 17 | (progn 18 | (lock-map-over-conflicting-owners 19 | self lock-argument 20 | #'(lambda (other-lock-arg) 21 | (add-promotion process lock-argument 22 | (lock-argument-process other-lock-arg) other-lock-arg))) 23 | (unless (timer-pending-p timer) 24 | (when (and (safe-to-use-timers %real-current-process) 25 | (not dbg:*debugger-might-have-system-problems*)) 26 | (reset-timer-relative-timer-units timer *lock-timer-interval*))) 27 | (assert (store-conditional (locf latch) process nil)) 28 | (sys:with-aborts-enabled (lock-latch) 29 | (let ((timeout (lock-argument-getf lock-argument :timeout nil))) 30 | (cond ((null timeout) 31 | (promotion-block waiter-queue name #'lock-lockable self lock-argument)) 32 | ((and (plusp timeout) 33 | (using-resource (timer process-block-timers) 34 | ;; Yeah, we know about the internal representation 35 | ;; of timers here. 36 | (setf (car (timer-args timer)) %real-current-process) 37 | (with-scheduler-locked 38 | (reset-timer-relative timer timeout) 39 | (flet ((lock-lockable-or-timeout (timer lock lock-argument) 40 | (or (not (timer-pending-p timer)) 41 | (lock-lockable lock lock-argument)))) 42 | (let ((priority (process-process-priority *current-process*))) 43 | (if (ldb-test %%scheduler-priority-preemption-field priority) 44 | (promotion-block waiter-queue name 45 | #'lock-lockable-or-timeout 46 | timer self lock-argument) 47 | ;; Change to preemptive priority so that when 48 | ;; unlock-internal wakes us up so we can have the lock, 49 | ;; we will really wake up right away 50 | (with-process-priority 51 | (dpb 1 %%scheduler-priority-preemption-field 52 | priority) 53 | (promotion-block waiter-queue name 54 | #'lock-lockable-or-timeout 55 | timer self lock-argument))))) 56 | (lock-lockable self lock-argument))))) 57 | (t (throw 'timeout nil)))))) 58 | (unless (store-conditional (locf latch) nil process) 59 | (lock-latch-wait-internal self)) 60 | (remove-promotions process lock-argument)))) 61 | 62 | (compile-flavor-methods xlib::clx-lock) 63 | -------------------------------------------------------------------------------- /demo/beziertest.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- 2 | 3 | ;;; CLX Bezier Spline Extension demo program 4 | 5 | ;;; 6 | ;;; TEXAS INSTRUMENTS INCORPORATED 7 | ;;; P.O. BOX 2909 8 | ;;; AUSTIN, TEXAS 78769 9 | ;;; 10 | ;;; Copyright (C) 1987 Texas Instruments Incorporated. 11 | ;;; 12 | ;;; Permission is granted to any individual or institution to use, copy, modify, 13 | ;;; and distribute this software, provided that this complete copyright and 14 | ;;; permission notice is maintained, intact, in all copies and supporting 15 | ;;; documentation. 16 | ;;; 17 | ;;; Texas Instruments Incorporated provides this software "as is" without 18 | ;;; express or implied warranty. 19 | ;;; 20 | 21 | (in-package :xlib) 22 | 23 | (defun bezier-test (host &optional (pathname "/usr/X.V11R1/extensions/test/datafile")) 24 | ;; Display the part picture in /extensions/test/datafile 25 | (let* ((display (open-display host)) 26 | (width 800) 27 | (height 800) 28 | (screen (display-default-screen display)) 29 | (black (screen-black-pixel screen)) 30 | (white (screen-white-pixel screen)) 31 | (win (create-window 32 | :parent (screen-root screen) 33 | :background black 34 | :border white 35 | :border-width 1 36 | :colormap (screen-default-colormap screen) 37 | :bit-gravity :center 38 | :event-mask '(:exposure :key-press) 39 | :x 20 :y 20 40 | :width width :height height)) 41 | (gc (create-gcontext 42 | :drawable win 43 | :background black 44 | :foreground white)) 45 | (lines (make-array (* 500 4) :fill-pointer 0 :element-type 'card16)) 46 | (curves (make-array (* 500 8) :fill-pointer 0 :element-type 'card16))) 47 | ;; Read the data 48 | (with-open-file (stream pathname) 49 | (loop 50 | (case (read-char stream nil :eof) 51 | (#\l (dotimes (i 4) (vector-push-extend (read stream) lines))) 52 | (#\b (dotimes (i 8) (vector-push-extend (read stream) curves))) 53 | ((#\space #\newline #\tab)) 54 | (otherwise (return))))) 55 | ;; The data points were created to fit in a 2048x2048 square, 56 | ;; this means scale_factor will always be small enough so that 57 | ;; we don't need to worry about overflows. 58 | (let ((factor (ash (min width height) 5))) 59 | (dotimes (i (length lines)) 60 | (setf (svref lines i) 61 | (ash (* (svref lines i) factor) -16))) 62 | (dotimes (i (length curves)) 63 | (setf (svref curves i) 64 | (ash (* (svref curves i) factor) -16)))) 65 | 66 | (map-window win) ; Map the window 67 | ;; Handle events 68 | (unwind-protect 69 | (loop 70 | (event-case (display :force-output-p t) 71 | (exposure ;; Come here on exposure events 72 | (window count) 73 | (when (zerop count) ;; Ignore all but the last exposure event 74 | (clear-area window) 75 | (draw-segments win gc lines) 76 | (draw-curves win gc curves) 77 | (draw-glyphs win gc 10 10 "Press any key to exit") 78 | ;; Returning non-nil causes event-case to exit 79 | t)) 80 | (key-press () (return-from bezier-test t)))) 81 | (close-display display)))) 82 | -------------------------------------------------------------------------------- /ms-patch.uu: -------------------------------------------------------------------------------- 1 | begin 666 make-sequence-patch.lbin 2 | M1D%33"!&24Q%.@I&05-,('9ET %682+6T &0 $*F[__$_N__@F5T[3L>T '6<& 16 | ML>T (682+6T )0 $*F[__$_N__@F5T[3L>T *682+6T +0 $*F[__$_N__@F 17 | M5T[3(&[_]+G(9PX@" ( <, !9@ #^B!N__0O* '0J)&T -;7N_^QF &X("[_Z R 19 | M#& 20 | M6(\@;O_T(F@ R1M $&UZ0 '9P @B!N__0B: #(FD R1M $&UZ0 '9RQ" 21 | MIR\.+PU(>@ @+RT .2\N__1\ B1M #TJ:@ 3W/S_X"!M %.Z %3EY8CR)N 22 | M__0B:0 #(&D !R)N__0B:0 #(FD R\I (&[_Y")M $E@!")I ,@"0( <, 25 | M !9P0O#& (L>D !V;F+PE/[O_@N>[_X&<"8%P@;O_DN@ !R1,9P0D; W+PJY[O_<9P)@*D*G+PXO#4AZ " O 27 | M+0 Y+R[_]'P")&T /2IJ !/<_/_4(&T 4[H 5.7D_N_^0@;O_T(F@ R)I 28 | M ,C;O_D B N_^@,@ 1F 29 | M$BUM $T !"IN__Q/[O_X)E=.TR N_^@,@ AG*@R #&D !V;F)$FYRF< (0@ 35 | M+O_H#( (9RQ"IR\.+PU(>@ @+RT .2\N__1\ B1M #TJ:@ 3W/S_W"!M 36 | M %.Z %3EY8CR!N_^RQ[0 59A(M;0 9 0J;O_\3^[_^"973M.Q[0 =9Q:Q 37 | M[0 A9Q M2 $*F[__$_N__@F5T[3+6T )0 $*F[__$_N__@F5T[33^[_Z+GN 38 | M__!G F X0J[_\&<"8#1"IR\.+PU(>@ <+R[_]'P!)&T 72IJ !/<_/_H(&T 41 | M 4[H 5.7BU?__0M; W__!@ /LL+6[_]/_P+6T .?_T? (D;0 ]*FH $R!M 42 | M %/[O_P3N@ !?X"!20N* A465!%4U!%0R@))D]05$E/3D%,* M.3U)-04Q) 43 | M6D5$4#A,* 1,25-4* 1.54Q,3"@&5D5#5$]23 $U#"@-4TE-4$Q%+59%0U1/ 44 | M4DPH#5-)35!,12U35%))3D=,*!)324U03$4M,4))5"U614-43U(H$E-)35!, 45 | M12TR0DE4+59%0U1/4B@24TE-4$Q%+31"250M5D5#5$]2*!)324U03$4M.$)) 46 | M5"U614-43U(H$U-)35!,12TQ-D))5"U614-43U(H$U-)35!,12TS,D))5"U6 47 | M14-43U(H&5-)35!,12U324=.140M.$))5"U614-43U(H&E-)35!,12U324=. 48 | M140M,39"250M5D5#5$]2*!I324U03$4M4TE'3D5$+3,R0DE4+59%0U1/4B@: 49 | M4TE-4$Q%+5-)3D=,12U&3$]!5"U614-43U),* 935%))3D?^"TPH"D))5"U6 50 | M14-43U),*!%324U03$4M0DE4+59%0U1/4OX,* A315%514Y#12Y,* )/4OX& 51 | M_@@H"TQ)4U0M3$5.1U1(_AHB.7Y3(&ES(&%N(&EN=F%L:60@;W(@=6YR97-O 52 | M;'9A8FQE(')E7!E (directory-namestring excl::*library-code-pathname*) 42 | 43 | to a running Lisp. If it prints something other than "/usr/local/lib/cl/code" 44 | substitute what it prints in the below instructions. 45 | 46 | % mv CLX.fasl /usr/local/lib/cl/code/clx.fasl 47 | % mv *.o /usr/local/lib/cl/code 48 | 49 | Now you can just start up Lisp and type: 50 | 51 | (load "clx") 52 | 53 | to load in CLX. You may want to dump a lisp at this point since CLX is a large 54 | package and can take some time to load into Lisp. You probably also want to 55 | set the :generation-spread to 1 while loading CLX. Please see your Allegro CL 56 | User Guide for more information on :generation-spread. 57 | 58 | 59 | Sophisticated users may wish to peruse the Makefile and defsystem.cl 60 | and note how things are set up. For example we hardwire the compiler 61 | interrupt check switch on, so that CL can still be interrupted while it 62 | is reading from the X11 socket. Please see chapter 7 of the CL User's 63 | guide for more information on compiler switches and their effects. 64 | 65 | 66 | Please report Franz specific CLX bugs to: 67 | 68 | bugs@Franz.COM 69 | or 70 | ucbvax!franz!bugs 71 | 72 | 73 | 74 | Building and running on Windows NT 75 | 76 | (1) With ACL 4.3.2 or later, :cd to the directory containing the clx 77 | sources. 78 | 79 | (2) :ld makeclx.cl - this should create winclx.fasl in that 80 | directory. Feel free to move winclx.fasl to a convenient location. 81 | 82 | (3) In a fresh lisp, :ld winclx.fasl. You should now be able to 83 | open your display, assuming your X display software is running and 84 | tcp/ip is installed, with: (xlib:open-display "localhost") -------------------------------------------------------------------------------- /sockcl.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- 2 | 3 | ;;;; Server Connection for kcl and ibcl 4 | 5 | ;;; Copyright (C) 1987, 1989 Massachussetts Institute of Technology 6 | ;;; 7 | ;;; Permission is granted to any individual or institution to use, copy, 8 | ;;; modify, and distribute this software, provided that this complete 9 | ;;; copyright and permission notice is maintained, intact, in all copies and 10 | ;;; supporting documentation. 11 | ;;; 12 | ;;; Massachussetts Institute of Technology provides this software "as is" 13 | ;;; without express or implied warranty. 14 | ;;; 15 | 16 | ;;; Adapted from code by Roman Budzianowski - Project Athena/MIT 17 | 18 | ;;; make-two-way-stream is probably not a reasonable thing to do. 19 | ;;; A close on a two way stream probably does not close the substreams. 20 | ;;; I presume an :io will not work (maybe because it uses 1 buffer?). 21 | ;;; There should be some fast io (writes and reads...). 22 | 23 | ;;; Compile this file with compile-file. 24 | ;;; Load it with (si:faslink "sockcl.o" "socket.o -lc") 25 | 26 | (in-package :xlib) 27 | 28 | ;;; The cmpinclude.h file does not have this type definition from 29 | ;;; /h/object.h. We include it here so the 30 | ;;; compile-file will work without figuring out where the distribution 31 | ;;; directory is located. 32 | ;;; 33 | (CLINES " 34 | enum smmode { /* stream mode */ 35 | smm_input, /* input */ 36 | smm_output, /* output */ 37 | smm_io, /* input-output */ 38 | smm_probe, /* probe */ 39 | smm_synonym, /* synonym */ 40 | smm_broadcast, /* broadcast */ 41 | smm_concatenated, /* concatenated */ 42 | smm_two_way, /* two way */ 43 | smm_echo, /* echo */ 44 | smm_string_input, /* string input */ 45 | smm_string_output, /* string output */ 46 | smm_user_defined /* for user defined */ 47 | }; 48 | ") 49 | 50 | #-akcl 51 | (CLINES " 52 | struct stream { 53 | short t, m; 54 | FILE *sm_fp; /* file pointer */ 55 | object sm_object0; /* some object */ 56 | object sm_object1; /* some object */ 57 | int sm_int0; /* some int */ 58 | int sm_int1; /* some int */ 59 | short sm_mode; /* stream mode */ 60 | /* of enum smmode */ 61 | }; 62 | ") 63 | 64 | 65 | ;;;; Connect to the server. 66 | 67 | ;;; A lisp string is not a reasonable type for C, so copy the characters 68 | ;;; out and then call connect_to_server routine defined in socket.o 69 | 70 | (CLINES " 71 | int 72 | konnect_to_server(host,display) 73 | object host; /* host name */ 74 | int display; /* display number */ 75 | { 76 | int fd; /* file descriptor */ 77 | int i; 78 | char hname[BUFSIZ]; 79 | FILE *fout, *fin; 80 | 81 | if (host->st.st_fillp > BUFSIZ - 1) 82 | too_long_file_name(host); 83 | for (i = 0; i < host->st.st_fillp; i++) 84 | hname[i] = host->st.st_self[i]; 85 | hname[i] = '\\0'; /* doubled backslash for lisp */ 86 | 87 | fd = connect_to_server(hname,display); 88 | 89 | return(fd); 90 | } 91 | ") 92 | 93 | (defentry konnect-to-server (object int) (int "konnect_to_server")) 94 | 95 | 96 | ;;;; Make a one-way stream from a file descriptor. 97 | 98 | (CLINES " 99 | object 100 | konnect_stream(host,fd,flag,elem) 101 | object host; /* not really used */ 102 | int fd; /* file descriptor */ 103 | int flag; /* 0 input, 1 output */ 104 | object elem; /* 'excl::string-char */ 105 | { 106 | struct stream *stream; 107 | char *mode; /* file open mode */ 108 | FILE *fp; /* file pointer */ 109 | enum smmode smm; /* lisp mode (a short) */ 110 | vs_mark; 111 | 112 | switch(flag){ 113 | case 0: 114 | smm = smm_input; 115 | mode = \"r\"; 116 | break; 117 | case 1: 118 | smm = smm_output; 119 | mode = \"w\"; 120 | break; 121 | default: 122 | FEerror(\"konnect_stream : wrong mode\"); 123 | } 124 | 125 | fp = fdopen(fd,mode); 126 | 127 | if (fp == NULL) { 128 | stream = Cnil; 129 | vs_push(stream); 130 | } else { 131 | stream = alloc_object(t_stream); 132 | stream->sm_mode = (short)smm; 133 | stream->sm_fp = fp; 134 | stream->sm_object0 = elem; 135 | stream->sm_object1 = host; 136 | stream->sm_int0 = stream->sm.sm_int1 = 0; 137 | vs_push(stream); 138 | setbuf(fp, alloc_contblock(BUFSIZ)); 139 | } 140 | vs_reset; 141 | return(stream); 142 | } 143 | ") 144 | 145 | (defentry konnect-stream (object int int object) (object "konnect_stream")) 146 | 147 | 148 | ;;;; Open an X stream 149 | 150 | (defun open-socket-stream (host display) 151 | (when (not (and (typep host 'string) ; sanity check the arguments 152 | (typep display 'fixnum))) 153 | (error "Host ~s or display ~s are bad." host display)) 154 | 155 | (let ((fd (konnect-to-server host display))) ; get a file discriptor 156 | (if (< fd 0) 157 | NIL 158 | (let ((stream-in (konnect-stream host fd 0 'excl::string-char)) ; input 159 | (stream-out (konnect-stream host fd 1 'excl::string-char))) ; output 160 | (if (or (null stream-in) (null stream-out)) 161 | (error "Could not make i/o streams for fd ~d." fd)) 162 | (make-two-way-stream stream-in stream-out)) 163 | ))) 164 | -------------------------------------------------------------------------------- /socket.c: -------------------------------------------------------------------------------- 1 | /* Copyright Massachusetts Institute of Technology 1988 */ 2 | /* 3 | * THIS IS AN OS DEPENDENT FILE! It should work on 4.2BSD derived 4 | * systems. VMS and System V should plan to have their own version. 5 | * 6 | * This code was cribbed from lib/X/XConnDis.c. 7 | * Compile using 8 | * % cc -c socket.c -DUNIXCONN 9 | */ 10 | 11 | # ifdef __alpha 12 | # pragma pointer_size (save) 13 | # pragma pointer_size (long) 14 | # endif 15 | 16 | #include 17 | #include 18 | #include 19 | #include 20 | #include 21 | #include 22 | #include 23 | #include 24 | #ifndef hpux 25 | #include 26 | #endif 27 | 28 | extern int errno; /* Certain (broken) OS's don't have this */ 29 | /* decl in errno.h */ 30 | 31 | #ifdef UNIXCONN 32 | #include 33 | 34 | # ifndef X_UNIX_PATH 35 | # ifdef hpux 36 | # define X_UNIX_PATH "/usr/spool/sockets/X11/" 37 | # define OLD_UNIX_PATH "/tmp/.X11-unix/X" 38 | # else /* hpux */ 39 | # define X_UNIX_PATH "/tmp/.X11-unix/X" 40 | # endif /* hpux */ 41 | # endif /* X_UNIX_PATH */ 42 | 43 | # ifdef __APPLE__ 44 | /* need to include this starting with a recent Xcode on macsup, 10/29/21 */ 45 | # include 46 | # endif 47 | 48 | #endif /* UNIXCONN */ 49 | 50 | # ifdef m_alpha 51 | # pragma pointer_size (restore) 52 | # endif 53 | 54 | #if 0 55 | void bcopy(); 56 | #endif /* hpux */ 57 | 58 | /* 59 | * Attempts to connect to server, given host and display. Returns file 60 | * descriptor (network socket) or 0 if connection fails. 61 | */ 62 | 63 | int connect_to_server (host, display) 64 | char *host; 65 | int display; 66 | { 67 | struct sockaddr_in inaddr; /* INET socket address. */ 68 | struct sockaddr *addr; /* address to connect to */ 69 | struct hostent *host_ptr; 70 | int addrlen; /* length of address */ 71 | #ifdef UNIXCONN 72 | struct sockaddr_un unaddr; /* UNIX socket address. */ 73 | #endif 74 | extern char *getenv(); 75 | extern struct hostent *gethostbyname(); 76 | int fd; /* Network socket */ 77 | { 78 | #ifdef UNIXCONN 79 | if ((!host) || (host[0] == '\0') || (strcmp("unix", host) == 0)) { 80 | /* Connect locally using Unix domain. */ 81 | unaddr.sun_family = AF_UNIX; 82 | (void) strcpy(unaddr.sun_path, X_UNIX_PATH); 83 | (void) sprintf(&unaddr.sun_path[strlen(unaddr.sun_path)], "%d", display); 84 | addr = (struct sockaddr *) &unaddr; 85 | addrlen = strlen(unaddr.sun_path) + 2; 86 | /* 87 | * Open the network connection. 88 | */ 89 | if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) { 90 | #ifdef hpux /* this is disgusting */ /* cribbed from X11R4 xlib source */ 91 | if (errno == ENOENT) { /* No such file or directory */ 92 | (void) sprintf(unaddr.sun_path, "%s%d", OLD_UNIX_PATH, display); 93 | addrlen = strlen(unaddr.sun_path) + 2; 94 | if ((fd = socket ((int) addr->sa_family, SOCK_STREAM, 0)) < 0) 95 | return(-1); /* errno set by most recent system call. */ 96 | } else 97 | #endif /* hpux */ 98 | perror("Unix domain socket failed"); 99 | return(-1); /* errno set by system call. */ 100 | } 101 | } else 102 | #endif /* UNIXCONN */ 103 | { 104 | /* Get the statistics on the specified host. */ 105 | if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) 106 | { 107 | if ((host_ptr = gethostbyname(host)) == NULL) 108 | { 109 | /* No such host! */ 110 | fprintf(stderr, "Unknown host: %s\n", host); 111 | errno = EINVAL; 112 | return(-1); 113 | } 114 | /* Check the address type for an internet host. */ 115 | if (host_ptr->h_addrtype != AF_INET) 116 | { 117 | /* Not an Internet host! */ 118 | perror("Host lookup failed"); 119 | errno = EPROTOTYPE; 120 | return(-1); 121 | } 122 | /* Set up the socket data. */ 123 | inaddr.sin_family = host_ptr->h_addrtype; 124 | 125 | (void) memcpy((char *)&inaddr.sin_addr, 126 | (char *)host_ptr->h_addr, 127 | sizeof(inaddr.sin_addr)); 128 | #if 0 129 | (void) bcopy((char *)host_ptr->h_addr, 130 | (char *)&inaddr.sin_addr, 131 | sizeof(inaddr.sin_addr)); 132 | #endif /* 0 */ 133 | } 134 | else 135 | { 136 | inaddr.sin_family = AF_INET; 137 | } 138 | addr = (struct sockaddr *) &inaddr; 139 | addrlen = sizeof (struct sockaddr_in); 140 | inaddr.sin_port = display + X_TCP_PORT; 141 | inaddr.sin_port = htons(inaddr.sin_port); 142 | /* 143 | * Open the network connection. 144 | */ 145 | if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){ 146 | perror("Internet domain socket failed"); 147 | return(-1); /* errno set by system call. */} 148 | /* make sure to turn off TCP coalescence */ 149 | #ifdef TCP_NODELAY 150 | { 151 | int mi = 1; 152 | setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); 153 | } 154 | #endif 155 | } 156 | 157 | /* 158 | * Changed 9/89 to retry connection if system call was interrupted. This 159 | * is necessary for multiprocessing implementations that use timers, 160 | * since the timer results in a SIGALRM. -- jdi 161 | */ 162 | while (connect(fd, addr, addrlen) == -1) { 163 | if (errno != EINTR) { 164 | perror("Connection of socket failed"); 165 | (void) close (fd); 166 | return(-1); /* errno set by system call. */ 167 | } 168 | } 169 | } 170 | /* 171 | * Return the id if the connection succeeded. 172 | */ 173 | return(fd); 174 | } 175 | -------------------------------------------------------------------------------- /test/image.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- 2 | 3 | ;;; Tests image code by randomly reading, copying and then writing images to 4 | ;;; the exact same place on the screen. If everything works, just the borders 5 | ;;; of the image windows appear. If one of these image windows is garbled, 6 | ;;; then somewhere something is broken. Entry point is the function 7 | ;;; IMAGE-TEST 8 | 9 | (in-package :xlib) 10 | 11 | (export '(image-test)) 12 | 13 | (defvar *image-test-host* "") 14 | 15 | (defvar *image-test-nimages* 25) 16 | 17 | (defvar *image-test-copy* t) 18 | 19 | (defvar *image-test-copy-random-subimage* t) 20 | 21 | (defvar *image-test-put-random-subimage* t) 22 | 23 | (defvar *image-test-get-image-result-type-choices* 24 | '(image-x image-x image-xy image-z)) 25 | 26 | (defvar *image-test-get-image-image-x-format-choices* 27 | '(:xy-pixmap :z-pixmap)) 28 | 29 | (defun image-test 30 | (&key 31 | (host *image-test-host*) 32 | (nimages *image-test-nimages*) 33 | (copy *image-test-copy*) 34 | (copy-random-subimage *image-test-copy-random-subimage*) 35 | (put-random-subimage *image-test-put-random-subimage*) 36 | (get-image-result-type-choices 37 | *image-test-get-image-result-type-choices*) 38 | (get-image-image-x-format-choices 39 | *image-test-get-image-image-x-format-choices*)) 40 | (let* ((display nil) 41 | (abort t) 42 | (images nil)) 43 | (loop 44 | (setq images nil) 45 | (unwind-protect 46 | (progn 47 | (setq display (open-display host)) 48 | (let* ((screen (display-default-screen display)) 49 | (window (screen-root screen)) 50 | (gcontext (create-gcontext 51 | :drawable window 52 | :font (open-font display "fixed")))) 53 | (dotimes (i nimages) 54 | (let ((image (image-test-get-image 55 | window 56 | get-image-result-type-choices 57 | get-image-image-x-format-choices))) 58 | (format t "~&Image=~S~%" image) 59 | (let ((copy (if copy 60 | (image-test-copy-image 61 | image 62 | copy-random-subimage) 63 | image))) 64 | (format t "~&Copy=~S~%" copy) 65 | (push (list image copy) images) 66 | (image-test-put-image 67 | screen gcontext copy 68 | (concatenate 69 | 'string (image-info image) (image-info copy)) 70 | put-random-subimage)))) 71 | (unless (y-or-n-p "More ") (return)) 72 | (setq abort nil))) 73 | (close-display (shiftf display nil) :abort abort)) 74 | (sleep 10)) 75 | (reverse images))) 76 | 77 | (defun image-test-choose (list) 78 | (nth (random (length list)) list)) 79 | 80 | (defun image-test-get-image (window result-type-choices image-x-format-choices) 81 | (let* ((x (random (floor (drawable-width window) 3))) 82 | (y (random (floor (drawable-height window) 3))) 83 | (hw (floor (- (drawable-width window) x) 3)) 84 | (hh (floor (- (drawable-height window) y) 3)) 85 | (width (+ hw hw (random hw))) 86 | (height (+ hh hh (random hh))) 87 | (result-type (image-test-choose result-type-choices)) 88 | (format 89 | (ecase result-type 90 | (image-x (image-test-choose image-x-format-choices)) 91 | (image-xy :xy-pixmap) 92 | (image-z :z-pixmap))) 93 | (image (get-image window :x x :y y :width width :height height 94 | :format format :result-type result-type))) 95 | (setf (image-x-hot image) (- x)) 96 | (setf (image-y-hot image) (- y)) 97 | image)) 98 | 99 | (defun image-test-subimage-parameters (image random-subimage-p) 100 | (if random-subimage-p 101 | (let* ((x (random (floor (image-width image) 3))) 102 | (y (random (floor (image-height image) 3))) 103 | (hw (floor (- (image-width image) x) 3)) 104 | (hh (floor (- (image-height image) y) 3)) 105 | (width (+ hw hw (random hw))) 106 | (height (+ hh hh (random hh)))) 107 | (values x y width height)) 108 | (values 0 0 (image-width image) (image-height image)))) 109 | 110 | (defun image-test-copy-image (image random-subimage-p) 111 | (let ((result-type 112 | (if (zerop (random 2)) 113 | (type-of image) 114 | (etypecase image 115 | (image-x (ecase (image-x-format image) 116 | (:xy-pixmap 'image-xy) 117 | (:z-pixmap 'image-z))) 118 | ((or image-xy image-z) 'image-x))))) 119 | (multiple-value-bind (x y width height) 120 | (image-test-subimage-parameters image random-subimage-p) 121 | (copy-image image :x x :y y :width width :height height 122 | :result-type result-type)))) 123 | 124 | (defun image-test-put-image (screen gcontext image info random-subimage-p) 125 | (multiple-value-bind (src-x src-y width height) 126 | (image-test-subimage-parameters image random-subimage-p) 127 | (let* ((border-width 1) 128 | (x (- src-x (image-x-hot image) border-width)) 129 | (y (- src-y (image-y-hot image) border-width))) 130 | (unless (or (zerop width) (zerop height)) 131 | (let ((window 132 | (create-window 133 | :parent (screen-root screen) :x x :y y 134 | :width width :height height 135 | :border-width border-width 136 | :background (screen-white-pixel screen) 137 | :override-redirect :on))) 138 | (map-window window) 139 | (display-finish-output (drawable-display window)) 140 | (put-image window gcontext image 141 | :x 0 :y 0 :src-x src-x :src-y src-y 142 | :width width :height height) 143 | (draw-image-glyphs window gcontext 0 (1- height) info) 144 | (display-finish-output (drawable-display window)) 145 | window))))) 146 | 147 | (defun image-info (image) 148 | (etypecase image 149 | (image-x (ecase (image-x-format image) 150 | (:xy-pixmap "XXY") 151 | (:z-pixmap "XZ "))) 152 | (image-xy "XY ") 153 | (image-z "Z "))) 154 | -------------------------------------------------------------------------------- /MITdist/Makefile: -------------------------------------------------------------------------------- 1 | # 2 | # Makefile for CLX 3 | # (X11 R4.4 release, Franz Allegro Common Lisp version) 4 | # 5 | 6 | # ************************************************************************* 7 | # * Change the next line to point to where you have Common Lisp installed * 8 | # * (make sure the Lisp doesn't already have CLX loaded in) * 9 | # ************************************************************************* 10 | CL = /usr/local/bin/cl 11 | 12 | RM = /bin/rm 13 | SHELL = /bin/sh 14 | ECHO = /bin/echo 15 | TAGS = /usr/local/lib/emacs/etc/etags 16 | 17 | # Name of dumped lisp 18 | CLX = CLX 19 | 20 | CLOPTS = -qq 21 | 22 | # Use this one for Suns 23 | CFLAGS = -O -DUNIXCONN 24 | # Use this one for Silicon Graphics & Mips Inc MIPS based machines 25 | # CFLAGS = -O -G 0 -I/usr/include/bsd 26 | # Use this one for DEC MIPS based machines 27 | # CFLAGS = -O -G 0 -DUNIXCONN 28 | # Use this one for HP machines 29 | # CFLAGS = -O -DSYSV -DUNIXCONN 30 | 31 | 32 | # Lisp optimization for compiling 33 | SPEED = 3 34 | SAFETY = 0 35 | 36 | 37 | C_SRC = excldep.c socket.c 38 | C_OBJS = excldep.o socket.o 39 | 40 | L_OBJS = defsystem.fasl package.fasl excldep.fasl depdefs.fasl clx.fasl \ 41 | dependent.fasl exclcmac.fasl macros.fasl bufmac.fasl buffer.fasl \ 42 | display.fasl gcontext.fasl requests.fasl input.fasl fonts.fasl \ 43 | graphics.fasl text.fasl attributes.fasl translate.fasl keysyms.fasl \ 44 | manager.fasl image.fasl resource.fasl 45 | 46 | L_NOMACROS_OBJS = package.fasl excldep.fasl depdefs.fasl clx.fasl \ 47 | dependent.fasl buffer.fasl display.fasl gcontext.fasl \ 48 | requests.fasl input.fasl fonts.fasl graphics.fasl text.fasl \ 49 | attributes.fasl translate.fasl keysyms.fasl manager.fasl image.fasl \ 50 | resource.fasl 51 | 52 | L_SRC = defsystem.cl package.cl excldep.cl depdefs.cl clx.cl \ 53 | dependent.cl exclcmac.cl macros.cl bufmac.cl buffer.cl \ 54 | display.cl gcontext.cl requests.cl input.cl fonts.cl \ 55 | graphics.cl text.cl attributes.cl translate.cl keysyms.cl \ 56 | manager.cl image.cl resource.cl 57 | 58 | # default and aliases 59 | all: no-clos 60 | # all: partial-clos 61 | compile-CLX-for-CLUE: compile-partial-clos-CLX 62 | clue: partial-clos 63 | 64 | # 65 | # Three build rules are provided: no-clos, partial-clos, and full-clos. 66 | # The first is no-clos, which results in a CLX whose datastructures are 67 | # all defstructs. partial-clos results in xlib:window, xlib:pixmap, and 68 | # xlib:drawable being CLOS instances, all others defstructs. full-clos 69 | # makes all CLX complex datatypes into CLOS instances. 70 | # 71 | # (note that the :clos feature implies native CLOS *not* PCL). 72 | # 73 | 74 | no-clos: $(C_OBJS) compile-no-clos-CLX cat 75 | 76 | # 77 | # This rule is used to compile CLX to be used with XCW version 2, or CLUE. 78 | # 79 | partial-clos: $(C_OBJS) compile-partial-clos-CLX cat 80 | 81 | full-clos: $(C_OBJS) compile-full-clos-CLX cat 82 | 83 | 84 | c: $(C_OBJS) 85 | 86 | 87 | compile-no-clos-CLX: $(C_OBJS) 88 | $(ECHO) " \ 89 | (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ 90 | #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ 91 | (load \"defsystem\") \ 92 | #+allegro (compile-system :clx) \ 93 | #-allegro (compile-clx) \ 94 | #+allegro (compile-system :clx-debug)" \ 95 | | $(CL) $(CLOPTS) -batch 96 | 97 | compile-partial-clos-CLX: $(C_OBJS) 98 | $(ECHO) " \ 99 | #-clos (setq excl::*print-nickname* t) \ 100 | (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ 101 | (unless (or (find-package 'clos) (find-package 'pcl)) \ 102 | (let ((spread (sys:gsgc-parameter :generation-spread))) \ 103 | (setf (sys:gsgc-parameter :generation-spread) 1) \ 104 | (require :pcl) \ 105 | (provide :pcl) \ 106 | (gc) (gc) \ 107 | (setf (sys:gsgc-parameter :generation-spread) spread))) \ 108 | #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ 109 | (load \"defsystem\") \ 110 | (load \"package\") \ 111 | (setq xlib::*def-clx-class-use-defclass* '(xlib:window xlib:pixmap xlib:drawable)) \ 112 | #+allegro (compile-system :clx) \ 113 | #-allegro (compile-clx \"\" \"\" :for-clue t) \ 114 | #+allegro (compile-system :clx-debug)" \ 115 | | $(CL) $(CLOPTS) -batch 116 | 117 | compile-full-clos-CLX: $(C_OBJS) 118 | $(ECHO) " \ 119 | #-clos (setq excl::*print-nickname* t) \ 120 | (proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)))) \ 121 | (unless (or (find-package 'clos) (find-package 'pcl)) \ 122 | (let ((spread (sys:gsgc-parameter :generation-spread))) \ 123 | (setf (sys:gsgc-parameter :generation-spread) 1) \ 124 | (require :pcl) \ 125 | (provide :pcl) \ 126 | (gc) (gc) \ 127 | (setf (sys:gsgc-parameter :generation-spread) spread))) \ 128 | #+(version>= 4 0) (pushnew :clx-ansi-common-lisp *features*) \ 129 | (load \"defsystem\") \ 130 | (load \"package\") \ 131 | (setq xlib::*def-clx-class-use-defclass* t) \ 132 | #+allegro (compile-system :clx) \ 133 | #-allegro (compile-clx \"\" \"\" :for-clue t) \ 134 | #+allegro (compile-system :clx-debug)" \ 135 | | $(CL) $(CLOPTS) -batch 136 | 137 | 138 | cat: 139 | -cat $(L_NOMACROS_OBJS) > CLX.fasl 140 | 141 | 142 | load-CLX: 143 | $(ECHO) " \ 144 | (let ((spread (sys:gsgc-parameter :generation-spread))) \ 145 | (setf (sys:gsgc-parameter :generation-spread) 1) \ 146 | (load \"defsystem\") \ 147 | #+allegro (load-system :clx) \ 148 | #-allegro (load-clx) \ 149 | (gc :tenure) \ 150 | (setf (sys:gsgc-parameter :generation-spread) spread)) \ 151 | (gc t)" \ 152 | '(dumplisp :name "$(CLX)" #+allegro :checkpoint #+allegro nil)' \ 153 | "(exit)" | $(CL) $(CLOPTS) 154 | 155 | clean: 156 | $(RM) -f *.fasl debug/*.fasl $(CLX) core $(C_OBJS) make.out 157 | 158 | 159 | install: 160 | mv CLX.fasl $(DEST)/clx.fasl 161 | mv *.o $(DEST) 162 | 163 | 164 | tags: 165 | $(TAGS) $(L_SRC) $(C_SRC) 166 | -------------------------------------------------------------------------------- /debug/util.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES; -*- 2 | 3 | ;; CLX utilities 4 | 5 | ;;; 6 | ;;; TEXAS INSTRUMENTS INCORPORATED 7 | ;;; P.O. BOX 2909 8 | ;;; AUSTIN, TEXAS 78769 9 | ;;; 10 | ;;; Copyright (C) 1987 Texas Instruments Incorporated. 11 | ;;; 12 | ;;; Permission is granted to any individual or institution to use, copy, modify, 13 | ;;; and distribute this software, provided that this complete copyright and 14 | ;;; permission notice is maintained, intact, in all copies and supporting 15 | ;;; documentation. 16 | ;;; 17 | ;;; Texas Instruments Incorporated provides this software "as is" without 18 | ;;; express or implied warranty. 19 | ;;; 20 | 21 | ;;; Created 04/09/87 14:30:41 by LaMott G. OREN 22 | 23 | (in-package :xlib) 24 | 25 | (eval-when (compile load eval) 26 | (export '(display-root 27 | display-black 28 | display-white 29 | report-events 30 | describe-window 31 | describe-gc 32 | degree 33 | radian 34 | display-refresh 35 | root-tree 36 | window-tree)) 37 | ) 38 | 39 | (defun display-root (display) (screen-root (display-default-screen display))) 40 | (defun display-black (display) (screen-black-pixel (display-default-screen display))) 41 | (defun display-white (display) (screen-white-pixel (display-default-screen display))) 42 | 43 | (defun report-events (display) 44 | (loop 45 | (unless 46 | (process-event display :handler #'(lambda (&rest args) (print args)) :discard-p t :timeout 0.001) 47 | (return nil)))) 48 | 49 | (defun describe-window (window) 50 | (macrolet ((da (attribute &key (transform 'progn) (format "~s")) 51 | (let ((func (intern (concatenate 'string (string 'window-) 52 | (string attribute)) 'xlib))) 53 | `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window)))))) 54 | (dg (attribute &key (transform 'progn) (format "~s")) 55 | (let ((func (intern (concatenate 'string (string 'drawable-) 56 | (string attribute)) 'xlib))) 57 | `(format t "~%~22a ~?" ',attribute ,format (list (,transform (,func window))))))) 58 | (with-state (window) 59 | (when (window-p window) 60 | (da visual :format "#x~x") 61 | (da class) 62 | (da gravity) 63 | (da bit-gravity) 64 | (da backing-store) 65 | (da backing-planes :format "#x~x") 66 | (da backing-pixel) 67 | (da save-under) 68 | (da colormap) 69 | (da colormap-installed-p) 70 | (da map-state) 71 | (da all-event-masks :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") 72 | (da event-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") 73 | (da do-not-propagate-mask :transform make-event-keys :format "~{~<~%~1:;~s ~>~}") 74 | (da override-redirect) 75 | ) 76 | (dg root) 77 | (dg depth) 78 | (dg x) 79 | (dg y) 80 | (dg width) 81 | (dg height) 82 | (dg border-width) 83 | 84 | ))) 85 | 86 | (defun describe-gc (gc) 87 | (macrolet ((dgc (name &key (transform 'progn) (format "~s")) 88 | (let ((func (intern (concatenate 'string (string 'gcontext-) 89 | (string name)) 'xlib))) 90 | `(format t "~%~22a ~?" ',name ,format (list (,transform (,func gc))))))) 91 | (dgc function) 92 | (dgc plane-mask) 93 | (dgc foreground) 94 | (dgc background) 95 | (dgc line-width) 96 | (dgc line-style) 97 | (dgc cap-style) 98 | (dgc join-style) 99 | (dgc fill-style) 100 | (dgc fill-rule) 101 | (dgc tile) 102 | (dgc stipple) 103 | (dgc ts-x) 104 | (dgc ts-y) 105 | (dgc font) ;; See below 106 | (dgc subwindow-mode) 107 | (dgc exposures) 108 | (dgc clip-x) 109 | (dgc clip-y) 110 | ;; (dgc clip-ordering) 111 | (dgc clip-mask) 112 | (dgc dash-offset) 113 | (dgc dashes) 114 | (dgc arc-mode) 115 | )) 116 | 117 | (defun degree (degrees) 118 | (* degrees (/ pi 180))) 119 | 120 | (defun radian (radians) 121 | (round (* radians (/ 180 pi)))) 122 | 123 | (defun display-refresh (host) 124 | ;; Useful for when the system writes to the screen (sometimes scrolling!) 125 | (let ((display (open-display host))) 126 | (unwind-protect 127 | (let ((screen (display-default-screen display))) 128 | (let ((win (create-window :parent (screen-root screen) :x 0 :y 0 :override-redirect :on 129 | :width (screen-width screen) :height (screen-height screen) 130 | :background (screen-black-pixel screen)))) 131 | (map-window win) 132 | (display-finish-output display) 133 | (unmap-window win) 134 | (destroy-window win) 135 | (display-finish-output display))) 136 | (close-display display)))) 137 | 138 | (defun root-tree (host) 139 | (let ((display (open-display host))) 140 | (unwind-protect 141 | (window-tree (screen-root (display-default-screen display))) 142 | (close-display display))) 143 | (values)) 144 | 145 | (defun window-tree (window &optional (depth 0)) 146 | ;; Print the window tree and properties starting from WINDOW 147 | ;; Returns a list of windows in the order that they are printed. 148 | (declare (arglist window) 149 | (type window window) 150 | (values (list window))) 151 | (let ((props (mapcar #'(lambda (prop) 152 | (multiple-value-bind (data type format) 153 | (get-property window prop) 154 | (case type 155 | (:string (setq data (coerce data 'string)))) 156 | (list prop format type data))) 157 | (list-properties window))) 158 | (result (list window))) 159 | (with-state (window) 160 | (format t "~%~v@t#x~x~20,20t X~3d Y~3d W~4d H~3d ~s" depth (window-id window) 161 | (drawable-x window) (drawable-y window) 162 | (drawable-width window) (drawable-height window) 163 | (window-map-state window))) 164 | (dolist (prop props) 165 | (format t "~%~v@t~{~s ~}" (+ depth 2) prop)) 166 | (dolist (w (query-tree window)) 167 | (setq result (nconc result (window-tree w (+ depth 2))))) 168 | result)) 169 | 170 | -------------------------------------------------------------------------------- /bufmac.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- 2 | 3 | ;;; This file contains macro definitions for the BUFFER object for Common-Lisp 4 | ;;; X windows version 11 5 | 6 | ;;; 7 | ;;; TEXAS INSTRUMENTS INCORPORATED 8 | ;;; P.O. BOX 2909 9 | ;;; AUSTIN, TEXAS 78769 10 | ;;; 11 | ;;; Copyright (C) 1987 Texas Instruments Incorporated. 12 | ;;; 13 | ;;; Permission is granted to any individual or institution to use, copy, modify, 14 | ;;; and distribute this software, provided that this complete copyright and 15 | ;;; permission notice is maintained, intact, in all copies and supporting 16 | ;;; documentation. 17 | ;;; 18 | ;;; Texas Instruments Incorporated provides this software "as is" without 19 | ;;; express or implied warranty. 20 | ;;; 21 | 22 | (in-package :xlib) 23 | 24 | ;;; The read- macros are in buffer.lisp, because event-case depends on (most of) them. 25 | 26 | (defmacro write-card8 (byte-index item) 27 | `(aset-card8 (the card8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) 28 | 29 | (defmacro write-int8 (byte-index item) 30 | `(aset-int8 (the int8 ,item) buffer-bbuf (index+ buffer-boffset ,byte-index))) 31 | 32 | (defmacro write-card16 (byte-index item) 33 | #+clx-overlapping-arrays 34 | `(aset-card16 (the card16 ,item) buffer-wbuf 35 | (index+ buffer-woffset (index-ash ,byte-index -1))) 36 | #-clx-overlapping-arrays 37 | `(aset-card16 (the card16 ,item) buffer-bbuf 38 | (index+ buffer-boffset ,byte-index))) 39 | 40 | (defmacro write-int16 (byte-index item) 41 | #+clx-overlapping-arrays 42 | `(aset-int16 (the int16 ,item) buffer-wbuf 43 | (index+ buffer-woffset (index-ash ,byte-index -1))) 44 | #-clx-overlapping-arrays 45 | `(aset-int16 (the int16 ,item) buffer-bbuf 46 | (index+ buffer-boffset ,byte-index))) 47 | 48 | (defmacro write-card32 (byte-index item) 49 | #+clx-overlapping-arrays 50 | `(aset-card32 (the card32 ,item) buffer-lbuf 51 | (index+ buffer-loffset (index-ash ,byte-index -2))) 52 | #-clx-overlapping-arrays 53 | `(aset-card32 (the card32 ,item) buffer-bbuf 54 | (index+ buffer-boffset ,byte-index))) 55 | 56 | (defmacro write-int32 (byte-index item) 57 | #+clx-overlapping-arrays 58 | `(aset-int32 (the int32 ,item) buffer-lbuf 59 | (index+ buffer-loffset (index-ash ,byte-index -2))) 60 | #-clx-overlapping-arrays 61 | `(aset-int32 (the int32 ,item) buffer-bbuf 62 | (index+ buffer-boffset ,byte-index))) 63 | 64 | (defmacro write-card29 (byte-index item) 65 | #+clx-overlapping-arrays 66 | `(aset-card29 (the card29 ,item) buffer-lbuf 67 | (index+ buffer-loffset (index-ash ,byte-index -2))) 68 | #-clx-overlapping-arrays 69 | `(aset-card29 (the card29 ,item) buffer-bbuf 70 | (index+ buffer-boffset ,byte-index))) 71 | 72 | ;; This is used for 2-byte characters, which may not be aligned on 2-byte boundaries 73 | ;; and always are written high-order byte first. 74 | (defmacro write-char2b (byte-index item) 75 | ;; It is impossible to do an overlapping write, so only nonoverlapping here. 76 | `(let ((%item ,item) 77 | (%byte-index (index+ buffer-boffset ,byte-index))) 78 | (declare (type card16 %item) 79 | (type array-index %byte-index)) 80 | (aset-card8 (the card8 (ldb (byte 8 8) %item)) buffer-bbuf %byte-index) 81 | (aset-card8 (the card8 (ldb (byte 8 0) %item)) buffer-bbuf (index+ %byte-index 1)))) 82 | 83 | (defmacro set-buffer-offset (value &environment env) 84 | env 85 | `(let ((.boffset. ,value)) 86 | (declare (type array-index .boffset.)) 87 | (setq buffer-boffset .boffset.) 88 | #+clx-overlapping-arrays 89 | ,@(when (member 16 (macroexpand '(%buffer-sizes) env)) 90 | `((setq buffer-woffset (index-ash .boffset. -1)))) 91 | #+clx-overlapping-arrays 92 | ,@(when (member 32 (macroexpand '(%buffer-sizes) env)) 93 | `((setq buffer-loffset (index-ash .boffset. -2)))) 94 | #+clx-overlapping-arrays 95 | .boffset.)) 96 | 97 | (defmacro advance-buffer-offset (value) 98 | `(set-buffer-offset (index+ buffer-boffset ,value))) 99 | 100 | (defmacro with-buffer-output ((buffer &key (sizes '(8 16 32)) length index) &body body) 101 | (unless (listp sizes) (setq sizes (list sizes))) 102 | `(let ((%buffer ,buffer)) 103 | (declare (type display %buffer)) 104 | ,(declare-bufmac) 105 | ,(when length 106 | `(when (index>= (index+ (buffer-boffset %buffer) ,length) (buffer-size %buffer)) 107 | (buffer-flush %buffer))) 108 | (let* ((buffer-boffset (the array-index ,(or index `(buffer-boffset %buffer)))) 109 | #-clx-overlapping-arrays 110 | (buffer-bbuf (buffer-obuf8 %buffer)) 111 | #+clx-overlapping-arrays 112 | ,@(append 113 | (when (member 8 sizes) 114 | `((buffer-bbuf (buffer-obuf8 %buffer)))) 115 | (when (or (member 16 sizes) (member 160 sizes)) 116 | `((buffer-woffset (index-ash buffer-boffset -1)) 117 | (buffer-wbuf (buffer-obuf16 %buffer)))) 118 | (when (member 32 sizes) 119 | `((buffer-loffset (index-ash buffer-boffset -2)) 120 | (buffer-lbuf (buffer-obuf32 %buffer)))))) 121 | (declare (type array-index buffer-boffset)) 122 | #-clx-overlapping-arrays 123 | (declare (type buffer-bytes buffer-bbuf) 124 | (array-register buffer-bbuf)) 125 | #+clx-overlapping-arrays 126 | ,@(append 127 | (when (member 8 sizes) 128 | '((declare (type buffer-bytes buffer-bbuf) 129 | (array-register buffer-bbuf)))) 130 | (when (member 16 sizes) 131 | '((declare (type array-index buffer-woffset)) 132 | (declare (type buffer-words buffer-wbuf) 133 | (array-register buffer-wbuf)))) 134 | (when (member 32 sizes) 135 | '((declare (type array-index buffer-loffset)) 136 | (declare (type buffer-longs buffer-lbuf) 137 | (array-register buffer-lbuf))))) 138 | buffer-boffset 139 | #-clx-overlapping-arrays 140 | buffer-bbuf 141 | #+clx-overlapping-arrays 142 | ,@(append 143 | (when (member 8 sizes) '(buffer-bbuf)) 144 | (when (member 16 sizes) '(buffer-woffset buffer-wbuf)) 145 | (when (member 32 sizes) '(buffer-loffset buffer-lbuf))) 146 | #+clx-overlapping-arrays 147 | (macrolet ((%buffer-sizes () ',sizes)) 148 | ,@body) 149 | #-clx-overlapping-arrays 150 | ,@body))) 151 | 152 | ;;; This macro is just used internally in buffer 153 | 154 | (defmacro writing-buffer-chunks (type args decls &body body) 155 | (when (> (length body) 2) 156 | (error "writing-buffer-chunks called with too many forms")) 157 | (let* ((size (* 8 (index-increment type))) 158 | (form #-clx-overlapping-arrays 159 | (first body) 160 | #+clx-overlapping-arrays ; XXX type dependencies 161 | (or (second body) 162 | (first body)))) 163 | `(with-buffer-output (buffer :index boffset :sizes ,(reverse (adjoin size '(8)))) 164 | ;; Loop filling the buffer 165 | (do* (,@args 166 | ;; Number of bytes needed to output 167 | (len ,(if (= size 8) 168 | `(index- end start) 169 | `(index-ash (index- end start) ,(truncate size 16))) 170 | (index- len chunk)) 171 | ;; Number of bytes available in buffer 172 | (chunk (index-min len (index- (buffer-size buffer) buffer-boffset)) 173 | (index-min len (index- (buffer-size buffer) buffer-boffset)))) 174 | ((not (index-plusp len))) 175 | (declare ,@decls 176 | (type array-index len chunk)) 177 | ,form 178 | (index-incf buffer-boffset chunk) 179 | ;; Flush the buffer 180 | (when (and (index-plusp len) (index>= buffer-boffset (buffer-size buffer))) 181 | (setf (buffer-boffset buffer) buffer-boffset) 182 | (buffer-flush buffer) 183 | (setq buffer-boffset (buffer-boffset buffer)) 184 | #+clx-overlapping-arrays 185 | ,(case size 186 | (16 '(setq buffer-woffset (index-ash buffer-boffset -1))) 187 | (32 '(setq buffer-loffset (index-ash buffer-boffset -2)))))) 188 | (setf (buffer-boffset buffer) (lround buffer-boffset))))) 189 | -------------------------------------------------------------------------------- /debug/event-test.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (XTEST (XLIB LISP)); Base: 10; Lowercase: Yes -*- 2 | 3 | (in-package :xtest :use '(:xlib :lisp)) 4 | 5 | (defstruct event 6 | key ; Event key 7 | display ; Display event was reported to 8 | ;; The following are from the CLX event 9 | code 10 | state 11 | time 12 | event-window 13 | root 14 | drawable 15 | window 16 | child 17 | parent 18 | root-x 19 | root-y 20 | x 21 | y 22 | width 23 | height 24 | border-width 25 | override-redirect-p 26 | same-screen-p 27 | configure-p 28 | hint-p 29 | kind 30 | mode 31 | keymap 32 | focus-p 33 | count 34 | major 35 | minor 36 | above-sibling 37 | place 38 | atom 39 | selection 40 | requestor 41 | target 42 | property 43 | colormap 44 | new-p 45 | installed-p 46 | format 47 | type 48 | data 49 | send-event-p 50 | ) 51 | 52 | (defun process-input (display &optional timeout) 53 | "Process one event" 54 | (declare (type display display) ; The display (from initialize-clue) 55 | (type (or null number) timeout) ; optional timeout in seconds 56 | (values (or null character))) ; Returns NIL only if timeout exceeded 57 | (let ((event (make-event))) 58 | (setf (event-display event) display) 59 | (macrolet ((set-event (&rest parameters) 60 | `(progn ,@(mapcar #'(lambda (parm) 61 | `(setf (,(intern (concatenate 'string 62 | (string 'event-) 63 | (string parm))) 64 | event) ,parm)) 65 | parameters))) 66 | (dispatch (contact) 67 | `(dispatch-event event event-key send-event-p ,contact))) 68 | 69 | (let ((result 70 | (xlib:event-case (display :timeout timeout :force-output-p t) 71 | ((:key-press :key-release :button-press :button-release) 72 | (code time root window child root-x root-y x y 73 | state same-screen-p event-key send-event-p) 74 | (set-event code time root window child root-x root-y x y 75 | state same-screen-p) 76 | (dispatch window)) 77 | 78 | (:motion-notify 79 | (hint-p time root window child root-x root-y x y 80 | state same-screen-p event-key send-event-p) 81 | (set-event hint-p time root window child root-x root-y x y 82 | state same-screen-p) 83 | (dispatch window)) 84 | 85 | ((:enter-notify :leave-notify) 86 | (kind time root window child root-x root-y x y 87 | state mode focus-p same-screen-p event-key send-event-p) 88 | (set-event kind time root window child root-x root-y x y 89 | state mode focus-p same-screen-p) 90 | (dispatch window)) 91 | 92 | ((:focus-in :focus-out) 93 | (kind window mode event-key send-event-p) 94 | (set-event kind window mode) 95 | (dispatch window)) 96 | 97 | (:keymap-notify 98 | (window keymap event-key send-event-p) 99 | (set-event window keymap) 100 | (dispatch window)) 101 | 102 | (:exposure 103 | (window x y width height count event-key send-event-p) 104 | (set-event window x y width height count) 105 | (dispatch window)) 106 | 107 | (:graphics-exposure 108 | (drawable x y width height count major minor event-key send-event-p) 109 | (set-event drawable x y width height count major minor) 110 | (dispatch drawable)) 111 | 112 | (:no-exposure 113 | (drawable major minor event-key send-event-p) 114 | (set-event drawable major minor) 115 | (dispatch drawable)) 116 | 117 | (:visibility-notify 118 | (window state event-key send-event-p) 119 | (set-event window state) 120 | (dispatch window)) 121 | 122 | (:create-notify 123 | (parent window x y width height border-width 124 | override-redirect-p event-key send-event-p) 125 | (set-event parent window x y width height border-width 126 | override-redirect-p) 127 | (dispatch parent)) 128 | 129 | (:destroy-notify 130 | (event-window window event-key send-event-p) 131 | (set-event event-window window) 132 | (dispatch event-window)) 133 | 134 | (:unmap-notify 135 | (event-window window configure-p event-key send-event-p) 136 | (set-event event-window window configure-p) 137 | (dispatch event-window)) 138 | 139 | (:map-notify 140 | (event-window window override-redirect-p event-key send-event-p) 141 | (set-event event-window window override-redirect-p) 142 | (dispatch event-window)) 143 | 144 | (:map-request 145 | (parent window event-key send-event-p) 146 | (set-event parent window) 147 | (dispatch parent)) 148 | 149 | (:reparent-notify 150 | (event-window window parent x y override-redirect-p event-key send-event-p) 151 | (set-event event-window window parent x y override-redirect-p) 152 | (dispatch event-window)) 153 | 154 | (:configure-notify 155 | (event-window window above-sibling x y width height border-width 156 | override-redirect-p event-key send-event-p) 157 | (set-event event-window window above-sibling x y width height 158 | border-width override-redirect-p) 159 | (dispatch event-window)) 160 | 161 | (:configure-request 162 | (parent window above-sibling x y width height border-width event-key send-event-p) 163 | (set-event parent window above-sibling x y width height border-width) 164 | (dispatch parent)) 165 | 166 | (:gravity-notify 167 | (event-window window x y event-key send-event-p) 168 | (set-event event-window window x y) 169 | (dispatch event-window)) 170 | 171 | (:resize-request 172 | (window width height event-key send-event-p) 173 | (set-event window width height) 174 | (dispatch window)) 175 | 176 | (:circulate-notify 177 | (event-window window parent place event-key send-event-p) 178 | (set-event event-window window parent place) 179 | (dispatch event-window)) 180 | 181 | (:circulate-request 182 | (parent window place event-key send-event-p) 183 | (set-event parent window place) 184 | (dispatch parent)) 185 | 186 | (:property-notify 187 | (window atom time state event-key send-event-p) 188 | (set-event window atom time state) 189 | (dispatch window)) 190 | 191 | (:selection-clear 192 | (time window selection event-key send-event-p) 193 | (set-event time window selection) 194 | (dispatch window)) 195 | 196 | (:selection-request 197 | (time window requestor selection target property event-key send-event-p) 198 | (set-event time window requestor selection target property) 199 | (dispatch window)) 200 | 201 | (:selection-notify 202 | (time window selection target property event-key send-event-p) 203 | (set-event time window selection target property) 204 | (dispatch window)) 205 | 206 | (:colormap-notify 207 | (window colormap new-p installed-p event-key send-event-p) 208 | (set-event window colormap new-p installed-p) 209 | (dispatch window)) 210 | 211 | (:client-message 212 | (format window type data event-key send-event-p) 213 | (set-event format window type data) 214 | (dispatch window)) 215 | 216 | (:mapping-notify 217 | (request start count) 218 | (mapping-notify display request start count)) ;; Special case 219 | ))) 220 | (and result t))))) 221 | 222 | (defun event-case-test (display) 223 | ;; Tests universality of display, event-key, event-code, send-event-p and event-window 224 | (event-case (display) 225 | ((key-press key-release button-press button-release motion-notify 226 | enter-notify leave-notify focus-in focus-out keymap-notify 227 | exposure graphics-exposure no-exposure visibility-notify 228 | create-notify destroy-notify unmap-notify map-notify map-request 229 | reparent-notify configure-notify gravity-notify resize-request 230 | configure-request circulate-notify circulate-request property-notify 231 | selection-clear selection-request selection-notify colormap-notify client-message) 232 | (display event-key event-code send-event-p event-window) 233 | (print (list display event-key event-code send-event-p event-window))) 234 | (mapping-notify ;; mapping-notify doesn't have event-window 235 | (display event-key event-code send-event-p) 236 | (print (list display event-key event-code send-event-p))) 237 | )) 238 | -------------------------------------------------------------------------------- /excldep.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- 2 | ;;; 3 | ;;; CLX -- excldep.cl 4 | ;;; 5 | ;;; copyright (c) 1987-1989 Franz Inc, Berkeley, CA - All rights reserved. 6 | ;; copyright (c) 1989-2004 Franz Inc, Oakland, CA - All rights reserved. 7 | ;;; 8 | ;;; Permission is granted to any individual or institution to use, copy, 9 | ;;; modify, and distribute this software, provided that this complete 10 | ;;; copyright and permission notice is maintained, intact, in all copies and 11 | ;;; supporting documentation. 12 | ;;; 13 | ;;; Franz Incorporated provides this software "as is" without 14 | ;;; express or implied warranty. 15 | ;;; 16 | 17 | (in-package :xlib) 18 | 19 | #+(version>= 5 0) 20 | (eval-when (compile) 21 | (require :foreign)) 22 | 23 | (eval-when (compile load eval) 24 | #-(or (version>= 5 0) mswindows) (require :foreign) 25 | (require :process) ; Needed even if scheduler is not 26 | ; running. (Must be able to make 27 | ; a process-lock.) 28 | ) 29 | 30 | (eval-when (load eval) 31 | (provide :clx)) 32 | 33 | 34 | #-(or little-endian big-endian) 35 | (eval-when (eval compile load) 36 | (let ((x '#(1))) 37 | (if (not (eq 0 (sys::memref x 38 | #.(sys::mdparam 'comp::md-svector-data0-adj) 39 | 0 :unsigned-byte))) 40 | (pushnew :little-endian *features*) 41 | (pushnew :big-endian *features*)))) 42 | 43 | #-(version>= 4 1) 44 | (eval-when (compile load eval) 45 | (defmacro define-compiler-macro (&rest args) 46 | `(excl::defcmacro ,@args))) 47 | 48 | (defmacro correct-case (string) 49 | ;; This macro converts the given string to the 50 | ;; current preferred case, or leaves it alone in a case-sensitive mode. 51 | (let ((str (gensym))) 52 | `(let ((,str ,string)) 53 | (case excl::*current-case-mode* 54 | (:case-insensitive-lower 55 | (string-downcase ,str)) 56 | (:case-insensitive-upper 57 | (string-upcase ,str)) 58 | ((:case-sensitive-lower :case-sensitive-upper) 59 | ,str))))) 60 | 61 | ;; Return t if there is a character available for reading or on error, 62 | ;; otherwise return nil. 63 | #-(version>= 6 0) 64 | (progn 65 | 66 | #-(or (version>= 4 2) mswindows) 67 | (defun fd-char-avail-p (fd) 68 | (multiple-value-bind (available-p errcode) 69 | (comp::.primcall-sargs 'sys::filesys #.excl::fs-char-avail fd) 70 | (excl:if* errcode 71 | then t 72 | else available-p))) 73 | 74 | #+(and (version>= 4 2) (not mswindows)) 75 | (defun fd-char-avail-p (fd) 76 | (excl::filesys-character-available-p fd)) 77 | 78 | #+mswindows 79 | (defun fd-char-avail-p (socket-stream) 80 | (listen socket-stream)) 81 | ) 82 | #+(version>= 6 0) 83 | (defun fd-char-avail-p (socket-stream) 84 | (excl::read-no-hang-p socket-stream)) 85 | 86 | (defmacro with-interrupt-checking-on (&body body) 87 | `(locally (declare (optimize (safety 1))) 88 | ,@body)) 89 | 90 | ;; Read from the given fd into 'vector', which has element type card8. 91 | ;; Start storing at index 'start-index' and read exactly 'length' bytes. 92 | ;; Return t if an error or eof occurred, nil otherwise. 93 | #-(and (version>= 6) clx-use-allegro-streams) 94 | (defun fd-read-bytes (fd vector start-index length) 95 | (declare (fixnum #-mswindows fd start-index length) 96 | (type (simple-array (unsigned-byte 8) (*)) vector)) 97 | (with-interrupt-checking-on 98 | (do ((rest length)) 99 | ((eq 0 rest) nil) 100 | (declare (fixnum rest)) 101 | ;; added by cac 24jul99 102 | ;; Crude but effective way to wait for input when whole buffer 103 | ;; doesn't get filled all at once. Probably should 104 | ;; make more robust in light of possible failing sockets. 105 | (loop 106 | (when (fd-char-avail-p fd) 107 | (return))) 108 | (multiple-value-bind (numread errcode) 109 | #-(version>= 4 2) 110 | (comp::.primcall-sargs 'sys::filesys #.excl::fs-read-bytes fd vector 111 | start-index rest) 112 | #+(version>= 4 2) 113 | (excl::fill-read-buffer #-mswindows fd 114 | #+mswindows (excl::stream-input-fn fd) 115 | vector start-index rest) 116 | (declare (fixnum numread)) 117 | (excl:if* errcode 118 | then (if (not (eq errcode 119 | excl::*error-code-interrupted-system-call*)) 120 | (return t)) 121 | elseif (eq 0 numread) 122 | then (return t) 123 | else (decf rest numread) 124 | (incf start-index numread)))))) 125 | 126 | #+(and (version>= 6) clx-use-allegro-streams) 127 | (defun fd-read-bytes (fd vector start-index length) 128 | ;; Read from the given stream fd into 'vector', which has element type card8. 129 | ;; Start storing at index 'start-index' and read exactly 'length' bytes. 130 | ;; Return t if an error or eof occurred, nil otherwise. 131 | (declare (fixnum start-index length)) 132 | (with-interrupt-checking-on 133 | (let ((end-index (+ start-index length))) 134 | (loop 135 | (let ((next-index (excl:read-vector vector fd 136 | :start start-index 137 | :end end-index))) 138 | (excl:if* (eq next-index start-index) 139 | then ; end of file before was all filled up 140 | (return t) 141 | elseif (eq next-index end-index) 142 | then ; we're all done 143 | (return nil) 144 | else (setq start-index next-index))))))) 145 | 146 | 147 | #-(or (version>= 5 0) mswindows) 148 | (unless (ff:get-entry-point (ff:convert-to-lang "fd_wait_for_input")) 149 | (ff:remove-entry-point (ff:convert-to-lang "fd_wait_for_input")) 150 | #+dlfcn (load "clx:excldep.so") 151 | #+dlhp (load "clx:excldep.sl") 152 | #-dynload (load "clx:excldep.o")) 153 | 154 | #-(or (version>= 5 0) mswindows) 155 | (unless (ff:get-entry-point (ff:convert-to-lang "connect_to_server")) 156 | (ff:remove-entry-point (ff:convert-to-lang "connect_to_server" :language :c)) 157 | #+dlfcn (load "clx:socket.so") 158 | #+dlhp (load "clx:socket.sl") 159 | #-dynload (load "clx:socket.o")) 160 | 161 | #-(or (version>= 5 0) mswindows) 162 | (ff:defforeign-list `((connect-to-server 163 | :entry-point 164 | ,(ff:convert-to-lang "connect_to_server") 165 | :return-type :fixnum 166 | :arg-checking nil 167 | :strings-convert nil ; cac 25feb00 168 | :arguments (string fixnum)) 169 | (fd-wait-for-input 170 | :entry-point ,(ff:convert-to-lang "fd_wait_for_input") 171 | :return-type :fixnum 172 | :arg-checking nil 173 | :call-direct t 174 | :callback nil 175 | :allow-other-keys t 176 | :arguments (fixnum fixnum)))) 177 | 178 | #+(and (version>= 5 0) (not mswindows)) 179 | (progn 180 | (unless (excl::get-entry-point (excl::convert-foreign-name "fd_wait_for_input")) 181 | (load (format nil "clx:excldep.~a" (car excl::*load-foreign-types*)))) 182 | 183 | (ff:def-foreign-call (fd-wait-for-input "fd_wait_for_input") 184 | ((fd :int fixnum) (timeout :int fixnum)) 185 | :returning (:int fixnum) 186 | :call-direct t 187 | :arg-checking nil) 188 | ) 189 | 190 | #+(and (version>= 5 0) (not clx-use-allegro-streams)) 191 | (progn 192 | (unless (excl::get-entry-point (excl::convert-foreign-name "connect_to_server")) 193 | (load (format nil "clx:socket.~a" (car excl::*load-foreign-types*)))) 194 | 195 | (ff:def-foreign-call (connect-to-server "connect_to_server") 196 | ((host (* :char) simple-string) (display :int fixnum)) 197 | :returning (:int fixnum) 198 | :strings-convert nil ; cac 25feb00 199 | :arg-checking nil) 200 | ) 201 | 202 | 203 | (eval-when (compile) 204 | (declaim (declaration buffer-bytes)) 205 | ) 206 | 207 | ;; Bring in and rename the old filesys-read-bytes from where it is 208 | ;; defined in streamc.cl, but streamc might no longer be available: 209 | 210 | (in-package :excl) 211 | 212 | (eval-when (compile eval) 213 | (require :iodefs)) 214 | 215 | (defun excl-write-bytes (handle svector start-index length stream) 216 | ;; Write the contents of the simple-vector to the given handle. 217 | ;; Start at start-index and write length bytes, counting 8 bit bytes. 218 | ;; The loop and retry on EINTR is necessary on some machines because random 219 | ;; alarm signals can cause a write that has been blocked to return EINTR. 220 | (declare (optimize speed) 221 | (type adim start-index length)) 222 | (let ( ;; [bug16880]: 223 | #+ignore (*stream-for-sigpipe* (or *stream-for-sigpipe* stream))) 224 | (fast 225 | (loop 226 | (multiple-value-bind (written errcode) 227 | (if* (streamp handle) 228 | then (let ((res (write-vector-2 svector handle start-index (+ start-index length) 0 0))) 229 | (declare (type adim res)) 230 | (- res start-index)) 231 | else (excl::.primcall 'sys::filesys #.fs-write-bytes 232 | handle svector start-index length)) 233 | (if* errcode 234 | then (if* (or (eq errcode (fast *error-code-would-block*)) 235 | (eq errcode (fast *error-code-eagain*))) 236 | then (let* ((fnn (- -1 handle)) 237 | (sys::*thread-watchfor-fds* 238 | (cons fnn sys::*thread-watchfor-fds*)) 239 | ) 240 | (excl::funcall-in-package 241 | :process-wait :multiprocessing "Blocked on output to socket" 242 | #'write-no-hang-p handle)) ;; [bug11901], [bug12195] 243 | elseif (eql errcode 244 | #-mswindows 32 ; sigpipe 245 | #+mswindows 10053 ; WSAECONNABORTED 246 | ) 247 | then ;; [bug16880]: indicate that this stream can't be written to any more 248 | (xlib::close-buffer stream) 249 | elseif (not (eq errcode *error-code-interrupted-system-call*)) 250 | then (.errno-stream-error "writing bytes to" handle errcode)) 251 | (setq written 0) ; if error assume 0 written 252 | else (decf length written) 253 | (if* (<= length 0) 254 | then (return t) 255 | else (incf start-index written)))))))) 256 | 257 | 258 | #+(version>= 8 2) 259 | (eval-when (compile load eval) 260 | (pushnew :allegro-pre-smp *features*) 261 | (require :smputil) 262 | ) 263 | 264 | -------------------------------------------------------------------------------- /debug/keytrans.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*- 2 | 3 | ;;; CLX keysym-translation test programs 4 | 5 | ;;; 6 | ;;; TEXAS INSTRUMENTS INCORPORATED 7 | ;;; P.O. BOX 2909 8 | ;;; AUSTIN, TEXAS 78769 9 | ;;; 10 | ;;; Copyright (C) 1987 Texas Instruments Incorporated. 11 | ;;; 12 | ;;; Permission is granted to any individual or institution to use, copy, modify, 13 | ;;; and distribute this software, provided that this complete copyright and 14 | ;;; permission notice is maintained, intact, in all copies and supporting 15 | ;;; documentation. 16 | ;;; 17 | ;;; Texas Instruments Incorporated provides this software "as is" without 18 | ;;; express or implied warranty. 19 | ;;; 20 | 21 | (in-package :xlib) 22 | 23 | (defun list-missing-keysyms () 24 | ;; Lists explorer characters which have no keysyms 25 | (dotimes (i 256) 26 | (unless (character->keysyms (character i)) 27 | (format t "~%(define-keysym ~@c ~d)" (character i) i)))) 28 | 29 | (defun list-multiple-keysyms () 30 | ;; Lists characters with more than one keysym 31 | (dotimes (i 256) 32 | (when (cdr (character->keysyms (character i))) 33 | (format t "~%Character ~@c [~d] has keysyms" (character i) i) 34 | (dolist (keysym (character->keysyms (character i))) 35 | (format t " ~d ~d" (ldb (byte 8 8) keysym) (ldb (byte 8 0) keysym)))))) 36 | 37 | (defun check-lowercase-keysyms () 38 | ;; Checks for keysyms with incorrect :lowercase parameters 39 | (maphash #'(lambda (key mapping) 40 | (let* ((value (car mapping)) 41 | (char (keysym-mapping-object value))) 42 | (if (and (characterp char) (both-case-p char) 43 | (= (char-int char) (char-int (char-upcase char)))) 44 | ;; uppercase alphabetic character 45 | (unless (eq (keysym-mapping-lowercase value) 46 | (char-int (char-downcase char))) 47 | (let ((lowercase (keysym-mapping-lowercase value)) 48 | (should-be (char-downcase char))) 49 | (format t "~%Error keysym ~3d ~3d (~@c) has :Lowercase ~3d ~3d (~s) Should be ~3d ~3d (~@c)" 50 | (ldb (byte 8 8) key) 51 | (ldb (byte 8 0) key) 52 | char 53 | (and lowercase (ldb (byte 8 8) lowercase)) 54 | (and lowercase (ldb (byte 8 0) lowercase)) 55 | (character lowercase) 56 | (ldb (byte 8 8) (char-int should-be)) 57 | (ldb (byte 8 0) (char-int should-be)) 58 | should-be))) 59 | (when (keysym-mapping-lowercase value) 60 | (let ((lowercase (keysym-mapping-lowercase value))) 61 | (format t "~%Error keysym ~3d ~3d (~@c) has :lowercase ~3d ~3d (~@c) and shouldn't" 62 | (ldb (byte 8 8) key) 63 | (ldb (byte 8 0) key) 64 | char 65 | (and lowercase (ldb (byte 8 8) (char-int lowercase))) 66 | (and lowercase (ldb (byte 8 0) (char-int lowercase))) 67 | lowercase 68 | )))))) 69 | *keysym->character-map*)) 70 | 71 | (defun print-all-keysyms () 72 | (let ((all nil)) 73 | (maphash #'(lambda (key value) (push (cons key value) all)) *keysym->character-map*) 74 | (setq all (sort all #'< :key #'car)) 75 | (format t "~%~d keysyms:" (length all)) 76 | 77 | (dolist (keysym all) 78 | (format t "~%~3d ~3d~{ ~s~}" 79 | (ldb (byte 8 8) (car keysym)) 80 | (ldb (byte 8 0) (car keysym)) 81 | (cadr keysym)) 82 | (dolist (mapping (cddr keysym)) 83 | (format t "~%~7@t~{ ~s~}" mapping))))) 84 | 85 | (defun keysym-mappings (keysym &key display (mask-format #'identity)) 86 | ;; Return all the keysym mappings for keysym. 87 | ;; Returns a list of argument lists that are argument-lists to define-keysym. 88 | ;; The following will re-create the mappings for KEYSYM: 89 | ;; (dolist (mapping (keysym-mappings) keysym) 90 | ;; (apply #'define-keysym mapping)) 91 | (let ((mappings (append (and display (cdr (assoc keysym (display-keysym-translation display)))) 92 | (gethash keysym *keysym->character-map*))) 93 | (result nil)) 94 | (dolist (mapping mappings) 95 | (let ((object (keysym-mapping-object mapping)) 96 | (translate (keysym-mapping-translate mapping)) 97 | (lowercase (keysym-mapping-lowercase mapping)) 98 | (modifiers (keysym-mapping-modifiers mapping)) 99 | (mask (keysym-mapping-mask mapping))) 100 | (push (append (list object keysym) 101 | (when translate (list :translate translate)) 102 | (when lowercase (list :lowercase lowercase)) 103 | (when modifiers (list :modifiers (funcall mask-format modifiers))) 104 | (when mask (list :mask (funcall mask-format mask)))) 105 | result))) 106 | (nreverse result))) 107 | 108 | #+comment 109 | (defun print-keysym-mappings (keysym &optional display) 110 | (format t "~%(keysym ~d ~3d) " 111 | (ldb (byte 8 8) keysym) 112 | (ldb (byte 8 0) keysym)) 113 | (dolist (mapping (keysym-mappings keysym :display display)) 114 | (format t "~16t~{ ~s~}~%" mapping))) 115 | 116 | (defun print-keysym-mappings (keysym &optional display) 117 | (flet ((format-mask (mask) 118 | (cond ((numberp mask) 119 | `(make-state-mask ,@(make-state-keys mask))) 120 | ((atom mask) mask) 121 | (t `(list ,@(mapcar 122 | #'(lambda (item) 123 | (if (numberp item) 124 | `(keysym ,(keysym-mapping-object 125 | (car (gethash item *keysym->character-map*)))) 126 | item)) 127 | mask)))))) 128 | (dolist (mapping (keysym-mappings keysym :display display :mask-format #'format-mask)) 129 | (format t "~%(define-keysym ~s (keysym ~d ~3d)~{ ~s~})" 130 | (car mapping) 131 | (ldb (byte 8 8) keysym) 132 | (ldb (byte 8 0) keysym) 133 | (cdr mapping))))) 134 | 135 | (defun keysym-test (host) 136 | ;; Server key-press Loop-back test 137 | (let* ((display (open-display host)) 138 | (width 400) 139 | (height 400) 140 | (screen (display-default-screen display)) 141 | (black (screen-black-pixel screen)) 142 | (white (screen-white-pixel screen)) 143 | (win (create-window 144 | :parent (screen-root screen) 145 | :background black 146 | :border white 147 | :border-width 1 148 | :colormap (screen-default-colormap screen) 149 | :bit-gravity :center 150 | :event-mask '(:exposure :key-press) 151 | :x 20 :y 20 152 | :width width :height height)) 153 | #+comment 154 | (gc (create-gcontext 155 | :drawable win 156 | :background black 157 | :foreground white))) 158 | (initialize-extensions display) 159 | 160 | (map-window win) ; Map the window 161 | ;; Handle events 162 | (unwind-protect 163 | (dotimes (state 64) 164 | (do ((code (display-min-keycode display) (1+ code))) 165 | ((> code (display-max-keycode display))) 166 | (send-event win :key-press '(:key-press) :code code :state state 167 | :window win :root (screen-root screen) :time 0 168 | :x 1 :y 2 :root-x 10 :root-y 20 :same-screen-p t) 169 | (event-case (display :force-output-p t :discard-p t) 170 | (exposure ;; Come here on exposure events 171 | (window count) 172 | (when (zerop count) ;; Ignore all but the last exposure event 173 | (clear-area window)) 174 | nil) 175 | (key-press (display code state) 176 | (princ (keycode->character display code state)) 177 | t)))) 178 | (close-display display)))) 179 | 180 | (defun keysym-echo (host &optional keymap-p) 181 | ;; Echo characters typed to a window 182 | (let* ((display (open-display host)) 183 | (width 400) 184 | (height 400) 185 | (screen (display-default-screen display)) 186 | (black (screen-black-pixel screen)) 187 | (white (screen-white-pixel screen)) 188 | (win (create-window 189 | :parent (screen-root screen) 190 | :background black 191 | :border white 192 | :border-width 1 193 | :colormap (screen-default-colormap screen) 194 | :bit-gravity :center 195 | :event-mask '(:exposure :key-press :keymap-state :enter-window) 196 | :x 20 :y 20 197 | :width width :height height)) 198 | (gc (create-gcontext 199 | :drawable win 200 | :background black 201 | :foreground white))) 202 | (initialize-extensions display) 203 | 204 | (map-window win) ; Map the window 205 | ;; Handle events 206 | (unwind-protect 207 | (event-case (display :force-output-p t :discard-p t) 208 | (exposure ;; Come here on exposure events 209 | (window count) 210 | (when (zerop count) ;; Ignore all but the last exposure event 211 | (clear-area window) 212 | (draw-glyphs window gc 10 10 "Press to exit")) 213 | nil) 214 | (key-press (display code state) 215 | (let ((char (keycode->character display code state))) 216 | (format t "~%Code: ~s State: ~s Char: ~s" code state char) 217 | ;; (PRINC char) (PRINC " ") 218 | (when keymap-p 219 | (let ((keymap (query-keymap display))) 220 | (unless (character-in-map-p display char keymap) 221 | (print "character-in-map-p failed") 222 | (print-keymap keymap)))) 223 | ;; (when (eql char #\0) (setq disp display) (break)) 224 | (eql char #\escape))) 225 | (keymap-notify (keymap) 226 | (print "Keymap-notify") ;; we never get here. Server bug? 227 | (when (keysym-in-map-p display 65 keymap) 228 | (print "Found A")) 229 | (when (character-in-map-p display #\b keymap) 230 | (print "Found B"))) 231 | (enter-notify (event-window) (format t "~%Enter ~s" event-window))) 232 | (close-display display)))) 233 | 234 | (defun print-keymap (keymap) 235 | (do ((j 32 (+ j 32))) ;; first 32 bits is for window 236 | ((>= j 256)) 237 | (format t "~% ~3d: " j) 238 | (do ((i j (1+ i))) 239 | ((>= i (+ j 32))) 240 | (when (zerop (logand i 7)) 241 | (princ " ")) 242 | (princ (aref keymap i))))) 243 | 244 | (defun define-keysym-test (&key display printp 245 | (modifiers (list (keysym :left-meta))) (mask :modifiers)) 246 | (let* ((keysym 067) 247 | (args `(baz ,keysym :modifiers ,modifiers ,@(and mask `(:mask ,mask)))) 248 | (original (copy-tree (keysym-mappings keysym :display display)))) 249 | (when printp (print-keysym-mappings 67) (terpri)) 250 | (apply #'define-keysym args) 251 | (when printp (print-keysym-mappings 67) (terpri)) 252 | (let ((is (keysym-mappings keysym :display display)) 253 | (should-be (append original (list args)))) 254 | (unless (equal is should-be) 255 | (cerror "Ignore" "define-keysym error. ~%is: ~s ~%Should be: ~s" is should-be))) 256 | (apply #'undefine-keysym args) 257 | (when printp (print-keysym-mappings 67) (terpri)) 258 | (let ((is (keysym-mappings keysym :display display))) 259 | (unless (equal is original) 260 | (cerror "Ignore" "undefine-keysym error. ~%is: ~s ~%Should be: ~s" is original))))) 261 | 262 | (define-keysym-test) 263 | (define-keysym-test :modifiers (make-state-mask :shift :lock)) 264 | (define-keysym-test :modifiers (list :shift (keysym :left-meta) :control)) 265 | (define-keysym-test :modifiers (make-state-mask :shift :lock) :mask nil) 266 | 267 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for CLX 2 | 3 | SHELL = sh 4 | 5 | FICODESIGN = ../src/scm-bin/ficodesign 6 | 7 | makefile_top = $(shell if test -f ../makefile.top; then echo exists; fi) 8 | 9 | ifeq ($(makefile_top),exists) 10 | include ../makefile.top 11 | include ../makefile.defs 12 | endif 13 | 14 | iacl = yes 15 | 16 | ifdef iacl 17 | lispexe = lispi$(exe) 18 | lispdxl = dcli.dxl 19 | else 20 | lispexe = lisp$(exe) 21 | lispdxl = dcl.dxl 22 | endif 23 | 24 | # For versions prior to ACL 5.0 (and 4.3.2 on Windows), comment out the 25 | # following line: 26 | SAVEIMG = yes 27 | 28 | # ************************************************************************* 29 | # * Change the next line to point to where you have Common Lisp installed * 30 | # * (make sure the Lisp doesn't already have CLX loaded in) * 31 | # ************************************************************************* 32 | ifdef SAVEIMG 33 | ifeq ($(OS_NAME),windows) 34 | CL = bash ../src/runlisp.sh -f clx.tmp ../src/$(lispexe) -I ../src/$(lispdxl) 35 | else 36 | CL = cat clx.tmp | ../src/$(lispexe) -I ../src/$(lispdxl) 37 | endif 38 | # Name of dumped lisp 39 | CLX = clx.dxl 40 | DUMPLISP_ARGS = 41 | else 42 | CL = cat clx.tmp | ../src/dcl 43 | # Name of dumped lisp 44 | CLX = clx 45 | DUMPLISP_ARGS = :checkpoint nil 46 | endif 47 | 48 | ifeq ($(OS_NAME),windows) 49 | ECHO = echo 50 | else 51 | ECHO = echo 52 | endif 53 | MV = mv 54 | TAGS = /usr/local/lib/emacs/etc/etags 55 | 56 | CLOPTS = -qq 57 | 58 | SO = so 59 | 60 | ifeq ($(OS_NAME),hp-ux) 61 | CC = /usr/bin/cc 62 | else 63 | CC = cc 64 | endif 65 | 66 | ifeq ($(OS_NAME),aix) 67 | ifeq ($(SIXTYFOURBIT),yes) 68 | XCFLAGS = -D_BSD -D_NO_PROTO -D_NONSTD_TYPES -D_MBI=void -q64 -DAcl64Bit 69 | MAKE_SHARED = sh ../src/bin/make_shared.ibm64 -make_exp ../src/bin/make_exp 70 | else 71 | XCFLAGS = -D_BSD -D_NO_PROTO -D_NONSTD_TYPES -D_MBI=void 72 | MAKE_SHARED = sh ../src/bin/make_shared.ibm -make_exp ../src/bin/make_exp 73 | endif 74 | endif 75 | 76 | ifeq ($(OS_NAME),hp-ux) 77 | ifeq ($(SIXTYFOURBIT),yes) 78 | XCFLAGS = -O -Ae +DA2.0W -DAcl64Bit 79 | MAKE_SHARED = sh ../src/bin/make_shared.hp64 80 | PICFLAGS = +Z 81 | #CC = aCC 82 | else 83 | XCFLAGS = -O -Ae +DA1.1 84 | SO = sl 85 | MAKE_SHARED = sh ../src/bin/make_shared.hp 86 | PICFLAGS = +z 87 | endif 88 | endif 89 | 90 | ifeq ($(OS_NAME),darwin) 91 | PICFLAGS = 92 | SHAREFLAGS = 93 | SO = dylib 94 | ifeq ($(SIXTYFOURBIT),yes) 95 | MAKE_SHARED = sh ../src/bin/make_shared.mac64 96 | ifeq ($(MACHINE),x86_64) 97 | XCFLAGS = -I/usr/X11/include -m64 -arch x86_64 98 | else 99 | XCFLAGS = -I/usr/X11/include 100 | endif 101 | else 102 | XCFLAGS = -I/usr/X11/include -arch i386 103 | ifeq ($(MACHINE),x86) 104 | MAKE_SHARED = sh ../src/bin/make_shared.mac86 105 | else 106 | MAKE_SHARED = sh ../src/bin/make_shared.mac 107 | endif 108 | 109 | endif 110 | endif 111 | 112 | ifeq ($(OS_NAME),sunos) 113 | ifeq ($(SIXTYFOURBIT),yes) 114 | ifeq ($(MACHINE),x86_64) 115 | XCFLAGS = -xarch=amd64 -DAcl64Bit 116 | PICFLAGS = -KPIC 117 | MAKE_SHARED = ld -G 118 | else 119 | XCFLAGS = -xarch=v9 -DAcl64Bit 120 | PICFLAGS = -K pic 121 | MAKE_SHARED = ld -G 122 | endif 123 | else 124 | XCFLAGS = -I/usr/openwin/include 125 | PICFLAGS = -K pic 126 | MAKE_SHARED = ld -G 127 | endif 128 | endif 129 | 130 | ifeq ($(OS_NAME),linux) 131 | X11R6exists = $(shell if test -d /usr/X11R6/include; then echo yes; fi) 132 | ifeq ($(X11R6exists),yes) 133 | XCFLAGS = -I/usr/X11R6/include 134 | endif 135 | PICFLAGS = -fPIC 136 | MAKE_SHARED = ld -shared 137 | THREADLIB = -lpthread 138 | ifneq ($(SIXTYFOURBIT),yes) 139 | XCFLAGS += -m32 140 | MAKE_SHARED = ../src/bin/make_shared.lx32 141 | endif 142 | endif 143 | 144 | ifeq ($(OS_NAME),freebsd) 145 | x11_include_location := $(shell if test -d /usr/local/include/X11; then echo /usr/local/include; else echo /usr/X11R6/include; fi) 146 | XCFLAGS = -I$(x11_include_location) 147 | PICFLAGS = -fPIC -DPIC 148 | MAKE_SHARED = ld -Bshareable -Bdynamic 149 | endif 150 | 151 | ifeq ($(OS_NAME),osf1) 152 | ifeq ($(SIXTYFOURBIT),yes) 153 | XCFLAGS = -G 0 -DAcl64Bit -resumption_safe 154 | MAKE_SHARED = sh ../src/bin/make_shared.dec64 155 | else 156 | XCFLAGS = -G 0 -taso -xtaso -xtaso_short -resumption_safe 157 | MAKE_SHARED = sh ../src/bin/make_shared.dec 158 | endif 159 | endif 160 | 161 | ifeq ($(OS_NAME),irix) 162 | XCFLAGS = -G 0 -ansi -n32 163 | PICFLAGS = -KPIC 164 | MAKE_SHARED = ld -n32 -shared -all 165 | endif 166 | 167 | CFLAGS = -O -DUNIXCONN $(XCFLAGS) 168 | 169 | # compile options: 170 | SPEED = 3 171 | SAFETY = 0 172 | DEBUG = 1 173 | RECORD_XREF_INFO = nil 174 | RECORD_SOURCE_FILE_INFO = nil 175 | SAVE_LOCAL_NAMES = nil 176 | SAVE_SOURCE_DEBUG = nil 177 | LOAD_XREF_INFO = nil 178 | LOAD_SOURCE_FILE_INFO = nil 179 | LOAD_LOCAL_NAMES_INFO = nil 180 | gc_print = nil 181 | compile_verbose = t 182 | compile_print = nil 183 | redef_warning = t 184 | 185 | C_SRC = excldep.c socket.c 186 | ifneq ($(OS_NAME),windows) 187 | C_OBJS = excldep.o socket.o 188 | C_SOBJS = excldep.$(SO) socket.$(SO) 189 | endif 190 | 191 | L_OBJS = defsystem.fasl package.fasl excldep.fasl depdefs.fasl clx0.fasl \ 192 | dependent.fasl exclcmac.fasl macros.fasl bufmac.fasl buffer.fasl \ 193 | display.fasl gcontext.fasl requests.fasl input.fasl fonts.fasl \ 194 | graphics.fasl text.fasl attributes.fasl translate.fasl keysyms.fasl \ 195 | manager.fasl image.fasl resource.fasl 196 | 197 | L_NOMACROS_OBJS = package.fasl excldep.fasl depdefs.fasl clx0.fasl \ 198 | dependent.fasl exclcmac.fasl buffer.fasl display.fasl gcontext.fasl \ 199 | requests.fasl input.fasl fonts.fasl graphics.fasl text.fasl \ 200 | attributes.fasl translate.fasl keysyms.fasl manager.fasl image.fasl \ 201 | resource.fasl 202 | 203 | L_SRC = defsystem.cl package.cl excldep.cl depdefs.cl clx0.cl \ 204 | dependent.cl exclcmac.cl macros.cl bufmac.cl buffer.cl \ 205 | display.cl gcontext.cl requests.cl input.cl fonts.cl \ 206 | graphics.cl text.cl attributes.cl translate.cl keysyms.cl \ 207 | manager.cl image.cl resource.cl 208 | 209 | all: $(C_SOBJS) partial-clos 210 | 211 | compile-CLX-for-CLUE: compile-partial-clos-CLX 212 | clue: partial-clos 213 | 214 | excldep.so: excldep.c 215 | $(CC) $(CFLAGS) -c $(PICFLAGS) excldep.c 216 | $(MAKE_SHARED) $(THREADLIB) -o excldep.so excldep.o 217 | 218 | excldep.sl: excldep.c 219 | $(CC) $(CFLAGS) -c $(PICFLAGS) excldep.c 220 | $(MAKE_SHARED) -o excldep.sl excldep.o 221 | 222 | excldep.dylib: excldep.c 223 | $(CC) $(CFLAGS) -c $(PICFLAGS) excldep.c 224 | $(MAKE_SHARED) -o excldep.dylib excldep.o 225 | $(FICODESIGN) excldep.dylib 226 | 227 | socket.so: socket.c 228 | $(CC) $(CFLAGS) -c $(PICFLAGS) socket.c 229 | $(MAKE_SHARED) $(THREADLIB) -o socket.so socket.o 230 | 231 | socket.sl: socket.c 232 | $(CC) $(CFLAGS) -c $(PICFLAGS) socket.c 233 | $(MAKE_SHARED) -o socket.sl socket.o 234 | 235 | socket.dylib: socket.c 236 | $(CC) $(CFLAGS) -c $(PICFLAGS) socket.c 237 | $(MAKE_SHARED) -o socket.dylib socket.o 238 | $(FICODESIGN) socket.dylib 239 | 240 | # 241 | # Three build rules are provided: no-clos, partial-clos, and full-clos. 242 | # The first is no-clos, which results in a CLX whose datastructures are 243 | # all defstructs. partial-clos results in xlib:window, xlib:pixmap, and 244 | # xlib:drawable being CLOS instances, all others defstructs. full-clos 245 | # makes all CLX complex datatypes into CLOS instances. 246 | # 247 | # (note that the :clos feature implies native CLOS *not* PCL). 248 | # 249 | 250 | no-clos: $(C_OBJS) compile-no-clos-CLX clx.fasl 251 | 252 | # 253 | # This rule is used to compile CLX to be used with XCW version 2, or CLUE. 254 | # 255 | partial-clos: $(C_OBJS) compile-partial-clos-CLX clx.fasl 256 | 257 | full-clos: $(C_OBJS) compile-full-clos-CLX clx.fasl 258 | 259 | 260 | c: $(C_OBJS) 261 | 262 | 263 | compile-no-clos-CLX: $(C_OBJS) 264 | $(ECHO) "(pushnew :clx-ansi-common-lisp *features*) \ 265 | (push :clx-use-allegro-streams *features*) \ 266 | (load-logical-pathname-translations \"clx\") \ 267 | (load \"defsystem\") \ 268 | (proclaim '(optimize \ 269 | (safety $(SAFETY)) \ 270 | (speed $(SPEED)) \ 271 | (debug $(DEBUG)))) \ 272 | (let ((*record-source-file-info* $(RECORD_SOURCE_FILE_INFO)) \ 273 | (*load-source-file-info* $(LOAD_SOURCE_FILE_INFO)) \ 274 | (*load-local-names-info* $(LOAD_LOCAL_NAMES_INFO)) \ 275 | (*record-xref-info* $(RECORD_XREF_INFO)) \ 276 | (*load-xref-info* $(LOAD_XREF_INFO)) \ 277 | (comp::save-local-names-switch $(SAVE_LOCAL_NAMES)) \ 278 | (comp:save-source-level-debug-info-switch $(SAVE_SOURCE_DEBUG)) \ 279 | (*compile-print* $(compile_print)) \ 280 | (*compile-verbose* $(compile_verbose))) \ 281 | (setf (sys:gsgc-switch :print) $(gc_print)) \ 282 | (setq excl::*warn-smp-usage* nil) \ 283 | (compile-system :clx) \ 284 | (compile-system :clx-debug) \ 285 | (exit 0))" > clx.tmp 286 | $(CL) $(CLOPTS) -batch 287 | 288 | compile-partial-clos-CLX: $(C_OBJS) 289 | $(ECHO) "#-mswindows (ff:get-entry-point (ff:convert-foreign-name \"fd_wait_for_input\")) \ 290 | (pushnew :clx-ansi-common-lisp *features*) \ 291 | (push :clx-use-allegro-streams *features*) \ 292 | (load-logical-pathname-translations \"clx\") \ 293 | (load \"defsystem\") \ 294 | (load \"package\") \ 295 | (setq xlib::*def-clx-class-use-defclass* \ 296 | '(xlib:window xlib:pixmap xlib:drawable)) \ 297 | (proclaim '(optimize \ 298 | (safety $(SAFETY)) \ 299 | (speed $(SPEED)) \ 300 | (debug $(DEBUG)))) \ 301 | (let ((*record-source-file-info* $(RECORD_SOURCE_FILE_INFO)) \ 302 | (*load-source-file-info* $(LOAD_SOURCE_FILE_INFO)) \ 303 | (*load-local-names-info* $(LOAD_LOCAL_NAMES_INFO)) \ 304 | (*record-xref-info* $(RECORD_XREF_INFO)) \ 305 | (*load-xref-info* $(LOAD_XREF_INFO)) \ 306 | (comp::save-local-names-switch $(SAVE_LOCAL_NAMES)) \ 307 | (comp:save-source-level-debug-info-switch $(SAVE_SOURCE_DEBUG)) \ 308 | (*compile-verbose* $(compile_verbose)) \ 309 | (*compile-print* $(compile_print))) \ 310 | (setf (sys:gsgc-switch :print) $(gc_print)) \ 311 | (setq excl::*warn-smp-usage* nil) \ 312 | (compile-system :clx) \ 313 | (compile-system :clx-debug) \ 314 | (exit 0))" > clx.tmp 315 | $(CL) $(CLOPTS) -batch -backtrace-on-error 316 | 317 | compile-full-clos-CLX: $(C_OBJS) 318 | $(ECHO) "(pushnew :clx-ansi-common-lisp *features*) \ 319 | (push :clx-use-allegro-streams *features*) \ 320 | (load-logical-pathname-translations \"clx\") \ 321 | (load \"defsystem\") \ 322 | (load \"package\") \ 323 | (setq xlib::*def-clx-class-use-defclass* t) \ 324 | (proclaim '(optimize \ 325 | (safety $(SAFETY)) \ 326 | (speed $(SPEED)) \ 327 | (debug $(DEBUG)))) \ 328 | (let ((*record-source-file-info* $(RECORD_SOURCE_FILE_INFO)) \ 329 | (*load-source-file-info* $(LOAD_SOURCE_FILE_INFO)) \ 330 | (*load-local-names-info* $(LOAD_LOCAL_NAMES_INFO)) \ 331 | (*record-xref-info* $(RECORD_XREF_INFO)) \ 332 | (*load-xref-info* $(LOAD_XREF_INFO)) \ 333 | (comp::save-local-names-switch $(SAVE_LOCAL_NAMES)) \ 334 | (comp:save-source-level-debug-info-switch $(SAVE_SOURCE_DEBUG)) \ 335 | (*compile-print* $(compile_print)) \ 336 | (*compile-verbose* $(compile_verbose))) \ 337 | (setf (sys:gsgc-switch :print) $(gc_print)) \ 338 | (setq excl::*warn-smp-usage* nil) \ 339 | (compile-system :clx) \ 340 | (compile-system :clx-debug) \ 341 | (exit 0))" > clx.tmp 342 | $(CL) $(CLOPTS) -batch 343 | 344 | clx.fasl: 345 | #The following doesn't work on Windows, so use concatenate-system instead. 346 | # -cat $(L_NOMACROS_OBJS) > clx.fasl 347 | #The following contains a little more than the above does (same as L_OBJS). 348 | $(ECHO) "(load-logical-pathname-translations \"clx\") \ 349 | (load \"defsystem\") \ 350 | (concatenate-system :clx \"clx.fasl\") \ 351 | (exit 0)" > clx.tmp 352 | $(CL) $(CLOPTS) -batch 353 | 354 | load-CLX: 355 | $(ECHO) "\ 356 | (load-logical-pathname-translations \"clx\") \ 357 | (load-application \ 358 | (progn (load \"defsystem\") (load-system :clx)) \ 359 | :global-gc t :devel nil)" \ 360 | '(dumplisp :name "$(CLX)" $(DUMPLISP_ARGS))' \ 361 | "(exit 0)" > clx.tmp 362 | $(CL) $(CLOPTS) 363 | 364 | clean_OS: 365 | rm -f *.o *.so *.sl 366 | 367 | clean: 368 | rm -f *.fasl *.o *.so *.sl *.dylib debug/*.fasl $(CLX) core make.out clx.tmp 369 | rm -f so_locations 370 | 371 | install_OS: 372 | $(MV) *.o $(DEST) 373 | if test -f socket.so; then \ 374 | $(MV) *.so $(DEST); \ 375 | fi 376 | if test -f socket.sl; then \ 377 | $(MV) *.sl $(DEST); \ 378 | fi 379 | 380 | install: install_OS 381 | $(MV) clx.fasl $(DEST)/clx.fasl 382 | 383 | tags: 384 | $(TAGS) $(L_SRC) $(C_SRC) 385 | 386 | DISTFILES = CHANGES ChangeLog Makefile */Makefile NEWCHANGES README */README \ 387 | *.c *.cl */*.cl doc/*.Z 388 | 389 | echo-distribution-source-files: 390 | @echo $(DISTFILES) 391 | 392 | -------------------------------------------------------------------------------- /exclcmac.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- 2 | ;;; 3 | ;;; CLX -- exclcmac.cl 4 | ;;; This file provides for inline expansion of some functions. 5 | ;;; 6 | ;;; copyright (c) 1989 Franz Inc, Berkeley, CA - All rights reserved. 7 | ;; copyright (c) 1989-2004 Franz Inc, Oakland, CA - All rights reserved. 8 | ;;; 9 | ;;; Permission is granted to any individual or institution to use, copy, 10 | ;;; modify, and distribute this software, provided that this complete 11 | ;;; copyright and permission notice is maintained, intact, in all copies and 12 | ;;; supporting documentation. 13 | ;;; 14 | ;;; Franz Incorporated provides this software "as is" without 15 | ;;; express or implied warranty. 16 | ;;; 17 | 18 | (in-package :xlib) 19 | 20 | 21 | (defconstant type-pred-alist 22 | '(#-(version>= 4 1 devel 16) 23 | (card8 . card8p) 24 | #-(version>= 4 1 devel 16) 25 | (card16 . card16p) 26 | #-(version>= 4 1 devel 16) 27 | (card29 . card29p) 28 | #-(version>= 4 1 devel 16) 29 | (card32 . card32p) 30 | #-(version>= 4 1 devel 16) 31 | (int8 . int8p) 32 | #-(version>= 4 1 devel 16) 33 | (int16 . int16p) 34 | #-(version>= 4 1 devel 16) 35 | (int32 . int32p) 36 | #-(version>= 4 1 devel 16) 37 | (mask16 . card16p) 38 | #-(version>= 4 1 devel 16) 39 | (mask32 . card32p) 40 | #-(version>= 4 1 devel 16) 41 | (pixel . card32p) 42 | #-(version>= 4 1 devel 16) 43 | (resource-id . card29p) 44 | #-(version>= 4 1 devel 16) 45 | (keysym . card32p) 46 | (angle . anglep) 47 | (color . color-p) 48 | (bitmap-format . bitmap-format-p) 49 | (pixmap-format . pixmap-format-p) 50 | (display . display-p) 51 | (drawable . drawable-p) 52 | (window . window-p) 53 | (pixmap . pixmap-p) 54 | (visual-info . visual-info-p) 55 | (colormap . colormap-p) 56 | (cursor . cursor-p) 57 | (gcontext . gcontext-p) 58 | (screen . screen-p) 59 | (font . font-p) 60 | #| 61 | ;; These types don't exist when this file gets loaded. Perhaps the def-clx-class 62 | ;; forms could be moved from image.cl and manager.cl to clx.cl. 63 | (image-x . image-x-p) 64 | (image-xy . image-xy-p) 65 | (image-z . image-z-p) 66 | (wm-hints . wm-hints-p) 67 | (wm-size-hints . wm-size-hints-p) 68 | |# 69 | )) 70 | 71 | ;; This (if (and ...) t nil) stuff has a purpose -- it lets the old 72 | ;; sun4 compiler opencode the `and'. 73 | 74 | #-(version>= 4 1 devel 16) 75 | (defun card8p (x) 76 | (declare (optimize (speed 3) (safety 0)) 77 | (fixnum x)) 78 | (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0)) 79 | t 80 | nil)) 81 | 82 | #-(version>= 4 1 devel 16) 83 | (defun card16p (x) 84 | (declare (optimize (speed 3) (safety 0)) 85 | (fixnum x)) 86 | (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0)) 87 | t 88 | nil)) 89 | 90 | #-(version>= 4 1 devel 16) 91 | (defun card29p (x) 92 | (declare (optimize (speed 3) (safety 0))) 93 | (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) 94 | (and (excl:bignump x) (> #.(expt 2 29) (the bignum x)) 95 | (>= (the bignum x) 0))) 96 | t 97 | nil)) 98 | 99 | #-(version>= 4 1 devel 16) 100 | (defun card32p (x) 101 | (declare (optimize (speed 3) (safety 0))) 102 | (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) 103 | (and (excl:bignump x) (> #.(expt 2 32) (the bignum x)) 104 | (>= (the bignum x) 0))) 105 | t 106 | nil)) 107 | 108 | #-(version>= 4 1 devel 16) 109 | (defun int8p (x) 110 | (declare (optimize (speed 3) (safety 0)) 111 | (fixnum x)) 112 | (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7))) 113 | t 114 | nil)) 115 | 116 | #-(version>= 4 1 devel 16) 117 | (defun int16p (x) 118 | (declare (optimize (speed 3) (safety 0)) 119 | (fixnum x)) 120 | (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15))) 121 | t 122 | nil)) 123 | 124 | #-(version>= 4 1 devel 16) 125 | (defun int32p (x) 126 | (declare (optimize (speed 3) (safety 0))) 127 | (if (or (excl:fixnump x) 128 | (and (excl:bignump x) (> #.(expt 2 31) (the bignum x)) 129 | (>= (the bignum x) #.(expt -2 31)))) 130 | t 131 | nil)) 132 | 133 | ;; This one can be handled better by knowing a little about what we're 134 | ;; testing for. Plus this version can handle (single-float pi), which 135 | ;; is otherwise larger than pi! 136 | (defun anglep (x) 137 | (declare (optimize (speed 3) (safety 0))) 138 | (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi))) 139 | (<= (the fixnum x) #.(truncate (* 2 pi)))) 140 | (and (excl::single-float-p x) 141 | (>= (the single-float x) #.(float (* -2 pi) 0.0s0)) 142 | (<= (the single-float x) #.(float (* 2 pi) 0.0s0))) 143 | (and (excl::double-float-p x) 144 | (>= (the double-float x) #.(float (* -2 pi) 0.0d0)) 145 | (<= (the double-float x) #.(float (* 2 pi) 0.0d0)))) 146 | t 147 | nil)) 148 | 149 | #-(version>= 4 1 devel 16) 150 | (define-compiler-macro card8p (x) 151 | (let ((xx (gensym))) 152 | `(let ((,xx ,x)) 153 | (declare (optimize (speed 3) (safety 0)) 154 | (fixnum ,xx)) 155 | (and (excl:fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0))))) 156 | 157 | #-(version>= 4 1 devel 16) 158 | (define-compiler-macro card16p (x) 159 | (let ((xx (gensym))) 160 | `(let ((,xx ,x)) 161 | (declare (optimize (speed 3) (safety 0)) 162 | (fixnum ,xx)) 163 | (and (excl:fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0))))) 164 | 165 | #-(version>= 4 1 devel 16) 166 | (define-compiler-macro int8p (x) 167 | (let ((xx (gensym))) 168 | `(let ((,xx ,x)) 169 | (declare (optimize (speed 3) (safety 0)) 170 | (fixnum ,xx)) 171 | (and (excl:fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7)))))) 172 | 173 | #-(version>= 4 1 devel 16) 174 | (define-compiler-macro int16p (x) 175 | (let ((xx (gensym))) 176 | `(let ((,xx ,x)) 177 | (declare (optimize (speed 3) (safety 0)) 178 | (fixnum ,xx)) 179 | (and (excl:fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15)))))) 180 | 181 | ;; Card29p, card32p, int32p are too large to expand inline. 182 | 183 | (eval-when (load eval) 184 | #+(version>= 4 1 devel 16) 185 | (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt))) 186 | type-pred-alist) 187 | #-(version>= 4 1 devel 16) 188 | (nconc excl::type-pred-alist type-pred-alist)) 189 | 190 | 191 | ;; 192 | ;; Type transformers 193 | ;; 194 | (define-compiler-macro card8->int8 (x) 195 | (let ((xx (gensym))) 196 | `(let ((,xx ,x)) 197 | ,(declare-bufmac) 198 | (declare (type card8 ,xx)) 199 | (the int8 (if (logbitp 7 ,xx) 200 | (the int8 (- ,xx #x100)) 201 | ,xx))))) 202 | (define-compiler-macro int8->card8 (x) 203 | `(locally ,(declare-bufmac) 204 | (the card8 (ldb (byte 8 0) (the int8 ,x))))) 205 | 206 | (define-compiler-macro card16->int16 (x) 207 | (let ((xx (gensym))) 208 | `(let ((,xx ,x)) 209 | ,(declare-bufmac) 210 | (declare (type card16 ,xx)) 211 | (the int16 (if (logbitp 15 ,xx) 212 | (the int16 (- ,xx #x10000)) 213 | ,xx))))) 214 | 215 | (define-compiler-macro int16->card16 (x) 216 | `(locally ,(declare-bufmac) 217 | (the card16 (ldb (byte 16 0) (the int16 ,x))))) 218 | 219 | (define-compiler-macro card32->int32 (x) 220 | (let ((xx (gensym))) 221 | `(let ((,xx ,x)) 222 | ,(declare-bufmac) 223 | (declare (type card32 ,xx)) 224 | (the int32 (if (logbitp 31 ,xx) 225 | (the int32 (- ,xx #x100000000)) 226 | ,xx))))) 227 | 228 | (define-compiler-macro int32->card32 (x) 229 | `(locally ,(declare-bufmac) 230 | (the card32 (ldb (byte 32 0) (the int32 ,x))))) 231 | 232 | (define-compiler-macro char->card8 (char) 233 | `(locally ,(declare-bufmac) 234 | (the card8 (char-code (the excl::string-char ,char))))) 235 | 236 | (define-compiler-macro card8->char (card8) 237 | `(locally ,(declare-bufmac) 238 | (the excl::string-char (code-char (the card8 ,card8))))) 239 | 240 | 241 | ;; 242 | ;; Array accessors and setters 243 | ;; 244 | (define-compiler-macro aref-card8 (a i) 245 | `(locally ,(declare-bufmac) 246 | (the card8 (sys:memref (the buffer-bytes ,a) 247 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 248 | (the array-index ,i) 249 | :unsigned-byte)))) 250 | 251 | (define-compiler-macro aset-card8 (v a i) 252 | `(locally ,(declare-bufmac) 253 | (setf (sys:memref (the buffer-bytes ,a) 254 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 255 | (the array-index ,i) 256 | :unsigned-byte) 257 | (the card8 ,v)))) 258 | 259 | (define-compiler-macro aref-int8 (a i) 260 | `(locally ,(declare-bufmac) 261 | (the int8 (sys:memref (the buffer-bytes ,a) 262 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 263 | (the array-index ,i) 264 | :signed-byte)))) 265 | 266 | (define-compiler-macro aset-int8 (v a i) 267 | `(locally ,(declare-bufmac) 268 | (setf (sys:memref (the buffer-bytes ,a) 269 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 270 | (the array-index ,i) 271 | :signed-byte) 272 | (the int8 ,v)))) 273 | 274 | (define-compiler-macro aref-card16 (a i) 275 | `(locally ,(declare-bufmac) 276 | (the card16 (sys:memref (the buffer-bytes ,a) 277 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 278 | (the array-index ,i) 279 | :unsigned-word)))) 280 | 281 | (define-compiler-macro aset-card16 (v a i) 282 | `(locally ,(declare-bufmac) 283 | (setf (sys:memref (the buffer-bytes ,a) 284 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 285 | (the array-index ,i) 286 | :unsigned-word) 287 | (the card16 ,v)))) 288 | 289 | (define-compiler-macro aref-int16 (a i) 290 | `(locally ,(declare-bufmac) 291 | (the int16 (sys:memref (the buffer-bytes ,a) 292 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 293 | (the array-index ,i) 294 | :signed-word)))) 295 | 296 | (define-compiler-macro aset-int16 (v a i) 297 | `(locally ,(declare-bufmac) 298 | (setf (sys:memref (the buffer-bytes ,a) 299 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 300 | (the array-index ,i) 301 | :signed-word) 302 | (the int16 ,v)))) 303 | 304 | (define-compiler-macro aref-card32 (a i) 305 | `(locally ,(declare-bufmac) 306 | (the card32 (sys:memref (the buffer-bytes ,a) 307 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 308 | (the array-index ,i) 309 | :unsigned-long32)))) 310 | 311 | (define-compiler-macro aset-card32 (v a i) 312 | `(locally ,(declare-bufmac) 313 | (setf (sys:memref (the buffer-bytes ,a) 314 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 315 | (the array-index ,i) 316 | :unsigned-long32) 317 | (the card32 ,v)))) 318 | 319 | (define-compiler-macro aref-int32 (a i) 320 | `(locally ,(declare-bufmac) 321 | (the int32 (sys:memref (the buffer-bytes ,a) 322 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 323 | (the array-index ,i) 324 | :signed-long)))) 325 | 326 | (define-compiler-macro aset-int32 (v a i) 327 | `(locally ,(declare-bufmac) 328 | (setf (sys:memref (the buffer-bytes ,a) 329 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 330 | (the array-index ,i) 331 | :signed-long) 332 | (the int32 ,v)))) 333 | 334 | (define-compiler-macro aref-card29 (a i) 335 | ;; Don't need to mask bits here since X protocol guarantees top bits zero 336 | `(locally ,(declare-bufmac) 337 | (the card29 (sys:memref (the buffer-bytes ,a) 338 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 339 | (the array-index ,i) 340 | :unsigned-long32)))) 341 | 342 | (define-compiler-macro aset-card29 (v a i) 343 | ;; I also assume here Lisp is passing a number that fits in 29 bits. 344 | `(locally ,(declare-bufmac) 345 | (setf (sys:memref (the buffer-bytes ,a) 346 | #.(sys::mdparam 'comp::md-lvector-data0-norm) 347 | (the array-index ,i) 348 | :unsigned-long32) 349 | (the card29 ,v)))) 350 | 351 | ;; 352 | ;; Font accessors 353 | ;; 354 | (define-compiler-macro font-id (font) 355 | ;; Get font-id, opening font if needed 356 | (let ((f (gensym))) 357 | `(let ((,f ,font)) 358 | (or (font-id-internal ,f) 359 | (open-font-internal ,f))))) 360 | 361 | (define-compiler-macro font-font-info (font) 362 | (let ((f (gensym))) 363 | `(let ((,f ,font)) 364 | (or (font-font-info-internal ,f) 365 | (query-font ,f))))) 366 | 367 | (define-compiler-macro font-char-infos (font) 368 | (let ((f (gensym))) 369 | `(let ((,f ,font)) 370 | (or (font-char-infos-internal ,f) 371 | (progn (query-font ,f) 372 | (font-char-infos-internal ,f)))))) 373 | 374 | 375 | ;; 376 | ;; Miscellaneous 377 | ;; 378 | (define-compiler-macro current-process () 379 | `(the (or mp::process null) (and (si:scheduler-running-p) 380 | mp::*current-process*))) 381 | 382 | (define-compiler-macro process-wakeup (process) 383 | (let ((proc (gensym))) 384 | `(let ((.pw-curproc. mp::*current-process*) 385 | (,proc ,process)) 386 | (when (and .pw-curproc. ,proc) 387 | (if (> (mp::process-priority ,proc) 388 | (mp::process-priority .pw-curproc.)) 389 | (mp::process-allow-schedule ,proc)))))) 390 | 391 | (define-compiler-macro buffer-new-request-number (buffer) 392 | (let ((buf (gensym))) 393 | `(let ((,buf ,buffer)) 394 | (declare (type buffer ,buf)) 395 | (setf (buffer-request-number ,buf) 396 | (ldb (byte 16 0) (1+ (buffer-request-number ,buf))))))) 397 | -------------------------------------------------------------------------------- /demo/menu.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*- 2 | 3 | ;;; 4 | ;;; TEXAS INSTRUMENTS INCORPORATED 5 | ;;; P.O. BOX 2909 6 | ;;; AUSTIN, TEXAS 78769 7 | ;;; 8 | ;;; Copyright (C) 1988 Texas Instruments Incorporated. 9 | ;;; 10 | ;;; Permission is granted to any individual or institution to use, copy, modify, 11 | ;;; and distribute this software, provided that this complete copyright and 12 | ;;; permission notice is maintained, intact, in all copies and supporting 13 | ;;; documentation. 14 | ;;; 15 | ;;; Texas Instruments Incorporated provides this software "as is" without 16 | ;;; express or implied warranty. 17 | ;;; 18 | 19 | (in-package :xlib) 20 | 21 | 22 | ;;;----------------------------------------------------------------------------------+ 23 | ;;; | 24 | ;;; These functions demonstrate a simple menu implementation described in | 25 | ;;; Kimbrough, Kerry, "Windows to the Future", Lisp Pointers, Oct-Nov, 1987. | 26 | ;;; See functions JUST-SAY-LISP and POP-UP for demonstrations. | 27 | ;;; | 28 | ;;;----------------------------------------------------------------------------------+ 29 | 30 | 31 | 32 | (defstruct (menu) 33 | "A simple menu of text strings." 34 | (title "choose an item:") 35 | item-alist ;((item-window item-string)) 36 | window 37 | gcontext 38 | width 39 | title-width 40 | item-width 41 | item-height 42 | (geometry-changed-p t)) ;nil iff unchanged since displayed 43 | 44 | 45 | 46 | (defun create-menu (parent-window text-color background-color text-font) 47 | (make-menu 48 | ;; Create menu graphics context 49 | :gcontext (CREATE-GCONTEXT :drawable parent-window 50 | :foreground text-color 51 | :background background-color 52 | :font text-font) 53 | ;; Create menu window 54 | :window (CREATE-WINDOW 55 | :parent parent-window 56 | :class :input-output 57 | :x 0 ;temporary value 58 | :y 0 ;temporary value 59 | :width 16 ;temporary value 60 | :height 16 ;temporary value 61 | :border-width 2 62 | :border text-color 63 | :background background-color 64 | :save-under :on 65 | :override-redirect :on ;override window mgr when positioning 66 | :event-mask (MAKE-EVENT-MASK :leave-window 67 | :exposure)))) 68 | 69 | 70 | (defun menu-set-item-list (menu &rest item-strings) 71 | ;; Assume the new items will change the menu's width and height 72 | (setf (menu-geometry-changed-p menu) t) 73 | 74 | ;; Destroy any existing item windows 75 | (dolist (item (menu-item-alist menu)) 76 | (DESTROY-WINDOW (first item))) 77 | 78 | ;; Add (item-window item-string) elements to item-alist 79 | (setf (menu-item-alist menu) 80 | (let (alist) 81 | (dolist (item item-strings (nreverse alist)) 82 | (push (list (CREATE-WINDOW 83 | :parent (menu-window menu) 84 | :x 0 ;temporary value 85 | :y 0 ;temporary value 86 | :width 16 ;temporary value 87 | :height 16 ;temporary value 88 | :background (GCONTEXT-BACKGROUND (menu-gcontext menu)) 89 | :event-mask (MAKE-EVENT-MASK :enter-window 90 | :leave-window 91 | :button-press 92 | :button-release)) 93 | item) 94 | alist))))) 95 | 96 | (defparameter *menu-item-margin* 4 97 | "Minimum number of pixels surrounding menu items.") 98 | 99 | 100 | (defun menu-recompute-geometry (menu) 101 | (when (menu-geometry-changed-p menu) 102 | (let* ((menu-font (GCONTEXT-FONT (menu-gcontext menu))) 103 | (title-width (TEXT-EXTENTS menu-font (menu-title menu))) 104 | (item-height (+ (FONT-ASCENT menu-font) (FONT-DESCENT menu-font))) 105 | (item-width 0) 106 | (items (menu-item-alist menu)) 107 | menu-width) 108 | 109 | ;; Find max item string width 110 | (dolist (next-item items) 111 | (setf item-width (max item-width 112 | (TEXT-EXTENTS menu-font (second next-item))))) 113 | 114 | ;; Compute final menu width, taking margins into account 115 | (setf menu-width (max title-width 116 | (+ item-width *menu-item-margin* *menu-item-margin*))) 117 | (let ((window (menu-window menu)) 118 | (delta-y (+ item-height *menu-item-margin*))) 119 | 120 | ;; Update width and height of menu window 121 | (WITH-STATE (window) 122 | (setf (DRAWABLE-WIDTH window) menu-width 123 | (DRAWABLE-HEIGHT window) (+ *menu-item-margin* 124 | (* (1+ (length items)) 125 | delta-y)))) 126 | 127 | ;; Update width, height, position of item windows 128 | (let ((item-left (round (- menu-width item-width) 2)) 129 | (next-item-top delta-y)) 130 | (dolist (next-item items) 131 | (let ((window (first next-item))) 132 | (WITH-STATE (window) 133 | (setf (DRAWABLE-HEIGHT window) item-height 134 | (DRAWABLE-WIDTH window) item-width 135 | (DRAWABLE-X window) item-left 136 | (DRAWABLE-Y window) next-item-top))) 137 | (incf next-item-top delta-y)))) 138 | 139 | ;; Map all item windows 140 | (MAP-SUBWINDOWS (menu-window menu)) 141 | 142 | ;; Save item geometry 143 | (setf (menu-item-width menu) item-width 144 | (menu-item-height menu) item-height 145 | (menu-width menu) menu-width 146 | (menu-title-width menu) title-width 147 | (menu-geometry-changed-p menu) nil)))) 148 | 149 | 150 | (defun menu-refresh (menu) 151 | (let* ((gcontext (menu-gcontext menu)) 152 | (baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext)))) 153 | 154 | ;; Show title centered in "reverse-video" 155 | (let ((fg (GCONTEXT-BACKGROUND gcontext)) 156 | (bg (GCONTEXT-FOREGROUND gcontext))) 157 | (WITH-GCONTEXT (gcontext :foreground fg :background bg) 158 | (DRAW-IMAGE-GLYPHS 159 | (menu-window menu) 160 | gcontext 161 | (round (- (menu-width menu) 162 | (menu-title-width menu)) 2) ;start x 163 | baseline-y ;start y 164 | (menu-title menu)))) 165 | 166 | ;; Show each menu item (position is relative to item window) 167 | (dolist (item (menu-item-alist menu)) 168 | (DRAW-IMAGE-GLYPHS 169 | (first item) gcontext 170 | 0 ;start x 171 | baseline-y ;start y 172 | (second item))))) 173 | 174 | 175 | (defun menu-choose (menu x y) 176 | ;; Display the menu so that first item is at x,y. 177 | (menu-present menu x y) 178 | 179 | (let ((items (menu-item-alist menu)) 180 | (mw (menu-window menu)) 181 | selected-item) 182 | 183 | ;; Event processing loop 184 | (do () (selected-item) 185 | (EVENT-CASE ((DRAWABLE-DISPLAY mw) :force-output-p t) 186 | (:exposure (count) 187 | 188 | ;; Discard all but final :exposure then display the menu 189 | (when (zerop count) (menu-refresh menu)) 190 | t) 191 | 192 | (:button-release (event-window) 193 | ;;Select an item 194 | (setf selected-item (second (assoc event-window items))) 195 | t) 196 | 197 | (:enter-notify (window) 198 | ;;Highlight an item 199 | (let ((position (position window items :key #'first))) 200 | (when position 201 | (menu-highlight-item menu position))) 202 | t) 203 | 204 | (:leave-notify (window kind) 205 | (if (eql mw window) 206 | ;; Quit if pointer moved out of main menu window 207 | (setf selected-item (when (eq kind :ancestor) :none)) 208 | 209 | ;; Otherwise, unhighlight the item window left 210 | (let ((position (position window items :key #'first))) 211 | (when position 212 | (menu-unhighlight-item menu position)))) 213 | t) 214 | 215 | (otherwise () 216 | ;;Ignore and discard any other event 217 | t))) 218 | 219 | ;; Erase the menu 220 | (UNMAP-WINDOW mw) 221 | 222 | ;; Return selected item string, if any 223 | (unless (eq selected-item :none) selected-item))) 224 | 225 | 226 | (defun menu-highlight-item (menu position) 227 | (let* ((box-margin (round *menu-item-margin* 2)) 228 | (left (- (round (- (menu-width menu) (menu-item-width menu)) 2) 229 | box-margin)) 230 | (top (- (* (+ *menu-item-margin* (menu-item-height menu)) 231 | (1+ position)) 232 | box-margin)) 233 | (width (+ (menu-item-width menu) box-margin box-margin)) 234 | (height (+ (menu-item-height menu) box-margin box-margin))) 235 | 236 | ;; Draw a box in menu window around the given item. 237 | (DRAW-RECTANGLE (menu-window menu) 238 | (menu-gcontext menu) 239 | left top 240 | width height))) 241 | 242 | (defun menu-unhighlight-item (menu position) 243 | ;; Draw a box in the menu background color 244 | (let ((gcontext (menu-gcontext menu))) 245 | (WITH-GCONTEXT (gcontext :foreground (gcontext-background gcontext)) 246 | (menu-highlight-item menu position)))) 247 | 248 | 249 | (defun menu-present (menu x y) 250 | ;; Make sure menu geometry is up-to-date 251 | (menu-recompute-geometry menu) 252 | 253 | ;; Try to center first item at the given location, but 254 | ;; make sure menu is completely visible in its parent 255 | (let ((menu-window (menu-window menu))) 256 | (multiple-value-bind (tree parent) (QUERY-TREE menu-window) 257 | (declare (ignore tree)) 258 | (WITH-STATE (parent) 259 | (let* ((parent-width (DRAWABLE-WIDTH parent)) 260 | (parent-height (DRAWABLE-HEIGHT parent)) 261 | (menu-height (+ *menu-item-margin* 262 | (* (1+ (length (menu-item-alist menu))) 263 | (+ (menu-item-height menu) *menu-item-margin*)))) 264 | (menu-x (max 0 (min (- parent-width (menu-width menu)) 265 | (- x (round (menu-width menu) 2))))) 266 | (menu-y (max 0 (min (- parent-height menu-height) 267 | (- y (round (menu-item-height menu) 2/3) 268 | *menu-item-margin*))))) 269 | (WITH-STATE (menu-window) 270 | (setf (DRAWABLE-X menu-window) menu-x 271 | (DRAWABLE-Y menu-window) menu-y))))) 272 | 273 | ;; Make menu visible 274 | (MAP-WINDOW menu-window))) 275 | 276 | (defun just-say-lisp (host &optional (font-name "fixed")) 277 | (let* ((display (OPEN-DISPLAY host)) 278 | (screen (first (DISPLAY-ROOTS display))) 279 | (fg-color (SCREEN-BLACK-PIXEL screen)) 280 | (bg-color (SCREEN-WHITE-PIXEL screen)) 281 | (nice-font (OPEN-FONT display font-name)) 282 | (a-menu (create-menu (screen-root screen) ;the menu's parent 283 | fg-color bg-color nice-font))) 284 | 285 | (setf (menu-title a-menu) "Please pick your favorite language:") 286 | (menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp") 287 | 288 | ;; Bedevil the user until he picks a nice programming language 289 | (unwind-protect 290 | (do (choice) 291 | ((and (setf choice (menu-choose a-menu 100 100)) 292 | (string-equal "Lisp" choice)))) 293 | 294 | (CLOSE-DISPLAY display)))) 295 | 296 | 297 | (defun pop-up (host strings &key (title "Pick one:") (font "fixed")) 298 | (let* ((display (OPEN-DISPLAY host)) 299 | (screen (first (DISPLAY-ROOTS display))) 300 | (fg-color (SCREEN-BLACK-PIXEL screen)) 301 | (bg-color (SCREEN-WHITE-PIXEL screen)) 302 | (font (OPEN-FONT display font)) 303 | (parent-width 400) 304 | (parent-height 400) 305 | (parent (CREATE-WINDOW :parent (SCREEN-ROOT screen) 306 | :override-redirect :on 307 | :x 100 :y 100 308 | :width parent-width :height parent-height 309 | :background bg-color 310 | :event-mask (MAKE-EVENT-MASK :button-press 311 | :exposure))) 312 | (a-menu (create-menu parent fg-color bg-color font)) 313 | (prompt "Press a button...") 314 | (prompt-gc (CREATE-GCONTEXT :drawable parent 315 | :foreground fg-color 316 | :background bg-color 317 | :font font)) 318 | (prompt-y (FONT-ASCENT font)) 319 | (ack-y (- parent-height (FONT-DESCENT font)))) 320 | 321 | (setf (menu-title a-menu) title) 322 | (apply #'menu-set-item-list a-menu strings) 323 | 324 | ;; Present main window 325 | (MAP-WINDOW parent) 326 | 327 | (flet ((display-centered-text 328 | (window string gcontext height width) 329 | (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string) 330 | (declare (ignore a d l r)) 331 | (let ((box-height (+ fa fd))) 332 | 333 | ;; Clear previous text 334 | (CLEAR-AREA window 335 | :x 0 :y (- height fa) 336 | :width width :height box-height) 337 | 338 | ;; Draw new text 339 | (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string))))) 340 | 341 | (unwind-protect 342 | (loop 343 | (EVENT-CASE (display :force-output-p t) 344 | 345 | (:exposure (count) 346 | 347 | ;; Display prompt 348 | (when (zerop count) 349 | (display-centered-text 350 | parent 351 | prompt 352 | prompt-gc 353 | prompt-y 354 | parent-width)) 355 | t) 356 | 357 | (:button-press (x y) 358 | 359 | ;; Pop up the menu 360 | (let ((choice (menu-choose a-menu x y))) 361 | (if choice 362 | (display-centered-text 363 | parent 364 | (format nil "You have selected ~a." choice) 365 | prompt-gc 366 | ack-y 367 | parent-width) 368 | 369 | (display-centered-text 370 | parent 371 | "No selection...try again." 372 | prompt-gc 373 | ack-y 374 | parent-width))) 375 | t) 376 | 377 | (otherwise () 378 | ;;Ignore and discard any other event 379 | t))) 380 | 381 | (CLOSE-DISPLAY display))))) 382 | 383 | -------------------------------------------------------------------------------- /fonts.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- 2 | 3 | ;;; 4 | ;;; TEXAS INSTRUMENTS INCORPORATED 5 | ;;; P.O. BOX 2909 6 | ;;; AUSTIN, TEXAS 78769 7 | ;;; 8 | ;;; Copyright (C) 1987 Texas Instruments Incorporated. 9 | ;;; 10 | ;;; Permission is granted to any individual or institution to use, copy, modify, 11 | ;;; and distribute this software, provided that this complete copyright and 12 | ;;; permission notice is maintained, intact, in all copies and supporting 13 | ;;; documentation. 14 | ;;; 15 | ;;; Texas Instruments Incorporated provides this software "as is" without 16 | ;;; express or implied warranty. 17 | ;;; 18 | 19 | (in-package :xlib) 20 | 21 | ;; The char-info stuff is here instead of CLX because of uses of int16->card16. 22 | 23 | ; To allow efficient storage representations, the type char-info is not 24 | ; required to be a structure. 25 | 26 | ;; For each of left-bearing, right-bearing, width, ascent, descent, attributes: 27 | 28 | ;(defun char- (font index) 29 | ; ;; Note: I have tentatively chosen to return nil for an out-of-bounds index 30 | ; ;; (or an in-bounds index on a pseudo font), although returning zero or 31 | ; ;; signalling might be better. 32 | ; (declare (type font font) 33 | ; (type integer index) 34 | ; (values (or null integer)))) 35 | 36 | ;(defun max-char- (font) 37 | ; ;; Note: I have tentatively chosen separate accessors over allowing :min and 38 | ; ;; :max as an index above. 39 | ; (declare (type font font) 40 | ; (values integer))) 41 | 42 | ;(defun min-char- (font) 43 | ; (declare (type font font) 44 | ; (values integer))) 45 | 46 | ;; Note: char16- accessors could be defined to accept two-byte indexes. 47 | 48 | (deftype char-info-vec () '(simple-array int16 (6))) 49 | 50 | (macrolet ((def-char-info-accessors (useless-name &body fields) 51 | `(within-definition (,useless-name def-char-info-accessors) 52 | ,@(do ((field fields (cdr field)) 53 | (n 0 (1+ n)) 54 | (name) (type) 55 | (result nil)) 56 | ((endp field) result) 57 | (setq name (xintern 'char- (caar field))) 58 | (setq type (cadar field)) 59 | (flet ((from (form) 60 | (if (eq type 'int16) 61 | form 62 | `(,(xintern 'int16-> type) ,form)))) 63 | (push 64 | `(defun ,name (font index) 65 | (declare (type font font) 66 | (type array-index index)) 67 | (declare (values (or null ,type))) 68 | (when (and (font-name font) 69 | (index>= (font-max-char font) index (font-min-char font))) 70 | (the ,type 71 | ,(from 72 | `(the int16 73 | (let ((char-info-vector (font-char-infos font))) 74 | (declare (type char-info-vec char-info-vector)) 75 | (if (index-zerop (length char-info-vector)) 76 | ;; Fixed width font 77 | (aref (the char-info-vec 78 | (font-max-bounds font)) 79 | ,n) 80 | ;; Variable width font 81 | (aref char-info-vector 82 | (index+ 83 | (index* 84 | 6 85 | (index- 86 | index 87 | (font-min-char font))) 88 | ,n))))))))) 89 | result) 90 | (setq name (xintern 'min-char- (caar field))) 91 | (push 92 | `(defun ,name (font) 93 | (declare (type font font)) 94 | (declare (values (or null ,type))) 95 | (when (font-name font) 96 | (the ,type 97 | ,(from 98 | `(the int16 99 | (aref (the char-info-vec (font-min-bounds font)) 100 | ,n)))))) 101 | result) 102 | (setq name (xintern 'max-char- (caar field))) 103 | (push 104 | `(defun ,name (font) 105 | (declare (type font font)) 106 | (declare (values (or null ,type))) 107 | (when (font-name font) 108 | (the ,type 109 | ,(from 110 | `(the int16 111 | (aref (the char-info-vec (font-max-bounds font)) 112 | ,n)))))) 113 | result))) 114 | 115 | (defun make-char-info 116 | (&key ,@(mapcar 117 | #'(lambda (field) 118 | `(,(car field) (required-arg ,(car field)))) 119 | fields)) 120 | (declare ,@(mapcar #'(lambda (field) `(type ,@(reverse field))) fields)) 121 | (let ((result (make-array ,(length fields) :element-type 'int16))) 122 | (declare (type char-info-vec result) 123 | (array-register result)) 124 | ,@(do* ((field fields (cdr field)) 125 | (var (caar field) (caar field)) 126 | (type (cadar field) (cadar field)) 127 | (n 0 (1+ n)) 128 | (result nil)) 129 | ((endp field) (nreverse result)) 130 | (push `(setf (aref result ,n) 131 | ,(if (eq type 'int16) 132 | var 133 | `(,(xintern type '->int16) ,var))) 134 | result)) 135 | result))))) 136 | (def-char-info-accessors ignore 137 | (left-bearing int16) 138 | (right-bearing int16) 139 | (width int16) 140 | (ascent int16) 141 | (descent int16) 142 | (attributes card16))) 143 | 144 | (defun open-font (display name) 145 | ;; Font objects may be cached and reference counted locally within the display 146 | ;; object. This function might not execute a with-display if the font is cached. 147 | ;; The protocol QueryFont request happens on-demand under the covers. 148 | (declare (type display display) 149 | (type stringable name)) 150 | (declare (values font)) 151 | (let* ((name-string (string-downcase (string name))) 152 | (font (car (member name-string (display-font-cache display) 153 | :key 'font-name 154 | :test 'equal))) 155 | font-id) 156 | (unless font 157 | (setq font (make-font :display display :name name-string)) 158 | (setq font-id (allocate-resource-id display font 'font)) 159 | (setf (font-id-internal font) font-id) 160 | (with-buffer-request (display *x-openfont*) 161 | (resource-id font-id) 162 | (card16 (length name-string)) 163 | (pad16 nil) 164 | (string name-string)) 165 | (push font (display-font-cache display))) 166 | (incf (font-reference-count font)) 167 | font)) 168 | 169 | (defun open-font-internal (font) 170 | ;; Called "under the covers" to open a font object 171 | (declare (type font font)) 172 | (declare (values resource-id)) 173 | (let* ((name-string (font-name font)) 174 | (display (font-display font)) 175 | (id (allocate-resource-id display font 'font))) 176 | (setf (font-id-internal font) id) 177 | (with-buffer-request (display *x-openfont*) 178 | (resource-id id) 179 | (card16 (length name-string)) 180 | (pad16 nil) 181 | (string name-string)) 182 | (push font (display-font-cache display)) 183 | (incf (font-reference-count font)) 184 | id)) 185 | 186 | (defun discard-font-info (font) 187 | ;; Discards any state that can be re-obtained with QueryFont. This is 188 | ;; simply a performance hint for memory-limited systems. 189 | (declare (type font font)) 190 | (setf (font-font-info-internal font) nil 191 | (font-char-infos-internal font) nil)) 192 | 193 | (defun query-font (font) 194 | ;; Internal function called by font and char info accessors 195 | (declare (type font font)) 196 | (declare (values font-info)) 197 | (let ((display (font-display font)) 198 | font-id 199 | font-info 200 | props) 201 | (setq font-id (font-id font)) ;; May issue an open-font request 202 | (with-buffer-request-and-reply (display *x-queryfont* 60) 203 | ((resource-id font-id)) 204 | (let* ((min-byte2 (card16-get 40)) 205 | (max-byte2 (card16-get 42)) 206 | (min-byte1 (card8-get 49)) 207 | (max-byte1 (card8-get 50)) 208 | (min-char min-byte2) 209 | (max-char (index+ (index-ash max-byte1 8) max-byte2)) 210 | (nfont-props (card16-get 46)) 211 | (nchar-infos (index* (card32-get 56) 6)) 212 | (char-info (make-array nchar-infos :element-type 'int16))) 213 | (setq font-info 214 | (make-font-info 215 | :direction (member8-get 48 :left-to-right :right-to-left) 216 | :min-char min-char 217 | :max-char max-char 218 | :min-byte1 min-byte1 219 | :max-byte1 max-byte1 220 | :min-byte2 min-byte2 221 | :max-byte2 max-byte2 222 | :all-chars-exist-p (boolean-get 51) 223 | :default-char (card16-get 44) 224 | :ascent (int16-get 52) 225 | :descent (int16-get 54) 226 | :min-bounds (char-info-get 8) 227 | :max-bounds (char-info-get 24))) 228 | (setq props (sequence-get :length (index* 2 nfont-props) :format int32 229 | :result-type 'list :index 60)) 230 | (sequence-get :length nchar-infos :format int16 :data char-info 231 | :index (index+ 60 (index* 2 nfont-props 4))) 232 | (setf (font-char-infos-internal font) char-info) 233 | (setf (font-font-info-internal font) font-info))) 234 | ;; Replace atom id's with keywords in the plist 235 | (do ((p props (cddr p))) 236 | ((endp p)) 237 | (setf (car p) (atom-name display (car p)))) 238 | (setf (font-info-properties font-info) props) 239 | font-info)) 240 | 241 | (defun close-font (font) 242 | ;; This might not generate a protocol request if the font is reference 243 | ;; counted locally. 244 | (declare (type font font)) 245 | (when (and (not (plusp (decf (font-reference-count font)))) 246 | (font-id-internal font)) 247 | (let ((display (font-display font)) 248 | (id (font-id-internal font))) 249 | (declare (type display display)) 250 | ;; Remove font from cache 251 | (setf (display-font-cache display) (delete font (display-font-cache display))) 252 | ;; Close the font 253 | (with-buffer-request (display *x-closefont*) 254 | (resource-id id))))) 255 | 256 | (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list)) 257 | (declare (type display display) 258 | (type string pattern) 259 | (type card16 max-fonts) 260 | (type t result-type)) ;; CL type 261 | (declare (values (sequence string))) 262 | (let ((string (string pattern))) 263 | (with-buffer-request-and-reply (display *x-listfonts* size :sizes (8 16)) 264 | ((card16 max-fonts (length string)) 265 | (string string)) 266 | (values 267 | (read-sequence-string 268 | buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*))))) 269 | 270 | (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list)) 271 | ;; Note: Was called list-fonts-with-info. 272 | ;; Returns "pseudo" fonts that contain basic font metrics and properties, but 273 | ;; no per-character metrics and no resource-ids. These pseudo fonts will be 274 | ;; converted (internally) to real fonts dynamically as needed, by issuing an 275 | ;; OpenFont request. However, the OpenFont might fail, in which case the 276 | ;; invalid-font error can arise. 277 | (declare (type display display) 278 | (type string pattern) 279 | (type card16 max-fonts) 280 | (type t result-type)) ;; CL type 281 | (declare (values (sequence font))) 282 | (let ((string (string pattern)) 283 | (result nil)) 284 | (with-buffer-request-and-reply (display *x-listfontswithinfo* 60 285 | :sizes (8 16) :multiple-reply t) 286 | ((card16 max-fonts (length string)) 287 | (string string)) 288 | (cond ((zerop (card8-get 1)) t) 289 | (t 290 | (let* ((name-len (card8-get 1)) 291 | (min-byte2 (card16-get 40)) 292 | (max-byte2 (card16-get 42)) 293 | (min-byte1 (card8-get 49)) 294 | (max-byte1 (card8-get 50)) 295 | (min-char min-byte2) 296 | (max-char (index+ (index-ash max-byte1 8) max-byte2)) 297 | (nfont-props (card16-get 46)) 298 | (font 299 | (make-font 300 | :display display 301 | :name nil 302 | :font-info-internal 303 | (make-font-info 304 | :direction (member8-get 48 :left-to-right :right-to-left) 305 | :min-char min-char 306 | :max-char max-char 307 | :min-byte1 min-byte1 308 | :max-byte1 max-byte1 309 | :min-byte2 min-byte2 310 | :max-byte2 max-byte2 311 | :all-chars-exist-p (boolean-get 51) 312 | :default-char (card16-get 44) 313 | :ascent (int16-get 52) 314 | :descent (int16-get 54) 315 | :min-bounds (char-info-get 8) 316 | :max-bounds (char-info-get 24) 317 | :properties (sequence-get :length (index* 2 nfont-props) 318 | :format int32 319 | :result-type 'list 320 | :index 60))))) 321 | (setf (font-name font) (string-get name-len (index+ 60 (index* 2 nfont-props 4)))) 322 | (push font result)) 323 | nil))) 324 | ;; Replace atom id's with keywords in the plist 325 | (dolist (font result) 326 | (do ((p (font-properties font) (cddr p))) 327 | ((endp p)) 328 | (setf (car p) (atom-name display (car p))))) 329 | (coerce (nreverse result) result-type))) 330 | 331 | (defun font-path (display &key (result-type 'list)) 332 | (declare (type display display) 333 | (type t result-type)) ;; CL type 334 | (declare (values (sequence (or string pathname)))) 335 | (with-buffer-request-and-reply (display *x-getfontpath* size :sizes (8 16)) 336 | () 337 | (values 338 | (read-sequence-string 339 | buffer-bbuf (index- size *replysize*) (card16-get 8) result-type *replysize*)))) 340 | 341 | (defun set-font-path (display paths) 342 | (declare (type display display) 343 | (type sequence paths)) ;; (sequence (or string pathname)) 344 | (let ((path-length (length paths)) 345 | (request-length 8)) 346 | ;; Find the request length 347 | (dotimes (i path-length) 348 | (let* ((string (string (elt paths i))) 349 | (len (length string))) 350 | (incf request-length (1+ len)))) 351 | (with-buffer-request (display *x-setfontpath* :length request-length) 352 | (length (ceiling request-length 4)) 353 | (card16 path-length) 354 | (pad16 nil) 355 | (progn 356 | (incf buffer-boffset 8) 357 | (dotimes (i path-length) 358 | (let* ((string (string (elt paths i))) 359 | (len (length string))) 360 | (card8-put 0 len) 361 | (string-put 1 string :appending t :header-length 1) 362 | (incf buffer-boffset (1+ len)))) 363 | (setf (buffer-boffset display) (lround buffer-boffset))))) 364 | paths) 365 | 366 | (defsetf font-path set-font-path) 367 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | R5 changes: (see below for details) 2 | 3 | o Numerous bug fixes 4 | 5 | o Continued gradual conversion towards ANSI Common Lisp 6 | 7 | o Performance improvements to image code 8 | 9 | o Multiprocess locking and error reporting made more robust 10 | 11 | o Event queue consing reduced 12 | 13 | o ICCCM support 14 | 15 | Details of changes since R4: 16 | 17 | R4.1 changes: 18 | 19 | o Fix reported bugs and to include the vendor-specific 20 | bug-fixing and performance-improving patches that I recently received. 21 | 22 | o Code compiled with the R4 CLX will work with the R4.1X CLX, but code 23 | compiled with the R4.1X CLX will NOT work with the R4 CLX. I made an effort 24 | to ensure backward binary compatibility with R4 CLX so that old code doesn't 25 | have to be recompiled to still work. It does have to be recompiled to fix 26 | an event-queue bug, since the fix involved a change to the event-loop macro. 27 | 28 | R4.2 changes: 29 | 30 | o Atoms and visuals are now correctly maintained in a separate namespace from 31 | windows, pixmaps, cursors, fonts, gcontexts, and colormaps. 32 | 33 | o I have made an attempt to make socket code work for kcl and ibcl. I have 34 | akcl here, but not kcl and ibcl, so it's only guesswork that kcl and ibcl 35 | works. 36 | 37 | o compile-clx and load-clx do more pathname merging to work around problems 38 | in some lisp implementations. *default-pathname-defaults* is never bound 39 | anymore. 40 | 41 | o Some ansi common lisp stuff. If you have :ansi-common-lisp on *features*, 42 | CLX will: 43 | 44 | - Use the common-lisp package instead of the lisp package. 45 | 46 | - Use the common lisp condition system, being careful not to stomp on 47 | define-condition and type-error. 48 | 49 | - Use declaim instead of proclaim. 50 | 51 | - Use the dynamic-extent declaration for rest args and closures. 52 | 53 | - Use print-unreadable-object. 54 | 55 | o Code compiled with the R4 and R4.1 CLX will work with the R4.2 CLX, provided 56 | you don't have :ansi-common-lisp on your features list. Code compiled with 57 | the R4.2 CLX will NOT work with the R4 CLX. 58 | 59 | R4.3 changes: 60 | 61 | o Changed the ansi-common-lisp feature to clx-ansi-common-lisp. 62 | 63 | o A new package.l file has been introduced. All the package operations that 64 | were in the other files have been moved to package.l. Because of this, 65 | the compile-clx and load-clx functions which are defined in the defsystem.l 66 | file have been moved to the user package from the xlib package, since the xlib 67 | package isn't defined when the defsystem.l file is loaded. 68 | 69 | o excldefsys.l has been merged into defsystem.l. You don't have to rename 70 | excldefsys.l to defsystem.l anymore. 71 | 72 | o User-specified-size/position-p hints are now set correctly. 73 | These hints were being ignored if the size-hints structure did not 74 | define the corresponding geometry slots. But ICCCM declares these 75 | slots to be obsolete. 76 | 77 | o (setf wm-command) has been changed to use PRIN1 inside the ANSI Common Lisp 78 | form WITH-STANDARD-IO-SYNTAX (or the equivalent defined in dependent.l), with 79 | elements of command separated by NULL characters. This enables 80 | (with-standard-io-syntax (mapcar #'read-from-string (wm-command window))) 81 | to recover a lisp command. 82 | 83 | o A typo in X-TYPE-ERROR has been fixed. 84 | 85 | o The WITH-GCONTEXT macro has been changed so that if you supply nil for a 86 | property value, WITH-GCONTEXT is will leave the property unchanged. It used 87 | to always change the property without regard for whether the supplied value 88 | was nil. This change to how the macro expands, so user code has to be 89 | recompiled for the change to take effect. 90 | 91 | o Since ANSI Common Lisp doesn't have CHAR-BIT, the implementation of 92 | DEFAULT-KEYSYM-TRANSLATE is now implementation dependent in ANSI Common Lisp 93 | implementations, with the default doing nothing to character objects. In 94 | non-ANSI Common Lisps and lispms, it still uses CHAR-BIT. The definition of 95 | DEFAULT-KEYSYM-TRANSLATE has been moved to dependent.l. 96 | 97 | o The image putting, getting, and copying code has been sped up a bit for lispm, 98 | lcl3.0, and excl. 99 | 100 | o The lcl3.0 io code has been sped up a bit by using read-array instead of 101 | fast-read-byte. 102 | 103 | o READ-RESOURCES now handles any lines that start with # and don't start with 104 | #include as comments. 105 | 106 | R4.4 changes: 107 | 108 | o Fixed typo in DEFAULT-KEYSYM-TRANSLATE. 109 | 110 | o In events, CurrentTime (encoded as 0 in the protocol) decodes to NIL instead 111 | of 0. 112 | 113 | o NIL now translates to and from the atom-id of 0. 114 | 115 | o A new variable *OUTPUT-BUFFER-SIZE* has been introduced, with value 8192. 116 | Now, instead of the buffer creating code always creating output buffers of 117 | length 8192 bytes, they create output buffers of length *OUTPUT-BUFFER-SIZE* 118 | bytes. 119 | 120 | o GCONTEXT-CACHE-P, COLORMAP-PLIST and CURSOR-PLIST have been exported. 121 | 122 | o If CREATE-GCONTEXT is given a rect-seq as a clip-mask, then a 123 | SetClipRectangles request must be sent to initialize the clip-mask. The logic 124 | to do this is located in FORCE-GCONTEXT-CHANGES-INTERNAL, but this wasn't 125 | being called because create-gcontext always forces local/server-state 126 | timestamps equal. Same problem for dash lists. CREATE-GCONTEXT has been 127 | fixed so that in these cases it makes the timestamps unequal so that 128 | FORCE-GCONTEXT-CHANGES-INTERNAL is called. 129 | 130 | o ANGLEP type check sped up for excl. Arc drawing should be lots faster. 131 | 132 | o RATIONAL type definition for kcl now takes the correct optional args. 133 | 134 | o (SETF FONT-PATH) changed to return the value 135 | 136 | o Fixed typo in the hex parsing in READ-BITMAP-FILE 137 | 138 | o Made READ-RESOURCES more robust about weird resource files. 139 | 140 | o New variable *DEF-CLX-CLASS-USE-DEFCLASS*, which controls whether DEF-CLX-CLASS 141 | uses DEFCLASS. If it is a list, it is interpreted by DEF-CLX-CLASS to be a list 142 | of type names for which DEFCLASS should be used. If it is not a list, DEFCLASS 143 | is always used. IF it is NIL, DEFCLASS is never used, since NIL is the empty 144 | list. By default, it's T in Genera, NIL otherwise. 145 | 146 | o Fixed typo in DEFINE-CONDITION for #-(or lispm clx-ansi-common-lisp excl lcl3.0). 147 | 148 | o Fixed typo in MERGE-RESOURCES 149 | 150 | o In Lucid lisp, the functions aref-card8, aref-int8, aset-card8, aset-int8, 151 | aref-card16, aref-int16, aref-card32, aref-int32, aref-card29, aset-card16, 152 | aset-int16, aset-card32, aset-int32, and aset-card29 Have been fixed so that 153 | they can be used inline with the development compiler. 154 | 155 | o The default value of the BYTE-LSB-FIRST-P argument to CREATE-IMAGE has been 156 | changed from always T to T on LSBFirst machines and NIL on MSBFirst machines. 157 | 158 | o The order of the color values returned by ALLOC-COLOR when a color name is supplied 159 | as an argument is fixed so that the screen color correctly is returned as the second 160 | value and the exact color is correctly returned as the third value. The order was 161 | backwards. 162 | 163 | o The internal WITH-BUFFER-INPUT and WITH-BUFFER-OUTPUT macros have been 164 | changed to wrap macrolet around body only when necessary. This simplifies the 165 | compiler's job for non lisp machines. 166 | 167 | o All uses of DEFINE-CONDITION have been changed to include a slots argument, 168 | even if that argument is NIL -- the argument is not optional. 169 | 170 | o DEFINE-CONDITION is no longer exported from the XLIB package. 171 | 172 | o New functionality has been added to make-pixmap and make-window. They may 173 | now take a :PIXMAP or :WINDOW argument (respectively). If non-NIL (default is 174 | nil), they will use that argument as the pixmap or window object to be set. 175 | Otherwise they will create a new pixmap/window object. This whole schmeel is 176 | necessary because creation of window and pixmap objects in CLX doesn't go 177 | through the CLOS initialize-instance mechanism. 178 | 179 | o The DESCRIBE-WINDOW debug utility has been fixed to not use strange 180 | lisp machine format codes. 181 | 182 | o Numerous Allegro specific changes in support of Allegro CL version 4.0. 183 | 184 | R4.5 changes: 185 | 186 | o Fixed READ-VECTOR-CARD8 and WRITE-VECTOR-CARD8 to work with arbitrary vectors. 187 | 188 | o Changed COMPILE-CLX and LOAD-CLX to use the verbose mode of COMPILE-FILE and LOAD. 189 | 190 | o Added a conditional for HPUX to COMPILE-CLX. 191 | 192 | o Changed DISPLAY-CONNECT to save the default colormap ID in the ID database. 193 | 194 | o Added new keyword arguments :PROGRAM-SPECIFIED-POSITION-P and :PROGRAM-SPECIFIED-SIZE-P 195 | to SET-WM-PROPERTIES and corresponsing slots in the WM-SIZE-HINTS structure. 196 | These control the appropriate flags in the size hints. The old way of controlling these 197 | flags, with the :X, :Y, :WIDTH, and :HEIGHT arguments, is now obsolete due to changes 198 | in the ICCCM. 199 | 200 | o Removed bogus declarations from the SETF expander for WM-NAME. 201 | 202 | o Defined a proper SETF function for CUT-BUFFER when in ANSI Lisp. 203 | 204 | o Fix the encoding of the revert-to argument to SET-INPUT-FOCUS. 205 | 206 | o Fix a fencepost error in STORE-COLORS. 207 | 208 | o Fix TEXT-EXTENTS and TEXT-WIDTH to handle font changes properly. 209 | 210 | o Fix TEXT-EXTENTS-LOCAL to handle negative ascents and descents properly. 211 | 212 | o Fix DRAW-IMAGE-GLYPHS to not try to write more than 255 glyphs. 213 | 214 | o Added conditionalizations for Minima, a new operating system under development at Symbolics. 215 | 216 | o Some gratuitous changes in the Symbolics-specific code. 217 | 218 | o Removed *EVENT-LOOP-VERSION* and support for pre-R4.1 compiled code. 219 | 220 | o In Lucid, fixed HOLDING-LOCK to clean up on timeout. 221 | 222 | o Gcontexts and fonts without associated displays now print correctly. 223 | 224 | Requests that send "strings" of two byte font indices can *not* assume that 225 | the two byte objects are being written on two byte boundaries. The simplest 226 | fix was just to modify the write-*-card16 functions to use a new macro that 227 | writes one half of the object at a time. The only undesirable affect of 228 | this is that CLIENT-MESSAGE and CHANGE-PROPERTY are slightly slower for 229 | card16 data than they were before. 230 | NEW macro 231 | -- write-card16-by-bytes bufmac.l 232 | CHANGED functions: 233 | -- write-list-card16 buffer.l 234 | -- write-list-card16-with-transform "" 235 | -- write-simple-array-card16 "" 236 | -- write-simple-array-card16-with-transform "" 237 | -- write-vector-card16 "" 238 | -- write-vector-card16-with-transform "" 239 | 240 | Print functions changed to use write-string instead of princ where 241 | possible. This allows for much cleaner printing when *print-circle* is 242 | true -- princ is required to use *print-circle*, even for strings! 243 | Write-string is, of course, not so burdened. 244 | -- print-color clx.l 245 | -- print-display "" 246 | -- print-drawable "" 247 | -- print-visual-info "" 248 | -- print-colormap "" 249 | -- print-cursor "" 250 | -- print-gcontext "" 251 | -- print-screen "" 252 | -- print-font "" 253 | -- print-resource-database resource.l 254 | -- print-image image.l 255 | 256 | Changes to display tracing: In a multiprocessing system is it very helpful 257 | to know what process wrote or read certain requests. Thus I have modified 258 | the format of the trace-history list. It is now an alist of: ((id . 259 | more-info) . byte-vector). (more-info is a list returned by the 260 | trace-more-info function). Also added the ability to suspend and resume 261 | tracing without destroying the trace history. Renamed 'display-trace' to 262 | 'show-trace' to avoid confusion. (Having both 'trace-display and 263 | 'display-trace wasn't such a hot idea). 264 | -- lots-o-stuff debug/trace.l 265 | 266 | Image-glyph functions had a different argument order than non-image glyph 267 | functions. Image-glyph functions changed to be compatible with others. 268 | Declarations in draw-glyphs* functions were wrong. 269 | -- draw-image-glyphs text.l 270 | -- draw-image-glyphs8 text.l 271 | -- draw-image-glyphs16 text.l 272 | -- draw-glyphs8 text.l 273 | -- draw-glyphs16 text.l 274 | 275 | Quote #.'ed arrays to accomodate CLTL1 lisps 276 | -- empty-data constants image.l 277 | 278 | Set-input-focus fix wasn't finished 279 | -- set-input-focus requests.l 280 | 281 | Standardized strange integer type specifier in keysym macro 282 | -- keysym translate.l 283 | 284 | =============================================================================== 285 | Franz specific changes, applicable to Allegro and Extended Common Lisps: 286 | (note that all these changes are #+excl or #+allegro, so if you're not 287 | using our product these changes are "commented" out) 288 | ----------------------------------------------------------------------- 289 | Atom-cache hash table type changed to #'equal. Resource-id-map has table 290 | type changed to #'equal. 291 | NEW macro 292 | -- atom-cache-map-test depdefs.l 293 | CHANGED def-clx-class 294 | -- display clx.l 295 | CHANGED macro 296 | -- resource-id-map-test depdefs.l 297 | 298 | Don't bother to import require, provide, since we're using the CLTL1 299 | package. Also put the requires and provides inside eval-when to make the 300 | compiler happy. Don't redefine typep, instead push our customizations onto 301 | the typep handling list. 302 | -- toplevel forms excldep.l 303 | 304 | Old code removed from file 305 | -- removed some cmacros exclcmac.l 306 | 307 | Allegro >=4.0 now does support with-standard-io-syntax and 308 | print-unreadable-object. 309 | -- with-standard-io-syntax{,-function} dependent.l 310 | -- print-unreadable-object{,-function} depdefs.l 311 | 312 | Conditionalizations in Makefile cleaned up. 313 | -- exclMakefile 314 | 315 | Descriptive comment added to holding-lock 316 | -- holding-lock dependent.l 317 | 318 | Added typep transformers for all CLX types. 319 | -- excldep.cl 320 | 321 | R5.0 changes: 322 | 323 | o Changed occurrances STRING-CHAR to BASE-CHAR. 324 | 325 | o Fixed some type declarations to use type NULL instead of NIL. 326 | 327 | o Various fixes to vendor-specific code. 328 | 329 | o Detect attempts to use images an incorrect depth. 330 | 331 | o Stop doing case conversion on resource names be default. -------------------------------------------------------------------------------- /MITdist/excldep.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*- 2 | ;;; 3 | ;;; CLX -- excldep.cl 4 | ;;; 5 | ;;; copyright (c) 1987-1989 Franz Inc, Berkeley, CA - All rights reserved. 6 | ;; copyright (c) 1989-2004 Franz Inc, Oakland, CA - All rights reserved. 7 | ;;; 8 | ;;; Permission is granted to any individual or institution to use, copy, 9 | ;;; modify, and distribute this software, provided that this complete 10 | ;;; copyright and permission notice is maintained, intact, in all copies and 11 | ;;; supporting documentation. 12 | ;;; 13 | ;;; Franz Incorporated provides this software "as is" without 14 | ;;; express or implied warranty. 15 | ;;; 16 | 17 | (in-package :xlib) 18 | 19 | (eval-when (compile load eval) 20 | (require :foreign) 21 | (require :process) ; Needed even if scheduler is not 22 | ; running. (Must be able to make 23 | ; a process-lock.) 24 | ) 25 | 26 | (eval-when (load) 27 | (provide :clx)) 28 | 29 | 30 | #-(or little-endian big-endian) 31 | (eval-when (eval compile load) 32 | (let ((x '#(1))) 33 | (if (not (eq 0 (sys::memref x 34 | #.(comp::mdparam 'comp::md-svector-data0-adj) 35 | 0 :unsigned-byte))) 36 | (pushnew :little-endian *features*) 37 | (pushnew :big-endian *features*)))) 38 | 39 | 40 | (defmacro correct-case (string) 41 | ;; This macro converts the given string to the 42 | ;; current preferred case, or leaves it alone in a case-sensitive mode. 43 | (let ((str (gensym))) 44 | `(let ((,str ,string)) 45 | (case excl::*current-case-mode* 46 | (:case-insensitive-lower 47 | (string-downcase ,str)) 48 | (:case-insensitive-upper 49 | (string-upcase ,str)) 50 | ((:case-sensitive-lower :case-sensitive-upper) 51 | ,str))))) 52 | 53 | 54 | (defconstant type-pred-alist 55 | '(#-(version>= 4 1 devel 16) 56 | (card8 . card8p) 57 | #-(version>= 4 1 devel 16) 58 | (card16 . card16p) 59 | #-(version>= 4 1 devel 16) 60 | (card29 . card29p) 61 | #-(version>= 4 1 devel 16) 62 | (card32 . card32p) 63 | #-(version>= 4 1 devel 16) 64 | (int8 . int8p) 65 | #-(version>= 4 1 devel 16) 66 | (int16 . int16p) 67 | #-(version>= 4 1 devel 16) 68 | (int32 . int32p) 69 | #-(version>= 4 1 devel 16) 70 | (mask16 . card16p) 71 | #-(version>= 4 1 devel 16) 72 | (mask32 . card32p) 73 | #-(version>= 4 1 devel 16) 74 | (pixel . card32p) 75 | #-(version>= 4 1 devel 16) 76 | (resource-id . card29p) 77 | #-(version>= 4 1 devel 16) 78 | (keysym . card32p) 79 | (angle . anglep) 80 | (color . color-p) 81 | (bitmap-format . bitmap-format-p) 82 | (pixmap-format . pixmap-format-p) 83 | (display . display-p) 84 | (drawable . drawable-p) 85 | (window . window-p) 86 | (pixmap . pixmap-p) 87 | (visual-info . visual-info-p) 88 | (colormap . colormap-p) 89 | (cursor . cursor-p) 90 | (gcontext . gcontext-p) 91 | (screen . screen-p) 92 | (font . font-p) 93 | (image-x . image-x-p) 94 | (image-xy . image-xy-p) 95 | (image-z . image-z-p) 96 | (wm-hints . wm-hints-p) 97 | (wm-size-hints . wm-size-hints-p) 98 | )) 99 | 100 | ;; This (if (and ...) t nil) stuff has a purpose -- it lets the old 101 | ;; sun4 compiler opencode the `and'. 102 | 103 | #-(version>= 4 1 devel 16) 104 | (defun card8p (x) 105 | (declare (optimize (speed 3) (safety 0)) 106 | (fixnum x)) 107 | (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0)) 108 | t 109 | nil)) 110 | 111 | #-(version>= 4 1 devel 16) 112 | (defun card16p (x) 113 | (declare (optimize (speed 3) (safety 0)) 114 | (fixnum x)) 115 | (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0)) 116 | t 117 | nil)) 118 | 119 | #-(version>= 4 1 devel 16) 120 | (defun card29p (x) 121 | (declare (optimize (speed 3) (safety 0))) 122 | (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) 123 | (and (excl:bignump x) (> #.(expt 2 29) (the bignum x)) 124 | (>= (the bignum x) 0))) 125 | t 126 | nil)) 127 | 128 | #-(version>= 4 1 devel 16) 129 | (defun card32p (x) 130 | (declare (optimize (speed 3) (safety 0))) 131 | (if (or (and (excl:fixnump x) (>= (the fixnum x) 0)) 132 | (and (excl:bignump x) (> #.(expt 2 32) (the bignum x)) 133 | (>= (the bignum x) 0))) 134 | t 135 | nil)) 136 | 137 | #-(version>= 4 1 devel 16) 138 | (defun int8p (x) 139 | (declare (optimize (speed 3) (safety 0)) 140 | (fixnum x)) 141 | (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7))) 142 | t 143 | nil)) 144 | 145 | #-(version>= 4 1 devel 16) 146 | (defun int16p (x) 147 | (declare (optimize (speed 3) (safety 0)) 148 | (fixnum x)) 149 | (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15))) 150 | t 151 | nil)) 152 | 153 | #-(version>= 4 1 devel 16) 154 | (defun int32p (x) 155 | (declare (optimize (speed 3) (safety 0))) 156 | (if (or (excl:fixnump x) 157 | (and (excl:bignump x) (> #.(expt 2 31) (the bignum x)) 158 | (>= (the bignum x) #.(expt -2 31)))) 159 | t 160 | nil)) 161 | 162 | ;; This one can be handled better by knowing a little about what we're 163 | ;; testing for. Plus this version can handle (single-float pi), which 164 | ;; is otherwise larger than pi! 165 | (defun anglep (x) 166 | (declare (optimize (speed 3) (safety 0))) 167 | (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi))) 168 | (<= (the fixnum x) #.(truncate (* 2 pi)))) 169 | (and (excl::single-float-p x) 170 | (>= (the single-float x) #.(float (* -2 pi) 0.0s0)) 171 | (<= (the single-float x) #.(float (* 2 pi) 0.0s0))) 172 | (and (excl::double-float-p x) 173 | (>= (the double-float x) #.(float (* -2 pi) 0.0d0)) 174 | (<= (the double-float x) #.(float (* 2 pi) 0.0d0)))) 175 | t 176 | nil)) 177 | 178 | (eval-when (load eval) 179 | #+(version>= 4 1 devel 16) 180 | (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt))) 181 | type-pred-alist) 182 | #-(version>= 4 1 devel 16) 183 | (nconc excl::type-pred-alist type-pred-alist)) 184 | 185 | 186 | ;; Return t if there is a character available for reading or on error, 187 | ;; otherwise return nil. 188 | #-(version>= 6 0) 189 | (defun fd-char-avail-p (fd) 190 | (multiple-value-bind (available-p errcode) 191 | (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd) 192 | (excl:if* errcode 193 | then t 194 | else available-p))) 195 | 196 | #+(version>= 6 0) 197 | (defun fd-char-avail-p (socket-stream) 198 | (excl::read-no-hang-p socket-stream)) 199 | 200 | (defmacro with-interrupt-checking-on (&body body) 201 | `(locally (declare (optimize (safety 1))) 202 | ,@body)) 203 | 204 | ;; Read from the given fd into 'vector', which has element type card8. 205 | ;; Start storing at index 'start-index' and read exactly 'length' bytes. 206 | ;; Return t if an error or eof occurred, nil otherwise. 207 | (defun fd-read-bytes (fd vector start-index length) 208 | (declare (fixnum fd start-index length) 209 | (type (simple-array (unsigned-byte 8) (*)) vector)) 210 | (with-interrupt-checking-on 211 | (do ((rest length)) 212 | ((eq 0 rest) nil) 213 | (declare (fixnum rest)) 214 | ;; added by cac 24jul99 215 | ;; Crude but effective way to wait for input when whole buffer 216 | ;; doesn't get filled all at once. Probably should 217 | ;; make more robust in light of possible failing sockets. 218 | (loop 219 | (when (fd-char-avail-p fd) 220 | (return))) 221 | (multiple-value-bind (numread errcode) 222 | (comp::.primcall-sargs 'sys::filesys excl::fs-read-bytes fd vector 223 | start-index rest) 224 | (declare (fixnum numread)) 225 | (excl:if* errcode 226 | then (if (not (eq errcode 227 | excl::*error-code-interrupted-system-call*)) 228 | (return t)) 229 | elseif (eq 0 numread) 230 | then (return t) 231 | else (decf rest numread) 232 | (incf start-index numread)))))) 233 | 234 | 235 | (when (plusp (ff:get-entry-points 236 | (make-array 1 :initial-contents 237 | (list (ff:convert-to-lang "fd_wait_for_input"))) 238 | (make-array 1 :element-type '(unsigned-byte 32)))) 239 | (ff:remove-entry-point (ff:convert-to-lang "fd_wait_for_input")) 240 | (load "excldep.o")) 241 | 242 | (when (plusp (ff:get-entry-points 243 | (make-array 1 :initial-contents 244 | (list (ff:convert-to-lang "connect_to_server"))) 245 | (make-array 1 :element-type '(unsigned-byte 32)))) 246 | (ff:remove-entry-point (ff:convert-to-lang "connect_to_server" :language :c)) 247 | (load "socket.o")) 248 | 249 | (ff:defforeign-list `((connect-to-server 250 | :entry-point 251 | ,(ff:convert-to-lang "connect_to_server") 252 | :return-type :fixnum 253 | :arg-checking nil 254 | :arguments (string fixnum)) 255 | (fd-wait-for-input 256 | :entry-point ,(ff:convert-to-lang "fd_wait_for_input") 257 | :return-type :fixnum 258 | :arg-checking nil 259 | :call-direct t 260 | :callback nil 261 | :allow-other-keys t 262 | :arguments (fixnum fixnum)))) 263 | 264 | 265 | ;; special patch for CLX (various process fixes) 266 | ;; patch1000.2 267 | 268 | (eval-when (compile load eval) 269 | (unless (find-package :patch) 270 | (make-package :patch :use '(:lisp :excl)))) 271 | 272 | (in-package :patch) 273 | 274 | (defvar *patches* nil) 275 | 276 | #+allegro 277 | (eval-when (compile eval load) 278 | (when (and (= excl::cl-major-version-number 3) 279 | (or (= excl::cl-minor-version-number 0) 280 | (and (= excl::cl-minor-version-number 1) 281 | excl::cl-generation-number 282 | (< excl::cl-generation-number 9)))) 283 | (push :clx-r4-process-patches *features*))) 284 | 285 | #+clx-r4-process-patches 286 | (push (cons 1000.2 "special patch for CLX (various process fixes)") 287 | *patches*) 288 | 289 | 290 | (in-package :mp) 291 | 292 | #+clx-r4-process-patches 293 | (export 'wait-for-input-available) 294 | 295 | 296 | #+clx-r4-process-patches 297 | (defun with-timeout-event (seconds fnc args) 298 | (unless (si:scheduler-running-p) 299 | (start-scheduler)) ;[spr670] 300 | (let ((clock-event (make-clock-event))) 301 | (when (<= seconds 0) (setq seconds 0)) 302 | (multiple-value-bind (secs msecs) (truncate seconds) 303 | ;; secs is now a nonegative integer, and msecs is either fixnum zero 304 | ;; or else something interesting. 305 | (unless (eq 0 msecs) 306 | (setq msecs (truncate (* 1000.0 msecs)))) 307 | ;; Now msecs is also a nonnegative fixnum. 308 | (multiple-value-bind (now mnow) (excl::cl-internal-real-time) 309 | (incf secs now) 310 | (incf msecs mnow) 311 | (when (>= msecs 1000) 312 | (decf msecs 1000) 313 | (incf secs)) 314 | (unless (excl:fixnump secs) (setq secs most-positive-fixnum)) 315 | (setf (clock-event-secs clock-event) secs 316 | (clock-event-msecs clock-event) msecs 317 | (clock-event-function clock-event) fnc 318 | (clock-event-args clock-event) args))) 319 | clock-event)) 320 | 321 | 322 | #+clx-r4-process-patches 323 | (defmacro with-timeout ((seconds &body timeout-body) &body body) 324 | `(let* ((clock-event (with-timeout-event ,seconds 325 | #'process-interrupt 326 | (cons *current-process* 327 | '(with-timeout-internal)))) 328 | (excl::*without-interrupts* t) 329 | ret) 330 | (unwind-protect 331 | ;; Warning: Branch tensioner better not reorder this code! 332 | (setq ret (catch 'with-timeout-internal 333 | (add-to-clock-queue clock-event) 334 | (let ((excl::*without-interrupts* nil)) 335 | (multiple-value-list (progn ,@body))))) 336 | (excl:if* (eq ret 'with-timeout-internal) 337 | then (let ((excl::*without-interrupts* nil)) 338 | (setq ret (multiple-value-list (progn ,@timeout-body)))) 339 | else (remove-from-clock-queue clock-event))) 340 | (values-list ret))) 341 | 342 | 343 | #+clx-r4-process-patches 344 | (defun process-lock (lock &optional (lock-value *current-process*) 345 | (whostate "Lock") timeout) 346 | (declare (optimize (speed 3))) 347 | (unless (process-lock-p lock) 348 | (error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock)) 349 | (without-interrupts 350 | (excl:if* (null (process-lock-locker lock)) 351 | then (setf (process-lock-locker lock) lock-value) 352 | else (excl:if* timeout 353 | then (excl:if* (or (eq 0 timeout) ;for speed 354 | (zerop timeout)) 355 | then nil 356 | else (with-timeout (timeout) 357 | (process-lock-1 lock lock-value whostate))) 358 | else (process-lock-1 lock lock-value whostate))))) 359 | 360 | 361 | #+clx-r4-process-patches 362 | (defun process-lock-1 (lock lock-value whostate) 363 | (declare (type process-lock lock) 364 | (optimize (speed 3))) 365 | (let ((process *current-process*)) 366 | (declare (type process process)) 367 | (unless process 368 | (error 369 | "PROCESS-LOCK may not be called on the scheduler's stack group.")) 370 | (loop (unless (process-lock-locker lock) 371 | (return (setf (process-lock-locker lock) lock-value))) 372 | (push process (process-lock-waiting lock)) 373 | (let ((saved-whostate (process-whostate process))) 374 | (unwind-protect 375 | (progn (setf (process-whostate process) whostate) 376 | (process-add-arrest-reason process lock)) 377 | (setf (process-whostate process) saved-whostate)))))) 378 | 379 | 380 | #+clx-r4-process-patches 381 | (defun process-wait (whostate function &rest args) 382 | (declare (optimize (speed 3))) 383 | ;; Run the wait function once here both for efficiency and as a 384 | ;; first line check for errors in the function. 385 | (unless (apply function args) 386 | (process-wait-1 whostate function args))) 387 | 388 | 389 | #+clx-r4-process-patches 390 | (defun process-wait-1 (whostate function args) 391 | (declare (optimize (speed 3))) 392 | (let ((process *current-process*)) 393 | (declare (type process process)) 394 | (unless process 395 | (error 396 | "Process-wait may not be called within the scheduler's stack group.")) 397 | (let ((saved-whostate (process-whostate process))) 398 | (unwind-protect 399 | (without-scheduling-internal 400 | (without-interrupts 401 | (setf (process-whostate process) whostate 402 | (process-wait-function process) function 403 | (process-wait-args process) args) 404 | (chain-rem-q process) 405 | (chain-ins-q process *waiting-processes*)) 406 | (process-resume-scheduler nil)) 407 | (setf (process-whostate process) saved-whostate 408 | (process-wait-function process) nil 409 | (process-wait-args process) nil))))) 410 | 411 | 412 | #+clx-r4-process-patches 413 | (defun process-wait-with-timeout (whostate seconds function &rest args) 414 | ;; Now returns T upon completion, NIL upon timeout. -- 6Jun89 smh 415 | ;; [spr1135] [rfe939] Timeout won't throw out of interrupt level code. 416 | ;; -- 28Feb90 smh 417 | ;; Run the wait function once here both for efficiency and as a 418 | ;; first line check for errors in the function. 419 | (excl:if* (apply function args) 420 | then t 421 | else (let ((ret (list nil))) 422 | (without-interrupts 423 | (let ((clock-event 424 | (with-timeout-event seconds #'identity '(nil)))) 425 | (add-to-clock-queue clock-event) 426 | (process-wait-1 whostate 427 | #'(lambda (clock-event function args ret) 428 | (or (null (chain-next clock-event)) 429 | (and (apply function args) 430 | (setf (car ret) 't)))) 431 | (list clock-event function args ret)))) 432 | (car ret)))) 433 | 434 | 435 | ;; 436 | ;; Returns nil on timeout, otherwise t. 437 | ;; 438 | #+clx-r4-process-patches 439 | (defun wait-for-input-available 440 | (stream-or-fd &key (wait-function #'listen) 441 | (whostate "waiting for input") 442 | timeout) 443 | (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd 444 | elseif (streamp stream-or-fd) 445 | then (excl::stream-input-fn stream-or-fd) 446 | else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd)))) 447 | ;; At this point fd could be nil, since stream-input-fn returns nil for 448 | ;; streams that are output only, or for certain special purpose streams. 449 | (if fd 450 | (unwind-protect 451 | (progn 452 | (mp::mpwatchfor fd) 453 | (excl:if* timeout 454 | then (mp::process-wait-with-timeout 455 | whostate timeout wait-function stream-or-fd) 456 | else (mp::process-wait whostate wait-function stream-or-fd) 457 | t)) 458 | (mp::mpunwatchfor fd)) 459 | (excl:if* timeout 460 | then (mp::process-wait-with-timeout 461 | whostate timeout wait-function stream-or-fd) 462 | else (mp::process-wait whostate wait-function stream-or-fd) 463 | t)))) 464 | -------------------------------------------------------------------------------- /keysyms.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*- 2 | 3 | ;;; Define lisp character to keysym mappings 4 | 5 | ;;; 6 | ;;; TEXAS INSTRUMENTS INCORPORATED 7 | ;;; P.O. BOX 2909 8 | ;;; AUSTIN, TEXAS 78769 9 | ;;; 10 | ;;; Copyright (C) 1987 Texas Instruments Incorporated. 11 | ;;; 12 | ;;; Permission is granted to any individual or institution to use, copy, modify, 13 | ;;; and distribute this software, provided that this complete copyright and 14 | ;;; permission notice is maintained, intact, in all copies and supporting 15 | ;;; documentation. 16 | ;;; 17 | ;;; Texas Instruments Incorporated provides this software "as is" without 18 | ;;; express or implied warranty. 19 | ;;; 20 | 21 | (in-package :xlib) 22 | 23 | (define-keysym-set :latin-1 (keysym 0 0) (keysym 0 255)) 24 | (define-keysym-set :latin-2 (keysym 1 0) (keysym 1 255)) 25 | (define-keysym-set :latin-3 (keysym 2 0) (keysym 2 255)) 26 | (define-keysym-set :latin-4 (keysym 3 0) (keysym 3 255)) 27 | (define-keysym-set :kana (keysym 4 0) (keysym 4 255)) 28 | (define-keysym-set :arabic (keysym 5 0) (keysym 5 255)) 29 | (define-keysym-set :cryllic (keysym 6 0) (keysym 6 255)) 30 | (define-keysym-set :greek (keysym 7 0) (keysym 7 255)) 31 | (define-keysym-set :tech (keysym 8 0) (keysym 8 255)) 32 | (define-keysym-set :special (keysym 9 0) (keysym 9 255)) 33 | (define-keysym-set :publish (keysym 10 0) (keysym 10 255)) 34 | (define-keysym-set :apl (keysym 11 0) (keysym 11 255)) 35 | (define-keysym-set :hebrew (keysym 12 0) (keysym 12 255)) 36 | (define-keysym-set :keyboard (keysym 255 0) (keysym 255 255)) 37 | 38 | (define-keysym :character-set-switch character-set-switch-keysym) 39 | (define-keysym :left-shift left-shift-keysym) 40 | (define-keysym :right-shift right-shift-keysym) 41 | (define-keysym :left-control left-control-keysym) 42 | (define-keysym :right-control right-control-keysym) 43 | (define-keysym :caps-lock caps-lock-keysym) 44 | (define-keysym :shift-lock shift-lock-keysym) 45 | (define-keysym :left-meta left-meta-keysym) 46 | (define-keysym :right-meta right-meta-keysym) 47 | (define-keysym :left-alt left-alt-keysym) 48 | (define-keysym :right-alt right-alt-keysym) 49 | (define-keysym :left-super left-super-keysym) 50 | (define-keysym :right-super right-super-keysym) 51 | (define-keysym :left-hyper left-hyper-keysym) 52 | (define-keysym :right-hyper right-hyper-keysym) 53 | 54 | (define-keysym #\space 032) 55 | (define-keysym #\! 033) 56 | (define-keysym #\" 034) 57 | (define-keysym #\# 035) 58 | (define-keysym #\$ 036) 59 | (define-keysym #\% 037) 60 | (define-keysym #\& 038) 61 | (define-keysym #\' 039) 62 | (define-keysym #\( 040) 63 | (define-keysym #\) 041) 64 | (define-keysym #\* 042) 65 | (define-keysym #\+ 043) 66 | (define-keysym #\, 044) 67 | (define-keysym #\- 045) 68 | (define-keysym #\. 046) 69 | (define-keysym #\/ 047) 70 | (define-keysym #\0 048) 71 | (define-keysym #\1 049) 72 | (define-keysym #\2 050) 73 | (define-keysym #\3 051) 74 | (define-keysym #\4 052) 75 | (define-keysym #\5 053) 76 | (define-keysym #\6 054) 77 | (define-keysym #\7 055) 78 | (define-keysym #\8 056) 79 | (define-keysym #\9 057) 80 | (define-keysym #\: 058) 81 | (define-keysym #\; 059) 82 | (define-keysym #\< 060) 83 | (define-keysym #\= 061) 84 | (define-keysym #\> 062) 85 | (define-keysym #\? 063) 86 | (define-keysym #\@ 064) 87 | (define-keysym #\A 065 :lowercase 097) 88 | (define-keysym #\B 066 :lowercase 098) 89 | (define-keysym #\C 067 :lowercase 099) 90 | (define-keysym #\D 068 :lowercase 100) 91 | (define-keysym #\E 069 :lowercase 101) 92 | (define-keysym #\F 070 :lowercase 102) 93 | (define-keysym #\G 071 :lowercase 103) 94 | (define-keysym #\H 072 :lowercase 104) 95 | (define-keysym #\I 073 :lowercase 105) 96 | (define-keysym #\J 074 :lowercase 106) 97 | (define-keysym #\K 075 :lowercase 107) 98 | (define-keysym #\L 076 :lowercase 108) 99 | (define-keysym #\M 077 :lowercase 109) 100 | (define-keysym #\N 078 :lowercase 110) 101 | (define-keysym #\O 079 :lowercase 111) 102 | (define-keysym #\P 080 :lowercase 112) 103 | (define-keysym #\Q 081 :lowercase 113) 104 | (define-keysym #\R 082 :lowercase 114) 105 | (define-keysym #\S 083 :lowercase 115) 106 | (define-keysym #\T 084 :lowercase 116) 107 | (define-keysym #\U 085 :lowercase 117) 108 | (define-keysym #\V 086 :lowercase 118) 109 | (define-keysym #\W 087 :lowercase 119) 110 | (define-keysym #\X 088 :lowercase 120) 111 | (define-keysym #\Y 089 :lowercase 121) 112 | (define-keysym #\Z 090 :lowercase 122) 113 | (define-keysym #\[ 091) 114 | (define-keysym #\\ 092) 115 | (define-keysym #\] 093) 116 | (define-keysym #\^ 094) 117 | (define-keysym #\_ 095) 118 | (define-keysym #\` 096) 119 | (define-keysym #\a 097) 120 | (define-keysym #\b 098) 121 | (define-keysym #\c 099) 122 | (define-keysym #\d 100) 123 | (define-keysym #\e 101) 124 | (define-keysym #\f 102) 125 | (define-keysym #\g 103) 126 | (define-keysym #\h 104) 127 | (define-keysym #\i 105) 128 | (define-keysym #\j 106) 129 | (define-keysym #\k 107) 130 | (define-keysym #\l 108) 131 | (define-keysym #\m 109) 132 | (define-keysym #\n 110) 133 | (define-keysym #\o 111) 134 | (define-keysym #\p 112) 135 | (define-keysym #\q 113) 136 | (define-keysym #\r 114) 137 | (define-keysym #\s 115) 138 | (define-keysym #\t 116) 139 | (define-keysym #\u 117) 140 | (define-keysym #\v 118) 141 | (define-keysym #\w 119) 142 | (define-keysym #\x 120) 143 | (define-keysym #\y 121) 144 | (define-keysym #\z 122) 145 | (define-keysym #\{ 123) 146 | (define-keysym #\| 124) 147 | (define-keysym #\} 125) 148 | (define-keysym #\~ 126) 149 | 150 | (progn ;; Semi-standard characters 151 | (define-keysym #\rubout (keysym 255 255)) ; :tty 152 | (define-keysym #\tab (keysym 255 009)) ; :tty 153 | (define-keysym #\linefeed (keysym 255 010)) ; :tty 154 | (define-keysym #\page (keysym 009 227)) ; :special 155 | (define-keysym #\return (keysym 255 013)) ; :tty 156 | (define-keysym #\backspace (keysym 255 008)) ; :tty 157 | ) 158 | 159 | #+(or lispm excl) 160 | (progn ;; Nonstandard characters 161 | (define-keysym #\escape (keysym 255 027)) ; :tty 162 | ) 163 | 164 | #+ti 165 | (progn 166 | (define-keysym #\Inverted-exclamation-mark 161) 167 | (define-keysym #\american-cent-sign 162) 168 | (define-keysym #\british-pound-sign 163) 169 | (define-keysym #\Currency-sign 164) 170 | (define-keysym #\Japanese-yen-sign 165) 171 | (define-keysym #\Yen 165) 172 | (define-keysym #\Broken-bar 166) 173 | (define-keysym #\Section-symbol 167) 174 | (define-keysym #\Section 167) 175 | (define-keysym #\Diaresis 168) 176 | (define-keysym #\Umlaut 168) 177 | (define-keysym #\Copyright-sign 169) 178 | (define-keysym #\Copyright 169) 179 | (define-keysym #\Feminine-ordinal-indicator 170) 180 | (define-keysym #\Angle-quotation-left 171) 181 | (define-keysym #\Soft-hyphen 173) 182 | (define-keysym #\Shy 173) 183 | (define-keysym #\Registered-trademark 174) 184 | (define-keysym #\Macron 175) 185 | (define-keysym #\Degree-sign 176) 186 | (define-keysym #\Ring 176) 187 | (define-keysym #\Plus-minus-sign 177) 188 | (define-keysym #\Superscript-2 178) 189 | (define-keysym #\Superscript-3 179) 190 | (define-keysym #\Acute-accent 180) 191 | (define-keysym #\Greek-mu 181) 192 | (define-keysym #\Paragraph-symbol 182) 193 | (define-keysym #\Paragraph 182) 194 | (define-keysym #\Pilcrow-sign 182) 195 | (define-keysym #\Middle-dot 183) 196 | (define-keysym #\Cedilla 184) 197 | (define-keysym #\Superscript-1 185) 198 | (define-keysym #\Masculine-ordinal-indicator 186) 199 | (define-keysym #\Angle-quotation-right 187) 200 | (define-keysym #\Fraction-1/4 188) 201 | (define-keysym #\One-quarter 188) 202 | (define-keysym #\Fraction-1/2 189) 203 | (define-keysym #\One-half 189) 204 | (define-keysym #\Fraction-3/4 190) 205 | (define-keysym #\Three-quarters 190) 206 | (define-keysym #\Inverted-question-mark 191) 207 | (define-keysym #\Multiplication-sign 215) 208 | (define-keysym #\Eszet 223) 209 | (define-keysym #\Division-sign 247) 210 | ) 211 | 212 | #+ti 213 | (progn ;; There are no 7-bit ascii representations for the following 214 | ;; European characters, so use int-char to create them to ensure 215 | ;; nothing is lost while sending files through the mail. 216 | (define-keysym (int-char 192) 192 :lowercase 224) 217 | (define-keysym (int-char 193) 193 :lowercase 225) 218 | (define-keysym (int-char 194) 194 :lowercase 226) 219 | (define-keysym (int-char 195) 195 :lowercase 227) 220 | (define-keysym (int-char 196) 196 :lowercase 228) 221 | (define-keysym (int-char 197) 197 :lowercase 229) 222 | (define-keysym (int-char 198) 198 :lowercase 230) 223 | (define-keysym (int-char 199) 199 :lowercase 231) 224 | (define-keysym (int-char 200) 200 :lowercase 232) 225 | (define-keysym (int-char 201) 201 :lowercase 233) 226 | (define-keysym (int-char 202) 202 :lowercase 234) 227 | (define-keysym (int-char 203) 203 :lowercase 235) 228 | (define-keysym (int-char 204) 204 :lowercase 236) 229 | (define-keysym (int-char 205) 205 :lowercase 237) 230 | (define-keysym (int-char 206) 206 :lowercase 238) 231 | (define-keysym (int-char 207) 207 :lowercase 239) 232 | (define-keysym (int-char 208) 208 :lowercase 240) 233 | (define-keysym (int-char 209) 209 :lowercase 241) 234 | (define-keysym (int-char 210) 210 :lowercase 242) 235 | (define-keysym (int-char 211) 211 :lowercase 243) 236 | (define-keysym (int-char 212) 212 :lowercase 244) 237 | (define-keysym (int-char 213) 213 :lowercase 245) 238 | (define-keysym (int-char 214) 214 :lowercase 246) 239 | (define-keysym (int-char 215) 215) 240 | (define-keysym (int-char 216) 216 :lowercase 248) 241 | (define-keysym (int-char 217) 217 :lowercase 249) 242 | (define-keysym (int-char 218) 218 :lowercase 250) 243 | (define-keysym (int-char 219) 219 :lowercase 251) 244 | (define-keysym (int-char 220) 220 :lowercase 252) 245 | (define-keysym (int-char 221) 221 :lowercase 253) 246 | (define-keysym (int-char 222) 222 :lowercase 254) 247 | (define-keysym (int-char 223) 223) 248 | (define-keysym (int-char 224) 224) 249 | (define-keysym (int-char 225) 225) 250 | (define-keysym (int-char 226) 226) 251 | (define-keysym (int-char 227) 227) 252 | (define-keysym (int-char 228) 228) 253 | (define-keysym (int-char 229) 229) 254 | (define-keysym (int-char 230) 230) 255 | (define-keysym (int-char 231) 231) 256 | (define-keysym (int-char 232) 232) 257 | (define-keysym (int-char 233) 233) 258 | (define-keysym (int-char 234) 234) 259 | (define-keysym (int-char 235) 235) 260 | (define-keysym (int-char 236) 236) 261 | (define-keysym (int-char 237) 237) 262 | (define-keysym (int-char 238) 238) 263 | (define-keysym (int-char 239) 239) 264 | (define-keysym (int-char 240) 240) 265 | (define-keysym (int-char 241) 241) 266 | (define-keysym (int-char 242) 242) 267 | (define-keysym (int-char 243) 243) 268 | (define-keysym (int-char 244) 244) 269 | (define-keysym (int-char 245) 245) 270 | (define-keysym (int-char 246) 246) 271 | (define-keysym (int-char 247) 247) 272 | (define-keysym (int-char 248) 248) 273 | (define-keysym (int-char 249) 249) 274 | (define-keysym (int-char 250) 250) 275 | (define-keysym (int-char 251) 251) 276 | (define-keysym (int-char 252) 252) 277 | (define-keysym (int-char 253) 253) 278 | (define-keysym (int-char 254) 254) 279 | (define-keysym (int-char 255) 255) 280 | ) 281 | 282 | #+lispm ;; Nonstandard characters 283 | (progn 284 | (define-keysym #\center-dot (keysym 183)) ; :latin-1 285 | (define-keysym #\down-arrow (keysym 008 254)) ; :technical 286 | (define-keysym #\alpha (keysym 007 225)) ; :greek 287 | (define-keysym #\beta (keysym 007 226)) ; :greek 288 | (define-keysym #\and-sign (keysym 008 222)) ; :technical 289 | (define-keysym #\not-sign (keysym 172)) ; :latin-1 290 | (define-keysym #\epsilon (keysym 007 229)) ; :greek 291 | (define-keysym #\pi (keysym 007 240)) ; :greek 292 | (define-keysym #\lambda (keysym 007 235)) ; :greek 293 | (define-keysym #\gamma (keysym 007 227)) ; :greek 294 | (define-keysym #\delta (keysym 007 228)) ; :greek 295 | (define-keysym #\up-arrow (keysym 008 252)) ; :technical 296 | (define-keysym #\plus-minus (keysym 177)) ; :latin-1 297 | (define-keysym #\infinity (keysym 008 194)) ; :technical 298 | (define-keysym #\partial-delta (keysym 008 239)) ; :technical 299 | (define-keysym #\left-horseshoe (keysym 011 218)) ; :apl 300 | (define-keysym #\right-horseshoe (keysym 011 216)) ; :apl 301 | (define-keysym #\up-horseshoe (keysym 011 195)) ; :apl 302 | (define-keysym #\down-horseshoe (keysym 011 214)) ; :apl 303 | (define-keysym #\double-arrow (keysym 008 205)) ; :technical 304 | (define-keysym #\left-arrow (keysym 008 251)) ; :technical 305 | (define-keysym #\right-arrow (keysym 008 253)) ; :technical 306 | (define-keysym #\not-equals (keysym 008 189)) ; :technical 307 | (define-keysym #\less-or-equal (keysym 008 188)) ; :technical 308 | (define-keysym #\greater-or-equal (keysym 008 190)) ; :technical 309 | (define-keysym #\equivalence (keysym 008 207)) ; :technical 310 | (define-keysym #\or-sign (keysym 008 223)) ; :technical 311 | (define-keysym #\integral (keysym 008 191)) ; :technical 312 | ;; break isn't null 313 | ;; (define-keysym #\null (keysym 255 107)) ; :function 314 | (define-keysym #\clear-input (keysym 255 011)) ; :tty 315 | (define-keysym #\help (keysym 255 106)) ; :function 316 | (define-keysym #\refresh (keysym 255 097)) ; :function 317 | (define-keysym #\abort (keysym 255 105)) ; :function 318 | (define-keysym #\resume (keysym 255 098)) ; :function 319 | (define-keysym #\end (keysym 255 087)) ; :cursor 320 | ;;#\universal-quantifier 321 | ;;#\existential-quantifier 322 | ;;#\circle-plus 323 | ;;#\circle-cross same as #\circle-x 324 | ) 325 | 326 | #+genera 327 | (progn 328 | ;;#\network 329 | ;;#\symbol-help 330 | (define-keysym #\lozenge (keysym 009 224)) ; :special 331 | (define-keysym #\suspend (keysym 255 019)) ; :tty 332 | (define-keysym #\function (keysym 255 032)) ; :function 333 | (define-keysym #\square (keysym 010 231)) ; :publishing 334 | (define-keysym #\circle (keysym 010 230)) ; :publishing 335 | (define-keysym #\triangle (keysym 010 232)) ; :publishing 336 | (define-keysym #\scroll (keysym 255 086)) ; :cursor 337 | (define-keysym #\select (keysym 255 096)) ; :function 338 | (define-keysym #\complete (keysym 255 104)) ; :function 339 | ) 340 | 341 | #+ti 342 | (progn 343 | (define-keysym #\terminal (keysym 255 032)) ; :function 344 | (define-keysym #\system (keysym 255 096)) ; :function 345 | (define-keysym #\center-arrow (keysym 255 80)) 346 | (define-keysym #\left-arrow (keysym 255 081)) ; :cursor 347 | (define-keysym #\up-arrow (keysym 255 082)) ; :cursor 348 | (define-keysym #\right-arrow (keysym 255 083)) ; :cursor 349 | (define-keysym #\down-arrow (keysym 255 084)) ; :cursor 350 | (define-keysym #\end (keysym 255 087)) ; :cursor 351 | (define-keysym #\undo (keysym 255 101)) ; :function 352 | (define-keysym #\break (keysym 255 107)) 353 | (define-keysym #\keypad-space (keysym 255 128)) ; :keypad 354 | (define-keysym #\keypad-tab (keysym 255 137)) ; :keypad 355 | (define-keysym #\keypad-enter (keysym 255 141)) ; :keypad 356 | (define-keysym #\f1 (keysym 255 145)) ; :keypad 357 | (define-keysym #\f2 (keysym 255 146)) ; :keypad 358 | (define-keysym #\f3 (keysym 255 147)) ; :keypad 359 | (define-keysym #\f4 (keysym 255 148)) ; :keypad 360 | (define-keysym #\f1 (keysym 255 190)) ; :keypad 361 | (define-keysym #\f2 (keysym 255 191)) ; :keypad 362 | (define-keysym #\f3 (keysym 255 192)) ; :keypad 363 | (define-keysym #\f4 (keysym 255 193)) ; :keypad 364 | (define-keysym #\keypad-plus (keysym 255 171)) ; :keypad 365 | (define-keysym #\keypad-comma (keysym 255 172)) ; :keypad 366 | (define-keysym #\keypad-minus (keysym 255 173)) ; :keypad 367 | (define-keysym #\keypad-period (keysym 255 174)) ; :keypad 368 | (define-keysym #\keypad-0 (keysym 255 176)) ; :keypad 369 | (define-keysym #\keypad-1 (keysym 255 177)) ; :keypad 370 | (define-keysym #\keypad-2 (keysym 255 178)) ; :keypad 371 | (define-keysym #\keypad-3 (keysym 255 179)) ; :keypad 372 | (define-keysym #\keypad-4 (keysym 255 180)) ; :keypad 373 | (define-keysym #\keypad-5 (keysym 255 181)) ; :keypad 374 | (define-keysym #\keypad-6 (keysym 255 182)) ; :keypad 375 | (define-keysym #\keypad-7 (keysym 255 183)) ; :keypad 376 | (define-keysym #\keypad-8 (keysym 255 184)) ; :keypad 377 | (define-keysym #\keypad-9 (keysym 255 185)) ; :keypad 378 | (define-keysym #\keypad-equal (keysym 255 189)) ; :keypad 379 | (define-keysym #\f1 (keysym 255 192)) ; :function 380 | (define-keysym #\f2 (keysym 255 193)) ; :function 381 | (define-keysym #\f3 (keysym 255 194)) ; :function 382 | (define-keysym #\f4 (keysym 255 195)) ; :function 383 | (define-keysym #\network (keysym 255 214)) 384 | (define-keysym #\status (keysym 255 215)) 385 | (define-keysym #\clear-screen (keysym 255 217)) 386 | (define-keysym #\left (keysym 255 218)) 387 | (define-keysym #\middle (keysym 255 219)) 388 | (define-keysym #\right (keysym 255 220)) 389 | (define-keysym #\resume (keysym 255 221)) 390 | (define-keysym #\vt (keysym 009 233)) ; :special ;; same as #\delete 391 | ) 392 | 393 | #+ti 394 | (progn ;; Explorer specific characters 395 | (define-keysym #\Call (keysym 131)) ; :latin-1 396 | (define-keysym #\Macro (keysym 133)) ; :latin-1 397 | (define-keysym #\Quote (keysym 142)) ; :latin-1 398 | (define-keysym #\Hold-output (keysym 143)) ; :latin-1 399 | (define-keysym #\Stop-output (keysym 144)) ; :latin-1 400 | (define-keysym #\Center (keysym 156)) ; :latin-1 401 | (define-keysym #\no-break-space (keysym 160)) ; :latin-1 402 | 403 | (define-keysym #\circle-plus (keysym 13)) ; :latin-1 404 | (define-keysym #\universal-quantifier (keysym 20)) ; :latin-1 405 | (define-keysym #\existential-quantifier (keysym 21)) ; :latin-1 406 | (define-keysym #\circle-cross (keysym 22)) ; :latin-1 407 | ) 408 | 409 | -------------------------------------------------------------------------------- /debug/trace.cl: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*- 2 | 3 | ;;; 4 | ;;; TEXAS INSTRUMENTS INCORPORATED 5 | ;;; P.O. BOX 2909 6 | ;;; AUSTIN, TEXAS 78769 7 | ;;; 8 | ;;; Copyright (C) 1987 Texas Instruments Incorporated. 9 | ;;; 10 | ;;; Permission is granted to any individual or institution to use, copy, modify, 11 | ;;; and distribute this software, provided that this complete copyright and 12 | ;;; permission notice is maintained, intact, in all copies and supporting 13 | ;;; documentation. 14 | ;;; 15 | ;;; Texas Instruments Incorporated provides this software "as is" without 16 | ;;; express or implied warranty. 17 | ;;; 18 | 19 | ;; Trace works by substituting trace functions for the display-write/input functions. 20 | ;; The trace functions maintain a database of requests sent to the server in the 21 | ;; trace-history display property. This is an alist of (id . byte-vector) where 22 | ;; id is the request number for writes, :reply for replies, :event for events and 23 | ;; :error for errors. The alist is kept in reverse order (most recent first) 24 | 25 | ;; In a multiprocessing system is it very helpful to know what process wrote or 26 | ;; read certain requests. Thus I have modified the format of the trace-history 27 | ;; list. It is now an alist of: ((id . more-info) . byte-vector). 28 | ;; (more-info is a list returned by the trace-more-info function). 29 | ;; Also added the ability to suspend and resume tracing without destroying the 30 | ;; trace history. Renamed 'display-trace' to 'show-trace' to avoid confusion. 31 | ;; 7feb91 -- jdi 32 | ;; 33 | ;; Unfortunately, the trace-write-hook only runs when a display-force-output 34 | ;; is done. This means that the "process" recorded for a request is the 35 | ;; process that did the force-output, which isn't necessarily the process 36 | ;; that made the request. Sigh. 37 | ;; 5oct91 -- jdi 38 | 39 | ;;; Created 09/14/87 by LaMott G. OREN 40 | 41 | (in-package :xlib) 42 | 43 | (eval-when (load eval) 44 | (export '(trace-display 45 | suspend-display-tracing 46 | resume-display-tracing 47 | untrace-display 48 | show-trace 49 | display-trace ; for backwards compatibility 50 | describe-request 51 | describe-event 52 | describe-reply 53 | describe-error 54 | describe-trace))) 55 | 56 | (defun trace-display (display) 57 | "Start a trace on DISPLAY. 58 | If display is already being traced, this discards previous history. 59 | See show-trace and describe-trace." 60 | (declare (type display display)) 61 | (unless (getf (display-plist display) 'write-function) 62 | (bind-io-hooks display)) 63 | (setf (display-trace-history display) nil) 64 | t) 65 | 66 | (defun suspend-display-tracing (display) 67 | "Tracing is suspended, but history is not cleared." 68 | (if (getf (display-plist display) 'suspend-display-tracing) 69 | (warn "Tracing is already suspend for ~s" display) 70 | (progn 71 | (unbind-io-hooks display) 72 | (setf (getf (display-plist display) 'suspend-display-tracing) t)))) 73 | 74 | (defun resume-display-tracing (display) 75 | "Used to resume tracing after suspending" 76 | (if (getf (display-plist display) 'suspend-display-tracing) 77 | (progn 78 | (bind-io-hooks display) 79 | (remf (display-plist display) 'suspend-display-tracing)) 80 | (warn "Tracing was not suspended for ~s" display))) 81 | 82 | (defun untrace-display (display) 83 | "Stop tracing DISPLAY." 84 | (declare (type display display)) 85 | (if (not (getf (display-plist display) 'suspend-display-tracing)) 86 | (unbind-io-hooks display) 87 | (remf (display-plist display) 'suspend-display-tracing)) 88 | (setf (display-trace-history display) nil)) 89 | 90 | ;; Assumes tracing is not already on. 91 | (defun bind-io-hooks (display) 92 | (let ((write-function (display-write-function display)) 93 | (input-function (display-input-function display))) 94 | ;; Save origional write/input functions so we can untrace 95 | (setf (getf (display-plist display) 'write-function) write-function) 96 | (setf (getf (display-plist display) 'input-function) input-function) 97 | ;; Set new write/input functions that will record what's sent to the server 98 | (setf (display-write-function display) 99 | #'(lambda (vector display start end) 100 | (trace-write-hook vector display start end) 101 | (funcall write-function vector display start end))) 102 | (setf (display-input-function display) 103 | #'(lambda (display vector start end timeout) 104 | (let ((result (funcall input-function 105 | display vector start end timeout))) 106 | (unless result 107 | (trace-read-hook display vector start end)) 108 | result))))) 109 | 110 | (defun unbind-io-hooks (display) 111 | (let ((write-function (getf (display-plist display) 'write-function)) 112 | (input-function (getf (display-plist display) 'input-function))) 113 | (when write-function 114 | (setf (display-write-function display) write-function)) 115 | (when input-function 116 | (setf (display-input-function display) input-function)) 117 | (remf (display-plist display) 'write-function) 118 | (remf (display-plist display) 'input-function))) 119 | 120 | 121 | (defun byte-ref16 (vector index) 122 | #+clx-little-endian 123 | (logior (the card16 124 | (ash (the card8 (aref vector (index+ index 1))) 8)) 125 | (the card8 126 | (aref vector index))) 127 | #-clx-little-endian 128 | (logior (the card16 129 | (ash (the card8 (aref vector index)) 8)) 130 | (the card8 131 | (aref vector (index+ index 1))))) 132 | 133 | (defun byte-ref32 (a i) 134 | (declare (type buffer-bytes a) 135 | (type array-index i)) 136 | (declare (values card32)) 137 | (declare-buffun) 138 | #+clx-little-endian 139 | (the card32 140 | (logior (the card32 141 | (ash (the card8 (aref a (index+ i 3))) 24)) 142 | (the card29 143 | (ash (the card8 (aref a (index+ i 2))) 16)) 144 | (the card16 145 | (ash (the card8 (aref a (index+ i 1))) 8)) 146 | (the card8 147 | (aref a i)))) 148 | #-clx-little-endian 149 | (the card32 150 | (logior (the card32 151 | (ash (the card8 (aref a i)) 24)) 152 | (the card29 153 | (ash (the card8 (aref a (index+ i 1))) 16)) 154 | (the card16 155 | (ash (the card8 (aref a (index+ i 2))) 8)) 156 | (the card8 157 | (aref a (index+ i 3)))))) 158 | 159 | (defun trace-write-hook (vector display start end) 160 | ;; Called only by buffer-flush. Start should always be 0 161 | (unless (zerop start) 162 | (format *debug-io* "write-called with non-zero start: ~d" start)) 163 | (let* ((history (display-trace-history display)) 164 | (request-number (display-request-number display)) 165 | (last-history (car history))) 166 | ;; There may be several requests in the buffer, and the last one may be 167 | ;; incomplete. The first one may be the completion of a previous request. 168 | ;; We can detect incomplete requests by comparing the expected length of 169 | ;; the last request with the actual length. 170 | (when (and last-history (numberp (caar last-history))) 171 | (let* ((last-length (index* 4 (byte-ref16 (cdr last-history) 2))) 172 | (append-length (min (- last-length (length (cdr last-history))) 173 | (- end start)))) 174 | (when (plusp append-length) 175 | ;; Last history incomplete - append to last 176 | (setf (cdr last-history) 177 | (concatenate '(vector card8) (cdr last-history) 178 | (subseq vector start (+ start append-length)))) 179 | (index-incf start append-length)))) 180 | ;; Copy new requests into the history 181 | (do* ((new-history nil) 182 | (i start (+ i length)) 183 | request 184 | length) 185 | ((>= i end) 186 | ;; add in sequence numbers 187 | (dolist (entry new-history) 188 | (setf (caar entry) request-number) 189 | (decf request-number)) 190 | (setf (display-trace-history display) 191 | (nconc new-history history))) 192 | (setq request (aref vector i)) 193 | (setq length (index* 4 (byte-ref16 vector (+ i 2)))) 194 | (when (zerop length) 195 | (warn "Zero length in buffer") 196 | (return nil)) 197 | (push (cons (cons 0 (trace-more-info display request vector 198 | i (min (+ i length) end))) 199 | (subseq vector i (min (+ i length) end))) new-history) 200 | (when (zerop request) 201 | (warn "Zero length in buffer") 202 | (return nil))))) 203 | 204 | (defun trace-read-hook (display vector start end) 205 | ;; Reading is done with an initial length of 32 (with start = 0) 206 | ;; This may be followed by several other reads for long replies. 207 | (let* ((history (display-trace-history display)) 208 | (last-history (car history)) 209 | (length (- end start))) 210 | (when (and history (eq (caar last-history) :reply)) 211 | (let* ((last-length (index+ 32 (index* 4 (byte-ref32 (cdr last-history) 4)))) 212 | (append-length (min (- last-length (length (cdr last-history))) 213 | (- end start)))) 214 | (when (plusp append-length) 215 | (setf (cdr last-history) 216 | (concatenate '(vector card8) (cdr last-history) 217 | (subseq vector start (+ start append-length)))) 218 | (index-incf start append-length) 219 | (index-decf length append-length)))) 220 | 221 | ;; Copy new requests into the history 222 | (when (plusp length) 223 | (let ((reply-type (case (aref vector start) (0 :error) (1 :reply) 224 | (otherwise :event)))) 225 | (push (cons (cons reply-type 226 | (trace-more-info display reply-type vector start 227 | (+ start length))) 228 | (subseq vector start (+ start length))) 229 | (display-trace-history display)))))) 230 | 231 | (defun trace-more-info (display request-id vector start end) 232 | ;; Currently only returns current process. 233 | (declare (ignore display request-id vector start end)) 234 | #+allegro 235 | (list mp::*current-process*)) 236 | 237 | 238 | (defun show-trace (display &key length show-process) 239 | "Display the trace history for DISPLAY. 240 | The default is to show ALL history entries. 241 | When the LENGTH parameter is used, only the last LENGTH entries are 242 | displayed." 243 | (declare (type display display)) 244 | (dolist (hist (reverse (subseq (display-trace-history display) 245 | 0 length))) 246 | (let* ((id (caar hist)) 247 | (more-info (cdar hist)) 248 | (vector (cdr hist)) 249 | (length (length vector)) 250 | (request (aref vector 0))) 251 | (format t "~%~5d " id) 252 | (case id 253 | (:error 254 | (trace-error-print display more-info vector)) 255 | (:event 256 | (format t "~a (~d) Sequence ~d" 257 | (if (< request (length *event-key-vector*)) 258 | (aref *event-key-vector* request) 259 | "Unknown") 260 | request 261 | (byte-ref16 vector 2)) 262 | (when show-process 263 | #+allegro 264 | (format t ", Proc ~a" (mp::process-name (car more-info))))) 265 | (:reply 266 | (format t "To ~d length ~d" 267 | (byte-ref16 vector 2) length) 268 | (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4))))) 269 | (unless (= length actual-length) 270 | (format t " Should be ~d **************" actual-length))) 271 | (when show-process 272 | #+allegro 273 | (format t ", Proc ~a" (mp::process-name (car more-info))))) 274 | (otherwise 275 | (format t "~a (~d) length ~d" 276 | (request-name request) request length) 277 | (when show-process 278 | #+allegro 279 | (format t ", Proc ~a" (mp::process-name (car more-info))))))))) 280 | 281 | ;; For backwards compatibility 282 | (defun display-trace (&rest args) 283 | (apply 'show-trace args)) 284 | 285 | (defun find-trace (display type sequence &optional (number 0)) 286 | (dolist (history (display-trace-history display)) 287 | (when (and (symbolp (caar history)) 288 | (= (logandc2 (aref (cdr history) 0) 128) type) 289 | (= (byte-ref16 (cdr history) 2) sequence) 290 | (minusp (decf number))) 291 | (return (cdr history))))) 292 | 293 | (defun describe-error (display sequence) 294 | "Describe the error associated with request SEQUENCE." 295 | (let ((vector (find-trace display 0 sequence))) 296 | (if vector 297 | (progn 298 | (terpri) 299 | (trace-error-print display nil vector)) 300 | (format t "Error with sequence ~d not found." sequence)))) 301 | 302 | (defun trace-error-print (display more-info vector 303 | &optional (stream *standard-output*)) 304 | (declare (ignore more-info)) 305 | (let ((event (allocate-event))) 306 | ;; Copy into event from reply buffer 307 | (buffer-replace (reply-ibuf8 event) 308 | vector 309 | 0 310 | *replysize*) 311 | (reading-event (event) 312 | (let* ((type (read-card8 0)) 313 | (error-code (read-card8 1)) 314 | (sequence (read-card16 2)) 315 | (resource-id (read-card32 4)) 316 | (minor-code (read-card16 8)) 317 | (major-code (read-card8 10)) 318 | (current-sequence (ldb (byte 16 0) (buffer-request-number display))) 319 | (error-key 320 | (if (< error-code (length *xerror-vector*)) 321 | (aref *xerror-vector* error-code) 322 | 'unknown-error)) 323 | (params 324 | (case error-key 325 | ((colormap-error cursor-error drawable-error font-error gcontext-error 326 | id-choice-error pixmap-error window-error) 327 | (list :resource-id resource-id)) 328 | (atom-error 329 | (list :atom-id resource-id)) 330 | (value-error 331 | (list :value resource-id)) 332 | (unknown-error 333 | ;; Prevent errors when handler is a sequence 334 | (setq error-code 0) 335 | (list :error-code error-code))))) 336 | type 337 | (let ((condition 338 | (apply #+lispm #'si:make-condition 339 | #+allegro #'make-condition 340 | #-(or lispm allegro) #'make-condition 341 | error-key 342 | :asynchronous :unknown 343 | :error-key error-key 344 | :display display 345 | :major major-code 346 | :minor minor-code 347 | :sequence sequence 348 | :current-sequence current-sequence 349 | params))) 350 | (princ condition stream) 351 | (deallocate-event event) 352 | condition))))) 353 | 354 | (defun describe-request (display sequence) 355 | "Describe the request with sequence number SEQUENCE" 356 | #+ti (si:load-if "clx:debug;describe") 357 | (let ((request (assoc sequence (display-trace-history display) 358 | :test #'(lambda (item key) 359 | (eql item (car key)))))) 360 | (if (null request) 361 | (format t "~%Request number ~d not found in trace history" sequence) 362 | (let* ((vector (cdr request)) 363 | (len (length vector)) 364 | (hist (make-reply-buffer len))) 365 | (buffer-replace (reply-ibuf8 hist) vector 0 len) 366 | (print-history-description hist))))) 367 | 368 | (defun describe-reply (display sequence) 369 | "Print the reply to request SEQUENCE. 370 | (The current implementation doesn't print very pretty)" 371 | (let ((vector (find-trace display 1 sequence)) 372 | (*print-array* t)) 373 | (if vector 374 | (print vector) 375 | (format t "~%Reply not found")))) 376 | 377 | (defun event-number (name) 378 | (if (integerp name) 379 | (let ((name (logandc2 name 128))) 380 | (if (typep name '(integer 0 63)) 381 | (aref *event-key-vector* name)) 382 | name) 383 | (position (string name) *event-key-vector* :test #'equalp :key #'string))) 384 | 385 | (defun describe-event (display name sequence &optional (number 0)) 386 | "Describe the event with event-name NAME and sequence number SEQUENCE. 387 | If there is more than one event, return NUMBER in the sequence." 388 | (declare (type display display) 389 | (type (or stringable (integer 0 63)) name) 390 | (integer sequence)) 391 | (let* ((event (event-number name)) 392 | (vector (and event (find-trace display event sequence number)))) 393 | (if (not event) 394 | (format t "~%~s isn't an event name" name) 395 | (if (not vector) 396 | (if (and (plusp number) (setq vector (find-trace display event sequence 0))) 397 | (do ((i 1 (1+ i)) 398 | (last-vector)) 399 | (nil) 400 | (if (setq vector (find-trace display event sequence i)) 401 | (setq last-vector vector) 402 | (progn 403 | (format t "~%Event number ~d not found, last event was ~d" 404 | number (1- i)) 405 | (return (trace-event-print display last-vector))))) 406 | (format t "~%Event ~s not found" 407 | (aref *event-key-vector* event))) 408 | (trace-event-print display vector))))) 409 | 410 | (defun trace-event-print (display vector) 411 | (let* ((event (allocate-event)) 412 | (event-code (ldb (byte 7 0) (aref vector 0))) 413 | (event-decoder (aref *event-handler-vector* event-code))) 414 | ;; Copy into event from reply buffer 415 | (setf (event-code event) event-code) 416 | (buffer-replace (reply-ibuf8 event) 417 | vector 418 | 0 419 | *replysize*) 420 | (prog1 (funcall event-decoder display event 421 | #'(lambda (&rest args &key send-event-p &allow-other-keys) 422 | (setq args (copy-list args)) 423 | (remf args :display) 424 | (remf args :event-code) 425 | (unless send-event-p (remf args :send-event-p)) 426 | args)) 427 | (deallocate-event event)))) 428 | 429 | (defun describe-trace (display &optional length) 430 | "Display the trace history for DISPLAY. 431 | The default is to show ALL history entries. 432 | When the LENGTH parameter is used, only the last LENGTH entries are 433 | displayed." 434 | (declare (type display display)) 435 | #+ti (si:load-if "clx:debug;describe") 436 | (dolist (hist (reverse (subseq (display-trace-history display) 437 | 0 length))) 438 | (let* ((id (car hist)) 439 | (vector (cdr hist)) 440 | (length (length vector))) 441 | (format t "~%~5d " id) 442 | (case id 443 | (:error 444 | (trace-error-print display nil vector)) 445 | (:event 446 | (let ((event (trace-event-print display vector))) 447 | (when event (format t "from ~d ~{ ~s~}" 448 | (byte-ref16 vector 2) event)))) 449 | (:reply 450 | (format t "To ~d length ~d" 451 | (byte-ref16 vector 2) length) 452 | (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4))))) 453 | (unless (= length actual-length) 454 | (format t " Should be ~d **************" actual-length))) 455 | (let ((*print-array* t) 456 | (*print-base* 16.)) 457 | (princ " ") 458 | (princ vector))) 459 | (otherwise 460 | (let* ((len (length vector)) 461 | (hist (make-reply-buffer len))) 462 | (buffer-replace (reply-ibuf8 hist) vector 0 len) 463 | (print-history-description hist))))))) 464 | 465 | ;; End of file 466 | --------------------------------------------------------------------------------