Skip to content
Browse files

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.
  • Loading branch information...
1 parent 473035a commit 165956b92d13f7b5edf72ad185f55cf63ebc2f82 Timothy Moore committed Mar 29, 2006
View
148 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
View
30 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,15 +469,15 @@
*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 ()
(let ((search-path (cons (merge-pathnames #P".mailcap" (user-homedir-pathname))
*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!~%"))))))))
View
4 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)
View
26 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.
View
20 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,15 +451,15 @@ 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
;; used as arguments to make program wrappers feel more "lispy".
(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))
View
2 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
View
2 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)))
View
2 Backends/PostScript/class.lisp
@@ -32,7 +32,7 @@
;;;
;;;--GB
-(in-package :CLIM-POSTSCRIPT)
+(in-package :clim-postscript)
;;;; Medium
View
2 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
View
2 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)
View
2 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)
View
29 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))
View
2 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)
View
26 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
View
6 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)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
View
2 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)
View
2 Examples/demodemo.lisp
@@ -211,4 +211,4 @@
-(format T "~&;; try (CLIM-DEMO::DEMODEMO)~%")
+(format t "~&;; try (CLIM-DEMO::DEMODEMO)~%")
View
2 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)
View
6 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
View
205 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)))) )
+
+
+
View
2 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)
View
11 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)
View
4 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)
View
191 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.
View
2 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)))
View
41 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)))
+
View
4 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)
View
4 mcclim.asd
@@ -51,18 +51,18 @@
;;; 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))
(list (cons op system)))
(defsystem :clx
:class requireable-system))
-
(defmacro clim-defsystem ((module &key depends-on) &rest components)
`(progn
(asdf:defsystem ,module
View
2 menu-choose.lisp
@@ -43,7 +43,7 @@
;;; + menu frame size
;;; + layout
-(in-package :CLIM-INTERNALS)
+(in-package :clim-internals)
(defgeneric menu-choose
(items
View
88 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))
View
13 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)
View
4 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)
View
6 stream-output.lisp
@@ -107,16 +107,16 @@
(defun decode-cursor-visibility (visibility)
"Given :on, :off, or nil, returns the needed active and state attributes for the cursor."
(ecase visibility
<