diff --git a/Makefile b/Makefile index 1b6bdb124cb10f32d3fdce2306c3c910b50b30a5..e6ad41f68eb8b47dc6933955c9143d3d9bb1744c 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# $fiHeader: Makefile,v 1.14 92/03/02 18:38:46 cer Exp Locker: cer $ +# $fiHeader: Makefile,v 1.15 92/03/09 17:42:01 cer Exp Locker: cer $ # # Makefile for CLIM 2.0 # @@ -92,6 +92,7 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \ clim/input-protocol.fasl \ clim/output-protocol.fasl \ clim/recording-protocol.fasl \ + clim/recording-defs.fasl \ clim/text-recording.fasl \ clim/graphics-recording.fasl \ clim/interactive-protocol.fasl \ diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index ed978c51d558829f855b0b2e55dcdd84ebc9b74e..da99a5c10c191cb535800ca6db104886cb4c959d 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.9 92/03/04 16:21:04 cer Exp Locker: cer $ +;; $fiHeader: accept-values.lisp,v 1.9 92/03/04 16:21:04 cer Exp $ (in-package :clim-internals) @@ -361,7 +361,7 @@ :stream command-stream :command-parser 'menu-command-parser :use-keystrokes t))))) - (if (and command (not (characterp command))) + (if (and command (not (keyboard-event-p command))) (execute-frame-command frame command) (beep stream))) (when (or resynchronize-every-pass (slot-value avv-record 'resynchronize)) @@ -558,7 +558,7 @@ (map-queries avv-record))) #+Genera -(define-accept-values-command (com-next-avv-choice :keystroke #\c-N) +(define-accept-values-command (com-next-avv-choice :keystroke (:n :control)) () (with-slots (stream selected-item) *application-frame* (let ((avv-record (slot-value stream 'avv-record))) @@ -581,7 +581,7 @@ (setq found-item t))))))))))) #+Genera -(define-accept-values-command (com-previous-avv-choice :keystroke #\c-P) +(define-accept-values-command (com-previous-avv-choice :keystroke (:p :control)) () (with-slots (stream selected-item) *application-frame* (let ((avv-record (slot-value stream 'avv-record))) @@ -593,7 +593,7 @@ ))))) #+Genera -(add-keystroke-to-command-table 'accept-values #\c-E :function +(add-keystroke-to-command-table 'accept-values '(:e :control) :function #'(lambda (gesture numeric-argument) (declare (ignore gesture numeric-argument)) (with-slots (selected-item) *application-frame* @@ -622,15 +622,11 @@ (setf value nil changed-p t)))) -(define-accept-values-command (com-exit-avv :keystroke #+Genera #\End - ;; what the key labelled END gives - #+CCL-2 #\^D - #-(or Genera CCL-2) nil) +(define-accept-values-command (com-exit-avv :keystroke :end) () (invoke-restart 'frame-exit)) -(define-accept-values-command (com-abort-avv :keystroke #+Genera #\Abort - #-Genera nil) +(define-accept-values-command (com-abort-avv :keystroke :abort) () (abort)) @@ -1078,7 +1074,7 @@ (defmethod value-changed-callback ((gadget radio-box) (client accept-values-stream) id new-value) - (do-avv-command new-value client id)) + (do-avv-command (gadget-id new-value) client id)) (defun do-avv-command (new-value client id) (throw-highlighted-presentation diff --git a/clim/accept.lisp b/clim/accept.lisp index e6c8c7fb2e5bba3b55412de2e2c785c507e18b7e..3045941a6a7f8edd8f281d54c380e58ea7978fdd 100644 --- a/clim/accept.lisp +++ b/clim/accept.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: accept.lisp,v 1.3 92/02/24 13:06:53 cer Exp $ +;; $fiHeader: accept.lisp,v 1.4 92/03/04 16:21:07 cer Exp $ (in-package :clim-internals) @@ -246,9 +246,9 @@ ;; The input has been parsed, moused, or defaulted. ;; If we are still inside a WITH-INPUT-EDITING at an outer level, leave the ;; delimiter in the stream. But if this was the top level of input, eat - ;; the activation character instead of leaving it in the stream. - ;; Don't eat the activation character on streams that can't ever support - ;; input editing, such as string streams. + ;; the activation gesture instead of leaving it in the stream. Don't eat + ;; the activation gesture on streams that can't ever support input editing, + ;; such as string streams. ;;--- This is really lousy. We need a coherent theory here. (when activated (when (and (not (input-editing-stream-p stream)) diff --git a/clim/command-processor.lisp b/clim/command-processor.lisp index 02c900f68ffff36141449effc9264edb10376891..fce22fadf8c584dcc81f98edc8d7514529e9f911 100644 --- a/clim/command-processor.lisp +++ b/clim/command-processor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: command-processor.lisp,v 1.3 92/02/24 13:07:05 cer Exp $ +;; $fiHeader: command-processor.lisp,v 1.4 92/03/04 16:21:13 cer Exp $ (in-package :clim-internals) @@ -15,7 +15,8 @@ ;;; What separates command args. (defparameter *command-argument-delimiters* '(#\Space)) -(defparameter *command-previewers* '(#+Genera #\m-Complete)) +(define-gesture-name :preview-command :keyboard (:complete :meta)) +(defparameter *command-previewers* '(:preview-command)) ;; This is around only to provide a input context "wall" during parsing (define-presentation-type command-arguments ()) @@ -46,7 +47,8 @@ (multiple-value-bind (command final-delimiter) (invoke-command-name-parser-and-collect-1 command-name arg-parser delimiter-parser stream) - (if (member final-delimiter *command-previewers*) + (if (member final-delimiter *command-previewers* + :test #'keyboard-event-matches-gesture-name-p) (with-input-editor-typeout (stream) (accept-values-command-parser command-name command-table @@ -97,9 +99,9 @@ (when (and activation-p (activation-gesture-p delimiter)) (unread-gesture delimiter :stream stream) (when echo-space - ;; If we're not finished yet, leave the activation character for later, - ;; insert a space in front of it, and read past the space. Something like - ;; the echo of a default will come after the space. + ;; If we're not finished yet, leave the activation gesture for later, + ;; insert a space in front of it, and read past the space. Something + ;; like the echo of a default will come after the space. ;; Must REPLACE-INPUT after UNREAD-GESTURE so the delimiter is unread ;; into the input editor's buffer, not the underlying stream's buffer. (when (input-editing-stream-p stream) @@ -183,12 +185,12 @@ (when (activation-gesture-p char) (return char)) (unless (whitespace-char-p char) - (simple-parse-error "Extraneous character seen"))))) + (simple-parse-error "Extraneous character seen at end of line"))))) ((eq args-to-go :keywords) ;; Reached before reading the first keyword argument ;; If this is a command with no positional arguments, the preceding call - ;; should have had args-to-go = (&key ...), but actually had :args - ;; Compensate for that by checking for an activation character now + ;; should have had args-to-go = (&key ...), but actually had :ARGS. + ;; Compensate for that by checking for an activation gesture now (let ((char (read-gesture :stream stream :timeout 0))) (when char (unread-gesture char :stream stream) @@ -388,11 +390,12 @@ (read-gesture :stream stream :timeout timeout)))) (when (eq numeric-arg :timeout) (return-from menu-command-parser nil)) - (when (characterp keystroke) - (let ((command (lookup-keystroke-command-item - keystroke command-table - :test #'char-equal - :numeric-argument numeric-arg))) + (when (keyboard-event-p keystroke) + (let ((command + (lookup-keystroke-command-item + keystroke command-table + :test #'keyboard-event-matches-gesture-name-p + :numeric-argument numeric-arg))) (when (presentation-typep command command-type) (return-from menu-command-parser (values command command-type))))) @@ -665,7 +668,7 @@ (command-unparser *command-unparser*) (partial-command-parser *partial-command-parser*) (use-keystrokes nil) - (keystroke-test #'eql)) + (keystroke-test #'keyboard-event-matches-gesture-name-p)) (if use-keystrokes (with-command-table-keystrokes (keystrokes command-table) (read-command-using-keystrokes command-table keystrokes @@ -687,7 +690,7 @@ (command-parser *command-parser*) (command-unparser *command-unparser*) (partial-command-parser *partial-command-parser*) - (keystroke-test #'eql)) + (keystroke-test #'keyboard-event-matches-gesture-name-p)) (let ((*command-parser* command-parser) (*command-unparser* command-unparser) (*partial-command-parser* partial-command-parser)) @@ -703,7 +706,7 @@ (let ((*accelerator-gestures* keystrokes)) (accept `(command :command-table ,command-table) :stream stream :prompt nil)))) - (if (characterp command) + (if (keyboard-event-p command) (let ((command (lookup-keystroke-command-item command command-table :test keystroke-test :numeric-argument numeric-arg))) diff --git a/clim/command.lisp b/clim/command.lisp index b466361d7d8993e81d7a12c695931d6fdb7832b2..2e41a62112e521aa7847b6e2895399321a92b28c 100644 --- a/clim/command.lisp +++ b/clim/command.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: command.lisp,v 1.4 92/03/04 16:21:15 cer Exp Locker: cer $ +;; $fiHeader: command.lisp,v 1.5 92/03/06 09:08:41 cer Exp $ (in-package :clim-internals) @@ -47,7 +47,7 @@ ;; COMMANDS is a table of all the commands in this command table, which maps from the ;; command name to the command-line name. ;; COMMAND-LINE-NAMES is a sorted set that maps from command-line names to command names. -;; MENU is a mapping from menu names and accelerator characters to menu items, stored +;; MENU is a mapping from menu names and accelerator gestures to menu items, stored ;; 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. @@ -195,13 +195,15 @@ (nstring-capitalize (nsubstitute #\Space #\- name)))) (defun add-command-to-command-table (command-name command-table - &key name menu keystroke (test #'eql) (errorp t)) + &key name menu keystroke (test #'gesture-eql) (errorp t)) (check-type command-name symbol) (setq command-table (find-command-table command-table)) (when (eq name t) (setq name (command-name-from-symbol command-name))) (check-type name (or string null)) - (check-type keystroke (or character null)) ;---gesture spec + (when keystroke + (assert (keyboard-gesture-spec-p keystroke) (keystroke) + "~S is not a keyboard gesture spec" keystroke)) (when (command-present-in-command-table-p command-name command-table) (when errorp (cerror "Remove the command and proceed" @@ -396,7 +398,9 @@ text-style (errorp t)) (check-type string (or string null)) (check-type type (member :command :function :menu :divider)) - (check-type keystroke (or character null)) ;---gesture spec + (when keystroke + (assert (keyboard-gesture-spec-p keystroke) (keystroke) + "~S is not a keyboard gesture spec" keystroke)) (check-type documentation (or string null)) (setq command-table (find-command-table command-table)) (let ((old-item (and string (find-menu-item string command-table :errorp nil)))) @@ -669,30 +673,31 @@ ;;; Keystroke accelerators -(defun add-keystroke-to-command-table (command-table character type value - &key documentation (test #'eql) (errorp t)) - (check-type character character) ;---gesture spec +(defun add-keystroke-to-command-table (command-table keystroke type value + &key documentation (test #'gesture-eql) (errorp t)) + (assert (keyboard-gesture-spec-p keystroke) (keystroke) + "~S is not a keyboard gesture spec" keystroke) (check-type type (member :command :function :menu)) (check-type documentation (or string null)) (setq command-table (find-command-table command-table)) - (let ((old-item (find-keystroke-item character command-table + (let ((old-item (find-keystroke-item keystroke command-table :test test :errorp nil))) (when old-item (when errorp (cerror "Remove the keystroke item and proceed" 'command-already-present :format-string "Keystroke item ~S already present in ~S" - :format-args (list character command-table))) - (remove-keystroke-from-command-table command-table character :test test))) + :format-args (list keystroke command-table))) + (remove-keystroke-from-command-table command-table keystroke :test test))) (add-menu-item-to-command-table command-table nil type value :documentation documentation - :keystroke character :errorp nil)) + :keystroke keystroke :errorp nil)) -(defun remove-keystroke-from-command-table (command-table character - &key (test #'eql) (errorp t)) +(defun remove-keystroke-from-command-table (command-table keystroke + &key (test #'gesture-eql) (errorp t)) (setq command-table (find-command-table command-table)) (with-slots (menu keystrokes) command-table - (let ((index (position character menu :key #'second :test test))) + (let ((index (position keystroke menu :key #'second :test test))) (cond (index (let ((element (aref menu index))) ;; Don't remove the whole item if there's a menu-name, @@ -708,7 +713,7 @@ (when errorp (error 'command-not-present :format-string "Keystroke item ~S not present in ~S" - :format-args (list character command-table)))))))) + :format-args (list keystroke command-table)))))))) (defun map-over-command-table-keystrokes (function command-table) (declare (dynamic-extent function)) @@ -717,14 +722,14 @@ (apply function entry))) (slot-value (find-command-table command-table) 'menu))) -(defun find-keystroke-item (character command-table &key (test #'eql) (errorp t)) +(defun find-keystroke-item (keystroke command-table &key (test #'gesture-eql) (errorp t)) (declare (values menu-item command-table)) (let* ((command-table (find-command-table command-table)) (entry (block find-entry - ;; Do it the hard way so that CHAR-EQUAL doesn't see NILs + ;; Do it the hard way so that GESTURE-EQL doesn't see NILs (map nil #'(lambda (entry) (when (and (second entry) - (funcall test character (second entry))) + (funcall test keystroke (second entry))) (return-from find-entry entry))) (slot-value command-table 'menu))))) (when entry @@ -733,15 +738,15 @@ (when errorp (error 'command-not-present :format-string "Keystroke ~S has no menu item present in ~S" - :format-args (list character command-table)))) + :format-args (list keystroke command-table)))) -(defun lookup-keystroke-item (character command-table &key (test #'eql)) +(defun lookup-keystroke-item (keystroke command-table &key (test #'gesture-eql)) (declare (values menu-item command-table)) (labels ((map-menu (command-table) (map nil #'(lambda (entry) (let ((item (third entry))) (when (and (second entry) - (funcall test character (second entry))) + (funcall test keystroke (second entry))) (return-from lookup-keystroke-item (values item command-table))) (when (and (eq (command-menu-item-type item) ':menu) @@ -757,10 +762,10 @@ (map-menu (find-command-table command-table)))) ;; Return a command associated with a keystroke iff it is enabled. -;; Otherwise, return the keystroke character. -(defun lookup-keystroke-command-item (character command-table - &key (test #'eql) (numeric-argument 1)) - (let ((item (lookup-keystroke-item character command-table :test test))) +;; Otherwise, return the keystroke keystroke. +(defun lookup-keystroke-command-item (keystroke command-table + &key (test #'gesture-eql) (numeric-argument 1)) + (let ((item (lookup-keystroke-item keystroke command-table :test test))) (when item (let* ((type (command-menu-item-type item)) (command @@ -770,7 +775,7 @@ (when (command-enabled (command-name command) *application-frame*) (return-from lookup-keystroke-command-item (substitute-numeric-argument-marker command numeric-argument)))))) - character) + keystroke) (defmacro with-command-table-keystrokes ((keystrokes-var command-table) &body body) (let ((comtab '#:command-table)) diff --git a/clim/completer.lisp b/clim/completer.lisp index 444bc9e6345c0512a7d7dad10b84f93b9d5282eb..b7adc5226c1cd6ec308fe3dcfe0edb86304989bf 100644 --- a/clim/completer.lisp +++ b/clim/completer.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: completer.lisp,v 1.3 92/02/24 13:07:09 cer Exp $ +;; $fiHeader: completer.lisp,v 1.4 92/03/04 16:21:17 cer Exp $ (in-package :clim-internals) @@ -41,8 +41,8 @@ (and (eq action :help) help-displays-possibilities))))) (declare (dynamic-extent #'completion-help)) (with-accept-help ((:subhelp #'completion-help)) - ;; Keep the input editor from handling help and possibilities characters. - ;; They will get treated as activation characters, thus ensuring that + ;; Keep the input editor from handling help and possibilities gestures. + ;; They will get treated as activation gestures, thus ensuring that ;; STUFF-SO-FAR will be accurate when we display the possibilities. (let ((*ie-help-enabled* nil) (location (input-position stream)) @@ -63,14 +63,18 @@ (extend-vector stuff-so-far token) (cond ((null ch) (error "Null ch?")) - ((characterp ch) - (cond ((member ch *help-gestures*) + ((keyboard-event-p ch) + (cond ((member ch *help-gestures* + :test #'keyboard-event-matches-gesture-name-p) (setq completion-mode ':help)) - ((member ch *possibilities-gestures*) + ((member ch *possibilities-gestures* + :test #'keyboard-event-matches-gesture-name-p) (setq completion-mode ':possibilities)) - ((member ch *completion-gestures*) + ((member ch *completion-gestures* + :test #'keyboard-event-matches-gesture-name-p) (setq completion-mode ':complete-maximal)) - ((member ch partial-completers :test #'char-equal) + ((member ch partial-completers + :test #'keyboard-event-matches-gesture-name-p) (setq completion-mode ':complete-limited unread t extend t return 'if-completed)) ;; What about "overloaded" partial completers?? diff --git a/clim/defresource.lisp b/clim/defresource.lisp index 47e43adbcd80fb171d2b4f12eab5a0937196c289..7a5a0ba4e3336273505cb33442e7d286db009acb 100644 --- a/clim/defresource.lisp +++ b/clim/defresource.lisp @@ -1,12 +1,12 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: defresource.lisp,v 1.4 92/02/24 13:07:22 cer Exp $ +;; $fiHeader: defresource.lisp,v 1.5 92/03/04 16:21:26 cer Exp $ (in-package :clim-internals) "Copyright (c) 1988, 1989, 1990 International Lisp Associates. All rights reserved." -(defstruct (resource-descriptor (:conc-name RD-) +(defstruct (resource-descriptor (:conc-name rd-) #+Allegro (:print-function print-resource) (:constructor make-resource-descriptor (name))) name @@ -20,9 +20,9 @@ #+Allegro (defun print-resource (o s d) (declare (ignore d)) - (format s "#<~S ~S>" (type-of o) (RD-name o))) + (format s "#<~S ~S>" (type-of o) (rd-name o))) -(defstruct (object-storage (:conc-name OS-)) +(defstruct (object-storage (:conc-name os-)) object use-cons parameters) @@ -39,15 +39,15 @@ ,@body))) (defun describe-resource (resource) - (with-resource-rd (resource RD) - (format t "~&Resource ~S:" (RD-name RD)) - (when (RD-constructor RD) - (format t "~%Constructor: ~S" (RD-constructor RD))) - (when (RD-initializer RD) - (format t "~%Initializer: ~S" (RD-initializer RD))) - (when (RD-matcher RD) - (format t "~%Matcher: ~S" (RD-matcher RD))) - (let ((objects (RD-objects RD))) + (with-resource-rd (resource rd) + (format t "~&Resource ~S:" (rd-name rd)) + (when (rd-constructor rd) + (format t "~%Constructor: ~S" (rd-constructor rd))) + (when (rd-initializer rd) + (format t "~%Initializer: ~S" (rd-initializer rd))) + (when (rd-matcher rd) + (format t "~%Matcher: ~S" (rd-matcher rd))) + (let ((objects (rd-objects rd))) (when (> (fill-pointer objects) 0) (format t "~%~D Object~:P:" (fill-pointer objects))) (doseq (object-storage objects) @@ -56,8 +56,8 @@ (os-use-cons object-storage)))))) (defun clear-resource (resource) - (with-resource-rd (resource RD) - (setf (fill-pointer (RD-objects RD)) 0)) + (with-resource-rd (resource rd) + (setf (fill-pointer (rd-objects rd)) 0)) nil) (defun lookup-resource-descriptor (name) @@ -89,14 +89,16 @@ ((symbolp function) `#',function) (t (let ((function-name (make-symbol (concatenate 'string - (string name) "-" (string type))))) + (string name) "-" (string type))))) (output `(defun ,function-name (,@extra-parameters ,@parameters) ,@extra-parameters ,@(cleanup-lambda-list parameters) ,function)) `#',function-name))))) - (setf constructor (output-function constructor 'constructor (make-symbol "RD")) + (setf constructor (output-function constructor 'constructor + (make-symbol (symbol-name 'rd))) initializer (output-function initializer 'initializer name) - matcher (or (output-function matcher 'matcher name (make-symbol "OBJECT-STORAGE")) + matcher (or (output-function matcher 'matcher name + (make-symbol (symbol-name 'object-storage))) (output-function 'default-resource-matcher 'matcher)) deinitializer (letf-globally ((parameters nil)) (output-function deinitializer 'deinitializer name))) @@ -110,33 +112,33 @@ (defun defresource-load-time (name constructor initializer deinitializer matcher initial-copies) - #+Ignore + #+++ignore (when (lookup-resource-descriptor name) (cerror "Continue to overwrite old definition of resource ~S" "Attempt to redefine resource ~S" name)) - (let ((RD (or (lookup-resource-descriptor name) (make-resource-descriptor name)))) - (with-lock-held ((RD-lock RD) "Resource lock") - (unless (RD-objects RD) - (setf (RD-objects RD) (make-array (* 2 (or initial-copies 10)) + (let ((rd (or (lookup-resource-descriptor name) (make-resource-descriptor name)))) + (with-lock-held ((rd-lock rd) "Resource lock") + (unless (rd-objects rd) + (setf (rd-objects rd) (make-array (* 2 (or initial-copies 10)) :fill-pointer 0)) (when initial-copies (dotimes (i initial-copies) #-(or Allegro Minima) (declare (ignore i)) - (vector-push (cons nil (funcall constructor RD)) (RD-objects RD))))) - (setf (RD-constructor RD) constructor) - (setf (RD-initializer RD) initializer) - (setf (RD-deinitializer RD) deinitializer) - (setf (RD-matcher RD) matcher) - (setf (lookup-resource-descriptor name) RD)))) - -(defun allocate-resource (name &rest parameters &aux RD object-storage) + (vector-push (cons nil (funcall constructor rd)) (rd-objects rd))))) + (setf (rd-constructor rd) constructor) + (setf (rd-initializer rd) initializer) + (setf (rd-deinitializer rd) deinitializer) + (setf (rd-matcher rd) matcher) + (setf (lookup-resource-descriptor name) rd)))) + +(defun allocate-resource (name &rest parameters &aux rd object-storage) (declare (dynamic-extent parameters)) (block allocate - (setf RD (lookup-resource-descriptor name)) - (unless RD (error "Can't allocate nonexistent resource ~S" name)) - (with-lock-held ((RD-lock RD) "Resource lock") - (let* ((array (RD-objects RD)) - (matcher (RD-matcher RD)) + (setf rd (lookup-resource-descriptor name)) + (unless rd (error "Can't allocate nonexistent resource ~S" name)) + (with-lock-held ((rd-lock rd) "Resource lock") + (let* ((array (rd-objects rd)) + (matcher (rd-matcher rd)) (fill-pointer (fill-pointer array))) #+Genera (declare (sys:array-register array)) #+Minima (declare (type vector array)) @@ -147,50 +149,50 @@ (equal (os-parameters object-storage) parameters) (apply matcher (os-object object-storage) object-storage parameters))) (if (os-use-cons object-storage) - (setf (car (os-use-cons object-storage)) RD + (setf (car (os-use-cons object-storage)) rd (cdr (os-use-cons object-storage)) i) - (setf (os-use-cons object-storage) (cons RD i))) + (setf (os-use-cons object-storage) (cons rd i))) (return-from allocate))) - (let* ((new-object (apply (RD-constructor RD) RD parameters)) + (let* ((new-object (apply (rd-constructor rd) rd parameters)) (array-size (array-dimension array 0))) (setf object-storage (make-object-storage :object new-object - :use-cons (cons RD fill-pointer) + :use-cons (cons rd fill-pointer) :parameters (copy-list parameters))) (when (<= array-size fill-pointer) (let ((new-array (make-array (* 2 array-size) :fill-pointer fill-pointer))) (replace new-array array) - (setf array (setf (RD-objects RD) new-array)))) + (setf array (setf (rd-objects rd) new-array)))) (vector-push object-storage array))))) - (when (RD-initializer RD) (apply (RD-initializer RD) (os-object object-storage) parameters)) + (when (rd-initializer rd) (apply (rd-initializer rd) (os-object object-storage) parameters)) (values (os-object object-storage) object-storage)) (defun deallocate-resource (name object &optional allocation-key - &aux RD object-array object-index object-storage) + &aux rd object-array object-index object-storage) (if allocation-key - (setf RD (car (os-use-cons allocation-key)) object-array (RD-objects RD) + (setf rd (car (os-use-cons allocation-key)) object-array (rd-objects rd) object-index (cdr (os-use-cons allocation-key))) - (setf RD (or (lookup-resource-descriptor name) + (setf rd (or (lookup-resource-descriptor name) (error "Can't deallocate nonexistent resource ~S" name)) - object-array (RD-objects RD) + object-array (rd-objects rd) object-index (position object object-array :key #'os-object))) (unless object-index - (error "Can't deallocate object ~S: not present in resource ~S" object (RD-name RD))) - (with-lock-held ((RD-lock RD) "Resource lock") + (error "Can't deallocate object ~S: not present in resource ~S" object (rd-name rd))) + (with-lock-held ((rd-lock rd) "Resource lock") (setf object-storage (aref object-array object-index)) (unless (cdr (os-use-cons object-storage)) (error "Can't deallocate object ~S: already deallocated from resource ~S" - object (RD-name RD))) + object (rd-name rd))) (unless (eq object (os-object object-storage)) - (error "Can't deallocate object ~S: not present in resource ~S" object (RD-name RD))) - (when (RD-deinitializer RD) - (funcall (RD-deinitializer RD) (os-object object-storage))) + (error "Can't deallocate object ~S: not present in resource ~S" object (rd-name rd))) + (when (rd-deinitializer rd) + (funcall (rd-deinitializer rd) (os-object object-storage))) (setf (cdr (os-use-cons object-storage)) nil))) (defmacro using-resource ((variable resource &rest parameters) &body body) - (let ((allocation-key (make-symbol "ALLOCATION-KEY"))) + (let ((allocation-key (make-symbol (symbol-name 'allocation-key)))) `(let ((,variable nil) (,allocation-key nil)) (unwind-protect diff --git a/clim/dragging-output.lisp b/clim/dragging-output.lisp index e612a57b82f3880496231a062b9e29dcba8abf1c..1b7cca16cea492d973b2ac2d5d9f840bb64d7112 100644 --- a/clim/dragging-output.lisp +++ b/clim/dragging-output.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: dragging-output.lisp,v 1.4 92/02/24 13:07:25 cer Exp $ +;; $fiHeader: dragging-output.lisp,v 1.5 92/03/04 16:21:30 cer Exp $ (in-package :clim-internals) @@ -21,7 +21,7 @@ (defun drag-output-record (stream output-record &key (repaint t) (erase #'erase-output-record) feedback (finish-on-release nil)) - (declare (values final-x final-y)) + (declare (values final-x final-y delta-x delta-y)) (let (last-x last-y (delta-x 0) (delta-y 0) diff --git a/clim/frames.lisp b/clim/frames.lisp index db1b9aca809d71b4e0da5df818a94a5e1e3a11d6..399c2424097cc92034514cbe37af83cdd23df00d 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.8 92/02/24 13:07:30 cer Exp $ +;; ;; $fiHeader: frames.lisp,v 1.9 92/03/04 16:21:35 cer Exp $ (in-package :clim-internals) @@ -580,32 +580,48 @@ force-p))) (frame-top-level-sheet frame))) -;;--- This needs to be more beefy, like in CLIM 1.0 -;;--- And what about CLIM 0.9's PANE-NEEDS-REDISPLAY, etc? +;;--- What about CLIM 0.9's PANE-NEEDS-REDISPLAY, etc? +;;--- What about CLIM 1.0's :DISPLAY-AFTER-COMMANDS :NO-CLEAR? (defun redisplay-frame-pane (frame pane &key force-p) (when (symbolp pane) (setq pane (get-frame-pane frame pane))) (when (pane-display-function pane) - (let* ((ird (slot-value pane 'incremental-redisplay-p)) - (history (and ird (stream-output-history pane))) - (record (and history - (> (output-record-count history) 0) - (output-record-element history 0)))) + (let* ((ir (slot-value pane 'incremental-redisplay-p)) + (redisplay-p (if (listp ir) (first ir) ir)) + (check-overlapping (or (atom ir) ;default is T + (getf (rest ir) :check-overlapping t)))) (with-simple-restart (nil "Skip redisplaying pane ~S" pane) (loop (with-simple-restart (nil "Retry displaying pane ~S" pane) (return - (cond ((and ird (or force-p (null record))) - (when force-p - (window-clear pane)) - (updating-output (pane) - (invoke-pane-redisplay-function frame pane))) - (ird - (redisplay record pane)) - (t - (invoke-pane-redisplay-function frame pane)))))))))) + (let ((redisplay-record + (and redisplay-p + (let ((history (stream-output-history pane))) + (when history + #+compulsive-redisplay + (when (> (output-record-count history) 1) + (cerror "Clear the output history and proceed" + "There is more than one element in this redisplay pane") + (window-clear pane)) + (unless (zerop (output-record-count history)) + (output-record-element history 0))))))) + (cond ((and redisplay-p + (or force-p (null redisplay-record))) + (when force-p + (window-clear pane)) + (invoke-pane-redisplay-function frame pane)) + (redisplay-p + (redisplay redisplay-record pane + :check-overlapping check-overlapping)) + (t + (invoke-pane-display-function frame pane))))))))))) (defun invoke-pane-redisplay-function (frame pane &rest args) + (declare (dynamic-extent args)) + (updating-output (pane) + (apply #'invoke-pane-display-function frame pane args))) + +(defun invoke-pane-display-function (frame pane &rest args) (declare (dynamic-extent args)) (let* ((df (pane-display-function pane)) (display-args (if (listp df) (rest df) nil)) @@ -741,6 +757,11 @@ (defmethod frame-maintain-presentation-histories ((frame standard-application-frame)) (not (null (find-frame-pane-of-type frame 'interactor-pane)))) +;;--- What should this really do? +#+Allegro +(defun notify-user (&rest ignore) + (format excl::*initial-terminal-io* "Notify ~a~%" ignore)) + ;;; Pointer documentation @@ -904,8 +925,3 @@ #+Genera (defmethod mouse-documentation-window ((window window-stream)) nil) - -;;--- What should this do? - -(defun notify-user (&rest ignore) - (format excl::*initial-terminal-io* "Notify ~a~%" ignore)) diff --git a/clim/genera-activities.lisp b/clim/genera-activities.lisp deleted file mode 100644 index e69de29bb2d1d6434b8b29ae775ad8c2e48c5391..0000000000000000000000000000000000000000 diff --git a/clim/gestures.lisp b/clim/gestures.lisp index b6a161a5e4c42ee270efd988923ad03b73572938..055672b7448f73c323a8c59138e63951baf7e99b 100644 --- a/clim/gestures.lisp +++ b/clim/gestures.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gestures.lisp,v 1.3 92/02/24 13:07:39 cer Exp $ +;; $fiHeader: gestures.lisp,v 1.4 92/03/04 16:21:43 cer Exp $ (in-package :clim-internals) @@ -15,9 +15,6 @@ ;;; as per CLtL. ;;; 2) The set of possible "mouse buttons" is :LEFT, :MIDDLE, and :RIGHT. -(defconstant *pointer-buttons* '#(:left :middle :right)) -(defconstant *modifier-keys* '#(:shift :control :meta :super :hyper)) - (defun-inline button-index (name) #+Genera (declare lt:(side-effects simple reducible)) (position name *pointer-buttons*)) @@ -33,6 +30,8 @@ ;; Modifier states can be compared with = (defun make-modifier-state (&rest modifiers) (declare (dynamic-extent modifiers)) + (assert (every #'(lambda (x) (find x *modifier-keys*)) modifiers) (modifiers) + "~S is not a subset of ~S" modifiers '(:shift :control :meta :super :hyper)) (let ((state 0)) (dolist (name modifiers) (let ((bit (modifier-key-index name))) @@ -63,6 +62,11 @@ ,(ash 1 (length *modifier-keys*))) :initial-element nil)) +;; A table indexed by the modifier state. +;; Each bucket in the table contains an alist of a keysym and 1 or more gesture names. +(defvar *keysym-and-modifier-key->gesture* + (make-array (ash 1 (length *modifier-keys*)) :initial-element nil)) + ;; BUTTON is a button number (0, 1, or 2), and MODIFIER-STATE is a mask (defun-inline button-and-modifier-state-gesture-names (button modifier-state) (declare (fixnum button modifier-state)) @@ -90,7 +94,18 @@ (declare (values button modifier-state)) (do-button-and-modifier-state (button modifier-state bucket) (when (member gesture-name bucket) - (return-from gesture-name-button-and-modifiers (values button modifier-state)))) + (return-from gesture-name-button-and-modifiers + (values button modifier-state)))) + nil) + +(defun gesture-name-keysym-and-modifiers (gesture-name) + (declare (values keysym modifier-state)) + (dotimes (index (ash 1 (length *modifier-keys*))) + (let ((bucket (aref *keysym-and-modifier-key->gesture* index))) + (dolist (entry bucket) + (when (member gesture-name (cdr entry)) + (return-from gesture-name-keysym-and-modifiers + (values (car entry) index)))))) nil) #|| @@ -149,9 +164,49 @@ (- (integer-length button) #.(integer-length +pointer-left-button+)) modifier-state gesture-name))) +;;--- Shouldn't #\A match (:A :SHIFT), and so forth? (defun keyboard-event-matches-gesture-name-p (event gesture-name) - ;;--- Fill this in - ) + (when (and (characterp event) + (characterp gesture-name) + (eql event gesture-name)) + (return-from keyboard-event-matches-gesture-name-p t)) + (multiple-value-bind (keysym modifier-state character) + (etypecase event + (character + (values nil 0 event)) + (key-press-event + (values (keyboard-event-key-name event) + (event-modifier-state event) + (keyboard-event-character event)))) + (declare (fixnum modifier-state)) + (let ((bucket (aref *keysym-and-modifier-key->gesture* modifier-state))) + ;;--- Presently allows both keysyms and characters. Is that right? + (or (member gesture-name (cdr (assoc keysym bucket))) + (member gesture-name (cdr (assoc character bucket))))))) + +(defun-inline keyboard-event-p (x) + (or (characterp x) + (typep x 'key-press-event))) + +(defun keyboard-gesture-spec-p (x) + (let ((keysym (if (consp x) (first x) x)) + (modifiers (and (consp x) (rest x)))) + (and (or (characterp keysym) + (symbolp keysym)) + (every #'(lambda (x) (find x *modifier-keys*)) modifiers)))) + +;;--- Shouldn't #\A match (:A :SHIFT), and so forth? +(defun gesture-eql (gesture1 gesture2) + (let ((g1-keysym (if (consp gesture1) (first gesture1) gesture1)) + (g1-modifiers (and (consp gesture1) (rest gesture1))) + (g2-keysym (if (consp gesture2) (first gesture2) gesture2)) + (g2-modifiers (and (consp gesture2) (rest gesture2)))) + (and (or (eql g1-keysym g2-keysym) + (and (characterp g1-keysym) + (characterp g2-keysym) + (char-equal g1-keysym g2-keysym))) + (every #'(lambda (x) (member x g2-modifiers)) g1-modifiers) + (every #'(lambda (x) (member x g1-modifiers)) g2-modifiers)))) (defun add-gesture-name (name type gesture-spec &key (unique t)) @@ -161,18 +216,23 @@ (ecase type (:keyboard (destructuring-bind (key-name &rest modifiers) gesture-spec - (check-type key-name (or character - (member :newline :linefeed :tab :backspace :page :rubout))) - (assert (every #'(lambda (x) (member x '(:shift :control :meta :super :hyper))) - modifiers) (modifiers) + (check-type key-name (or symbol character)) + (assert (every #'(lambda (x) (find x *modifier-keys*)) modifiers) (modifiers) "~S is not a subset of ~S" modifiers '(:shift :control :meta :super :hyper)) - ;;--- Fill this in - )) + (let* ((index (apply #'make-modifier-state modifiers)) + (bucket (aref *keysym-and-modifier-key->gesture* index)) + (entry (assoc key-name bucket))) + (cond (entry + (setf (aref *keysym-and-modifier-key->gesture* index) + (nsubstitute (append entry (list name)) entry bucket))) + (t + (setq entry (list key-name name)) + (push entry (aref *keysym-and-modifier-key->gesture* index)))) + bucket))) (:pointer-button (destructuring-bind (button &rest modifiers) gesture-spec (check-type button (member :left :middle :right)) - (assert (every #'(lambda (x) (member x '(:shift :control :meta :super :hyper))) - modifiers) (modifiers) + (assert (every #'(lambda (x) (find x *modifier-keys*)) modifiers) (modifiers) "~S is not a subset of ~S" modifiers '(:shift :control :meta :super :hyper)) (pushnew name (button-and-modifier-state-gesture-names (button-index button) @@ -182,7 +242,14 @@ (do-button-and-modifier-state (button modifier-state bucket) (when (member name bucket) (setf (aref *button-and-modifier-key->gesture* button modifier-state) - (delete name bucket))))) + (delete name bucket)))) + (dotimes (index (ash 1 (length *modifier-keys*))) + (let ((bucket (aref *keysym-and-modifier-key->gesture* index))) + (do* ((entryl bucket (cdr entryl)) + (entry (first entryl) (first entryl))) + ((null entryl)) + (when (member name (cdr entry)) + (setf (first entryl) (delete name entry))))))) #+CLIM-1-compatibility (define-compatibility-function (add-pointer-gesture-name add-gesture-name) diff --git a/clim/input-editor-commands.lisp b/clim/input-editor-commands.lisp index 570f5ccf5f76ca25c98a16c44544e90fee8be1d2..591d5b5ddc93ae6d21b13983639d6339b1e33e37 100644 --- a/clim/input-editor-commands.lisp +++ b/clim/input-editor-commands.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-editor-commands.lisp,v 1.3 92/02/24 13:07:52 cer Exp $ +;; $fiHeader: input-editor-commands.lisp,v 1.4 92/03/04 16:21:53 cer Exp $ (in-package :clim-internals) @@ -11,29 +11,41 @@ ;;; an input editor. This may prove to be a foolish decision down the pike. (eval-when (compile load eval) -(defvar *ie-command-arglist* '(stream input-buffer character numeric-argument)) +(defvar *ie-command-arglist* '(stream input-buffer gesture numeric-argument)) ) -;; CHARS is either a single character, or a list of characters. FUNCTION is -;; the function that implements an input editor command. This associates -;; the character(s) with the command. -(defun add-input-editor-command (characters function) - (flet ((add-aarray-entry (char thing aarray) - (let ((old (find char aarray :key #'first))) +;; GESTURES is either a gesture name, or a list of gesture names. FUNCTION +;; is the function that implements an input editor command. This associates +;; the gesture(s) with the command. +(defun add-input-editor-command (gestures function) + (flet ((add-aarray-entry (gesture thing aarray) + (let ((old (find gesture aarray :key #'first))) (if old (setf (second old) thing) - (vector-push-extend (list char thing) aarray))))) - (declare (dynamic-extent #'add-aarray-entry)) - (cond ((characterp characters) - (assert (not (ordinary-char-p characters))) - (add-aarray-entry characters function *input-editor-command-aarray*)) + (vector-push-extend (list gesture thing) aarray)))) + ;; Does the gesture correspond to some character with any bucky + ;; bits on, or some other non-standard non-printing character? + (bucky-char-p (gesture) + (multiple-value-bind (keysym modifier-state) + (gesture-name-keysym-and-modifiers gesture) + (if (zerop modifier-state) + ;;--- What should this really be? + (member keysym '(:rubout :clear-input :scroll)) + (logtest modifier-state + #.(logior +control-key+ +meta-key+ +super-key+ +hyper-key+)))))) + (declare (dynamic-extent #'add-aarray-entry #'bucky-char-p)) + (cond ((atom gestures) + (assert (bucky-char-p gestures) (gestures) + "~S does not correspond to a bucky character" gestures) + (add-aarray-entry gestures function *input-editor-command-aarray*)) (t - (assert (> (length characters) 1)) - (assert (not (ordinary-char-p (first characters)))) - ;; We've got a command that wil be bound to a sequence of characters, + (assert (> (length gestures) 1)) + (assert (bucky-char-p (first gestures)) (gestures) + "~S does not correspond to a bucky character" gestures) + ;; We've got a command that wil be bound to a sequence of gestures, ;; so set up the prefix tables. (let ((aarray *input-editor-command-aarray*)) - (dorest (rest characters) + (dorest (rest gestures) (let* ((prefix (first rest)) (rest (rest rest))) (if (null rest) @@ -44,81 +56,56 @@ (add-aarray-entry prefix subaarray aarray)) (setq aarray subaarray)))))))))) -(defmacro assign-input-editor-key-bindings (&body functions-and-keystrokes) - (let ((forms nil)) - (loop - (when (null functions-and-keystrokes) (return)) - (let* ((function (pop functions-and-keystrokes)) - (keystrokes (pop functions-and-keystrokes))) - (when keystrokes - (push `(add-input-editor-command ',keystrokes ',function) - forms)))) - `(progn ,@(nreverse forms)))) - -;; These need to be defined before being used, otherwise they would -;; live in CLOE-IMPLMENTATION -#+Cloe-Runtime -(eval-when (compile load) - -;; Define the new key chars for Cloe CLIM. Regular Cloe defines 0-127, we define -;; 128-139 as the F-keys (F1 thru F12), 140 for c-sh-A, and 141 as c-sh-V -(sys::define-character-name "F1" 128) -(sys::define-character-name "F2" 129) -(sys::define-character-name "F3" 130) -(sys::define-character-name "F4" 131) -(sys::define-character-name "F5" 132) -(sys::define-character-name "F6" 133) -(sys::define-character-name "F7" 134) -(sys::define-character-name "F8" 135) -(sys::define-character-name "F9" 136) -;; Note windows traps F10 as alt-space. Why? -(sys::define-character-name "F10" 137) -(sys::define-character-name "F11" 138) -(sys::define-character-name "F12" 139) -(sys::define-character-name "Arglist" 140) -(sys::define-character-name "ShowValue" 141) - -) ;eval-when ;; When T, the input editor should handle help and completion. Otherwise, ;; something like COMPLETE-INPUT will do it for us. (defvar *ie-help-enabled* t) +(define-gesture-name :complete :keyboard (:tab)) +(define-gesture-name :complete :keyboard (:complete)) +(define-gesture-name :help :keyboard (:help)) +(define-gesture-name :possibilities :keyboard (:? :shift :control)) + ;; These need to be on a per-implementation basis, naturally -;;--- If you change these, change *MAGIC-COMPLETION-CHARACTERS* too -(defvar *completion-gestures* #+Genera '(#\Complete #\Tab) - #-Genera '(#\Tab)) -(defvar *help-gestures* '(#+Genera #\Help - #+Cloe-Runtime #\F1 - #+CCL-2 #\^E)) -(defvar *possibilities-gestures* `(#+Genera #\c-? - #+Lucid #\control-\? - #+Allegro #\c-? - #+CCL-2 ,(extended-char #\? :control :shift))) - -(defun lookup-input-editor-command (character aarray) +;;--- If you change these, change *MAGIC-COMPLETION-GESTURES* too +(defvar *completion-gestures* '(:complete)) +(defvar *help-gestures* '(:help)) +(defvar *possibilities-gestures* '(:possibilities)) + +(defun lookup-input-editor-command (gesture aarray) ;; Need to handle the help and possibilities commands specially so ;; that they work correctly inside of COMPLETE-INPUT - (cond ((and *ie-help-enabled* (member character *help-gestures*)) + (cond ((and *ie-help-enabled* + (member gesture *help-gestures* + :test #'keyboard-event-matches-gesture-name-p)) 'com-ie-help) - ((and *ie-help-enabled* (member character *possibilities-gestures*)) + ((and *ie-help-enabled* + (member gesture *possibilities-gestures* + :test #'keyboard-event-matches-gesture-name-p)) 'com-ie-possibilities) - ((and *ie-help-enabled* (member character *completion-gestures*)) + ((and *ie-help-enabled* + (member gesture *completion-gestures* + :test #'keyboard-event-matches-gesture-name-p)) 'com-ie-complete) (t - (let ((code (char-code character)) - (bits (char-bits character))) + (let* ((keysym (keyboard-event-key-name gesture)) + (modifier-state (event-modifier-state gesture)) + (bucky-p + (logtest modifier-state + #.(logior +control-key+ +meta-key+ +super-key+ +hyper-key+)))) (cond ((and (eq aarray *input-editor-command-aarray*) - (not (zerop bits)) - (<= (char-code #\0) code (char-code #\9))) + bucky-p + (member keysym '(:0 :1 :2 :3 :4 :5 :6 :7 :8 :9))) ;; A numeric argument... - (- code (char-code #\0))) + (position keysym '(:0 :1 :2 :3 :4 :5 :6 :7 :8 :9))) ((and (eq aarray *input-editor-command-aarray*) - (not (zerop bits)) - (= code (char-code #\-))) + bucky-p + (eq keysym ':-)) ;a smiley face indeed! -1) (t - (second (find character aarray :key #'first)))))))) + (second (find gesture aarray + :key #'first + :test #'keyboard-event-matches-gesture-name-p)))))))) (defmacro define-input-editor-command ((name &key (rescan T) (type 'motion) history) arglist &body body) @@ -140,45 +127,53 @@ (scl:defprop define-input-editor-command zwei:defselect-function-spec-finder zwei:definition-function-spec-finder) -(defmethod stream-process-gesture ((istream input-editing-stream-mixin) gesture type) +(defmethod stream-process-gesture ((istream input-editing-stream-mixin) + gesture type) + (values gesture type)) + +;; No input editing commands are standard characters... +(defmethod stream-process-gesture ((istream input-editing-stream-mixin) + (gesture character) type) + (with-slots (last-command-type command-state) istream + (setq last-command-type 'character + command-state *input-editor-command-aarray*)) + (values gesture type)) + +(defmethod stream-process-gesture ((istream input-editing-stream-mixin) + (gesture key-press-event) type) (with-slots (numeric-argument last-command-type command-state) istream - (cond ((characterp gesture) - ;; The COMMAND-STATE slot holds the current IE command aarray, - ;; and gets updated when we see a prefix characters (e.g., ESC) - (let ((command (unless (activation-gesture-p gesture) - (lookup-input-editor-command gesture command-state)))) - (cond ((numberp command) - (cond ((null numeric-argument) - (setq numeric-argument command)) - ((= command -1) - (setq numeric-argument (- numeric-argument))) - (t - (setq numeric-argument (+ (* numeric-argument 10) command)))) - ;; Numeric arguments don't affect LAST-COMMAND-TYPE - (return-from stream-process-gesture nil)) - ((arrayp command) - ;; A prefix character, update the state and return - (setq command-state command) - (return-from stream-process-gesture nil)) - (command - (let ((argument (or numeric-argument 1))) - (setq numeric-argument nil - command-state *input-editor-command-aarray*) - (funcall command - istream (slot-value istream 'input-buffer) gesture argument)) - (return-from stream-process-gesture nil)) - ((not (eq command-state *input-editor-command-aarray*)) - (beep istream) - (setq numeric-argument nil - command-state *input-editor-command-aarray*) - (return-from stream-process-gesture nil)) + ;; The COMMAND-STATE slot holds the current IE command aarray, and + ;; gets updated when we see a prefix (such as ESC or c-X) + (let ((command (unless (activation-gesture-p gesture) + (lookup-input-editor-command gesture command-state)))) + (cond ((numberp command) + (cond ((null numeric-argument) + (setq numeric-argument command)) + ((= command -1) + (setq numeric-argument (- numeric-argument))) (t - (setq last-command-type 'character - command-state *input-editor-command-aarray*))))) - (t - (setq numeric-argument nil - last-command-type 'gesture - command-state *input-editor-command-aarray*)))) + (setq numeric-argument (+ (* numeric-argument 10) command)))) + ;; Numeric arguments don't affect LAST-COMMAND-TYPE + (return-from stream-process-gesture nil)) + ((arrayp command) + ;; A prefix, update the state and return + (setq command-state command) + (return-from stream-process-gesture nil)) + (command + (let ((argument (or numeric-argument 1))) + (setq numeric-argument nil + command-state *input-editor-command-aarray*) + (funcall command + istream (slot-value istream 'input-buffer) gesture argument)) + (return-from stream-process-gesture nil)) + ((not (eq command-state *input-editor-command-aarray*)) + (beep istream) + (setq numeric-argument nil + command-state *input-editor-command-aarray*) + (return-from stream-process-gesture nil)) + (t + (setq last-command-type 'character + command-state *input-editor-command-aarray*))))) (values gesture type)) @@ -658,206 +653,83 @@ (beep)))) -;;; Per-platform key bindings - -#+Genera -(assign-input-editor-key-bindings - com-ie-ctrl-g #\c-G - com-ie-universal-argument #\c-U - com-ie-forward-character #\c-F - com-ie-forward-word #\m-F - com-ie-backward-character #\c-B - com-ie-backward-word #\m-B - com-ie-beginning-of-buffer #\m-< - com-ie-end-of-buffer #\m-> - com-ie-beginning-of-line #\c-A - com-ie-end-of-line #\c-E - com-ie-next-line #\c-N - com-ie-previous-line #\c-P - com-ie-rubout #\Rubout - com-ie-delete-character #\c-D - com-ie-rubout-word #\m-Rubout - com-ie-delete-word #\m-D - com-ie-clear-input #\Clear-Input - com-ie-kill-line #\c-K - com-ie-make-room #\c-O - com-ie-transpose-characters #\c-T - com-ie-show-arglist #\c-sh-A - com-ie-show-value #\c-sh-V - com-ie-kill-ring-yank #\c-Y - com-ie-history-yank #\c-m-Y - com-ie-yank-next #\m-Y - com-ie-scroll-forward #\Scroll - com-ie-scroll-backward #\meta-Scroll - com-ie-scroll-forward #\c-V - com-ie-scroll-backward #\meta-V) - -#+Cloe-Runtime -(assign-input-editor-key-bindings - com-ie-ctrl-g #\BEL - com-ie-universal-argument nil - com-ie-beginning-of-buffer #\m-< - com-ie-end-of-buffer #\m-> - com-ie-forward-character #\ACK - com-ie-forward-word #\m-F - com-ie-backward-character #\STX - com-ie-backward-word #\m-B - com-ie-beginning-of-line #\SOH - com-ie-end-of-line #\ENQ - com-ie-next-line #\SO - com-ie-previous-line #\DLE - com-ie-rubout #\Rubout - com-ie-delete-character #\Eot - com-ie-rubout-word #\m-Rubout - com-ie-delete-word #\m-D - com-ie-clear-input #\Del - com-ie-kill-line #\Vt - com-ie-make-room nil - com-ie-transpose-characters #\DC4 - com-ie-show-arglist #\Arglist - com-ie-show-value #\ShowValue - com-ie-kill-ring-yank #\EM - com-ie-history-yank #\F3 - com-ie-yank-next #\m-Y - com-ie-scroll-forward #\Syn - com-ie-scroll-backward #\m-V) - -#+Minima-Runtime -(assign-input-editor-key-bindings - com-ie-rubout #\Rubout) - -#+Lucid -(assign-input-editor-key-bindings - com-ie-ctrl-g #\Control-\g - com-ie-universal-argument #\Control-\u - com-ie-forward-character #\Control-\f - com-ie-forward-word #\Meta-\f - com-ie-backward-character #\Control-\b - com-ie-backward-word #\Meta-\b - com-ie-beginning-of-buffer #\Meta-< - com-ie-end-of-buffer #\Meta-> - com-ie-beginning-of-line #\Control-\a - com-ie-end-of-line #\Control-\e - com-ie-next-line #\Control-\n - com-ie-previous-line #\Control-\p - com-ie-rubout #\Rubout - com-ie-delete-character #\Control-\d - com-ie-rubout-word #\Meta-Rubout - com-ie-delete-word #\Meta-\d - com-ie-clear-input #\Control-Meta-Rubout - com-ie-kill-line #\Control-\k - com-ie-make-room #\Control-\o - com-ie-transpose-characters #\Control-\t - com-ie-show-arglist #\Control-\A - com-ie-show-value #\Control-\V - com-ie-kill-ring-yank #\Control-\y - com-ie-history-yank #\Control-Meta-\y - com-ie-yank-next #\Meta-\y - com-ie-scroll-forward #\Control-\v - com-ie-scroll-backward #\Meta-\v) - -#+(and Allegro (not Silica)) -;; Like above but lowercase characters -(assign-input-editor-key-bindings - com-ie-ctrl-g #\c-\g - com-ie-universal-argument nil - com-ie-forward-character #\c-\f - com-ie-forward-word #\meta-\f - com-ie-backward-character #\c-\b - com-ie-backward-word #\meta-\b - com-ie-beginning-of-buffer #\meta-\< - com-ie-end-of-buffer #\meta-\> - com-ie-beginning-of-line #\c-\a - com-ie-end-of-line #\c-\e - com-ie-next-line #\c-\n - com-ie-previous-line #\c-\p - com-ie-rubout #\rubout - com-ie-delete-character #\c-\d - com-ie-rubout-word #\meta-rubout - com-ie-delete-word #\meta-d - com-ie-clear-input #\c-\u - com-ie-kill-line #\c-\k - com-ie-make-room #\c-\o - com-ie-transpose-characters #\c-\t - com-ie-show-arglist (#\c-\x #\c-\a) - com-ie-show-value (#\c-\x #\c-\v) - com-ie-kill-ring-yank #\c-\y - com-ie-history-yank #\control-meta-\y - com-ie-yank-next #\meta-\y - com-ie-scroll-forward #\c-\v - com-ie-scroll-backward #\meta-\v) - -;;--- Until the keyboard event processor works... -#+(and Allegro Silica) -(assign-input-editor-key-bindings - com-ie-ctrl-g #\^g - com-ie-universal-argument nil - com-ie-forward-character #\^f - com-ie-forward-word #\meta-\f - com-ie-backward-character #\^b - com-ie-backward-word #\meta-\b - com-ie-beginning-of-buffer #\meta-\< - com-ie-end-of-buffer #\meta-\> - com-ie-beginning-of-line #\^a - com-ie-end-of-line #\^e - com-ie-next-line #\^n - com-ie-previous-line #\^p - com-ie-rubout #\rubout - com-ie-rubout #\backspace - com-ie-rubout #\c-\h - com-ie-delete-character #\^d - com-ie-rubout-word #\meta-rubout - com-ie-delete-word #\meta-d - com-ie-clear-input #\^u - com-ie-kill-line #\^k - com-ie-make-room #\^o - com-ie-transpose-characters #\^t - com-ie-show-arglist (#\^x #\^a) - com-ie-show-value (#\^x #\^v) - com-ie-kill-ring-yank #\^y - com-ie-history-yank #\control-meta-\y - com-ie-yank-next #\meta-\y - com-ie-scroll-forward #\^v - com-ie-scroll-backward #\meta-\v) - -#+CCL-2 -(defmacro assign-input-editor-key-bindings-ccl (&body functions-and-keystrokes) +;;; Key bindings + +(defmacro define-input-editor-gestures (&body gestures) + `(progn + ,@(mapcar #'(lambda (gesture) + (let ((name (first gesture)) + (gesture-spec (rest gesture))) + `(add-gesture-name ,name :keyboard ',gesture-spec :unique nil))) + gestures))) + +(define-input-editor-gestures + (:ie-abort :g :control) + (:ie-universal-argument :u :control) + (:ie-forward-character :f :control) + (:ie-forward-word :f :meta) + (:ie-backward-character :b :control) + (:ie-backward-word :b :meta) + (:ie-beginning-of-buffer :\< :meta) + (:ie-end-of-buffer :\> :meta) + (:ie-beginning-of-line :a :control) + (:ie-end-of-line :e :control) + (:ie-next-line :n :control) + (:ie-previous-line :p :control) + (:ie-delete-character :d :control) + (:ie-delete-word :d :meta) + (:ie-rubout-character :rubout) + (:ie-rubout-word :rubout :meta) + (:ie-kill-line :k :control) + (:ie-clear-input :clear-input) + (:ie-make-room :o :control) + (:ie-transpose-characters :t :control) + (:ie-show-arglist :a :control :shift) + (:ie-show-value :v :control :shift) + (:ie-kill-ring-yank :y :control) + (:ie-history-yank :y :control :meta) + (:ie-yank-next :y :meta) + (:ie-scroll-forward :v :control) + (:ie-scroll-backward :v :meta) + (:ie-scroll-forward :scroll) + (:ie-scroll-backward :scroll :meta)) + +(defmacro assign-input-editor-key-bindings (&body functions-and-gestures) (let ((forms nil)) (loop - (when (null functions-and-keystrokes) (return)) - (let* ((function (pop functions-and-keystrokes)) - (keystroke (pop functions-and-keystrokes))) - (when keystroke - (push `(add-input-editor-command ,keystroke ',function) - forms)))) + (when (null functions-and-gestures) (return)) + (let* ((function (pop functions-and-gestures)) + (gesture (pop functions-and-gestures))) + (when gesture + (push `(add-input-editor-command ',gesture ',function) + forms)))) `(progn ,@(nreverse forms)))) -#+CCL-2 -(assign-input-editor-key-bindings-ccl - com-ie-ctrl-g (extended-char #\g :control) - com-ie-universal-argument (extended-char #\u :control) - com-ie-forward-character (extended-char #\f :control) - com-ie-forward-word (extended-char #\f :meta) - com-ie-backward-character (extended-char #\b :control) - com-ie-backward-word (extended-char #\b :meta) - com-ie-beginning-of-buffer (extended-char #\< :meta) - com-ie-end-of-buffer (extended-char #\> :meta) - com-ie-beginning-of-line (extended-char #\a :control) - com-ie-end-of-line (extended-char #\e :control) - com-ie-next-line (extended-char #\n :control) - com-ie-previous-line (extended-char #\p :control) - com-ie-rubout #\Rubout - com-ie-delete-character (extended-char #\d :control) - com-ie-rubout-word (extended-char #\Rubout :meta) - com-ie-delete-word (extended-char #\d :meta) - com-ie-clear-input (extended-char #\Rubout :control :meta) - com-ie-kill-line (extended-char #\k :control) - com-ie-make-room (extended-char #\o :control) - com-ie-transpose-characters (extended-char #\t :control) - com-ie-show-arglist (extended-char #\A :control :shift) - com-ie-show-value (extended-char #\V :control :shift) - com-ie-kill-ring-yank (extended-char #\y :control) - com-ie-history-yank (extended-char #\y :control :meta) - com-ie-yank-next (extended-char #\y :meta) - com-ie-scroll-forward (extended-char #\v :control) - com-ie-scroll-backward (extended-char #\v :meta)) +(assign-input-editor-key-bindings + com-ie-ctrl-g :ie-abort + com-ie-universal-argument :ie-universal-argument + com-ie-forward-character :ie-forward-character + com-ie-forward-word :ie-forward-word + com-ie-backward-character :ie-backward-character + com-ie-backward-word :ie-backward-word + com-ie-beginning-of-buffer :ie-beginning-of-buffer + com-ie-end-of-buffer :ie-end-of-buffer + com-ie-beginning-of-line :ie-beginning-of-line + com-ie-end-of-line :ie-end-of-line + com-ie-next-line :ie-next-line + com-ie-previous-line :ie-previous-line + com-ie-delete-character :ie-delete-character + com-ie-delete-word :ie-delete-word + com-ie-rubout :ie-rubout-character + com-ie-rubout-word :ie-rubout-word + com-ie-clear-input :ie-clear-input + com-ie-kill-line :ie-kill-line + com-ie-make-room :ie-make-room + com-ie-transpose-characters :ie-transpose-characters + com-ie-show-arglist :ie-show-arglist + com-ie-show-value :ie-show-value + com-ie-kill-ring-yank :ie-kill-ring-yank + com-ie-history-yank :ie-history-yank + com-ie-yank-next :ie-yank-next + com-ie-scroll-forward :ie-scroll-forward + com-ie-scroll-backward :ie-scroll-backward) diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index 264fda2b003d83c878657da1b68fe8b02ca89b3a..f6b1164cb7c8bdae96154fdbb930770cf42356b7 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.7 92/02/28 09:17:49 cer Exp $ +;; $fiHeader: input-protocol.lisp,v 1.8 92/03/04 16:21:55 cer Exp $ (in-package :clim-internals) @@ -57,7 +57,9 @@ ;;; Our implementation of the extended-input protocol. (defclass input-protocol-mixin (basic-extended-input-protocol) - ((pointer-motion-pending :initform nil) + (#+++ignore (input-buffer :accessor stream-input-buffer + :initarg :input-buffer) + (pointer-motion-pending :initform nil) (text-cursor :accessor stream-text-cursor :initarg :text-cursor)) (:default-initargs @@ -156,18 +158,18 @@ (defmethod queue-event ((stream input-protocol-mixin) (event key-press-event)) (let ((char (keyboard-event-character event)) (keysym (keyboard-event-key-name event))) - ;; this probably wants to be STRING-CHAR-P, but that will still require some thought. - (cond ((and char (characterp char)) + ;;--- This probably wants to be STRING-CHAR-P... + (cond ((and char (standard-char-p char)) (queue-put (stream-input-buffer stream) char)) - ((and keysym (not (typep keysym 'modifier-keysym)) - (queue-put (stream-input-buffer stream) (copy-event event)))) + ((and keysym (not (typep keysym 'modifier-keysym))) + (queue-put (stream-input-buffer stream) (copy-event event))) (keysym ;; must be a shift keysym ;; must update the pointer shifts. (let ((pointer (stream-primary-pointer stream))) (when pointer (setf (pointer-button-state pointer) - (event-modifier-state event)))))))) + (event-modifier-state event)))))))) (defmethod queue-event ((stream input-protocol-mixin) (event key-release-event)) ;;--- key state table? Not unless all sheets are helping maintain it. @@ -179,9 +181,10 @@ (setf (pointer-button-state pointer) (event-modifier-state event)))))) nil) -;;; --- need to modularize stream implementation into fundamental and extended layers -;;; so that we can tell when to queue up non-characters into the stream. -;;; These don't need to set pointer-motion-pending because they synchronize through the io buffer. +;;;--- need to modularize stream implementation into fundamental and extended +;;;--- layers so that we can tell when to queue up non-characters into the +;;;--- stream. These don't need to set pointer-motion-pending because they +;;;--- synchronize through the io buffer. (defmethod queue-event ((stream input-protocol-mixin) (event pointer-button-press-event)) (queue-put (stream-input-buffer stream) (copy-event event))) @@ -428,26 +431,31 @@ ;; don't translate it gesture) -(defmethod receive-gesture :around +(defmethod receive-gesture ((stream input-protocol-mixin) (gesture character)) - (cond ((member gesture *accelerator-gestures*) + (process-abort-or-accelerator-gesture stream gesture) + gesture) + +(defmethod receive-gesture + ((stream input-protocol-mixin) (gesture key-press-event)) + (process-abort-or-accelerator-gesture stream gesture) + gesture) + +(defun process-abort-or-accelerator-gesture (stream gesture) + (cond ((member gesture *accelerator-gestures* + :test #'keyboard-event-matches-gesture-name-p) (signal 'accelerator-gesture :event gesture :numeric-argument (or *accelerator-numeric-argument* 1))) - ((member gesture *abort-gestures*) + ((member gesture *abort-gestures* + :test #'keyboard-event-matches-gesture-name-p) (let ((cursor (slot-value stream 'text-cursor))) (when (and cursor (cursor-active cursor)) (write-string "[Abort]" stream) (force-output stream))) - (error 'abort-gesture :event gesture)) - (t (call-next-method)))) + (error 'abort-gesture :event gesture)))) -(defmethod receive-gesture :around - ((stream input-protocol-mixin) (gesture key-press-event)) - ;;--- What about Abort gestures that aren't characters? - (call-next-method)) - ;;; This function is just a convenience for the programmer, defaulting the ;;; keyword :STREAM argument to *standard-input*. The application can call ;;; stream-read-gesture directly. diff --git a/clim/interactive-defs.lisp b/clim/interactive-defs.lisp index 26781ab36c5a99d362a914ec1374ddaf748545ed..4f3d1dfafc3e4df2a7fb27a797c9220b5967accc 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.4 92/02/24 13:07:56 cer Exp $ +;; $fiHeader: interactive-defs.lisp,v 1.5 92/03/04 16:21:57 cer Exp $ (in-package :clim-internals) @@ -14,27 +14,33 @@ (defvar *pointer-button-press-handler* nil) -(defparameter *abort-gestures* '(#+Genera #\Abort - #+Cloe-Runtime #\Escape - #+Lucid #\control-\z - #+Allegro #\c-\z - ;;--- Until the keyboard event processor works... - #+(and Allegro Silica) #\^z)) +(define-gesture-name :abort :keyboard + #+Genera (:abort) + #+Cloe-Runtime (:escape) + #-(or Genera Cloe-Runtime) (:z :control)) + +(defparameter *abort-gestures* '(:abort)) (defvar *accelerator-gestures* nil) (defvar *accelerator-numeric-argument* nil) +(define-gesture-name :newline :keyboard (:newline)) +(define-gesture-name :return :keyboard (:return)) +(define-gesture-name :end :keyboard (:end)) + +;;--- Kludge until gesture matching working properly. +;;--- That is, the standard characters should match their own keysyms, +;;--- such as :A and #\A, :NEWLINE and #\Newline, and so on. +(define-gesture-name :newline :keyboard (#\Newline)) + ;; Activation gestures terminate the entire input line. They are usually -;; non-printing characters such as Return or End. +;; non-printing characters such as #\Newline or #\End. (defvar *activation-gestures* nil) -;; Until we have a real per-implementation key table, we don't -;; know whether the implementation puts #\Newline or #\Return on the -;; key marked "Return". -(defvar *standard-activation-gestures* '(#+Genera #\End #\Newline #\Return)) +(defvar *standard-activation-gestures* '(:newline :return :end)) (defmacro with-activation-gestures ((additional-gestures &key override) &body body) - (when (characterp additional-gestures) + (when (characterp additional-gestures) ;yes, we mean CHARACTERP (setq additional-gestures `'(,additional-gestures))) `(with-stack-list* (*activation-gestures* ,additional-gestures @@ -47,7 +53,8 @@ (defun activation-gesture-p (gesture) (dolist (set *activation-gestures*) (when (if (listp set) - (member gesture set) + (member gesture set + :test #'keyboard-event-matches-gesture-name-p) (funcall set gesture)) (return-from activation-gesture-p t)))) @@ -66,11 +73,11 @@ ;; Delimiter gestures terminate a field in an input line. They are usually -;; printing characters such as Space or Tab +;; printing characters such as #\Space or #\Tab (defvar *delimiter-gestures* nil) (defmacro with-delimiter-gestures ((additional-gestures &key override) &body body) - (when (characterp additional-gestures) + (when (characterp additional-gestures) ;yes, we mean CHARACTERP (setq additional-gestures `'(,additional-gestures))) `(with-stack-list* (*delimiter-gestures* ,additional-gestures @@ -83,7 +90,8 @@ (defun delimiter-gesture-p (gesture) (dolist (set *delimiter-gestures*) (when (if (listp set) - (member gesture set) + (member gesture set + :test #'keyboard-event-matches-gesture-name-p) (funcall set gesture)) (return-from delimiter-gesture-p t)))) @@ -105,7 +113,7 @@ (defparameter *quotation-character* #\") -;; READ-TOKEN reads characters until it encounters an activation character, +;; READ-TOKEN reads characters until it encounters an activation gesture, ;; a delimiter character, or something else (like a mouse click). (defun read-token (stream &key input-wait-handler pointer-button-press-handler click-only timeout) diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp index 12be25053d97d43b5b832a603bbb9c3ec5949da9..ba8c58ca08a1c00baa5b94d5d53229dc5c65466d 100644 --- a/clim/interactive-protocol.lisp +++ b/clim/interactive-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: interactive-protocol.lisp,v 1.4 92/02/24 13:07:57 cer Exp $ +;; $fiHeader: interactive-protocol.lisp,v 1.5 92/03/04 16:21:59 cer Exp $ (in-package :clim-internals) @@ -32,7 +32,7 @@ (defclass input-editing-stream-mixin (standard-encapsulating-stream input-editing-stream) ;; The fill-pointer of INPUT-BUFFER is the "high water" mark, - ;; that is, it points past the last character in the buffer. + ;; that is, it points past the last thing in the buffer. ((input-buffer :initform (make-array 100 :fill-pointer 0 :adjustable t) :accessor input-editor-buffer) ;; SCAN-POINTER (or INPUT-POSITION) is the point at which @@ -47,8 +47,8 @@ ;; input that was already typed in response to some editing command. (rescanning-p :accessor rescanning-p :initform nil) (rescan-queued :initform nil) - ;; A buffer for an activation character to process. Conceptually, - ;; the activation character lives at the end of the input buffer. + ;; A buffer for an activation gesture to process. Conceptually, + ;; the activation gesture lives at the end of the input buffer. (activation-gesture :initform nil) ;; State for prefixed commands, holds a command aarray (command-state :initform nil) @@ -61,7 +61,7 @@ (last-command-type :initform nil))) ;; The structure of *INPUT-EDITOR-COMMAND-AARRAY* is an alist that associates -;; a character with either an input editor command, in the case of a "prefix", +;; a gesture with either an input editor command, in the case of a "prefix", ;; another alist. It is purposely not adjustable for performance reasons. ;; If you overflow, make another bigger one. ;; Perhaps the input-editor command table [or alist] should be a conceptual @@ -110,8 +110,8 @@ (start-index-var end-index-var noise-string-var) &key normal noise-string) #+Genera (declare (zwei:indentation 2 1)) - (let ((end-var (make-symbol "END")) - (next-var (make-symbol "NEXT"))) + (let ((end-var '#:end) + (next-var '#:next)) `(let ((,start-index-var ,start) (,end-var (or ,end (length ,input-buffer))) (,end-index-var 0) @@ -376,8 +376,8 @@ (defmethod stream-unread-gesture ((istream input-editing-stream-mixin) gesture) (with-slots (input-buffer scan-pointer activation-gesture stream) istream - (when (characterp gesture) - ;; If it's an activation character, store it in the input editor's + (when (characterp gesture) ;no general keyboard events here... + ;; If it's an activation gesture, store it in the input editor's ;; slot rather than sending it back to the underlying stream. (when (activation-gesture-p gesture) (when activation-gesture @@ -506,10 +506,10 @@ (return-from stream-read-gesture (values new-thing new-type))) ((activation-gesture-p new-thing) - ;; If we got an activation character, we must first finish + ;; If we got an activation gesture, we must first finish ;; scanning the input line, moving the insertion-pointer ;; to the end and finishing rescanning. Only then can we - ;; return the activation character. + ;; return the activation gesture. (cond ((= insertion-pointer (fill-pointer input-buffer)) (return-from stream-read-gesture (values new-thing new-type))) @@ -904,11 +904,11 @@ (let ((sys:rubout-handler :read)) (funcall continuation stream))) ;; On the way out, swallow the unread delimiter, since the Genera input - ;; editor discards activation characters on the way out + ;; editor discards activation gestures on the way out. ;; This breaks some cases of read-preserving-whitespace, which could be - ;; fixed by only discarding activation characters, but there's no way - ;; to tell here if a character was an activation character, so trying to - ;; fix read-preserving-whitespace would only break more important things + ;; fixed by only discarding activation gestures, but there's no way to + ;; tell here if a character was an activation gesture, so trying to fix + ;; read-preserving-whitespace would only break more important things (stream-read-char-no-hang stream)))))) #+Genera diff --git a/clim/menus.lisp b/clim/menus.lisp index 2a040e294a31eeaea08a55c95f02cb5e80e4d163..d9c388d5548b7623bafe1b26f17d2c8bbd30e70d 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.13 92/03/04 16:22:00 cer Exp Locker: cer $ +;; $fiHeader: menus.lisp,v 1.14 92/03/06 09:08:44 cer Exp $ (in-package :clim-internals) @@ -269,6 +269,19 @@ (write-string string stream)) (write-string string stream)))) +(defclass static-menu () + ((name :initarg :name) + (menu-contents :initarg :menu-contents) + (default-presentation :initarg :default-presentation) + (root-window :initarg :root-window) + ;; In case we need to "compile" the menu on the fly + (items :initarg :items) + (default-item :initarg :default-item) + (default-style :initarg :default-style) + (printer :initarg :printer) + (presentation-type :initarg :presentation-type) + (drawer-args :initarg :drawer-args))) + (defgeneric menu-choose (items &rest keys &key associated-window default-item default-style label printer presentation-type @@ -545,19 +558,6 @@ ;;; Static menus -(defclass static-menu () - ((name :initarg :name) - (menu-contents :initarg :menu-contents) - (default-presentation :initarg :default-presentation) - (root-window :initarg :root-window) - ;; In case we need to "compile" the menu on the fly - (items :initarg :items) - (default-item :initarg :default-item) - (default-style :initarg :default-style) - (printer :initarg :printer) - (presentation-type :initarg :presentation-type) - (drawer-args :initarg :drawer-args))) - (defmethod print-object ((static-menu static-menu) stream) (print-unreadable-object (static-menu stream :type t :identity t) (write (slot-value static-menu 'name) :stream stream :escape nil))) diff --git a/clim/presentations.lisp b/clim/presentations.lisp index 57d95760ae25c296e5605a5b48689db0b3c71859..6581a13778d7ee68a959ec857af6d2b9a5f10041 100644 --- a/clim/presentations.lisp +++ b/clim/presentations.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: presentations.lisp,v 1.5 92/02/24 13:08:18 cer Exp $ +;; $fiHeader: presentations.lisp,v 1.6 92/03/04 16:22:07 cer Exp $ (in-package :clim-internals) @@ -339,12 +339,15 @@ ;; a translator from it to the input context. (dolist (context input-context) (let ((context-type (input-context-type context))) - (when (presentation-matches-context-type presentation context-type - frame stream x y - :event event - :modifier-state modifier-state) - (return-from find-innermost-applicable-presentation - presentation)))))) + (multiple-value-bind (translator any-match-p) + (presentation-matches-context-type presentation context-type + frame stream x y + :event event + :modifier-state modifier-state) + (declare (ignore translator)) + (when any-match-p + (return-from find-innermost-applicable-presentation + presentation))))))) (declare (dynamic-extent #'mapper #'test)) (mapper (stream-output-history stream) nil 0 0))) diff --git a/clim/ptypes1.lisp b/clim/ptypes1.lisp index 40db5b58945e0b25e521e917aa2ef4431d690a83..d71f8a87ac0351e7929e11c3134caf970ae1e8d0 100644 --- a/clim/ptypes1.lisp +++ b/clim/ptypes1.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: ptypes1.lisp,v 1.6 92/02/28 09:17:51 cer Exp $ +;; $fiHeader: ptypes1.lisp,v 1.7 92/03/04 16:22:09 cer Exp $ (in-package :clim-internals) @@ -1167,13 +1167,13 @@ (unless (or (constantp parameters-massager) (symbolp parameters-massager) (member (second (assoc to-class class-bindings-used)) '(0 1 nil))) - (let ((temp (make-symbol (format nil "~A-PARAMETERS" supertype)))) + (let ((temp (make-symbol (format nil "~A-~A" supertype 'parameters)))) (push (list temp parameters-massager) bindings) (setq parameters-massager temp))) (unless (or (constantp options-massager) (symbolp options-massager) (member (third (assoc to-class class-bindings-used)) '(0 1 nil))) - (let ((temp (make-symbol (format nil "~A-OPTIONS" supertype)))) + (let ((temp (make-symbol (format nil "~A-~A" supertype 'options)))) (push (list temp options-massager) bindings) (setq options-massager temp)))) (push (list to-class parameters-massager options-massager) alist))))))) diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp index f640c552b1b2aa6b9bdf5f7174feb629f3666c04..79b8eb552934980d5424f8b2c4abdb37ae15cdbf 100644 --- a/clim/recording-protocol.lisp +++ b/clim/recording-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: recording-protocol.lisp,v 1.3 92/03/04 16:22:13 cer Exp Locker: cer $ +;; $fiHeader: recording-protocol.lisp,v 1.3 92/03/04 16:22:13 cer Exp $ (in-package :clim-internals) @@ -8,20 +8,7 @@ Portions copyright (c) 1991, 1992 Franz, Inc. All rights reserved. Portions copyright (c) 1989, 1990 International Lisp Associates." -;; The protocol class for an object that obeys the output record protocol, -;; that is, can hold output record elements -(define-protocol-class output-record (bounding-rectangle)) -;; The protocol class for output records that are leaves. -(define-protocol-class displayed-output-record (bounding-rectangle)) - -;; The protocol class for textual displayed output records. -(define-protocol-class text-displayed-output-record (displayed-output-record)) - -;; The protocol class for graphical displayed output records. -(define-protocol-class graphics-displayed-output-record (displayed-output-record)) - - ;;; A mix-in for classes that can be stored by other output records ;;; OUTPUT-RECORD-ELEMENT-MIXIN has slots for ;;; (bounding rectangle, parent, start-position, end-position, contents-ok) @@ -1074,14 +1061,14 @@ (vp (pane-viewport stream))) (when vp (update-scrollbars vp)) + #-ignore (update-region stream nminx nminy nmaxy nmaxx) #+ignore - (update-region stream (- nmaxx nminx) (- nmaxy nminy)) - )))) + (update-region stream (- nmaxx nminx) (- nmaxy nminy)))))) ;;; Defclass of OUTPUT-RECORDING-MIXIN, etc. is in STREAM-CLASS-DEFS (defmethod initialize-instance :after ((stream output-recording-mixin) &rest args) @@ -1105,19 +1092,14 @@ (with-slots (output-record current-output-record-stack) stream (let ((the-output-record (or current-output-record-stack output-record))) (add-output-record record the-output-record) - ;;--- I suspect that this is totally unncessary since - ;;--- adding the record will update the history which will - ;;-- do this - #+Silica-ignore + ;;--- I think we let the history worry about this + #+ignore-Silica (let ((width (bounding-rectangle-width stream)) (height (bounding-rectangle-height stream))) (declare (type coordinate width height)) (with-bounding-rectangle* (rl rt rr rb) the-output-record (when (or (< rl 0) (< width rr) (< rt 0) (< height rb)) - #+ignore - (update-region stream rl rt rr rb) - #+ignore (update-region stream (- rr rl) (- rb rt)))))))) (defmethod stream-replay ((stream output-recording-mixin) &optional region) @@ -1173,36 +1155,6 @@ (add-character-output-to-text-record record character text-style width height baseline))) -(defmethod get-text-output-record ((stream output-recording-mixin) style) - (let ((default-style (medium-default-text-style stream))) - (let ((record (stream-text-output-record stream))) - (when record - ;; If we're changing styles mid-stream, need to convert this - ;; text record to the more expensive form - (when (and (not (eq style default-style)) - (not (typep record 'styled-text-output-record))) - (setq record (stylize-text-output-record record default-style stream))) - (return-from get-text-output-record record))) - (let* ((string (make-array 16 :element-type 'extended-char ;--- 16? - :fill-pointer 0 :adjustable t)) - (record (if (not (eq style default-style)) - (make-styled-text-output-record (medium-ink stream) string) - (make-standard-text-output-record (medium-ink stream) string)))) - (setf (stream-text-output-record stream) record) - (multiple-value-bind (abs-x abs-y) - (point-position* - (stream-output-history-position stream)) - (declare (type coordinate abs-x abs-y)) - (multiple-value-bind (cx cy) (stream-cursor-position* stream) - (declare (type coordinate cx cy)) - (output-record-set-start-cursor-position* - record (- cx abs-x) (- cy abs-y)))) - ;; Moved to STREAM-CLOSE-TEXT-OUTPUT-RECORD, since we don't need this thing - ;; in the history until then. This should save an extra recompute-extent call - ;; (one in here, one when the string is added). - ;; (stream-add-output-record stream record) - record))) - (defmethod stream-close-text-output-record ((stream output-recording-mixin) &optional wrapped) ;; It's faster to access the slot directly instead of going through @@ -1242,52 +1194,6 @@ (unless (eq y old-y) (stream-close-text-output-record stream)))) -;; Copy just the text from the window to the stream. If REGION is supplied, -;; only the text overlapping that region is copied. -;; This loses information about text styles, presentations, and graphics, and -;; doesn't deal perfectly with tab characters and changing baselines. -(defun copy-textual-output-history (window stream &optional region) - (let* ((char-width (stream-character-width window #\space)) - (line-height (stream-line-height window)) - (history (stream-output-history window)) - (array (make-array (ceiling (bounding-rectangle-height history) line-height) - :fill-pointer 0 :adjustable t :initial-element nil))) - (labels ((collect (record x-offset y-offset) - (multiple-value-bind (start-x start-y) - (output-record-start-cursor-position* record) - (translate-positions x-offset y-offset start-x start-y) - (when (typep record 'standard-text-output-record) - (vector-push-extend (list* start-y start-x (slot-value record 'string)) - array)) - (map-over-output-records-overlapping-region - #'collect record region - (- x-offset) (- y-offset) start-x start-y)))) - (declare (dynamic-extent #'collect)) - (collect history 0 0)) - (sort array #'(lambda (r1 r2) - (or (< (first r1) (first r2)) - (and (= (first r1) (first r2)) - (< (second r1) (second r2)))))) - (let ((current-x 0) - (current-y (first (aref array 0)))) - (dotimes (i (fill-pointer array)) - (let* ((item (aref array i)) - (y (pop item)) - (x (pop item))) - (unless (= y current-y) - (dotimes (j (round (- y current-y) line-height)) - #-(or Allegro Minima) (declare (ignore j)) - (terpri stream) - (setq current-x 0)) - (setq current-y y)) - (unless (= x current-x) - (dotimes (j (round (- x current-x) char-width)) - #-(or Allegro Minima) (declare (ignore j)) - (write-char #\space stream)) - (setq current-x x)) - (write-string item stream) - (incf current-x (stream-string-width window item))))))) - ;;; This method should cover a multitude of sins. #+Silica (defmethod repaint-sheet :after ((stream output-recording-mixin) region) @@ -1304,7 +1210,6 @@ :ink +background-ink+) (stream-replay stream region))) - ;;; For Silica ;;;--- Consider these old methods on a case-by-case basis to see if the diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp index bbc2eda49492c90c278cae31d10b7b6bf16fbbdf..034cb738aebcc0e010ea8b4184fe8b5dd74fabd7 100644 --- a/clim/standard-types.lisp +++ b/clim/standard-types.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: standard-types.lisp,v 1.3 92/02/24 13:08:26 cer Exp $ +;; $fiHeader: standard-types.lisp,v 1.4 92/03/04 16:22:15 cer Exp $ (in-package :clim-internals) @@ -1431,7 +1431,8 @@ (let ((char (read-char stream))) (vector-push-extend char input-buffer))) (t - (when (activation-gesture-p char) ;wasn't really an activation char + (when (activation-gesture-p char) + ;; I guess it wasn't really an activation gesture... (unless (rescanning-p stream) (replace-input stream (string char)))) (vector-push-extend char input-buffer) diff --git a/clim/temp-strings.lisp b/clim/temp-strings.lisp index 382db4fd6ba6daee252ad6007d7eda2dee96466f..afe5dc0ec8ce336ecd704b369c76f0ba13f623e5 100644 --- a/clim/temp-strings.lisp +++ b/clim/temp-strings.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: temp-strings.lisp,v 1.3 92/01/31 14:58:53 cer Exp $ +;; $fiHeader: temp-strings.lisp,v 1.4 92/02/24 13:08:38 cer Exp $ (in-package :clim-internals) @@ -15,7 +15,7 @@ (defresource temporary-string (&key (length 100) (adjustable t)) :constructor (make-array length - :element-type 'extended-char + :element-type 'character :fill-pointer 0 :adjustable adjustable) :matcher (and (eq adjustable (adjustable-array-p temporary-string)) @@ -39,7 +39,7 @@ (defmacro evacuate-temporary-string (string-var) `(if (temporary-string-p ,string-var) (make-array (length ,string-var) - :element-type 'extended-char + :element-type 'character :fill-pointer (length ,string-var) :initial-contents ,string-var) ,string-var)) @@ -51,8 +51,9 @@ (progn (defmacro with-temporary-string ((var &key (length 100) (adjustable t)) &body body) - `(sys:with-stack-array (,var ,length :element-type 'extended-char :adjustable ,adjustable - :fill-pointer 0) + `(sys:with-stack-array (,var ,length :element-type 'character + :adjustable ,adjustable + :fill-pointer 0) ,@body)) (defun temporary-string-p (string) diff --git a/clim/text-formatting.lisp b/clim/text-formatting.lisp index 2d2ed00007d1ce6a15946a62d2eb3fba78e26875..e61e6144a695db91c060f613c55cffd01da4f9f0 100644 --- a/clim/text-formatting.lisp +++ b/clim/text-formatting.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: text-formatting.lisp,v 1.4 92/02/24 13:08:40 cer Exp $ +;; $fiHeader: text-formatting.lisp,v 1.5 92/03/04 16:22:21 cer Exp $ (in-package :clim-internals) @@ -133,7 +133,7 @@ (defresource filling-stream (stream fill-width break-characters prefix prefix-width) :constructor (make-instance 'filling-stream - :buffer (make-array 100 :element-type 'extended-char + :buffer (make-array 100 :element-type 'character :fill-pointer 0 :adjustable t)) :matcher 't diff --git a/clim/text-recording.lisp b/clim/text-recording.lisp index 7c700a166d074089da5cea5a34844c78d7b9e6ce..67b12a0d68c93f0aff754c876e4da9a8b8f6c5e0 100644 --- a/clim/text-recording.lisp +++ b/clim/text-recording.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: text-recording.lisp,v 1.1 92/02/24 13:18:29 cer Exp $ +;; $fiHeader: text-recording.lisp,v 1.2 92/03/04 16:22:22 cer Exp $ (in-package :clim-internals) @@ -394,6 +394,62 @@ (output-record-set-old-start-cursor-position* text old-start-x old-start-y)))))))) +(defmethod get-text-output-record ((stream output-recording-mixin) style) + (let ((default-style (medium-default-text-style stream))) + (let ((record (stream-text-output-record stream))) + (when record + ;; If we're changing styles mid-stream, need to convert this + ;; text record to the more expensive form + (when (and (not (eq style default-style)) + (not (typep record 'styled-text-output-record))) + (setq record (stylize-text-output-record record default-style stream))) + (return-from get-text-output-record record))) + (let* ((string (make-array 16 :element-type 'character ;--- 16? + :fill-pointer 0 :adjustable t)) + (record (if (not (eq style default-style)) + (make-styled-text-output-record (medium-ink stream) string) + (make-standard-text-output-record (medium-ink stream) string)))) + (setf (stream-text-output-record stream) record) + (multiple-value-bind (abs-x abs-y) + (point-position* + (stream-output-history-position stream)) + (declare (type coordinate abs-x abs-y)) + (multiple-value-bind (cx cy) (stream-cursor-position* stream) + (declare (type coordinate cx cy)) + (output-record-set-start-cursor-position* + record (- cx abs-x) (- cy abs-y)))) + ;; Moved to STREAM-CLOSE-TEXT-OUTPUT-RECORD, since we don't need this thing + ;; in the history until then. This should save an extra recompute-extent call + ;; (one in here, one when the string is added). + ;; (stream-add-output-record stream record) + record))) + +;; The cost of stylizing an existing record is actually fairly low, and we +;; don't do it very often, because of the optimization in GET-TEXT-OUTPUT-RECORD +;; that creates a stylized record as early as possible. +(defmethod stylize-text-output-record ((record standard-text-output-record) style stream) + (with-slots (ink string wrapped-p left top right bottom + start-x start-y end-x end-y) record + (let* (#+Silica (port (port stream)) + (new-record (make-styled-text-output-record-1 + ink string wrapped-p + style (- (text-style-height style #-Silica stream #+Silica port) + (text-style-descent style #-Silica stream #+Silica port))))) + (with-slots ((new-left left) (new-top top) (new-right right) (new-bottom bottom) + (new-sx start-x) (new-sy start-y) (new-ex end-x) (new-ey end-y) + (new-wrapped-p wrapped-p)) new-record + (setq new-left left + new-top top + new-right right + new-bottom bottom + new-sx start-x + new-sy start-y + new-ex end-x + new-ey end-y)) + (setf (stream-text-output-record stream) new-record) + new-record))) + + (defun find-text-baseline (record stream) ;; This finds the lowest baseline of the text in RECORD, which will be slower than, say, ;; the first baseline but more likely to look good with misaligned things. @@ -421,27 +477,48 @@ (find-or-recurse record 0)) baseline)) -;; The cost of stylizing an existing record is actually fairly low, and we -;; don't do it very often, because of the optimization in GET-TEXT-OUTPUT-RECORD -;; that creates a stylized record as early as possible. -(defmethod stylize-text-output-record ((record standard-text-output-record) style stream) - (with-slots (ink string wrapped-p left top right bottom - start-x start-y end-x end-y) record - (let* (#+Silica (port (port stream)) - (new-record (make-styled-text-output-record-1 - ink string wrapped-p - style (- (text-style-height style #-Silica stream #+Silica port) - (text-style-descent style #-Silica stream #+Silica port))))) - (with-slots ((new-left left) (new-top top) (new-right right) (new-bottom bottom) - (new-sx start-x) (new-sy start-y) (new-ex end-x) (new-ey end-y) - (new-wrapped-p wrapped-p)) new-record - (setq new-left left - new-top top - new-right right - new-bottom bottom - new-sx start-x - new-sy start-y - new-ex end-x - new-ey end-y)) - (setf (stream-text-output-record stream) new-record) - new-record))) +;; Copy just the text from the window to the stream. If REGION is supplied, +;; only the text overlapping that region is copied. +;; This loses information about text styles, presentations, and graphics, and +;; doesn't deal perfectly with tab characters and changing baselines. +(defun copy-textual-output-history (window stream &optional region) + (let* ((char-width (stream-character-width window #\space)) + (line-height (stream-line-height window)) + (history (stream-output-history window)) + (array (make-array (ceiling (bounding-rectangle-height history) line-height) + :fill-pointer 0 :adjustable t :initial-element nil))) + (labels ((collect (record x-offset y-offset) + (multiple-value-bind (start-x start-y) + (output-record-start-cursor-position* record) + (translate-positions x-offset y-offset start-x start-y) + (when (typep record 'standard-text-output-record) + (vector-push-extend (list* start-y start-x (slot-value record 'string)) + array)) + (map-over-output-records-overlapping-region + #'collect record region + (- x-offset) (- y-offset) start-x start-y)))) + (declare (dynamic-extent #'collect)) + (collect history 0 0)) + (sort array #'(lambda (r1 r2) + (or (< (first r1) (first r2)) + (and (= (first r1) (first r2)) + (< (second r1) (second r2)))))) + (let ((current-x 0) + (current-y (first (aref array 0)))) + (dotimes (i (fill-pointer array)) + (let* ((item (aref array i)) + (y (pop item)) + (x (pop item))) + (unless (= y current-y) + (dotimes (j (round (- y current-y) line-height)) + #-(or Allegro Minima) (declare (ignore j)) + (terpri stream) + (setq current-x 0)) + (setq current-y y)) + (unless (= x current-x) + (dotimes (j (round (- x current-x) char-width)) + #-(or Allegro Minima) (declare (ignore j)) + (write-char #\space stream)) + (setq current-x x)) + (write-string item stream) + (incf current-x (stream-string-width window item))))))) diff --git a/clim/tracking-pointer.lisp b/clim/tracking-pointer.lisp index 9006f4e4f7120b448633255d7ed7231c76aab40e..dbe3054656268ef5e2c96833a138416ff80773e2 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.4 92/02/24 13:08:43 cer Exp $ +;; $fiHeader: tracking-pointer.lisp,v 1.5 92/03/04 16:22:24 cer Exp $ (in-package :clim-internals) @@ -266,7 +266,7 @@ (block process-gesture (cond ((null gesture) (return-from input-wait)) - ((characterp gesture) + ((keyboard-event-p gesture) (when keyboard-function (funcall keyboard-function gesture) (return-from process-gesture))) diff --git a/clim/translators.lisp b/clim/translators.lisp index 41d8ec863490db21eb637b12d5d1636bf09fa19d..6d5be7b830a590ceb6df5b025a67f7f449352348 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.3 92/02/24 13:08:45 cer Exp $ +;; $fiHeader: translators.lisp,v 1.4 92/03/04 16:22:27 cer Exp $ (in-package :clim-internals) @@ -445,12 +445,15 @@ ;; Returns the higherst priority translator that matches the presentation ;; in this context, or NIL if there is no matching translator. +;; Returns a second value of T if there was any translator that matched +;; on everything except for the gesture, and the menu translator matched +;; (that is, a second value of T means that the menu translator will apply) (defun presentation-matches-context-type (presentation context-type frame window x y &key event (modifier-state 0) #+CLIM-1-compatibility (shift-mask 0 shift-mask-p)) - (declare (values translator)) + (declare (values translator any-match-p)) #+CLIM-1-compatibility (when shift-mask-p (setq modifier-state shift-mask)) @@ -467,22 +470,30 @@ frame event window x y))) (when (and by-gesture by-tester) ;; Matched by both gesture and by the tester, we're done - (return-from presentation-matches-context-type translator)) + (return-from presentation-matches-context-type + (values translator t))) (when by-tester - ;; We matched by the tester, it's OK to try the menu translator. - (setq one-matched t)))) + ;; 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 + (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 ;; matched during the test phase, which means that the PRESENTATION-MENU ;; translator might be applicable, even though no others were found. - (when (and event one-matched - *presentation-menu-translator* - (test-presentation-translator *presentation-menu-translator* - presentation context-type - frame window x y - :event event)) - (return-from presentation-matches-context-type *presentation-menu-translator*)))) - nil) + (let ((menu-applicable + (and one-matched + *presentation-menu-translator* + (test-presentation-translator *presentation-menu-translator* + presentation context-type + frame window x y + :modifier-state modifier-state + :event event)))) + (if (and event menu-applicable) + (values *presentation-menu-translator* t) + (values nil (and one-matched + (presentation-translator-matches-event + *presentation-menu-translator* event modifier-state)))))))) ;; When FASTP is T, that means "as soon as you find a matching translator, return ;; that translator". Otherwise, return a list of all applicable translators. diff --git a/clim/window-stream.lisp b/clim/window-stream.lisp index 68a6bef94ca4e5ecfb44b5f5f151a30a871e6670..80d8e687fe5f41476662dc2dac7c159230339cdb 100644 --- a/clim/window-stream.lisp +++ b/clim/window-stream.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: window-stream.lisp,v 1.3 92/01/31 14:59:02 cer Exp $ +;; $fiHeader: window-stream.lisp,v 1.4 92/02/24 13:08:55 cer Exp $ (in-package :clim-internals) @@ -140,7 +140,7 @@ port-type *port-types*) (let ((port-type (second (assoc port-type *port-types*)))) (let ((port (apply #'find-port :port-type port-type creation-args))) - (values (find-graft :port port :origin :nw) port)))) + (values (find-graft :port port :orientation :nw) port)))) #+Silica (defun open-window-stream (&rest args &key parent left top right bottom width height diff --git a/clx/clx-medium.lisp b/clx/clx-medium.lisp index a7a9e0226d8210f785642e13ca287eab3d1428df..be9743a1913809a583d915389530ff00201fae7f 100644 --- a/clx/clx-medium.lisp +++ b/clx/clx-medium.lisp @@ -3,7 +3,7 @@ (in-package :clx-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved." -;;; $fiHeader: clx-medium.lisp,v 1.2 92/02/24 13:23:46 cer Exp $ +;;; $fiHeader: clx-medium.lisp,v 1.3 92/03/04 16:20:52 cer Exp $ (defclass clx-medium (medium) @@ -294,8 +294,15 @@ (error "Pattern designs other than colors are not supported yet."))) (let* ((design-pixels (make-array (length designs))) (depth (xlib:screen-root-depth screen)) - (image-data (make-array (list height width) - :element-type `(unsigned-byte ,depth)))) + (image-data + (make-array (list height width) + :element-type + (cond ((= depth 1) 'xlib::pixarray-1-element-type) + ((<= depth 4) 'xlib::pixarray-4-element-type) + ((<= depth 8) 'xlib::pixarray-8-element-type) + ((<= depth 16) 'xlib::pixarray-16-element-type) + ((<= depth 24) 'xlib::pixarray-24-element-type) + (t 'xlib::pixarray-32-element-type))))) (declare #+Genera (sys:array-register design-pixels) (simple-vector design-pixels)) ;; Cache the decoded designs from the pattern @@ -321,7 +328,6 @@ (setf (xlib:gcontext-tile gc) (let ((image (xlib:create-image :depth depth - :bits-per-pixel depth :data image-data :width width :height height)) (pixmap @@ -423,9 +429,6 @@ (convert-to-device-coordinates transform x y) (let ((thickness (line-style-thickness line-style)) (gc (clx-decode-ink ink medium))) - (ecase (line-style-unit line-style) - ((:normal :point) - (setf thickness (* thickness points-to-pixels)))) (if (< thickness 2) (xlib:draw-point drawable gc x y) (let ((thickness (round thickness))) @@ -440,8 +443,8 @@ x1 y1 x2 y2) (xlib:draw-line drawable (clx-adjust-ink (clx-decode-ink ink medium) medium line-style - (min start-x end-x) (min start-y end-y)) - start-x start-y end-x end-y))) + (min x1 x2) (min y1 y2)) + x1 y1 x2 y2))) (defmethod port-draw-rectangle* ((port clx-port) sheet medium left top right bottom filled) @@ -454,7 +457,7 @@ (xlib:draw-rectangle drawable (clx-adjust-ink (clx-decode-ink ink medium) medium line-style left top) - left top (- right left) (- bottom top) (null line-style)))) + left top (- right left) (- bottom top) filled))) (defmethod port-draw-polygon* ((port clx-port) sheet medium points closed filled) (let ((transform (sheet-device-transformation sheet)) @@ -465,7 +468,7 @@ (miny most-positive-fixnum) (points (copy-list points))) (declare (fixnum minx miny)) - (do* ((points points (cddr points))a) + (do* ((points points (cddr points))) ((null points)) (let ((x (first points)) (y (second points))) @@ -479,7 +482,7 @@ (xlib:draw-lines drawable (clx-adjust-ink (clx-decode-ink ink medium) medium line-style minx miny) - points :fill-p (null line-style))))) + points :fill-p filled)))) (defmethod port-draw-ellipse* ((port clx-port) sheet medium center-x center-y @@ -534,7 +537,7 @@ (- center-x x-radius) (- center-y y-radius) (* x-radius 2) (* y-radius 2) ;; CLX measures the second angle relative to the first - start-angle angle-size (null line-style)))))) + start-angle angle-size filled))))) (defmethod port-draw-string* ((port clx-port) sheet medium string x y start end align-x align-y) @@ -547,7 +550,7 @@ (setq end (length string))) (let* ((font (if text-style (text-style-mapping port text-style) - (clx-get-default-font medium))) + (clx-get-default-font port medium))) (ascent (xlib:font-ascent font)) (descent (xlib:font-descent font)) (height (+ ascent descent)) @@ -568,7 +571,7 @@ (convert-to-device-coordinates transform x y) (let* ((font (if text-style (text-style-mapping port text-style) - (clx-get-default-font medium))) + (clx-get-default-font port medium))) (ascent (xlib:font-ascent font)) (descent (xlib:font-descent font)) (height (+ ascent descent)) @@ -659,7 +662,8 @@ (with-sheet-medium (medium from-sheet) (let ((width (- from-right from-left)) (height (- from-bottom from-top)) - (drawable (slot-value medium 'drawable))) + (drawable (slot-value medium 'drawable)) + (copy-gc (slot-value medium 'copy-gcontext))) (xlib:copy-area drawable copy-gc from-left from-top width height drawable to-left to-top)))))) diff --git a/clx/clx-port.lisp b/clx/clx-port.lisp index 58443b9581db00ae1ad9194c00cb15bb32c643e8..e72dfe23122585129e6d1455d4d765911f6d1667 100644 --- a/clx/clx-port.lisp +++ b/clx/clx-port.lisp @@ -3,7 +3,7 @@ (in-package :clx-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved. -;;; $fiHeader: clx-port.lisp,v 1.2 92/02/24 13:23:53 cer Exp $ +;;; $fiHeader: clx-port.lisp,v 1.3 92/03/04 16:20:55 cer Exp $ Portions copyright (c) 1991, 1992 International Lisp Associates." @@ -171,10 +171,10 @@ ;;; Text styles for CLX windows -(defvar *clx-font-families* - '((:fix "*-courier-*") - (:sans-serif "*-helvetica-*") - (:serif "*-charter-*" "*-new century schoolbook-*" "*-times-*"))) +(defvar *clx-font-families* + '((:fix "-*-courier-*") + (:sans-serif "-*-helvetica-*") + (:serif "-*-charter-*" "-*-new century schoolbook-*" "-*-times-*"))) (defvar *clx-fallback-font* "8x13" "When non NIL and nothing better exists use this as the fallback font") diff --git a/demo/listener.lisp b/demo/listener.lisp index b5335316c582f79dd66b1f6cb3cd271bd72e9838..3a83bf5d297ea5128b5cf8f222575d67d73dde1b 100644 --- a/demo/listener.lisp +++ b/demo/listener.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: listener.lisp,v 1.5 92/03/04 16:23:00 cer Exp Locker: cer $ +;; $fiHeader: listener.lisp,v 1.6 92/03/06 09:08:54 cer Exp $ (in-package :clim-demo) @@ -90,11 +90,12 @@ &key keystrokes listener-depth (prompt "=> ")) (catch-abort-gestures ("Return to ~A command level ~D" (frame-pretty-name frame) listener-depth) - ;; Eat any abort characters that might be hanging around. + ;; Eat any abort gestures that might be hanging around. ;; We need to do this because COMMAND-OR-FORM is wierd. - (let* ((abort-chars *abort-gestures*) + (let* ((abort-gestures *abort-gestures*) (*abort-gestures* nil)) - (when (member (stream-read-gesture *standard-input* :timeout 0 :peek-p t) abort-chars) + ;;--- What test does this need? + (when (member (stream-read-gesture *standard-input* :timeout 0 :peek-p t) abort-gestures) (stream-read-gesture *standard-input* :timeout 0))) (fresh-line *standard-input*) (multiple-value-bind (command-or-form type numeric-arg) @@ -118,7 +119,7 @@ (when (eq type :keystroke) (let ((command (lookup-keystroke-command-item command-or-form command-table :numeric-argument numeric-arg))) - (unless (characterp command) + (unless (clim-internals::keyboard-gesture-p command) (when (partial-command-p command) (setq command (funcall *partial-command-parser* command command-table *standard-input* nil @@ -291,7 +292,8 @@ (window-clear (frame-standard-output *application-frame*))) #+Genera -(add-keystroke-to-command-table 'lisp-listener #\c-m-L :command 'com-clear-output-history) +(add-keystroke-to-command-table + 'lisp-listener '(:l :control :meta) :command 'com-clear-output-history) #-Minima (progn @@ -519,8 +521,7 @@ (ll (cdr entry))) (when (or (null ll) reinit) (setq ll (make-application-frame 'lisp-listener - :parent root - :width 500 :height 500)) + :width 600 :height 500)) (if entry (setf (cdr entry) ll) (push (cons root ll) *listeners*))) diff --git a/misc/compile-xm.lisp b/misc/compile-xm.lisp index 915419bdb48b81c07b0d91c99beedb1dfe43d316..1eba2ebd5f5f4077d03d54b87ef98b1d699c1e80 100644 --- a/misc/compile-xm.lisp +++ b/misc/compile-xm.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: compile-xm.lisp,v 1.4 92/03/04 16:23:11 cer Exp Locker: cer $ +;; $fiHeader: compile-xm.lisp,v 1.5 92/03/09 17:42:03 cer Exp Locker: cer $ (in-package :user) diff --git a/pre-silica/cloe-implementation.lisp b/pre-silica/cloe-implementation.lisp index bad5cea51e158ba245d40bbd6b5469a75c8d7c84..e6967b469bf3199fdc83b053c247a3d5035f1068 100644 --- a/pre-silica/cloe-implementation.lisp +++ b/pre-silica/cloe-implementation.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cloe-implementation.lisp,v 1.1 92/01/31 14:27:40 cer Exp $ +;; $fiHeader: cloe-implementation.lisp,v 1.2 92/02/24 13:07:01 cer Exp $ (in-package :clim-internals) @@ -45,6 +45,31 @@ text-color background-color) +;;; + +(eval-when (compile load eval) + +;; Define the new key chars for Cloe CLIM. Regular Cloe defines 0-127, we define +;; 128-139 as the F-keys (F1 thru F12), 140 for c-sh-A, and 141 as c-sh-V +(sys::define-character-name "F1" 128) +(sys::define-character-name "F2" 129) +(sys::define-character-name "F3" 130) +(sys::define-character-name "F4" 131) +(sys::define-character-name "F5" 132) +(sys::define-character-name "F6" 133) +(sys::define-character-name "F7" 134) +(sys::define-character-name "F8" 135) +(sys::define-character-name "F9" 136) +;; Note windows traps F10 as alt-space. Why? +(sys::define-character-name "F10" 137) +(sys::define-character-name "F11" 138) +(sys::define-character-name "F12" 139) +(sys::define-character-name "Arglist" 140) +(sys::define-character-name "ShowValue" 141) + +) ;eval-when + + ;;; (defun initialize-dc () diff --git a/pre-silica/clx-implementation.lisp b/pre-silica/clx-implementation.lisp index e6f3e48806e5289a07bf79843b99f7065f1f0899..658bbb756e6eb009db78efdb8827839b563514b8 100644 --- a/pre-silica/clx-implementation.lisp +++ b/pre-silica/clx-implementation.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clx-implementation.lisp,v 1.2 92/02/24 13:07:02 cer Exp $ +;; $fiHeader: clx-implementation.lisp,v 1.3 92/03/04 16:21:10 cer Exp $ (in-package :clim-internals) @@ -15,9 +15,10 @@ (defvar *window-manager-border-size* 2) -(defvar *clx-font-families* '((:fix "*-courier-*") - (:sans-serif "*-helvetica-*") - (:serif "*-charter-*" "*-new century schoolbook-*" "*-times-*"))) +(defvar *clx-font-families* + '((:fix "-*-courier-*") + (:sans-serif "-*-helvetica-*") + (:serif "-*-charter-*" "-*-new century schoolbook-*" "-*-times-*"))) (defvar *clx-white-color* (xlib:make-color :red 1 :blue 1 :green 1)) (defvar *clx-black-color* (xlib:make-color :red 0 :blue 0 :green 0)) @@ -506,8 +507,8 @@ ;; the event is about any other windows (e.g. intermediaries inserted ;; by the window manger), then it's talking about something beyond ;; our sphere of influence and we ignore it. - (cond ((eq parent (clx-stream-window (window-parent ws))) - (with-slots (left top right bottom) ws + (with-slots (left top right bottom) ws + (cond ((eq parent (clx-stream-window (window-parent ws))) (let ((border-width ;;--- This is technically more correct, but it doesn't ;;--- account for the title bar, and generally messes @@ -518,9 +519,19 @@ (window-note-size-or-position-change ws (- x border-width) (- y border-width) (+ x (- right left) border-width) - (+ y (- bottom top) border-width))))) - (setf (slot-value ws 'reparented-p) nil)) - (t (setf (slot-value ws 'reparented-p) t))) + (+ y (- bottom top) border-width)))) + (setf (slot-value ws 'reparented-p) nil)) + (t + (multiple-value-setq (x y) + (xlib:translate-coordinates + window 0 0 (clx-stream-window (window-parent ws)))) + (let ((border-width 0)) + (window-note-size-or-position-change + ws + (- x border-width) (- y border-width) + (+ x (- right left) border-width) + (+ y (- bottom top) border-width))) + (setf (slot-value ws 'reparented-p) t)))) t) ((:configure-notify) (window width height x y send-event-p border-width) (setq ws (getf (xlib:window-plist window) 'stream)) ;test form @@ -1520,8 +1531,15 @@ (error "Pattern designs other than colors are not supported yet."))) (let* ((design-pixels (make-array (length designs))) (depth (xlib:screen-root-depth screen)) - (image-data (make-array (list height width) - :element-type `(unsigned-byte ,depth)))) + (image-data + (make-array (list height width) + :element-type + (cond ((= depth 1) 'xlib::pixarray-1-element-type) + ((<= depth 4) 'xlib::pixarray-4-element-type) + ((<= depth 8) 'xlib::pixarray-8-element-type) + ((<= depth 16) 'xlib::pixarray-16-element-type) + ((<= depth 24) 'xlib::pixarray-24-element-type) + (t 'xlib::pixarray-32-element-type))))) (declare #+Genera (sys:array-register design-pixels) (simple-vector design-pixels)) ;; Cache the decoded designs from the pattern @@ -1547,7 +1565,6 @@ (setf (xlib:gcontext-tile gc) (let ((image (xlib:create-image :depth depth - :bits-per-pixel depth :data image-data :width width :height height)) (pixmap diff --git a/pre-silica/default-application.lisp b/pre-silica/default-application.lisp index 525ca3c92b71d213b1b056fdd4172a8b57517e0c..1d230f346b20bb557b438729dba0cf2f16eeb453 100644 --- a/pre-silica/default-application.lisp +++ b/pre-silica/default-application.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: default-application.lisp,v 1.2 92/02/24 13:07:17 cer Exp $ +;; $fiHeader: default-application.lisp,v 1.3 92/03/04 16:21:23 cer Exp $ (in-package :clim-internals) @@ -36,7 +36,8 @@ (throw-highlighted-presentation (or (and (output-recording-stream-p window) (frame-find-innermost-applicable-presentation - frame input-context window x y)) + frame input-context window x y + :event button-press-event)) *null-presentation*) input-context button-press-event))) @@ -45,8 +46,11 @@ ;;; satisfying the input context specified by TYPE. Everything that looks for a ;;; presentation goes through this so that applications can specialize it. (defmethod frame-find-innermost-applicable-presentation - ((frame standard-application-frame) input-context stream x y) - (find-innermost-applicable-presentation input-context stream x y)) + ((frame standard-application-frame) input-context stream x y &key event) + (find-innermost-applicable-presentation + input-context stream x y + :frame frame + :modifier-state (window-modifier-state stream) :event event)) ;;; The contract of this is to replay the contents of STREAM within the region. (defmethod frame-replay ((frame standard-application-frame) stream &optional region) @@ -106,7 +110,9 @@ (frame presentation input-context window x y stream) (let ((modifier-state (window-modifier-state window))) (declare (fixnum modifier-state)) - (multiple-value-bind (left left-context middle middle-context right right-context) + (multiple-value-bind (left left-presentation left-context + middle middle-presentation middle-context + right right-presentation right-context) (find-applicable-translators-for-documentation presentation input-context frame window x y modifier-state) (let* ((*print-length* 3) @@ -115,7 +121,8 @@ (*print-array* nil) (*print-readably* nil) (*print-pretty* nil)) - (flet ((document-translator (translator context-type button-name separator) + (flet ((document-translator (translator presentation context-type + button-name separator) ;; Assumes 5 modifier keys and the reverse ordering of *MODIFIER-KEYS* (let ((bit #o20) (shift-name '("h-" "s-" "m-" "c-" "sh-"))) @@ -143,17 +150,18 @@ (setq middle nil) "L,M: ") (t "L: ")))) - (document-translator left left-context button-name - (if (or middle right) "; " ".")))) + (document-translator left left-presentation left-context + button-name (if (or middle right) "; " ".")))) (when middle (let ((button-name (cond ((eq middle right) (setq right nil) "M,R: ") (t "M: ")))) - (document-translator middle middle-context button-name - (if right "; " ".")))) + (document-translator middle middle-presentation middle-context + button-name (if right "; " ".")))) (when right - (document-translator right right-context "R: " ".")) + (document-translator right right-presentation right-context + "R: " ".")) ;; Return non-NIL if any pointer documentation was produced (or left middle right)))))) @@ -161,12 +169,14 @@ (defun find-applicable-translators-for-documentation (presentation input-context frame window x y modifier-state) ;; Assume a maximum of three pointer buttons - (let ((left nil) (left-context nil) - (middle nil) (middle-context nil) - (right nil) (right-context nil)) - (macrolet ((match (translator context-type button) - (let ((button-translator (intern (symbol-name button))) - (button-context (fintern "~A-~A" (symbol-name button) 'context))) + (let ((left nil) (left-presentation nil) (left-context nil) + (middle nil) (middle-presentation nil) (middle-context nil) + (right nil) (right-presentation nil) (right-context nil)) + (macrolet ((match (translator presentation context-type button) + (let* ((symbol (symbol-name button)) + (button-translator (intern symbol)) + (button-presentation (fintern "~A-~A" symbol 'presentation)) + (button-context (fintern "~A-~A" symbol 'context))) `(when (and (or (null ,button-translator) (> (presentation-translator-priority ,translator) (presentation-translator-priority ,button-translator))) @@ -174,6 +184,7 @@ (button-index ,button) modifier-state (presentation-translator-gesture-name ,translator))) (setq ,button-translator ,translator + ,button-presentation ,presentation ,button-context ,context-type))))) (do ((presentation presentation (parent-presentation-with-shared-box presentation window))) @@ -189,21 +200,21 @@ presentation context-type frame window x y :modifier-state modifier-state) - (match translator context-type :left) - (match translator context-type :middle) - (match translator context-type :right))))) + (match translator presentation context-type :left) + (match translator presentation context-type :middle) + (match translator presentation context-type :right))))) (when (and (or left middle right) *presentation-menu-translator* (test-presentation-translator *presentation-menu-translator* presentation context-type frame window x y :modifier-state modifier-state)) - (match *presentation-menu-translator* context-type :left) - (match *presentation-menu-translator* context-type :middle) - (match *presentation-menu-translator* context-type :right))))))) - (values left left-context - middle middle-context - right right-context))) + (match *presentation-menu-translator* presentation context-type :left) + (match *presentation-menu-translator* presentation context-type :middle) + (match *presentation-menu-translator* presentation context-type :right))))))) + (values left left-presentation left-context + middle middle-presentation middle-context + right right-presentation right-context))) #+Genera (defmethod mouse-documentation-window ((window window-stream)) nil) diff --git a/pre-silica/define-application.lisp b/pre-silica/define-application.lisp index f01499015c992dc34665aeb5661fb373f03dcb8e..37d37cd75510a76574c99c878657cdb64ec3f39e 100644 --- a/pre-silica/define-application.lisp +++ b/pre-silica/define-application.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: define-application.lisp,v 1.2 92/02/24 13:07:19 cer Exp $ +;; $fiHeader: define-application.lisp,v 1.3 92/03/04 16:21:24 cer Exp $ (in-package :clim-internals) @@ -1181,9 +1181,12 @@ (defun redisplay-frame-pane-1 (frame pane description &optional force-p) (let* ((options (pane-descriptor-options description)) (display-function (getf options :display-function)) - (incremental-redisplay (getf options :incremental-redisplay)) + (ir (getf options :incremental-redisplay)) + (redisplay-p (if (listp ir) (first ir) ir)) + (check-overlapping (or (atom ir) ;default is T + (getf (rest ir) :check-overlapping t))) (redisplay-record - (and incremental-redisplay + (and redisplay-p (let ((history (stream-output-history pane))) (when history #+compulsive-redisplay @@ -1211,13 +1214,14 @@ (return (cond (display-function ;; If there's a display function, call it to generate new contents. - (cond (incremental-redisplay + (cond (redisplay-p (cond ((or (null redisplay-record) force-p) (when force-p (window-clear pane)) (call-redisplay-function display-function frame pane)) - (t (redisplay redisplay-record pane)))) + (t (redisplay redisplay-record pane + :check-overlapping check-overlapping)))) ((or force-p (getf options :display-after-commands t)) (unless (and (not force-p) diff --git a/silica/classes.lisp b/silica/classes.lisp index fe7c4981f89c035cbf9eab28f57710e65cf04c68..c6dd7ef3b317f9822df21d70b617b938e61e19cf 100644 --- a/silica/classes.lisp +++ b/silica/classes.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: classes.lisp,v 1.5 92/02/26 10:23:16 cer Exp $ +;; $fiHeader: classes.lisp,v 1.6 92/03/04 16:19:23 cer Exp $ (in-package :silica) @@ -120,12 +120,14 @@ (define-event-class keyboard-event (device-event) ((key-name :reader keyboard-event-key-name :initarg :key-name) + ;; This is NIL for keyboard events that don't correspond to + ;; characters in the standard CL character set (character :reader keyboard-event-character :initarg :character))) - (define-event-class key-press-event (keyboard-event) ()) (define-event-class key-release-event (keyboard-event) ()) + (define-event-class pointer-event (device-event) ((x :reader pointer-event-x :initarg :x) (y :reader pointer-event-y :initarg :y) @@ -153,6 +155,7 @@ (define-event-class pointer-exit-event (pointer-motion-or-boundary-event) ()) (define-event-class pointer-enter-event (pointer-motion-or-boundary-event) ()) + (define-event-class window-event (event) ((region :reader window-event-region :initarg :region) (native-region :reader window-event-native-region :initarg :native-region) @@ -163,10 +166,41 @@ (define-event-class window-configuration-event (window-event) ()) (define-event-class window-repaint-event (window-event) ()) + (define-event-class window-manager-event (event) ((sheet :reader event-sheet :initarg :sheet))) (define-event-class window-manager-delete-event (window-manager-event) ()) + (define-event-class timer-event (event) ()) +;;; Values used in event objects + +(defconstant +pointer-left-button+ (ash 1 8)) +(defconstant +pointer-middle-button+ (ash 1 9)) +(defconstant +pointer-right-button+ (ash 1 10)) + +;; The order of this must match the values above +(defconstant *pointer-buttons* '#(:left :middle :right)) + +(deftype button-name () '(member :left :middle :right)) + +(defconstant +shift-key+ (ash 1 0)) +(defconstant +control-key+ (ash 1 1)) +(defconstant +meta-key+ (ash 1 2)) +(defconstant +super-key+ (ash 1 3)) +(defconstant +hyper-key+ (ash 1 4)) + +;; The order of this must match the values above +(defconstant *modifier-keys* '#(:shift :control :meta :super :hyper)) + +(deftype shift-keysym () '(member :left-shift :right-shift)) +(deftype control-keysym () '(member :left-control :right-control)) +(deftype meta-keysym () '(member :left-meta :right-meta)) +(deftype super-keysym () '(member :left-super :right-super)) +(deftype hyper-keysym () '(member :left-hyper :right-hyper)) +(deftype lock-keysym () '(member :caps-lock :shift-lock :mode-lock)) + +(deftype modifier-keysym () + '(or shift-keysym control-keysym meta-keysym super-keysym hyper-keysym lock-keysym)) diff --git a/silica/db-border.lisp b/silica/db-border.lisp index 036ff188bfaf34b2d2859c274c53b7d8a63cc61e..e864a2fad69507ede3a91717656f023d1137bccb 100644 --- a/silica/db-border.lisp +++ b/silica/db-border.lisp @@ -5,17 +5,12 @@ (in-package :silica) -;;; $fiHeader: db-border.lisp,v 1.2 92/02/24 13:16:24 cer Exp Locker: cer $ +;; $fiHeader: db-border.lisp,v 1.3 92/03/04 16:19:25 cer Exp $ ;;; Border Panes (defclass border-pane (layout-pane) ((thickness :initform 1 :initarg :thickness))) -(defmacro bordering (options &body contents) - `(realize-pane 'border-pane - :contents ,@contents - ,@options)) - (defmethod initialize-instance :after ((pane border-pane) &key contents) (sheet-adopt-child pane contents)) @@ -35,6 +30,11 @@ (- width (* 2 thickness)) (- height (* 2 thickness))))) +(defmacro bordering (options &body contents) + `(realize-pane 'border-pane + :contents ,@contents + ,@options)) + (defclass outlined-pane (border-pane) ((background :initform +black+ :accessor pane-background))) diff --git a/silica/db-button.lisp b/silica/db-button.lisp index 956696a0d6d845e63baf4ea03624cbb548430ad9..2ce2f856513366434ba91ffa9ece3026c12f13b1 100644 --- a/silica/db-button.lisp +++ b/silica/db-button.lisp @@ -3,8 +3,6 @@ "Copyright (c) 1990, 1991 International Lisp Associates. Portions copyright (c) 1991, 1992 by Symbolics, Inc. All rights reserved." -;;; $fiHeader$ - (in-package :silica) diff --git a/silica/db-slider.lisp b/silica/db-slider.lisp index 881229472a2a7304e8616687e07d65b1fd562712..e9417a18ab467c66c8f874b44d9d7519c312095f 100644 --- a/silica/db-slider.lisp +++ b/silica/db-slider.lisp @@ -3,8 +3,6 @@ "Copyright (c) 1990, 1991 International Lisp Associates. Portions copyright (c) 1991, 1992 by Symbolics, Inc. All rights reserved." -;;; $fiHeader$ - (in-package :silica) diff --git a/silica/event.lisp b/silica/event.lisp index 0018929330d1d64b5e758d3c7bab98241cc8deab..9a4acf62bc51337fcfeeec251545c86a09517f3f 100644 --- a/silica/event.lisp +++ b/silica/event.lisp @@ -19,129 +19,11 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: event.lisp,v 1.6 92/02/26 10:23:17 cer Exp $ +;; $fiHeader: event.lisp,v 1.7 92/03/04 16:19:36 cer Exp $ (in-package :silica) -;;; Event stuff - -;;--- How important are these actual values? -;;--- Just flush them? -(deftype button-name () - '(member :left :middle :right)) - ; Button and Modifier State Masks -(deftype shift-keysym () - '(member :left-shift :right-shift)) - -(deftype control-keysym () - '(member :left-control :right-control)) - -(deftype meta-keysym () - '(member :left-meta :right-meta)) - -(deftype super-keysym () - '(member :left-super :right-super)) - -(deftype hyper-keysym () - '(member :left-hyper :right-hyper)) - -(deftype lock-keysym () - '(member :caps-lock :shift-lock :mode-lock)) - - -(deftype modifier-keysym () - '(or shift-keysym control-keysym meta-keysym super-keysym - hyper-keysym lock-keysym)) - -(defun-inline state->modifier-state (state) - ;; Get just the modifier-state part of state - (logand state #xFF)) - -(defconstant +pointer-left-button+ (ash 1 8)) -(defconstant +pointer-middle-button+ (ash 1 9)) -(defconstant +pointer-right-button+ (ash 1 10)) - -(defconstant +shift-key+ (ash 1 0)) -(defconstant +control-key+ (ash 1 2)) -(defconstant +meta-key+ (ash 1 3)) -(defconstant +super-key+ (ash 1 4)) -(defconstant +hyper-key+ (ash 1 5)) - -(defmacro keyboard-modifier-state-match-p (button modifier-state &body clauses) - (let ((b (gensym)) - (m (gensym))) - `(let ((,b ,button) - (,m ,modifier-state)) - (declare (ignore-if-unused ,b ,m)) - ,(compile-kbms-clauses - b m `(and ,@clauses))))) - -(defun compile-kbms-clauses (button modifier clause) - (if (atom clause) - (ecase clause - (:left `(= ,button +pointer-left-button+)) - (:right `(= ,button +pointer-right-button+)) - (:middle `(= ,button +pointer-middle-button+)) - (:shift `(logtest ,modifier +shift-key+)) - (:control `(logtest ,modifier +control-key+)) - (:meta `(logtest ,modifier +meta-key+)) - (:super `(logtest ,modifier +super-key+)) - (:hyper `(logtest ,modifier +hyper-key+))) - (ecase (car clause) - (and `(and ,@(mapcar #'(lambda (c) - (compile-kbms-clauses button modifier c)) - (cdr clause)))) - (or `(or ,@(mapcar #'(lambda (c) - (compile-kbms-clauses button modifier c)) - (cdr clause)))) - (not `(not ,(compile-kbms-clauses button modifier (second clause))))))) - - -(defun parse-gesture-spec (gesture-spec) - (if (or (atom gesture-spec) - (and (cdr gesture-spec) - (atom (cdr gesture-spec)))) - gesture-spec - (let ((button (find-if-not #'shift-code gesture-spec))) - (unless button - (cerror "Assume :LEFT and go on." - "Gesture spec missing a keysym: ~S" gesture-spec) - (setq button ':left)) - (cons button (apply #'make-modifier-state (delete button gesture-spec)))))) - -(defvar symbolic->mask `(:left ,+pointer-left-button+ - :right ,+pointer-right-button+ - :middle ,+pointer-middle-button+ - :hyper ,+hyper-key+ - :super ,+super-key+ - :meta ,+meta-key+ - :control ,+control-key+ - :shift ,+shift-key+)) - -(defun button-name->mask (button) - (or (getf symbolic->mask button) - (error "Cannot find button name: ~S" button))) - -(defvar *shifts* `(:hyper ,+hyper-key+ - :super ,+super-key+ - :meta ,+meta-key+ - :control ,+control-key+ - :shift ,+shift-key+)) - -(defun modifier->mask (m) - (or (getf *shifts* m) - (error "cannot find modifier: ~S" m))) - -(defun modifiers->mask (modifiers) - (let ((n 0)) - (dolist (m modifiers n) - (setq n (logior n (modifier->mask m)))))) - - - -;;; - (defgeneric process-next-event (port &key wait-function timeout)) (defgeneric distribute-event (port event)) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index f8ca5a4ed03167a15cab5ed09feb96bafb3e69d4..c1d62cd3d8ae2fa5d8c60a24eb6db0f7dfc87b21 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.9 92/03/04 16:19:41 cer Exp Locker: cer $ +;; $fiHeader: gadgets.lisp,v 1.10 92/03/06 14:17:30 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -100,7 +100,7 @@ (defclass labelled-gadget () ((label :initarg :label :accessor gadget-label) - (alignment :initarg :halign ;;--- compat hack + (alignment :initarg :halign ;--- compatibility hack :initarg :alignment :accessor gadget-alignment)) (:default-initargs :label nil)) @@ -148,10 +148,6 @@ ;;; Push-button (defclass push-button (action-gadget labelled-gadget) - ()) - -(defclass label-pane - (labelled-gadget) ()) @@ -169,6 +165,11 @@ :reader gadget-indicator-type))) +(defclass label-pane + (labelled-gadget) + ()) + + ;;; Caption ;;; option menu ;;; label diff --git a/silica/macros.lisp b/silica/macros.lisp index 808cf80ec19ca041773fd1e9e8e05f9bc17a15c9..d9f3505cd98a55d823e153e2523075e3d88b6ef4 100644 --- a/silica/macros.lisp +++ b/silica/macros.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: macros.lisp,v 1.4 92/02/24 13:04:46 cer Exp $ +;; $fiHeader: macros.lisp,v 1.5 92/03/04 16:19:46 cer Exp $ (in-package :silica) @@ -61,5 +61,6 @@ (defmacro realize-pane (&whole form pane-class &rest pane-options) (declare (ignore pane-class pane-options)) - (error "Realize-pane not inside a with-look-and-feel-realization") + (error "~S not inside a call to ~S" + 'realize-pane 'with-look-and-feel-realization) form) diff --git a/silica/mirror.lisp b/silica/mirror.lisp index f4d832f76733a60b7d1f8f7b4b8f6fffda55684b..bb71f0a1d3ba015a6776f4c8f6c04999ff3f7e55 100644 --- a/silica/mirror.lisp +++ b/silica/mirror.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: mirror.lisp,v 1.10 92/03/06 09:08:28 cer Exp Locker: cer $ +;; $fiHeader: mirror.lisp,v 1.11 92/03/06 14:17:31 cer Exp Locker: cer $ (in-package :silica) @@ -264,7 +264,7 @@ (- bottom top)))) (when (or (/= sc-x 1.0) (/= sc-y 1.0) - (not (zerop tr-x)) + (not (zerop tr-x)) (not (zerop tr-y))) (let (#+Allegro (*error-output* excl::*initial-terminal-io*)) (warn "Mirror scaling ~S,~S,~S,~S" diff --git a/silica/port.lisp b/silica/port.lisp index 3b85d14bf6bcb20302691aa745e6dbef8c4885e2..671674a5dbbd882c773b7c449de76f52d2248fcf 100644 --- a/silica/port.lisp +++ b/silica/port.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: port.lisp,v 1.6 92/03/04 16:19:51 cer Exp Locker: cer $ +;; $fiHeader: port.lisp,v 1.7 92/03/09 17:41:14 cer Exp Locker: cer $ (in-package :silica) @@ -114,14 +114,15 @@ (server-path *default-server-path*) (orientation :default) (units :device)) - (unless port (setq port (find-port :server-paths server-path))) + (unless port + (setq port (find-port :server-path server-path))) (map-over-grafts #'(lambda (graft) (when (graft-matches-spec graft orientation units) (return-from find-graft graft))) port) (make-instance (port-graft-class port) :port port - :orientation orientation + :orientation orientation :units units)) (defun graft-matches-spec (graft orientation units) diff --git a/silica/text-style.lisp b/silica/text-style.lisp index 98853d62cfdfb0f8d21b10247b67ce560c5dd9d5..466decd412400f0dc838a9ca02d7df9922e9af9d 100644 --- a/silica/text-style.lisp +++ b/silica/text-style.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: text-style.lisp,v 1.4 92/02/24 13:05:00 cer Exp $ +;; $fiHeader: text-style.lisp,v 1.5 92/03/04 16:19:56 cer Exp $ (in-package :silica) @@ -76,7 +76,8 @@ (defun initialize-text-style-tables () (setf *null-text-style* (make-text-style-1 nil nil nil 0) - *undefined-text-style* (make-text-style-1 (make-symbol "UNDEFINED") nil nil 1) + *undefined-text-style* + (make-text-style-1 (make-symbol (symbol-name 'undefined)) nil nil 1) *next-text-style-index* 2 *text-style-index-table* (make-array maximum-text-style-index @@ -553,28 +554,7 @@ (dolist (spec specs) (load-specs nil nil nil spec)))) -;(defclass display-device () -; ((name :initarg :name :reader display-device-name) -; (undefined-text-style :initform *undefined-text-style* -; :accessor device-undefined-text-style) -; ;; When this is true, the text style -> device font mapping is done -; ;; loosely. That is, the actual screen size of the font need not be -; ;; exactly what the user has asked for. Instead the closest fit is -; ;; chosen. This is necessary in X11 because different screen sizes & -; ;; resolutions result in fonts having *actual displayed sizes* that -; ;; are not exactly what the fonts were designed for. Loose text style -; ;; mapping is done by having the mapping table ignore size when hashing. -; ;; Thus each bucket is a list of fonts with the same family and face, -; ;; but different sizes. They are kept sorted small to large. -; (allow-loose-text-style-size-mapping -; :initform nil :initarg :allow-loose-text-style-size-mapping) -; ;; When ALLOW-LOOSE-TEXT-STYLE-SIZE-MAPPING is true, this should be -; ;; an EQUAL hash table! -; (mapping-table -; :initform (make-hash-table) :initarg :mapping-table))) -; -;(defvar *display-devices* nil) -; +;;--- I think we need to preserve some of this, no? ;(defmethod initialize-instance :after ; ((device display-device) &key font-for-undefined-style) ; (push-unique device *display-devices* :key #'display-device-name) @@ -587,10 +567,6 @@ ; (add-text-style-mapping ; device *standard-character-set* *undefined-text-style* ; font-for-undefined-style))) -; -;(defmethod print-object ((device display-device) stream) -; (print-unreadable-object (device stream :type t :identity t) -; (format stream "~A" (slot-value device 'name)))) (defmethod (setf text-style-mapping) (mapping (device port) style diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index 80970c3014e37bbac636b15c1022edd8752f89ab..1649d2058605b6e6dbedf28a9a040d81ce0bbe30 100644 --- a/sys/sysdcl.lisp +++ b/sys/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.6 92/03/04 16:22:34 cer Exp Locker: cer $ +;; $fiHeader: sysdcl.lisp,v 1.6 92/03/04 16:22:34 cer Exp $ (in-package #-ANSI-90 "USER" #+ANSI-90 :cl-user) @@ -8,7 +8,9 @@ (eval-when (compile load eval) -;; Tell the world that we're here +;;; Tell the world that we're here + ;;------------- This needs to be in the CLIM.fasl also. + (pushnew :clim *features*) (pushnew :clim-2 *features*) (pushnew :clim-2.0 *features*) @@ -242,8 +244,10 @@ ("window-protocol" :features (not Silica)) ;; Output recording - ("recording-protocol" + ("recording-defs" :load-before-compile ("clim-defs")) + ("recording-protocol" + :load-before-compile ("recording-defs")) ("text-recording" :load-before-compile ("recording-protocol")) ("graphics-recording" @@ -406,13 +410,12 @@ #+(and Silica Allegro) (defsys:defsystem xlib-clim (:default-pathname (frob-pathname "xlib") - :default-binary-pathname (frob-pathname "xlib") - :needed-systems (clim-standalone) - :load-before-compile (clim-standalone)) + :default-binary-pathname (frob-pathname "xlib") + :needed-systems (clim-standalone) + :load-before-compile (clim-standalone)) ("pkg") - #+ignore - ("ffi" :eval-after (mapc #'load '("xlib/xlib.lisp" "xlib/x11-keysyms.lisp" - "xlib/last.lisp"))) + #+++ignore ("ffi" :eval-after (mapc #'load '("xlib/xlib.lisp" "xlib/x11-keysyms.lisp" + "xlib/last.lisp"))) ("ffi") ("xlib-defs" #|:load-before-compile ("ffi") |#) ; Takes forever to compile... ("xlib-funs" :load-before-compile ("ffi")) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 1c9d662149f5c4489678e3a31a3de01c41854405..d79bc778937f122b757eecf1b61eb9286ca427eb 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.14 92/03/06 09:08:32 cer Exp Locker: cer $ +;; $fiHeader: xm-gadgets.lisp,v 1.14 92/03/06 09:08:32 cer Exp $ (in-package :xm-silica) @@ -105,7 +105,8 @@ (sheet motif-label-pane)) (with-accessors ((label gadget-label)) sheet (values 'tk::xm-label - (and label (list :label-string label))))) + (and label (list :label-string label))))) + ;;; Push button diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index db7b5752bb7c1fbf582e9719845eb3c485ff7281..c5089f3743cf1ef4b08ebb346607e1f7d224771d 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.11 92/03/06 14:17:37 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.12 92/03/09 17:41:30 cer Exp Locker: cer $ (in-package :xm-silica) @@ -53,6 +53,7 @@ (,ignore &key ((:display ,display) (or (sys::getenv "DISPLAY") "localhost:0"))) + ,path (declare (ignore ,ignore)) ,@body))) diff --git a/tk/resources.lisp b/tk/resources.lisp index 5a0746a56c6981aa0cb96a88d3fdc9c6cc369053..b525054c32e3d3f5698a3fa344820f127358f9cd 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: resources.lisp,v 1.9 92/03/06 09:08:25 cer Exp Locker: cer $ +;; $fiHeader: resources.lisp,v 1.10 92/03/09 17:40:58 cer Exp Locker: cer $ (in-package :tk) @@ -203,8 +203,7 @@ (defmethod convert-resource-out ((parent t) (type (eql 'boolean)) value) (if value 1 0)) -(defmethod convert-resource-out ((parent t) (type (eql 'string)) - value) +(defmethod convert-resource-out ((parent t) (type (eql 'string)) value) (string-to-char* value)) (define-enumerated-resource dialog-style (:modeless @@ -226,8 +225,7 @@ value) (not (zerop (ash value -24)))) -(defmethod convert-resource-in ((parent t) (type (eql 'cardinal)) - value) +(defmethod convert-resource-in ((parent t) (type (eql 'cardinal)) value) value) ;; We have to do this because we pass a pointer to :unsigned-long but @@ -254,12 +252,10 @@ (defmethod convert-resource-in ((parent t) (type (eql 'pixel)) value) value) -(defmethod convert-resource-out ((parent t) (type (eql - 'horizontal-position)) value) +(defmethod convert-resource-out ((parent t) (type (eql 'horizontal-position)) value) value) -(defmethod convert-resource-out ((parent t) (type (eql - 'vertical-position)) value) +(defmethod convert-resource-out ((parent t) (type (eql 'vertical-position)) value) value) (define-enumerated-resource resize-policy (:none :grow :any)) @@ -274,14 +270,12 @@ (defmethod convert-resource-out ((parent t) (type (eql 'shell-vert-dim)) x) x) (defmethod convert-resource-out ((parent t) (type (eql 'shell-vert-pos)) x) x) (defmethod convert-resource-out ((parent t) (type (eql 'shell-horiz-dim)) x) x) -(defmethod convert-resource-out ((parent t) (type (eql - 'shell-horiz-pos)) x) x) +(defmethod convert-resource-out ((parent t) (type (eql 'shell-horiz-pos)) x) x) (defmethod convert-resource-in ((parent t) (type (eql 'shell-vert-dim)) x) x) (defmethod convert-resource-in ((parent t) (type (eql 'shell-vert-pos)) x) x) (defmethod convert-resource-in ((parent t) (type (eql 'shell-horiz-dim)) x) x) -(defmethod convert-resource-in ((parent t) (type (eql - 'shell-horiz-pos)) x) x) +(defmethod convert-resource-in ((parent t) (type (eql 'shell-horiz-pos)) x) x) (define-enumerated-resource delete-response (:destroy :unmap :do-nothing)) @@ -338,8 +332,7 @@ (defmethod convert-resource-out ((parent t) (type (eql 'position)) value) value) -(defmethod convert-resource-in ((parent t) (type (eql 'position)) - value) +(defmethod convert-resource-in ((parent t) (type (eql 'position)) value) (convert-16bit-resource-in value)) (defun convert-16bit-resource-in (value) @@ -352,8 +345,7 @@ (defmethod convert-resource-out ((parent t) (type (eql 'dimension)) value) value) -(defmethod convert-resource-in ((parent t) (type (eql 'dimension)) - value) +(defmethod convert-resource-in ((parent t) (type (eql 'dimension)) value) (ash value -16)) ;; from OpenLook.h diff --git a/utils/clim-streams.lisp b/utils/clim-streams.lisp index e5b3b213534c89829f3304fa85f57155e39fa5a0..3d5f0144f76466b95b59fe56daed42effd31e21a 100644 --- a/utils/clim-streams.lisp +++ b/utils/clim-streams.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clim-streams.lisp,v 1.1 92/01/31 14:25:28 cer Exp $ +;; $fiHeader: clim-streams.lisp,v 1.2 92/02/24 13:05:20 cer Exp $ (in-package :clim-utils) @@ -19,6 +19,6 @@ (encapsulating-stream) ((stream :initarg :stream :reader encapsulating-stream-stream)) - #+Allegro (:default-initargs :element-type 'extended-char)) + #+Allegro (:default-initargs :element-type 'character)) diff --git a/utils/coral-char-bits.lisp b/utils/coral-char-bits.lisp index f53ca9f1b97135254c8c6f3704aad510f0cb6721..5ae97352ebc4ed2f5ae8f7a68f7eca4089f6c611 100644 --- a/utils/coral-char-bits.lisp +++ b/utils/coral-char-bits.lisp @@ -1,7 +1,7 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: coral-char-bits.lisp,v 1.2 92/01/31 15:16:24 cer Exp $ +;; $fiHeader: coral-char-bits.lisp,v 1.3 92/02/24 13:05:27 cer Exp $ (in-package :clim-utils) @@ -29,7 +29,7 @@ (declare (fixnum ch1 ch2)) ;; Really gross! (ccl::require-type ch1 'character) - (ccl::require-type ch2'character) + (ccl::require-type ch2 'character) (= ch1 ch2)) (defmacro shadow-char-p-function (name) @@ -43,5 +43,3 @@ (shadow-char-p-function graphic-char-p) (shadow-char-p-function standard-char-p) (shadow-char-p-function alpha-char-p) - -;; --- do we need to shadow ALPHANUMERICP ? diff --git a/utils/defpackage.lisp b/utils/defpackage.lisp index 3ef1a5baa9f89ff2302cf9728a6ffa7c5199e9a5..6109d31b5c7cfe5cd5c47e1485d6d46afed226eb 100644 --- a/utils/defpackage.lisp +++ b/utils/defpackage.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: (CLIM-LISP :USE LISP :COLON-MODE :EXTERNAL); Base: 10; Lowercase: Yes -*- -;; $fiHeader: defpackage.lisp,v 1.3 92/02/24 13:05:29 cer Exp $ +;; $fiHeader: defpackage.lisp,v 1.4 92/03/04 16:20:11 cer Exp $ "Copyright (c) 1989, 1990, 1991 by International Lisp Associates. All Rights Reserved." @@ -43,7 +43,7 @@ (nicknames (get-option :nicknames)) #+Genera (prefix-name (car (get-option :prefix-name))) (size (get-option :size)) - (package-var (make-symbol "PACKAGE"))) + (package-var '#:package)) (let ((bad-option (find-if-not #'(lambda (opt) (lisp:member opt '(:use :nicknames :size #+Genera :prefix-name diff --git a/utils/excl-verification.lisp b/utils/excl-verification.lisp index 92bd144aa1dc897eefcf8104c6476d52b8ad00fd..236816a42a1271fca7ca5c57a16a40c35563a815 100644 --- a/utils/excl-verification.lisp +++ b/utils/excl-verification.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: excl-verification.lisp,v 1.2 92/01/31 14:52:38 cer Exp $ +;; $fiHeader: excl-verification.lisp,v 1.4 92/02/24 13:05:36 cer Exp $ (in-package :sys) diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp index 3c27103fce434fec41ed1ecfe76471382cb8df44..64a27b9227feeda3e67358c819fbef04d6ef6d42 100644 --- a/utils/lisp-utilities.lisp +++ b/utils/lisp-utilities.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: lisp-utilities.lisp,v 1.4 92/02/24 13:05:40 cer Exp $ +;; $fiHeader: lisp-utilities.lisp,v 1.5 92/03/04 16:20:15 cer Exp $ (in-package :clim-utils) @@ -89,11 +89,6 @@ forms))))) -;;--- Yes, this is a kludge. I promise we'll fix it. -(deftype extended-char () - #+(or Minima CCL-2) 'character - #-(or Minima CCL-2) 'string-char) - ;;; Characters that are ordinary text rather than potential input editor commands. ;;; Note that GRAPHIC-CHAR-P is true of #\Space (defun ordinary-char-p (char) @@ -208,10 +203,13 @@ (apply #'lisp:format () format-string format-args)))))) (defvar *gensymbol* 0) + +(eval-when (compile load eval) (defun gensymbol (&rest parts) (declare (dynamic-extent parts)) (when (null parts) (setf parts '(gensymbol))) (make-symbol (lisp:format nil "~{~A-~}~D" parts (incf *gensymbol*)))) +) ;eval-when ;;; For macro writers; you can have your GENSYMBOLs start at 1. Use ;;; this in the macro, not in its expansion... @@ -648,7 +646,7 @@ ,@body)) (defmacro writing-clauses (&body body) - (let ((clauses-var (make-symbol "CLAUSES"))) + (let ((clauses-var (gensymbol 'clauses))) `(let ((,clauses-var nil)) (macrolet ((clause (clause) `(push ,clause ,',clauses-var))) @@ -821,8 +819,10 @@ ;;; objects which have the right properties flavors mixed in. (defmacro define-class-mixture-and-resource (name (&key initializer initial-copies) &body specs) - (let ((matcher-function-name (make-symbol (lisp:format nil "~A-MATCHER" name))) - (constructor-function-name (make-symbol (lisp:format nil "~A-CONSTRUCTOR" name)))) + (let ((matcher-function-name + (make-symbol (lisp:format nil "~A-~A" name 'matcher))) + (constructor-function-name + (make-symbol (lisp:format nil "~A-~A" name 'constructor)))) `(define-group ,name define-class-mixture-and-resource (define-class-mixture ,name ,@specs) (defun ,matcher-function-name (object os &rest args) @@ -956,7 +956,8 @@ (unless (eq property :property) (warn "Using ~S to define a function named ~S, which is not a property" 'defun-property (list property symbol indicator))) - (let ((function-name (make-symbol (lisp:format nil "~A-~A-PROPERTY" symbol indicator)))) + (let ((function-name + (make-symbol (lisp:format nil "~A-~A-~A" symbol indicator 'property)))) `(progn (defun ,function-name ,lambda-list ,@body) (eval-when (load eval) (setf (get ',symbol ',indicator) #',function-name))))) @@ -965,10 +966,10 @@ substring-form &body char-clauses) (let ((special-characters ()) - (next-var (make-symbol "NEXT")) - (string-var (if (symbolp string) string (make-symbol "STRING"))) - (end-var (make-symbol "END")) - (char-var (or char-var (make-symbol "THE-CHAR")))) + (next-var (gensymbol 'next)) + (string-var (if (symbolp string) string (gensymbol 'string))) + (end-var (gensymbol 'end)) + (char-var (or char-var (gensymbol 'the-char)))) (dolist (char-clause char-clauses) (let ((chars (first char-clause))) (if (atom chars) diff --git a/utils/packages.lisp b/utils/packages.lisp index 35a2bf3466eed042cc9e90b16ec90cd4caa321df..1872248945b2a85d220d7910e76ae04a18840783 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.5 92/03/04 16:20:19 cer Exp Locker: cer $ +;; $fiHeader: packages.lisp,v 1.4 92/02/24 13:05:46 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -2318,7 +2318,6 @@ viewp with-input-context with-output-as-presentation - with-output-as-gadget with-presentation-type-decoded with-presentation-type-options with-presentation-type-parameters @@ -2579,9 +2578,7 @@ gadget-label gadget-orientation gadget-value - label-pane menu-bar - notify-user note-gadget-activated note-gadget-deactivated push-button @@ -2986,7 +2983,6 @@ doseq dovector evacuate-list - extended-char find-class-that-works fintern flatten-arglist @@ -3189,7 +3185,9 @@ (:export *all-drawing-options* *default-text-style* + *modifier-keys* *null-text-style* + *pointer-buttons* *standard-character-set* *undefined-text-style* +highlighting-line-style+ diff --git a/utils/reader.lisp b/utils/reader.lisp index fb2e0915554f922924e968c870c8e47aecb71a3e..64fead9d2c6d93e1d5866172085d71e11ef6cddf 100644 --- a/utils/reader.lisp +++ b/utils/reader.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: reader.lisp,v 1.4 92/01/31 15:07:27 cer Exp $ +;; $fiHeader: reader.lisp,v 1.5 92/02/24 13:05:53 cer Exp $ (in-package :clim-utils) @@ -11,7 +11,7 @@ ;;; Tool to temporarily add a macro character. (defmacro with-macro-character ((char function) &body body) - (let ((existing (make-symbol "EXISTING"))) + (let ((existing (make-symbol (symbol-name 'existing)))) `(let ((,existing (get-macro-character ,char))) (unwind-protect (progn diff --git a/utils/region-arithmetic.lisp b/utils/region-arithmetic.lisp index 98a8088d7bc9fb66f004fd8552635bb081609285..d3330eaf88fcf00db572ec47794e7df6155f3672 100644 --- a/utils/region-arithmetic.lisp +++ b/utils/region-arithmetic.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: region-arithmetic.lisp,v 1.3 92/02/24 13:05:55 cer Exp $ +;; $fiHeader: region-arithmetic.lisp,v 1.4 92/03/04 16:20:22 cer Exp $ (in-package :clim-utils) @@ -123,8 +123,8 @@ ;;; General region difference (defclass standard-region-difference (region-set area) - ((region1 :type region :initarg region1) - (region2 :type region :initarg region2) + ((region1 :type region :initarg :region1) + (region2 :type region :initarg :region2) (regions :type list))) (define-constructor make-region-difference standard-region-difference