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))))