Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv21959
Modified Files:
commands.lisp decls.lisp dialog-views.lisp gadgets.lisp
medium.lisp output.lisp recording.lisp utils.lisp
Log Message:
- added more DEFGENERICs
- fiddled with a few IGNORE declarations
- with CMUCL, macros no longer attempt to declare special variables
IGNORABLE
Date: Thu Dec 1 12:10:55 2005
Author: gbaumann
Index: mcclim/commands.lisp
diff -u mcclim/commands.lisp:1.55 mcclim/commands.lisp:1.56
--- mcclim/commands.lisp:1.55 Fri Sep 30 18:01:30 2005
+++ mcclim/commands.lisp Thu Dec 1 12:10:54 2005
@@ -811,7 +811,7 @@
into key-clauses
finally (setq key-case-clauses key-clauses))
`(defun ,name (,command ,stream)
- (declare (ignorable ,stream))
+ ,(declare-ignorable-form* stream)
(let* ((,seperator #\Space) (,command-args (cdr ,command))
,@required-arg-bindings)
(declare (ignorable ,seperator ,command-args
Index: mcclim/decls.lisp
diff -u mcclim/decls.lisp:1.32 mcclim/decls.lisp:1.33
--- mcclim/decls.lisp:1.32 Fri Feb 11 10:10:36 2005
+++ mcclim/decls.lisp Thu Dec 1 12:10:54 2005
@@ -24,10 +24,6 @@
(in-package :clim-internals)
-;;;; Early special variables
-
-(defvar *application-frame* nil)
-
;;; This is just an ad hoc list. Would it be a good idea to include all
;;; (exported) generic functions here? --GB
;;;
@@ -35,6 +31,57 @@
;;; We'll get right on it :) -- moore
;;; Whose numbers are we using here?
+;;; The numbers are section numbers from the spec. --GB
+
+;; Since the declaim form for functions looks clumsy and is
+;; syntax-wise different from defun, we define us a new declfun, which
+;; fixes this.
+
+(defmacro declfun (name lambda-list)
+ `(declaim (ftype (function
+ ,(let ((q lambda-list)
+ res)
+ (do () ((or (null q)
+ (member (car q) '(&optional &rest &key))))
+ (push 't res)
+ (pop q))
+ (when (eq (car q) '&optional)
+ (push '&optional res)
+ (pop q)
+ (do () ((or (null q)
+ (member (car q) '(&rest &key))))
+ (pop q)
+ (push 't res)))
+ (when (eq (car q) '&rest)
+ (push '&rest res)
+ (pop q)
+ (push 't res)
+ (pop q))
+ (when (eq (car q) '&key)
+ (push '&key res)
+ (pop q)
+ (do () ((or (null q)
+ (member (car q) '(&allow-other-keys))))
+ (push (list (intern (string (if (consp (car q))
+ (if (consp (caar q))
+ (caaar q)
+ (caar q))
+ (car q)))
+ :keyword)
+ 't)
+ res)
+ (pop q)))
+ (when (eq (car q) '&allow-other-keys)
+ (push '&allow-other-keys res)
+ (pop q))
+ (reverse res))
+ t)
+ ,name)))
+
+;;;; Early special variables
+
+(defvar *application-frame* nil)
+
;;; 3.2.1
(defgeneric point-x (point))
(defgeneric point-y (point))
@@ -55,6 +102,56 @@
(defgeneric transform-region (transformation region))
+;;; 5.3.2 Composition of Transformations
+
+(defgeneric compose-transformations (transformation1 transformation2))
+(defgeneric invert-transformation (transformation))
+(declfun compose-translation-with-transformation (transformation dx dy))
+(declfun compose-scaling-with-transformation (transformation sx sy &optional origin))
+(declfun compose-rotation-with-transformation (transformation angle &optional origin))
+(declfun compose-transformation-with-translation (transformation dx dy))
+(declfun compose-transformation-with-scaling (transformation sx sy &optional origin))
+(declfun compose-transformation-with-rotation (transformation angle &optional origin))
+
+;;; 5.3.3 Applying Transformations
+
+(defgeneric transform-region (transformation region))
+(defgeneric untransform-region (transformation region))
+(defgeneric transform-position (transformation x y))
+(defgeneric untransform-position (transformation x y))
+(defgeneric transform-distance (transformation dx dy))
+(defgeneric untransform-distance (transformation dx dy))
+(defgeneric transform-rectangle* (transformation x1 y1 x2 y2))
+(defgeneric untransform-rectangle* (transformation x1 y1 x2 y2))
+
+;;; 7.3.1 Sheet Geometry Functions [complete]
+
+(defgeneric sheet-transformation (sheet))
+(defgeneric (setf sheet-transformation) (transformation sheet))
+(defgeneric sheet-region (sheet))
+(defgeneric (setf sheet-region) (region sheet))
+(defgeneric move-sheet (sheet x y))
+(defgeneric resize-sheet (sheet width height))
+(defgeneric move-and-resize-sheet (sheet x y width height))
+(defgeneric map-sheet-position-to-parent (sheet x y))
+(defgeneric map-sheet-position-to-child (sheet x y))
+(defgeneric map-sheet-rectangle*-to-parent (sheet x1 y1 x2 y2))
+(defgeneric map-sheet-rectangle*-to-child (sheet x1 y1 x2 y2))
+(defgeneric map-over-sheets-containing-position (function sheet x y))
+(defgeneric map-over-sheets-overlapping-region (function sheet region))
+(defgeneric child-containing-position (sheet x y))
+(defgeneric children-overlapping-region (sheet region))
+(defgeneric children-overlapping-rectangle* (sheet x1 y1 x2 y2))
+(defgeneric sheet-delta-transformation (sheet ancestor))
+(defgeneric sheet-allocated-region (sheet child))
+
+;;; 7.3.2
+
+;; sheet-identity-transformation-mixin [class]
+;; sheet-translation-mixin [class]
+;; sheet-y-inverting-transformation-mixin [class]
+;; sheet-transformation-mixin [class]
+
;;;; 8.1
(defgeneric process-next-event (port &key wait-function timeout))
@@ -70,7 +167,7 @@
(defgeneric medium-drawable (medium))
(defgeneric port (medium))
-;;;; 8.3.4.1 Grafting and Degrafting of Mediums
+;;; 8.3.4.1 Grafting and Degrafting of Mediums
(defgeneric allocate-medium (port sheet))
(defgeneric deallocate-medium (port medium))
@@ -78,17 +175,34 @@
(defgeneric engraft-medium (medium port sheet))
(defgeneric degraft-medium (medium port sheet))
-;; 8.4.1 Repaint Protocol Functions
+;;; 8.4.1 Repaint Protocol Functions
(defgeneric queue-repaint (sheet repaint-event))
(defgeneric handle-repaint (sheet region))
(defgeneric repaint-sheet (sheet region))
-;; 9 Ports, Grafts, and Mirrored Sheets
+;;;; 9 Ports, Grafts, and Mirrored Sheets
;; (defgeneric portp (object))
;; find-port function
+;;; 9.3 Grafts
+
+(defgeneric sheet-grafted-p (sheet))
+(declfun find-graft (&key (server-path *default-server-path*)
+ (port (find-port :server-path server-path))
+ (orientation :default)
+ (units :device)))
+(defgeneric graft (object))
+(declfun map-over-grafts (function port))
+;; with-graft-locked (graft) &body body [macro]
+(defgeneric graft-orientation (graft))
+(defgeneric graft-units (graft))
+(defgeneric graft-width (graft &key units))
+(defgeneric graft-height (graft &key units))
+(declfun graft-pixels-per-millimeter (graft))
+(declfun graft-pixels-per-inch (graft))
+
;; 9.4.1 Mirror Functions
(defgeneric sheet-direct-mirror (sheet))
@@ -144,6 +258,73 @@
line-unit line-dashes line-joint-shape line-cap-shape text-style
text-family text-face text-size))
+;;; 15.3 The Text Cursor [complete]
+
+;;; 15.3.1 Text Cursor Protocol [complete]
+
+;; cursor [protocol class]
+;; cursorp object [protocol predicate]
+;; :sheet [Initarg for cursor]
+;; standard-text-cursor [class]
+(defgeneric cursor-sheet (cursor))
+(defgeneric cursor-position (cursor))
+;;(defgeneric (setf* cursor-position) (x y cursor))
+(defgeneric cursor-active (cursor))
+(defgeneric (setf cursor-active) (value cursor))
+(defgeneric cursor-state (cursor))
+(defgeneric (setf cursor-state) (value cursor))
+(defgeneric cursor-focus (cursor))
+(defgeneric cursor-visibility (cursor))
+(defgeneric (setf cursor-visibility) (visibility cursor))
+
+;;; 15.3.2 Stream Text Cursor Protocol [complete]
+
+(defgeneric stream-text-cursor (stream))
+(defgeneric (setf stream-text-cursor) (cursor stream))
+(defgeneric stream-cursor-position (stream))
+;; (defgeneric (setf* stream-cursor-position) (x y stream)) unsure how to declare this, can somebody help? --GB
+(defgeneric stream-increment-cursor-position (stream dx dy))
+
+;;; 15.4 Text Protocol [complete]
+
+(defgeneric stream-character-width (stream character &key text-style))
+(defgeneric stream-string-width (stream character &key start end text-style))
+(defgeneric stream-text-margin (stream))
+(defgeneric (setf stream-text-margin) (margin stream))
+(defgeneric stream-line-height (stream &key text-style))
+(defgeneric stream-vertical-spacing (stream))
+(defgeneric stream-baseline (stream))
+
+;;; 15.4.1 Mixing Text and Graphics [complete]
+
+;; with-room-for-graphics (&optional stream &key (first-quadrant t) height (move-cursor t) record-type) &body body [Macro]
+
+;;; 15.4.2 Wrapping of Text Lines [complete]
+
+(defgeneric stream-end-of-line-action (stream))
+(defgeneric (setf stream-end-of-line-action) (action stream))
+;; with-end-of-line-action (stream action) &body body [Macro]
+(defgeneric stream-end-of-page-action (stream))
+(defgeneric (setf stream-end-of-page-action) (action stream))
+;; with-end-of-page-action (stream action) &body body [Macro]
+
+;;; 16.4.3 Text Output Recording [complete]
+
+(defgeneric stream-text-output-record (stream text-style))
+(defgeneric stream-close-text-output-record (stream))
+(defgeneric stream-add-character-output (stream character text-style width height baseline))
+(defgeneric stream-add-string-output (stream string start end text-style width height baseline))
+
+;;; 16.4.4 Output Recording Utilities [complete]
+
+;; with-output-recording-options (stream &key record draw) &body body [Macro]
+(defgeneric invoke-with-output-recording-options (stream continuation record draw))
+;; with-new-output-record (stream &optional record-type record &rest initargs) &body body [MAcro]
+(defgeneric invoke-with-new-output-record (stream continuation record-type &rest initargs &key parent &allow-other-keys))
+;; with-output-to-output-record (stream &optional record-type record &rest initargs)) &body body [Macro]
+(defgeneric invoke-with-output-to-output-record (stream continuation record-type &rest initargs &key))
+(defgeneric make-design-from-output-record (record))
+
;;;; 21.2
(defgeneric invoke-updating-output
(stream continuation record-type unique-id id-test cache-value cache-test
@@ -289,50 +470,6 @@
;; fall back, where to put this?
(defmethod text-style-character-width (text-style medium char)
(text-size medium char :text-style text-style))
-
-;; Since the declaim form for functions looks clumsy and is
-;; syntax-wise different from defun, we define us a new declfun, which
-;; fixes this.
-
-(defmacro declfun (name lambda-list)
- `(declaim (ftype (function
- ,(let ((q lambda-list)
- res)
- (do () ((or (null q)
- (member (car q) '(&optional &rest &key))))
- (push 't res)
- (pop q))
- (when (eq (car q) '&optional)
- (push '&optional res)
- (pop q)
- (do () ((or (null q)
- (member (car q) '(&rest &key))))
- (push 't res)))
- (when (eq (car q) '&rest)
- (push '&rest res)
- (pop q)
- (push 't res)
- (pop q))
- (when (eq (car q) '&key)
- (push '&key res)
- (pop q)
- (do () ((or (null q)
- (member (car q) '(&allow-other-keys))))
- (push (list (intern (string (if (consp (car q))
- (if (consp (caar q))
- (caaar q)
- (caar q))
- (car q)))
- :keyword)
- 't)
- res)
- (pop q)))
- (when (eq (car q) '&allow-other-keys)
- (push '&allow-other-keys res)
- (pop q))
- (reverse res))
- t)
- ,name)))
(declfun draw-rectangle (sheet point1 point2
&rest args
Index: mcclim/dialog-views.lisp
diff -u mcclim/dialog-views.lisp:1.1 mcclim/dialog-views.lisp:1.2
--- mcclim/dialog-views.lisp:1.1 Tue Jan 18 11:58:08 2005
+++ mcclim/dialog-views.lisp Thu Dec 1 12:10:54 2005
@@ -78,6 +78,6 @@
nil)
(defmethod finalize-query-record (query (record av-pop-up-menu-record))
- (declare (ignore stream query))
+ (declare (ignore query))
nil)
Index: mcclim/gadgets.lisp
diff -u mcclim/gadgets.lisp:1.93 mcclim/gadgets.lisp:1.94
--- mcclim/gadgets.lisp:1.93 Tue Nov 29 14:04:16 2005
+++ mcclim/gadgets.lisp Thu Dec 1 12:10:55 2005
@@ -1140,6 +1140,13 @@
(draw-label* pane x1 y1 x2 y2 :ink (effective-gadget-foreground pane))
(draw-engraved-label* pane x1 y1 x2 y2))))))
+(defmethod deactivate-gadget :after ((gadget push-button-pane))
+ (dispatch-repaint gadget +everywhere+))
+
+(defmethod activate-gadget :after ((gadget push-button-pane))
+ (dispatch-repaint gadget +everywhere+))
+
+
;;; ------------------------------------------------------------------------------------------
;;; 30.4.2 The concrete toggle-button Gadget
@@ -1533,7 +1540,9 @@
(defmethod scroll-bar-thumb-region ((sb scroll-bar-pane))
(with-bounding-rectangle* (x1 y1 x2 y2) (scroll-bar-thumb-bed-region sb)
+ (declare (ignore y1 y2))
(multiple-value-bind (y1 y2 y3) (scroll-bar/thumb-bed* sb)
+ (declare (ignore y1))
(let ((y4 (scroll-bar/map-value-to-coordinate sb (gadget-value sb))))
(make-rectangle* x1 y4 x2 (+ y4 (- y3 y2)))))))
@@ -2246,7 +2255,8 @@
(defun generic-option-pane-compute-label (pane)
(generic-option-pane-compute-label-from-value pane (gadget-value pane)))
-(defmethod initialize-instance :after ((object generic-option-pane) &rest rest)
+(defmethod initialize-instance :after ((object generic-option-pane) &rest rest)
+ (declare (ignore rest))
(setf (slot-value object 'current-label)
(if (slot-boundp object 'value)
(generic-option-pane-compute-label object)
Index: mcclim/medium.lisp
diff -u mcclim/medium.lisp:1.55 mcclim/medium.lisp:1.56
--- mcclim/medium.lisp:1.55 Tue Sep 20 22:35:59 2005
+++ mcclim/medium.lisp Thu Dec 1 12:10:55 2005
@@ -334,7 +334,7 @@
(check-type medium symbol)
(with-gensyms (cont)
`(flet ((,cont (,medium)
- (declare (ignorable ,medium))
+ ,(declare-ignorable-form* medium)
,@body))
(declare (dynamic-extent #',cont))
(invoke-with-text-style ,medium #',cont
@@ -363,7 +363,7 @@
(setq medium '*standard-output*))
(with-gensyms (cont)
`(flet ((,cont (,medium)
- (declare (ignorable ,medium))
+ ,(declare-ignorable-form* medium)
,@body))
(declare (dynamic-extent #',cont))
(invoke-with-text-style ,medium #',cont
@@ -375,7 +375,7 @@
(setq medium '*standard-output*))
(with-gensyms (cont)
`(flet ((,cont (,medium)
- (declare (ignorable ,medium))
+ ,(declare-ignorable-form* medium)
,@body))
(declare (dynamic-extent #',cont))
(invoke-with-text-style ,medium #',cont
@@ -386,7 +386,7 @@
(when (eq medium t) (setq medium '*standard-output*))
(with-gensyms (cont)
`(flet ((,cont (,medium)
- (declare (ignorable ,medium))
+ ,(declare-ignorable-form* medium)
,@body))
(declare (dynamic-extent #',cont))
(invoke-with-text-style ,medium #',cont
@@ -398,7 +398,7 @@
(when (eq medium t) (setq medium '*standard-output*))
(with-gensyms (cont)
`(flet ((,cont (,medium)
- (declare (ignorable ,medium))
+ ,(declare-ignorable-form* medium)
,@body))
(declare (dynamic-extent #',cont))
(invoke-with-text-style ,medium #',cont
@@ -828,7 +828,7 @@
"Macro for optimizing drawing with graphical system dependant mechanisms."
(with-gensyms (fn)
`(flet ((,fn (,medium)
- (declare (ignorable ,medium))
+ ,(declare-ignorable-form* medium)
,@body))
(declare (dynamic-extent #',fn))
(invoke-with-special-choices #',fn ,medium))))
Index: mcclim/output.lisp
diff -u mcclim/output.lisp:1.10 mcclim/output.lisp:1.11
--- mcclim/output.lisp:1.10 Sun Jun 1 04:06:57 2003
+++ mcclim/output.lisp Thu Dec 1 12:10:55 2005
@@ -77,7 +77,7 @@
(check-type medium symbol)
(let ((fn (gensym)))
`(labels ((,fn (,medium)
- (declare (ignorable ,medium))
+ ,(declare-ignorable-form* medium)
,@body))
(declare (dynamic-extent #',fn))
(invoke-with-sheet-medium-bound #',fn nil ,sheet))))
@@ -86,7 +86,7 @@
(check-type medium symbol)
(let ((fn (gensym)))
`(labels ((,fn (,medium)
- (declare (ignorable ,medium))
+ ,(declare-ignorable-form* medium)
,@body))
(declare (dynamic-extent #',fn))
(invoke-with-sheet-medium-bound #',fn ,medium ,sheet))))
Index: mcclim/recording.lisp
diff -u mcclim/recording.lisp:1.119 mcclim/recording.lisp:1.120
--- mcclim/recording.lisp:1.119 Sat Aug 13 16:28:19 2005
+++ mcclim/recording.lisp Thu Dec 1 12:10:55 2005
@@ -374,7 +374,7 @@
(setq stream (stream-designator-symbol stream '*standard-output*))
(with-gensyms (continuation)
`(flet ((,continuation (,stream)
- (declare (ignorable ,stream))
+ ,(declare-ignorable-form* stream)
,@body))
(declare (dynamic-extent #',continuation))
(invoke-with-output-recording-options
@@ -400,7 +400,7 @@
(flet ((,constructor ()
(make-instance ,record-type ,@m-i-args))
(,continuation (,stream ,record)
- (declare (ignorable ,stream ,record))
+ ,(declare-ignorable-form* stream record)
,@body))
(declare (dynamic-extent #'constructor #'continuation))
(,',func-name ,stream #',continuation ,record-type #',constructor
@@ -444,8 +444,7 @@
(defmethod initialize-instance :after ((record basic-output-record)
&key (x-position 0.0d0)
- (y-position 0.0d0))
- (declare (ignore args))
+ (y-position 0.0d0))
(setf (rectangle-edges* record)
(values x-position y-position x-position y-position)))
@@ -1267,7 +1266,6 @@
,class-vars)
(defmethod initialize-instance :after ((graphic ,class-name)
&key)
- (declare (ignore args))
(with-slots (stream ink clipping-region
line-style text-style ,@args)
graphic
Index: mcclim/utils.lisp
diff -u mcclim/utils.lisp:1.41 mcclim/utils.lisp:1.42
--- mcclim/utils.lisp:1.41 Mon Mar 14 23:03:05 2005
+++ mcclim/utils.lisp Thu Dec 1 12:10:55 2005
@@ -461,21 +461,27 @@
(t
(error "~S Can not be a stream designator for ~S" symbol default))))
+(defun declare-ignorable-form (variables)
+ #+CMU
+ ;; CMUCL barfs if you declare a special variable ignorable, work
+ ;; around that.
+ `(declare (ignorable
+ ,@(remove-if (lambda (symbol)
+ (eq :special (lisp::info lisp::variable lisp::kind symbol)))
+ variables)))
+ #-CMU
+ `(declare (ignorable ,@variables)))
+
+;; spread version:
+
+(defun declare-ignorable-form* (&rest variables)
+ (declare-ignorable-form variables))
+
(defun gen-invoke-trampoline (fun to-bind to-pass body)
"Macro helper function, generates the LABELS / INVOKE-WITH-... ideom."
(let ((cont (gensym ".CONT.")))
`(labels ((,cont (,@to-bind)
- #+CMU
- ;; for some reason CMUCL barfs if we declare a special
- ;; variable to be ignored. so we take an alternate
- ;; route.
- ;; --GB 2003-06-05
- (progn
- ,@to-bind
- (locally ,@body))
- #-CMU
- (declare (ignorable ,@to-bind))
- #-CMU
+ ,(declare-ignorable-form to-bind)
,@body))
(declare (dynamic-extent #',cont))
(,fun ,@to-bind #',cont ,@to-pass))))
