From 165956b92d13f7b5edf72ad185f55cf63ebc2f82 Mon Sep 17 00:00:00 2001 From: Timothy Moore Date: Wed, 29 Mar 2006 10:43:50 +0000 Subject: [PATCH] Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- Apps/Listener/dev-commands.lisp | 148 ++++++++-------- Apps/Listener/file-types.lisp | 30 ++-- Apps/Listener/icons.lisp | 4 +- Apps/Listener/listener.lisp | 26 +-- Apps/Listener/util.lisp | 20 +-- Apps/Scigraph/dwim/tv.lisp | 2 +- Backends/PostScript/afm.lisp | 2 +- Backends/PostScript/class.lisp | 2 +- Backends/PostScript/encoding.lisp | 2 +- Backends/PostScript/font.lisp | 2 +- Backends/PostScript/graphics.lisp | 2 +- Backends/PostScript/package.lisp | 29 ++- Backends/PostScript/sheet.lisp | 2 +- Backends/PostScript/standard-metrics.lisp | 26 +-- Backends/beagle/output/medium.lisp | 6 +- Backends/beagle/windowing/mirror.lisp | 2 +- Examples/demodemo.lisp | 2 +- Experimental/pointer-doc-hack.lisp | 2 +- Experimental/unzip/inflate.lisp | 6 +- Lisp-Dep/fix-acl.lisp | 205 +++++++++++----------- Lisp-Dep/mp-acl.lisp | 2 +- Looks/pixie.lisp | 11 +- bordered-output.lisp | 4 +- events.lisp | 191 +++++++------------- frames.lisp | 2 +- gadgets.lisp | 41 ++++- graphics.lisp | 4 +- mcclim.asd | 4 +- menu-choose.lisp | 2 +- panes.lisp | 88 +++++----- protocol-classes.lisp | 13 +- recording.lisp | 4 +- stream-output.lisp | 6 +- text-formatting.lisp | 4 +- 34 files changed, 452 insertions(+), 444 deletions(-) diff --git a/Apps/Listener/dev-commands.lisp b/Apps/Listener/dev-commands.lisp index 1461572..3f96a46 100644 --- a/Apps/Listener/dev-commands.lisp +++ b/Apps/Listener/dev-commands.lisp @@ -158,41 +158,41 @@ (define-presentation-translator class-name-to-class (class-name class lisp-dev-commands :documentation ((object stream) (format stream "Class object ~A" object)) - :gesture T) + :gesture t) (object) (find-class object)) (define-presentation-translator symbol-to-class (symbol class lisp-dev-commands :documentation ((object stream) (format stream "Class object ~A" object)) - :gesture T + :gesture t :tester ((object) (not (not (find-class object nil)))) - :tester-definitive T) + :tester-definitive t) (object) (find-class object)) (define-presentation-translator symbol-to-class-name (symbol class-name lisp-dev-commands :documentation ((object stream) (format stream "Class ~A" object)) - :gesture T + :gesture t :tester ((object) (not (not (find-class object nil)))) - :tester-definitive T) + :tester-definitive t) (object) object) (define-presentation-translator class-to-class-name (class class-name lisp-dev-commands :documentation ((object stream) (format stream "Class of ~A" object)) - :gesture T) + :gesture t) (object) (clim-mop:class-name object)) (define-presentation-translator symbol-to-function-name (symbol function-name lisp-dev-commands :documentation ((object stream) (format stream "Function ~A" object)) - :gesture T + :gesture t :tester ((object) (fboundp object)) - :tester-definitive T) + :tester-definitive t) (object) object) ;;; Application commands @@ -214,7 +214,7 @@ :provide-output-destination-keyword t) ((program 'string :prompt "command") (args '(sequence string) :default nil :prompt "args")) - (run-program program args :wait T :input nil)) + (run-program program args :wait t :input nil)) ;; I could replace this command with a keyword to COM-RUN.. (define-command (com-background-run :name "Background Run" @@ -327,10 +327,10 @@ (let ((symbols (remove-if-not (lambda (sym) (apropos-applicable-p domain sym)) (apropos-list string real-package)))) (dolist (sym symbols) - (apropos-present-symbol sym *standard-output* T) + (apropos-present-symbol sym *standard-output* t) (terpri)) (setf *apropos-list* symbols) - (note "Results have been saved to ~W~%" '*APROPOS-LIST*)))) + (note "Results have been saved to ~W~%" '*apropos-list*)))) (define-command (com-trace :name "Trace" :command-table lisp-commands @@ -340,8 +340,8 @@ (if (fboundp fsym) (progn (eval `(trace ,fsym)) - (format T "~&Tracing ~W.~%" fsym)) - (format T "~&Function ~W is not defined.~%" fsym))) + (format t "~&Tracing ~W.~%" fsym)) + (format t "~&Function ~W is not defined.~%" fsym))) (define-command (com-untrace :name "Untrace" :command-table lisp-commands @@ -351,8 +351,8 @@ (if (fboundp fsym) (progn (eval `(untrace ,fsym)) - (format T "~&~W will no longer be traced.~%" fsym)) - (format T "~&Function ~W is not defined.~%" fsym))) + (format t "~&~W will no longer be traced.~%" fsym)) + (format t "~&Function ~W is not defined.~%" fsym))) (define-command (com-load-file :name "Load File" @@ -453,7 +453,7 @@ (princ (clim-mop:class-name class) stream)))) ;) inferior-fun :stream stream - :merge-duplicates T + :merge-duplicates t :graph-type :tree :orientation orientation :arc-drawer @@ -528,30 +528,30 @@ (direct-slots (direct-slot-definitions class name)) (readers (reduce #'append (filtermap direct-slots #'clim-mop:slot-definition-readers))) (writers (reduce #'append (filtermap direct-slots #'clim-mop:slot-definition-writers))) - (documentation (first (filtermap direct-slots (lambda (x) (documentation x T))))) + (documentation (first (filtermap direct-slots (lambda (x) (documentation x t))))) (*standard-output* stream)) (macrolet ((with-ink ((var) &body body) - `(with-drawing-options (T :ink ,(intern (concatenate 'string "*SLOT-" (symbol-name var) "-INK*"))) + `(with-drawing-options (t :ink ,(intern (concatenate 'string "*SLOT-" (symbol-name var) "-INK*"))) ,@body)) (fcell ((var align-x &rest cell-opts) &body body) - `(formatting-cell (T :align-x ,align-x ,@cell-opts) + `(formatting-cell (t :align-x ,align-x ,@cell-opts) (with-ink (,var) ,@body) ))) (fcell (name :left) - (with-output-as-presentation (T slot 'slot-definition) + (with-output-as-presentation (t slot 'slot-definition) (princ name)) - (unless (eq type T) + (unless (eq type t) (fresh-line) (with-ink (type) (princ type)))) (fcell (initargs :right) (dolist (x initargs) - (format T "~W~%" x))) + (format t "~W~%" x))) (fcell (initform :left) (if initfunc - (format T "~W" initform) + (format t "~W" initform) (note "No initform"))) #+NIL ; argh, shouldn't this work? @@ -567,19 +567,19 @@ (dolist (writer writers) (format T "~A~%" writer)) (note "No writers")))))) - (formatting-cell (T :align-x :left) + (formatting-cell (t :align-x :left) (if (not (or readers writers)) (note "No accessors") (progn (with-ink (readers) - (if readers (dolist (reader readers) (format T "~A~%" reader)) + (if readers (dolist (reader readers) (format t "~A~%" reader)) (note "No readers~%"))) (with-ink (writers) - (if writers (dolist (writer writers) (format T "~A~%" writer)) + (if writers (dolist (writer writers) (format t "~A~%" writer)) (note "No writers")))))) (fcell (documentation :left) - (when documentation (with-text-family (T :serif) (princ documentation)))) + (when documentation (with-text-family (t :serif) (princ documentation)))) ))) @@ -601,18 +601,18 @@ (position (earliest-slot-definer b class) cpl)))))) (defun print-slot-table-heading () - (formatting-row (T) + (formatting-row (t) (dolist (name '("Slot name" "Initargs" "Initform" "Accessors")) - (formatting-cell (T :align-x :center) - (underlining (T) - (with-text-family (T :sans-serif) + (formatting-cell (t :align-x :center) + (underlining (t) + (with-text-family (t :sans-serif) (princ name))))))) (defun present-slot-list (slots class) - (formatting-table (T) + (formatting-table (t) (print-slot-table-heading) (dolist (slot slots) - (formatting-row (T) + (formatting-row (t) (present-slot slot class))))) (defun friendly-slot-allocation-type (allocation) @@ -626,11 +626,11 @@ (other-slots (set-difference slots instance-slots)) (allocation-types (remove-duplicates (mapcar #'clim-mop:slot-definition-allocation other-slots)))) (when other-slots - (underlining (T) (format T "~&Instance Slots~%"))) + (underlining (t) (format t "~&Instance Slots~%"))) (present-slot-list instance-slots class) (dolist (alloc allocation-types) - (underlining (T) - (format T "~&Allocation: ~A~%" (friendly-slot-allocation-type alloc))) + (underlining (t) + (format t "~&Allocation: ~A~%" (friendly-slot-allocation-type alloc))) (present-slot-list (remove-if (lambda (x) (not (eq alloc (clim-mop:slot-definition-allocation x)))) other-slots) @@ -643,17 +643,17 @@ ((class-name 'clim:symbol :prompt "class name")) (let ((class (find-class class-name nil))) (if (null class) - (format T "~&~A is not a defined class.~%" class-name) + (format t "~&~A is not a defined class.~%" class-name) (let ((slots (clim-mop:class-slots class))) (if (null slots) (note "~%This class has no slots.~%~%") (progn ; oddly, looks much better in courier, because of all the capital letters. -; (with-text-family (T :sans-serif) +; (with-text-family (t :sans-serif) (invoke-as-heading (lambda () - (format T "~&Slots for ") - (with-output-as-presentation (T (clim-mop:class-name class) 'class-name) + (format t "~&Slots for ") + (with-output-as-presentation (t (clim-mop:class-name class) 'class-name) (princ (clim-mop:class-name class))))) (present-the-slots class) )))))) @@ -697,7 +697,7 @@ (symbol-package b))) (string< (package-name (symbol-package a)) (package-name (symbol-package b)))) - (T (string< (symbol-name a) + (t (string< (symbol-name a) (symbol-name b)))) (string< (princ-to-string a) (princ-to-string b)))))) @@ -714,10 +714,10 @@ (let ((funcs (sort (class-funcs class) (lambda (a b) (slot-name-sortp (clim-mop:generic-function-name a) (clim-mop:generic-function-name b)))))) - (with-text-size (T :small) + (with-text-size (t :small) (format-items funcs :printer (lambda (item stream) (present item 'generic-function :stream stream)) - :move-cursor T)))))) + :move-cursor t)))))) (defun method-applicable-to-args-p (method args arg-types) (loop @@ -1026,7 +1026,7 @@ :type (pathname-type pathname) :version (pathname-version pathname)))))) -(defun pretty-pretty-pathname (pathname stream &key (long-name T)) +(defun pretty-pretty-pathname (pathname stream &key (long-name t)) (with-output-as-presentation (stream pathname 'clim:pathname) (let ((icon (icon-of pathname))) (when icon (draw-icon stream icon :extra-spacing 3))) @@ -1077,10 +1077,10 @@ &key (sort-by '(member name size modify none) :default 'name) (show-hidden 'boolean :default nil :prompt "show hidden") - (hide-garbage 'boolean :default T :prompt "hide garbage") + (hide-garbage 'boolean :default t :prompt "hide garbage") (show-all 'boolean :default nil :prompt "show all") (style '(member items list) :default 'items :prompt "listing style") - (group-directories 'boolean :default T :prompt "group directories?") + (group-directories 'boolean :default t :prompt "group directories?") (full-names 'boolean :default nil :prompt "show full name?") (list-all-direct-subdirectories 'boolean :default nil :prompt "list all direct subdirectories?")) @@ -1092,18 +1092,18 @@ (list-directory-with-all-direct-subdirectories wild-pathname) (list-directory wild-pathname)))) - (with-text-family (T :sans-serif) + (with-text-family (t :sans-serif) (invoke-as-heading (lambda () - (format T "Directory contents of ") + (format t "Directory contents of ") (present (directory-namestring pathname) 'pathname) (when (pathname-type pathname) - (format T " (only files of type ~a)" (pathname-type pathname))))) + (format t " (only files of type ~a)" (pathname-type pathname))))) (when (parent-directory pathname) - (with-output-as-presentation (T (strip-filespec (parent-directory pathname)) 'clim:pathname) - (draw-icon T (standard-icon "up-folder.xpm") :extra-spacing 3) - (format T "Parent Directory~%"))) + (with-output-as-presentation (t (strip-filespec (parent-directory pathname)) 'clim:pathname) + (draw-icon t (standard-icon "up-folder.xpm") :extra-spacing 3) + (format t "Parent Directory~%"))) (dolist (group (split-sort-pathnames dir group-directories sort-by)) (unless show-all @@ -1120,7 +1120,7 @@ (declare (ignore stream)) (pretty-pretty-pathname x *standard-output* :long-name full-names))) (goatee::reposition-stream-cursor *standard-output*) - (vertical-gap T)) + (vertical-gap t)) (list (dolist (ent group) (let ((ent (merge-pathnames ent pathname))) ;; This is for CMUCL, see above. (fixme!) ;; And breaks some things for SBCL.. (mgr) @@ -1131,7 +1131,7 @@ (clim:pathname com-show-directory filesystem-commands :gesture :select :pointer-documentation ((object stream) (format stream "Show directory ~A" object)) - :tester-definitive T + :tester-definitive t :tester ((object) (directoryp object))) (object) @@ -1147,7 +1147,7 @@ (note "~A does not exist." pathname)) ((not (directoryp pathname)) (note "~A is not a directory." pathname)) - (T (change-directory (merge-pathnames pathname))) ))) + (t (change-directory (merge-pathnames pathname))) ))) (define-command (com-up-directory :name "Up Directory" :menu t @@ -1156,8 +1156,8 @@ (let ((parent (parent-directory *default-pathname-defaults*))) (when parent (change-directory parent) - (italic (T) - (format T "~&The current directory is now ") + (italic (t) + (format t "~&The current directory is now ") (present (truename parent)) (terpri))))) @@ -1283,18 +1283,18 @@ (directoryp pathname));; FIXME: Need smart conversion to directories, here and elsewhere. (progn (push *default-pathname-defaults* *directory-stack*) (com-change-directory pathname)) - (italic (T) + (italic (t) (fresh-line) (present (truename pathname)) - (format T " does not exist or is not a directory.~%")) )) + (format t " does not exist or is not a directory.~%")) )) (compute-dirstack-command-eligibility *application-frame*)) (defun comment-on-dir-stack () (if *directory-stack* (progn - (format T "~&The top of the directory stack is now ") + (format t "~&The top of the directory stack is now ") (present (truename (first *directory-stack*))) (terpri)) - (format T "~&The directory stack is now empty.~%"))) + (format t "~&The directory stack is now empty.~%"))) (define-command (com-pop-directory :name "Pop Directory" :menu t @@ -1304,16 +1304,16 @@ (note "The directory stack is empty!") (progn (com-change-directory (pop *directory-stack*)) - (italic (T) (comment-on-dir-stack)))) + (italic (t) (comment-on-dir-stack)))) (compute-dirstack-command-eligibility *application-frame*)) (define-command (com-drop-directory :name "Drop Directory" :menu t :command-table directory-stack-commands) () - (italic (T) + (italic (t) (if (null *directory-stack*) - (format T "~&The directory stack is empty!~%") + (format t "~&The directory stack is empty!~%") (progn (setf *directory-stack* (rest *directory-stack*)) (comment-on-dir-stack)))) @@ -1323,9 +1323,9 @@ :menu t :command-table directory-stack-commands) () - (italic (T) + (italic (t) (if (null *directory-stack*) - (format T "~&The directory stack is empty!~%") + (format t "~&The directory stack is empty!~%") (progn (psetf (first *directory-stack*) *default-pathname-defaults* *default-pathname-defaults* (first *directory-stack*)) @@ -1412,21 +1412,21 @@ "Hack of the day.. let McCLIM determine presentation type to use, except for lists, because the list presentation method is inappropriate for lisp return values." (typecase object (sequence (present object 'expression)) - (T (present object)))) + (t (present object)))) (defun display-evalues (values) - (with-drawing-options (T :ink +olivedrab+) + (with-drawing-options (t :ink +olivedrab+) (cond ((null values) - (format T "No values.~%")) + (format t "No values.~%")) ((= 1 (length values)) (hackish-present (first values)) (fresh-line)) - (T (do ((i 0 (1+ i)) + (t (do ((i 0 (1+ i)) (item values (rest item))) ((null item)) - (with-drawing-options (T :ink +limegreen+) - (with-text-style (T (make-text-style nil :italic :small)) - (format T "~A " i))) + (with-drawing-options (t :ink +limegreen+) + (with-text-style (t (make-text-style nil :italic :small)) + (format t "~A " i))) (hackish-present (first item)) (fresh-line)))))) @@ -1484,7 +1484,7 @@ (commands (cdr foo))) (invoke-as-heading (lambda () - (format T "Command table ") + (format t "Command table ") (with-output-as-presentation (t ct 'clim:command-table) (princ (command-table-name ct))))) (if commands diff --git a/Apps/Listener/file-types.lisp b/Apps/Listener/file-types.lisp index 40673d4..8190dbe 100644 --- a/Apps/Listener/file-types.lisp +++ b/Apps/Listener/file-types.lisp @@ -136,7 +136,7 @@ (cond ((wild-pathname-p pathname) (standard-icon "wild.xpm")) ((not (probe-file pathname)) (standard-icon "invalid.xpm")) ((directoryp pathname) *folder-icon*) ;; FIXME: use inode mime types - (T (let ((mime-class (find-class (pathname-mime-type pathname) nil))) + (t (let ((mime-class (find-class (pathname-mime-type pathname) nil))) (if mime-class (or (gethash (class-name mime-class) *icon-mapping*) (icon-of (clim-mop:class-prototype (find-class (pathname-mime-type pathname) nil)))) @@ -201,15 +201,15 @@ (defun read-slashified-line (stream &optional (accumulation nil)) (let ((line (read-line stream nil))) (cond ((null line) (values nil nil)) - ((zerop (length line)) (values accumulation T)) + ((zerop (length line)) (values accumulation t)) ((and (null accumulation) ;; # Comment (char= (elt line 0) #\#)) - (values nil T)) - (T (if (char= #\\ (elt line (1- (length line)))) + (values nil t)) + (t (if (char= #\\ (elt line (1- (length line)))) (read-slashified-line stream (concatenate 'string accumulation (subseq line 0 (1- (length line))))) - (values (concatenate 'string accumulation line) T)))))) + (values (concatenate 'string accumulation line) t)))))) (defun read-the-lines (pathname) (let ((elements nil)) @@ -273,7 +273,7 @@ (when split-pos (let* ((foo (subseq string start split-pos)) (pos (skip-whitespace string (1+ split-pos)))) -; (format T "~%***** foo=~A~%" foo) +; (format t "~%***** foo=~A~%" foo) (when pos (let* ((end (or (if (eql (elt string pos) #\") (1+ (position-if (lambda (c) @@ -299,7 +299,7 @@ (when (eq keysym :type) (setf (gethash :subtype table) (nth-value 2 (read-mime-type bar))) (setf (gethash :media-type table) (read-mime-type bar))) -; (format T "~&~W => ~W~%" foo bar) +; (format t "~&~W => ~W~%" foo bar) (setf (gethash keysym table) value) (parse-netscrapings table string end) )))))) table) @@ -335,7 +335,7 @@ (exts (gethash :exts elt))) (eval `(define-mime-type (,media-type ,subtype) (:extensions ,@exts)))) - #+nil(format T "Ignoring ~W, unknown media type.~%" (gethash :type elt))))) + #+nil(format t "Ignoring ~W, unknown media type.~%" (gethash :type elt))))) (defun parse-mime-types-file (pathname) (mapcar (lambda (x) (process-mime-type (parse-mt-elt x))) @@ -401,7 +401,7 @@ (when (< index (1- (length string))) (push (elt string (incf index)) chars))) ((eql c #\;) (return-from poop chars)) - (T (push c chars))) + (t (push c chars))) (incf index))) (values (string-trim *whitespace* (concatenate 'string (nreverse chars))) @@ -411,7 +411,7 @@ (let* ((sep-pos (position #\= string)) (field-name (subseq string 0 (or sep-pos (length string))))) (values (intern (string-upcase field-name) (find-package :keyword)) - (ignore-errors (or (when sep-pos (subseq string (1+ sep-pos))) T))))) + (ignore-errors (or (when sep-pos (subseq string (1+ sep-pos))) t))))) (defun parse-mailcap-entry (line) "Parses a line of the mailcap file, returning either nil or the properties @@ -469,7 +469,7 @@ *mime.types-search-path*))) (dolist (path (reverse search-path)) (when (probe-file path) - (format T "Loading mime types from ~A~%" path) + (format t "Loading mime types from ~A~%" path) (parse-mime-types-file path))))) (defun load-mailcaps () @@ -477,7 +477,7 @@ *mailcap-search-path*))) (dolist (path (reverse search-path)) (when (probe-file path) - (format T "Loading mailcap from ~A~%" path) + (format t "Loading mailcap from ~A~%" path) (parse-mailcap-file path))))) @@ -544,7 +544,7 @@ (cond ((eql d #\s) (princ (quote-shell-characters (namestring (truename pathname))) out)) ((eql d #\t) (princ (gethash :type spec) out)) ((eql d #\u) (princ (pathname-to-uri-string pathname) out)) - (T (debugf "Ignoring unknown % syntax." d)))) + (t (debugf "Ignoring unknown % syntax." d)))) (write-char c out)))))) (defun find-viewspec (pathname) @@ -571,13 +571,13 @@ (test (gethash :test def)) (needsterminal (gethash :needsterminal def))) (if needsterminal - (format T "Sorry, the viewer app needs a terminal (fixme!)~%") + (format t "Sorry, the viewer app needs a terminal (fixme!)~%") (progn (when test (debugf "Sorry, ignoring TEST option right now.. " test)) (if view-command (run-program "/bin/sh" `("-c" ,(gen-view-command-line def pathname) "&")) - (format T "~&No view-command!~%")))))))) + (format t "~&No view-command!~%")))))))) diff --git a/Apps/Listener/icons.lisp b/Apps/Listener/icons.lisp index 984af6e..6b54c62 100644 --- a/Apps/Listener/icons.lisp +++ b/Apps/Listener/icons.lisp @@ -52,11 +52,11 @@ ;; Icon functions -(defmethod icon-of ((object T)) +(defmethod icon-of ((object t)) *object-icon*) (defun draw-icon (stream pattern &key (extra-spacing 0) ) - (let ((stream (if (eq stream T) *standard-output* stream))) + (let ((stream (if (eq stream t) *standard-output* stream))) (multiple-value-bind (x y) (stream-cursor-position stream) (draw-pattern* stream pattern x y) diff --git a/Apps/Listener/listener.lisp b/Apps/Listener/listener.lisp index 84bcd1a..2193612 100644 --- a/Apps/Listener/listener.lisp +++ b/Apps/Listener/listener.lisp @@ -84,22 +84,22 @@ #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes)) #+clisp (values (sys::%room)) #-(or cmu scl sbcl lispworks openmcl clisp) 0)) - (with-text-family (T :serif) - (formatting-table (T :x-spacing '(3 :character)) - (formatting-row (T) + (with-text-family (t :serif) + (formatting-table (t :x-spacing '(3 :character)) + (formatting-row (t) (macrolet ((cell ((align-x) &body body) - `(formatting-cell (T :align-x ,align-x) ,@body))) - (cell (:left) (format T "~A@~A" username sitename)) + `(formatting-cell (t :align-x ,align-x) ,@body))) + (cell (:left) (format t "~A@~A" username sitename)) (cell (:center) - (format T "Package ") - (print-package-name T)) + (format t "Package ") + (print-package-name t)) (cell (:center) (when (probe-file *default-pathname-defaults*) - (with-output-as-presentation (T (truename *default-pathname-defaults*) 'pathname) - (format T "~A" (frob-pathname *default-pathname-defaults*)))) + (with-output-as-presentation (t (truename *default-pathname-defaults*) 'pathname) + (format t "~A" (frob-pathname *default-pathname-defaults*)))) (when *directory-stack* - (with-output-as-presentation (T *directory-stack* 'directory-stack) - (format T " (~D deep)" (length *directory-stack*))))) + (with-output-as-presentation (t *directory-stack* 'directory-stack) + (format t " (~D deep)" (length *directory-stack*))))) ;; Although the CLIM spec says the item formatter should try to fill ;; the available width, I can't get either the item or table formatters ;; to really do so such that the memory usage appears right justified. @@ -157,7 +157,7 @@ ((system-command-reader :accessor system-command-reader :initarg :system-command-reader :initform t)) - (:panes (interactor :interactor :scroll-bars T + (:panes (interactor :interactor :scroll-bars t :display-function #'listener-initial-display-function :display-time t) (doc :pointer-documentation) @@ -218,7 +218,7 @@ (restart-case (call-next-method) (return-to-listener () :report "Return to listener." - (throw 'return-to-listener T))))))) + (throw 'return-to-listener t))))))) ;; Oops. As we've ditched our custom toplevel, we now have to duplicate all ;; this setup work to implement one little trick. diff --git a/Apps/Listener/util.lisp b/Apps/Listener/util.lisp index e1ba6d6..9e47f96 100644 --- a/Apps/Listener/util.lisp +++ b/Apps/Listener/util.lisp @@ -42,7 +42,7 @@ (mapcar #'(lambda (x) (cond ((stringp x) `((princ ,x *trace-output*))) - (T `((princ ',x *trace-output*) + (t `((princ ',x *trace-output*) (princ "=" *trace-output*) (write ,x :stream *trace-output*) (princ #\space *trace-output*))))) @@ -96,8 +96,8 @@ (defun sbcl-frob-to-pathname (pathname string) "This just keeps getting more disgusting." (let* ((parent (strip-filespec pathname)) - (pn (merge-pathnames (make-pathname :name (subseq string 0 (position #\. string :start 1 :from-end T)) - :type (let ((x (position #\. string :start 1 :from-end T))) + (pn (merge-pathnames (make-pathname :name (subseq string 0 (position #\. string :start 1 :from-end t)) + :type (let ((x (position #\. string :start 1 :from-end t))) (if x (subseq string (1+ x)) nil))) parent)) (dir (ignore-errors (sb-posix:opendir (namestring pn))))) @@ -168,7 +168,7 @@ ;;; This ought to change the current directory to *default-pathname-defaults*.. ;;; (see above) -(defun run-program (program args &key (wait T) (output *standard-output*) (input *standard-input*)) +(defun run-program (program args &key (wait t) (output *standard-output*) (input *standard-input*)) #+(or CMU scl) (ext:run-program program args :input input :output output :wait wait) @@ -182,7 +182,7 @@ #+clisp (ext:run-program program :arguments args :wait wait) #-(or CMU scl SBCL lispworks clisp) - (format T "~&Sorry, don't know how to run programs in your CL.~%")) + (format t "~&Sorry, don't know how to run programs in your CL.~%")) ;;;; CLIM/UI utilities @@ -216,12 +216,12 @@ (truncate (/ (text-style-ascent (medium-text-style stream) stream) fraction)))) (defun invoke-as-heading (cont &optional ink) - (with-drawing-options (T :ink (or ink +royal-blue+) :text-style (make-text-style :sans-serif :bold nil)) + (with-drawing-options (t :ink (or ink +royal-blue+) :text-style (make-text-style :sans-serif :bold nil)) (fresh-line) - (bordering (T :underline) + (bordering (t :underline) (funcall cont)) (fresh-line) - (vertical-gap T))) + (vertical-gap t))) (defun indent-to (stream x &optional (spacing 0) ) "Advances cursor horizontally to coordinate X. If the cursor is already past @@ -451,7 +451,7 @@ function specified by :ABBREVIATOR. Abbreviate is controlled by the variables ;; Disgusting hacks to make input default to nil, as CMUCL's run-program seems ;; to hang randomly unless I do that. But sometimes I'll need to really change these.. ;; ** Goddamn CMUCL's run-program likes to hang randomly even with this dumb hack. Beware.. -(defparameter *run-output* T) +(defparameter *run-output* t) (defparameter *run-input* nil) ;; We attempt to translate keywords and a few types of lisp objects @@ -459,7 +459,7 @@ function specified by :ABBREVIATOR. Abbreviate is controlled by the variables (defgeneric transform-program-arg (arg)) -(defmethod transform-program-arg ((arg T)) +(defmethod transform-program-arg ((arg t)) (values (prin1-to-string arg))) (defmethod transform-program-arg ((arg string)) diff --git a/Apps/Scigraph/dwim/tv.lisp b/Apps/Scigraph/dwim/tv.lisp index 9e032ba..cbd00c2 100644 --- a/Apps/Scigraph/dwim/tv.lisp +++ b/Apps/Scigraph/dwim/tv.lisp @@ -457,7 +457,7 @@ advised of the possiblity of such damages. (clim:enable-frame frame) (clim:panes-need-redisplay frame) (clim:redisplay-frame-panes frame)) - (T (clim:start-frame frame wait-until-done))))) + (t (clim:start-frame frame wait-until-done))))) (:clim-1.0 (labels ((set-backing-store (window value) #+xlib diff --git a/Backends/PostScript/afm.lisp b/Backends/PostScript/afm.lisp index 8637c0d..51dab3b 100644 --- a/Backends/PostScript/afm.lisp +++ b/Backends/PostScript/afm.lisp @@ -25,7 +25,7 @@ ;;; - Kerning, ligatures. ;;; - Full AFM/AMFM/ACFM support. -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) (defun space-char-p (char) (member char '(#\Space #\Tab))) diff --git a/Backends/PostScript/class.lisp b/Backends/PostScript/class.lisp index b548424..8440368 100644 --- a/Backends/PostScript/class.lisp +++ b/Backends/PostScript/class.lisp @@ -32,7 +32,7 @@ ;;; ;;;--GB -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) ;;;; Medium diff --git a/Backends/PostScript/encoding.lisp b/Backends/PostScript/encoding.lisp index 43e0fb9..6ea1a69 100644 --- a/Backends/PostScript/encoding.lisp +++ b/Backends/PostScript/encoding.lisp @@ -23,7 +23,7 @@ ;;; Boston, MA 02111-1307 USA. -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) (defvar *iso-latin-1-symbolic-names* '#(NIL NIL NIL NIL diff --git a/Backends/PostScript/font.lisp b/Backends/PostScript/font.lisp index 05e9ce5..84797c5 100644 --- a/Backends/PostScript/font.lisp +++ b/Backends/PostScript/font.lisp @@ -23,7 +23,7 @@ ;;; - Kerning, ligatures. ;;; - device fonts -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) (defclass font-info () ((name :type string :initarg :name :reader font-info-name) diff --git a/Backends/PostScript/graphics.lisp b/Backends/PostScript/graphics.lisp index d2cb0d6..6029b15 100644 --- a/Backends/PostScript/graphics.lisp +++ b/Backends/PostScript/graphics.lisp @@ -37,7 +37,7 @@ ;;; - structure this file ;;; - set miter limit? -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) ;;; Postscript output utilities (defun write-number (stream number) diff --git a/Backends/PostScript/package.lisp b/Backends/PostScript/package.lisp index d775ea0..e77daa1 100644 --- a/Backends/PostScript/package.lisp +++ b/Backends/PostScript/package.lisp @@ -18,24 +18,23 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -(in-package :COMMON-LISP-USER) +(in-package :cl-user) -(defpackage "CLIM-POSTSCRIPT" - (:use "CLIM" "CLIM-EXTENSIONS" "CLIM-LISP") - (:export "LOAD-AFM-FILE") - (:import-from "CLIM-INTERNALS" - "GET-ENVIRONMENT-VARIABLE" - "MAP-REPEATED-SEQUENCE" - "ATAN*" +(defpackage #:clim-postscript + (:use #:clim #:clim-extensions #:clim-lisp) + (:export #:load-afm-file) + (:import-from #:clim-internals + #:get-environment-variable + #:map-repeated-sequence + #:atan* - "ELLIPSE-NORMAL-RADII*" + #:ellipse-normal-radii* - "GET-TRANSFORMATION" - "UNTRANSFORM-ANGLE" - "WITH-TRANSFORMED-POSITION" + #:get-transformation + #:untransform-angle + #:with-transformed-position - "MAXF" + #:maxf - "PORT-TEXT-STYLE-MAPPINGS" - )) + #:port-text-style-mappings)) diff --git a/Backends/PostScript/sheet.lisp b/Backends/PostScript/sheet.lisp index 426c250..0d79718 100644 --- a/Backends/PostScript/sheet.lisp +++ b/Backends/PostScript/sheet.lisp @@ -35,7 +35,7 @@ ;;; ;;;--GB -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) (defmacro with-output-to-postscript-stream ((stream-var file-stream &rest options) diff --git a/Backends/PostScript/standard-metrics.lisp b/Backends/PostScript/standard-metrics.lisp index 0ab5b79..cd430b9 100644 --- a/Backends/PostScript/standard-metrics.lisp +++ b/Backends/PostScript/standard-metrics.lisp @@ -1,6 +1,6 @@ -(IN-PACKAGE :CLIM-POSTSCRIPT) -(DEFINE-FONT-METRICS '"Times-Roman" +(in-package :clim-postscript) +(define-font-metrics '"Times-Roman" '683 '217 '0 @@ -209,7 +209,7 @@ (-1 "Yacute" 722 890 0 -22 703) (-1 "brokenbar" 200 676 14 -67 133) (-1 "onehalf" 750 676 14 -31 746))) -(DEFINE-FONT-METRICS '"Times-Bold" +(define-font-metrics '"Times-Bold" '676 '205 '0 @@ -419,7 +419,7 @@ (-1 "Yacute" 722 928 0 -15 699) (-1 "brokenbar" 220 691 19 -66 154) (-1 "onehalf" 750 688 12 7 775))) -(DEFINE-FONT-METRICS '"Times-Italic" +(define-font-metrics '"Times-Italic" '683 '205 '-15.5 @@ -630,7 +630,7 @@ (-1 "Yacute" 556 876 0 -78 633) (-1 "brokenbar" 275 666 18 -105 171) (-1 "onehalf" 750 676 10 -34 749))) -(DEFINE-FONT-METRICS '"Times-BoldItalic" +(define-font-metrics '"Times-BoldItalic" '699 '205 '-15 @@ -836,7 +836,7 @@ (-1 "Yacute" 611 904 0 -73 659) (-1 "brokenbar" 220 685 18 -66 154) (-1 "onehalf" 750 683 14 9 723))) -(DEFINE-FONT-METRICS '"Courier" +(define-font-metrics '"Courier" '629 '157 '0 @@ -1077,7 +1077,7 @@ (-1 "aring" 600 627 15 -53 559) (-1 "yacute" 600 672 157 -7 592) (-1 "icircumflex" 600 654 0 -94 505))) -(DEFINE-FONT-METRICS '"Courier-Oblique" +(define-font-metrics '"Courier-Oblique" '629 '157 '-12 @@ -1319,7 +1319,7 @@ (-1 "aring" 600 627 15 -76 569) (-1 "yacute" 600 672 157 4 683) (-1 "icircumflex" 600 654 0 -95 551))) -(DEFINE-FONT-METRICS '"Courier-Bold" +(define-font-metrics '"Courier-Bold" '626 '142 '0 @@ -1558,7 +1558,7 @@ (-1 "aring" 600 678 15 -35 570) (-1 "yacute" 600 661 142 4 601) (-1 "icircumflex" 600 657 0 -63 523))) -(DEFINE-FONT-METRICS '"Courier-BoldOblique" +(define-font-metrics '"Courier-BoldOblique" '626 '142 '-12 @@ -1798,7 +1798,7 @@ (-1 "aring" 600 678 15 -62 592) (-1 "yacute" 600 661 142 20 694) (-1 "icircumflex" 600 657 0 -77 566))) -(DEFINE-FONT-METRICS '"Helvetica" +(define-font-metrics '"Helvetica" '718 '207 '0 @@ -2006,7 +2006,7 @@ (-1 "Yacute" 667 929 0 -14 653) (-1 "brokenbar" 260 737 19 -94 167) (-1 "onehalf" 834 703 19 -43 773))) -(DEFINE-FONT-METRICS '"Helvetica-Oblique" +(define-font-metrics '"Helvetica-Oblique" '718 '207 '-12 @@ -2215,7 +2215,7 @@ (-1 "Yacute" 667 929 0 -167 806) (-1 "brokenbar" 260 737 19 -90 324) (-1 "onehalf" 834 703 19 -114 839))) -(DEFINE-FONT-METRICS '"Helvetica-Bold" +(define-font-metrics '"Helvetica-Bold" '718 '207 '0 @@ -2423,7 +2423,7 @@ (-1 "Yacute" 667 936 0 -15 653) (-1 "brokenbar" 280 737 19 -84 196) (-1 "onehalf" 834 710 19 -26 794))) -(DEFINE-FONT-METRICS '"Helvetica-BoldOblique" +(define-font-metrics '"Helvetica-BoldOblique" '718 '207 '-12 diff --git a/Backends/beagle/output/medium.lisp b/Backends/beagle/output/medium.lisp index f1fccb7..0f2b16b 100644 --- a/Backends/beagle/output/medium.lisp +++ b/Backends/beagle/output/medium.lisp @@ -93,7 +93,7 @@ (send (medium-bezier-path medium) :set-line-width width) (when dashes - (when (eq dashes T) + (when (eq dashes t) ;; Provide default dash pattern... no idea why, but when I use ;; #(5.0 5.0) as the dafault dash, it gets displayed as a solid ;; line (no dashing). So the default is larger than it needs to @@ -694,7 +694,7 @@ rounding\" gives consistent results." (defmethod medium-draw-point* ((medium beagle-medium) x y) (let ((width (coerce (line-style-thickness (medium-line-style medium)) 'short-float))) - (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) T))) + (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -709,7 +709,7 @@ rounding\" gives consistent results." (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) (let ((width (coerce (line-style-thickness (medium-line-style medium)) 'short-float))) (do-sequence ((x y) coord-seq) - (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) T))))) + (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) t))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/Backends/beagle/windowing/mirror.lisp b/Backends/beagle/windowing/mirror.lisp index cdfd51d..902e456 100644 --- a/Backends/beagle/windowing/mirror.lisp +++ b/Backends/beagle/windowing/mirror.lisp @@ -455,7 +455,7 @@ for windows that are not decorated." (send (send mirror 'window) :frame-rect-for-content-rect rect :style-mask (%beagle-style-mask-for-frame sheet)) - :display T)))) + :display t)))) (defun %beagle-style-mask-for-frame (sheet) diff --git a/Examples/demodemo.lisp b/Examples/demodemo.lisp index 605c0f8..13fa261 100644 --- a/Examples/demodemo.lisp +++ b/Examples/demodemo.lisp @@ -211,4 +211,4 @@ -(format T "~&;; try (CLIM-DEMO::DEMODEMO)~%") +(format t "~&;; try (CLIM-DEMO::DEMODEMO)~%") diff --git a/Experimental/pointer-doc-hack.lisp b/Experimental/pointer-doc-hack.lisp index a25217f..c490f02 100644 --- a/Experimental/pointer-doc-hack.lisp +++ b/Experimental/pointer-doc-hack.lisp @@ -235,7 +235,7 @@ ((eql button +pointer-left-button+) *icon-mouse-left*) ((eql button +pointer-middle-button+) *icon-mouse-middle*) ((eql button +pointer-right-button+) *icon-mouse-right*) - (T name))) + (t name))) (if (not (typep name 'indexed-pattern)) (format pstream "~A: " name) (multiple-value-bind (x y) (stream-cursor-position pstream) (draw-pattern* pstream name x y) diff --git a/Experimental/unzip/inflate.lisp b/Experimental/unzip/inflate.lisp index f42f7e3..66e8535 100644 --- a/Experimental/unzip/inflate.lisp +++ b/Experimental/unzip/inflate.lisp @@ -220,7 +220,7 @@ ;; needed. We loop, until we have enough bits to make a ;; sensible decision. `((lambda (ht) - (declare (type (simple-array T (*)) ht)) + (declare (type (simple-array t (*)) ht)) (let ((m ',(car ms)) (b 0) x) (declare (type (unsigned-byte 24) b)) ;; (bs/ensure-n-bits 24) @@ -246,7 +246,7 @@ `((lambda (huffman-tree n) (declare (type (integer 0 1000) n)) (let ((res (make-array n :initial-element 0))) - (declare (type (simple-array T (*)) res)) + (declare (type (simple-array t (*)) res)) (do ((i 0 i)) ((>= i n)) (declare (type (integer 0 1000) i)) @@ -507,7 +507,7 @@ n-hclen (+ 4 (bs/read-byte 4)) hclens (make-array 19 :initial-element 0)) (locally - (declare (type (simple-array T (*)) hclens) + (declare (type (simple-array t (*)) hclens) (type (unsigned-byte 6) n-hdist) (type (unsigned-byte 5) n-hclen)) (loop diff --git a/Lisp-Dep/fix-acl.lisp b/Lisp-Dep/fix-acl.lisp index 5d2466b..f0b99d9 100644 --- a/Lisp-Dep/fix-acl.lisp +++ b/Lisp-Dep/fix-acl.lisp @@ -11,107 +11,107 @@ (defpackage :clim-mop (:use :clos :common-lisp) - (:export "ACCESSOR-METHOD-SLOT-DEFINITION" - "ADD-DEPENDENT" - "ADD-DIRECT-METHOD" - "ADD-DIRECT-SUBCLASS" - "ADD-METHOD" - "ALLOCATE-INSTANCE" - "BUILT-IN-CLASS" - "CLASS" - "CLASS-DEFAULT-INITARGS" - "CLASS-DIRECT-DEFAULT-INITARGS" - "CLASS-DIRECT-SLOTS" - "CLASS-DIRECT-SUBCLASSES" - "CLASS-DIRECT-SUPERCLASSES" - "CLASS-FINALIZED-P" - "CLASS-NAME" - "CLASS-PRECEDENCE-LIST" - "CLASS-PROTOTYPE" - "CLASS-SLOTS" - "COMPUTE-APPLICABLE-METHODS" - "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" - "COMPUTE-CLASS-PRECEDENCE-LIST" - "COMPUTE-DEFAULT-INITARGS" - "COMPUTE-DISCRIMINATING-FUNCTION" - "COMPUTE-EFFECTIVE-METHOD" - "COMPUTE-EFFECTIVE-SLOT-DEFINITION" - "COMPUTE-SLOTS" - "DIRECT-SLOT-DEFINITION" - "DIRECT-SLOT-DEFINITION-CLASS" - "EFFECTIVE-SLOT-DEFINITION" - "EFFECTIVE-SLOT-DEFINITION-CLASS" - "ENSURE-CLASS" - "ENSURE-CLASS-USING-CLASS" - "ENSURE-GENERIC-FUNCTION" - "ENSURE-GENERIC-FUNCTION-USING-CLASS" - "EQL-SPECIALIZER" - "EQL-SPECIALIZER-OBJECT" - "EXTRACT-LAMBDA-LIST" - "EXTRACT-SPECIALIZER-NAMES" - "FINALIZE-INHERITANCE" - "FIND-METHOD-COMBINATION" - "FORWARD-REFERENCED-CLASS" - "FUNCALLABLE-STANDARD-CLASS" - "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" - "FUNCALLABLE-STANDARD-OBJECT" - "FUNCTION" - "GENERIC-FUNCTION" - "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" - "GENERIC-FUNCTION-DECLARATIONS" - "GENERIC-FUNCTION-LAMBDA-LIST" - "GENERIC-FUNCTION-METHOD-CLASS" - "GENERIC-FUNCTION-METHOD-COMBINATION" - "GENERIC-FUNCTION-METHODS" - "GENERIC-FUNCTION-NAME" - "INTERN-EQL-SPECIALIZER" - "MAKE-INSTANCE" - "MAKE-METHOD-LAMBDA" - "MAP-DEPENDENTS" - "METAOBJECT" - "METHOD" - "METHOD-COMBINATION" - "METHOD-FUNCTION" - "METHOD-GENERIC-FUNCTION" - "METHOD-LAMBDA-LIST" - "METHOD-QUALIFIERS" - "METHOD-SPECIALIZERS" - "READER-METHOD-CLASS" - "REMOVE-DEPENDENT" - "REMOVE-DIRECT-METHOD" - "REMOVE-DIRECT-SUBCLASS" - "REMOVE-METHOD" - "SET-FUNCALLABLE-INSTANCE-FUNCTION" - "SLOT-BOUNDP-USING-CLASS" - "SLOT-DEFINITION" - "SLOT-DEFINITION-ALLOCATION" - "SLOT-DEFINITION-INITARGS" - "SLOT-DEFINITION-INITFORM" - "SLOT-DEFINITION-INITFUNCTION" - "SLOT-DEFINITION-LOCATION" - "SLOT-DEFINITION-NAME" - "SLOT-DEFINITION-READERS" - "SLOT-DEFINITION-TYPE" - "SLOT-DEFINITION-WRITERS" - "SLOT-MAKUNBOUND-USING-CLASS" - "SLOT-VALUE-USING-CLASS" - "SPECIALIZER" - "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" - "SPECIALIZER-DIRECT-METHODS" - "STANDARD-ACCESSOR-METHOD" - "STANDARD-CLASS" - "STANDARD-DIRECT-SLOT-DEFINITION" - "STANDARD-EFFECTIVE-SLOT-DEFINITION" - "STANDARD-GENERIC-FUNCTION" - "STANDARD-INSTANCE-ACCESS" - "STANDARD-METHOD" - "STANDARD-OBJECT" - "STANDARD-READER-METHOD" - "STANDARD-SLOT-DEFINITION" - "STANDARD-WRITER-METHOD" - "UPDATE-DEPENDENT" - "VALIDATE-SUPERCLASS" - "WRITER-METHOD-CLASS")) + (:export #:accessor-method-slot-definition + #:add-dependent + #:add-direct-method + #:add-direct-subclass + #:add-method + #:allocate-instance + #:built-in-class + #:class + #:class-default-initargs + #:class-direct-default-initargs + #:class-direct-slots + #:class-direct-subclasses + #:class-direct-superclasses + #:class-finalized-p + #:class-name + #:class-precedence-list + #:class-prototype + #:class-slots + #:compute-applicable-methods + #:compute-applicable-methods-using-classes + #:compute-class-precedence-list + #:compute-default-initargs + #:compute-discriminating-function + #:compute-effective-method + #:compute-effective-slot-definition + #:compute-slots + #:direct-slot-definition + #:direct-slot-definition-class + #:effective-slot-definition + #:effective-slot-definition-class + #:ensure-class + #:ensure-class-using-class + #:ensure-generic-function + #:ensure-generic-function-using-class + #:eql-specializer + #:eql-specializer-object + #:extract-lambda-list + #:extract-specializer-names + #:finalize-inheritance + #:find-method-combination + #:forward-referenced-class + #:funcallable-standard-class + #:funcallable-standard-instance-access + #:funcallable-standard-object + #:function + #:generic-function + #:generic-function-argument-precedence-order + #:generic-function-declarations + #:generic-function-lambda-list + #:generic-function-method-class + #:generic-function-method-combination + #:generic-function-methods + #:generic-function-name + #:intern-eql-specializer + #:make-instance + #:make-method-lambda + #:map-dependents + #:metaobject + #:method + #:method-combination + #:method-function + #:method-generic-function + #:method-lambda-list + #:method-qualifiers + #:method-specializers + #:reader-method-class + #:remove-dependent + #:remove-direct-method + #:remove-direct-subclass + #:remove-method + #:set-funcallable-instance-function + #:slot-boundp-using-class + #:slot-definition + #:slot-definition-allocation + #:slot-definition-initargs + #:slot-definition-initform + #:slot-definition-initfunction + #:slot-definition-location + #:slot-definition-name + #:slot-definition-readers + #:slot-definition-type + #:slot-definition-writers + #:slot-makunbound-using-class + #:slot-value-using-class + #:specializer + #:specializer-direct-generic-functions + #:specializer-direct-methods + #:standard-accessor-method + #:standard-class + #:standard-direct-slot-definition + #:standard-effective-slot-definition + #:standard-generic-function + #:standard-instance-access + #:standard-method + #:standard-object + #:standard-reader-method + #:standard-slot-definition + #:standard-writer-method + #:update-dependent + #:validate-superclass + #:writer-method-class)) ;;;(eval-when (:compile-toplevel :load-toplevel :execute) ;;; (do-external-symbols (sym :clos) @@ -165,3 +165,6 @@ .args.)))))) (t `(defun ,fun ,args ,@body)))) ) + + + diff --git a/Lisp-Dep/mp-acl.lisp b/Lisp-Dep/mp-acl.lisp index a9c4703..e1340a4 100644 --- a/Lisp-Dep/mp-acl.lisp +++ b/Lisp-Dep/mp-acl.lisp @@ -23,7 +23,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -(in-package :CLIM-INTERNALS) +(in-package :clim-internals) (defconstant *multiprocessing-p* t) diff --git a/Looks/pixie.lisp b/Looks/pixie.lisp index 573685d..ba0100b 100644 --- a/Looks/pixie.lisp +++ b/Looks/pixie.lisp @@ -1,4 +1,4 @@ -(in-package :CLIM-INTERNALS) +(in-package :clim-internals) ;;; ; @@ -341,6 +341,7 @@ ; We derive from the slider, since the slider is the same, only ; less so. +;;; XXX Probably should derive from scroll-bar too. (defconstant +pixie-scroll-bar-pane-thumb-size+ 5000.0) (defconstant +pixie-scroll-bar-thumb-half-height+ 17) @@ -476,6 +477,14 @@ (yb (translate-range-value (+ v ts) minv (+ maxv ts) y1 y2))) (make-rectangle* x1 (- ya 1) x2 (+ yb 1))))))))) +(defmethod* (setf scroll-bar-values) + (min-value max-value thumb-size value (scroll-bar pixie-scroll-bar-pane)) + (setf (slot-value scroll-bar 'min-value) min-value + (slot-value scroll-bar 'max-value) max-value + (slot-value scroll-bar 'thumb-size) thumb-size + (slot-value scroll-bar 'value) value) + (dispatch-repaint scroll-bar (sheet-region scroll-bar))) + (defmethod handle-event ((pane pixie-scroll-bar-pane) (event pointer-button-release-event)) (with-slots (armed dragging repeating was-repeating) pane (setf was-repeating repeating) diff --git a/bordered-output.lisp b/bordered-output.lisp index e62bfcb..ce0262d 100644 --- a/bordered-output.lisp +++ b/bordered-output.lisp @@ -101,11 +101,11 @@ :filled nil) (draw-rectangle* stream right-edge (+ top-edge offset) - (+ right-edge offset) bottom-edge :filled T) + (+ right-edge offset) bottom-edge :filled t) (draw-rectangle* stream (+ left-edge offset) bottom-edge (+ right-edge offset) (+ bottom-edge offset) - :filled T))) + :filled t))) (define-border-type :underline (stream record) (labels ((fn (record) diff --git a/events.lisp b/events.lisp index c4ad970..8d5b04d 100644 --- a/events.lisp +++ b/events.lisp @@ -59,7 +59,11 @@ (defclass standard-event (event) ((timestamp :initarg :timestamp :initform nil - :reader event-timestamp))) + :reader event-timestamp) + ;; This slot is pretty much required in order to call handle-event. Some + ;; events have something other than a sheet in this slot, which is gross. + (sheet :initarg :sheet + :reader event-sheet))) (defmethod initialize-instance :after ((event standard-event) &rest initargs) (declare (ignore initargs)) @@ -79,11 +83,28 @@ ; (if (null position) ; :event ; (intern (subseq type 0 position) :keyword)))) - -(defclass device-event (standard-event) - ((sheet :initarg :sheet - :reader event-sheet) - (modifier-state :initarg :modifier-state +;;; Reintroduce something like that definition, with defmethod goodness. +;;; -- moore + +(defmacro define-event-class (name supers slots &rest options) + (let* ((event-tag (string '#:-event)) + (name-string (string name)) + (pos (search event-tag name-string :from-end t))) + (when (or (null pos) + (not (eql (+ pos (length event-tag)) (length name-string)))) + (error "~S does not end in ~A and is not a valid event name for ~ + define-event-class." + name event-tag)) + (let ((type (intern (subseq name-string 0 pos) :keyword))) + `(progn + (defclass ,name ,supers + ,slots + ,@options) + (defmethod event-type ((event ,name)) + ',type))))) + +(define-event-class device-event (standard-event) + ((modifier-state :initarg :modifier-state :reader event-modifier-state) (x :initarg :x :reader device-event-native-x) @@ -94,21 +115,19 @@ (graft-y :initarg :graft-y :reader device-event-native-graft-y))) -(defclass keyboard-event (device-event) +(define-event-class keyboard-event (device-event) ((key-name :initarg :key-name :reader keyboard-event-key-name) (key-character :initarg :key-character :reader keyboard-event-character :initform nil))) -(defclass key-press-event (keyboard-event) - ( - )) +(define-event-class key-press-event (keyboard-event) + ()) -(defclass key-release-event (keyboard-event) - ( - )) +(define-event-class key-release-event (keyboard-event) + ()) -(defclass pointer-event (device-event) +(define-event-class pointer-event (device-event) ((pointer :initarg :pointer :reader pointer-event-pointer) (button :initarg :button @@ -149,33 +168,28 @@ (defmethod device-event-y ((event device-event)) (get-pointer-position ((event-sheet event) event) y)) -(defclass pointer-button-event (pointer-event) - ( - )) +(define-event-class pointer-button-event (pointer-event) + ()) -(defclass pointer-button-press-event (pointer-button-event) ()) +(define-event-class pointer-button-press-event (pointer-button-event) ()) -(defclass pointer-button-release-event (pointer-button-event) ()) +(define-event-class pointer-button-release-event (pointer-button-event) ()) -(defclass pointer-button-hold-event (pointer-button-event) ()) +(define-event-class pointer-button-hold-event (pointer-button-event) ()) -(defclass pointer-button-click-event (pointer-button-event) - ( - )) +(define-event-class pointer-button-click-event (pointer-button-event) + ()) -(defclass pointer-button-double-click-event (pointer-button-event) - ( - )) +(define-event-class pointer-button-double-click-event (pointer-button-event) + ()) -(defclass pointer-button-click-and-hold-event (pointer-button-event) - ( - )) +(define-event-class pointer-button-click-and-hold-event (pointer-button-event) + ()) -(defclass pointer-motion-event (pointer-event) - ( - )) +(define-event-class pointer-motion-event (pointer-event) + ()) (defclass motion-hint-mixin () () @@ -185,28 +199,22 @@ (defclass pointer-motion-hint-event (pointer-motion-event motion-hint-mixin) ()) -(defclass pointer-boundary-event (pointer-motion-event) - ( - )) +(define-event-class pointer-boundary-event (pointer-motion-event) + ()) -(defclass pointer-enter-event (pointer-boundary-event) - ( - )) +(define-event-class pointer-enter-event (pointer-boundary-event) + ()) -(defclass pointer-exit-event (pointer-boundary-event) - ( - )) +(define-event-class pointer-exit-event (pointer-boundary-event) + ()) -(defclass pointer-ungrab-event (pointer-exit-event) +(define-event-class pointer-ungrab-event (pointer-exit-event) ()) -(defclass window-event (standard-event) - ((sheet :initarg :sheet - :reader event-sheet) - (region :initarg :region - :reader window-event-native-region) - )) +(define-event-class window-event (standard-event) + ((region :initarg :region + :reader window-event-native-region))) (defmethod window-event-region ((event window-event)) (untransform-region (sheet-native-transformation (event-sheet event)) @@ -215,7 +223,7 @@ (defmethod window-event-mirrored-sheet ((event window-event)) (sheet-mirror (event-sheet event))) -(defclass window-configuration-event (window-event) +(define-event-class window-configuration-event (window-event) ((x :initarg :x :reader window-configuration-event-native-x) (y :initarg :y :reader window-configuration-event-native-y) (width :initarg :width :reader window-configuration-event-width) @@ -235,64 +243,27 @@ (defmethod window-configuration-event-y ((event window-configuration-event)) (get-window-position ((event-sheet event) event) y)) -(defclass window-unmap-event (window-event) +(define-event-class window-unmap-event (window-event) ()) -(defclass window-destroy-event (window-event) +(define-event-class window-destroy-event (window-event) ()) -(defclass window-repaint-event (window-event) - ( - )) +(define-event-class window-repaint-event (window-event) + ()) -(defclass window-manager-event (standard-event) ()) +(define-event-class window-manager-event (standard-event) ()) -(defclass window-manager-delete-event (window-manager-event) - ((sheet :initarg :sheet ; not required by the spec but we need - :reader event-sheet) ; to know which window to delete - mikemac - )) +(define-event-class window-manager-delete-event (window-manager-event) + ;; sheet (inherited from standard-event) is not required by the spec but we + ;; need to know which window to delete - mikemac + ()) -(defclass timer-event (standard-event) - ((sheet - :initarg :sheet - :reader event-sheet) - (token +(define-event-class timer-event (standard-event) + ((token :initarg :token :reader event-token))) -(defmethod event-instance-slots ((self event)) - '(timestamp)) - -(defmethod event-instance-slots ((self device-event)) - '(timestamp modifier-state sheet)) - -(defmethod event-instance-slots ((self keyboard-event)) - '(timestamp modifier-state sheet key-name)) - -(defmethod event-instance-slots ((self pointer-event)) - '(timestamp modifier-state sheet pointer button x y root-x root-y)) - -(defmethod event-instance-slots ((self window-event)) - '(timestamp region)) - -;(defmethod print-object ((self event) sink) -; (print-object-with-slots self (event-instance-slots self) sink)) - -;(defmethod translate-event ((self pointer-event) dx dy) -; (apply #'make-instance (class-of self) -; :x (+ dx (pointer-event-x self)) -; :y (+ dy (pointer-event-y self)) -; (fetch-slots-as-kwlist self (event-instance-slots self)))) - -;(defmethod translate-event ((self window-event) dx dy) -; (apply #'make-instance (class-of self) -; :region (translate-region (window-event-region self) dx dy) -; (fetch-slots-as-kwlist self (event-instance-slots self)))) - -;(defmethod translate-event ((self event) dx dy) -; (declare (ignore dx dy)) -; self) - ;;; Constants dealing with events (defconstant +pointer-left-button+ #x01) @@ -339,32 +310,6 @@ (check-modifier (,m) (not (zerop (logand ,m ,modifier-state))))) (and ,@(do-substitutes clauses)))))) -(defmethod event-type ((event device-event)) :device) -(defmethod event-type ((event keyboard-event)) :keyboard) -(defmethod event-type ((event key-press-event)) :key-press) -(defmethod event-type ((event key-release-event)) :key-release) -(defmethod event-type ((event pointer-event)) :pointer) -(defmethod event-type ((event pointer-button-event)) :pointer-button) -(defmethod event-type ((event pointer-button-press-event)) :pointer-button-press) -(defmethod event-type ((event pointer-button-release-event)) :pointer-button-release) -(defmethod event-type ((event pointer-button-hold-event)) :pointer-button-hold) -(defmethod event-type ((event pointer-motion-event)) :pointer-motion) -(defmethod event-type ((event pointer-boundary-event)) :pointer-boundary) -(defmethod event-type ((event pointer-enter-event)) :pointer-enter) -(defmethod event-type ((event pointer-exit-event)) :pointer-exit) -(defmethod event-type ((event window-event)) :window) -(defmethod event-type ((event window-configuration-event)) :window-configuration) -(defmethod event-type ((event window-repaint-event)) :window-repaint) -(defmethod event-type ((event window-manager-event)) :window-manager) -(defmethod event-type ((event window-manager-delete-event)) :window-manager-delete) -(defmethod event-type ((event timer-event)) :timer) - -;; keyboard-event-character keyboard-event -;; pointer-event-native-x pointer-event -;; pointer-event-native-y pointer-event -;; window-event-native-region window-event -;; window-event-mirrored-sheet window-event - ;; Key names are a symbol whose value is port-specific. Key names ;; corresponding to the set of standard characters (such as the ;; alphanumerics) will be a symbol in the keyword package. diff --git a/frames.lisp b/frames.lisp index d1b85ad..83db296 100644 --- a/frames.lisp +++ b/frames.lisp @@ -581,7 +581,7 @@ documentation produced by presentations."))) #+NIL (read-command (frame-command-table frame) :use-keystrokes nil :stream stream) (read-command (frame-command-table frame) :use-keystrokes t :stream stream)) -(defclass execute-command-event (window-manager-event) +(define-event-class execute-command-event (window-manager-event) ((sheet :initarg :sheet :reader event-sheet) (command :initarg :command :reader execute-command-event-command))) diff --git a/gadgets.lisp b/gadgets.lisp index 57acff1..ef14e5e 100644 --- a/gadgets.lisp +++ b/gadgets.lisp @@ -115,11 +115,14 @@ ;; - make NIL a valid label, and take it into account when applying ;; spacing. -;;;; ------------------------------------------------------------------------------------------ +;;;; -------------------------------------------------------------------------- ;;;; ;;;; 30.3 Basic Gadget Classes ;;;; +;;; XXX I'm not sure that *application-frame* should be rebound like this. What +;;; about gadgets in accepting-values windows? An accepting-values window +;;; shouldn't be bound to *application-frame*. -- moore (defun invoke-callback (pane callback &rest more-arguments) (when callback (let ((*application-frame* (pane-frame pane))) @@ -1421,6 +1424,14 @@ and must never be nil.")) (declare (ignore new-value invoke-callback)) (scroll-bar/update-display pane)) +(defmethod* (setf scroll-bar-values) + (min-value max-value thumb-size value (scroll-bar scroll-bar-pane)) + (setf (slot-value scroll-bar 'min-value) min-value + (slot-value scroll-bar 'max-value) max-value + (slot-value scroll-bar 'thumb-size) thumb-size + (slot-value scroll-bar 'value) value) + (scroll-bar/update-display scroll-bar)) + ;;;; geometry (defparameter +minimum-thumb-size-in-pixels+ 30) @@ -2818,3 +2829,31 @@ it in a layout between two panes that are to be resizeable. E.g.: (defmethod note-sheet-grafted ((sheet clim-extensions:box-adjuster-gadget)) (setf (sheet-pointer-cursor sheet) :rotate)) + +;;; Support for definition of callbacks and associated callback events. A +;;; callback event is used by a backend when a high-level notification of a +;;; gadget state change is delivered in the CLIM event process -- by a native +;;; gadget, for example -- and must be delivered in the application process. + +(define-event-class callback-event (standard-event) + ((sheet :initarg :gadget :reader event-gadget + :documentation "An alias for sheet, for readability") + (callback-function :initarg :callback-function :reader callback-function) + (client :initarg :client :reader event-client) + (client-id :initarg :client-id :reader event-client-id) + (other-args :initarg :other-args :reader event-other-args :initform nil))) + +(defun queue-callback (fn gadget client client-id &rest other-args) + (queue-event gadget (make-instance 'callback-event + :callback-function fn + :gadget gadget + :client client + :client-id client-id + :other-args other-args))) + +(defmethod handle-event ((gadget basic-gadget) (event callback-event)) + (apply (callback-function event) + (event-client event) + (event-client-id event) + (event-other-args event))) + diff --git a/graphics.lisp b/graphics.lisp index 8430bd6..e3441de 100644 --- a/graphics.lisp +++ b/graphics.lisp @@ -111,7 +111,7 @@ (if (null line-style) (setf line-style old-line-style)) (when (or line-unit line-thickness dashes-p line-joint-shape line-cap-shape) - (setf changed-line-style T) + (setf changed-line-style t) (setf line-style (make-line-style :unit (or line-unit (line-style-unit line-style)) @@ -130,7 +130,7 @@ (medium-merged-text-style medium))) (setf text-style (medium-merged-text-style medium))) (when (or text-family-p text-face-p text-size-p) - (setf changed-text-style T) + (setf changed-text-style t) (setf text-style (merge-text-styles (make-text-style text-family text-face text-size) diff --git a/mcclim.asd b/mcclim.asd index f0ee3be..8814838 100644 --- a/mcclim.asd +++ b/mcclim.asd @@ -51,10 +51,11 @@ ;;; Make CLX asdf-loadable on Allegro 6.2 ;;; possibly this should be further refined to funciton properly for ;;; Allegro on Windows platforms. [2005/04/18:rpg] + #+allegro (progn (defclass requireable-system (asdf:system) - ()) + ()) (defmethod asdf:perform ((op asdf:load-op) (system requireable-system)) (require (intern (slot-value system 'asdf::name) :keyword))) (defmethod asdf::traverse ((op asdf:load-op) (system requireable-system)) @@ -62,7 +63,6 @@ (defsystem :clx :class requireable-system)) - (defmacro clim-defsystem ((module &key depends-on) &rest components) `(progn (asdf:defsystem ,module diff --git a/menu-choose.lisp b/menu-choose.lisp index fa22740..7d1513f 100644 --- a/menu-choose.lisp +++ b/menu-choose.lisp @@ -43,7 +43,7 @@ ;;; + menu frame size ;;; + layout -(in-package :CLIM-INTERNALS) +(in-package :clim-internals) (defgeneric menu-choose (items diff --git a/panes.lisp b/panes.lisp index 68e70eb..94a4e5a 100644 --- a/panes.lisp +++ b/panes.lisp @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.168 2006/03/27 10:46:11 crhodes Exp $ +;;; $Id: panes.lisp,v 1.169 2006/03/29 10:43:37 tmoore Exp $ (in-package :clim-internals) @@ -1515,7 +1515,7 @@ order to produce a double-click") (space-requirement-major sr)))) srs))) #+nil - (format T "~&;; ~S: allot=~S, wanted=~S, excess=~S, qs=~S~%" + (format t "~&;; ~S: allot=~S, wanted=~S, excess=~S, qs=~S~%" 'allot-space-xically allot wanted excess qs) (let ((sum (reduce #'+ qs))) (cond ((zerop sum) @@ -1592,11 +1592,11 @@ order to produce a double-click") (- width xs)))) #+nil (progn - (format T "~&;; row space requirements = ~S." rsrs) - (format T "~&;; col space requirements = ~S." csrs) - (format T "~&;; row allotment: needed = ~S result = ~S (sum ~S)." height rows (reduce #'+ rows)) - (format T "~&;; col allotment: needed = ~S result = ~S (sum ~S)." width cols (reduce #'+ cols)) - (format T "~&;; align-x = ~S, align-y ~S~%" + (format t "~&;; row space requirements = ~S." rsrs) + (format t "~&;; col space requirements = ~S." csrs) + (format t "~&;; row allotment: needed = ~S result = ~S (sum ~S)." height rows (reduce #'+ rows)) + (format t "~&;; col allotment: needed = ~S result = ~S (sum ~S)." width cols (reduce #'+ cols)) + (format t "~&;; align-x = ~S, align-y ~S~%" (pane-align-x pane) (pane-align-y pane))) ;; now finally layout each child @@ -1882,7 +1882,7 @@ order to produce a double-click") ;; ;; One might argue that in case of no scroll-bars the ;; application programmer can just skip the scroller - ;; pane altogether. But I think that the then needed + ;; pane altogether. Bu I think that the then needed ;; special casing on having a scroller pane or a bare ;; viewport at hand is an extra burden, that can be ;; avoided. @@ -1899,6 +1899,12 @@ order to produce a double-click") :x-spacing 4 :y-spacing 4)) +(defgeneric scroll-bar-values (scroll-bar) + (:documentation "Returns the min value, max value, thumb size, and value of a + scroll bar. When Setf-ed, updates the scroll bar graphics")) + +(defgeneric* (setf scroll-bar-values) (min-value max-value thumb-size value scroll-bar)) + (defmacro scrolling ((&rest options) &body contents) `(let ((viewport (make-pane 'viewport-pane :contents (list ,@contents)))) (make-pane 'scroller-pane ,@options :contents (list viewport)))) @@ -1973,11 +1979,7 @@ order to produce a double-click") 0 (* (/ (gadget-value vscrollbar) (gadget-max-value vscrollbar)) max)))) - (setf (gadget-min-value vscrollbar) min - (gadget-max-value vscrollbar) max - (scroll-bar-thumb-size vscrollbar) ts - (gadget-value vscrollbar :invoke-callback nil) val))) - + (setf (scroll-bar-values vscrollbar) (values min max ts val)))) (when hscrollbar (let* ((scrollee (first (sheet-children viewport))) (min 0) @@ -1989,11 +1991,7 @@ order to produce a double-click") 0 (* (/ (gadget-value hscrollbar) (gadget-max-value hscrollbar)) max)))) - (setf (gadget-min-value hscrollbar) min - (gadget-max-value hscrollbar) max - (scroll-bar-thumb-size hscrollbar) ts - (gadget-value hscrollbar :invoke-callback nil) val))) - + (setf (scroll-bar-values hscrollbar) (values min max ts val)))) (when viewport (setf (sheet-transformation viewport) (make-translation-transformation @@ -2009,17 +2007,24 @@ order to produce a double-click") "Callback for the vertical scroll-bar of a scroller-pane." (with-slots (viewport hscrollbar vscrollbar) pane (let ((scrollee (first (sheet-children viewport)))) - (scroll-extent scrollee - (if hscrollbar (gadget-value hscrollbar) 0) - new-value)))) + (when (pane-viewport scrollee) + (move-sheet scrollee + (round (if hscrollbar + (- (gadget-value hscrollbar)) + 0)) + (round (- new-value))))))) (defmethod scroller-pane/horizontal-drag-callback ((pane scroller-pane) new-value) "Callback for the horizontal scroll-bar of a scroller-pane." (with-slots (viewport hscrollbar vscrollbar) pane (let ((scrollee (first (sheet-children viewport)))) - (scroll-extent scrollee - new-value - (if vscrollbar (gadget-value vscrollbar) 0))))) + (when (pane-viewport scrollee) + (move-sheet scrollee + (round (- new-value)) + (round (if vscrollbar + (- (gadget-value vscrollbar)) + 0))))))) + (defmethod scroller-pane/update-scroll-bars ((pane scroller-pane)) (with-slots (viewport hscrollbar vscrollbar) pane @@ -2028,24 +2033,27 @@ order to produce a double-click") (viewport-sr (sheet-region viewport))) ;; (when hscrollbar - (setf (gadget-min-value hscrollbar) (bounding-rectangle-min-x scrollee-sr) - (gadget-max-value hscrollbar) (max (- (bounding-rectangle-max-x scrollee-sr) - (bounding-rectangle-width viewport-sr)) - (bounding-rectangle-min-x scrollee-sr)) - (scroll-bar-thumb-size hscrollbar) (bounding-rectangle-width viewport-sr) - (gadget-value hscrollbar :invoke-callback nil) - (- (nth-value 0 (transform-position (sheet-transformation scrollee) 0 0))) - )) + (setf (scroll-bar-values hscrollbar) + (values (bounding-rectangle-min-x scrollee-sr) + (max (- (bounding-rectangle-max-x scrollee-sr) + (bounding-rectangle-width viewport-sr)) + (bounding-rectangle-min-x scrollee-sr)) + (bounding-rectangle-width viewport-sr) + (- (nth-value 0 (transform-position + (sheet-transformation scrollee) 0 0)))))) ;; (when vscrollbar - (setf (gadget-min-value vscrollbar) (bounding-rectangle-min-y scrollee-sr) - (gadget-max-value vscrollbar) (max (- (bounding-rectangle-max-y scrollee-sr) - (bounding-rectangle-height viewport-sr)) - (bounding-rectangle-min-y scrollee-sr)) - (scroll-bar-thumb-size vscrollbar) (bounding-rectangle-height viewport-sr) - (gadget-value vscrollbar :invoke-callback nil) - (- (nth-value 1 (transform-position (sheet-transformation scrollee) 0 0))) - ))))) + (setf (scroll-bar-values vscrollbar) + (values (bounding-rectangle-min-y scrollee-sr) + (max (- (bounding-rectangle-max-y scrollee-sr) + (bounding-rectangle-height viewport-sr)) + (bounding-rectangle-min-y scrollee-sr)) + (bounding-rectangle-height viewport-sr) + (- (nth-value 1 (transform-position + (sheet-transformation scrollee) + 0 + 0))))))))) + (defmethod initialize-instance :after ((pane scroller-pane) &key contents &allow-other-keys) (sheet-adopt-child pane (first contents)) diff --git a/protocol-classes.lisp b/protocol-classes.lisp index 831a0cd..daed114 100644 --- a/protocol-classes.lisp +++ b/protocol-classes.lisp @@ -22,10 +22,15 @@ (in-package :clim-internals) (defmacro define-protocol-class (name super-classes &optional slots &rest options) - (let ((protocol-predicate - (intern (concatenate 'string (symbol-name name) (if (find #\- (symbol-name name)) "-" "") "P"))) - (predicate-docstring - (concatenate 'string "Protocol predicate checking for class " (symbol-name name)))) + (let* ((sym-name (symbol-name name)) + (protocol-predicate + (intern (concatenate 'string + sym-name + (if (find #\- sym-name) "-" "") + (symbol-name '#:p)))) + (predicate-docstring + (concatenate 'string + "Protocol predicate checking for class " sym-name))) `(progn (defclass ,name ,super-classes ,slots ,@options) diff --git a/recording.lisp b/recording.lisp index ecce467..5b8db57 100644 --- a/recording.lisp +++ b/recording.lisp @@ -844,7 +844,7 @@ the associated sheet can be determined." (>= cx2 old-max-x) (>= cy2 old-max-y)) (values (min cx1 ox1) (min cy1 oy1) (max cx2 ox2) (max cy2 oy2))) - (T (%tree-recompute-extent* record))) + (t (%tree-recompute-extent* record))) ;; XXX banish x, y (with-slots (x y) record @@ -2337,7 +2337,7 @@ according to the flags RECORD and DRAW." (bounding-rectangle region)))) (with-bounding-rectangle* (x1 y1 x2 y2) region (with-output-recording-options (stream :record nil) - (draw-rectangle* stream x1 y1 x2 y2 :filled T :ink +background-ink+))) + (draw-rectangle* stream x1 y1 x2 y2 :filled t :ink +background-ink+))) (stream-replay stream region))))) (defmethod handle-repaint ((stream output-recording-stream) region) diff --git a/stream-output.lisp b/stream-output.lisp index b9e3589..dd670ce 100644 --- a/stream-output.lisp +++ b/stream-output.lisp @@ -107,8 +107,8 @@ (defun decode-cursor-visibility (visibility) "Given :on, :off, or nil, returns the needed active and state attributes for the cursor." (ecase visibility - ((:on T) (values T T)) - (:off (values T nil)) + ((:on t) (values t t)) + (:off (values t nil)) ((nil) (values nil nil)))) (defmethod cursor-visibility ((cursor cursor-mixin)) @@ -116,7 +116,7 @@ (s (cursor-state cursor))) (cond ((and a s) :on) ((and a (not s)) :off) - (T nil)))) + (t nil)))) (defmethod (setf cursor-visibility) (nv (cursor cursor-mixin)) (multiple-value-bind (active state) diff --git a/text-formatting.lisp b/text-formatting.lisp index 5f2320e..2d373bb 100644 --- a/text-formatting.lisp +++ b/text-formatting.lisp @@ -143,8 +143,8 @@ SUPPRESS-SPACE-AFTER-CONJUNCTION are non-standard." (setq seg-start (1+ i)))) (foo seg-start end))))) -(defmacro indenting-output ((stream indent &key (move-cursor T)) &body body) - (when (eq stream T) +(defmacro indenting-output ((stream indent &key (move-cursor t)) &body body) + (when (eq stream t) (setq stream '*standard-output*)) (with-gensyms (old-x old-y) `(multiple-value-bind (,old-x ,old-y)