From 265f17a2296be4edd081b0392383e76da8165820 Mon Sep 17 00:00:00 2001 From: colin <colin> Date: Tue, 17 Oct 1995 05:04:21 +0000 Subject: [PATCH] see ChangeLog.n for Mon Oct 16 21:58:05 PDT 1995 --- .cvsignore | 2 +- ChangeLog.n | 164 ++++++++ Makefile.cobjs | 4 +- Makefile.generic | 8 +- Makefile.sun4-svr4 | 14 +- clim/accept-values.lisp | 9 +- clim/command.lisp | 61 +-- clim/db-stream.lisp | 96 ++--- clim/frames.lisp | 13 +- clim/gadget-output.lisp | 5 +- clim/input-protocol.lisp | 9 +- clim/interactive-defs.lisp | 6 +- clim/menus.lisp | 74 ++-- clim/tracking-pointer.lisp | 272 ++++++------ clim/translators.lisp | 32 +- demo/color-editor.lisp | 127 +++--- postscript/postscript-medium.lisp | 49 ++- postscript/postscript-port.lisp | 124 +++--- silica/db-border.lisp | 24 +- silica/db-layout.lisp | 110 +++-- silica/db-scroll.lisp | 69 ++-- silica/event.lisp | 50 +-- silica/gadgets.lisp | 176 ++++---- silica/port.lisp | 18 +- silica/sheet.lisp | 34 +- test/test-suite.lisp | 4 +- tk-silica/last.lisp | 8 +- tk-silica/xm-frames.lisp | 53 ++- tk-silica/xm-gadgets.lisp | 362 +++++++++++----- tk-silica/xm-silica.lisp | 22 +- tk-silica/xt-gadgets.lisp | 59 ++- tk-silica/xt-graphics.lisp | 67 ++- tk-silica/xt-silica.lisp | 116 ++++-- tk/callbacks.lisp | 81 ++-- tk/ol-init.lisp | 4 +- tk/resources.lisp | 54 +-- tk/xlib.lisp | 8 +- tk/xm-defs.lisp | 20 +- tk/xm-funs.lisp | 21 +- tk/xm-init.lisp | 4 +- tk/xt-defs.lisp | 10 +- tk/xt-funs.lisp | 52 ++- utils/base-designs.lisp | 18 +- utils/designs.lisp | 31 +- utils/packages.lisp | 6 +- xlib/xlib-funs.lisp | 663 +++++++++++++++--------------- 46 files changed, 1925 insertions(+), 1288 deletions(-) diff --git a/.cvsignore b/.cvsignore index 6d2d1b38..a2bc171b 100755 --- a/.cvsignore +++ b/.cvsignore @@ -12,4 +12,4 @@ test-suite-reportol.lisp test-suite-reportxm.lisp hpgl.output foo.diffs -update.out +update.log diff --git a/ChangeLog.n b/ChangeLog.n index d93578b4..7844eca3 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -1,3 +1,167 @@ +************************************************************* +Mon Oct 16 21:58:05 PDT 1995 Colin Meldrum (colin@vapor) + +Makefile.cobjs fix library path for ol version + +Makefile.generic added rule clean-notes + fixed library path for make train rule + +Makefile.sun4-svr4 defs for multiple versions of Motif libraries + +clim/accept-values.lisp fixed bug positioning own-window t dialogs + improved appearance of dialogs produced with + display-invalid-queries + fix typo in display-invalid-queries + +clim/command.lisp added support for user defined accelerator-text in + add-menu-item-to-command-table + +clim/db-stream.lisp added support for scroller-pane options to + make-clim-stream-pane + +clim/frames.lisp reinstated 0.9 fudge factor in limit-size-to-graft + to workaround bug in openwindows window managers + fixed find-application-frame to create new frame when + no existing frame found + changed enable-frame to use position-sheet-carefully + rather than move-sheet - allows correct positioning + of non avv popup-frames. + +clim/gadget-output.lisp fixed option-pane to activate/de-activate correctly + +clim/input-protocol.lisp + changed repaint-sheet to not require a viewport so + that cursor redraw works correctly in panes without + scroll-bars + +clim/interactive-defs.lisp + fixed bug in read-token's handling of activation + and delimiter gestures + +clim/menus.lisp fixed bug in open-window-stream by moving :left and + :top args into call to make-application-frame + +clim/tracking-pointer.lisp + fixed bug with tracking-pointer over multiple panes + when mouse button grabbed + +clim/translators.lisp removed restriction on priorities to be >0 in + define-presentation-trasnlator-1 + +climtoys/calendar.lisp removed com-print3 + +demo/color-editor.lisp include tick-marks on sliders + +postscript/postscript-medium.lisp + added dummy maybe-set-color method to hack + compose-in inks for postscript port + fixed prolog to do calculate the correct + bounding-rectangle for encapsulted postscript + +silica/db-border.lisp changed region painted in repaint-boder-pane to + workaround bug with repaint drawing over cursor + +silica/db-layout.lisp tentative compose-space :around method for + client-overridability-mixin + +silica/db-scroll.lisp added support for :vertical-page-scroll-amount and + :horizontal-page-scroll-amount + +silica/gadgets.lisp added :decimal-places 0 initarg for slider + added echo-character initarg to text-fields for + password entry support + support in compute-list-pane-selected-items for + auto scrolling of list-pane to show selected item + support for armed/disarmed events + +silica/port.lisp, tk/xm-init.lisp tk/ol-init.lisp + new *restart-actions* syntax + +silica/sheet.lisp new gf port-remove-all-pointer-grabs (to fix + tracking pointer multiple window bug) + + +test/test-suite.lisp fixed title of region-intersects-region-p test + +tk/callbacks.lisp support for text-field echo-character + +tk/resources.lisp support for auto-scrolling list-pane + added top-item-position resource + +tk/xlib.lisp fix bug with non-standard bits-per-pixel image + format in image initialize-instance :after method + +tk/xm-defs.lisp support for text-field echo-character + +tk/xm-funs.lisp support for setting scale value + support for changing widget background color and + associated shadows + +tk/xt-defs.lisp misc typdef fixes + +tk/xt-funs.lisp added xt_ungrab_button + fixed init_clim_gc_cursor_stuff to be :call-direct t + +tk-silica/last.lisp changed patch load pathname to be ";update-clim;" + +tk-silica/xm-frames.lisp + replaced frobulate-menubars with more general + frobulate-mirrors to fix bug with gadgets coming up + wrong size + support for user-defined accelerator-text + fixed bug with shifted accelerators + +tk-silica/xm-gadgets.lisp + added armed/disarmed callbacks + support for quantized slider values + support for slider tick marks + support for min/max label + variable page-increment for scroll-bars + support for text-field echo-character + support for auto-scrolling list-pane + added motif specific port-set-pane-background to + deal with shadow colors + handle :default keyword arg frame-manager-select-file + +tk-silica/xm-silica.lisp + added note-sheet-degrafter method on + clim-stream-sheets to destroy any cursor widget + +tk-silica/xt-gadgets.lisp + redone find-widget-resouce-initargs-for-sheet + support for variable page-increment for scroll-bars + simplified get-accelerator-text + +tk-silica/xt-graphics.lisp + added palette slot to xt-medium + medium-palette only goes to the sheet the first time + new decode-ink-1 method on composite-in inks + decode-ink-opacity now takes an optional color arg + fixes bug in decode-layered-color-set for layers + which are not exact powers of 2 + +tk-silica/xt-silica.lisp + support to inhibit use of scalable fonts. + new queue-armed-event and queue-disarmed-event + explicitly switch off program-specified position + hints in enable-mirror on top-level-sheet to make + OpenWindows cascading work properly + added new method port-remove-all-pointer-grabs + +utils/base-designs.lisp coerce designs in make-pattern to be a + simple-vector + +utils/designs.lisp *use-closest-color* can now be :warn + check for recursive errors when no closest color + available + +utils/packages.lisp armed-gadget-event + disarmed-gadget-event + port-remove-all-pointer-grabs + text-field-echo-character + +xlib/xlib-funs.lisp added defforeign for _XGetBitsPerPixel + ************************************************************* 4.3.devel.4 (aka 4.3.alpha.0) diff --git a/Makefile.cobjs b/Makefile.cobjs index 18a97716..9125ac8b 100644 --- a/Makefile.cobjs +++ b/Makefile.cobjs @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.cobjs,v 1.8 1994/12/04 23:56:22 colin Exp $ +# $fiHeader: Makefile.cobjs,v 1.9 1995/05/17 19:46:58 colin Exp $ # # Makefile.cobj for CLIM 2.0 # @@ -55,7 +55,7 @@ climxm.so: xlibsupport.o xtsupport.o xmsupport.o $(IMPORTS) $(TKLIB) $(XTLIB) $(XLIB) $(MOTIFXTRAS)) climol.so: xlibsupport.o xtsupport.o olsupport.o - (eval '$(SET_LIBRARY_PATH)' ; + (eval '$(SET_LIBRARY_PATH)' ; \ $(MAKE_SHARED) $(SHAREFLAGS) -o climol.so \ xlibsupport.o xtsupport.o olsupport.o \ $(IMPORTS) $(TKLIB) $(XTLIB) $(XLIB)) diff --git a/Makefile.generic b/Makefile.generic index aa0b6c08..7f31f4f6 100644 --- a/Makefile.generic +++ b/Makefile.generic @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.generic,v 1.28 1994/12/18 06:44:37 duane Exp $ +# $fiHeader: Makefile.generic,v 1.30 1995/06/21 21:24:08 georgej Exp $ # # Makefile.generic for CLIM 2.0 # @@ -125,6 +125,7 @@ clim: FORCE $(PRODUCT-GENERIC-OBJS) $(PRODUCT-TK-OBJS) # Training train: FORCE + (eval '$(SET_LIBRARY_PATH)' ; \ $(ECHO) " \ (progn \ (load \"misc/train.lisp\") \ @@ -132,7 +133,7 @@ train: FORCE :benchmarkp $(TRAIN_BM) :profilep $(TRAIN_PROFILEP) \ :compile $(TRAIN_COMPILE) :psview $(PSVIEW) \ :hpglview $(HPGLVIEW)))" \ - | $(CLIM) $(CLOPTS) + | $(CLIM) $(CLOPTS)) echo $(SYSTEM) trained!!!! # the following two rules are used by make-dist so that we don't have @@ -189,6 +190,9 @@ clean: stub-motif.c stub-olit.c stub-xt.c stub-x.c rm -f *.z *.Z *.gz *.ilt *.out +clean-notes: + cd notes ; find . -name '*.lisp' -print | xargs rm -f + tags: $(TAGS) $(ALL_SRC) diff --git a/Makefile.sun4-svr4 b/Makefile.sun4-svr4 index c287b28b..66e92acf 100644 --- a/Makefile.sun4-svr4 +++ b/Makefile.sun4-svr4 @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.sun4-svr4,v 1.6 1995/05/15 07:17:43 duane Exp $ +# $fiHeader: Makefile.sun4-svr4,v 1.7 1995/05/17 19:47:15 colin Exp $ # # Makefile.sun4-svr4 for CLIM 2.0 # @@ -7,14 +7,20 @@ include Makefile.defs Makefile=Makefile.sun4-svr4 -XINCLUDES=-I/usr/openwin/include -I/usr/dt/include +XINCLUDES= \ + -I/usr/openwin/include -I/usr/dt/include +# -I/net/sole/opt/ICS/Motif1.2.4/usr/include +# -I/net/vapor/3rd/motif-1.2.2-sol2/ICS/Motif/usr/include TKLIB=-lXm XTLIB=-lXt XLIB=-lX11 -SET_LIBRARY_PATH= \ - LD_LIBRARY_PATH=/usr/dt/lib:/usr/openwin/lib:/usr/lib; export LD_LIBRARY_PATH +SET_LIBRARY_PATH= LD_LIBRARY_PATH= \ + /usr/dt/lib:/usr/openwin/lib:/usr/lib; \ +# /net/sole/opt/ICS/Motif1.2.4/usr/lib:/usr/lib; \ +# /net/vapor/3rd/motif-1.2.2-sol2/ICS/Motif/usr/lib:/usr/lib; \ + export LD_LIBRARY_PATH PRODUCT-TK-OBJS= $(STATIC-XM-OBJS) $(SHARED-XM-OBJS) diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 0ee58be3..64ad585a 100644 --- a/clim/accept-values.lisp +++ b/clim/accept-values.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: accept-values.lisp,v 1.75 1994/12/04 23:57:18 colin Exp $ +;; $fiHeader: accept-values.lisp,v 1.76 1995/05/17 19:47:38 colin Exp $ (in-package :clim-internals) @@ -377,6 +377,7 @@ :own-window-properties (list x-position y-position width height right-margin bottom-margin) + :left x-position :right y-position :initially-select-query-identifier (and initially-select-query-identifier (cons initially-select-query-identifier modify-initial-query)) @@ -1004,7 +1005,7 @@ (defmethod display-invalid-queries ((frame standard-application-frame) stream query-info) (declare (ignore stream)) (notify-user frame - (format nil "The following fields are not valid:~{ ~{~A~:[~;~:* : ~A~]~}~}" + (format nil "The following fields are not valid:~:{~%~4T~A~@[: ~A~]~}" (mapcar #'(lambda (query-stuff) (destructuring-bind (query id condition) query-stuff (declare (ignore query)) @@ -1018,8 +1019,8 @@ (and (not (eq condition t)) condition)))) query-info)) :title "Invalid Fields" - :style :error : - exit-boxes '(:exit))) + :style :error + :exit-boxes '(:exit))) (defmethod display-invalid-queries ((frame accept-values-own-window) stream queries) (display-invalid-queries (frame-calling-frame frame) stream queries)) diff --git a/clim/command.lisp b/clim/command.lisp index 9e1d5d6f..22841ba0 100644 --- a/clim/command.lisp +++ b/clim/command.lisp @@ -1,6 +1,6 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: command.lisp,v 1.27 1994/12/04 23:57:24 colin Exp $ +;; $fiHeader: command.lisp,v 1.28 1995/05/17 19:47:42 colin Exp $ (in-package :clim-internals) @@ -49,7 +49,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 ;; in the form (MENU-NAME KEYSTROKE COMMAND-MENU-ITEM), where the menu item is of the ;; form (TYPE VALUE . OPTIONS). MENU-TICK is incremented when MENU changes. ;; TRANSLATORS is the set of presentation translators for this command table. -(defclass standard-command-table +(defclass standard-command-table (command-table) ((name :reader command-table-name :initarg :name) @@ -73,7 +73,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (print-unreadable-object (command-table stream :type t :identity t) (write (command-table-name command-table) :stream stream :escape nil))) -(defmethod (setf command-table-inherit-from) +(defmethod (setf command-table-inherit-from) (new-inherit-from (command-table standard-command-table)) (with-slots (inherit-from completion-alist translators-cache) command-table (unless (eq new-inherit-from inherit-from) @@ -106,7 +106,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 nil)))) (t (error "~S is not a symbol or command table")))) - + (defun make-command-table (name &key inherit-from menu inherit-menu (errorp t)) (check-type name symbol) @@ -140,12 +140,12 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (dovector (element menu) (destructuring-bind (string keystroke (type value &rest options)) element (when (case inherit-menu - (:menu (setq keystroke nil) + (:menu (setq keystroke nil) t) - (:keystrokes (setq string nil) + (:keystrokes (setq string nil) keystroke) (otherwise t)) - (apply #'add-menu-item-to-command-table + (apply #'add-menu-item-to-command-table command-table string type value :keystroke keystroke :errorp nil options)))))))) @@ -167,8 +167,8 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 #+Genera (declare (zwei:indentation 1 1)) (setf (compile-time-property name 'command-table-name) t) `(define-group ,name define-command-table - (define-command-table-1 ',name - :inherit-from ',inherit-from + (define-command-table-1 ',name + :inherit-from ',inherit-from ,@(and menu-p `(:menu ',menu)) :inherit-menu ,inherit-menu))) @@ -198,7 +198,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (setf (slot-value old-command-table 'keystrokes) nil) old-command-table) (t - (make-command-table name :inherit-from inherit-from + (make-command-table name :inherit-from inherit-from :menu menu :inherit-menu inherit-menu))))) ;; CLIM's general "user" command table @@ -308,7 +308,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (dolist (comtab (command-table-inherit-from command-table)) (do-command-table-inheritance-1 function (find-command-table comtab)))) -(defmethod command-present-in-command-table-p +(defmethod command-present-in-command-table-p (command-name (command-table standard-command-table)) (gethash command-name (slot-value command-table 'commands))) @@ -418,8 +418,8 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (and s1 s2 (string-equal s1 s2))) (defun add-menu-item-to-command-table (command-table string type value - &key documentation (after ':end) - keystroke mnemonic + &key documentation (after ':end) + keystroke mnemonic accelerator-text text-style button-type (errorp t)) (check-type string (or string null)) (check-type type (member :command :function :menu :divider)) @@ -449,16 +449,17 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (when (and n-required (not (zerop n-required)) (< n-supplied n-required)) - (setq value (append value + (setq value (append value (make-list (- n-required n-supplied) :initial-element *unsupplied-argument-marker*)))))) (with-slots (menu menu-tick commands keystrokes) command-table (incf menu-tick) (setq keystrokes nil) - (let* ((item `(,type ,value + (let* ((item `(,type ,value ,@(and documentation `(:documentation ,documentation)) ,@(and text-style `(:text-style ,text-style)) ,@(and mnemonic `(:mnemonic ,mnemonic)) + ,@(and accelerator-text `(:accelerator-text ,accelerator-text)) ,@(and button-type `(:button-type ,button-type)))) ;; Entries are of the form (MENU-NAME KEYSTROKE MENU-ITEM) (entry (list string keystroke item))) @@ -584,7 +585,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (defun display-command-table-menu (command-table stream &key max-width max-height n-rows n-columns - x-spacing y-spacing + x-spacing y-spacing (cell-align-x ':left) (cell-align-y ':top) (initial-spacing t) (row-wise nil) move-cursor) (unless (or max-width max-height) @@ -605,7 +606,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (cond ((eq (command-menu-item-type (third element)) :divider) (typecase (first element) (string - (let ((text-style + (let ((text-style (getf (command-menu-item-options (third element)) :text-style))) (with-text-style (stream text-style) (formatting-cell (stream :align-x cell-align-x @@ -619,7 +620,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (formatting-cell (stream :align-x cell-align-x :align-y :center) (with-local-coordinates (stream) - (draw-line* stream 0 0 width 0 + (draw-line* stream 0 0 width 0 :line-thickness thickness :ink ink))))))) ((first element) (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y) @@ -683,7 +684,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (cond ((eq (command-menu-item-type (third item)) :divider) (typecase (first item) (string - (let ((text-style + (let ((text-style (getf (command-menu-item-options (third item)) :text-style))) (with-text-style (stream text-style) (formatting-cell (stream) @@ -696,7 +697,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (formatting-cell (stream :align-x :left :align-y :center) (with-local-coordinates (stream) - (draw-line* stream 0 0 width 0 + (draw-line* stream 0 0 width 0 :line-thickness thickness :ink ink))))))) ((first item) (formatting-cell (stream) @@ -707,7 +708,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (present item 'command-menu-element :stream stream))))))) nil) -(defun extract-command-menu-item-value (menu-item gesture +(defun extract-command-menu-item-value (menu-item gesture &optional (numeric-argument *numeric-argument*)) (let ((type (command-menu-item-type menu-item)) (value (command-menu-item-value menu-item))) @@ -767,7 +768,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (apply function entry))) (slot-value (find-command-table command-table) 'menu))) -(defun find-keystroke-item (keystroke command-table +(defun find-keystroke-item (keystroke command-table &key (test #'keyboard-event-matches-gesture-name-p) (errorp t)) (declare (values menu-item command-table)) (let* ((command-table (find-command-table command-table)) @@ -786,7 +787,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 :format-string "Keystroke ~S has no menu item present in ~S" :format-args (list keystroke command-table)))) -(defun lookup-keystroke-item (keystroke command-table +(defun lookup-keystroke-item (keystroke command-table &key (test #'keyboard-event-matches-gesture-name-p)) (declare (values menu-item command-table)) (labels ((map-menu (command-table) @@ -816,7 +817,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (let ((item (lookup-keystroke-item keystroke command-table :test test))) (when item (let* ((type (command-menu-item-type item)) - (command + (command (and (or (eq type ':command) (eq type ':function)) (extract-command-menu-item-value item t numeric-argument)))) @@ -1031,7 +1032,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (push `(and ,(cadr l) '(,keyword)) conditional-keywords)) (:documentation (push `(,keyword ,(second l)) keyword-documentation)))) - (when default + (when default (push default keyword-defaults)) (unless when (push keyword constant-keywords)) @@ -1040,7 +1041,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 `(flet ((read-keyword-value (keyword) (ecase keyword ,@clauses))) - (process-keyword-args + (process-keyword-args parsing-stream ,(if conditional-keywords `(append ,@conditional-keywords ',constant-keywords) `',constant-keywords) @@ -1198,7 +1199,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 command-line-name))) (n-required (or (position '&key arguments) (length arguments)))) (setf (compile-time-property command-name 'command-name) t) - `(define-group ,command-name define-command + `(define-group ,command-name define-command ,parser-function (defun ,command-name ,(deduce-body-arglist arguments) ,@body) @@ -1213,7 +1214,7 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (defun ensure-command-in-command-table (command-name command-table &key name menu keystroke) - + (when menu (let ((menu-options (and (consp menu) (cdr menu))) (menu-name (if (consp menu) (car menu) menu))) @@ -1235,10 +1236,10 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10 (t (setf (getf menu-options :after) (first (aref menu-vector (1- position))) menu (cons menu-name menu-options))))))))) - + (remove-command-from-command-table command-name command-table :errorp nil) - + (add-command-to-command-table command-name command-table :name name :menu menu diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index a68acc05..103bd142 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-stream.lisp,v 1.60 1994/12/04 23:57:29 colin Exp $ +;; $fiHeader: db-stream.lisp,v 1.61 1995/05/17 19:47:47 colin Exp $ (in-package :clim-internals) @@ -13,7 +13,7 @@ ;;--- How to keep PANE-BACKGROUND/FOREGROUND in sync with the medium? ;;--- I'm not convinced that including WINDOW-STREAM here is right... -(defclass clim-stream-sheet +(defclass clim-stream-sheet (window-stream ;includes output recording sheet-permanently-enabled-mixin sheet-mute-input-mixin @@ -23,18 +23,18 @@ permanent-medium-sheet-output-mixin basic-pane) ((input-editor-stream :initform nil :accessor stream-input-editor-stream)) - (:default-initargs - :medium t + (:default-initargs + :medium t :transformation +identity-transformation+)) (defmethod stream-input-editor-stream ((stream sheet)) nil) (defmethod (setf stream-input-editor-stream) (value (stream sheet)) value) -(defmethod stream-input-editor-stream ((stream standard-encapsulating-stream)) +(defmethod stream-input-editor-stream ((stream standard-encapsulating-stream)) (stream-input-editor-stream (encapsulating-stream-stream stream))) -(defmethod (setf stream-input-editor-stream) (value (stream standard-encapsulating-stream)) +(defmethod (setf stream-input-editor-stream) (value (stream standard-encapsulating-stream)) (setf (stream-input-editor-stream (encapsulating-stream-stream stream)) value)) (defun maybe-redraw-input-editor-stream (stream region) @@ -119,12 +119,12 @@ (defclass clim-stream-pane (clim-stream-sheet) ((incremental-redisplay-p :initarg :incremental-redisplay :initform nil) - (display-function + (display-function :reader pane-display-function :initarg :display-function :initform nil) (display-time :reader pane-display-time - :initarg :display-time :initform :command-loop + :initarg :display-time :initform :command-loop :type (member nil :command-loop :no-clear t)))) @@ -137,19 +137,19 @@ (with-slots (display-time) pane (ecase display-time ((t) - (setq display-time nil) + (setq display-time nil) (values t t)) ((nil) (values nil nil)) (:command-loop (values t t)) - (:no-clear + (:no-clear (values t nil))))) -(defmethod pane-needs-redisplay ((pane basic-pane)) +(defmethod pane-needs-redisplay ((pane basic-pane)) (values nil nil)) -(defmethod (setf pane-needs-redisplay) (value (pane basic-pane)) +(defmethod (setf pane-needs-redisplay) (value (pane basic-pane)) value) ;;--- Although the unit options are mostly applicable here I guess @@ -162,7 +162,7 @@ (unless vars (setq vars '(sr-width sr-min-width sr-max-width sr-height sr-min-height sr-max-height))) `(multiple-value-bind ,vars - (space-requirement-components ,sr) + (space-requirement-components ,sr) (macrolet ((do-with-space-req-components (operator var vars &body body) `(,operator ,@(mapcar #'(lambda (a-var) @@ -180,13 +180,13 @@ (compute-space-for-clim-stream-pane pane (call-next-method) width height)) (defun compute-space-for-clim-stream-pane (pane sr width height) - (labels + (labels ((process-compute-space-requirements () (with-space-requirement (sr) (when (do-with-space-req-components or - sr-component + sr-component (sr-width sr-min-width sr-max-width - sr-height sr-min-height sr-max-height) + sr-height sr-min-height sr-max-height) (eq sr-component :compute)) (multiple-value-bind (width height) (let ((record @@ -196,9 +196,9 @@ history (let ((*sizing-application-frame* t)) (with-output-to-output-record (pane) - (funcall + (funcall (if (slot-value pane 'incremental-redisplay-p) - #'invoke-pane-redisplay-function + #'invoke-pane-redisplay-function #'invoke-pane-display-function) (pane-frame pane) pane ;;--- Are all pane display functions prepared to @@ -213,19 +213,19 @@ (flet ((process-computes (size preferred min max) (values - (if (eq preferred :compute) + (if (eq preferred :compute) (let ((size size)) (when (numberp min) (maxf size min)) (when (numberp max) (minf size max)) size) - preferred) + preferred) (if (eq min :compute) size min) (if (eq max :compute) size max)))) (multiple-value-setq (sr-width sr-min-width sr-max-width) (process-computes width sr-width sr-min-width sr-max-width)) (multiple-value-setq (sr-height sr-min-height sr-max-height) (process-computes height sr-height sr-min-height sr-max-height))) - + #+ignore (do-with-space-req-components progn sr-component (sr-width sr-min-width sr-max-width) @@ -241,9 +241,9 @@ (with-space-requirement (sr) (let ((changed nil)) (do-with-space-req-components progn - sr-component + sr-component (sr-width sr-min-width sr-max-width - sr-height sr-min-height sr-max-height) + sr-height sr-min-height sr-max-height) (when (unit-space-requirement-p sr-component) (setq sr-component (process-unit-space-requirement pane sr-component) changed t))) @@ -254,9 +254,9 @@ (unless (and (numberp sr-width) (numberp sr-height) (do-with-space-req-components and - sr-component + sr-component (sr-min-width sr-max-width - sr-min-height sr-max-height) + sr-min-height sr-max-height) (or (numberp sr-component) (relative-space-requirement-p sr-component)))) (error "Illegal space requirement ~S" sr)) @@ -337,7 +337,7 @@ (setf (sheet-transformation pane) xform))))) (defmethod pane-stream ((pane clim-stream-pane)) - (unless (port pane) + (unless (port pane) (error "Can't call ~S on ~S until it's been grafted!" 'pane-stream pane)) pane) @@ -348,8 +348,8 @@ ;; available viewport space. ;; well this method breaks accepting-values :own-window t by ignoring -;; explicit :width/:height so I'm going to ignore it and see what else -;; breaks instead. Then perhaps we can make a fix which satisfies both +;; explicit :width/:height so I'm going to ignore it and see what else +;; breaks instead. Then perhaps we can make a fix which satisfies both ;; constraints. (cim 2/13/95) #+ignore @@ -375,7 +375,7 @@ (defclass pointer-documentation-pane (clim-stream-pane) ()) -(defclass title-pane (clim-stream-pane) +(defclass title-pane (clim-stream-pane) ((display-string :initform nil :initarg :display-string))) (defclass command-menu-pane (clim-stream-pane) ()) @@ -383,9 +383,9 @@ (defun make-clim-stream-pane-1 (framem frame &rest options &key (type 'clim-stream-pane) - label + label (label-alignment #+Genera :bottom #-Genera :top) - (scroll-bars ':vertical) + (scroll-bars :vertical) (borders t) (display-after-commands nil dac-p) background @@ -405,30 +405,34 @@ (pane stream)) (when scroll-bars - (setq pane (make-pane 'scroller-pane - :scroll-bars scroll-bars - :contents pane - :name name - :background background))) + (let ((scroller-pane-options + (if (consp scroll-bars) + `(:scroll-bars ,@scroll-bars) + `(:scroll-bars ,scroll-bars)))) + (setq pane (apply #'make-pane 'scroller-pane + :contents pane + :name name + :background background + scroller-pane-options)))) (when label (let ((label (if (stringp label) - (make-pane 'label-pane + (make-pane 'label-pane :label label :max-width +fill+ :background background) - (apply #'make-pane 'label-pane + (apply #'make-pane 'label-pane :label (first label) - :max-width +fill+ + :max-width +fill+ :background background (rest label))))) (setq pane (make-pane 'vbox-pane - :contents + :contents (ecase label-alignment (:bottom (list pane label)) (:top (list label pane))) :background background)))) - (when borders + (when borders (setq pane (make-pane 'outlined-pane :name name @@ -490,7 +494,7 @@ (when text-record (replay text-record stream))) (let ((presentation (highlighted-presentation stream nil))) (when presentation - (highlight-presentation + (highlight-presentation presentation (presentation-type presentation) stream :highlight)))) (defmethod window-refresh :around ((stream clim-stream-sheet)) @@ -520,7 +524,7 @@ (defmethod window-visibility ((stream clim-stream-sheet)) (let ((frame (pane-frame stream))) - (and (if frame + (and (if frame (eq (frame-state frame) :enabled) (sheet-enabled-p stream)) (mirror-visible-p (port stream) stream)))) @@ -659,7 +663,7 @@ (let ((width (- stream-width (abs delta-x))) (height (- stream-height (abs delta-y))) (transform (sheet-transformation window))) - (multiple-value-call #'copy-area + (multiple-value-call #'copy-area window (untransform-position transform from-x from-y) (untransform-distance transform width height) @@ -672,7 +676,7 @@ (multiple-value-bind (valid-p left top right bottom) (ltrb-overlaps-ltrb-p old-left old-top old-right old-bottom new-left new-top new-right new-bottom) - (when valid-p + (when valid-p (with-sheet-medium (medium window) (medium-clear-area medium left top right bottom) (repaint-sheet window (make-bounding-rectangle left top right bottom)))))) @@ -691,7 +695,7 @@ (:selector :visible-cursorpos-limits)) #+Genera -(defmethod stream-compatible-visible-cursorpos-limits +(defmethod stream-compatible-visible-cursorpos-limits ((window clim-stream-sheet) &optional (unit ':pixel)) (with-bounding-rectangle* (left top right bottom) (window-viewport window) (ecase unit diff --git a/clim/frames.lisp b/clim/frames.lisp index d387f590..f76ed290 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: frames.lisp,v 1.77 1994/12/04 23:57:38 colin Exp $ +;; $fiHeader: frames.lisp,v 1.78 1995/05/17 19:47:51 colin Exp $ (in-package :clim-internals) @@ -404,7 +404,11 @@ `(multiple-value-bind (graft-width graft-height) (bounding-rectangle-size ,graft) ;;--- This fudge factor stuff looks dubious --SWM - (let ((fudge-factor #+ignore 0.9 #-ignore 1)) + ;; using 1 works ok by limiting the size of the top level window + ;; (not the top level window + frame). As you can't know (I don't + ;; think) what the particular wm frame size will be using a hard + ;; wired fudge factor of .9 seems ok to me (cim 9/4/95) + (let ((fudge-factor #-ignore 0.9 #+ignore 1)) (minf-or ,width (* graft-width fudge-factor)) (minf-or ,height (* graft-height fudge-factor))))) @@ -565,7 +569,8 @@ (when (typep frame frame-class) (return-from find-frame frame))) :frame-manager frame-manager - :port port))))) + :port port) + nil)))) (when (and create (null frame)) (with-keywords-removed (initargs initargs '(:create :activate :own-process)) (setq frame (apply #'make-application-frame frame-name initargs)))) @@ -601,7 +606,7 @@ (frame-top-level-sheet frame)))) (layout-frame frame width height) (when (and left top) - (move-sheet (frame-top-level-sheet frame) left top)) + (position-sheet-carefully (frame-top-level-sheet frame) left top)) (note-frame-enabled (frame-manager frame) frame))) (:shrunk (note-frame-deiconified (frame-manager frame) frame))))) diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index 1ef778d5..c414fc27 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadget-output.lisp,v 1.57 1994/12/04 23:57:41 colin Exp $ +;; $fiHeader: gadget-output.lisp,v 1.58 1995/05/17 19:47:55 colin Exp $ (in-package :clim-internals) @@ -791,6 +791,9 @@ (move-cursor-to-view-position stream view) (flet ((update-gadget (record gadget list-pane) (declare (ignore gadget record)) + (if active-p + (activate-gadget list-pane) + (deactivate-gadget list-pane)) (setf (gadget-value list-pane) default) list-pane)) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index 106f5f36..a3587f3a 100644 --- a/clim/input-protocol.lisp +++ b/clim/input-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-protocol.lisp,v 1.46 1994/12/04 23:57:50 colin Exp $ +;; $fiHeader: input-protocol.lisp,v 1.47 1995/05/17 19:48:00 colin Exp $ (in-package :clim-internals) @@ -114,8 +114,11 @@ (defmethod repaint-sheet :after ((stream input-protocol-mixin) region) (let ((cursor (stream-text-cursor stream)) - (viewport (pane-viewport stream))) - (when (and cursor viewport) + #+ignore (viewport (pane-viewport stream))) + ;; I don't know why the requirement was being made for the stream + ;; to have a viewport. This was causing problems for cursor redraw + ;; in panes with no scroll-bars. + (when (and cursor #+ignore viewport) (when (and (cursor-active cursor) (cursor-state cursor)) (multiple-value-bind (x y) (cursor-position cursor) diff --git a/clim/interactive-defs.lisp b/clim/interactive-defs.lisp index 7ee9fcd1..f65843bd 100644 --- a/clim/interactive-defs.lisp +++ b/clim/interactive-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: interactive-defs.lisp,v 1.24 1993/07/27 01:40:00 colin Exp $ +;; $fiHeader: interactive-defs.lisp,v 1.25 1995/05/17 19:48:03 colin Exp $ (in-package :clim-internals) @@ -179,6 +179,10 @@ ;;--- haven't updated WRITE-CHAR yet #+++ignore (write-char gesture stream)) (t (beep stream)))) + ((activation-gesture-p gesture) + (return-token gesture)) + ((delimiter-gesture-p gesture) + (return-token gesture)) (t (beep stream)))))))) (defun write-token (token stream &key acceptably) diff --git a/clim/menus.lisp b/clim/menus.lisp index 4abef5e8..30fb5e59 100644 --- a/clim/menus.lisp +++ b/clim/menus.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: menus.lisp,v 1.47 1994/12/04 23:57:57 colin Exp $ +;; $fiHeader: menus.lisp,v 1.48 1995/05/17 19:48:06 colin Exp $ (in-package :clim-internals) @@ -13,9 +13,9 @@ (defparameter *default-menu-label-text-style* (make-text-style :fix :italic :normal)) (define-application-frame menu-frame () - (menu + (menu (label :initarg :label :initform nil :accessor menu-frame-label) - (scroll-bars :initarg :scroll-bars + (scroll-bars :initarg :scroll-bars :initform t :reader menu-frame-scroll-bars)) (:pane @@ -30,7 +30,7 @@ :initial-cursor-visibility nil))))) (if label (vertically () - (setq label (make-pane 'label-pane + (setq label (make-pane 'label-pane :label "" :text-style *default-menu-label-text-style*)) main) @@ -58,16 +58,16 @@ (values (slot-value frame 'menu) frame))) (defresource menu (associated-window root &key label (scroll-bars t)) - :constructor + :constructor (let* ((framem (if (null root) (find-frame-manager) (frame-manager root)))) - (frame-manager-get-menu framem + (frame-manager-get-menu framem :scroll-bars scroll-bars :label label :parent-frame (pane-frame root))) :matcher (and (eq scroll-bars (menu-frame-scroll-bars (pane-frame menu))) (eq (not label) (not (menu-frame-label (pane-frame menu)))) (eq (frame-manager menu) (frame-manager root))) - + :deinitializer (progn (setf (window-visibility menu) nil) (window-clear menu)) @@ -77,7 +77,7 @@ ;;--- Should this flush the menu's event queue? (setf (stream-default-text-margin menu) nil) (when label - (let ((text-style (if (listp label) + (let ((text-style (if (listp label) (getf (rest label) :text-style *default-menu-label-text-style*) *default-menu-label-text-style*)) (label (if (listp label) (first label) label)) @@ -126,7 +126,7 @@ ;; Perhaps misguided attempt at allowing performance win if you use ;; simple unique-ids. -(defvar *menu-choose-output-history-caches* +(defvar *menu-choose-output-history-caches* (cons (make-hash-table :test #'eql) (make-hash-table :test #'equal))) @@ -181,12 +181,12 @@ (flet ((format-item (item) (let ((type (menu-item-type item))) (flet ((print-item () - (formatting-cell (menu :align-x cell-align-x + (formatting-cell (menu :align-x cell-align-x :align-y cell-align-y) (funcall item-printer item menu)))) (declare (dynamic-extent #'print-item)) (ecase type - (:item + (:item (if (menu-item-active item) (let ((presentation (with-output-as-presentation (menu item presentation-type @@ -198,7 +198,7 @@ (with-drawing-options (menu :ink *command-table-menu-gray* :text-face :bold) (print-item)))) - (:label + (:label (print-item)) (:divider (let* ((width (menu-item-getf item :width 50)) @@ -207,7 +207,7 @@ (formatting-cell (menu :align-x cell-align-x :align-y :center) (with-local-coordinates (menu) - (draw-line* menu 0 0 width 0 + (draw-line* menu 0 0 width 0 :line-thickness thickness :ink ink)))))))))) (declare (dynamic-extent #'format-item)) (map nil #'format-item items))) @@ -318,12 +318,12 @@ :item-printer item-printer :max-width max-width :max-height max-height :n-rows n-rows :n-columns n-columns - :x-spacing x-spacing :y-spacing y-spacing + :x-spacing x-spacing :y-spacing y-spacing :row-wise row-wise :cell-align-x cell-align-x :cell-align-y cell-align-y))) (declare (dynamic-extent #'menu-choose-body)) - (menu-choose-from-drawer + (menu-choose-from-drawer menu 'menu-item #'menu-choose-body :cache cache :unique-id unique-id :id-test id-test @@ -350,7 +350,7 @@ (invoke-with-mouse-grabbed-in-window (frame-manager ,w) ,w #'with-mouse-grabbed-in-window-body ,@options))))) -(defmethod invoke-with-mouse-grabbed-in-window +(defmethod invoke-with-mouse-grabbed-in-window ((framem standard-frame-manager) (window t) continuation &key) (funcall continuation)) @@ -359,10 +359,10 @@ `(flet ((with-menu-as-popup-body () ,@body)) (declare (dynamic-extent #'with-menu-as-popup-body)) (let ((,w ,menu)) - (invoke-with-menu-as-popup + (invoke-with-menu-as-popup (frame-manager ,w) ,w #'with-menu-as-popup-body))))) -(defmethod invoke-with-menu-as-popup +(defmethod invoke-with-menu-as-popup ((framem standard-frame-manager) (sheet basic-sheet) continuation) (funcall continuation)) @@ -374,7 +374,7 @@ ;; that are of different types. See example below (defun menu-choose-from-drawer (menu presentation-type drawer &key x-position y-position - cache unique-id (id-test #'equal) + cache unique-id (id-test #'equal) (cache-value t) (cache-test #'eql) ;; for use by HIERARCHICHAL-MENU-CHOOSE leave-menu-visible @@ -382,7 +382,7 @@ pointer-documentation menu-type) (declare (ignore menu-type)) (flet (#+Allegro - (abort-menu-handler () + (abort-menu-handler () (return-from menu-choose-from-drawer nil))) #+Allegro (declare (dynamic-extent #'abort-menu-handler)) (with-clim-state-reset (:all t @@ -412,7 +412,7 @@ (with-output-recording-options (menu :draw nil :record t) (let ((menu-contents (with-new-output-record (menu) - (setq default-presentation + (setq default-presentation (funcall drawer menu presentation-type))))) (when cache (setf (get-from-output-history-cache unique-id id-test) @@ -443,7 +443,7 @@ ;; is needed. ;;--- This screws up in Allegro because querying the server ;;--- in the wait function screws event handling. - (or #-Allegro + (or #-Allegro (and *abort-menus-when-buried* (not (window-visibility menu))) (pointer-motion-pending menu))) @@ -455,7 +455,7 @@ (return-from menu-choose-from-drawer nil)) ;; Take care of highlighting (highlight-presentation-of-context-type menu))) - #-Allegro + #-Allegro (declare (dynamic-extent #'input-wait-test #'input-wait-handler)) ;; Await exposure before going any further, since X can get ;; to the call to READ-GESTURE before the menu is visible. @@ -502,7 +502,7 @@ :item-printer item-printer :max-width max-width :max-height max-height :n-rows n-rows :n-columns n-columns - :x-spacing x-spacing :y-spacing y-spacing + :x-spacing x-spacing :y-spacing y-spacing :row-wise row-wise :cell-align-x cell-align-x :cell-align-y cell-align-y))) @@ -615,7 +615,7 @@ (let ((new-menu (define-static-menu-1 name this-root items :default-item default-item :text-style text-style - :printer printer + :printer printer :presentation-type presentation-type :drawer-args drawer-args))) (setq menu-contents (slot-value new-menu 'menu-contents) @@ -624,7 +624,7 @@ (with-menu (menu associated-window :label label :scroll-bars scroll-bars) (with-text-style (menu text-style) (multiple-value-bind (item gesture) - (menu-choose-from-drawer + (menu-choose-from-drawer menu 'menu-item #'false ;the drawer never gets called :cache static-menu :unique-id name @@ -645,7 +645,7 @@ (define-application-frame open-window-stream-frame () ((type :initarg :type) - (scroll-bars :initarg :scroll-bars) + (scroll-bars :initarg :scroll-bars) (borders :initarg :borders) (background :initarg :background) (foreground :initarg :foreground) @@ -667,12 +667,12 @@ :borders borders)) pane))) -(defun open-window-stream (&key (left nil leftp) - (top nil topp) - (right nil rightp) - (bottom nil bottomp) +(defun open-window-stream (&key left + top + right + bottom width height - foreground + foreground background text-style (vertical-spacing 2) @@ -708,10 +708,11 @@ :text-style text-style :frame-manager (etypecase parent - ((or pane standard-application-frame) + ((or pane standard-application-frame) (frame-manager parent)) (frame-manager parent) - (null (find-frame-manager))))) + (null (find-frame-manager))) + :left left :top top)) (stream (slot-value frame 'stream))) (setf (stream-vertical-spacing stream) vertical-spacing (stream-end-of-line-action stream) end-of-line-action @@ -725,6 +726,11 @@ (stream-output-history stream) (make-instance output-record)) (window-set-inside-size stream width height) (window-set-viewport-position stream 0 0) + + ;; moved this into the :left, :top args to above make-application-frame. + ;; The position-sheet-carefully doesn't seem to work because the frame + ;; window isn't realized at this point (cim 9/15/95) + #+ignore (when (or leftp topp rightp bottomp) (position-sheet-carefully (frame-top-level-sheet (pane-frame stream)) left top)) diff --git a/clim/tracking-pointer.lisp b/clim/tracking-pointer.lisp index b0a3c3a6..64eddcc5 100644 --- a/clim/tracking-pointer.lisp +++ b/clim/tracking-pointer.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: tracking-pointer.lisp,v 1.18 1993/07/27 01:41:43 colin Exp $ +;; $fiHeader: tracking-pointer.lisp,v 1.19 1994/12/04 23:58:14 colin Exp $ (in-package :clim-internals) @@ -41,7 +41,7 @@ ) ;eval-when (defmacro tracking-pointer ((&optional stream - &key pointer multiple-window transformp + &key pointer multiple-window transformp (context-type t) (highlight nil highlight-p) timeout) &body clauses) @@ -91,7 +91,7 @@ :timeout ,timeout)))))) (defun tracking-pointer-1 (stream pointer generator - &key multiple-window transformp + &key multiple-window transformp context-type highlight timeout) (unless pointer (setq pointer (stream-primary-pointer stream))) @@ -117,8 +117,8 @@ (highlighted-presentation-window nil) ;; Bind the input context so that presentation searching works (*input-context* - (with-presentation-type-decoded (name parameters) context-type - (list (list (list* name parameters) nil)))) + (with-presentation-type-decoded (name parameters) context-type + (list (list (list* name parameters) nil)))) ;; Bind these to NIL in case someone is doing TRACKING-POINTER ;; inside of a presentation action (*input-wait-test* nil) @@ -130,141 +130,145 @@ highlighted-presentation-type (presentation-type ,presentation) highlighted-presentation-window current-window) (when (output-recording-stream-p current-window) - (highlight-presentation - highlighted-presentation highlighted-presentation-type - highlighted-presentation-window :highlight)))) + (highlight-presentation + highlighted-presentation highlighted-presentation-type + highlighted-presentation-window :highlight)))) (unhighlight () `(when highlighted-presentation (when (output-recording-stream-p current-window) (highlight-presentation - highlighted-presentation highlighted-presentation-type - highlighted-presentation-window :unhighlight)) + highlighted-presentation highlighted-presentation-type + highlighted-presentation-window :unhighlight)) (setq highlighted-presentation nil))) (find-presentation (window x y &key event) `(if (eq context-type t) (find-innermost-presentation ,window ,x ,y) - (frame-find-innermost-applicable-presentation - *application-frame* *input-context* - ,window ,x ,y ,@(and event `(:event ,event)))))) + (frame-find-innermost-applicable-presentation + *application-frame* *input-context* + ,window ,x ,y ,@(and event `(:event ,event)))))) (unwind-protect - (loop - ;; Handle pointer motion - (block handle-simple-motion - (when (or motion-function presentation-motion-function highlight) - (when multiple-window - (setq current-window (or (pointer-sheet pointer) (graft pointer)))) - (multiple-value-bind (x y) (sheet-pointer-position - current-window pointer) - (when moved-p - (setq moved-p nil) - (setq last-x x last-y y - last-window current-window) - ;; Pointer position is in root (graft) coordinates - (when (or presentation-motion-function highlight) - (let ((presentation - (and (output-recording-stream-p current-window) - (find-presentation current-window x y)))) - (when presentation - (when highlight - (unless (eq presentation highlighted-presentation) - (unhighlight) - (highlight presentation))) - (when presentation-motion-function - (funcall presentation-motion-function - presentation current-window x y)) - (return-from handle-simple-motion)))) - (unhighlight) - (when motion-function - (when transformp - (multiple-value-bind (tx ty) - (transform-position - (medium-transformation current-window) x y) - (setq x (coordinate tx) - y (coordinate ty)))) - (funcall motion-function current-window x y)))))) - (block input-wait - (loop - ;; Handle any clicks or characters, otherwise wait for something - ;; interesting to happen. - (when multiple-window - (setq current-window (or (pointer-sheet pointer) (graft pointer)))) - (flet ((pointer-motion-pending (window) - (when (and (or multiple-window - (eq current-window (pointer-sheet pointer))) - (eq (stream-primary-pointer window) pointer)) - (multiple-value-setq (moved-p last-window last-x last-y) - (pointer-state-changed pointer last-window last-x last-y)) - (and moved-p last-window)))) - #-Allegro (declare (dynamic-extent #'pointer-motion-pending)) - ;; It's OK to do the input wait on STREAM instead of on - ;; CURRENT-WINDOW, because multiple-window mode only works - ;; when all the windows share the same I/O buffer. Same - ;; deal with the READ-GESTURE below, too. - ;;--- It's a bug that multiple-window has that restriction... - (multiple-value-setq (input-happened timed-out) - (stream-input-wait stream - :timeout timeout - :input-wait-test #'pointer-motion-pending))) - ;; Don't call READ-GESTURE if there is no gesture to read - ;;--- If we called READ-GESTURE on CURRENT-WINDOW, we would - ;;--- get the (possibly undesirable) side-effect that the - ;;--- "input focus" will follow the mouse, having particularly - ;;--- weird behavior regarding keystrokes. - (let ((gesture - (and input-happened - (read-gesture :stream stream :timeout 0)))) - (block process-gesture - (cond ((null gesture) - (if (and (eq timed-out :timeout) - timeout-function) - (funcall timeout-function)) - (return-from input-wait)) - ((keyboard-event-p gesture) - (when keyboard-function - (funcall keyboard-function gesture) - (return-from process-gesture))) - ((or (typep gesture 'pointer-button-press-event) - (typep gesture 'pointer-button-release-event)) - (let* ((px (pointer-event-x gesture)) - (py (pointer-event-y gesture)) - (wx px) - (wy py)) - (when transformp - (multiple-value-bind (tx ty) - (transform-position - (medium-transformation current-window) px py) - (setq wx (coordinate tx) - wy (coordinate ty)))) - (typecase gesture - (pointer-button-press-event - (when presentation-press-function - (let* ((window (event-sheet gesture)) - (presentation - (and (output-recording-stream-p window) - (find-presentation - window px py :event gesture)))) - (when presentation - (funcall presentation-press-function - presentation gesture wx wy) - (return-from process-gesture)))) - (when button-press-function - (funcall button-press-function gesture wx wy)) - (return-from process-gesture)) - (t ;pointer-button-release-event - (when presentation-release-function - (let* ((window (event-sheet gesture)) - (presentation - (and (output-recording-stream-p window) - (find-presentation - window px py :event gesture)))) - (when presentation - (funcall presentation-release-function - presentation gesture wx wy) - (return-from process-gesture)))) - (when button-release-function - (funcall button-release-function gesture wx wy)) - (return-from process-gesture)))))) - (beep stream)))))) + (when multiple-window + (port-remove-all-pointer-grabs (port pointer))) + (loop + ;; Handle pointer motion + (block handle-simple-motion + (when (or motion-function presentation-motion-function highlight) + (when multiple-window + (setq current-window (or (pointer-sheet pointer) (graft pointer)))) + (multiple-value-bind (x y) (sheet-pointer-position + current-window pointer) + (when moved-p + (setq moved-p nil) + (setq last-x x last-y y + last-window current-window) + ;; Pointer position is in root (graft) coordinates + (when (or presentation-motion-function highlight) + (let ((presentation + (and (output-recording-stream-p current-window) + (find-presentation current-window x y)))) + (when presentation + (when highlight + (unless (eq presentation highlighted-presentation) + (unhighlight) + (highlight presentation))) + (when presentation-motion-function + (funcall presentation-motion-function + presentation current-window x y)) + (return-from handle-simple-motion)))) + (unhighlight) + (when motion-function + (when transformp + (multiple-value-bind (tx ty) + (transform-position + (medium-transformation current-window) x y) + (setq x (coordinate tx) + y (coordinate ty)))) + (funcall motion-function current-window x y)))))) + (block input-wait + (loop + ;; Handle any clicks or characters, otherwise wait for something + ;; interesting to happen. + (when multiple-window + (setq current-window (or (pointer-sheet pointer) (graft pointer)))) + (flet ((pointer-motion-pending (window) + (when (and (or multiple-window + (eq current-window (pointer-sheet pointer))) + (eq (stream-primary-pointer window) pointer)) + (multiple-value-setq (moved-p last-window last-x last-y) + (pointer-state-changed pointer last-window last-x last-y)) + (and moved-p last-window)))) + #-Allegro (declare (dynamic-extent #'pointer-motion-pending)) + ;; It's OK to do the input wait on STREAM instead of on + ;; CURRENT-WINDOW, because multiple-window mode only works + ;; when all the windows share the same I/O buffer. Same + ;; deal with the READ-GESTURE below, too. + ;;--- It's a bug that multiple-window has that restriction... + (multiple-value-setq (input-happened timed-out) + (stream-input-wait stream + :timeout timeout + :input-wait-test #'pointer-motion-pending))) + ;; Don't call READ-GESTURE if there is no gesture to read + ;;--- If we called READ-GESTURE on CURRENT-WINDOW, we would + ;;--- get the (possibly undesirable) side-effect that the + ;;--- "input focus" will follow the mouse, having particularly + ;;--- weird behavior regarding keystrokes. + (let ((gesture + (and input-happened + (read-gesture :stream stream :timeout 0)))) + (block process-gesture + (cond ((null gesture) + (if (and (eq timed-out :timeout) + timeout-function) + (funcall timeout-function)) + (return-from input-wait)) + ((keyboard-event-p gesture) + (when keyboard-function + (funcall keyboard-function gesture) + (return-from process-gesture))) + ((or (typep gesture 'pointer-button-press-event) + (typep gesture 'pointer-button-release-event)) + (let* ((px (pointer-event-x gesture)) + (py (pointer-event-y gesture)) + (wx px) + (wy py)) + (when transformp + (multiple-value-bind (tx ty) + (transform-position + (medium-transformation current-window) px py) + (setq wx (coordinate tx) + wy (coordinate ty)))) + (typecase gesture + (pointer-button-press-event + (when multiple-window + (port-remove-all-pointer-grabs (port pointer))) + (when presentation-press-function + (let* ((window (event-sheet gesture)) + (presentation + (and (output-recording-stream-p window) + (find-presentation + window px py :event gesture)))) + (when presentation + (funcall presentation-press-function + presentation gesture wx wy) + (return-from process-gesture)))) + (when button-press-function + (funcall button-press-function gesture wx wy)) + (return-from process-gesture)) + (t ;pointer-button-release-event + (when presentation-release-function + (let* ((window (event-sheet gesture)) + (presentation + (and (output-recording-stream-p window) + (find-presentation + window px py :event gesture)))) + (when presentation + (funcall presentation-release-function + presentation gesture wx wy) + (return-from process-gesture)))) + (when button-release-function + (funcall button-release-function gesture wx wy)) + (return-from process-gesture)))))) + (beep stream)))))) (unhighlight) (when last-window (unhighlight-highlighted-presentation last-window)))))) @@ -276,13 +280,13 @@ (let ((x (coordinate x)) (y (coordinate y))) (declare (type coordinate x y)) - (labels + (labels ((mapper (record presentations x-offset y-offset) (declare (type coordinate x-offset y-offset)) (multiple-value-bind (sensitive superior-sensitive inferior-presentation) (if (presentationp record) ;;--- This should call PRESENTATION-REFINED-POSITION-TEST - (if (output-record-refined-position-test + (if (output-record-refined-position-test record (- x x-offset) (- y y-offset)) (let ((displayed (displayed-output-record-p record)) (single-box (presentation-single-box record))) @@ -302,7 +306,7 @@ (when inferior-presentation (setq presentations more-presentations)) (multiple-value-bind (dx dy) (output-record-position record) - (map-over-output-records-containing-position + (map-over-output-records-containing-position #'mapper record x y (- x-offset) (- y-offset) presentations (+ x-offset dx) (+ y-offset dy))) diff --git a/clim/translators.lisp b/clim/translators.lisp index c38a81da..ff2afd50 100644 --- a/clim/translators.lisp +++ b/clim/translators.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: translators.lisp,v 1.12 93/03/04 19:00:20 colin Exp $ +;; $fiHeader: translators.lisp,v 1.13 1993/07/27 01:41:46 colin Exp $ (in-package :clim-internals) @@ -27,7 +27,7 @@ (defclass presentation-translator () ((name :initarg :name :reader presentation-translator-name) - (function :initform nil :initarg :function + (function :initform nil :initarg :function :reader presentation-translator-function) (tester :initform nil :initarg :tester :reader presentation-translator-tester) @@ -172,7 +172,7 @@ (check-type documentation (or string symbol list)) (check-type pointer-documentation (or string symbol list)) (check-type menu symbol) - (check-type priority (or null (integer 0))) + (check-type priority (or null integer)) (check-type translator-class (or null symbol)) (let ((defining-forms nil) (translator-functions nil)) @@ -192,7 +192,7 @@ name ',clause-name ,extra-args) (emit function) (push `#',gensym translator-functions)))) - (push (intern (symbol-name ',clause-name) *keyword-package*) + (push (intern (symbol-name ',clause-name) *keyword-package*) translator-functions)))) (do-translator-function tester) (do-translator-function documentation '(stream) t) @@ -232,13 +232,13 @@ (or translator-class 'presentation-translator)) (translator (apply #'make-instance - translator-class + translator-class :name translator-name :from-type from-type :to-type to-type :gesture-name gesture :pointer-documentation (or pointer-documentation documentation) - ;; Err on the side of performance: if there's no tester, + ;; Err on the side of performance: if there's no tester, ;; assume that it is definitive. :tester-definitive (or (null tester) tester-definitive) :priority (or priority 0) @@ -302,7 +302,7 @@ (and cache (gethash key cache)) (cond ((or (null found-p) (/= (pop translators) *translators-cache-tick*)) - (let ((translators (find-presentation-translators-1 + (let ((translators (find-presentation-translators-1 from-key to-key command-table))) (when (null cache) (setq translators-cache @@ -310,7 +310,7 @@ :test #'equal)) (setq cache translators-cache)) ;; Need to copy the whole tree, since the from- and to-keys - ;; could themselves be stack-consed. + ;; could themselves be stack-consed. (setf (gethash (copy-tree key) cache) (cons *translators-cache-tick* translators)) translators)) @@ -339,10 +339,10 @@ (declare (dynamic-extent #'collect-translators)) (map-over-command-table-translators #'collect-translators command-table)) ;; The translator ordering is as follows, in this order: - ;; - Translators with higher high-order priority precede ones with lower + ;; - Translators with higher high-order priority precede ones with lower ;; high-order priority ;; - Translators on more specific types precede ones on less specific types - ;; - Translators with higher low-order priority precede ones with lower + ;; - Translators with higher low-order priority precede ones with lower ;; low-order priority ;; - Translators from this command table precede inherited translators ;; First get the command table ordering correct. @@ -453,8 +453,8 @@ &key event (modifier-state 0)) (declare (values translator any-match-p)) (let ((one-matched nil) - (translators - (find-presentation-translators + (translators + (find-presentation-translators (presentation-type presentation) context-type (frame-command-table frame)))) (when translators (dolist (translator translators) @@ -470,7 +470,7 @@ (when by-tester ;; We matched by the tester, it's OK to try the menu translator ;; unless the translator is not supposed to be in a menu. - (setq one-matched (or one-matched + (setq one-matched (or one-matched (presentation-translator-menu translator)))))) ;; If EVENT is non-NIL, then we are running on behalf of the user having ;; pressed a pointer button, which means that some translator must have @@ -512,7 +512,7 @@ (test-presentation-translator translator presentation context-type frame window x y - :event event + :event event :modifier-state modifier-state :for-menu for-menu)) (when fastp @@ -532,7 +532,7 @@ (test-presentation-translator *presentation-menu-translator* presentation context-type frame window x y - :event event + :event event :modifier-state modifier-state :for-menu for-menu)) (push (list *presentation-menu-translator* presentation @@ -566,7 +566,7 @@ (cond ((stringp documentation) (write-string documentation stream)) (documentation - (funcall documentation + (funcall documentation (presentation-object presentation) presentation context-type frame event window x y stream)) diff --git a/demo/color-editor.lisp b/demo/color-editor.lisp index cfc02771..ff6dd027 100644 --- a/demo/color-editor.lisp +++ b/demo/color-editor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: color-editor.lisp,v 1.12 1993/09/17 00:20:23 colin Exp $ +;; $fiHeader: color-editor.lisp,v 1.13 1993/09/17 19:05:51 cer Exp $ (in-package :clim-demo) @@ -14,69 +14,72 @@ (display-color (pane-frame stream) stream)) (define-application-frame color-chooser () - (color dynamic-p - red blue green - intensity hue saturation) + (color dynamic-p + red blue green + intensity hue saturation) (:menu-bar nil) - (:panes - (display (make-clim-stream-pane - :type 'color-chooser-pane - :scroll-bars nil - :display-function 'display-color - ;; Make sure we don't have a useless cursor blinking away... - :initial-cursor-visibility nil)) - (exit push-button - :label "Exit" - :activate-callback #'(lambda (button) - (frame-exit (pane-frame button)))) - (rgb (with-slots (red green blue) *application-frame* - (outlining () - (horizontally () - (setq red (make-pane 'slider - :label "Red" :foreground +red+ - :orientation :vertical - :min-value 0.0 :max-value 1.0 - :show-value-p t :decimal-places 3 - :client 'color :id 'red)) - (setq green (make-pane 'slider - :label "Green" :foreground +green+ - :orientation :vertical - :min-value 0.0 :max-value 1.0 - :show-value-p t :decimal-places 3 - :client 'color :id 'green)) - (setq blue (make-pane 'slider - :label "Blue" :foreground +blue+ - :orientation :vertical - :min-value 0.0 :max-value 1.0 - :show-value-p t :decimal-places 3 - :client 'color :id 'blue)))))) - (ihs (with-slots (intensity hue saturation) *application-frame* - (outlining () - (horizontally () - (setq intensity (make-pane 'slider - :label "Intensity" - :orientation :vertical - :min-value 0.0 :max-value (sqrt 3) - :show-value-p t :decimal-places 3 - :client 'color :id 'intensity)) - (setq hue (make-pane 'slider - :label "Hue" - :orientation :vertical - :min-value 0.0 :max-value 1.0 - :show-value-p t :decimal-places 3 - :client 'color :id 'hue)) - (setq saturation (make-pane 'slider - :label "Saturation" - :orientation :vertical - :min-value 0.0 :max-value 1.0 - :show-value-p t :decimal-places 3 - :client 'color :id 'saturation))))))) + (:panes + (display (make-clim-stream-pane + :type 'color-chooser-pane + :scroll-bars nil + :display-function 'display-color + ;; Make sure we don't have a useless cursor blinking away... + :initial-cursor-visibility nil)) + (exit push-button + :label "Exit" + :activate-callback #'(lambda (button) + (frame-exit (pane-frame button)))) + (rgb (with-slots (red green blue) *application-frame* + (outlining () + (horizontally () + (setq red (make-pane 'slider + :label "Red" :foreground +red+ + :orientation :vertical + :min-value 0.0 :max-value 1.0 + :min-label "0.0" :max-label "1.0" + :number-of-tick-marks 9 :decimal-places 3 + :client 'color :id 'red)) + (setq green (make-pane 'slider + :label "Green" :foreground +green+ + :orientation :vertical + :min-value 0.0 :max-value 1.0 + :min-label "0.0" :max-label "1.0" + :number-of-tick-marks 9 :decimal-places 3 + :client 'color :id 'green)) + (setq blue (make-pane 'slider + :label "Blue" :foreground +blue+ + :orientation :vertical + :min-value 0.0 :max-value 1.0 + :min-label "0.0" :max-label "1.0" + :number-of-tick-marks 9 :decimal-places 3 + :client 'color :id 'blue)))))) + (ihs (with-slots (intensity hue saturation) *application-frame* + (outlining () + (horizontally () + (setq intensity (make-pane 'slider + :label "Intensity" + :orientation :vertical + :min-value 0.0 :max-value (sqrt 3) + :show-value-p t :decimal-places 3 + :client 'color :id 'intensity)) + (setq hue (make-pane 'slider + :label "Hue" + :orientation :vertical + :min-value 0.0 :max-value 1.0 + :show-value-p t :decimal-places 3 + :client 'color :id 'hue)) + (setq saturation (make-pane 'slider + :label "Saturation" + :orientation :vertical + :min-value 0.0 :max-value 1.0 + :show-value-p t :decimal-places 3 + :client 'color :id 'saturation))))))) (:layouts - (default - (horizontally () - (outlining () - (vertically () display exit)) - rgb ihs)))) + (default + (horizontally () + (outlining () + (vertically () display exit)) + rgb ihs)))) (defmethod run-frame-top-level :before ((frame color-chooser) &key) (with-slots (color dynamic-p) frame diff --git a/postscript/postscript-medium.lisp b/postscript/postscript-medium.lisp index 7730924f..da3d2a02 100644 --- a/postscript/postscript-medium.lisp +++ b/postscript/postscript-medium.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: postscript-medium.lisp,v 1.16 1993/06/21 20:50:48 cer Exp $ +;; $fiHeader: postscript-medium.lisp,v 1.17 1994/12/05 00:00:05 colin Exp $ (in-package :postscript-clim) @@ -35,7 +35,7 @@ (defun use-line-style (medium line-style) (let* ((printer-stream (slot-value medium 'printer-stream)) (thickness (ecase (line-style-unit line-style) - (:normal (normal-line-thickness + (:normal (normal-line-thickness (port medium) (line-style-thickness line-style))) (:point (line-style-thickness line-style)))) (dashes (line-style-dashes line-style)) @@ -119,9 +119,16 @@ ((medium postscript-medium) (ink contrasting-ink)) (maybe-set-color medium (make-color-for-contrasting-ink ink))) +;; a temporary hack + +(defmethod maybe-set-color + ((medium postscript-medium) (ink composite-in)) + (maybe-set-color medium + (elt (slot-value ink 'clim-utils::designs) 0))) + (defmacro with-postscript-drawing-options ((medium printer-stream-var &key ink (filled nil - filled-p) line-style + filled-p) line-style clip-region epilogue (newpath t)) &body body) @@ -286,7 +293,7 @@ position-seq))))) (defmethod medium-draw-ellipse* ((medium postscript-medium) - center-x center-y + center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) (maybe-send-feature medium 'ellipse *ps-ellipse-code*) @@ -295,7 +302,7 @@ (line-style (medium-line-style medium)) (clip-region (medium-clipping-region medium))) (convert-to-postscript-coordinates transform center-x center-y) - (convert-to-postscript-distances transform + (convert-to-postscript-distances transform radius-1-dx radius-1-dy radius-2-dx radius-2-dy) (when (null start-angle) (setq start-angle 0 @@ -356,9 +363,9 @@ (height (psfck-clim-height fcs)) (descent (psfck-clim-descent fcs)) (ascent (- height descent))) - (let ((x-adjust + (let ((x-adjust (compute-text-x-adjustment align-x medium string text-style start end)) - (y-adjust + (y-adjust (compute-text-y-adjustment align-y descent ascent height))) (incf x x-adjust) (incf y y-adjust) @@ -367,14 +374,14 @@ (incf towards-y y-adjust))) ;; do raster/ink stuff. (set-font-if-needed medium fcs) - + (ps-pos-op medium "m" x y) (with-postscript-drawing-options (medium printer-stream :epilogue nil :newpath nil :ink ink :clip-region clip-region) (if towards-x - (with-postscript-gsave medium + (with-postscript-gsave medium (format printer-stream " currentpoint translate ~D rotate " (- 360 (truncate (* (atan (- towards-y y) (- towards-x x)) (/ 360 (* pi 2)))))) (carefully-output-ps-showstring printer-stream string start end)) @@ -393,7 +400,7 @@ string-or-char ch1buf start 0 end 1)) - (medium-draw-string* medium string-or-char x y start end + (medium-draw-string* medium string-or-char x y start end align-x align-y towards-x towards-y transform-glyphs))) (defmethod medium-text-bounding-box ((medium postscript-medium) @@ -406,7 +413,7 @@ (left top right bottom cx cy towards-x towards-y) (call-next-method) (if (and towards-y towards-x) (let ((transformation - (make-rotation-transformation + (make-rotation-transformation (atan (- towards-y cy) (- towards-x cx)) (make-point cx cy)))) (multiple-value-setq (left top) @@ -431,15 +438,15 @@ (height (psfck-clim-height fcs)) (descent (psfck-clim-descent fcs)) (ascent (- height descent))) - (let ((x-adjust + (let ((x-adjust (compute-text-x-adjustment align-x medium string text-style start end)) - (y-adjust + (y-adjust (compute-text-y-adjustment align-y descent ascent height))) (set-font-if-needed medium fcs) (with-postscript-drawing-options (medium printer-stream :epilogue nil :newpath nil :ink ink) - (with-postscript-gsave medium + (with-postscript-gsave medium (ps-pos-op medium "m" x y) (format printer-stream " currentpoint translate 90 rotate ") (ps-rel-pos-op medium "rmoveto" x-adjust y-adjust) @@ -475,7 +482,7 @@ ;; about. (let* ((fcs (or ,our-font (get-font-compat-str ,port nil ,style))) (cwt (psfck-width-table fcs)) - (relwidth (if (numberp cwt) + (relwidth (if (numberp cwt) cwt (aref cwt index))) (escapement-x (* (psfck-clim-height fcs) relwidth)) @@ -499,10 +506,10 @@ ;;-- Is this needed?? #+ignore -(defmethod stream-scan-string-for-writing +(defmethod stream-scan-string-for-writing ((stream clim-internals::output-protocol-mixin) (medium postscript-medium) string start end style cursor-x max-x &optional glyph-buffer) - (with-postscript-glyph-for-character + (with-postscript-glyph-for-character (stream-scan-string-for-writing-1 stream medium string start end style cursor-x max-x glyph-buffer))) @@ -545,13 +552,13 @@ (return fcs)) (when (eq styledesc (psfck-style-descriptor fcs)) (return fcs)))))) - (when (and fcs + (when (and fcs medium (let ((stream (medium-sheet medium))) (or (not (output-recording-stream-p stream)) (stream-drawing-p stream))) (not (psfck-established fcs))) - (with-slots (printer-stream) medium + (with-slots (printer-stream) medium (format printer-stream "~D ~D /~A estfont~%" (psfck-index fcs) (psfck-points fcs) (get-ps-fam-face-name fcs)) (setf (psfck-established fcs) t))) @@ -568,7 +575,7 @@ ;;--- This should consult the real metrics. (nth-value 6 (port-glyph-for-character (port medium) #\M text-style))) -(defmethod text-style-height +(defmethod text-style-height ((text-style standard-text-style) (medium postscript-medium)) (nth-value 7 (port-glyph-for-character (port medium) #\M text-style))) @@ -593,7 +600,7 @@ (point-size-for-size-keyword size famdat)))) points)) -(defmethod text-style-fixed-width-p +(defmethod text-style-fixed-width-p ((text-style standard-text-style) (medium postscript-medium)) (let* ((family (text-style-family text-style)) (face (text-style-face text-style)) diff --git a/postscript/postscript-port.lisp b/postscript/postscript-port.lisp index f3b4dfa5..317e8354 100644 --- a/postscript/postscript-port.lisp +++ b/postscript/postscript-port.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: postscript-port.lisp,v 1.23 1993/11/18 18:44:51 cer Exp $ +;; $fiHeader: postscript-port.lisp,v 1.24 1994/12/05 00:00:07 colin Exp $ (provide :climps) @@ -145,7 +145,7 @@ ;; The second element is a character size, which is either a number or a ;; place to go looking to get the character width table (defparameter *ps-font-family-data* - '(("Times" + '(("Times" (nil "tir" "Times-Roman") (:bold "tib" "Times-Bold") (:italic "tii" "Times-Italic") @@ -168,13 +168,13 @@ (error "No info for PostScript font family ~A" fam))))) (third (or (assoc face famdata) (error "No info for PostScript family ~A face ~A." fam face)))))) - + ;; Value is a 3 element list acceptable as a returned value from ;; CONVERT-CLIM-TO-PS-FONT-DESCRIPTION: a postscript family name as ;; appears in the CARs of the elements of *PS-FONT-FAMILY-DATA*, a face ;; keyword as returned by the function KEYWORDIFY-STYLE-FACE, and a ;; size in points. -(defparameter *ps-font-description-for-undefined-style* '("Courier" nil 4)) +(defparameter *ps-font-description-for-undefined-style* '("Courier" nil 4)) (defun convert-clim-to-ps-font-description (style) (let ((size (text-style-size style)) @@ -346,7 +346,7 @@ ;;; the software that drives the LGP2 (sys:hardcopy;postscript.lisp) ;;; uses LGP:FAST-PRINT-NUM except for writing transformation matrices, -;;; for which it uses +;;; for which it uses ;;; (prin1 (if (fixp elem) elem (float elem)) output-stream) ;;; and also some cases of Format ~D. (defun ps-optimal-flonize (n stream) @@ -367,7 +367,7 @@ (negative-p nil)) (when (minusp n) (setq negative-p t)) - (with-stack-array (string from :element-type #+ANSI-90 'character + (with-stack-array (string from :element-type #+ANSI-90 'character #-ANSI-90 'string-char) (macrolet ((add-char (char) `(setf (aref string (decf from)) ,char))) @@ -412,10 +412,10 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def /str 100 string def nbits 0 ne { gsave width height scale - bitwidth height true [bitwidth 0 0 height neg 0 height] - { nbits 800 ge {/nbits nbits 800 sub def str} + bitwidth height true [bitwidth 0 0 height neg 0 height] + { nbits 800 ge {/nbits nbits 800 sub def str} {nbits 8 idiv string /nbits 0 def} - ifelse + ifelse currentfile exch readhexstring pop} imagemask grestore } if end @@ -443,7 +443,7 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def width 0 ne { height 0 ne { /scanline -1 def /linebits 0 def width height idtransform abs scale scal dup scale - width height true [width 0 0 height neg 0 height] + width height true [width 0 0 height neg 0 height] % This procedure returns the same row the right number of times % I suppose if the pattern does not fit exactly it does not matter % since there is a clipping region. @@ -460,12 +460,12 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def /patfill1 { initmatrix clippath %condition-case for nocurrentpoint, returning empty rectangle errordict begin - /nocurrentpoint dup dup load exch { pop 0 0 0 0 } def + /nocurrentpoint dup dup load exch { pop 0 0 0 0 } def pathbbox 6 -2 roll def end % pattern scale opaque-p bx1 by1 bx2 by2 4 2 roll 2 copy translate 4 -2 roll -% pattern scale opaque-p bx1 by1 bx2 by2 +% pattern scale opaque-p bx1 by1 bx2 by2 3 -1 roll sub 3 1 roll exch sub exch % pattern scale opaque-p dx dy 3 -1 roll { 2 copy gsave 1 setgray newpath @@ -482,11 +482,11 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def [/depth /height /width] {exch def} forall gsave clip -% Get the bounding box of the clip path on the stack +% Get the bounding box of the clip path on the stack initmatrix clippath %condition-case for nocurrentpoint, returning empty rectangle errordict begin - /nocurrentpoint dup dup load exch { pop 0 0 0 0 } def + /nocurrentpoint dup dup load exch { pop 0 0 0 0 } def pathbbox 6 -2 roll def end % Stack is bx1 by1 bx2 by2 @@ -510,36 +510,56 @@ end } def ") (defmethod postscript-prologue ((medium postscript-medium) - &key scale-factor (orientation :portrait) + &key (scale-factor 1) (orientation :portrait) header-comments) (let ((printer-stream (slot-value medium 'printer-stream)) (port (port medium))) - (format printer-stream "%!PS-Adobe-2.0 EPSF-2.0~%") - (multiple-value-bind (left top right bottom) - (postscript-bounding-box-edges (medium-sheet medium)) - (format printer-stream "%%BoundingBox: ~D ~D ~D ~D~%" - (float left) (float top) (float right) (float bottom))) - (format printer-stream "%%Creator: CLIM 2.0~%") - (let ((title (getf header-comments :title))) - (when title - (format printer-stream "%%Title: ~A~%" title))) - (let ((for (or (getf header-comments :for) #+Genera zl:user-id))) - (when for - (format printer-stream "%%For: ~A~%" for))) - - (multiple-value-bind (second minute hour date month year) - (decode-universal-time (get-universal-time)) - (format printer-stream "%%CreationDate: ~D-~A-~D ~2,'0D:~2,'0D:~2,'0D~%" - date (svref #("Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (1- month)) year - hour minute second)) - (format printer-stream "%%DocumentFonts: (atend)~%") - (format printer-stream "%%EndComments~%") - (format printer-stream *postscript-prologue* (length (slot-value (port medium) 'font-map))) - (with-slots (page-indent page-height page-width device-units-per-inch) + (with-slots (page-indent page-height page-width device-units-per-inch) port (flet ((device-units (x) - (float (* x device-units-per-inch)))) + (float (* x device-units-per-inch))) + (scale (x) + (* x scale-factor))) + + (format printer-stream "%!PS-Adobe-2.0 EPSF-2.0~%") + + (multiple-value-bind (left top right bottom) + (postscript-bounding-box-edges (medium-sheet medium)) + (let (llx lly urx ury) + (ecase orientation + (:portrait + (let ((dx (device-units page-indent)) + (dy (device-units (+ page-indent page-height)))) + (setq llx (+ dx (scale left)) lly (- dy (scale bottom)) + urx (+ dx (scale right)) ury (- dy (scale top))))) + (:landscape + (let ((dx (device-units (+ page-indent page-height))) + (dy (device-units (+ page-indent page-width)))) + (setq llx (- dx (scale bottom)) lly (- dy (scale right)) + urx (- dx (scale top)) ury (- dy (scale left)))))) + (format printer-stream "%%BoundingBox: ~D ~D ~D ~D~%" + llx lly urx ury) + #+debug + (format printer-stream + "newpath ~D ~D moveto ~D ~D lineto stroke~%" + llx lly urx ury))) + + (format printer-stream "%%Creator: CLIM 2.0~%") + (let ((title (getf header-comments :title))) + (when title + (format printer-stream "%%Title: ~A~%" title))) + (let ((for (or (getf header-comments :for) #+Genera zl:user-id))) + (when for + (format printer-stream "%%For: ~A~%" for))) + (multiple-value-bind (second minute hour date month year) + (decode-universal-time (get-universal-time)) + (format printer-stream "%%CreationDate: ~D-~A-~D ~2,'0D:~2,'0D:~2,'0D~%" + date (svref #("Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (1- month)) year + hour minute second)) + (format printer-stream "%%DocumentFonts: (atend)~%") + (format printer-stream "%%EndComments~%") + (format printer-stream *postscript-prologue* (length (slot-value (port medium) 'font-map))) (ecase orientation (:portrait (format printer-stream @@ -548,10 +568,10 @@ end } def (device-units (+ page-indent page-height)))) (:landscape (format printer-stream - "/format-rotation -90 def ~%/format-translation {~D ~D} def~%" + "/format-rotation -90 def ~%/format-translation {~D ~D} def~%" (device-units (+ page-indent page-height)) (device-units (+ page-indent page-width))))))) - (format printer-stream "/format-scale ~D def~%" (float (or scale-factor 1))) + (format printer-stream "/format-scale ~D def~%" (float scale-factor)) (format printer-stream "/new-matrix {format-translation translate format-rotation rotate @@ -593,7 +613,7 @@ end } def (assert (= bottom (1+ top))) (unless (zerop (rem right 8)) (error "Sorry, can't hack right /= 0 (mod 8); you have ~D" right)) - (with-stack-array (arr (array-total-size raster) + (with-stack-array (arr (array-total-size raster) :element-type #+Genera '(unsigned-byte 8) #-Genera (array-element-type raster) :displaced-to raster) @@ -618,7 +638,7 @@ end } def ((< index toprow)) (repeat bytes-per-raster (let ((byte (aref arr i))) - (setf (aref buf j) + (setf (aref buf j) (aref bigend-digit-char (ldb (byte 4 0) byte))) (setf (aref buf (1+ j)) (aref bigend-digit-char (ldb (byte 4 4) byte))) @@ -637,7 +657,7 @@ end } def (error "Sorry, can't hack right - left /= 0 (mod 8); you have ; ~D,~D" right left)) (let ((i left) (n-cells (/ 8 bits-per-cell))) - (loop + (loop (when (= i right) (return)) (let ((value 0)) (dotimes (j n-cells) @@ -750,7 +770,7 @@ end } def (defmethod make-palette ((port postscript-port) &key) (make-instance 'postscript-palette - :port port + :port port :color-p t :dynamic-p nil)) @@ -762,14 +782,14 @@ end } def (with-slots (page-width page-height) port (with-slots (silica::mm-height silica::mm-width silica::pixel-height silica::pixel-width - silica::pixels-per-point) + silica::pixels-per-point) graft (setf silica::pixel-width (* page-width 72) silica::pixel-height (* page-height 72) silica::mm-width (* page-width 25.4) silica::mm-height (* page-height 25.4) silica::pixels-per-point 1) - + (setf (sheet-region graft) (ecase (graft-units graft) (:device (make-rectangle* 0 0 silica::pixel-width silica::pixel-height)) @@ -815,7 +835,7 @@ end } def (defclass apple-laser-writer (postscript-port) ;; x-resolution and y-resolution should *never* appear in any ;; calculations - they have no relevance whatsoever as postscript is - ;; co-ordinates are given in user space *not* device space. + ;; co-ordinates are given in user space *not* device space. ((x-resolution :initform 300) ;pixels per inch (y-resolution :initform 300) (page-indent :initform 0.5) ;in inches @@ -848,7 +868,7 @@ end } def (device-transformation :accessor sheet-device-transformation :initform +identity-transformation+) (generating-postscript :initform t :accessor stream-generating-postscript)) - (:default-initargs + (:default-initargs :default-text-margin 1000 :output-record (make-instance 'standard-sequence-output-history))) @@ -943,11 +963,11 @@ end } def (incf viewport-y page-height)) (setq viewport-x 0 viewport-y 0)))))))))) -(defmethod invoke-with-output-recording-options :before +(defmethod invoke-with-output-recording-options :before ((stream postscript-stream) continuation record draw) (declare (ignore record continuation)) ;; See [clim2bug459] - (when (and draw + (when (and draw (not (stream-drawing-p stream)) (not (stream-generating-postscript stream))) (error "Cannot turning drawing on for postscript stream ~S" stream))) @@ -993,7 +1013,7 @@ end } def (let ((record (stream-output-history stream))) (when (or scale-to-fit multi-page) (bounding-rectangle-set-position record 0 0)) - (multiple-value-bind (width height) + (multiple-value-bind (width height) (bounding-rectangle-size record) (let* ((page-width (floor (* (slot-value port 'page-width) diff --git a/silica/db-border.lisp b/silica/db-border.lisp index 23bccd8d..829122f2 100644 --- a/silica/db-border.lisp +++ b/silica/db-border.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-border.lisp,v 1.20 93/04/16 09:45:18 cer Exp $ +;; $fiHeader: db-border.lisp,v 1.21 1993/07/27 01:50:23 colin Exp $ "Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. Portions copyright (c) 1991, 1992 by Symbolics, Inc. All rights reserved." @@ -23,7 +23,7 @@ (child (sheet-child pane))) (space-requirement+ (compose-space child :width width :height height) - (make-space-requirement + (make-space-requirement :width (* 2 thickness) :height (* 2 thickness))))) @@ -34,17 +34,21 @@ thickness thickness (- width (* 2 thickness)) (- height (* 2 thickness))) (repaint-border-pane pane))) - + (defmethod handle-repaint ((pane border-pane) region) (declare (ignore region)) ;not worth checking (repaint-border-pane pane)) (defun repaint-border-pane (pane) (with-sheet-medium (medium pane) - (with-bounding-rectangle* (left top right bottom) + (with-bounding-rectangle* (left top right bottom) (sheet-region pane) (let* ((thickness (slot-value pane 'thickness)) - (ht (ceiling thickness 2))) + ;; this used to be ceiling but it sometimes caused + ;; borders to overwrite the child pane - which played + ;; havoc with the flipping-ink mechanism used to draw the + ;; cursor (cim 9/14/95) + (ht (floor thickness 2))) (incf left ht) (incf top ht) (decf right ht) @@ -94,10 +98,10 @@ ;;; Label panes -(defparameter *default-label-text-style* +(defparameter *default-label-text-style* (make-text-style :sans-serif :italic :small)) -(defclass label-pane +(defclass label-pane (sheet-with-resources-mixin labelled-gadget-mixin pane) @@ -107,9 +111,9 @@ ;; mechanism for the Motif/OpenLook ports :text-style nil)) -(defmacro labelling ((&rest options - &key (label-alignment #+Genera :bottom #-Genera :top) - &allow-other-keys) +(defmacro labelling ((&rest options + &key (label-alignment #+Genera :bottom #-Genera :top) + &allow-other-keys) &body contents &environment env) #-(or Genera Minima) (declare (ignore env)) (assert (null (cdr contents)) (contents) diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp index 3ba10563..f447ed7e 100644 --- a/silica/db-layout.lisp +++ b/silica/db-layout.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-layout.lisp,v 1.35 1993/06/21 20:51:16 cer Exp $ +;; $fiHeader: db-layout.lisp,v 1.36 1993/07/22 15:38:51 cer Exp $ (in-package :silica) @@ -58,18 +58,18 @@ (defmethod note-sheet-region-changed :after ((pane layout-mixin) &key port-did-it) (note-layout-mixin-region-changed pane :port port-did-it)) -(defmethod note-layout-mixin-region-changed ((pane layout-mixin) &key port) +(defmethod note-layout-mixin-region-changed ((pane layout-mixin) &key port) (declare (ignore port)) (multiple-value-bind (width height) (bounding-rectangle-size pane) (allocate-space pane width height))) -(defmacro changing-space-requirements ((&rest options &key resize-frame layout) +(defmacro changing-space-requirements ((&rest options &key resize-frame layout) &body body) (declare (ignore resize-frame layout)) `(flet ((changing-space-requirements-body () ,@body)) (declare (dynamic-extent #'changing-space-requirements-body)) - (invoke-with-changing-space-requirements + (invoke-with-changing-space-requirements #'changing-space-requirements-body ,@options))) (defmethod change-space-requirements-to ((pane layout-mixin) space-requirement) @@ -77,7 +77,7 @@ height min-height max-height) (space-requirement-components space-requirement) (change-space-requirements pane - :width width :min-width min-width :max-width max-width + :width width :min-width min-width :max-width max-width :height height :min-height min-height :max-height max-height))) @@ -92,9 +92,9 @@ (defun invoke-with-changing-space-requirements (continuation &key resize-frame (layout t)) (declare (ignore resize-frame)) ;-- Why? - (let ((old-inside-changing-space-requirements + (let ((old-inside-changing-space-requirements *inside-changing-space-requirements*) - (*inside-changing-space-requirements* + (*inside-changing-space-requirements* (cons nil *inside-changing-space-requirements*))) (multiple-value-prog1 (funcall continuation) @@ -102,7 +102,7 @@ ;; Layout that frames that need to be laid out and ;; re-layout the minimal subtrees that need to be laid out (let* ((frames (remove-duplicates - (remove-if-not + (remove-if-not #'(lambda (x) (application-frame-p x)) *inside-changing-space-requirements*))) (panes (remove-if #'(lambda (x) @@ -111,17 +111,17 @@ *inside-changing-space-requirements*))) (mapc #'layout-frame frames) (dolist (pane panes) - (unless (some #'(lambda (p) + (unless (some #'(lambda (p) (and (not (eq p pane)) (sheet-ancestor-p pane p))) panes) ;; do this because the change has occurred somewhere in ;; the tree - (clear-space-requirement-caches-in-tree pane) - (multiple-value-call #'allocate-space + (clear-space-requirement-caches-in-tree pane) + (multiple-value-call #'allocate-space pane (bounding-rectangle-size pane))))))))) -(defmethod change-space-requirements :around ((pane layout-mixin) +(defmethod change-space-requirements :around ((pane layout-mixin) &key resize-frame &allow-other-keys) (call-next-method) (let ((frame (pane-frame pane))) @@ -153,7 +153,7 @@ ;; The "spread" version of the above... (defun space-requirement+* (sr &key (width 0) (max-width width) (min-width width) (height 0) (max-height height) (min-height height)) - (multiple-value-bind (srwidth srmin-width srmax-width + (multiple-value-bind (srwidth srmin-width srmax-width srheight srmin-height srmax-height) (space-requirement-components sr) (make-space-requirement @@ -188,13 +188,13 @@ ;;; ;;; Space Req Mixin -;;; +;;; (defclass basic-space-requirement-mixin (layout-mixin) ((initial-space-requirement :reader pane-initial-space-requirements) (space-requirement :reader pane-space-requirements))) -(defmethod initialize-instance :after ((pane basic-space-requirement-mixin) +(defmethod initialize-instance :after ((pane basic-space-requirement-mixin) &rest args &key width max-width min-width height max-height min-height) @@ -206,7 +206,7 @@ height min-height max-height) (apply #'default-space-requirements pane :allow-other-keys t args) (let ((sr (make-space-requirement - :width width :min-width min-width :max-width max-width + :width width :min-width min-width :max-width max-width :height height :min-height min-height :max-height max-height))) ;; Space requirements are immutable... (setf space-requirement sr @@ -216,7 +216,7 @@ (when (pane-initial-space-requirements pane) (change-space-requirements-to pane (pane-initial-space-requirements pane)))) -(defmethod default-space-requirements ((pane basic-space-requirement-mixin) +(defmethod default-space-requirements ((pane basic-space-requirement-mixin) &key (width 0) (min-width width) (max-width width) @@ -226,16 +226,16 @@ (values width min-width max-width height min-height max-height)) -(defmethod change-space-requirements ((pane basic-space-requirement-mixin) +(defmethod change-space-requirements ((pane basic-space-requirement-mixin) &key width min-width max-width height min-height max-height resize-frame) (declare (ignore resize-frame)) (with-slots (space-requirement) pane - (multiple-value-bind (srwidth srmin-width srmax-width + (multiple-value-bind (srwidth srmin-width srmax-width srheight srmin-height srmax-height) (space-requirement-components space-requirement) - (setq space-requirement (make-space-requirement + (setq space-requirement (make-space-requirement :width (or width srwidth) :min-width (or min-width srmin-width) :max-width (or max-width srmax-width) @@ -261,7 +261,7 @@ (defclass client-overridability-mixin (basic-space-requirement-mixin) ()) -(defmethod default-space-requirements ((pane client-overridability-mixin) +(defmethod default-space-requirements ((pane client-overridability-mixin) &key width min-width max-width height min-height max-height) (values width min-width max-width height min-height max-height)) @@ -272,7 +272,7 @@ (defmethod compose-space :around ((pane client-overridability-mixin) &key width height) (declare (ignore width height)) (with-slots (space-requirement) pane - (multiple-value-bind (width1 min-width1 max-width1 height1 min-height1 max-height1) + (multiple-value-bind (width1 min-width1 max-width1 height1 min-height1 max-height1) (space-requirement-components (normalize-space-requirement pane space-requirement)) (multiple-value-bind (width2 min-width2 max-width2 height2 min-height2 max-height2) (space-requirement-components (call-next-method)) @@ -289,7 +289,63 @@ :height height :min-height (or (mmin min-height1 height1 min-height2) height) :max-height (or (mmax max-height1 height1 max-height2) height)))))))) -;;; + +;; A more correct version. This was implemented to make :max-height +;; override the :visible-items in list-panes. This is "more correct" +;; than the above definition in that it ensures that as long as the +;; original space requirement is well formed (ie min<=desired<=max) +;; then the result space requirement is well formed. Unfortunately +;; this breaks other code which relies in certain circumstances that +;; desired>max. In other words the whole thing is a complete mess and +;; I give up (cim 8/31/95) + +#+ignore +(defmethod compose-space :around ((pane client-overridability-mixin) &key width height) + (declare (ignore width height)) + (with-slots (space-requirement) pane + (multiple-value-bind (width1 min-width1 max-width1 height1 min-height1 max-height1) + (space-requirement-components (normalize-space-requirement pane space-requirement)) + (multiple-value-bind (width2 min-width2 max-width2 height2 min-height2 max-height2) + (space-requirement-components (call-next-method)) + + (macrolet ((nmin (arg &rest args) + (if args + (with-gensyms (a b) + `(let ((,a ,arg) + (,b (nmin ,@args))) + (if ,a (if ,b (min ,a ,b) ,a) ,b))) + arg)) + (nmax (arg &rest args) + (if args + (with-gensyms (a b) + `(let ((,a ,arg) + (,b (nmax ,@args))) + (if ,a (if ,b (max ,a ,b) ,a) ,b))) + arg))) + (let* ((min-width (nmin (nmax min-width1 min-width2) + width1 + max-width1)) + (max-width (nmax (nmin max-width1 max-width2) + width1 + min-width1)) + (width (or width1 + (and width2 + (nmin max-width + (nmax min-width width2))))) + (min-height (nmin (nmax min-height1 min-height2) + height1 + max-height1)) + (max-height (nmax (nmin max-height1 max-height2) + height1 + min-height1)) + (height (or height1 + (and height2 + (nmin max-height + (nmax min-height height2)))))) + (make-space-requirement + :width width :min-width min-width :max-width max-width + :height height :min-height min-height :max-height max-height))))))) + ;;; Space Req Cache ;;; @@ -321,7 +377,7 @@ (clear-space-requirement-cache pane)) (defun clear-space-requirement-caches-in-tree (sheet) - (map-over-sheets #'(lambda (sheet) + (map-over-sheets #'(lambda (sheet) (clear-space-requirement-cache sheet)) sheet)) @@ -336,7 +392,7 @@ (defclass wrapping-space-mixin (layout-mixin) ()) - + (defmethod allocate-space ((pane wrapping-space-mixin) width height) (resize-sheet (sheet-child pane) width height)) @@ -405,8 +461,8 @@ (let ((fills (count :fill sizes)) (leftover (- given allocated))) (when (> fills 0) - (let ((x (if (> leftover 0) - (fix-coordinate (/ leftover fills)) + (let ((x (if (> leftover 0) + (fix-coordinate (/ leftover fills)) 0))) (setf sizes (nsubstitute x :fill sizes))))) (nreverse sizes)))) diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index 16a479c1..051d2e98 100644 --- a/silica/db-scroll.lisp +++ b/silica/db-scroll.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-scroll.lisp,v 1.51 1993/11/23 19:58:50 cer Exp $ +;; $fiHeader: db-scroll.lisp,v 1.52 1994/12/05 00:00:14 colin Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -16,11 +16,11 @@ pane) ((scroll-bars :initarg :scroll-bars :reader scroller-pane-scroll-bar-policy) - (drag-scroll :initarg :drag-scroll + (drag-scroll :initarg :drag-scroll :accessor scroller-pane-drag-scroll) viewport (contents :initarg :contents :accessor pane-contents) - (vertical-scroll-bar :initform nil + (vertical-scroll-bar :initform nil :accessor scroller-pane-vertical-scroll-bar) (horizontal-scroll-bar :initform nil :accessor scroller-pane-horizontal-scroll-bar) @@ -30,8 +30,14 @@ (vertical-line-scroll-amount :initform nil :initarg :vertical-line-scroll-amount) - (horizontal-line-scroll-amount :initform nil - :initarg :horizontal-line-scroll-amount)) + (horizontal-line-scroll-amount :initform nil + :initarg + :horizontal-line-scroll-amount) + (vertical-page-scroll-amount :initform nil + :initarg + :vertical-page-scroll-amount) + (horizontal-page-scroll-amount :initform nil + :initarg :horizontal-page-scroll-amount)) (:default-initargs :scroll-bars :both :drag-scroll t)) ;; Returns the viewport of the pane, if there is one @@ -90,10 +96,10 @@ (compute-dynamic-scroll-bar-values scroller) (update-dynamic-scroll-bars scroller changedp - hscroll-bar hscroll-bar-enabled-p + hscroll-bar hscroll-bar-enabled-p vscroll-bar vscroll-bar-enabled-p t)) - - (with-bounding-rectangle* (left top right bottom) + + (with-bounding-rectangle* (left top right bottom) (viewport-contents-extent viewport) (with-bounding-rectangle* (vleft vtop vright vbottom) (viewport-viewport-region viewport) @@ -105,12 +111,12 @@ (horizontal-scroll-bar (scroller-pane-horizontal-scroll-bar scroller))) (when vertical-scroll-bar (update-scroll-bar vertical-scroll-bar - top bottom + top bottom vtop vbottom :vertical)) (when horizontal-scroll-bar (update-scroll-bar horizontal-scroll-bar - left right + left right vleft vright :horizontal)))))))) @@ -149,7 +155,7 @@ (min 1.0s0 (max 0.0s0 (if (<= contents-range viewport-range) 0.0 - (/ (float (- vmin min) 0.0s0) + (/ (float (- vmin min) 0.0s0) contents-range)))))))) (declare (type single-float pos size)) (unless (and current-size @@ -160,20 +166,29 @@ (let* ((line-scroll (line-scroll-amount (slot-value scroll-bar 'client) orientation nil)) - (line-scroll (if (zerop contents-range) - 0 ;-- Who knows - (* range (/ line-scroll contents-range))))) - (change-scroll-bar-values scroll-bar + (page-scroll (page-scroll-amount (slot-value scroll-bar 'client) + orientation + nil))) + (change-scroll-bar-values scroll-bar :slider-size size :value pos - :line-increment line-scroll))))))) + :line-increment (if (zerop contents-range) + 0 ;-- Who knows + (* range (/ line-scroll + contents-range))) + :page-increment (if (> page-scroll 1) + (if (zerop contents-range) + 0 ;-- Who knows + (* range (/ page-scroll + contents-range))) + (* size page-scroll))))))))) -(defmethod value-changed-callback +(defmethod value-changed-callback ((sheet scroll-bar) (client scroller-pane) id value) (scroll-bar-value-changed-callback sheet client id value (scroll-bar-size sheet))) -(defmethod drag-callback +(defmethod drag-callback ((sheet scroll-bar) (client scroller-pane) id value) (when (scroller-pane-drag-scroll client) (scroll-bar-value-changed-callback sheet client id value @@ -206,7 +221,7 @@ (gadget-range sheet))))) (bounding-rectangle-min-y region)))) ;;-- Yuck - (clim-internals::maybe-redraw-input-editor-stream + (clim-internals::maybe-redraw-input-editor-stream contents (pane-viewport-region contents))))) (defmethod update-region ((sheet basic-sheet) nleft ntop nright nbottom &key no-repaint) @@ -221,7 +236,7 @@ (fix-coordinates x y) (let ((viewport (pane-viewport sheet))) (when viewport - (with-bounding-rectangle* (left top right bottom) + (with-bounding-rectangle* (left top right bottom) (pane-viewport-region sheet) ;; Optimize this case, since the rest of this code can be ;; quite expensive, especially on servers that require COPY-AREA @@ -231,7 +246,7 @@ (setf (sheet-transformation sheet) (make-translation-transformation (- x) (- y))) (bounding-rectangle-set-position (viewport-viewport-region viewport) x y) - (with-bounding-rectangle* (nleft ntop nright nbottom) + (with-bounding-rectangle* (nleft ntop nright nbottom) (pane-viewport-region sheet) ;; If we are scrolling programatically then this might ;; reveal more of the sheet than currently exists @@ -241,7 +256,7 @@ (if (ltrb-overlaps-ltrb-p left top right bottom nleft ntop nright nbottom) (progn ;; Move the old stuff to the new position - (window-shift-visible-region sheet + (window-shift-visible-region sheet left top right bottom nleft ntop nright nbottom) (let ((rectangles (ltrb-difference nleft ntop nright nbottom @@ -308,5 +323,13 @@ (:vertical (bounding-rectangle-height r)) (:horizontal (bounding-rectangle-width r))) 10))) - + +(defmethod page-scroll-amount ((pane scroller-pane) orientation direction) + (declare (ignore direction)) + (or (with-slots (vertical-page-scroll-amount + horizontal-page-scroll-amount) pane + (ecase orientation + (:horizontal horizontal-page-scroll-amount) + (:vertical vertical-page-scroll-amount))) + 0.9)) diff --git a/silica/event.lisp b/silica/event.lisp index 5094ee8d..3bdea016 100644 --- a/silica/event.lisp +++ b/silica/event.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: event.lisp,v 1.38 1993/08/12 16:04:13 cer Exp $ +;; $fiHeader: event.lisp,v 1.39 1994/12/05 00:00:17 colin Exp $ (in-package :silica) @@ -95,7 +95,7 @@ -;;; Standard +;;; Standard (defclass standard-sheet-input-mixin (sheet-with-event-queue-mixin) ()) @@ -154,7 +154,7 @@ child (untransform-region (sheet-transformation child) region))))) (declare (dynamic-extent #'repaint-sheet-1)) (map-over-sheets-overlapping-region #'repaint-sheet-1 sheet region))) - + (defgeneric handle-repaint (sheet region)) @@ -271,9 +271,9 @@ (return)) (multiple-value-setq (new-x new-y) (map-sheet-position-to-parent sheet new-x new-y))))) - + (let* ((v (port-trace-thing port)) - (exitted-a-window + (exitted-a-window (and (typep event 'pointer-exit-event) (not (eq (pointer-boundary-event-kind event) :inferior)))) (entered-from-child @@ -311,7 +311,7 @@ (when (or (and (not mirrored-sheet-in-trace) (not (member sheet ancestors-of-mirrored-sheet))) (not (sheet-enabled-p sheet)) - (not (region-contains-position-p + (not (region-contains-position-p (sheet-region sheet) new-x new-y))) (return i)))) 0))) @@ -353,7 +353,7 @@ (sheet (aref v (1- (fill-pointer v)))) child) (loop - (unless (typep sheet 'sheet-parent-mixin) + (unless (typep sheet 'sheet-parent-mixin) (return nil)) (setq child (child-containing-position sheet new-x new-y)) (unless child @@ -402,7 +402,7 @@ :kind ,kind :modifier-state modifiers :pointer pointer))))) - ;; If we got an event for some mirrored child, go back to the + ;; If we got an event for some mirrored child, go back to the ;; top level sheet. (unless (graftp (sheet-parent mirrored-sheet)) (do* ((sheet mirrored-sheet) @@ -417,7 +417,7 @@ (map-sheet-position-to-parent sheet new-x new-y)) (setq sheet parent))) (let* ((v (port-trace-thing port)) - (exitted-a-window + (exitted-a-window (and (typep event 'pointer-exit-event) (not (eq (pointer-boundary-event-kind event) :inferior)))) (entered-from-child @@ -442,7 +442,7 @@ (map-sheet-position-to-child (aref v i) new-x new-y))) (unless (or (and pos (<= i pos)) (and (sheet-enabled-p (aref v i)) - (region-contains-position-p + (region-contains-position-p (sheet-region (aref v i)) new-x new-y))) (return i)))) 0))) @@ -481,7 +481,7 @@ (sheet (aref v (1- (fill-pointer v)))) child) (loop - (unless (typep sheet 'sheet-parent-mixin) + (unless (typep sheet 'sheet-parent-mixin) (return nil)) (setq child (child-containing-position sheet new-x new-y)) (unless child @@ -504,12 +504,12 @@ (defmethod distribute-event :before ((port basic-port) (event pointer-button-press-event)) (let ((pointer (pointer-event-pointer event))) - (setf (pointer-button-state pointer) + (setf (pointer-button-state pointer) (logior (pointer-button-state pointer) (pointer-event-button event))))) (defmethod distribute-event :before ((port basic-port) (event pointer-button-release-event)) (let ((pointer (pointer-event-pointer event))) - (setf (pointer-button-state pointer) + (setf (pointer-button-state pointer) (logandc2 (pointer-button-state pointer) (pointer-event-button event))))) ;;; @@ -539,7 +539,7 @@ (setf (port-keyboard-input-focus port) nil)) (defmethod distribute-event-1 ((port basic-port) (event window-event)) - (dispatch-event + (dispatch-event (window-event-mirrored-sheet event) event)) @@ -547,11 +547,11 @@ ;; Generate all the correct enter/exit events. (if (port-deep-mirroring port) (generate-deeply-mirrored-crossing-events port event) - (generate-crossing-events port event))) + (generate-crossing-events port event))) (defmethod distribute-event-1 :around ((port basic-port) (event pointer-event)) (let ((sheet (port-grabbing-sheet port))) - (if sheet + (if sheet (let ((event-sheet (event-sheet event)) (grab-sheet (sheet-mirrored-ancestor sheet))) ;; If the grabbing sheet is different from the sheet the @@ -584,13 +584,13 @@ (aref v (1- (fill-pointer v))))))) (dispatch-pointer-event-to-sheet port event sheet))) -(defmethod dispatch-pointer-event-to-sheet :before +(defmethod dispatch-pointer-event-to-sheet :before ((port basic-port) (event pointer-button-press-event) sheet) (let ((button (pointer-event-button event))) (when (and (eq (port-input-focus-selection port) :click-to-select) (eq button +pointer-left-button+)) (setf (port-keyboard-input-focus port) sheet)))) - + (defmethod dispatch-pointer-event-to-sheet ((port basic-port) (event event) sheet) (let ((event-type (class-name (class-of event))) (x (pointer-event-native-x event)) @@ -668,18 +668,18 @@ (handle-event (event-sheet event) event)) (defun local-event-loop (sheet) - (loop + (loop (process-event-locally sheet (event-read sheet)))) -(defun port-event-wait (port waiter +(defun port-event-wait (port waiter &key (wait-reason #+Genera si:*whostate-awaiting-user-input* #-Genera "CLIM Input") timeout) (cond (*multiprocessing-p* (assert (and port (port-alive-p port)) () "The port is not alive") - (process-wait-with-timeout wait-reason timeout waiter) + (process-wait-with-timeout wait-reason timeout waiter) (values)) - (t + (t ;; Single process, so run the event processing loop right here (process-next-event port :timeout timeout @@ -708,15 +708,15 @@ (defmethod initialize-event ((event ,event-class) &key ,@slot-names) ,@(mapcar #'(lambda (slot) (if (eq slot 'timestamp) - `(setf (slot-value event ',slot) + `(setf (slot-value event ',slot) (or ,slot (atomic-incf *event-timestamp*))) `(setf (slot-value event ',slot) ,slot))) slot-names)) (let ((old (assoc ',event-class *resourced-events*))) (unless old - (setq *resourced-events* + (setq *resourced-events* (append *resourced-events* - (list (list ',event-class ',resource-name + (list (list ',event-class ',resource-name ;; Allocates, misses, creates, deallocates #+meter-events ,@(list 0 0 0 0))))))) ;; When an event is in the event resource, we use the timestamp diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index 1b46dd1d..65d9bed0 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -1,6 +1,6 @@ ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadgets.lisp,v 1.59 1994/12/05 00:00:21 colin Exp $ +;; $fiHeader: gadgets.lisp,v 1.60 1995/05/17 19:49:07 colin Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -18,8 +18,8 @@ (disarmed-callback :initarg :disarmed-callback :initform nil :reader gadget-disarmed-callback) (active :initarg :active :accessor gadget-active-p) - (help-callback :initform nil - :initarg :help-callback + (help-callback :initform nil + :initarg :help-callback :accessor gadget-help-callback)) (:default-initargs :active t)) @@ -55,25 +55,25 @@ (unless (gadget-active-p gadget) (setf (gadget-active-p gadget) t) (note-gadget-activated (gadget-client gadget) gadget))) - + (defmethod note-gadget-activated ((client t) (gadget basic-gadget)) nil) - + (defmethod deactivate-gadget ((gadget basic-gadget)) (when (gadget-active-p gadget) (setf (gadget-active-p gadget) nil) (note-gadget-deactivated (gadget-client gadget) gadget))) - + (defmethod note-gadget-deactivated ((client t) (gadget basic-gadget)) nil) ;;; Value Gadgets -(defclass value-gadget (basic-gadget) +(defclass value-gadget (basic-gadget) ((value :initarg :value :initform nil) ; no accessor defined - see below - (value-changed-callback + (value-changed-callback :initarg :value-changed-callback :initform nil :reader gadget-value-changed-callback))) @@ -98,7 +98,7 @@ (value-changed-callback gadget (gadget-client gadget) (gadget-id gadget) value))) -(defmethod value-changed-callback :around +(defmethod value-changed-callback :around ((gadget value-gadget) (client t) (id t) value) (setf (slot-value gadget 'value) value) (let ((callback (gadget-value-changed-callback gadget))) @@ -115,7 +115,7 @@ (defclass action-gadget (basic-gadget) ((activate-callback :initarg :activate-callback :initform nil - :reader gadget-activate-callback))) + :reader gadget-activate-callback))) (defmethod activate-callback :around ((gadget action-gadget) (client t) (id t)) @@ -124,7 +124,7 @@ (invoke-callback-function callback gadget)) (call-next-method))) -(defmethod activate-callback +(defmethod activate-callback ((gadget action-gadget) (client t) (id t)) nil) @@ -137,7 +137,7 @@ :reader gadget-focus-in-callback))) (defmethod focus-out-callback :around - ((gadget focus-gadget) (client t) (id t)) + ((gadget focus-gadget) (client t) (id t)) (let ((callback (gadget-focus-out-callback gadget))) (when callback (invoke-callback-function callback gadget)) @@ -148,13 +148,13 @@ nil) (defmethod focus-in-callback :around - ((gadget focus-gadget) (client t) (id t)) + ((gadget focus-gadget) (client t) (id t)) (let ((callback (gadget-focus-in-callback gadget))) (when callback (invoke-callback-function callback gadget)) (call-next-method))) -(defmethod focus-in-callback +(defmethod focus-in-callback ((gadget focus-gadget) (client t) (id t)) nil) @@ -217,7 +217,7 @@ ;;; The intent is that the real implementations inherit from these -(defparameter *default-slider-label-text-style* +(defparameter *default-slider-label-text-style* (make-text-style :sans-serif :bold :small)) (defparameter *default-slider-range-label-text-style* (make-text-style :sans-serif :bold :very-small)) @@ -229,7 +229,7 @@ :reader slider-drag-callback) (decimal-places :initarg :decimal-places :reader slider-decimal-places) - (show-value-p :initarg :show-value-p + (show-value-p :initarg :show-value-p :accessor gadget-show-value-p) (min-label :initarg :min-label) (max-label :initarg :max-label) @@ -238,15 +238,18 @@ (number-of-quanta :initarg :number-of-quanta) (editable-p :initarg :editable-p :accessor gadget-editable-p)) (:default-initargs :value 0.0 + :decimal-places 0 :show-value-p nil :min-label nil :max-label nil - :range-label-text-style *default-slider-range-label-text-style* + :range-label-text-style + #+allegro nil + #-allegro *default-slider-range-label-text-style* :number-of-tick-marks 0 :number-of-quanta nil :editable-p t)) -(defmethod initialize-instance :after ((pane slider) +(defmethod initialize-instance :after ((pane slider) &key (decimal-places 0 places-p) &allow-other-keys) (declare (ignore decimal-places)) @@ -288,30 +291,30 @@ (defmethod (setf scroll-bar-size) :around (size (gadget scroll-bar)) (assert (and (<= (+ size (gadget-value gadget)) (gadget-max-value gadget)) - (> size 0)) + (> size 0)) (size) "Scroll bar size ~A out of range" size) (call-next-method size gadget)) -(defmethod (setf gadget-value) :around +(defmethod (setf gadget-value) :around (value (gadget scroll-bar) &key invoke-callback) (declare (ignore invoke-callback)) (assert (and (<= (+ value (scroll-bar-size gadget)) (gadget-max-value gadget)) - (>= value (gadget-min-value gadget))) + (>= value (gadget-min-value gadget))) (value) "Scroll bar value ~A out of range" value) (call-next-method value gadget)) ;;; Push-button -(defclass push-button - (action-gadget labelled-gadget-mixin) +(defclass push-button + (action-gadget labelled-gadget-mixin) ((show-as-default :initform nil :initarg :show-as-default :accessor push-button-show-as-default))) ;;; Toggle button -(defclass toggle-button +(defclass toggle-button (value-gadget labelled-gadget-mixin) ((indicator-type :initarg :indicator-type :initform :some-of :type (member :some-of :one-of) @@ -319,8 +322,8 @@ ;;; Menu button -(defclass menu-button - (value-gadget labelled-gadget-mixin) +(defclass menu-button + (value-gadget labelled-gadget-mixin) ((indicator-type :initarg :indicator-type :initform :some-of :reader gadget-indicator-type))) @@ -343,9 +346,9 @@ (columns :initarg :columns :initform nil :accessor gadget-columns))) ;;; Radio box [exclusive-choice] .. [inclusive-choice] -(defclass radio-box - (value-gadget row-column-gadget-mixin) - ((selections :initform nil +(defclass radio-box + (value-gadget row-column-gadget-mixin) + ((selections :initform nil :reader radio-box-selections) ;;--- think about this... (value :initform nil @@ -368,7 +371,7 @@ (assert (and frame framem) () "There must be both a frame and frame manager active") (when current-selection - (assert (member current-selection choices :test #'equal) + (assert (member current-selection choices :test #'equal) () "Radio box current-selection: ~S must be one of choices: ~S" current-selection choices)) @@ -385,7 +388,7 @@ (string ;; Create a button if the user supplied an abbreviation (let* ((value (equal current-selection choice)) - (button (make-pane 'toggle-button + (button (make-pane 'toggle-button :value value :label choice :indicator-type :one-of @@ -397,7 +400,7 @@ (setf (radio-box-current-selection rb) button))))))) (setf (slot-value rb 'selections) (nreverse selections)))) -(defmethod value-changed-callback :around +(defmethod value-changed-callback :around ((selection basic-gadget) (client radio-box) gadget-id value) (declare (ignore gadget-id)) ;;--- The following comment is wrong. Perhaps these should be :BEFORE @@ -406,16 +409,16 @@ ;; specified a callback function only :AROUNDs ever get executed. (when (eq value t) (setf (radio-box-current-selection client) selection) - (value-changed-callback + (value-changed-callback client (gadget-client client) (gadget-id client) selection)) (call-next-method)) ;;; Check-box -(defclass check-box - (value-gadget row-column-gadget-mixin) - ((selections :initform nil +(defclass check-box + (value-gadget row-column-gadget-mixin) + ((selections :initform nil :reader check-box-selections) ;;--- think about this... (value :initform nil @@ -455,7 +458,7 @@ (string ;; Create a button if the user supplied an abbreviation (let* ((value (member choice current-selection :test #'equal)) - (button (make-pane 'toggle-button + (button (make-pane 'toggle-button :value (and value t) :label choice :indicator-type :some-of @@ -467,7 +470,7 @@ (setf (car value) button))))))) (setf (slot-value cb 'selections) (nreverse selections)))) -(defmethod value-changed-callback :around +(defmethod value-changed-callback :around ((selection basic-gadget) (client check-box) gadget-id value) (declare (ignore gadget-id)) (if (eq value t) @@ -501,13 +504,13 @@ (macrolet ((radio-box-current-selection (form) (let ((button (gensym))) `(let ((,button ,form)) - (setq ,',current-selection + (setq ,',current-selection (append ,',current-selection (list ,button))) ,button))) (check-box-current-selection (form) (let ((button (gensym))) `(let ((,button ,form)) - (setq ,',current-selection + (setq ,',current-selection (append ,',current-selection (list ,button))) ,button)))) (let ((,choices (list ,@body))) @@ -519,12 +522,14 @@ ;;; Text edit ;;--- Do we want to specify a binding to commands? -(defclass text-field - (value-gadget focus-gadget action-gadget) - ((editable-p :initarg :editable-p :accessor gadget-editable-p)) +(defclass text-field + (value-gadget focus-gadget action-gadget) + ((editable-p :initarg :editable-p :accessor gadget-editable-p) + (echo-character :initarg :echo-character :initform nil + :reader text-field-echo-character)) (:default-initargs :editable-p t)) -(defclass text-editor (text-field) +(defclass text-editor (text-field) ((ncolumns :initarg :ncolumns :accessor gadget-columns) (nlines :initarg :nlines @@ -587,7 +592,7 @@ (max-height (space-requirement-max-height sr)) (desired-width (space-requirement-width sr)) (desired-height (space-requirement-height sr))) - (resize-sheet child + (resize-sheet child (if (>= max-width +fill+) (max width desired-width) (max desired-width max-width)) @@ -607,7 +612,7 @@ (let ((cw (- cright cleft)) (ch (- cbottom ctop))) (let ((x ox) (y oy)) - (when (and (< owidth cw) (<= cw width)) + (when (and (< owidth cw) (<= cw width)) (setq x cleft)) (when (and (< oheight ch) (<= ch height)) (setq y ctop)) @@ -635,20 +640,20 @@ (defmethod note-space-requirements-changed ((pane viewport) inner) (declare (ignore inner)) - (allocate-space - pane + (allocate-space + pane (bounding-rectangle-width pane) (bounding-rectangle-height pane))) ;;--- Work on this #+++ignore (defmethod note-sheet-region-changed :around ((viewport viewport) &key port-did-it) (declare (ignore port-did-it)) - (multiple-value-bind (changedp + (multiple-value-bind (changedp hscroll-bar hscroll-bar-enabled-p vscroll-bar vscroll-bar-enabled-p) (compute-dynamic-scroll-bar-values viewport) (if changedp - (update-dynamic-scroll-bars + (update-dynamic-scroll-bars viewport changedp hscroll-bar hscroll-bar-enabled-p vscroll-bar vscroll-bar-enabled-p) @@ -669,7 +674,7 @@ ; (let* ((contents (slot-value scroller 'contents)) ; (c-extent (viewport-contents-extent ; (pane-viewport contents)))) -; (multiple-value-bind (vx vy) +; (multiple-value-bind (vx vy) ; (window-viewport-position contents) ; (window-set-viewport-position ; contents @@ -693,10 +698,10 @@ ; (vscroll-bar (scroller-pane-vertical-scroll-bar scroller)) ; (scroll-bar-policy (scroller-pane-scroll-bar-policy scroller))) ; (if (eq scroll-bar-policy :dynamic) -; (multiple-value-bind (vwidth vheight) +; (multiple-value-bind (vwidth vheight) ; (bounding-rectangle-size scroller) -; (multiple-value-bind (cwidth cheight) -; (bounding-rectangle-size +; (multiple-value-bind (cwidth cheight) +; (bounding-rectangle-size ; (viewport-contents-extent (slot-value scroller 'viewport))) ; (let ((ohenp (sheet-enabled-p hscroll-bar)) ; (ovenp (sheet-enabled-p vscroll-bar)) @@ -738,7 +743,7 @@ :test #'eql :value-key #'identity :name-key #'princ-to-string)) - + (defclass list-pane (set-gadget-mixin value-gadget) ;;--- Should this be :ONE-OF/:SOME-OF, as radio boxes are? @@ -746,22 +751,38 @@ :accessor list-pane-mode) (visible-items :initarg :visible-items :reader gadget-visible-items)) (:default-initargs :mode :exclusive :visible-items nil)) - + (defun compute-list-pane-selected-items (sheet value) - (with-accessors ((items set-gadget-items) - (value-key set-gadget-value-key) + (with-accessors ((value-key set-gadget-value-key) (test set-gadget-test) (mode list-pane-mode) (name-key set-gadget-name-key)) sheet - (ecase mode - (:exclusive - (let ((x (find value items :test test :key value-key))) - (and x (list (funcall name-key x))))) - (:nonexclusive - (mapcar name-key - (remove-if-not #'(lambda (item) - (member (funcall value-key item) value :test test)) - items)))))) + (let* ((items (set-gadget-items sheet)) + (total-items (length items)) + (visible-items (or (gadget-visible-items sheet) + ;; what's the best default to assume here + 1))) + (multiple-value-bind (selected-items m n) + (ecase mode + (:exclusive + (let ((i (position value items :test test :key value-key))) + (and i + (values (list (elt items i)) i i)))) + (:nonexclusive + (let (selected-items m n) + (dotimes (i (length items)) + (let ((item (elt items i))) + (when (member (funcall value-key item) value :test test) + (push item selected-items) + (setq m (if m (min m i) i) + n (if n (max n i) i))))) + (when selected-items + (values (nreverse selected-items) m n))))) + (when selected-items + (values (mapcar name-key selected-items) + (max 0 (- n (1- visible-items))) + (min m (max 0 (- total-items visible-items))))))))) + (defun list-pane-selected-item-p (sheet item) (with-accessors ((items set-gadget-items) @@ -777,7 +798,7 @@ (member (funcall value-key item) value :test test))))) -(defclass option-pane (set-gadget-mixin +(defclass option-pane (set-gadget-mixin labelled-gadget-mixin value-gadget) ;;--- Should this be :ONE-OF/:SOME-OF, as radio boxes are? @@ -789,11 +810,11 @@ ;; Callbacks on widgets generate these events -(defclass gadget-event (event) +(defclass gadget-event (event) ((gadget :initarg :gadget :reader event-sheet))) -(defclass value-changed-gadget-event (gadget-event) +(defclass value-changed-gadget-event (gadget-event) ((value :initarg :value :reader event-value))) (defmethod handle-event ((gadget value-gadget) (event value-changed-gadget-event)) @@ -807,7 +828,7 @@ (activate-callback gadget (gadget-client gadget) (gadget-id gadget))) -(defclass drag-gadget-event (gadget-event) +(defclass drag-gadget-event (gadget-event) ((value :initarg :value :reader event-value))) (defmethod handle-event ((gadget value-gadget) (event drag-gadget-event)) @@ -825,6 +846,19 @@ (defmethod handle-event ((gadget focus-gadget) (event focus-in-gadget-event)) (focus-in-callback gadget (gadget-client gadget) (gadget-id gadget))) +;; armed/disarmed events + +(defclass armed-gadget-event (gadget-event) ()) + +(defmethod handle-event ((gadget basic-gadget) (event armed-gadget-event)) + (armed-callback gadget (gadget-client gadget) (gadget-id gadget))) + +(defclass disarmed-gadget-event (gadget-event) ()) + +(defmethod handle-event ((gadget basic-gadget) (event disarmed-gadget-event)) + (disarmed-callback gadget (gadget-client gadget) (gadget-id gadget))) + + (defun move-focus-to-gadget (gadget) (port-move-focus-to-gadget (port gadget) gadget)) diff --git a/silica/port.lisp b/silica/port.lisp index 21b31e39..cc48d8b7 100644 --- a/silica/port.lisp +++ b/silica/port.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: port.lisp,v 1.32 1993/09/07 21:46:48 colin Exp $ +;; $fiHeader: port.lisp,v 1.33 1994/12/05 00:00:27 colin Exp $ (in-package :silica) @@ -29,7 +29,7 @@ (defun find-port (&rest initargs &key (server-path *default-server-path*) &allow-other-keys) (declare (dynamic-extent initargs)) (map-over-ports #'(lambda (port) - (when (port-match port server-path) + (when (port-match port server-path) (return-from find-port port)))) (with-keywords-removed (initargs initargs '(:server-path)) (apply #'make-port :server-path server-path initargs))) @@ -53,7 +53,7 @@ (defun reset-ports () ;;--- Should this do more? (setq *ports* nil)) - (push `(:eval reset-ports) excl::*restart-actions*)) + (push `reset-ports excl::*restart-actions*)) (defun port-match (port server-path) (equal (port-server-path port) server-path)) @@ -82,7 +82,7 @@ (defmethod port-pointer ((port basic-port)) (with-slots (pointer grafts) port (or pointer - (setq pointer (make-instance 'standard-pointer + (setq pointer (make-instance 'standard-pointer :graft (find-graft :port port) :port port))))) @@ -135,15 +135,15 @@ (setq *ports* (delete port *ports*))) -(define-event-class port-terminated (window-manager-event) +(define-event-class port-terminated (window-manager-event) ((condition :initarg :condition :reader port-terminated-condition))) (defmethod port-terminated ((port basic-port) condition) - ;;--- Should mark it as dead + ;;--- Should mark it as dead (setq *ports* (delete port *ports*)) (dolist (graft (port-grafts port)) (dolist (sheet (sheet-children graft)) - (queue-event sheet (make-instance 'port-terminated + (queue-event sheet (make-instance 'port-terminated :condition condition :sheet sheet))))) @@ -158,7 +158,7 @@ (defgeneric graft-orientation (graft)) (defgeneric graft-units (graft)) -(defclass standard-graft +(defclass standard-graft (mirrored-sheet-mixin sheet-multiple-child-mixin sheet-transformation-mixin @@ -198,7 +198,7 @@ port) (make-instance (port-graft-class port) :port port - :orientation orientation + :orientation orientation :units units)) (defgeneric realize-graft (port graft)) diff --git a/silica/sheet.lisp b/silica/sheet.lisp index 864900de..46460bd9 100644 --- a/silica/sheet.lisp +++ b/silica/sheet.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sheet.lisp,v 1.38 1993/07/27 01:51:13 colin Exp $ +;; $fiHeader: sheet.lisp,v 1.39 1994/12/05 00:00:29 colin Exp $ (in-package :silica) @@ -82,7 +82,7 @@ ((children :initform nil :accessor sheet-children))) (defmethod sheet-adopt-child ((sheet sheet-multiple-child-mixin) child) - (setf (sheet-children sheet) + (setf (sheet-children sheet) ;; Preserve the order in which the sheets were adopted ;;--- This may have unwanted effects if the children overlap... (nconc (sheet-children sheet) (list child))) @@ -215,7 +215,7 @@ (and (sheet-enabled-p child) (multiple-value-call #'ltrb-overlaps-ltrb-p (bounding-rectangle* child) - (untransform-rectangle* + (untransform-rectangle* (sheet-transformation child) left top right bottom)))) (sheet-children sheet))))) @@ -244,11 +244,11 @@ (when (and (sheet-enabled-p child) (multiple-value-call #'ltrb-overlaps-ltrb-p (bounding-rectangle* child) - (untransform-rectangle* + (untransform-rectangle* (sheet-transformation child) left top right bottom))) (funcall function child)))))) -;;;; +;;;; (defclass sheet-identity-transformation-mixin () ()) @@ -256,7 +256,7 @@ +identity-transformation+) (defclass sheet-transformation-mixin () - ((transformation + ((transformation :initarg :transformation :initform +identity-transformation+ :accessor sheet-transformation) (cached-device-transformation :initform nil @@ -312,14 +312,14 @@ (defgeneric note-sheet-transformation-changed (sheet &key port-did-it)) (defmethod note-sheet-transformation-changed ((sheet basic-sheet) &key port-did-it) - (declare (ignore port-did-it)) + (declare (ignore port-did-it)) nil) (defgeneric invalidate-cached-regions (sheet)) (defmethod invalidate-cached-regions ((sheet basic-sheet)) nil) -(defmethod invalidate-cached-regions ((sheet sheet-transformation-mixin)) +(defmethod invalidate-cached-regions ((sheet sheet-transformation-mixin)) (let ((region (sheet-cached-device-region sheet))) (when region (if (eq region +nowhere+) ;it can happen... @@ -339,7 +339,7 @@ (defmethod invalidate-cached-transformations ((sheet basic-sheet)) nil) -(defmethod invalidate-cached-transformations ((sheet sheet-transformation-mixin)) +(defmethod invalidate-cached-transformations ((sheet sheet-transformation-mixin)) (let ((region (sheet-cached-device-region sheet))) (when region (if (eq region +nowhere+) ;it can happen... @@ -351,7 +351,7 @@ ;;--- In theory if this sheet has a mirror we don't need to do any more (unless (sheet-direct-mirror sheet) (mapc #'invalidate-cached-transformations (sheet-children sheet)))) - + ;;--- Check to see if the call to INVALIDATE-CACHED-REGIONS is really necessary. ;;--- CER thinks we do because regions depend on transformations. (defmethod note-sheet-transformation-changed :before ((sheet basic-sheet) &key port-did-it) @@ -415,7 +415,7 @@ (defmethod invalidate-cached-regions :before ((sheet sheet-with-medium-mixin)) (let ((medium (sheet-medium sheet))) - (when medium + (when medium (invalidate-cached-regions medium)))) (defmethod invalidate-cached-transformations :before ((sheet sheet-with-medium-mixin)) @@ -463,7 +463,7 @@ (defclass sheet-permanently-enabled-mixin () () (:default-initargs :enabled t)) -(defmethod initialize-instance :after ((sheet sheet-permanently-enabled-mixin) +(defmethod initialize-instance :after ((sheet sheet-permanently-enabled-mixin) &key enabled) (setf (sheet-enabled-p sheet) enabled)) @@ -493,7 +493,7 @@ (letf-globally (((port-grabbing-sheet port) sheet)) (call-next-method))) -(defmethod port-invoke-with-pointer-grabbed +(defmethod port-invoke-with-pointer-grabbed ((port basic-port) (sheet basic-sheet) continuation &key) (funcall continuation)) @@ -505,3 +505,11 @@ (declare (ignore cursor)) nil) +(defmethod port-remove-all-pointer-grabs ((port basic-port)) + nil) + +(defmethod port-remove-all-pointer-grabs :after ((port basic-port)) + (setf (port-grabbing-sheet port) nil)) + + + diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 57615adb..905836dc 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: test-suite.lisp,v 1.75 1994/12/05 00:00:46 colin Exp $ +;; $fiHeader: test-suite.lisp,v 1.76 1995/05/17 19:49:18 colin Exp $ (in-package :clim-user) @@ -558,7 +558,7 @@ people, shall not perish from the earth. (return-from lookup-result (third result)))) (or (equal region1 region2) :none))))) (formatting-table (stream :x-spacing " ") - (abbreviated-regions-column-headings regions stream 'region-contains-region-p) + (abbreviated-regions-column-headings regions stream 'region-intersects-region-p) (dolist (region1 regions) (formatting-row (stream) (formatting-cell (stream :align-x :right) diff --git a/tk-silica/last.lisp b/tk-silica/last.lisp index 1308c33c..f26af4a6 100644 --- a/tk-silica/last.lisp +++ b/tk-silica/last.lisp @@ -1,7 +1,7 @@ ;; -*- mode: common-lisp; package: system -*- ;; ;; -[Thu Apr 15 18:06:28 1993 by layer]- -;; +;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved. ;; @@ -20,18 +20,18 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: last.lisp,v 1.5 1993/09/17 19:06:58 cer Exp $ +;; $fiHeader: last.lisp,v 1.6 1994/12/05 00:01:46 colin Exp $ (in-package :system) (defvar system::*devel* nil) -(load-application +(load-application (load-patches "patch" (namestring - (merge-pathnames "update-clim-2.0" + (merge-pathnames ";update-clim;" excl::*library-pathname*))) :devel (locally (declare (special system::*devel*)) system::*devel*)) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index d551de54..088287e0 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-frames.lisp,v 1.67 1994/12/05 00:01:53 colin Exp $ +;; $fiHeader: xm-frames.lisp,v 1.68 1995/05/17 19:50:01 colin Exp $ (in-package :xm-silica) @@ -48,16 +48,19 @@ ;;-- This is because the :resize-width/height are true ;;-- ManagedSetChanged allows the widget to be resized. ;;-- Conversely querygeoetry will return bogus results otherwise. - (frobulate-menubars frame)) + (frobulate-mirrors frame)) (defmethod note-frame-layout-changed ((frame-manager motif-frame-manager) (frame t)) - (frobulate-menubars frame)) + (frobulate-mirrors frame)) -(defun frobulate-menubars (frame) +;; This gets around the problem with gadgets in different layouts +;; coming up the wrong size when the layout changes (cim 9/28/95) + +(defun frobulate-mirrors (frame) (flet ((fix-sheet (sheet) - (when (typep sheet 'motif-menu-bar) - (update-mirror-region (port sheet) sheet)))) - (declare (dynamic-extent #'fix-sheet)) + (when (or (typep sheet 'motif-menu-bar) + (typep sheet 'clim-stream-pane)) + (invalidate-cached-transformations sheet)))) (map-over-sheets #'fix-sheet (frame-top-level-sheet frame)))) ;;; Definitions of the individual classes @@ -165,8 +168,10 @@ (tk::set-values mirror :menu-help-widget button)) (unless flatp (set-button-mnemonic sheet button (getf options :mnemonic)) - (when keystroke - (set-button-accelerator-from-keystroke sheet button keystroke)))) + (let ((accelerator-text (getf options :accelerator-text))) + (when (or keystroke accelerator-text) + (set-button-accelerator-from-keystroke + sheet button keystroke accelerator-text))))) (make-command-button (parent menu keystroke item command-table) (let ((command-name (car (command-menu-item-value item))) @@ -279,8 +284,10 @@ (make-menu-for-command-table top-command-table mirror)) mirror)) +;; get rid of get-accelerator-text and clean this function up! + (defmethod set-button-accelerator-from-keystroke - ((menubar motif-menu-bar) button keystroke) + ((menubar motif-menu-bar) button keystroke accelerator-text) (when keystroke (let ((modifiers (cdr keystroke))) (record-accelerator menubar keystroke) @@ -289,23 +296,29 @@ (dolist (modifier modifiers) (setq accel-text (concatenate 'string - (ecase modifier + (case modifier + (:shift "Shift+") (:control "Ctrl+") (:meta "Alt+") (:super "Super+") - (:hyper "Hyper+")) + (:hyper "Hyper+") + (t "")) accel-text)) (setq accel (concatenate 'string - (ecase modifier - (:control "Ctrl") - (:meta "Mod1") - (:super "Mod2") - (:hyper "Mod3")) + (case modifier + (:shift "Shift ") + (:control "Ctrl ") + (:meta "Mod1 ") + (:super "Mod2 ") + (:hyper "Mod3 ") + (t "")) accel))) - (tk::set-values button - :accelerator accel - :accelerator-text accel-text))))) + (tk::set-values button :accelerator accel) + (setq accelerator-text (or accelerator-text + accel-text))))) + (when accelerator-text + (tk::set-values button :accelerator-text accelerator-text))) (defun display-motif-help (widget framem documentation) (frame-manager-notify-user diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index bd7dd65c..1ff4b678 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.87 1994/12/05 00:01:56 colin Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.88 1995/05/17 19:50:04 colin Exp $ (in-package :xm-silica) @@ -152,6 +152,21 @@ (allocate-event 'activate-gadget-event :gadget sheet))) + +;;; Motif widgets that support armed/disarmed callbacks + +(defclass motif-arm-disarm-pane () ()) + +(defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-arm-disarm-pane) (widget t)) + (tk::add-callback widget + :arm-callback + 'queue-armed-event + sheet) + (tk::add-callback widget + :disarm-callback + 'queue-disarmed-event + sheet)) + ;;; Label (defclass motif-label-pane (label-pane xt-leaf-pane motif-labelled-gadget) @@ -190,6 +205,7 @@ (defclass motif-push-button (push-button motif-action-pane + motif-arm-disarm-pane motif-labelled-gadget xt-leaf-pane) ()) @@ -201,35 +217,6 @@ (sheet motif-push-button)) 'tk::xm-push-button) -(defmethod add-sheet-callbacks - ((port motif-port) (sheet t) (widget tk::xm-my-drawing-area)) - (tk::add-callback widget - :expose-callback - 'sheet-mirror-exposed-callback - sheet) - (tk::add-callback widget - :input-callback - 'sheet-mirror-input-callback - sheet) - (tk::add-event-handler widget - '(:enter-window - :leave-window - :pointer-motion-hint - :pointer-motion - :button1-motion - :button2-motion - :button3-motion - :button4-motion - :button5-motion - :button-motion - ) - 1 - 'sheet-mirror-event-handler - sheet)) - - -;;-- This is identical to the method for label - ;;; How we deal with the default button in bulletin boards... ;;; ;;; The problem is that as soon as motif sees a default button in a @@ -255,8 +242,6 @@ ;;; ;;; cim (8/29/94) - - (defun find-bulletin-board (widget) (and widget (if (typep widget 'tk::xm-bulletin-board) @@ -290,7 +275,6 @@ (when bb (tk::set-values bb :default-button widget))))) - (defmethod initialize-mirror :after ((port motif-port) parent parent-widget @@ -299,6 +283,33 @@ (declare (ignore parent parent-widget)) (tk::set-values widget :default-button widget)) +;; drawing area + +(defmethod add-sheet-callbacks + ((port motif-port) (sheet t) (widget tk::xm-my-drawing-area)) + (tk::add-callback widget + :expose-callback + 'sheet-mirror-exposed-callback + sheet) + (tk::add-callback widget + :input-callback + 'sheet-mirror-input-callback + sheet) + (tk::add-event-handler widget + '(:enter-window + :leave-window + :pointer-motion-hint + :pointer-motion + :button1-motion + :button2-motion + :button3-motion + :button4-motion + :button5-motion + :button-motion + ) + 1 + 'sheet-mirror-event-handler + sheet)) ;;; range pane mixin @@ -329,14 +340,13 @@ (multiple-value-bind (smin smax) (gadget-range* gadget) (multiple-value-bind - (mmin mmax) - (tk::get-values mirror :minimum :maximum) - (with-no-value-changed-callbacks - (tk::set-values mirror - :value - (fix-coordinate - (compute-symmetric-value - smin smax nv mmin mmax))))))))) + (mmin mmax value) + (tk::get-values mirror :minimum :maximum :value) + (let ((nv (fix-coordinate + (compute-symmetric-value smin smax nv mmin mmax)))) + (unless (eql value nv) + (with-no-value-changed-callbacks + (tk::set-values mirror :value nv))))))))) ;;; @@ -376,7 +386,32 @@ (tk::add-callback widget :drag-callback 'queue-drag-event - sheet)) + sheet) + (tk::add-callback widget + :value-changed-callback + 'quantize-slider-value + sheet)) + +(defun quantize-slider-value (widget sheet) + (when (slot-value sheet 'silica::number-of-quanta) + (multiple-value-bind (scale-multiple value mmax show-value) + (tk::get-values widget :scale-multiple :value :maximum :show-value) + (let ((nv (* scale-multiple (round value scale-multiple)))) + ;; this hack is to fix a bug in Motif where setting the value + ;; of the slider will move the slider to the correct rounded + ;; position but not the displayed value. This forces the value + ;; to change so that the second set-values moves both the + ;; slider and the displayed value (cim 9/19/95) + (when (and show-value (eql nv value)) + (tk::set-values widget :value (if (eql value mmax) + (1- value) + (1+ value)))) + (tk::set-values widget :value nv))))) + +(defmethod (setf gadget-value) :after + (nv (gadget motif-slider) &key invoke-callback) + (declare (ignore nv invoke-callback)) + (quantize-slider-value (sheet-mirror gadget) gadget)) (defmethod find-widget-class-and-name-for-sheet ((port motif-port) (parent t) @@ -394,11 +429,12 @@ (let ((mmin 0) (mmax 1000) (decimal-points 0) - (decimal-places (slider-decimal-places sheet))) + (decimal-places (slider-decimal-places sheet)) + (quanta (slot-value sheet 'silica::number-of-quanta))) (cond ((and (zerop decimal-places) (typep smin '(signed-byte 32)) (typep smax '(signed-byte 32))) - (setq mmin smin mmax smax decimal-points 0)) + (setq mmin smin mmax smax decimal-points 0)) ;; Real case (t (setq smin (float smin) smax (float smax)) @@ -407,6 +443,7 @@ mmax (fix-coordinate (* scaling smax)) decimal-points decimal-places)))) + (assert (and (typep mmin '(signed-byte 32)) (typep mmax '(signed-byte 32)))) @@ -415,11 +452,67 @@ (list :minimum mmin :maximum mmax :decimal-points decimal-points) + (and quanta + (list :scale-multiple + (max 1 (floor (- mmax mmin) quanta)))) (and value (list :value (fix-coordinate (compute-symmetric-value smin smax value mmin mmax))))))))) +(defmethod realize-mirror :around ((port motif-port) (pane motif-slider)) + (let* ((mirror (call-next-method)) + (scale-orientation (gadget-orientation pane)) + (ticks (slot-value pane 'silica::number-of-tick-marks)) + (min-label (slot-value pane 'silica::min-label)) + (max-label (slot-value pane 'silica::max-label)) + (initargs (remove-keywords + (find-widget-resource-initargs-for-sheet port pane) + '(:font-list))) + (font-list (text-style-mapping + port + (or (slot-value pane 'silica::range-label-text-style) + (sheet-text-style port pane)))) + (children nil) + (tick-long-dimension (tk::font-height font-list)) + (tick-short-dimension 8) + tick-orientation tick-width tick-height + first-label second-label) + (case scale-orientation + (:vertical + (setq tick-orientation :horizontal + tick-width tick-long-dimension + tick-height tick-short-dimension + first-label max-label second-label min-label)) + (:horizontal + (setq tick-orientation :vertical + tick-width tick-short-dimension + tick-height tick-long-dimension + first-label min-label second-label max-label))) + (when first-label + (push (apply #'make-instance 'tk::xm-label + :parent mirror :managed nil + :label-string first-label + :font-list font-list + initargs) + children)) + (dotimes (i ticks) + (push (apply #'make-instance 'tk::xm-separator + :orientation tick-orientation + :width tick-width :height tick-height + :parent mirror :managed nil + initargs) + children)) + (when second-label + (push (apply #'make-instance 'tk::xm-label + :parent mirror :managed nil + :label-string second-label + :font-list font-list + initargs) + children)) + (tk::manage-children children) + mirror)) + (defmethod (setf gadget-show-value-p) :after (nv (sheet motif-slider)) (when (sheet-direct-mirror sheet) (tk::set-values (sheet-direct-mirror sheet) :show-value nv))) @@ -435,17 +528,17 @@ (sx sy swidth sheight) (tk::widget-best-geometry (sheet-direct-mirror m)) (declare (ignore sx sy)) - (let ((fudge 16)) + (let ((fudge 64)) (ecase (gadget-orientation m) (:vertical (make-space-requirement :width swidth :min-height fudge - :height (max (* 2 fudge) sheight) + :height (max fudge sheight) :max-height +fill+)) (:horizontal (make-space-requirement :height sheight :min-width fudge - :width (max (* 2 fudge) swidth) + :width (max fudge swidth) :max-width +fill+)))))) ;;; Scroll-Bar @@ -478,15 +571,17 @@ (defmethod change-scroll-bar-values ((sb motif-scroll-bar) &key slider-size - value line-increment) + value + line-increment + (page-increment slider-size)) (let ((mirror (sheet-direct-mirror sb))) (when mirror - (multiple-value-bind - (real-value real-size line-increment) - (compute-new-scroll-bar-values sb value slider-size line-increment) + (multiple-value-bind (value slider-size line-increment page-increment) + (compute-new-scroll-bar-values + sb value slider-size line-increment page-increment) (tk::set-values mirror - :increment line-increment :page-increment real-size - :slider-size real-size :value real-value))))) + :increment line-increment :page-increment page-increment + :slider-size slider-size :value value))))) (defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-scroll-bar) (widget t)) (tk::add-callback widget @@ -635,13 +730,21 @@ ;;;; text field +;; text-fields no longer inherit from motif-value pane because we have +;; special value handling for password type entry fields. (cim 5/25/95) + (defclass motif-text-field (motif-losing-focus-callback-pane motif-value-changed-callback-pane - motif-value-pane motif-action-pane text-field xt-leaf-pane) - ()) + ()) + +(defmethod text-field-echoed-value ((sheet motif-text-field) value) + (let ((echo-character (text-field-echo-character sheet))) + (if echo-character + (make-string (length value) :initial-element echo-character) + value))) (defmethod find-widget-class-and-name-for-sheet ((port motif-port) (parent t) @@ -655,7 +758,8 @@ (value gadget-value)) sheet (append (and (not editable) '(:cursor-position-visible nil)) `(:editable ,editable) - (and value `(:value ,value))))) + (and value `(:value + ,(text-field-echoed-value sheet value)))))) (defmethod gadget-current-selection ((tf motif-text-field)) (let ((m (sheet-direct-mirror tf))) @@ -664,6 +768,44 @@ (and (not (zerop x)) (ff:char*-to-string x)))))) +(defmethod (setf gadget-value) :after + (nv (gadget motif-text-field) &key invoke-callback) + (declare (ignore invoke-callback)) + (let ((m (sheet-direct-mirror gadget)) + (ev (text-field-echoed-value gadget nv))) + (when (and m (not (equal ev + (tk::get-values m :value)))) + (with-no-value-changed-callbacks + (tk::set-values m :value ev))))) + +(defmethod add-sheet-callbacks :after + ((port motif-port) (sheet motif-text-field) (widget t)) + (tk::add-callback widget + :modify-verify-callback + 'text-field-modify-verify-callback + sheet)) + +(defmethod text-field-modify-verify-callback (widget callback-struct sheet) + (declare (ignore widget)) + (unless *dont-invoke-callbacks* + (let* ((text-block (tk::xm-text-field-callback-struct-text callback-struct)) + (length (tk::xm-text-block-rec-length text-block)) + (ptr (tk::xm-text-block-rec-ptr text-block)) + (text (if (zerop length) + "" + (ff:char*-to-string ptr))) + (start-pos (tk::xm-text-field-callback-struct-start-pos callback-struct)) + (end-pos (tk::xm-text-field-callback-struct-end-pos callback-struct))) + (with-slots (silica::value) sheet + (setf silica::value + (concatenate + 'string + (subseq silica::value 0 start-pos) + text + (subseq silica::value end-pos)))) + (unless (zerop length) + (setf (tk::xm-text-block-rec-ptr text-block) + (ff:string-to-char* (text-field-echoed-value sheet text))))))) ;;; New definitions to support specifying width and height in terms of @@ -741,19 +883,6 @@ (* 2 (+ margin highlight shadow)))) -#+ignore -(defmethod add-sheet-callbacks :after - ((port motif-port) (sheet motif-text-field) (widget t)) - (tk::add-callback widget - :modify-verify-callback - 'queue-modify-verify-event - sheet)) - -#+ignore -(defmethod queue-modify-verify-event (widget doit sheet) - (format excl:*initial-terminal-io* "~&~s,~s,~s" widget doit sheet)) - - ;;; @@ -850,6 +979,7 @@ (defclass motif-toggle-button (motif-labelled-gadget motif-value-changed-callback-pane + motif-arm-disarm-pane toggle-button xt-leaf-pane) ()) @@ -1207,36 +1337,37 @@ (mode list-pane-mode) (visible-items gadget-visible-items) (name-key set-gadget-name-key)) sheet - (let ((selected-items - (compute-list-pane-selected-items sheet value)) - (scroll-mode - (let ((p (sheet-parent sheet))) - (and (typep p 'motif-scroller-pane) - (silica::scroller-pane-scroll-bar-policy p))))) - `(:list-size-policy - #-ignore - ,(case scroll-mode - (:vertical :variable) - (t :constant)) - #+ignore ;; this one required for buggy pre motif-1.2.4 - ,(case scroll-mode - ((:horizontal t :both) :constant) - (t :variable)) - :scroll-bar-display-policy - ,(case scroll-mode - ((:horizontal :vertical t :both) :static) - (t :as-needed) - :as-needed) - ,@(and selected-items - `(:selected-item-count ,(length selected-items) - :selected-items ,selected-items)) - :selection-policy - ,(ecase mode - (:exclusive :browse-select) - (:nonexclusive :multiple-select)) - ,@(and visible-items `(:visible-item-count ,visible-items)) - :items ,(mapcar name-key items) - :item-count ,(length items))))) + (multiple-value-bind (selected-items m n) + (compute-list-pane-selected-items sheet value) + (let ((scroll-mode + (let ((p (sheet-parent sheet))) + (and (typep p 'motif-scroller-pane) + (silica::scroller-pane-scroll-bar-policy p))))) + `(:list-size-policy + #-ignore + ,(case scroll-mode + (:vertical :variable) + (t :constant)) + #+ignore ;; this one required for buggy pre motif-1.2.4 + ,(case scroll-mode + ((:horizontal t :both) :constant) + (t :variable)) + :scroll-bar-display-policy + ,(case scroll-mode + ((:horizontal :vertical t :both) :static) + (t :as-needed) + :as-needed) + ,@(and selected-items + `(:selected-item-count ,(length selected-items) + :selected-items ,selected-items + :top-item-position ,(1+ (min m n)))) + :selection-policy + ,(ecase mode + (:exclusive :browse-select) + (:nonexclusive :multiple-select)) + ,@(and visible-items `(:visible-item-count ,visible-items)) + :items ,(mapcar name-key items) + :item-count ,(length items)))))) (defmethod (setf set-gadget-items) :after (items (gadget motif-list-pane)) ;;---- What should this do about selected items and the value etc etc @@ -1286,13 +1417,18 @@ (defmethod (setf gadget-value) :after (nv (l motif-list-pane) &key invoke-callback) (declare (ignore invoke-callback)) - (when (sheet-direct-mirror l) - (let ((selected-items - (compute-list-pane-selected-items l nv))) - (with-no-value-changed-callbacks - (tk::set-values (sheet-direct-mirror l) - :selected-item-count (length selected-items) - :selected-items selected-items))))) + (let ((mirror (sheet-direct-mirror l))) + (when mirror + (multiple-value-bind (selected-items m n) + (compute-list-pane-selected-items l nv) + (let ((position (tk::get-values mirror :top-item-position))) + (with-no-value-changed-callbacks + (tk::set-values mirror + :top-item-position (if selected-items + (1+ (min n (max m (1- position)))) + position) + :selected-item-count (length selected-items) + :selected-items selected-items))))))) ;;; Option buttons @@ -1546,6 +1682,7 @@ (name :select-file) directory pattern + default background foreground text-style @@ -1579,6 +1716,9 @@ (when pattern (tk::set-values dialog :pattern pattern)) + (when default + (tk::set-values dialog :dir-spec default)) + (when directory-list-label (tk::set-values dialog :dir-list-label-string directory-list-label)) @@ -1970,6 +2110,16 @@ (when (typep m 'xt::xt-root-class) (tk::set-values m :font-list (text-style-mapping port text-style)))) +(defmethod silica::port-set-pane-background ((port motif-port) pane m (ink color)) + (when (typep m 'xt::xt-root-class) + (with-sheet-medium (medium pane) + ;; we save and restore the foreground because xm_change_color + ;; will recalculate the foreground as well as the shadow colors + ;; and we want the latter but not the former (cim 9/21/95) + (let ((fg (tk::get-values m :foreground))) + (tk::xm_change_color m (decode-color ink medium)) + (tk::set-values m :foreground fg))))) + (defmethod find-widget-resource-initargs-for-sheet :around ((port motif-port) (sheet t) &key text-style) (let ((initargs (call-next-method)) diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index bbcb45fc..96c0d0ef 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -1,5 +1,5 @@ ;; -*- mode: common-lisp; package: xm-silica -*- -;; +;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. ;; @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.lisp,v 1.42 1993/12/07 05:34:27 colin Exp $ +;; $fiHeader: xm-silica.lisp,v 1.43 1994/12/05 00:02:00 colin Exp $ (in-package :xm-silica) @@ -75,7 +75,7 @@ 'clim-internals::menu-frame) '(:override-redirect t)))) (call-next-method)) - (values class `(:keyboard-focus-policy + (values class `(:keyboard-focus-policy ,(ecase (port-input-focus-selection port) (:click-to-select :explicit) (:sheet-under-pointer :pointer)) @@ -95,7 +95,7 @@ (my-drawing-area-query-geometry widget intended desired)) (defun setup-mda () - (tk::initializemydrawingareaquerygeometry + (tk::initializemydrawingareaquerygeometry (ff:register-function 'my-drawing-area-query-geometry-stub))) (setup-mda) @@ -120,7 +120,7 @@ (when (and (logtest rm x11:cwheight) (logtest rm x11:cwwidth)) (return-from my-drawing-area-query-geometry tk::xt-geometry-yes)) - + (setf (tk::xt-widget-geometry-width desired) (fix-coordinate width) (tk::xt-widget-geometry-height desired) (fix-coordinate height) (tk::xt-widget-geometry-request-mode desired) (logior x11:cwwidth x11:cwheight))) @@ -149,7 +149,7 @@ (with-slots (clim-internals::plist) cursor (setf (getf clim-internals::plist :input-widget) input-widget) (tk::add-callback input-widget - :input-callback + :input-callback 'sheet-mirror-input-callback sheet) (tk::add-event-handler input-widget @@ -158,7 +158,15 @@ 'sheet-mirror-event-handler sheet)))))) -(defmethod port-note-cursor-change :after +(defmethod note-sheet-degrafted :after ((sheet clim-stream-sheet)) + (let* ((cursor (stream-text-cursor sheet)) + (plist (and cursor + (slot-value cursor 'clim-internals::plist))) + (input-widget (getf plist :input-widget))) + (when input-widget + (tk::destroy-widget input-widget)))) + +(defmethod port-note-cursor-change :after ((port motif-port) cursor stream (type (eql 'cursor-active)) old new) (declare (ignore stream old)) (let* ((plist (slot-value cursor 'clim-internals::plist)) diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp index 7becf1a3..4e5ce012 100644 --- a/tk-silica/xt-gadgets.lisp +++ b/tk-silica/xt-gadgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-gadgets.lisp,v 1.40 1994/12/05 00:02:03 colin Exp $ +;; $fiHeader: xt-gadgets.lisp,v 1.41 1995/05/17 19:50:11 colin Exp $ (in-package :xm-silica) @@ -65,41 +65,30 @@ (integer (make-device-color palette c)))) (defmethod find-widget-resource-initargs-for-sheet - ((port xt-port) (sheet sheet-with-resources-mixin) &key) - (let ((background (pane-background sheet)) - (foreground (pane-foreground sheet))) + ((port xt-port) (sheet sheet-with-resources-mixin) + &key background foreground) + (let ((bg (or background (pane-background sheet) *default-pane-background*)) + (fg (or foreground (pane-foreground sheet) *default-pane-foreground*))) (with-sheet-medium (medium sheet) (let ((palette (medium-palette medium))) - `(,@(when background + `(,@(when bg (decode-gadget-background medium sheet - (ensure-color background palette))) - ,@(when foreground + (ensure-color bg palette))) + ,@(when fg (decode-gadget-foreground medium sheet - (ensure-color foreground palette)))))))) + (ensure-color fg palette)))))))) (defmethod find-widget-resource-initargs-for-sheet - ((port xt-port) (sheet t) &key) + ((port xt-port) (sheet t) &key background foreground) (let* ((resources (get-application-resources port)) - (background (or (getf resources :background) *default-pane-background*)) - (foreground (or (getf resources :foreground) *default-pane-foreground*)) + (bg (or background (getf resources :background) *default-pane-background*)) + (fg (or foreground (getf resources :foreground) *default-pane-foreground*)) (palette (port-default-palette port))) - `(:background ,(decode-color-in-palette (ensure-color background palette) + `(:background ,(decode-color-in-palette (ensure-color bg palette) palette) - :foreground ,(decode-color-in-palette (ensure-color foreground palette) + :foreground ,(decode-color-in-palette (ensure-color fg palette) palette)))) -(defmethod find-widget-resource-initargs-for-sheet :around - ((port xt-port) (sheet t) &key foreground background) - (let ((initargs (call-next-method)) - (palette (port-default-palette port))) - (when foreground - (setf (getf initargs :foreground) - (decode-color-in-palette (ensure-color foreground palette) palette))) - (when background - (setf (getf initargs :background) - (decode-color-in-palette (ensure-color background palette) palette))) - initargs)) - (defmethod decode-gadget-background (medium sheet ink) (declare (ignore sheet)) (let ((pixel (decode-color ink medium))) @@ -231,14 +220,17 @@ (compute-symmetric-value 0 1000 value smin smax ))) -(defun compute-new-scroll-bar-values (scroll-bar value slider-size line-increment) +(defun compute-new-scroll-bar-values (scroll-bar value slider-size line-increment + &optional (page-increment slider-size)) (values (and value (convert-scroll-bar-value-out scroll-bar value)) (and slider-size (max 1 (convert-scroll-bar-value-out scroll-bar slider-size))) (and line-increment - (max 1 (convert-scroll-bar-value-out scroll-bar line-increment))))) + (max 1 (convert-scroll-bar-value-out scroll-bar line-increment))) + (and page-increment + (max 1 (convert-scroll-bar-value-out scroll-bar page-increment))))) (defun wait-for-callback-invocation (port predicate &optional (whostate "Waiting for callback")) @@ -339,14 +331,9 @@ (let ((key (car keystroke))) (let ((x (assoc key *funny-accelerator-characters* :test #'member))) - (if x - (values (if olit - (format nil "<~A>" (second x)) - (format nil "<Key>~A" (second x))) - (format nil "~A" key)) - (values (if olit - (format nil "<~A>" key) - (format nil "<Key>~A" key)) - (format nil "~A" key)))))) + (values (format nil + (if olit "<~A>" "<Key>~A") + (if x (second x) key)) + (format nil "~:@(~A~)" key))))) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 1a150b65..8873b3ad 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.85 1994/12/05 00:02:06 colin Exp $ +;; $fiHeader: xt-graphics.lisp,v 1.86 1995/05/17 19:50:15 colin Exp $ (in-package :tk-silica) @@ -72,6 +72,7 @@ (defclass xt-medium (basic-medium) ((drawable :initform nil) + (palette :initform nil) ;; alist of (palette . ink-table) for non-current palettes (ink-tables :initform nil) (ink-table :initform nil) @@ -91,6 +92,17 @@ sheet (sheet-mirror sheet)))))) +(defmethod medium-palette ((medium xt-medium)) + (with-slots (palette sheet) medium + (or palette + (setf palette + (let ((frame (pane-frame sheet))) + (if frame + (frame-palette frame) + (port-default-palette (port medium)))))))) + + + ;;; Palette handling (defclass xt-palette (basic-palette) @@ -119,12 +131,6 @@ :white-pixel (x11:xwhitepixel display screen) :black-pixel (x11:xblackpixel display screen)))) -(defmethod medium-palette ((medium xt-medium)) - (let ((frame (pane-frame (medium-sheet medium)))) - (if frame - (frame-palette frame) - (port-default-palette (port medium))))) - (defmethod update-medium-ink-table ((medium xt-medium)) (let ((palette (medium-palette medium))) (with-slots (ink-table ink-tables) medium @@ -147,6 +153,8 @@ 'silica::sheet-with-medium-mixin) (sheet-medium sheet)))) (when medium + ;; invalidate the medium's palette cache + (setf (slot-value medium 'palette) nil) (update-medium-ink-table medium) (repaint-sheet sheet +everywhere+)))) (frame-top-level-sheet frame))))) @@ -349,8 +357,8 @@ (defmethod deallocate-medium :after (port (medium xt-medium)) (declare (ignore port)) - (with-slots (drawable) medium - (setf drawable nil))) + (with-slots (drawable palette) medium + (setf drawable nil palette nil))) (defmethod fetch-medium-drawable (sheet (mirror tk::xt-root-class)) (declare (ignore sheet)) @@ -369,9 +377,10 @@ (defmethod degraft-medium :after ((medium xt-medium) (port xt-port) sheet) (declare (ignore sheet)) - (with-slots (ink-table ink-tables indirect-inks drawable) + (with-slots (ink-table ink-tables indirect-inks drawable palette) medium (setf drawable nil + palette nil indirect-inks nil (medium-sheet medium) nil) (dolist (entry ink-tables) @@ -610,14 +619,46 @@ (defmethod decode-ink-1 ((ink standard-opacity) (medium xt-medium)) (decode-ink-opacity ink medium)) -(defmethod decode-ink-opacity (opacity (medium xt-medium)) +(defmethod decode-ink-1 ((ink composite-in) (medium xt-medium)) + (let ((color +foreground-ink+) + (opacity nil) + (pattern nil)) + (map nil + #'(lambda (ink) + (typecase ink + (opacity (setq opacity ink)) + (pattern (setq pattern ink)) + (t (setq color ink)))) + (slot-value ink 'clim-utils::designs)) + (cond + ;; compose-in of patterns we treat as stencils + (pattern + (multiple-value-bind (pixmap format pixels) + (pixmap-from-pattern pattern medium :bitmap) + (declare (ignore format pixels)) + (let* ((drawable (or (slot-value medium 'drawable) + (tk::display-root-window + (port-display (port (medium-sheet medium)))))) + (gc (make-instance 'ink-gcontext :drawable drawable))) + (setf (tk::gcontext-stipple gc) pixmap + (tk::gcontext-fill-style gc) :stippled + (tk::gcontext-foreground gc) (decode-color color medium) + (tk::gcontext-background gc) 0) + gc))) + (opacity + (decode-ink-opacity opacity medium color)) + (t + (decode-ink-1 color medium))))) + +(defmethod decode-ink-opacity (opacity (medium xt-medium) + &optional (color +foreground-ink+)) (with-slots (sheet drawable) medium (let* ((port (port sheet)) (display (port-display port)) (drawable (or drawable (tk::display-root-window display))) (new-gc (make-instance 'ink-gcontext :drawable drawable))) - (setf (tk::gcontext-foreground new-gc) (decode-color +foreground-ink+ medium) + (setf (tk::gcontext-foreground new-gc) (decode-color color medium) (tk::gcontext-stipple new-gc) (decode-stipple (opacity-value opacity) port) (tk::gcontext-fill-style new-gc) :stippled) new-gc))) @@ -893,7 +934,7 @@ layer-nplanes (total-nplanes 0)) (dolist (layer layers) - (let ((nplanes (floor (log layer 2)))) + (let ((nplanes (ceiling (log layer 2)))) (push nplanes layer-nplanes) (incf total-nplanes nplanes))) (multiple-value-bind (pixels masks) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 2473d0fc..39809a97 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.95 1994/12/05 00:02:12 colin Exp $ +;; $fiHeader: xt-silica.lisp,v 1.96 1995/05/17 19:50:21 colin Exp $ (in-package :xm-silica) @@ -196,18 +196,23 @@ port (make-text-style :stand-in-for-undefined-style :roman 10))) (flet ((font->text-style (font family) (let* ((tokens (disassemble-x-font-name font)) - (italic (member (fifth tokens) '("i" "o") :test #'equalp)) - (bold (equalp (fourth tokens) "Bold")) + (italic (member (nth 4 tokens) '("i" "o") :test #'equalp)) + (bold (equalp (nth 3 tokens) "bold")) (face (if italic (if bold '(:bold :italic) :italic) (if bold :bold :roman))) - (designed-point-size (parse-integer (ninth tokens))) - (designed-y-resolution (parse-integer (nth 10 tokens))) - (point-size (* (float designed-point-size) - (/ designed-y-resolution - screen-pixels-per-inch))) - (size (/ point-size 10))) - (make-text-style family face size)))) + (pixel-size (parse-integer (nth 7 tokens))) + (point-size (parse-integer (nth 8 tokens))) + (y-resolution (parse-integer (nth 10 tokens))) + (average-width (parse-integer (nth 12 tokens))) + (corrected-point-size (* (float point-size) + (/ y-resolution + screen-pixels-per-inch)))) + (unless (and (not *use-scalable-fonts*) + (or (eql pixel-size 0) + (eql point-size 0) + (eql average-width 0))) + (make-text-style family face (/ corrected-point-size 10)))))) (dolist (family-stuff *xt-font-families*) (let ((family (car family-stuff))) (dolist (font-pattern (cdr family-stuff)) @@ -217,9 +222,10 @@ (let ((text-style (font->text-style xfont family))) ;; prefer first font satisfying this text style, so ;; don't override if we've already defined one. - (unless (text-style-mapping-exists-p - port text-style *standard-character-set* t) - (setf (text-style-mapping port text-style) xfont)))))) + (when text-style + (unless (text-style-mapping-exists-p + port text-style *standard-character-set* t) + (setf (text-style-mapping port text-style) xfont))))))) ;; Now build the logical size alist for the family )) (let (temp) @@ -1479,6 +1485,22 @@ the geometry of the children. Instead the parent has control. ")) (allocate-event 'focus-in-gadget-event :gadget sheet)))) +(defmethod queue-armed-event (widget sheet) + (declare (ignore widget)) + (unless *dont-invoke-callbacks* + (distribute-event + (port sheet) + (allocate-event 'armed-gadget-event + :gadget sheet)))) + +(defmethod queue-disarmed-event (widget sheet) + (declare (ignore widget)) + (unless *dont-invoke-callbacks* + (distribute-event + (port sheet) + (allocate-event 'disarmed-gadget-event + :gadget sheet)))) + (defmethod queue-drag-event (widget sheet &optional (value (gadget-value sheet))) (declare (ignore widget)) (distribute-event @@ -1581,26 +1603,27 @@ the geometry of the children. Instead the parent has control. ")) (or (sheet-pointer-cursor sheet) :default))) (let ((ussp (slot-value sheet 'silica::user-specified-size-p)) - (uspp (slot-value sheet 'silica::user-specified-position-p))) - (unless (and (eq ussp :unspecified) - (eq uspp :unspecified)) - (let ((size-hints (x11::xallocsizehints))) - (tk::with-ref-par ((supplied 0)) - (when (zerop - (x11::xgetwmnormalhints display window size-hints supplied)) - (warn "top-level-sheet had no size hints?!") - (return-from enable-mirror)) - (let ((flags (x11::xsizehints-flags size-hints))) - (if* (and uspp (not (eq uspp :unspecified))) - then (setf flags (logior flags x11::uspositionhint)) - elseif (null uspp) - then (setf flags (logandc2 flags x11::uspositionhint))) - (if* (and ussp (not (eq ussp :unspecified))) - then (setf flags (logior flags x11::ussizehint)) - elseif (null ussp) - then (setf flags (logandc2 flags x11::ussizehint))) - (setf (x11::xsizehints-flags size-hints) flags)) - (x11::xsetwmnormalhints display window size-hints)))))) + (uspp (slot-value sheet 'silica::user-specified-position-p)) + (size-hints (x11::xallocsizehints))) + (tk::with-ref-par ((supplied 0)) + (when (zerop + (x11::xgetwmnormalhints display window size-hints supplied)) + (warn "top-level-sheet had no size hints?!") + (return-from enable-mirror)) + (let ((flags (x11::xsizehints-flags size-hints))) + (if* (and uspp (not (eq uspp :unspecified))) + then (setf flags (logior flags x11::uspositionhint)) + elseif (null uspp) + then (setf flags (logandc2 flags x11::uspositionhint))) + (if* (and ussp (not (eq ussp :unspecified))) + then (setf flags (logior flags x11::ussizehint)) + elseif (null ussp) + then (setf flags (logandc2 flags x11::ussizehint))) + ;; always switch off program-specified position hint so + ;; that OpenWindows cascading works + (setf flags (logandc2 flags x11::ppositionhint)) + (setf (x11::xsizehints-flags size-hints) flags)) + (x11::xsetwmnormalhints display window size-hints)))) (popup parent))) ;;; so is this next method ever called???? let's comment it out and @@ -1742,20 +1765,22 @@ the geometry of the children. Instead the parent has control. ")) (if (eq pixel 0) 0 1)))))) - (let* ((drawable (tk::display-root-window - (port-display port))) + (let* ((display (port-display port)) + (drawable (tk::display-root-window display)) (depth 1) (pixmap-image (make-instance 'tk::image - :width width - :height height - :data pixmap-data - :depth depth)) + :display display + :width width + :height height + :data pixmap-data + :depth depth)) (mask-image (and maskp (make-instance 'tk::image - :width width - :height height - :data mask-data - :depth depth))) + :display display + :width width + :height height + :data mask-data + :depth depth))) (pixmap (make-instance 'tk::pixmap :drawable drawable @@ -1780,7 +1805,7 @@ the geometry of the children. Instead the parent has control. ")) (tk::destroy-image mask-image)) (prog1 (x11:xcreatepixmapcursor - (port-display port) + display pixmap (or mask 0) (multiple-value-bind (red green blue) @@ -1832,6 +1857,9 @@ the geometry of the children. Instead the parent has control. ")) (funcall continuation)))) (tk::xt_ungrab_pointer widget 0)))) +(defmethod port-remove-all-pointer-grabs ((port xt-port)) + (x11:xungrabpointer (port-display port) x11:currenttime)) + (defun xt-grabbed-event-mask () (tk::encode-event-mask '(:enter-window :leave-window diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp index ddac38bc..0c814f50 100644 --- a/tk/callbacks.lisp +++ b/tk/callbacks.lisp @@ -1,7 +1,7 @@ ;; -*- mode: common-lisp; package: tk -*- ;; ;; -[]- -;; +;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. ;; @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: callbacks.lisp,v 1.22 92/12/03 10:29:59 cer Exp $ +;; $fiHeader: callbacks.lisp,v 1.23 1993/07/27 01:52:33 colin Exp $ (in-package :tk) @@ -78,7 +78,7 @@ (funcall function widget))) -(defvar *create-popup-child-proc-function-address* +(defvar *create-popup-child-proc-function-address* (ff:register-function 'create-popup-child-proc-function)) (defun (setf widget-create-popup-child-proc) (function widget) @@ -87,7 +87,7 @@ (widget-callback-data widget)) (set-values widget :create-popup-child-proc *create-popup-child-proc-function-address*) function) - + (defun remove-all-callbacks (widget callback-name) (xt_remove_all_callbacks widget (convert-callback-name callback-name))) @@ -102,51 +102,50 @@ nil;; malloc cache type))) -(defparameter *callback-name-alist* +(defparameter *callback-name-alist* (mapcar #'process-callback-alist-component '( ("activateCallback" :activate) - ("armCallback") - ("disarmCallback") - ("popupCallback") - ("popdownCallback") - ("helpCallback") - ("decrementCallback") - ("dragCallback") - ("incrementCallback") - ("pageDecrementCallback") - ("pageIncrementCallback") - ("toBottomCallback") - ("toTopCallback") - ("focusCallback") - ("losingFocusCallback") - ("modifyVerifyCallback") + ("armCallback") + ("disarmCallback") + ("popupCallback") + ("popdownCallback") + ("helpCallback") + ("decrementCallback") + ("dragCallback") + ("incrementCallback") + ("pageDecrementCallback") + ("pageIncrementCallback") + ("toBottomCallback") + ("toTopCallback") + ("focusCallback") + ("losingFocusCallback") ("modifyVerifyCallback" :modify-verify) - ("valueChangedCallback") - ("noMatchCallback") - ("cancelCallback") - ("applyCallback") - ("okCallback") - ("browseSelectionCallback" :single-selection) - ("singleSelectionCallback" :single-selection) - ("defaultActionCallback") + ("valueChangedCallback") + ("noMatchCallback") + ("cancelCallback") + ("applyCallback") + ("okCallback") + ("browseSelectionCallback" :single-selection) + ("singleSelectionCallback" :single-selection) + ("defaultActionCallback") ("extendedSelectionCallback") ("multipleSelectionCallback" :multiple-selection) - ("entryCallback") - ("mapCallback") - ("unmapCallback") - ("cascadingCallback") - ("commandChangedCallback") - ("commandEnteredCallback") - ("exposeCallback" drawing-area) - ("inputCallback" drawing-area) - ("resizeCallback" drawing-area) - ("destroyCallback") - ("gainPrimaryCallback") + ("entryCallback") + ("mapCallback") + ("unmapCallback") + ("cascadingCallback") + ("commandChangedCallback") + ("commandEnteredCallback") + ("exposeCallback" drawing-area) + ("inputCallback" drawing-area) + ("resizeCallback" drawing-area) + ("destroyCallback") + ("gainPrimaryCallback") ("losePrimaryCallback") ;; Motif Callbacks - + ;; OpenLook Callbacks ("sliderMoved" slider-moved) ("select") @@ -168,7 +167,7 @@ (defmethod spread-callback-data (widget data (type (eql :modify-verify))) (declare (ignore widget)) - (xm-text-field-callback-struct-doit data)) + data) (defmethod spread-callback-data (widget call-data (type (eql 'drawing-area))) (declare (ignore widget)) diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp index f29ea953..dd46217e 100644 --- a/tk/ol-init.lisp +++ b/tk/ol-init.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-init.lisp,v 1.20 1994/12/05 00:01:06 colin Exp $ +;; $fiHeader: ol-init.lisp,v 1.21 1995/05/17 19:49:32 colin Exp $ (in-package :tk) @@ -96,4 +96,4 @@ (setup-error-handlers) (install-ol-error-handlers) (fixup-class-entry-points)) - (push '(:eval reinitialize-toolkit) excl::*restart-actions*)) + (push 'reinitialize-toolkit excl::*restart-actions*)) diff --git a/tk/resources.lisp b/tk/resources.lisp index 00af2498..092e3554 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -1,7 +1,7 @@ ;; -*- mode: common-lisp; package: tk -*- ;; ;; -[Fri Jul 30 16:14:28 1993 by colin]- -;; +;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. ;; @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: resources.lisp,v 1.50 1993/08/12 16:04:44 cer Exp $ +;; $fiHeader: resources.lisp,v 1.51 1994/12/05 00:01:09 colin Exp $ (in-package :tk) @@ -35,7 +35,7 @@ `(defmethod convert-resource-in ((parent t) (type (eql ',type)) value) ,@body)) - + (defmacro define-enumerated-resource (type elements) (if (consp (car elements)) `(progn @@ -66,9 +66,9 @@ (cerror "Try again" "cannot convert-in resource for ~S,~S,~S" class type value) (convert-resource-in class type value)) -(define-enumerated-resource separator-type (:no-line +(define-enumerated-resource separator-type (:no-line :single-line - :double-line + :double-line :single-dashed-line :double-dashed-line :shadow-etched-in @@ -91,14 +91,14 @@ (define-enumerated-resource delete-response (:destroy :unmap :do-nothing)) (define-enumerated-resource keyboard-focus-policy (:explicit :pointer)) - + (define-enumerated-resource packing (:no-packing :tight :column :none)) -(define-enumerated-resource row-column-type (:work-area - :menu-bar +(define-enumerated-resource row-column-type (:work-area + :menu-bar :menu-pulldown :menu-popup :menu-option)) @@ -109,8 +109,8 @@ (define-enumerated-resource scroll-bar-display-policy (:static :as-needed)) -(define-enumerated-resource selection-policy (:single-select - :multiple-select +(define-enumerated-resource selection-policy (:single-select + :multiple-select :extended-select :browse-select)) @@ -279,7 +279,7 @@ (declare (ignore parent)) (or (second (find value *ol-defines* :key #'first)) (call-next-method))) - + @@ -332,7 +332,7 @@ (declare (optimize (safety 0))) (unless entry (setf entry (fill-sv-cache parent-class class resources))) - + (destructuring-bind (arglist length &rest resource-descriptions) entry (do ((resdess resource-descriptions (cdr resdess)) @@ -396,6 +396,7 @@ (int nil) (short nil) (function nil) + (top-item-position nil) (t t))) (defmethod resource-type-set-conversion-p (type) @@ -418,6 +419,7 @@ (short nil) (int nil) (function nil) + (top-item-position nil) (t t))) (defmethod resource-type-get-memref-type (type) @@ -447,7 +449,7 @@ (constraint-resource-used nil) (i 0)) (dotimes (j len) - (setf (xt-arglist-value arglist j) + (setf (xt-arglist-value arglist j) (excl::malloc 8))) ;--- A crock... (dolist (r resources) (let ((resource (or (find-class-resource class r) @@ -472,7 +474,7 @@ (note-malloced-object (xt-arglist-value arglist j))) r) (setf (gethash resources (class-get-values-cache class)) r))))) - + (defun get-values (widget &rest resources) (declare (optimize (speed 3)) (dynamic-extent resources)) @@ -486,7 +488,7 @@ (declare (optimize (safety 0))) (unless entry (setf entry (fill-gv-cache parent-class class resources))) - + (destructuring-bind (arglist length &rest resource-descriptions) entry (xt_get_values widget arglist length) @@ -608,7 +610,7 @@ (incf *color-counter*) (color (allocate-color (default-colormap (widget-display parent)) value)))) - + (defmethod convert-resource-out ((parent t) (type (eql 'window)) x) x) @@ -630,7 +632,7 @@ (defmethod convert-resource-in ((widget t) (type (eql 'widget-list)) x) (let ((r nil)) (dotimes (i (widget-num-children widget)) - (push (convert-resource-in + (push (convert-resource-in widget 'widget (xt-widget-list x i)) r)) (nreverse r))) @@ -677,9 +679,9 @@ (defmethod convert-resource-out ((parent t) (typep (eql 'pointer)) value) value) - -;;; + +;;; (defmethod convert-resource-out ((parent t) (typep (eql 'key-sym)) value) (char-int value)) @@ -693,7 +695,7 @@ (defmethod convert-resource-in ((parent t) (typep (eql 'colormap)) value) value) -;; Openlook +;; Openlook (defmethod convert-resource-out ((parent t) (typep (eql 'char)) value) (char-int value)) @@ -720,17 +722,17 @@ (define-enumerated-resource list-size-policy (:variable :constant :resize-if-possible)) -(define-enumerated-resource shadow-type ((:etched-in 5) - (:etched-out 6) +(define-enumerated-resource shadow-type ((:etched-in 5) + (:etched-out 6) (:in 7) (:out 8))) -(define-enumerated-resource navigation-type (:none +(define-enumerated-resource navigation-type (:none :tab-group :sticky-tab-group :exclusive-tab-group)) -(define-enumerated-resource ol-wrap-mode ((:wrap-off 74) +(define-enumerated-resource ol-wrap-mode ((:wrap-off 74) (:wrap-any 75) (:wrap-white-space 76))) @@ -738,7 +740,7 @@ (defmethod convert-resource-out (parent (type (eql 'xt::translation-table)) value) (declare (ignore parent)) ;;--- Allocate-no-free - (xt_parse_translation_table + (xt_parse_translation_table (etypecase value (string value) (null "")))) @@ -746,7 +748,7 @@ ;; solaris 2.2 stuff (defmethod convert-resource-out ((parent t) (type (eql 'ol-str)) value) - (note-malloced-object + (note-malloced-object (string-to-char* value))) (defmethod convert-resource-in ((parent t) (type (eql 'ol-str)) value) diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 6c75e398..8baf86cf 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.52 1994/12/05 00:01:14 colin Exp $ +;; $fiHeader: xlib.lisp,v 1.53 1995/05/17 19:49:36 colin Exp $ (in-package :tk) @@ -674,6 +674,7 @@ (depth :reader image-depth :initarg :depth) (format :reader image-format :initform x11:zpixmap :initarg :format))) +;; I don't believe that this should be hard-wired (defconstant bitmap-pad 8) (defmethod initialize-instance :after @@ -681,10 +682,11 @@ (declare (optimize (speed 3) (safety 0))) (with-slots (display format depth width height) image (unless foreign-address - (let* ((bits-per-line (* width depth)) + (let* ((bits-per-pixel (x11:_xgetbitsperpixel display depth)) + (bits-per-line (* width bits-per-pixel)) (padded-bits-per-line (* bitmap-pad (ceiling bits-per-line bitmap-pad))) - (bytes-per-line (/ padded-bits-per-line bitmap-pad)) + (bytes-per-line (/ padded-bits-per-line 8)) (v (excl::malloc (* bytes-per-line height))) (visual (x11:screen-root-visual (x11:xdefaultscreenofdisplay display))) diff --git a/tk/xm-defs.lisp b/tk/xm-defs.lisp index dd2ea58f..97d1b2bf 100644 --- a/tk/xm-defs.lisp +++ b/tk/xm-defs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-defs.lisp,v 1.9 1994/12/05 00:01:17 colin Exp $ +;; $fiHeader: xm-defs.lisp,v 1.11 1995/06/21 21:24:19 georgej Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -40,13 +40,24 @@ (protocol * :char)) (def-c-typedef xm-string :int) +(def-c-typedef xm-text-position :long) + +(def-c-type (xm-text-block-rec :no-defuns) :struct + (ptr * :char) + (length :int) + (format x11:atom)) + +(def-c-typedef xm-text-block * xm-text-block-rec) (def-c-type (xm-text-field-callback-struct :no-defuns) :struct (reason :int) (event * x11:xevent) - (doit :int) - ;; and more later - ) + (doit boolean) + (curr-insert xm-text-position) + (new-insert xm-text-position) + (start-pos xm-text-position) + (end-pos xm-text-position) + (text xm-text-block)) (def-c-type (xm-file-selection-box-callback-struct :no-defuns) :struct (reason :int) @@ -74,4 +85,3 @@ (def-c-type (xm-selected-position-array :no-defuns) 1 :int) (def-c-type (xm-string-table :no-defuns) 1 * :char) - diff --git a/tk/xm-funs.lisp b/tk/xm-funs.lisp index 18bfd22f..d7be4ff6 100644 --- a/tk/xm-funs.lisp +++ b/tk/xm-funs.lisp @@ -1,7 +1,7 @@ ;; -*- mode: common-lisp; package: tk -*- ;; ;; -[Thu Jul 22 17:17:07 1993 by colin]- -;; +;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved. ;; @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-funs.lisp,v 1.14 1993/09/17 19:06:51 cer Exp $ +;; $fiHeader: xm-funs.lisp,v 1.15 1994/12/05 00:01:20 colin Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -105,7 +105,7 @@ :arg-checking nil :return-type :void) -(defforeign 'xm_intern_atom +(defforeign 'xm_intern_atom :entry-point (ff:convert-to-lang "XmInternAtom") :call-direct t :callback nil @@ -248,9 +248,24 @@ :entry-point (ff:convert-to-lang "XmTextGetSelection") :return-type :integer) +(ff:defforeign 'xm_scale_set_value + :call-direct t + :arguments '(foreign-address fixnum) + :arg-checking nil + :entry-point (ff:convert-to-lang "XmScaleSetValue") + :return-type :void) + (ff:defforeign 'xm_get_display :call-direct t :arguments '(foreign-address) :arg-checking nil :entry-point (ff:convert-to-lang "XmGetXmDisplay") :return-type :integer) + +(ff:defforeign 'xm_change_color + :call-direct t + :arguments '(foreign-address fixnum) + :arg-checking nil + :entry-point (ff:convert-to-lang "XmChangeColor") + :return-type :void) + diff --git a/tk/xm-init.lisp b/tk/xm-init.lisp index 1550217a..80e36fa9 100644 --- a/tk/xm-init.lisp +++ b/tk/xm-init.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-init.lisp,v 1.12 1994/12/05 00:01:22 colin Exp $ +;; $fiHeader: xm-init.lisp,v 1.14 1995/06/21 21:24:22 georgej Exp $ (in-package :tk) @@ -43,5 +43,5 @@ #+dlfcn (unless sys::*toolkit-static* - (push '(:eval reinitialize-toolkit) excl::*restart-actions*)) + (push 'reinitialize-toolkit excl::*restart-actions*)) diff --git a/tk/xt-defs.lisp b/tk/xt-defs.lisp index 80dcfe2e..bcc0d1b8 100644 --- a/tk/xt-defs.lisp +++ b/tk/xt-defs.lisp @@ -1,7 +1,7 @@ ;; -*- mode: common-lisp; package: tk -*- ;; ;; -[]- -;; +;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved. ;; @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-defs.lisp,v 1.9 1993/07/27 01:54:16 colin Exp $ +;; $fiHeader: xt-defs.lisp,v 1.10 1994/12/05 00:01:26 colin Exp $ ;; ;; This file contains compile time only code -- put in clim-debug.fasl. @@ -35,9 +35,9 @@ (def-c-typedef resource-list * :char) (def-c-typedef xrm-quark :int) (def-c-typedef xrm-quark-list * :int) -(def-c-typedef boolean :unsigned-long) +(def-c-typedef boolean :char) (def-c-typedef xrm-class xrm-quark) -(def-c-typedef xt-enum :long) +(def-c-typedef xt-enum :unsigned-char) (def-c-typedef xt-version-type :long) (def-c-typedef xt-geometry-mask :unsigned-int) (def-c-typedef xt-position :short) @@ -85,7 +85,7 @@ ) ;; Horrible internal stuff - + (def-c-type (xt-offset-rec :no-defuns) :struct (next * :char) (name xrm-quark) diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp index 5ac4d746..256d3ce8 100644 --- a/tk/xt-funs.lisp +++ b/tk/xt-funs.lisp @@ -1,7 +1,7 @@ ;; -*- mode: common-lisp; package: xt -*- ;; ;; -[Thu Nov 10 19:28:13 1994 by smh]- -;; +;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved. ;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved. ;; @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-funs.lisp,v 1.24 1994/11/23 23:29:18 smh Exp $ +;; $fiHeader: xt-funs.lisp,v 1.25 1994/12/05 00:01:29 colin Exp $ ;; @@ -35,7 +35,7 @@ :arguments '(foreign-address foreign-address foreign-address) :arg-checking nil :return-type :void) - + (defforeign 'xt_get_constraint_resource_list :entry-point (ff:convert-to-lang "XtGetConstraintResourceList") :call-direct t @@ -131,7 +131,7 @@ :arg-checking nil :return-type :unsigned-integer) -(defforeign 'xt_app_create_shell +(defforeign 'xt_app_create_shell :entry-point (ff:convert-to-lang "XtAppCreateShell") :call-direct t :arguments '(foreign-address foreign-address foreign-address foreign-address @@ -139,7 +139,7 @@ :arg-checking nil :return-type :unsigned-integer) -;;;; +;;;; (defforeign 'xt_create_widget :entry-point (ff:convert-to-lang "XtCreateWidget") @@ -148,8 +148,8 @@ foreign-address fixnum) :arg-checking nil :return-type :unsigned-integer) - - + + (defforeign 'xt_create_managed_widget :entry-point (ff:convert-to-lang "XtCreateManagedWidget") :call-direct t @@ -164,7 +164,7 @@ :arguments '(foreign-address) :arg-checking nil :return-type :void) - + (defforeign 'xt_is_realized :entry-point (ff:convert-to-lang "XtIsRealized") :call-direct t @@ -192,7 +192,7 @@ :arguments '(foreign-address) :arg-checking nil :return-type :fixnum) - + (defforeign 'xt_unmanage_child :entry-point (ff:convert-to-lang "XtUnmanageChild") :call-direct t @@ -221,7 +221,7 @@ :arguments '(foreign-address foreign-address foreign-address foreign-address fixnum) :arg-checking nil :return-type :unsigned-integer) - + (defforeign 'xt_popup :entry-point (ff:convert-to-lang "XtPopup") :call-direct t @@ -235,14 +235,14 @@ :arguments '(foreign-address) :arg-checking nil :return-type :void) - + (defforeign 'xt_window :entry-point (ff:convert-to-lang "XtWindow") :call-direct t :arguments '(foreign-address) :arg-checking nil :return-type :unsigned-integer) - + (defforeign 'xt_parent :entry-point (ff:convert-to-lang "XtParent") :call-direct t @@ -330,7 +330,7 @@ :arguments '(foreign-address integer fixnum foreign-address foreign-address) :arg-checking nil :return-type :void) - + (defforeign 'xt_build_event_mask :entry-point (ff:convert-to-lang "XtBuildEventMask") :call-direct t @@ -344,28 +344,28 @@ :arguments '(foreign-address foreign-address foreign-address foreign-address) :arg-checking nil :return-type :void) - + (defforeign 'xt_has_callbacks :entry-point (ff:convert-to-lang "XtHasCallbacks") :call-direct t :arguments '(foreign-address foreign-address) :arg-checking nil :return-type :unsigned-integer) - + (defforeign 'xt_remove_all_callbacks :entry-point (ff:convert-to-lang "XtRemoveAllCallbacks") :call-direct t :arguments '(foreign-address foreign-address) :arg-checking nil :return-type :void) - + (defforeign 'xt_set_sensitive :entry-point (ff:convert-to-lang "XtSetSensitive") :call-direct t :arguments '(foreign-address fixnum) :arg-checking nil :return-type :void) - + (defforeign 'xt_grab_pointer :entry-point (ff:convert-to-lang "XtGrabPointer") :call-direct t @@ -390,6 +390,15 @@ :arg-checking nil :return-type :fixnum) +(defforeign 'xt_ungrab_button + :entry-point (ff:convert-to-lang "XtUngrabButton") + :call-direct t + :arguments '(foreign-address ; widget + fixnum ; button + fixnum ; modifiers + ) + :arg-checking nil + :return-type :void) (defforeign 'xt-last-timestamp-processed :entry-point (ff:convert-to-lang "XtLastTimestampProcessed") @@ -407,12 +416,11 @@ :return-type :unsigned-integer) (ff:defforeign 'init_clim_gc_cursor_stuff - ;; :call-direct t - ;; :arguments '(fixnum) - ;; :arg-checking nil + :call-direct t + :arguments '(foreign-address) + :arg-checking nil :entry-point (ff:convert-to-lang "init_clim_gc_cursor_stuff") - ;; :return-type :unsigned-integer - ) + :return-type :unsigned-integer) (ff:defforeign 'set_clim_gc_cursor_widget :call-direct t diff --git a/utils/base-designs.lisp b/utils/base-designs.lisp index dc28bffd..7f2a4003 100644 --- a/utils/base-designs.lisp +++ b/utils/base-designs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: base-designs.lisp,v 1.8 1993/08/19 20:10:25 smh Exp $ +;; $fiHeader: base-designs.lisp,v 1.9 1994/12/05 00:02:22 colin Exp $ (in-package :clim-utils) @@ -112,15 +112,15 @@ (defgeneric deallocate-color (color palette)) -;;; Dynamic Colors +;;; Dynamic Colors (defclass dynamic-color (color) ((color :accessor dynamic-color-color :initarg :color) - (palettes :type list + (palettes :type list :initform nil :accessor dynamic-color-palettes))) -(define-constructor make-dynamic-color dynamic-color (color) +(define-constructor make-dynamic-color dynamic-color (color) :color color) (defmethod make-load-form ((color dynamic-color) &optional environment) @@ -147,12 +147,12 @@ (defclass layered-color (design) ((set :initarg :set :reader layered-color-set) (layers :initarg :layers :initform nil :reader layered-color-layers) - (dynamic-colors :initform nil))) - + (dynamic-colors :initform nil))) + (define-constructor make-layered-color layered-color (set layers) :set set :layers layers) -;;; Device Colors +;;; Device Colors (defclass device-color (color) ((palette :reader device-color-palette :initarg :palette) @@ -213,7 +213,7 @@ ;;; Patterns (defclass pattern (design) - ((array :type (array * (* *)) :initarg :array + ((array :type (array * (* *)) :initarg :array :reader pattern-array) (designs :type vector :initarg :designs :reader pattern-designs))) @@ -221,7 +221,7 @@ (defun make-pattern (array designs) #+Genera (declare lt:(side-effects simple reducible)) (check-type array (array * (* *))) - (make-instance 'pattern :array array :designs (coerce designs 'vector))) + (make-instance 'pattern :array array :designs (coerce designs 'simple-vector))) (defmethod make-load-form ((design pattern) &optional environment) (declare (ignore environment)) diff --git a/utils/designs.lisp b/utils/designs.lisp index 7234de25..d53b01ed 100644 --- a/utils/designs.lisp +++ b/utils/designs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: designs.lisp,v 1.18 1994/12/05 00:02:24 colin Exp $ +;; $fiHeader: designs.lisp,v 1.19 1995/05/17 19:50:33 colin Exp $ (in-package :clim-utils) @@ -115,7 +115,7 @@ ;;; Color constants (defmacro define-primary-color (color-name r g b) - `(defconstant ,color-name + `(defconstant ,color-name (make-rgb-color-1 (float ,r 0f0) (float ,g 0f0) (float ,b 0f0)))) ;; The primary colors, constant across all platforms @@ -323,14 +323,19 @@ (palette-full-palette condition))))) ) ;eval-when -(defvar *use-closest-color* t) +(defvar *use-closest-color* :warn) (defmethod palette-full-error ((palette basic-palette) &optional color) - (if (and *use-closest-color* - (find-restart 'use-other-color)) - (invoke-restart 'use-other-color - (find-closest-matching-color palette color)) - (error 'palette-full :palette palette :color color))) + (when (and *use-closest-color* + (find-restart 'use-other-color)) + (let ((closest-match (find-closest-matching-color palette color))) + (when closest-match + (when (eq *use-closest-color* :warn) + (let ((*error-output* excl:*initial-terminal-io*)) + (warn "Failed to allocate color ~A, using ~A" + color closest-match))) + (invoke-restart 'use-other-color closest-match)))) + (error 'palette-full :palette palette :color color)) (defmethod find-closest-matching-color ((palette basic-palette) (desired-color color)) (let ((best-color nil) @@ -435,7 +440,7 @@ (rest-set-layers (cdr set-layers)) (rest-dims (cdr dims))) (if layer - (progn + (progn (setf (car dims) layer) (iterate rest-layers rest-set-layers rest-dims)) (dotimes (i set-layer) @@ -459,12 +464,12 @@ (setf (gethash layers cache) (make-layered-color set layers)))))) -(defmethod (setf layered-color-color) +(defmethod (setf layered-color-color) ((color color) (layered-color layered-color)) (with-delayed-recoloring (dolist (dynamic-color (layered-color-dynamic-colors layered-color)) (setf (dynamic-color-color dynamic-color) color)))) - + ;; LAYERED-COLOR-DYNAMIC-COLORS should not be exported to the user. It ;; is important that these dynamics are not drawn with. Instead, the ;; fully specified layered is used. @@ -474,7 +479,7 @@ (setf dynamic-colors (let ((dynamic-array (layered-color-set-dynamic-array set)) (dynamics nil)) - (map-over-layered-colors + (map-over-layered-colors #'(lambda (dimensions) (push (apply #'aref dynamic-array dimensions) dynamics)) set layers) @@ -590,7 +595,7 @@ pattern))) (declare (dynamic-extent #'make-dash-pattern)) (etypecase k - (null + (null (let ((patterns (make-array n))) (dotimes (i n) (setf (aref patterns i) (make-dash-pattern i))) diff --git a/utils/packages.lisp b/utils/packages.lisp index 81c9e779..ee336788 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: packages.lisp,v 1.64 1994/12/05 00:02:30 colin Exp $ +;; $fiHeader: packages.lisp,v 1.65 1995/05/17 19:50:36 colin Exp $ (in-package :common-lisp-user) @@ -3245,6 +3245,7 @@ add-sheet-callbacks all-drawing-options-lambda-list allocate-event + armed-gadget-event basic-pixmap-medium bury-mirror canvas @@ -3274,6 +3275,7 @@ define-graphics-method define-text-style-mappings define-text-style-mappings-1 + disarmed-gadget-event distribute-event-1 drag-gadget-event draw-gadget-label @@ -3379,6 +3381,7 @@ port-mirror->sheet-table port-move-frame port-resize-frame + port-remove-all-pointer-grabs port-note-cursor-change port-note-frame-adopted port-note-gadget-activated @@ -3435,6 +3438,7 @@ stream-scan-string-for-writing-1 string-height string-width + text-field-echo-character text-style-index text-style-mapping* text-style-scale diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp index 269d8329..6ae4ce34 100644 --- a/xlib/xlib-funs.lisp +++ b/xlib/xlib-funs.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: x11 -*- ;;; (c) Copyright 1990 Sun Microsystems, Inc. All Rights Reserved. -;; +;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. ;; @@ -45,7 +45,7 @@ ;; OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION ;; WITH THE USE OR PERFORMANCE OF THIS OBJECT CODE. -;;; $fiHeader: xlib-funs.lisp,v 1.14 1993/11/18 18:46:00 cer Exp $ +;;; $fiHeader: xlib-funs.lisp,v 1.15 1994/12/05 00:02:47 colin Exp $ (in-package :x11) @@ -58,7 +58,7 @@ (pixels (:pointer unsigned-long)) (ncolors unsigned-int)) -(def-exported-foreign-function (xalloccolorplanes (:return-type int) (:name "XAllocColorPlanes")) +(def-exported-foreign-function (xalloccolorplanes (:return-type int) (:name "XAllocColorPlanes")) (dpy (:pointer display)) (cmap colormap) (contig int) @@ -71,73 +71,73 @@ (gmask (:pointer unsigned-long)) (bmask (:pointer unsigned-long))) -(def-exported-foreign-function (xallowevents (:name "XAllowEvents")) +(def-exported-foreign-function (xallowevents (:name "XAllowEvents")) (dpy (:pointer display)) (mode int) (time :unsigned-32bit)) -(def-exported-foreign-function (xautorepeaton (:name "XAutoRepeatOn")) +(def-exported-foreign-function (xautorepeaton (:name "XAutoRepeatOn")) (dpy (:pointer display))) -(def-exported-foreign-function (xautorepeatoff (:name "XAutoRepeatOff")) +(def-exported-foreign-function (xautorepeatoff (:name "XAutoRepeatOff")) (dpy (:pointer display))) -(def-exported-foreign-function (xsetwindowbackground (:name "XSetWindowBackground")) +(def-exported-foreign-function (xsetwindowbackground (:name "XSetWindowBackground")) (dpy (:pointer display)) (w window) (pixel unsigned-long)) -(def-exported-foreign-function (xsetwindowborderwidth (:name "XSetWindowBorderWidth")) +(def-exported-foreign-function (xsetwindowborderwidth (:name "XSetWindowBorderWidth")) (dpy (:pointer display)) (w window) (width unsigned-int)) -(def-exported-foreign-function (xbell (:name "XBell")) +(def-exported-foreign-function (xbell (:name "XBell")) (dpy (:pointer display)) (percent int)) -(def-exported-foreign-function (xsetwindowborder (:name "XSetWindowBorder")) +(def-exported-foreign-function (xsetwindowborder (:name "XSetWindowBorder")) (dpy (:pointer display)) (w window) (pixel unsigned-long)) -(def-exported-foreign-function (xenableaccesscontrol (:name "XEnableAccessControl")) +(def-exported-foreign-function (xenableaccesscontrol (:name "XEnableAccessControl")) (dpy (:pointer display))) -(def-exported-foreign-function (xdisableaccesscontrol (:name "XDisableAccessControl")) +(def-exported-foreign-function (xdisableaccesscontrol (:name "XDisableAccessControl")) (dpy (:pointer display))) -(def-exported-foreign-function (xsetaccesscontrol (:name "XSetAccessControl")) +(def-exported-foreign-function (xsetaccesscontrol (:name "XSetAccessControl")) (dpy (:pointer display)) (mode int)) -(def-exported-foreign-function (xchangeactivepointergrab (:name "XChangeActivePointerGrab")) +(def-exported-foreign-function (xchangeactivepointergrab (:name "XChangeActivePointerGrab")) (dpy (:pointer display)) (event-mask unsigned-int) (curs cursor) (time :unsigned-32bit)) -(def-exported-foreign-function (xsetclosedownmode (:name "XSetCloseDownMode")) +(def-exported-foreign-function (xsetclosedownmode (:name "XSetCloseDownMode")) (dpy (:pointer display)) (mode int)) -(def-exported-foreign-function (xsetwindowcolormap (:name "XSetWindowColormap")) +(def-exported-foreign-function (xsetwindowcolormap (:name "XSetWindowColormap")) (dpy (:pointer display)) (w window) (colormap colormap)) -(def-exported-foreign-function (xchangegc (:name "XChangeGC")) +(def-exported-foreign-function (xchangegc (:name "XChangeGC")) (dpy (:pointer display)) (gc gc) (valuemask unsigned-long) (values (:pointer xgcvalues))) -(def-exported-foreign-function (xchangekeyboardcontrol (:name "XChangeKeyboardControl")) +(def-exported-foreign-function (xchangekeyboardcontrol (:name "XChangeKeyboardControl")) (dpy (:pointer display)) (mask unsigned-long) (value-list (:pointer xkeyboardcontrol))) -(def-exported-foreign-function (xchangepointercontrol (:name "XChangePointerControl")) +(def-exported-foreign-function (xchangepointercontrol (:name "XChangePointerControl")) (dpy (:pointer display)) (do-acc int) (do-thresh int) @@ -145,7 +145,7 @@ (acc-denominator int) (threshold int)) -(def-exported-foreign-function (xchangeproperty (:name "XChangeProperty")) +(def-exported-foreign-function (xchangeproperty (:name "XChangeProperty")) (dpy (:pointer display)) (w window) (property :unsigned-32bit) @@ -155,80 +155,80 @@ (data (:pointer unsigned-char)) (nelements int)) -(def-exported-foreign-function (xchangesaveset (:name "XChangeSaveSet")) +(def-exported-foreign-function (xchangesaveset (:name "XChangeSaveSet")) (dpy (:pointer display)) (win window) (mode int)) -(def-exported-foreign-function (xaddtosaveset (:name "XAddToSaveSet")) +(def-exported-foreign-function (xaddtosaveset (:name "XAddToSaveSet")) (dpy (:pointer display)) (win window)) -(def-exported-foreign-function (xremovefromsaveset (:name "XRemoveFromSaveSet")) +(def-exported-foreign-function (xremovefromsaveset (:name "XRemoveFromSaveSet")) (dpy (:pointer display)) (win window)) -(def-exported-foreign-function (xchangewindowattributes (:name "XChangeWindowAttributes")) +(def-exported-foreign-function (xchangewindowattributes (:name "XChangeWindowAttributes")) (dpy (:pointer display)) (w window) (valuemask unsigned-long) (attributes (:pointer xsetwindowattributes))) -(def-exported-foreign-function (xresizewindow (:name "XResizeWindow")) +(def-exported-foreign-function (xresizewindow (:name "XResizeWindow")) (dpy (:pointer display)) (w window) (width unsigned-int) (height unsigned-int)) -(def-exported-foreign-function (xcheckifevent (:return-type int) (:name "XCheckIfEvent")) +(def-exported-foreign-function (xcheckifevent (:return-type int) (:name "XCheckIfEvent")) (dpy (:pointer display)) (event (:pointer xevent)) (predicate (:pointer :pointer)) (arg (:pointer char))) -(def-exported-foreign-function (xcheckmaskevent (:return-type int) (:name "XCheckMaskEvent")) +(def-exported-foreign-function (xcheckmaskevent (:return-type int) (:name "XCheckMaskEvent")) (dpy (:pointer display)) (mask long) (event (:pointer xevent))) -(def-exported-foreign-function (xchecktypedevent (:return-type int) (:name "XCheckTypedEvent")) +(def-exported-foreign-function (xchecktypedevent (:return-type int) (:name "XCheckTypedEvent")) (dpy (:pointer display)) (type int) (event (:pointer xevent))) -(def-exported-foreign-function (xchecktypedwindowevent (:return-type int) (:name "XCheckTypedWindowEvent")) +(def-exported-foreign-function (xchecktypedwindowevent (:return-type int) (:name "XCheckTypedWindowEvent")) (dpy (:pointer display)) (w window) (type int) (event (:pointer xevent))) -(def-exported-foreign-function (xcheckwindowevent (:return-type int) (:name "XCheckWindowEvent")) +(def-exported-foreign-function (xcheckwindowevent (:return-type int) (:name "XCheckWindowEvent")) (dpy (:pointer display)) (w window) (mask long) (event (:pointer xevent))) -(def-exported-foreign-function (xcirculatesubwindows (:name "XCirculateSubwindows")) +(def-exported-foreign-function (xcirculatesubwindows (:name "XCirculateSubwindows")) (dpy (:pointer display)) (w window) (direction int)) -(def-exported-foreign-function (xcirculatesubwindowsdown (:name "XCirculateSubwindowsDown")) +(def-exported-foreign-function (xcirculatesubwindowsdown (:name "XCirculateSubwindowsDown")) (dpy (:pointer display)) (w window)) -(def-exported-foreign-function (xcirculatesubwindowsup (:name "XCirculateSubwindowsUp")) +(def-exported-foreign-function (xcirculatesubwindowsup (:name "XCirculateSubwindowsUp")) (dpy (:pointer display)) (w window)) -(def-exported-foreign-function (xclosedisplay (:name "XCloseDisplay")) +(def-exported-foreign-function (xclosedisplay (:name "XCloseDisplay")) (dpy (:pointer display))) -(def-exported-foreign-function (xclearwindow (:name "XClearWindow")) +(def-exported-foreign-function (xclearwindow (:name "XClearWindow")) (dpy (:pointer display)) (w window)) -(def-exported-foreign-function (xcleararea (:name "XClearArea")) +(def-exported-foreign-function (xcleararea (:name "XClearArea")) (dpy (:pointer display)) (w window) (x int) @@ -245,7 +245,7 @@ (width unsigned-int) (height unsigned-int)) -(def-exported-foreign-function (xconvertselection (:name "XConvertSelection")) +(def-exported-foreign-function (xconvertselection (:name "XConvertSelection")) (dpy (:pointer display)) (selection :unsigned-32bit) (target :unsigned-32bit) @@ -253,7 +253,7 @@ (requestor window) (time :unsigned-32bit)) -(def-exported-foreign-function (xcopyarea (:name "XCopyArea")) +(def-exported-foreign-function (xcopyarea (:name "XCopyArea")) (dpy (:pointer display)) (src-drawable drawable) (dst-drawable drawable) @@ -265,17 +265,17 @@ (dst-x int) (dst-y int)) -(def-exported-foreign-function (xcopycolormapandfree (:name "XCopyColormapAndFree")) +(def-exported-foreign-function (xcopycolormapandfree (:name "XCopyColormapAndFree")) (dpy (:pointer display)) (src-cmap colormap)) -(def-exported-foreign-function (xcopygc (:name "XCopyGC")) +(def-exported-foreign-function (xcopygc (:name "XCopyGC")) (dpy (:pointer display)) (mask unsigned-long) (srcgc gc) (destgc gc)) -(def-exported-foreign-function (xcopyplane (:name "XCopyPlane")) +(def-exported-foreign-function (xcopyplane (:name "XCopyPlane")) (dpy (:pointer display)) (src-drawable drawable) (dst-drawable drawable) @@ -288,13 +288,13 @@ (dst-y int) (bit-plane unsigned-long)) -(def-exported-foreign-function (xcreatecolormap (:return-type colormap) (:name "XCreateColormap")) +(def-exported-foreign-function (xcreatecolormap (:return-type colormap) (:name "XCreateColormap")) (dpy (:pointer display)) (w window) (visual (:pointer visual)) (alloc int)) -(def-exported-foreign-function (xcreatepixmapcursor (:return-type cursor) (:name "XCreatePixmapCursor")) +(def-exported-foreign-function (xcreatepixmapcursor (:return-type cursor) (:name "XCreatePixmapCursor")) (dpy (:pointer display)) (source pixmap) (mask pixmap) @@ -303,16 +303,16 @@ (x unsigned-int) (y unsigned-int)) -(def-exported-foreign-function (xcreategc (:return-type gc) (:name "XCreateGC")) +(def-exported-foreign-function (xcreategc (:return-type gc) (:name "XCreateGC")) (dpy (:pointer display)) (d drawable) (valuemask unsigned-long) (values (:pointer xgcvalues))) -(def-exported-foreign-function (xgcontextfromgc (:return-type gcontext) (:name "XGContextFromGC")) +(def-exported-foreign-function (xgcontextfromgc (:return-type gcontext) (:name "XGContextFromGC")) (gc gc)) -(def-exported-foreign-function (xcreateglyphcursor (:return-type cursor) (:name "XCreateGlyphCursor")) +(def-exported-foreign-function (xcreateglyphcursor (:return-type cursor) (:name "XCreateGlyphCursor")) (dpy (:pointer display)) (source-font font) (mask-font font) @@ -321,14 +321,14 @@ (foreground (:pointer xcolor)) (background (:pointer xcolor))) -(def-exported-foreign-function (xcreatepixmap (:return-type pixmap) (:name "XCreatePixmap")) +(def-exported-foreign-function (xcreatepixmap (:return-type pixmap) (:name "XCreatePixmap")) (dpy (:pointer display)) (d drawable) (width unsigned-int) (height unsigned-int) (depth unsigned-int)) -(def-exported-foreign-function (xcreatesimplewindow (:return-type window) (:name "XCreateSimpleWindow")) +(def-exported-foreign-function (xcreatesimplewindow (:return-type window) (:name "XCreateSimpleWindow")) (dpy (:pointer display)) (parent window) (x int) @@ -339,39 +339,39 @@ (border unsigned-long) (background unsigned-long)) -(def-exported-foreign-function (xcreatefontcursor (:return-type cursor) (:name "XCreateFontCursor")) +(def-exported-foreign-function (xcreatefontcursor (:return-type cursor) (:name "XCreateFontCursor")) (dpy (:pointer display)) (which unsigned-int)) -(def-exported-foreign-function (xdefinecursor (:name "XDefineCursor")) +(def-exported-foreign-function (xdefinecursor (:name "XDefineCursor")) (dpy (:pointer display)) (w window) (cursor cursor)) -(def-exported-foreign-function (xdeleteproperty (:name "XDeleteProperty")) +(def-exported-foreign-function (xdeleteproperty (:name "XDeleteProperty")) (dpy (:pointer display)) (window window) (property :unsigned-32bit)) -(def-exported-foreign-function (xdestroysubwindows (:name "XDestroySubwindows")) +(def-exported-foreign-function (xdestroysubwindows (:name "XDestroySubwindows")) (dpy (:pointer display)) (win window)) -(def-exported-foreign-function (xdestroywindow (:name "XDestroyWindow")) +(def-exported-foreign-function (xdestroywindow (:name "XDestroyWindow")) (dpy (:pointer display)) (w window)) -(def-exported-foreign-function (xdisplayname (:return-type (:pointer char)) (:name "XDisplayName")) +(def-exported-foreign-function (xdisplayname (:return-type (:pointer char)) (:name "XDisplayName")) (display (:pointer char))) -(def-exported-foreign-function (xgeterrortext (:name "XGetErrorText")) +(def-exported-foreign-function (xgeterrortext (:name "XGetErrorText")) (dpy (:pointer display)) (code int) (buffer (:pointer char)) - (nbytes int)) + (nbytes int)) -(def-exported-foreign-function (xgeterrordatabasetext (:name "XGetErrorDatabaseText")) +(def-exported-foreign-function (xgeterrordatabasetext (:name "XGetErrorDatabaseText")) (name (:pointer char)) (type (:pointer char)) (defaultp (:pointer char)) @@ -379,33 +379,33 @@ (buffer (:pointer char)) (nbytes int)) -(def-exported-foreign-function (xseterrorhandler (:name "XSetErrorHandler")) +(def-exported-foreign-function (xseterrorhandler (:name "XSetErrorHandler")) (handler callback-function-addr)) -(def-exported-foreign-function (xsetioerrorhandler (:name "XSetIOErrorHandler")) +(def-exported-foreign-function (xsetioerrorhandler (:name "XSetIOErrorHandler")) (handler callback-function-addr)) -(def-exported-foreign-function (xactivatescreensaver (:name "XActivateScreenSaver")) +(def-exported-foreign-function (xactivatescreensaver (:name "XActivateScreenSaver")) (dpy (:pointer display))) -(def-exported-foreign-function (xresetscreensaver (:name "XResetScreenSaver")) +(def-exported-foreign-function (xresetscreensaver (:name "XResetScreenSaver")) (dpy (:pointer display))) -(def-exported-foreign-function (xforcescreensaver (:return-type int) (:name "XForceScreenSaver")) +(def-exported-foreign-function (xforcescreensaver (:return-type int) (:name "XForceScreenSaver")) (dpy (:pointer display)) (mode int)) -(def-exported-foreign-function (xfetchname (:return-type int) (:name "XFetchName")) +(def-exported-foreign-function (xfetchname (:return-type int) (:name "XFetchName")) (dpy (:pointer display)) (w window) (name (:pointer (:pointer char)))) -(def-exported-foreign-function (xgeticonname (:return-type int) (:name "XGetIconName")) +(def-exported-foreign-function (xgeticonname (:return-type int) (:name "XGetIconName")) (dpy (:pointer display)) (w window) (icon-name (:pointer (:pointer char)))) -(def-exported-foreign-function (xfillarc (:name "XFillArc")) +(def-exported-foreign-function (xfillarc (:name "XFillArc")) (dpy (:pointer display)) (d drawable) (gc gc) @@ -416,14 +416,14 @@ (angle1 int) (angle2 int)) -(def-exported-foreign-function (xfillarcs (:name "XFillArcs")) +(def-exported-foreign-function (xfillarcs (:name "XFillArcs")) (dpy (:pointer display)) (d drawable) (gc gc) (arcs (:pointer xarc)) (n-arcs int)) -(def-exported-foreign-function (xfillpolygon (:name "XFillPolygon")) +(def-exported-foreign-function (xfillpolygon (:name "XFillPolygon")) (dpy (:pointer display)) (d drawable) (gc gc) @@ -432,7 +432,7 @@ (shape int) (mode int)) -(def-exported-foreign-function (xfillrectangle (:name "XFillRectangle")) +(def-exported-foreign-function (xfillrectangle (:name "XFillRectangle")) (dpy (:pointer display)) (d drawable) (gc gc) @@ -441,7 +441,7 @@ (width unsigned-int) (height unsigned-int)) -(def-exported-foreign-function (xfillrectangles (:name "XFillRectangles")) +(def-exported-foreign-function (xfillrectangles (:name "XFillRectangles")) (dpy (:pointer display)) (d drawable) (gc gc) @@ -451,111 +451,111 @@ (def-exported-foreign-function (xflush (:name "XFlush")) (dpy (:pointer display))) -(def-exported-foreign-function (xloadqueryfont (:return-type (:pointer xfontstruct)) (:name "XLoadQueryFont")) +(def-exported-foreign-function (xloadqueryfont (:return-type (:pointer xfontstruct)) (:name "XLoadQueryFont")) (dpy (:pointer display)) (name (:pointer char))) -(def-exported-foreign-function (xfreefont (:name "XFreeFont")) +(def-exported-foreign-function (xfreefont (:name "XFreeFont")) (dpy (:pointer display)) (fs (:pointer xfontstruct))) -(def-exported-foreign-function (xqueryfont (:return-type (:pointer xfontstruct)) (:name "XQueryFont")) +(def-exported-foreign-function (xqueryfont (:return-type (:pointer xfontstruct)) (:name "XQueryFont")) (dpy (:pointer display)) (fid font)) -(def-exported-foreign-function (xlistfontswithinfo (:return-type (:pointer (:pointer char))) (:name "XListFontsWithInfo")) +(def-exported-foreign-function (xlistfontswithinfo (:return-type (:pointer (:pointer char))) (:name "XListFontsWithInfo")) (dpy (:pointer display)) (pattern (:pointer char)) (maxnames int) (actualcount (:pointer int)) (info (:pointer (:pointer xfontstruct)))) -(def-exported-foreign-function (xfreefontinfo (:name "XFreeFontInfo")) +(def-exported-foreign-function (xfreefontinfo (:name "XFreeFontInfo")) (names (:pointer (:pointer char))) (info (:pointer xfontstruct)) (actualcount int)) -(def-exported-foreign-function (xlistfonts (:return-type (:pointer (:pointer char))) (:name "XListFonts")) +(def-exported-foreign-function (xlistfonts (:return-type (:pointer (:pointer char))) (:name "XListFonts")) (dpy (:pointer display)) (pattern (:pointer char)) (maxnames int) (actualcount (:pointer int))) -(def-exported-foreign-function (xfreefontnames (:name "XFreeFontNames")) +(def-exported-foreign-function (xfreefontnames (:name "XFreeFontNames")) (list (:pointer (:pointer char)))) -(def-exported-foreign-function (xfreecolormap (:name "XFreeColormap")) +(def-exported-foreign-function (xfreecolormap (:name "XFreeColormap")) (dpy (:pointer display)) (cmap colormap)) -(def-exported-foreign-function (xfreecolors (:name "XFreeColors")) +(def-exported-foreign-function (xfreecolors (:name "XFreeColors")) (dpy (:pointer display)) (cmap colormap) (pixels (:pointer unsigned-long)) (npixels int) (planes unsigned-long)) -(def-exported-foreign-function (xfreecursor (:name "XFreeCursor")) +(def-exported-foreign-function (xfreecursor (:name "XFreeCursor")) (dpy (:pointer display)) (cursor cursor)) -(def-exported-foreign-function (xfreegc (:name "XFreeGC")) +(def-exported-foreign-function (xfreegc (:name "XFreeGC")) (dpy (:pointer display)) (gc gc)) -(def-exported-foreign-function (xfreepixmap (:name "XFreePixmap")) +(def-exported-foreign-function (xfreepixmap (:name "XFreePixmap")) (dpy (:pointer display)) (pixmap pixmap)) -(def-exported-foreign-function (xsetarcmode (:name "XSetArcMode")) +(def-exported-foreign-function (xsetarcmode (:name "XSetArcMode")) (dpy (:pointer display)) (gc gc) (arc-mode int)) -(def-exported-foreign-function (xsetfillrule (:name "XSetFillRule")) +(def-exported-foreign-function (xsetfillrule (:name "XSetFillRule")) (dpy (:pointer display)) (gc gc) (fill-rule int)) -(def-exported-foreign-function (xsetfillstyle (:name "XSetFillStyle")) +(def-exported-foreign-function (xsetfillstyle (:name "XSetFillStyle")) (dpy (:pointer display)) (gc gc) (fill-style int)) -(def-exported-foreign-function (xsetgraphicsexposures (:name "XSetGraphicsExposures")) +(def-exported-foreign-function (xsetgraphicsexposures (:name "XSetGraphicsExposures")) (dpy (:pointer display)) (gc gc) (graphics-exposures int)) -(def-exported-foreign-function (xsetsubwindowmode (:name "XSetSubwindowMode")) +(def-exported-foreign-function (xsetsubwindowmode (:name "XSetSubwindowMode")) (dpy (:pointer display)) (gc gc) (subwindow-mode int)) -(def-exported-foreign-function (xgetatomname (:return-type (:pointer char)) (:name "XGetAtomName")) +(def-exported-foreign-function (xgetatomname (:return-type (:pointer char)) (:name "XGetAtomName")) (dpy (:pointer display)) (atom :unsigned-32bit)) -(def-exported-foreign-function (xallocnamedcolor (:return-type int) (:name "XAllocNamedColor")) +(def-exported-foreign-function (xallocnamedcolor (:return-type int) (:name "XAllocNamedColor")) (dpy (:pointer display)) (cmap colormap) (colorname (:pointer char)) (hard-def (:pointer xcolor)) (exact-def (:pointer xcolor))) -(def-exported-foreign-function (xgetfontpath (:return-type (:pointer (:pointer char))) (:name "XGetFontPath")) +(def-exported-foreign-function (xgetfontpath (:return-type (:pointer (:pointer char))) (:name "XGetFontPath")) (dpy (:pointer display)) (npaths (:pointer int))) -(def-exported-foreign-function (xfreefontpath (:name "XFreeFontPath")) +(def-exported-foreign-function (xfreefontpath (:name "XFreeFontPath")) (list (:pointer (:pointer char)))) -(def-exported-foreign-function (xgetfontproperty (:return-type int) (:name "XGetFontProperty")) +(def-exported-foreign-function (xgetfontproperty (:return-type int) (:name "XGetFontProperty")) (fs (:pointer xfontstruct)) (name :unsigned-32bit) (valueptr (:pointer unsigned-long))) -(def-exported-foreign-function (xgetgeometry (:return-type int) (:name "XGetGeometry")) +(def-exported-foreign-function (xgetgeometry (:return-type int) (:name "XGetGeometry")) (dpy (:pointer display)) (d drawable) (root (:pointer window)) @@ -566,17 +566,17 @@ (borderwidth (:pointer unsigned-int)) (depth (:pointer unsigned-int))) -(def-exported-foreign-function (xalloccolor (:return-type int) (:name "XAllocColor")) +(def-exported-foreign-function (xalloccolor (:return-type int) (:name "XAllocColor")) (dpy (:pointer display)) (cmap colormap) (def (:pointer xcolor))) -(def-exported-foreign-function (xgetinputfocus (:name "XGetInputFocus")) +(def-exported-foreign-function (xgetinputfocus (:name "XGetInputFocus")) (dpy (:pointer display)) (focus (:pointer window)) (revert-to (:pointer int))) -(def-exported-foreign-function (xgetimage (:return-type (:pointer ximage)) (:name "XGetImage")) +(def-exported-foreign-function (xgetimage (:return-type (:pointer ximage)) (:name "XGetImage")) (dpy (:pointer display)) (d drawable) (x int) @@ -586,7 +586,7 @@ (plane-mask unsigned-long) (format int)) -(def-exported-foreign-function (xgetsubimage (:return-type (:pointer ximage)) (:name "XGetSubImage")) +(def-exported-foreign-function (xgetsubimage (:return-type (:pointer ximage)) (:name "XGetSubImage")) (dpy (:pointer display)) (d drawable) (x int) @@ -599,35 +599,35 @@ (dest-x int) (dest-y int)) -(def-exported-foreign-function (xgetkeyboardcontrol (:name "XGetKeyboardControl")) +(def-exported-foreign-function (xgetkeyboardcontrol (:name "XGetKeyboardControl")) (dpy (:pointer display)) (state (:pointer xkeyboardstate))) -(def-exported-foreign-function (xgetmotionevents (:return-type (:pointer xtimecoord)) (:name "XGetMotionEvents")) +(def-exported-foreign-function (xgetmotionevents (:return-type (:pointer xtimecoord)) (:name "XGetMotionEvents")) (dpy (:pointer display)) (start :unsigned-32bit) (stop :unsigned-32bit) (w window) (nevents (:pointer int))) -(def-exported-foreign-function (xgetpointercontrol (:name "XGetPointerControl")) +(def-exported-foreign-function (xgetpointercontrol (:name "XGetPointerControl")) (dpy (:pointer display)) (accel-numer (:pointer int)) (accel-denom (:pointer int)) (threshold (:pointer int))) -(def-exported-foreign-function (xgetpointermapping (:return-type int) (:name "XGetPointerMapping")) +(def-exported-foreign-function (xgetpointermapping (:return-type int) (:name "XGetPointerMapping")) (dpy (:pointer display)) (map (:pointer unsigned-char)) (nmaps int)) -(def-exported-foreign-function (xgetkeyboardmapping (:return-type (:pointer keysym)) (:name "XGetKeyboardMapping")) +(def-exported-foreign-function (xgetkeyboardmapping (:return-type (:pointer keysym)) (:name "XGetKeyboardMapping")) (dpy (:pointer display)) (first-keycode :character) ;; (first-keycode keycode) (count int) (keysyms-per-keycode (:pointer int))) -(def-exported-foreign-function (xgetwindowproperty (:return-type int) (:name "XGetWindowProperty")) +(def-exported-foreign-function (xgetwindowproperty (:return-type int) (:name "XGetWindowProperty")) (dpy (:pointer display)) (w window) (property :unsigned-32bit) @@ -641,23 +641,23 @@ (bytesafter (:pointer unsigned-long)) (prop (:pointer (:pointer unsigned-char)))) -(def-exported-foreign-function (xgetselectionowner (:return-type window) (:name "XGetSelectionOwner")) +(def-exported-foreign-function (xgetselectionowner (:return-type window) (:name "XGetSelectionOwner")) (dpy (:pointer display)) (selection :unsigned-32bit)) -(def-exported-foreign-function (xgetscreensaver (:name "XGetScreenSaver")) +(def-exported-foreign-function (xgetscreensaver (:name "XGetScreenSaver")) (dpy (:pointer display)) (timeout (:pointer int)) (interval (:pointer int)) (prefer-blanking (:pointer int)) (allow-exp (:pointer int))) -(def-exported-foreign-function (xgetwindowattributes (:return-type int) (:name "XGetWindowAttributes")) +(def-exported-foreign-function (xgetwindowattributes (:return-type int) (:name "XGetWindowAttributes")) (dpy (:pointer display)) (w window) (att (:pointer xwindowattributes))) -(def-exported-foreign-function (xgrabbutton (:name "XGrabButton")) +(def-exported-foreign-function (xgrabbutton (:name "XGrabButton")) (dpy (:pointer display)) (modifiers unsigned-int) (button unsigned-int) @@ -669,7 +669,7 @@ (confine-to window) (curs cursor)) -(def-exported-foreign-function (xgrabkey (:name "XGrabKey")) +(def-exported-foreign-function (xgrabkey (:name "XGrabKey")) (dpy (:pointer display)) (key int) (modifiers unsigned-int) @@ -678,7 +678,7 @@ (pointer-mode int) (keyboard-mode int)) -(def-exported-foreign-function (xgrabkeyboard (:return-type int) (:name "XGrabKeyboard")) +(def-exported-foreign-function (xgrabkeyboard (:return-type int) (:name "XGrabKeyboard")) (dpy (:pointer display)) (window window) (ownerevents int) @@ -686,7 +686,7 @@ (keyboardmode int) (time :unsigned-32bit)) -(def-exported-foreign-function (xgrabpointer (:return-type int) (:name "XGrabPointer")) +(def-exported-foreign-function (xgrabpointer (:return-type int) (:name "XGrabPointer")) (dpy (:pointer display)) (grab-window window) (owner-events int) @@ -697,119 +697,119 @@ (curs cursor) (time :unsigned-32bit)) -(def-exported-foreign-function (xgrabserver (:name "XGrabServer")) +(def-exported-foreign-function (xgrabserver (:name "XGrabServer")) (dpy (:pointer display))) -(def-exported-foreign-function (xaddhost (:name "XAddHost")) +(def-exported-foreign-function (xaddhost (:name "XAddHost")) (dpy (:pointer display)) (host (:pointer xhostaddress))) -(def-exported-foreign-function (xremovehost (:name "XRemoveHost")) +(def-exported-foreign-function (xremovehost (:name "XRemoveHost")) (dpy (:pointer display)) (host (:pointer xhostaddress))) -(def-exported-foreign-function (xaddhosts (:name "XAddHosts")) +(def-exported-foreign-function (xaddhosts (:name "XAddHosts")) (dpy (:pointer display)) (hosts (:pointer xhostaddress)) (n int)) -(def-exported-foreign-function (xremovehosts (:name "XRemoveHosts")) +(def-exported-foreign-function (xremovehosts (:name "XRemoveHosts")) (dpy (:pointer display)) (hosts (:pointer xhostaddress)) (n int)) -(def-exported-foreign-function (xifevent (:name "XIfEvent")) +(def-exported-foreign-function (xifevent (:name "XIfEvent")) (dpy (:pointer display)) (event (:pointer xevent)) (predicate (:pointer :pointer)) (arg (:pointer char))) -(def-exported-foreign-function (xinitextension (:return-type (:pointer xextcodes)) (:name "XInitExtension")) +(def-exported-foreign-function (xinitextension (:return-type (:pointer xextcodes)) (:name "XInitExtension")) (dpy (:pointer display)) (name (:pointer char))) -(def-exported-foreign-function (xaddextension (:return-type (:pointer xextcodes)) (:name "XAddExtension")) +(def-exported-foreign-function (xaddextension (:return-type (:pointer xextcodes)) (:name "XAddExtension")) (dpy (:pointer display))) -(def-exported-foreign-function (xeheadofextensionlist (:return-type (:pointer (:pointer xextdata))) (:name "XEHeadOfExtensionList")) +(def-exported-foreign-function (xeheadofextensionlist (:return-type (:pointer (:pointer xextdata))) (:name "XEHeadOfExtensionList")) (object xedataobject)) -(def-exported-foreign-function (xfindonextensionlist (:return-type (:pointer xextdata)) (:name "XFindOnExtensionList")) +(def-exported-foreign-function (xfindonextensionlist (:return-type (:pointer xextdata)) (:name "XFindOnExtensionList")) (structure (:pointer (:pointer xextdata))) (number int)) -(def-exported-foreign-function (xesetcreategc (:return-type (:pointer :pointer)) (:name "XESetCreateGC")) +(def-exported-foreign-function (xesetcreategc (:return-type (:pointer :pointer)) (:name "XESetCreateGC")) (dpy (:pointer display)) (extension int) (proc (:pointer :pointer))) -(def-exported-foreign-function (xesetcopygc (:return-type (:pointer :pointer)) (:name "XESetCopyGC")) +(def-exported-foreign-function (xesetcopygc (:return-type (:pointer :pointer)) (:name "XESetCopyGC")) (dpy (:pointer display)) (extension int) (proc (:pointer :pointer))) -(def-exported-foreign-function (xesetflushgc (:return-type (:pointer :pointer)) (:name "XESetFlushGC")) +(def-exported-foreign-function (xesetflushgc (:return-type (:pointer :pointer)) (:name "XESetFlushGC")) (dpy (:pointer display)) (extension int) (proc (:pointer :pointer))) -(def-exported-foreign-function (xesetfreegc (:return-type (:pointer :pointer)) (:name "XESetFreeGC")) +(def-exported-foreign-function (xesetfreegc (:return-type (:pointer :pointer)) (:name "XESetFreeGC")) (dpy (:pointer display)) (extension int) (proc (:pointer :pointer))) -(def-exported-foreign-function (xesetcreatefont (:return-type (:pointer :pointer)) (:name "XESetCreateFont")) +(def-exported-foreign-function (xesetcreatefont (:return-type (:pointer :pointer)) (:name "XESetCreateFont")) (dpy (:pointer display)) (extension int) (proc (:pointer :pointer))) -(def-exported-foreign-function (xesetfreefont (:return-type (:pointer :pointer)) (:name "XESetFreeFont")) +(def-exported-foreign-function (xesetfreefont (:return-type (:pointer :pointer)) (:name "XESetFreeFont")) (dpy (:pointer display)) (extension int) (proc (:pointer :pointer))) -(def-exported-foreign-function (xesetclosedisplay (:return-type (:pointer :pointer)) (:name "XESetCloseDisplay")) +(def-exported-foreign-function (xesetclosedisplay (:return-type (:pointer :pointer)) (:name "XESetCloseDisplay")) (dpy (:pointer display)) (extension int) (proc (:pointer :pointer))) -(def-exported-foreign-function (xesetwiretoevent (:return-type (:pointer :pointer)) (:name "XESetWireToEvent")) +(def-exported-foreign-function (xesetwiretoevent (:return-type (:pointer :pointer)) (:name "XESetWireToEvent")) (dpy (:pointer display)) (proc (:pointer :pointer)) (event-number int)) -(def-exported-foreign-function (xeseteventtowire (:return-type (:pointer :pointer)) (:name "XESetEventToWire")) +(def-exported-foreign-function (xeseteventtowire (:return-type (:pointer :pointer)) (:name "XESetEventToWire")) (dpy (:pointer display)) (proc (:pointer :pointer)) (event-number int)) -(def-exported-foreign-function (xeseterror (:return-type (:pointer :pointer)) (:name "XESetError")) +(def-exported-foreign-function (xeseterror (:return-type (:pointer :pointer)) (:name "XESetError")) (dpy (:pointer display)) (extension int) (proc (:pointer :pointer))) -(def-exported-foreign-function (xeseterrorstring (:return-type (:pointer :pointer)) (:name "XESetErrorString")) +(def-exported-foreign-function (xeseterrorstring (:return-type (:pointer :pointer)) (:name "XESetErrorString")) (dpy (:pointer display)) (extension int) (proc (:pointer :pointer))) -(def-exported-foreign-function (xinstallcolormap (:name "XInstallColormap")) +(def-exported-foreign-function (xinstallcolormap (:name "XInstallColormap")) (dpy (:pointer display)) (cmap colormap)) -(def-exported-foreign-function (xinternatom (:return-type :unsigned-32bit) (:name "XInternAtom")) +(def-exported-foreign-function (xinternatom (:return-type :unsigned-32bit) (:name "XInternAtom")) (dpy (:pointer display)) (name (:pointer char)) (onlyifexists int)) -(def-exported-foreign-function (xrefreshkeyboardmapping (:name "XRefreshKeyboardMapping")) +(def-exported-foreign-function (xrefreshkeyboardmapping (:name "XRefreshKeyboardMapping")) (event (:pointer xmappingevent))) #+ignore -(def-exported-foreign-function (xusekeymap (:return-type int) (:name "XUseKeymap")) +(def-exported-foreign-function (xusekeymap (:return-type int) (:name "XUseKeymap")) (filename (:pointer char))) -(def-exported-foreign-function (xrebindkeysym (:name "XRebindKeysym")) +(def-exported-foreign-function (xrebindkeysym (:name "XRebindKeysym")) (dpy (:pointer display)) (keysym keysym) (mlist (:pointer keysym)) @@ -817,217 +817,217 @@ (str (:pointer unsigned-char)) (nbytes int)) -(def-exported-foreign-function (xkillclient (:name "XKillClient")) +(def-exported-foreign-function (xkillclient (:name "XKillClient")) (dpy (:pointer display)) (resource xid)) -(def-exported-foreign-function (xlisthosts (:return-type (:pointer xhostaddress)) (:name "XListHosts")) +(def-exported-foreign-function (xlisthosts (:return-type (:pointer xhostaddress)) (:name "XListHosts")) (dpy (:pointer display)) (nhosts (:pointer int)) (enabled (:pointer int))) -(def-exported-foreign-function (xlistinstalledcolormaps (:return-type (:pointer colormap)) (:name "XListInstalledColormaps")) +(def-exported-foreign-function (xlistinstalledcolormaps (:return-type (:pointer colormap)) (:name "XListInstalledColormaps")) (dpy (:pointer display)) (win window) (n (:pointer int))) -(def-exported-foreign-function (xlistproperties (:return-type (:pointer atom)) (:name "XListProperties")) +(def-exported-foreign-function (xlistproperties (:return-type (:pointer atom)) (:name "XListProperties")) (dpy (:pointer display)) (window window) (n-props (:pointer int))) -(def-exported-foreign-function (xlistextensions (:return-type (:pointer (:pointer char))) (:name "XListExtensions")) +(def-exported-foreign-function (xlistextensions (:return-type (:pointer (:pointer char))) (:name "XListExtensions")) (dpy (:pointer display)) (nextensions (:pointer int))) -(def-exported-foreign-function (xfreeextensionlist (:name "XFreeExtensionList")) +(def-exported-foreign-function (xfreeextensionlist (:name "XFreeExtensionList")) (list (:pointer (:pointer char)))) -(def-exported-foreign-function (xloadfont (:return-type font) (:name "XLoadFont")) +(def-exported-foreign-function (xloadfont (:return-type font) (:name "XLoadFont")) (dpy (:pointer display)) (name (:pointer char))) -(def-exported-foreign-function (xlookupcolor (:return-type int) (:name "XLookupColor")) +(def-exported-foreign-function (xlookupcolor (:return-type int) (:name "XLookupColor")) (dpy (:pointer display)) (cmap colormap) (spec (:pointer char)) (def (:pointer xcolor)) (scr (:pointer xcolor))) -(def-exported-foreign-function (xlowerwindow (:name "XLowerWindow")) +(def-exported-foreign-function (xlowerwindow (:name "XLowerWindow")) (dpy (:pointer display)) (w window)) -(def-exported-foreign-function (xconnectionnumber (:return-type int) (:name "XConnectionNumber")) +(def-exported-foreign-function (xconnectionnumber (:return-type int) (:name "XConnectionNumber")) (dpy (:pointer display))) -(def-exported-foreign-function (xrootwindow (:return-type window) (:name "XRootWindow")) +(def-exported-foreign-function (xrootwindow (:return-type window) (:name "XRootWindow")) (dpy (:pointer display)) (scr int)) -(def-exported-foreign-function (xdefaultscreen (:return-type int) (:name "XDefaultScreen")) +(def-exported-foreign-function (xdefaultscreen (:return-type int) (:name "XDefaultScreen")) (dpy (:pointer display))) -(def-exported-foreign-function (xdefaultrootwindow (:return-type window) (:name "XDefaultRootWindow")) +(def-exported-foreign-function (xdefaultrootwindow (:return-type window) (:name "XDefaultRootWindow")) (dpy (:pointer display))) -(def-exported-foreign-function (xdefaultvisual (:return-type (:pointer visual)) (:name "XDefaultVisual")) +(def-exported-foreign-function (xdefaultvisual (:return-type (:pointer visual)) (:name "XDefaultVisual")) (dpy (:pointer display)) (scr int)) -(def-exported-foreign-function (xdefaultgc (:return-type gc) (:name "XDefaultGC")) +(def-exported-foreign-function (xdefaultgc (:return-type gc) (:name "XDefaultGC")) (dpy (:pointer display)) (scr int)) -(def-exported-foreign-function (xblackpixel (:return-type unsigned-long) (:name "XBlackPixel")) +(def-exported-foreign-function (xblackpixel (:return-type unsigned-long) (:name "XBlackPixel")) (dpy (:pointer display)) (scr int)) -(def-exported-foreign-function (xwhitepixel (:return-type unsigned-long) (:name "XWhitePixel")) +(def-exported-foreign-function (xwhitepixel (:return-type unsigned-long) (:name "XWhitePixel")) (dpy (:pointer display)) (scr int)) (def-exported-foreign-function (xallplanes (:return-type unsigned-long) (:name "XAllPlanes")) ) -(def-exported-foreign-function (xqlength (:return-type int) (:name "XQLength")) +(def-exported-foreign-function (xqlength (:return-type int) (:name "XQLength")) (dpy (:pointer display))) -(def-exported-foreign-function (xdisplaywidth (:return-type int) (:name "XDisplayWidth")) +(def-exported-foreign-function (xdisplaywidth (:return-type int) (:name "XDisplayWidth")) (dpy (:pointer display)) (scr int)) -(def-exported-foreign-function (xdisplayheight (:return-type int) (:name "XDisplayHeight")) +(def-exported-foreign-function (xdisplayheight (:return-type int) (:name "XDisplayHeight")) (dpy (:pointer display)) (scr int)) -(def-exported-foreign-function (xdisplaywidthmm (:return-type int) (:name "XDisplayWidthMM")) +(def-exported-foreign-function (xdisplaywidthmm (:return-type int) (:name "XDisplayWidthMM")) (dpy (:pointer display)) (scr int)) -(def-exported-foreign-function (xdisplayheightmm (:return-type int) (:name "XDisplayHeightMM")) +(def-exported-foreign-function (xdisplayheightmm (:return-type int) (:name "XDisplayHeightMM")) (dpy (:pointer display)) (scr int)) -(def-exported-foreign-function (xdisplayplanes (:return-type int) (:name "XDisplayPlanes")) +(def-exported-foreign-function (xdisplayplanes (:return-type int) (:name "XDisplayPlanes")) (dpy (:pointer display)) (scr int)) -(def-exported-foreign-function (xdisplaycells (:return-type int) (:name "XDisplayCells")) +(def-exported-foreign-function (xdisplaycells (:return-type int) (:name "XDisplayCells")) (dpy (:pointer display)) (scr int)) -(def-exported-foreign-function (xscreencount (:return-type int) (:name "XScreenCount")) +(def-exported-foreign-function (xscreencount (:return-type int) (:name "XScreenCount")) (dpy (:pointer display))) -(def-exported-foreign-function (xservervendor (:return-type (:pointer char)) (:name "XServerVendor")) +(def-exported-foreign-function (xservervendor (:return-type (:pointer char)) (:name "XServerVendor")) (dpy (:pointer display))) -(def-exported-foreign-function (xprotocolversion (:return-type int) (:name "XProtocolVersion")) +(def-exported-foreign-function (xprotocolversion (:return-type int) (:name "XProtocolVersion")) (dpy (:pointer display))) -(def-exported-foreign-function (xprotocolrevision (:return-type int) (:name "XProtocolRevision")) +(def-exported-foreign-function (xprotocolrevision (:return-type int) (:name "XProtocolRevision")) (dpy (:pointer display))) -(def-exported-foreign-function (xvendorrelease (:return-type int) (:name "XVendorRelease")) +(def-exported-foreign-function (xvendorrelease (:return-type int) (:name "XVendorRelease")) (dpy (:pointer display))) -(def-exported-foreign-function (xdisplaystring (:return-type (:pointer char)) (:name "XDisplayString")) +(def-exported-foreign-function (xdisplaystring (:return-type (:pointer char)) (:name "XDisplayString")) (dpy (:pointer display))) -(def-exported-foreign-function (xdefaultdepth (:return-type int) (:name "XDefaultDepth")) +(def-exported-foreign-function (xdefaultdepth (:return-type int) (:name "XDefaultDepth")) (dpy (:pointer display)) (scr int)) -(def-exported-foreign-function (xdefaultcolormap (:return-type colormap) (:name "XDefaultColormap")) +(def-exported-foreign-function (xdefaultcolormap (:return-type colormap) (:name "XDefaultColormap")) (dp (:pointer display)) (scr int)) -(def-exported-foreign-function (xbitmapunit (:return-type int) (:name "XBitmapUnit")) +(def-exported-foreign-function (xbitmapunit (:return-type int) (:name "XBitmapUnit")) (dpy (:pointer display))) -(def-exported-foreign-function (xbitmapbitorder (:return-type int) (:name "XBitmapBitOrder")) +(def-exported-foreign-function (xbitmapbitorder (:return-type int) (:name "XBitmapBitOrder")) (dpy (:pointer display))) -(def-exported-foreign-function (xbitmappad (:return-type int) (:name "XBitmapPad")) +(def-exported-foreign-function (xbitmappad (:return-type int) (:name "XBitmapPad")) (dpy (:pointer display))) -(def-exported-foreign-function (ximagebyteorder (:return-type int) (:name "XImageByteOrder")) +(def-exported-foreign-function (ximagebyteorder (:return-type int) (:name "XImageByteOrder")) (dpy (:pointer display))) -(def-exported-foreign-function (xnextrequest (:return-type unsigned-long) (:name "XNextRequest")) +(def-exported-foreign-function (xnextrequest (:return-type unsigned-long) (:name "XNextRequest")) (dpy (:pointer display))) -(def-exported-foreign-function (xlastknownrequestprocessed (:return-type unsigned-long) (:name "XLastKnownRequestProcessed")) +(def-exported-foreign-function (xlastknownrequestprocessed (:return-type unsigned-long) (:name "XLastKnownRequestProcessed")) (dpy (:pointer display))) -(def-exported-foreign-function (xscreenofdisplay (:return-type (:pointer screen)) (:name "XScreenOfDisplay")) +(def-exported-foreign-function (xscreenofdisplay (:return-type (:pointer screen)) (:name "XScreenOfDisplay")) (dpy (:pointer display)) (scr int)) -(def-exported-foreign-function (xdefaultscreenofdisplay (:return-type (:pointer screen)) (:name "XDefaultScreenOfDisplay")) +(def-exported-foreign-function (xdefaultscreenofdisplay (:return-type (:pointer screen)) (:name "XDefaultScreenOfDisplay")) (dpy (:pointer display))) -(def-exported-foreign-function (xdisplayofscreen (:return-type (:pointer display)) (:name "XDisplayOfScreen")) +(def-exported-foreign-function (xdisplayofscreen (:return-type (:pointer display)) (:name "XDisplayOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xrootwindowofscreen (:return-type window) (:name "XRootWindowOfScreen")) +(def-exported-foreign-function (xrootwindowofscreen (:return-type window) (:name "XRootWindowOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xblackpixelofscreen (:return-type unsigned-long) (:name "XBlackPixelOfScreen")) +(def-exported-foreign-function (xblackpixelofscreen (:return-type unsigned-long) (:name "XBlackPixelOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xwhitepixelofscreen (:return-type unsigned-long) (:name "XWhitePixelOfScreen")) +(def-exported-foreign-function (xwhitepixelofscreen (:return-type unsigned-long) (:name "XWhitePixelOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xdefaultcolormapofscreen (:return-type colormap) (:name "XDefaultColormapOfScreen")) +(def-exported-foreign-function (xdefaultcolormapofscreen (:return-type colormap) (:name "XDefaultColormapOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xdefaultdepthofscreen (:return-type int) (:name "XDefaultDepthOfScreen")) +(def-exported-foreign-function (xdefaultdepthofscreen (:return-type int) (:name "XDefaultDepthOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xdefaultgcofscreen (:return-type gc) (:name "XDefaultGCOfScreen")) +(def-exported-foreign-function (xdefaultgcofscreen (:return-type gc) (:name "XDefaultGCOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xdefaultvisualofscreen (:return-type (:pointer visual)) (:name "XDefaultVisualOfScreen")) +(def-exported-foreign-function (xdefaultvisualofscreen (:return-type (:pointer visual)) (:name "XDefaultVisualOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xwidthofscreen (:return-type int) (:name "XWidthOfScreen")) +(def-exported-foreign-function (xwidthofscreen (:return-type int) (:name "XWidthOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xheightofscreen (:return-type int) (:name "XHeightOfScreen")) +(def-exported-foreign-function (xheightofscreen (:return-type int) (:name "XHeightOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xwidthmmofscreen (:return-type int) (:name "XWidthMMOfScreen")) +(def-exported-foreign-function (xwidthmmofscreen (:return-type int) (:name "XWidthMMOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xheightmmofscreen (:return-type int) (:name "XHeightMMOfScreen")) +(def-exported-foreign-function (xheightmmofscreen (:return-type int) (:name "XHeightMMOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xplanesofscreen (:return-type int) (:name "XPlanesOfScreen")) +(def-exported-foreign-function (xplanesofscreen (:return-type int) (:name "XPlanesOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xcellsofscreen (:return-type int) (:name "XCellsOfScreen")) +(def-exported-foreign-function (xcellsofscreen (:return-type int) (:name "XCellsOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xmincmapsofscreen (:return-type int) (:name "XMinCmapsOfScreen")) +(def-exported-foreign-function (xmincmapsofscreen (:return-type int) (:name "XMinCmapsOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xmaxcmapsofscreen (:return-type int) (:name "XMaxCmapsOfScreen")) +(def-exported-foreign-function (xmaxcmapsofscreen (:return-type int) (:name "XMaxCmapsOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xdoessaveunders (:return-type int) (:name "XDoesSaveUnders")) +(def-exported-foreign-function (xdoessaveunders (:return-type int) (:name "XDoesSaveUnders")) (s (:pointer screen))) -(def-exported-foreign-function (xdoesbackingstore (:return-type int) (:name "XDoesBackingStore")) +(def-exported-foreign-function (xdoesbackingstore (:return-type int) (:name "XDoesBackingStore")) (s (:pointer screen))) -(def-exported-foreign-function (xeventmaskofscreen (:return-type long) (:name "XEventMaskOfScreen")) +(def-exported-foreign-function (xeventmaskofscreen (:return-type long) (:name "XEventMaskOfScreen")) (s (:pointer screen))) -(def-exported-foreign-function (xnoop (:name "XNoOp")) +(def-exported-foreign-function (xnoop (:name "XNoOp")) (dpy (:pointer display))) -(def-exported-foreign-function (XParseColor (:return-type int) +(def-exported-foreign-function (XParseColor (:return-type int) (:name "XParseColor")) (display (:pointer Display)) (colormap Colormap) @@ -1042,108 +1042,108 @@ (width-return (:pointer unsigned-int)) (height-return (:pointer unsigned-int))) -(def-exported-foreign-function (xmapraised (:name "XMapRaised")) +(def-exported-foreign-function (xmapraised (:name "XMapRaised")) (dpy (:pointer display)) (w window)) -(def-exported-foreign-function (xmapsubwindows (:name "XMapSubwindows")) +(def-exported-foreign-function (xmapsubwindows (:name "XMapSubwindows")) (dpy (:pointer display)) (win window)) -(def-exported-foreign-function (xmapwindow (:name "XMapWindow")) +(def-exported-foreign-function (xmapwindow (:name "XMapWindow")) (dpy (:pointer display)) (win window)) -(def-exported-foreign-function (xmaskevent (:name "XMaskEvent")) +(def-exported-foreign-function (xmaskevent (:name "XMaskEvent")) (dpy (:pointer display)) (mask long) (event (:pointer xevent))) -(def-exported-foreign-function (xmaxrequestsize (:return-type long) (:name "XMaxRequestSize")) +(def-exported-foreign-function (xmaxrequestsize (:return-type long) (:name "XMaxRequestSize")) (dpy (:pointer display))) -(def-exported-foreign-function (xresourcemanagerstring (:return-type (:pointer char)) (:name "XResourceManagerString")) +(def-exported-foreign-function (xresourcemanagerstring (:return-type (:pointer char)) (:name "XResourceManagerString")) (dpy (:pointer display))) -(def-exported-foreign-function (xdisplaymotionbuffersize (:return-type unsigned-long) (:name "XDisplayMotionBufferSize")) +(def-exported-foreign-function (xdisplaymotionbuffersize (:return-type unsigned-long) (:name "XDisplayMotionBufferSize")) (dpy (:pointer display))) -(def-exported-foreign-function (xdisplaykeycodes (:name "XDisplayKeycodes")) +(def-exported-foreign-function (xdisplaykeycodes (:name "XDisplayKeycodes")) (dpy (:pointer display)) (min-keycode-return (:pointer int)) (max-keycode-return (:pointer int))) -(def-exported-foreign-function (xvisualidfromvisual (:return-type visualid) (:name "XVisualIDFromVisual")) +(def-exported-foreign-function (xvisualidfromvisual (:return-type visualid) (:name "XVisualIDFromVisual")) (visual (:pointer visual))) -(def-exported-foreign-function (xgetmodifiermapping (:return-type (:pointer xmodifierkeymap)) (:name "XGetModifierMapping")) +(def-exported-foreign-function (xgetmodifiermapping (:return-type (:pointer xmodifierkeymap)) (:name "XGetModifierMapping")) (dpy (:pointer display))) -(def-exported-foreign-function (xsetmodifiermapping (:return-type int) (:name "XSetModifierMapping")) +(def-exported-foreign-function (xsetmodifiermapping (:return-type int) (:name "XSetModifierMapping")) (dpy (:pointer display)) (modifier-map (:pointer xmodifierkeymap))) -(def-exported-foreign-function (xnewmodifiermap (:return-type (:pointer xmodifierkeymap)) (:name "XNewModifiermap")) +(def-exported-foreign-function (xnewmodifiermap (:return-type (:pointer xmodifierkeymap)) (:name "XNewModifiermap")) (keyspermodifier int)) -(def-exported-foreign-function (xfreemodifiermap (:name "XFreeModifiermap")) +(def-exported-foreign-function (xfreemodifiermap (:name "XFreeModifiermap")) (map (:pointer xmodifierkeymap))) -(def-exported-foreign-function (xinsertmodifiermapentry (:return-type (:pointer xmodifierkeymap)) (:name "XInsertModifiermapEntry")) +(def-exported-foreign-function (xinsertmodifiermapentry (:return-type (:pointer xmodifierkeymap)) (:name "XInsertModifiermapEntry")) (map (:pointer xmodifierkeymap)) (keysym :character) ;; (keysym keycode) (modifier int)) -(def-exported-foreign-function (xdeletemodifiermapentry (:return-type (:pointer xmodifierkeymap)) (:name "XDeleteModifiermapEntry")) +(def-exported-foreign-function (xdeletemodifiermapentry (:return-type (:pointer xmodifierkeymap)) (:name "XDeleteModifiermapEntry")) (map (:pointer xmodifierkeymap)) (keysym :character) ;; (keysym keycode) (modifier int)) -(def-exported-foreign-function (xmovewindow (:name "XMoveWindow")) +(def-exported-foreign-function (xmovewindow (:name "XMoveWindow")) (dpy (:pointer display)) (w window) (x int) (y int)) -(def-exported-foreign-function (xnextevent (:name "XNextEvent")) +(def-exported-foreign-function (xnextevent (:name "XNextEvent")) (dpy (:pointer display)) (event (:pointer xevent))) -(def-exported-foreign-function (xopendisplay (:return-type (:pointer display)) (:name "XOpenDisplay")) +(def-exported-foreign-function (xopendisplay (:return-type (:pointer display)) (:name "XOpenDisplay")) (display (:pointer char))) -(def-exported-foreign-function (xpeekevent (:name "XPeekEvent")) +(def-exported-foreign-function (xpeekevent (:name "XPeekEvent")) (dpy (:pointer display)) (event (:pointer xevent))) -(def-exported-foreign-function (xpeekifevent (:name "XPeekIfEvent")) +(def-exported-foreign-function (xpeekifevent (:name "XPeekIfEvent")) (dpy (:pointer display)) (event (:pointer xevent)) (predicate (:pointer :pointer)) (arg (:pointer char))) -(def-exported-foreign-function (xeventsqueued (:return-type int) (:name "XEventsQueued")) +(def-exported-foreign-function (xeventsqueued (:return-type int) (:name "XEventsQueued")) (dpy (:pointer display)) (mode int)) -(def-exported-foreign-function (xpending (:return-type fixnum-int) (:name "XPending")) +(def-exported-foreign-function (xpending (:return-type fixnum-int) (:name "XPending")) (dpy (:pointer display))) -(def-exported-foreign-function (xsetwindowbackgroundpixmap (:name "XSetWindowBackgroundPixmap")) +(def-exported-foreign-function (xsetwindowbackgroundpixmap (:name "XSetWindowBackgroundPixmap")) (dpy (:pointer display)) (w window) (pixmap pixmap)) -(def-exported-foreign-function (xsetwindowborderpixmap (:name "XSetWindowBorderPixmap")) +(def-exported-foreign-function (xsetwindowborderpixmap (:name "XSetWindowBorderPixmap")) (dpy (:pointer display)) (w window) (pixmap pixmap)) -(def-exported-foreign-function (xputbackevent (:name "XPutBackEvent")) +(def-exported-foreign-function (xputbackevent (:name "XPutBackEvent")) (dpy (:pointer display)) (event (:pointer xevent))) -(def-exported-foreign-function (xputimage (:name "XPutImage")) +(def-exported-foreign-function (xputimage (:name "XPutImage")) (dpy (:pointer display)) (d drawable) (gc gc) @@ -1155,7 +1155,7 @@ (req-xoffset int) (req-yoffset int)) -(def-exported-foreign-function (xquerybestsize (:return-type int) (:name "XQueryBestSize")) +(def-exported-foreign-function (xquerybestsize (:return-type int) (:name "XQueryBestSize")) (dpy (:pointer display)) (class int) (drawable drawable) @@ -1164,18 +1164,18 @@ (ret-width (:pointer unsigned-int)) (ret-height (:pointer unsigned-int))) -(def-exported-foreign-function (xquerycolor (:name "XQueryColor")) +(def-exported-foreign-function (xquerycolor (:name "XQueryColor")) (dpy (:pointer display)) (cmap colormap) (def (:pointer xcolor))) -(def-exported-foreign-function (xquerycolors (:name "XQueryColors")) +(def-exported-foreign-function (xquerycolors (:name "XQueryColors")) (dpy (:pointer display)) (cmap colormap) (defs (:pointer xcolor)) (ncolors int)) -(def-exported-foreign-function (xquerybestcursor (:return-type int) (:name "XQueryBestCursor")) +(def-exported-foreign-function (xquerybestcursor (:return-type int) (:name "XQueryBestCursor")) (dpy (:pointer display)) (drawable drawable) (width unsigned-int) @@ -1183,18 +1183,18 @@ (ret-width (:pointer unsigned-int)) (ret-height (:pointer unsigned-int))) -(def-exported-foreign-function (xqueryextension (:return-type int) (:name "XQueryExtension")) +(def-exported-foreign-function (xqueryextension (:return-type int) (:name "XQueryExtension")) (dpy (:pointer display)) (name (:pointer char)) (major-opcode (:pointer int)) (first-event (:pointer int)) (first-error (:pointer int))) -(def-exported-foreign-function (xquerykeymap (:name "XQueryKeymap")) +(def-exported-foreign-function (xquerykeymap (:name "XQueryKeymap")) (dpy (:pointer display)) (keys (:array char (32)))) -(def-exported-foreign-function (xquerypointer (:return-type int) (:name "XQueryPointer")) +(def-exported-foreign-function (xquerypointer (:return-type int) (:name "XQueryPointer")) (dpy (:pointer display)) (w window) (root (:pointer window)) @@ -1205,7 +1205,7 @@ (win-y (:pointer int)) (mask (:pointer unsigned-int))) -(def-exported-foreign-function (xquerybeststipple (:return-type int) (:name "XQueryBestStipple")) +(def-exported-foreign-function (xquerybeststipple (:return-type int) (:name "XQueryBestStipple")) (dpy (:pointer display)) (drawable drawable) (width unsigned-int) @@ -1213,7 +1213,7 @@ (ret-width (:pointer unsigned-int)) (ret-height (:pointer unsigned-int))) -(def-exported-foreign-function (xquerytextextents16 (:name "XQueryTextExtents16")) +(def-exported-foreign-function (xquerytextextents16 (:name "XQueryTextExtents16")) (dpy (:pointer display)) (fid font) (string (:pointer xchar2b)) @@ -1223,7 +1223,7 @@ (font-descent (:pointer int)) (overall (:pointer xcharstruct))) -(def-exported-foreign-function (xquerytextextents (:name "XQueryTextExtents")) +(def-exported-foreign-function (xquerytextextents (:name "XQueryTextExtents")) (dpy (:pointer display)) (fid font) (string (:pointer char)) @@ -1233,7 +1233,7 @@ (font-descent (:pointer int)) (overall (:pointer xcharstruct))) -(def-exported-foreign-function (xquerybesttile (:return-type int) (:name "XQueryBestTile")) +(def-exported-foreign-function (xquerybesttile (:return-type int) (:name "XQueryBestTile")) (dpy (:pointer display)) (drawable drawable) (width unsigned-int) @@ -1241,7 +1241,7 @@ (ret-width (:pointer unsigned-int)) (ret-height (:pointer unsigned-int))) -(def-exported-foreign-function (xquerytree (:return-type int) (:name "XQueryTree")) +(def-exported-foreign-function (xquerytree (:return-type int) (:name "XQueryTree")) (dpy (:pointer display)) (w window) (root (:pointer window)) @@ -1249,35 +1249,35 @@ (children (:pointer (:pointer window))) (nchildren (:pointer unsigned-int))) -(def-exported-foreign-function (xraisewindow (:name "XRaiseWindow")) +(def-exported-foreign-function (xraisewindow (:name "XRaiseWindow")) (dpy (:pointer display)) (w window)) -(def-exported-foreign-function (xrecolorcursor (:name "XRecolorCursor")) +(def-exported-foreign-function (xrecolorcursor (:name "XRecolorCursor")) (dpy (:pointer display)) (cursor cursor) (foreground (:pointer xcolor)) (background (:pointer xcolor))) -(def-exported-foreign-function (xconfigurewindow (:name "XConfigureWindow")) +(def-exported-foreign-function (xconfigurewindow (:name "XConfigureWindow")) (dpy (:pointer display)) (w window) (mask unsigned-int) (changes (:pointer xwindowchanges))) -(def-exported-foreign-function (xreparentwindow (:name "XReparentWindow")) +(def-exported-foreign-function (xreparentwindow (:name "XReparentWindow")) (dpy (:pointer display)) (w window) (p window) (x int) (y int)) -(def-exported-foreign-function (xrestackwindows (:name "XRestackWindows")) +(def-exported-foreign-function (xrestackwindows (:name "XRestackWindows")) (dpy (:pointer display)) (windows (:pointer window)) (n int)) -(def-exported-foreign-function (xrotatewindowproperties (:name "XRotateWindowProperties")) +(def-exported-foreign-function (xrotatewindowproperties (:name "XRotateWindowProperties")) (dpy (:pointer display)) (w window) (properties (:pointer atom)) @@ -1289,19 +1289,19 @@ (w window) (mask long)) -(def-exported-foreign-function (xsendevent (:return-type int) (:name "XSendEvent")) +(def-exported-foreign-function (xsendevent (:return-type int) (:name "XSendEvent")) (dpy (:pointer display)) (w window) (propagate int) (event-mask long) (event (:pointer xevent))) -(def-exported-foreign-function (xsetbackground (:name "XSetBackground")) +(def-exported-foreign-function (xsetbackground (:name "XSetBackground")) (dpy (:pointer display)) (gc gc) (background unsigned-long)) -(def-exported-foreign-function (xsetcliprectangles (:name "XSetClipRectangles")) +(def-exported-foreign-function (xsetcliprectangles (:name "XSetClipRectangles")) (dpy (:pointer display)) (gc gc) (clip-x-origin int) @@ -1310,57 +1310,57 @@ (n int) (ordering int)) -(def-exported-foreign-function (xsetclipmask (:name "XSetClipMask")) +(def-exported-foreign-function (xsetclipmask (:name "XSetClipMask")) (dpy (:pointer display)) (gc gc) (mask pixmap)) -(def-exported-foreign-function (xsetcliporigin (:name "XSetClipOrigin")) +(def-exported-foreign-function (xsetcliporigin (:name "XSetClipOrigin")) (dpy (:pointer display)) (gc gc) (xorig int) (yorig int)) -(def-exported-foreign-function (xsetdashes (:name "XSetDashes")) +(def-exported-foreign-function (xsetdashes (:name "XSetDashes")) (dpy (:pointer display)) (gc gc) (dash-offset int) (list (:pointer char)) (n int)) -(def-exported-foreign-function (xsetfontpath (:name "XSetFontPath")) +(def-exported-foreign-function (xsetfontpath (:name "XSetFontPath")) (dpy (:pointer display)) (directories (:pointer (:pointer char))) (ndirs int)) -(def-exported-foreign-function (xsetfont (:name "XSetFont")) +(def-exported-foreign-function (xsetfont (:name "XSetFont")) (dpy (:pointer display)) (gc gc) (font font)) -(def-exported-foreign-function (xsetforeground (:name "XSetForeground")) +(def-exported-foreign-function (xsetforeground (:name "XSetForeground")) (dpy (:pointer display)) (gc gc) (foreground unsigned-long)) -(def-exported-foreign-function (xsetfunction (:name "XSetFunction")) +(def-exported-foreign-function (xsetfunction (:name "XSetFunction")) (dpy (:pointer display)) (gc gc) (function int)) -(def-exported-foreign-function (xsetcommand (:name "XSetCommand")) +(def-exported-foreign-function (xsetcommand (:name "XSetCommand")) (dpy (:pointer display)) (w window) (argv (:pointer (:pointer char))) (argc int)) -(def-exported-foreign-function (xsetinputfocus (:name "XSetInputFocus")) +(def-exported-foreign-function (xsetinputfocus (:name "XSetInputFocus")) (dpy (:pointer display)) (focus window) (revert-to int) (time :unsigned-32bit)) -(def-exported-foreign-function (xsetlineattributes (:name "XSetLineAttributes")) +(def-exported-foreign-function (xsetlineattributes (:name "XSetLineAttributes")) (dpy (:pointer display)) (gc gc) (linewidth unsigned-int) @@ -1368,37 +1368,37 @@ (capstyle int) (joinstyle int)) -(def-exported-foreign-function (xsetplanemask (:name "XSetPlaneMask")) +(def-exported-foreign-function (xsetplanemask (:name "XSetPlaneMask")) (dpy (:pointer display)) (gc gc) (planemask unsigned-long)) -(def-exported-foreign-function (xsetpointermapping (:return-type int) (:name "XSetPointerMapping")) +(def-exported-foreign-function (xsetpointermapping (:return-type int) (:name "XSetPointerMapping")) (dpy (:pointer display)) (map (:pointer unsigned-char)) (nmaps int)) -(def-exported-foreign-function (xchangekeyboardmapping (:name "XChangeKeyboardMapping")) +(def-exported-foreign-function (xchangekeyboardmapping (:name "XChangeKeyboardMapping")) (dpy (:pointer display)) (first-keycode int) (keysyms-per-keycode int) (keysyms (:pointer keysym)) (nkeycodes int)) -(def-exported-foreign-function (xsetselectionowner (:name "XSetSelectionOwner")) +(def-exported-foreign-function (xsetselectionowner (:name "XSetSelectionOwner")) (dpy (:pointer display)) (selection :unsigned-32bit) (owner window) (time :unsigned-32bit)) -(def-exported-foreign-function (xsetscreensaver (:name "XSetScreenSaver")) +(def-exported-foreign-function (xsetscreensaver (:name "XSetScreenSaver")) (dpy (:pointer display)) (timeout int) (interval int) (prefer-blank int) (allow-exp int)) -(def-exported-foreign-function (xsetstate (:name "XSetState")) +(def-exported-foreign-function (xsetstate (:name "XSetState")) (dpy (:pointer display)) (gc gc) (function int) @@ -1406,69 +1406,69 @@ (foreground unsigned-long) (background unsigned-long)) -(def-exported-foreign-function (xsetstipple (:name "XSetStipple")) +(def-exported-foreign-function (xsetstipple (:name "XSetStipple")) (dpy (:pointer display)) (gc gc) (stipple pixmap)) -(def-exported-foreign-function (xsettsorigin (:name "XSetTSOrigin")) +(def-exported-foreign-function (xsettsorigin (:name "XSetTSOrigin")) (dpy (:pointer display)) (gc gc) (x int) (y int)) -(def-exported-foreign-function (xsettile (:name "XSetTile")) +(def-exported-foreign-function (xsettile (:name "XSetTile")) (dpy (:pointer display)) (gc gc) (tile pixmap)) -(def-exported-foreign-function (xstorecolor (:name "XStoreColor")) +(def-exported-foreign-function (xstorecolor (:name "XStoreColor")) (dpy (:pointer display)) (cmap colormap) (def (:pointer xcolor))) -(def-exported-foreign-function (xstorecolors (:name "XStoreColors")) +(def-exported-foreign-function (xstorecolors (:name "XStoreColors")) (dpy (:pointer display)) (cmap colormap) (defs (:pointer xcolor)) (ncolors int)) -(def-exported-foreign-function (xstorenamedcolor (:name "XStoreNamedColor")) +(def-exported-foreign-function (xstorenamedcolor (:name "XStoreNamedColor")) (dpy (:pointer display)) (cmap colormap) (name (:pointer char)) (pixel unsigned-long) (flags int)) -(def-exported-foreign-function (xstorename (:name "XStoreName")) +(def-exported-foreign-function (xstorename (:name "XStoreName")) (dpy (:pointer display)) (w window) (name (:pointer char))) -(def-exported-foreign-function (xseticonname (:name "XSetIconName")) +(def-exported-foreign-function (xseticonname (:name "XSetIconName")) (dpy (:pointer display)) (w window) (icon-name (:pointer char))) -(def-exported-foreign-function (xstringtokeysym (:return-type keysym) (:name "XStringToKeysym")) +(def-exported-foreign-function (xstringtokeysym (:return-type keysym) (:name "XStringToKeysym")) (s (:pointer char))) -(def-exported-foreign-function (xkeysymtostring (:return-type (:pointer char)) (:name "XKeysymToString")) +(def-exported-foreign-function (xkeysymtostring (:return-type (:pointer char)) (:name "XKeysymToString")) (ks keysym)) -(def-exported-foreign-function (xsync (:name "XSync")) +(def-exported-foreign-function (xsync (:name "XSync")) (dpy (:pointer display)) (discard int)) -(def-exported-foreign-function (xsynchronize (:return-type (:pointer :pointer)) (:name "XSynchronize")) +(def-exported-foreign-function (xsynchronize (:return-type (:pointer :pointer)) (:name "XSynchronize")) (dpy (:pointer display)) (onoff int)) -(def-exported-foreign-function (xsetafterfunction (:return-type (:pointer :pointer)) (:name "XSetAfterFunction")) +(def-exported-foreign-function (xsetafterfunction (:return-type (:pointer :pointer)) (:name "XSetAfterFunction")) (dpy (:pointer display)) (func (:pointer :pointer))) -(def-exported-foreign-function (xtextextents (:name "XTextExtents")) +(def-exported-foreign-function (xtextextents (:name "XTextExtents")) (fontstruct (:pointer xfontstruct)) (string (:pointer char)) (nchars int) @@ -1477,12 +1477,12 @@ (font-descent (:pointer int)) (overall (:pointer xcharstruct))) -(def-exported-foreign-function (xtextwidth (:return-type int) (:name "XTextWidth")) +(def-exported-foreign-function (xtextwidth (:return-type int) (:name "XTextWidth")) (fontstruct (:pointer xfontstruct)) (string (:pointer char)) (count int)) -(def-exported-foreign-function (xtextextents16 (:name "XTextExtents16")) +(def-exported-foreign-function (xtextextents16 (:name "XTextExtents16")) (fontstruct (:pointer xfontstruct)) (string (:pointer xchar2b)) (nchars int) @@ -1491,12 +1491,12 @@ (font-descent (:pointer int)) (overall (:pointer xcharstruct))) -(def-exported-foreign-function (xtextwidth16 (:return-type int) (:name "XTextWidth16")) +(def-exported-foreign-function (xtextwidth16 (:return-type int) (:name "XTextWidth16")) (fontstruct (:pointer xfontstruct)) (string (:pointer xchar2b)) (count int)) -(def-exported-foreign-function (xtranslatecoordinates (:return-type int) (:name "XTranslateCoordinates")) +(def-exported-foreign-function (xtranslatecoordinates (:return-type int) (:name "XTranslateCoordinates")) (dpy (:pointer display)) (src-win window) (dest-win window) @@ -1506,50 +1506,50 @@ (dst-y (:pointer int)) (child (:pointer window))) -(def-exported-foreign-function (xundefinecursor (:name "XUndefineCursor")) +(def-exported-foreign-function (xundefinecursor (:name "XUndefineCursor")) (dpy (:pointer display)) (w window)) -(def-exported-foreign-function (xungrabbutton (:name "XUngrabButton")) +(def-exported-foreign-function (xungrabbutton (:name "XUngrabButton")) (dpy (:pointer display)) (button unsigned-int) (modifiers unsigned-int) (grab-window window)) -(def-exported-foreign-function (xungrabkeyboard (:name "XUngrabKeyboard")) +(def-exported-foreign-function (xungrabkeyboard (:name "XUngrabKeyboard")) (dpy (:pointer display)) (time :unsigned-32bit)) -(def-exported-foreign-function (xungrabkey (:name "XUngrabKey")) +(def-exported-foreign-function (xungrabkey (:name "XUngrabKey")) (dpy (:pointer display)) (key int) (modifiers unsigned-int) (grab-window window)) -(def-exported-foreign-function (xungrabpointer (:name "XUngrabPointer")) +(def-exported-foreign-function (xungrabpointer (:name "XUngrabPointer")) (dpy (:pointer display)) (time :unsigned-32bit)) -(def-exported-foreign-function (xungrabserver (:name "XUngrabServer")) +(def-exported-foreign-function (xungrabserver (:name "XUngrabServer")) (dpy (:pointer display))) -(def-exported-foreign-function (xuninstallcolormap (:name "XUninstallColormap")) +(def-exported-foreign-function (xuninstallcolormap (:name "XUninstallColormap")) (dpy (:pointer display)) (cmap colormap)) -(def-exported-foreign-function (xunloadfont (:name "XUnloadFont")) +(def-exported-foreign-function (xunloadfont (:name "XUnloadFont")) (dpy (:pointer display)) (font font)) -(def-exported-foreign-function (xunmapsubwindows (:name "XUnmapSubwindows")) +(def-exported-foreign-function (xunmapsubwindows (:name "XUnmapSubwindows")) (dpy (:pointer display)) (win window)) -(def-exported-foreign-function (xunmapwindow (:name "XUnmapWindow")) +(def-exported-foreign-function (xunmapwindow (:name "XUnmapWindow")) (dpy (:pointer display)) (w window)) -(def-exported-foreign-function (xwarppointer (:name "XWarpPointer")) +(def-exported-foreign-function (xwarppointer (:name "XWarpPointer")) (dpy (:pointer display)) (src-win window) (dest-win window) @@ -1560,13 +1560,13 @@ (dest-x int) (dest-y int)) -(def-exported-foreign-function (xwindowevent (:name "XWindowEvent")) +(def-exported-foreign-function (xwindowevent (:name "XWindowEvent")) (dpy (:pointer display)) (w window) (mask long) (event (:pointer xevent))) -(def-exported-foreign-function (xcreatewindow (:return-type window) (:name "XCreateWindow")) +(def-exported-foreign-function (xcreatewindow (:return-type window) (:name "XCreateWindow")) (dpy (:pointer display)) (parent window) (x int) @@ -1580,7 +1580,7 @@ (valuemask unsigned-long) (attributes (:pointer xsetwindowattributes))) -(def-exported-foreign-function (xfree (:name "XFree")) +(def-exported-foreign-function (xfree (:name "XFree")) (data (:pointer char))) @@ -1645,15 +1645,15 @@ ;;; Xlib Output Functions ;;; -;;; All of the following functions have been modified - the type of int coordinate +;;; All of the following functions have been modified - the type of int coordinate ;;; arguments have been changed to fixnum-int, the type of drawable arguments ;;; have been changed to fixnum-drawable, the type of int and unsigned-int dimensions -;;; (length, npoints etc) arguments have been changed to fixnum-int or fixnum-unsigned-int, -;;; and the :return-type option has been omitted (to avoid consing up an integer -;;; return value). A function that draws a single character, XDrawChar function has +;;; (length, npoints etc) arguments have been changed to fixnum-int or fixnum-unsigned-int, +;;; and the :return-type option has been omitted (to avoid consing up an integer +;;; return value). A function that draws a single character, XDrawChar function has ;;; been added. -(def-exported-foreign-function (xdrawarc (:name "XDrawArc")) +(def-exported-foreign-function (xdrawarc (:name "XDrawArc")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) @@ -1664,14 +1664,14 @@ (angle1 fixnum-int) (angle2 fixnum-int)) -(def-exported-foreign-function (xdrawarcs (:name "XDrawArcs")) +(def-exported-foreign-function (xdrawarcs (:name "XDrawArcs")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) (arcs (:pointer xarc)) - (n-arcs fixnum-int)) + (n-arcs fixnum-int)) -(def-exported-foreign-function (xdrawline (:name "XDrawLine")) +(def-exported-foreign-function (xdrawline (:name "XDrawLine")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) @@ -1680,80 +1680,80 @@ (x2 fixnum-int) (y2 fixnum-int)) -(def-exported-foreign-function (xdrawlines (:name "XDrawLines")) +(def-exported-foreign-function (xdrawlines (:name "XDrawLines")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) (points (:pointer xpoint)) - (npoints fixnum-int) - (mode fixnum-int)) + (npoints fixnum-int) + (mode fixnum-int)) -(def-exported-foreign-function (xdrawpoint (:name "XDrawPoint")) +(def-exported-foreign-function (xdrawpoint (:name "XDrawPoint")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) (x fixnum-int) (y fixnum-int)) -(def-exported-foreign-function (xdrawpoints (:name "XDrawPoints")) +(def-exported-foreign-function (xdrawpoints (:name "XDrawPoints")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) (points (:pointer xpoint)) - (n-points fixnum-int) - (mode fixnum-int)) + (n-points fixnum-int) + (mode fixnum-int)) -(def-exported-foreign-function (xdrawrectangle (:name "XDrawRectangle")) +(def-exported-foreign-function (xdrawrectangle (:name "XDrawRectangle")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) (x fixnum-int) (y fixnum-int) - (width fixnum-unsigned-int) - (height fixnum-unsigned-int)) + (width fixnum-unsigned-int) + (height fixnum-unsigned-int)) -(def-exported-foreign-function (xdrawrectangles (:name "XDrawRectangles")) +(def-exported-foreign-function (xdrawrectangles (:name "XDrawRectangles")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) (rects (:pointer xrectangle)) (n-rects fixnum-int)) ;; was int -(def-exported-foreign-function (xdrawsegments (:name "XDrawSegments")) +(def-exported-foreign-function (xdrawsegments (:name "XDrawSegments")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) (segments (:pointer xsegment)) - (nsegments fixnum-int)) + (nsegments fixnum-int)) -(def-exported-foreign-function (xdrawimagestring (:name "XDrawImageString")) +(def-exported-foreign-function (xdrawimagestring (:name "XDrawImageString")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) (x fixnum-int) (y fixnum-int) (string (:pointer char)) - (length fixnum-int)) + (length fixnum-int)) -(def-exported-foreign-function (xdrawimagestring16 (:name "XDrawImageString16")) +(def-exported-foreign-function (xdrawimagestring16 (:name "XDrawImageString16")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) (x fixnum-int) (y fixnum-int) (string (:pointer xchar2b)) - (length fixnum-int)) + (length fixnum-int)) -(def-exported-foreign-function (xdrawtext (:name "XDrawText")) +(def-exported-foreign-function (xdrawtext (:name "XDrawText")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) (x fixnum-int) (y fixnum-int) (items (:pointer xtextitem)) - (nitems fixnum-int)) + (nitems fixnum-int)) -(def-exported-foreign-function (xdrawtext16 (:name "XDrawText16")) +(def-exported-foreign-function (xdrawtext16 (:name "XDrawText16")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) @@ -1762,7 +1762,7 @@ (items (:pointer xtextitem16)) (nitems fixnum-int)) -(def-exported-foreign-function (xdrawstring (:name "XDrawString")) +(def-exported-foreign-function (xdrawstring (:name "XDrawString")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) @@ -1771,7 +1771,7 @@ (string (:pointer char)) (length fixnum-int)) -(def-exported-foreign-function (xdrawstring16 (:name "XDrawString16")) +(def-exported-foreign-function (xdrawstring16 (:name "XDrawString16")) (dpy (:pointer display)) (d fixnum-drawable) (gc gc) @@ -1800,8 +1800,8 @@ (start fixnum-int) (end fixnum-int)) -(def-exported-foreign-function - (xpermalloc (:return-type (:pointer char)) +(def-exported-foreign-function + (xpermalloc (:return-type (:pointer char)) (:name "Xpermalloc")) (size unsigned-int)) @@ -1942,10 +1942,10 @@ (argc (:pointer int)) (argv (:pointer (:pointer char)))) -(def-exported-foreign-function (xallocwmhints +(def-exported-foreign-function (xallocwmhints (:name "XAllocWMHints") (:return-type (:pointer xwmhints)))) - + (def-exported-foreign-function (xsetwmhints (:name "XSetWMHints")) (display (:pointer display)) (window window) @@ -1959,7 +1959,7 @@ (def-exported-foreign-function (xallocsizehints (:name "XAllocSizeHints") (:return-type (:pointer xsizehints)))) - + (def-exported-foreign-function (xsetwmnormalhints (:return-type void) (:name "XSetWMNormalHints")) (display (:pointer display)) @@ -2000,7 +2000,7 @@ (keysym-return (:pointer keysym)) (status-in-out (:pointer xcomposestatus))) -(def-exported-foreign-function (xiconifywindow (:return-type int) (:name "XIconifyWindow")) +(def-exported-foreign-function (xiconifywindow (:return-type int) (:name "XIconifyWindow")) (dpy (:pointer display)) (win window) (scr int)) @@ -2015,6 +2015,11 @@ (vinfo-return (:pointer visual-info))) -(def-exported-foreign-function (_xflushgccache (:name "_XFlushGCCache")) +(def-exported-foreign-function (_xflushgccache (:name "_XFlushGCCache")) (dpy (:pointer display)) - (gc gc)) + (gc gc)) + +(def-exported-foreign-function (_xgetbitsperpixel (:return-type int) + (:name "_XGetBitsPerPixel")) + (dpy (:pointer display)) + (depth int)) -- GitLab