From gbaumann at common-lisp.net Thu Dec 1 11:10:58 2005 From: gbaumann at common-lisp.net (Gilbert Baumann) Date: Thu, 1 Dec 2005 12:10:58 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Listener/cmu-hacks.lisp Message-ID: <20051201111058.964078858C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv21959/Apps/Listener Modified Files: cmu-hacks.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:57 2005 Author: gbaumann Index: mcclim/Apps/Listener/cmu-hacks.lisp diff -u mcclim/Apps/Listener/cmu-hacks.lisp:1.5 mcclim/Apps/Listener/cmu-hacks.lisp:1.6 --- mcclim/Apps/Listener/cmu-hacks.lisp:1.5 Sun Mar 6 21:23:13 2005 +++ mcclim/Apps/Listener/cmu-hacks.lisp Thu Dec 1 12:10:57 2005 @@ -41,6 +41,11 @@ (in-package "DEBUG") +(#+CMU19C + ext:without-package-locks + #-CMU19C + progn + (defun internal-debug () (let ((*in-the-debugger* t) (*read-suppress* nil)) @@ -85,9 +90,15 @@ (defparameter *debug-prompt* #'debug-prompt "This is a function of no arguments that prints the debugger prompt on *debug-io*.") +) (in-package "LISP") +(#+CMU19C + ext:without-package-locks + #-CMU19C + progn + (defun get-stream-command (stream) "This takes a stream and waits for text or a command to appear on it. If text appears before a command, this returns nil, and otherwise it returns @@ -99,3 +110,4 @@ (t ;; This waits for input and returns nil when it arrives. (unread-char (read-char stream) stream))))) +) From gbaumann at common-lisp.net Thu Dec 1 11:10:58 2005 From: gbaumann at common-lisp.net (Gilbert Baumann) Date: Thu, 1 Dec 2005 12:10:58 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/commands.lisp mcclim/decls.lisp mcclim/dialog-views.lisp mcclim/gadgets.lisp mcclim/medium.lisp mcclim/output.lisp mcclim/recording.lisp mcclim/utils.lisp Message-ID: <20051201111058.5B6B688554@common-lisp.net> 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)) , at 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) , at 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) , at 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) , at 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) , at 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) , at 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) , at 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) , at 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) , at 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) , at body)) (declare (dynamic-extent #',continuation)) (invoke-with-output-recording-options @@ -400,7 +400,7 @@ (flet ((,constructor () (make-instance ,record-type , at m-i-args)) (,continuation (,stream ,record) - (declare (ignorable ,stream ,record)) + ,(declare-ignorable-form* stream record) , at 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 , at 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 , at 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 (, at 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 - , at to-bind - (locally , at body)) - #-CMU - (declare (ignorable , at to-bind)) - #-CMU + ,(declare-ignorable-form to-bind) , at body)) (declare (dynamic-extent #',cont)) (,fun , at to-bind #',cont , at to-pass)))) From gbaumann at common-lisp.net Thu Dec 1 12:06:41 2005 From: gbaumann at common-lisp.net (Gilbert Baumann) Date: Thu, 1 Dec 2005 13:06:41 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp Message-ID: <20051201120641.1391B88554@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26542 Modified Files: panes.lisp Log Message: more IGNORE declarations Date: Thu Dec 1 13:06:41 2005 Author: gbaumann Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.164 mcclim/panes.lisp:1.165 --- mcclim/panes.lisp:1.164 Wed Nov 30 11:30:50 2005 +++ mcclim/panes.lisp Thu Dec 1 13:06:40 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.164 2005/11/30 10:30:50 gbaumann Exp $ +;;; $Id: panes.lisp,v 1.165 2005/12/01 12:06:40 gbaumann Exp $ (in-package :clim-internals) @@ -1704,6 +1704,7 @@ (typep pane 'spacing-pane)) (defmethod initialize-instance :after ((spacing spacing-pane) &key thickness contents &allow-other-keys) + (declare (ignorable thickness contents)) (with-slots (user-width user-min-width user-max-width user-height user-min-height user-max-height) spacing @@ -1819,6 +1820,7 @@ (defclass viewport-pane (single-child-composite-pane) ()) (defmethod compose-space ((pane viewport-pane) &key width height) + (declare (ignorable width height)) ; I _think_ this is right, it certainly shouldn't be the requirements of the child. (make-space-requirement)) @@ -2433,6 +2435,7 @@ (call-next-method)))) (defmethod compose-space ((pane clim-stream-pane) &key width height) + (declare (ignorable width height)) (let ((w (bounding-rectangle-width (stream-output-history pane))) (h (bounding-rectangle-height (stream-output-history pane)))) (make-space-requirement :width w :min-width w :max-width +fill+ From afuchs at common-lisp.net Mon Dec 5 22:40:03 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Mon, 5 Dec 2005 23:40:03 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Goatee/goatee-command.lisp Message-ID: <20051205224003.43A93880D9@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory common-lisp.net:/tmp/cvs-serv20554/Goatee Modified Files: goatee-command.lisp Log Message: patch queue clearing: add arrow key support (and gestures) to goatee. Date: Mon Dec 5 23:40:02 2005 Author: afuchs Index: mcclim/Goatee/goatee-command.lisp diff -u mcclim/Goatee/goatee-command.lisp:1.19 mcclim/Goatee/goatee-command.lisp:1.20 --- mcclim/Goatee/goatee-command.lisp:1.19 Sun Aug 1 07:39:41 2004 +++ mcclim/Goatee/goatee-command.lisp Mon Dec 5 23:40:01 2005 @@ -67,7 +67,9 @@ modifier-state (keyboard-event-character gesture)) (cdr (assoc modifier-state - (gethash (keyboard-event-character gesture) table nil))))) + (gethash (or (keyboard-event-character gesture) + (keyboard-event-key-name gesture)) + table nil))))) (defmethod lookup-gesture-command (gesture table) (declare (ignore gesture table)) @@ -265,18 +267,30 @@ (add-gesture-command-to-table '(#\f :control) 'forward-character *simple-area-gesture-table*) +(add-gesture-command-to-table '(:right) + 'forward-character + *simple-area-gesture-table*) (add-gesture-command-to-table '(#\b :control) 'backward-character *simple-area-gesture-table*) +(add-gesture-command-to-table '(:left) + 'backward-character + *simple-area-gesture-table*) (add-gesture-command-to-table '(#\f :meta) 'forward-word *simple-area-gesture-table*) +(add-gesture-command-to-table '(:right :meta) + 'forward-word + *simple-area-gesture-table*) (add-gesture-command-to-table '(#\b :meta) 'backward-word *simple-area-gesture-table*) +(add-gesture-command-to-table '(:left :meta) + 'backward-word + *simple-area-gesture-table*) (add-gesture-command-to-table '(#\backspace :meta) 'backwards-delete-word @@ -285,14 +299,23 @@ (add-gesture-command-to-table '(#\delete :meta) 'delete-word *simple-area-gesture-table*) +(add-gesture-command-to-table '(#\d :meta) + 'delete-word + *simple-area-gesture-table*) (add-gesture-command-to-table '(#\a :control) 'beginning-line *simple-area-gesture-table*) +(add-gesture-command-to-table '(:home) + 'beginning-line + *simple-area-gesture-table*) (add-gesture-command-to-table '(#\e :control) 'end-line *simple-area-gesture-table*) +(add-gesture-command-to-table '(:end) + 'end-line + *simple-area-gesture-table*) (add-gesture-command-to-table '(#\k :control) 'kill-line @@ -305,8 +328,14 @@ (add-gesture-command-to-table '(#\p :control) 'up-line *simple-area-gesture-table*) +(add-gesture-command-to-table '(:up) + 'up-line + *simple-area-gesture-table*) (add-gesture-command-to-table '(#\n :control) + 'down-line + *simple-area-gesture-table*) +(add-gesture-command-to-table '(:down) 'down-line *simple-area-gesture-table*) From rgoldman at common-lisp.net Tue Dec 6 13:40:07 2005 From: rgoldman at common-lisp.net (Robert Goldman) Date: Tue, 6 Dec 2005 14:40:07 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/decls.lisp Message-ID: <20051206134007.AA12388545@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv25420 Modified Files: decls.lisp Log Message: No functional change; just added documentation string to compose-space. Date: Tue Dec 6 14:40:06 2005 Author: rgoldman Index: mcclim/decls.lisp diff -u mcclim/decls.lisp:1.33 mcclim/decls.lisp:1.34 --- mcclim/decls.lisp:1.33 Thu Dec 1 12:10:54 2005 +++ mcclim/decls.lisp Tue Dec 6 14:40:04 2005 @@ -390,7 +390,14 @@ ;; space-requirement+ sr1 sr2 [Function] ;; space-requirement+* space-req &key width min-width max-width height min-height max-height [Function] -(defgeneric compose-space (pane &key width height)) +(defgeneric compose-space (pane &key width height) + (:documentation "During the space composition pass, a composite pane will +typically ask each of its children how much space it requires by calling COMPOSE-SPACE. +They answer by returning space-requirement objects. The composite will then form +its own space requirement by composing the space requirements of its children +according to its own rules for laying out its children. + +Returns a SPACE-REQUIREMENT object.")) (defgeneric allocate-space (pane width height)) (defgeneric change-space-requirements (pane &rest space-req-keys &key resize-frame width height From rgoldman at common-lisp.net Tue Dec 6 16:21:12 2005 From: rgoldman at common-lisp.net (Robert Goldman) Date: Tue, 6 Dec 2005 17:21:12 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Listener/listener.lisp Message-ID: <20051206162112.33B0A88545@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv5288 Modified Files: listener.lisp Log Message: Cheap hack to get USER env var in Allegro CL. Date: Tue Dec 6 17:21:12 2005 Author: rgoldman Index: mcclim/Apps/Listener/listener.lisp diff -u mcclim/Apps/Listener/listener.lisp:1.21 mcclim/Apps/Listener/listener.lisp:1.22 --- mcclim/Apps/Listener/listener.lisp:1.21 Tue Jan 11 06:26:26 2005 +++ mcclim/Apps/Listener/listener.lisp Tue Dec 6 17:21:11 2005 @@ -72,7 +72,8 @@ (declare (ignore frame)) (let* ((*standard-output* pane) (username (or #+cmu (cdr (assoc :user ext:*environment-list*)) - #-cmu (getenv "USER") + #+allegro (sys:getenv "USER") + #-(or allegro cmu) (getenv "USER") "luser")) ; sorry.. (sitename (machine-instance)) (memusage #+cmu (lisp::dynamic-usage) From rgoldman at common-lisp.net Tue Dec 6 16:22:00 2005 From: rgoldman at common-lisp.net (Robert Goldman) Date: Tue, 6 Dec 2005 17:22:00 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Listener/dev-commands.lisp Message-ID: <20051206162200.3010688545@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv5339 Modified Files: dev-commands.lisp Log Message: Made class-grapher update space requirements. Date: Tue Dec 6 17:21:58 2005 Author: rgoldman Index: mcclim/Apps/Listener/dev-commands.lisp diff -u mcclim/Apps/Listener/dev-commands.lisp:1.31 mcclim/Apps/Listener/dev-commands.lisp:1.32 --- mcclim/Apps/Listener/dev-commands.lisp:1.31 Thu Oct 13 17:15:24 2005 +++ mcclim/Apps/Listener/dev-commands.lisp Tue Dec 6 17:21:58 2005 @@ -440,24 +440,29 @@ (arrow-ink *graph-edge-ink*) (text-style *graph-text-style*)) (with-drawing-options (stream :text-style text-style) - (format-graph-from-roots (list class) - #'(lambda (class stream) - (with-drawing-options (stream :ink normal-ink - :text-style text-style) - ;; Present class name rather than class here because the printing of the - ;; class object itself is rather long and freaks out the pointer doc pane. - (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name) - ; (surrounding-output-with-border (stream :shape :drop-shadow) - (princ (clim-mop:class-name class) stream)))) ;) - inferior-fun - :stream stream - :merge-duplicates T - :graph-type :tree - :orientation orientation - :arc-drawer - #'(lambda (stream foo bar x1 y1 x2 y2) - (declare (ignore foo bar)) - (draw-arrow* stream x1 y1 x2 y2 :ink arrow-ink)))))) + (prog1 + ;; not sure whether anyone wants the return value... + (format-graph-from-roots (list class) + #'(lambda (class stream) + (with-drawing-options (stream :ink normal-ink + :text-style text-style) + ;; Present class name rather than class here because the printing of the + ;; class object itself is rather long and freaks out the pointer doc pane. + (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name) + ; (surrounding-output-with-border (stream :shape :drop-shadow) + (princ (clim-mop:class-name class) stream)))) ;) + inferior-fun + :stream stream + :merge-duplicates T + :graph-type :tree + :orientation orientation + :arc-drawer + #'(lambda (stream foo bar x1 y1 x2 y2) + (declare (ignore foo bar)) + (draw-arrow* stream x1 y1 x2 y2 :ink arrow-ink))) + ;; format-graph-from-roots doesn't do this by default... + (when (typep stream 'pane) + (change-space-requirements stream)))))) (defun frob-to-class (spec) (if (typep spec 'class) From rgoldman at common-lisp.net Fri Dec 16 16:42:17 2005 From: rgoldman at common-lisp.net (Robert Goldman) Date: Fri, 16 Dec 2005 17:42:17 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/transforms.lisp Message-ID: <20051216164217.5162488446@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv30371 Modified Files: transforms.lisp Log Message: Applied Paul Werkowski's patch on ordering transformations to bring McCLIM in compliance with the standard. Also added docstring to MAKE-SCALING-TRANSFORMATION, pulled from CLIM spec. Date: Fri Dec 16 17:42:16 2005 Author: rgoldman Index: mcclim/transforms.lisp diff -u mcclim/transforms.lisp:1.30 mcclim/transforms.lisp:1.31 --- mcclim/transforms.lisp:1.30 Tue Nov 22 12:40:02 2005 +++ mcclim/transforms.lisp Fri Dec 16 17:42:15 2005 @@ -4,7 +4,7 @@ ;;; Created: 1998-09-29 ;;; Author: Gilbert Baumann ;;; License: LGPL (See file COPYING for details). -;;; $Id: transforms.lisp,v 1.30 2005/11/22 11:40:02 gbaumann Exp $ +;;; $Id: transforms.lisp,v 1.31 2005/12/16 16:42:15 rgoldman Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2003 by Gilbert Baumann ;;; (c) copyright 2000 by @@ -161,6 +161,12 @@ origin-x origin-y (+ origin-x c) (+ origin-y s) (- origin-x s) (+ origin-y c)) ))) (defun make-scaling-transformation (scale-x scale-y &optional origin) + "MAKE-SCALING-TRANSFORMATION returns a transformation that multiplies +the x-coordinate distance of every point from origin by SCALE-X and the +y-coordinate distance of every point from origin by SCALE-Y. SCALE-X and +SCALE-Y must be real numbers. If ORIGIN is supplied it must be a point; +if not supplied it defaults to (0, 0). ORIGIN-X and ORIGIN-Y must be +real numbers, and default to 0." (make-scaling-transformation* scale-x scale-y (if origin (point-x origin) 0) (if origin (point-y origin) 0))) @@ -390,22 +396,22 @@ value))) (defun compose-translation-with-transformation (transformation dx dy) - (compose-transformations (make-translation-transformation dx dy) transformation)) + (compose-transformations transformation (make-translation-transformation dx dy))) (defun compose-scaling-with-transformation (transformation sx sy &optional origin) - (compose-transformations (make-scaling-transformation sx sy origin) transformation)) + (compose-transformations transformation (make-scaling-transformation sx sy origin))) (defun compose-rotation-with-transformation (transformation angle &optional origin) - (compose-transformations (make-rotation-transformation angle origin) transformation)) + (compose-transformations transformation (make-rotation-transformation angle origin))) (defun compose-transformation-with-translation (transformation dx dy) - (compose-transformations transformation (make-translation-transformation dx dy))) + (compose-transformations (make-translation-transformation dx dy) transformation)) (defun compose-transformation-with-scaling (transformation sx sy &optional origin) - (compose-transformations transformation (make-scaling-transformation sx sy origin))) + (compose-transformations (make-scaling-transformation sx sy origin) transformation)) (defun compose-transformation-with-rotation (transformation angle &optional origin) - (compose-transformations transformation (make-rotation-transformation angle origin))) + (compose-transformations (make-rotation-transformation angle origin) transformation)) (defmacro with-translation ((medium dx dy) &body body) `(with-drawing-options (,medium :transformation (make-translation-transformation ,dx ,dy)) From crhodes at common-lisp.net Fri Dec 30 17:50:03 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Fri, 30 Dec 2005 18:50:03 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp Message-ID: <20051230175003.2FF948858F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv3071 Modified Files: panes.lisp Log Message: Merge patch from Tim Daly ("apparent typos", sent 2005-10-16) Date: Fri Dec 30 18:50:02 2005 Author: crhodes Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.165 mcclim/panes.lisp:1.166 --- mcclim/panes.lisp:1.165 Thu Dec 1 13:06:40 2005 +++ mcclim/panes.lisp Fri Dec 30 18:50:01 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.165 2005/12/01 12:06:40 gbaumann Exp $ +;;; $Id: panes.lisp,v 1.166 2005/12/30 17:50:01 crhodes Exp $ (in-package :clim-internals) @@ -367,7 +367,7 @@ (new-width :initform nil) (new-height :initform nil) (redisplay-needed :accessor pane-redisplay-needed - :initarg :redisplay-neeeded :initform nil)) + :initarg :redisplay-needed :initform nil)) (:documentation "")) (defmethod print-object ((pane pane) sink) @@ -2373,7 +2373,7 @@ :initarg :end-of-line-action :reader pane-end-of-line-action) (end-of-page-action :initform :scroll - :initarg :end-of-line-action + :initarg :end-of-page-action :reader pane-end-of-page-action) (double-buffering :initform nil :initarg :double-buffering From crhodes at common-lisp.net Fri Dec 30 18:02:42 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Fri, 30 Dec 2005 19:02:42 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Backends/PostScript/graphics.lisp mcclim/Backends/PostScript/sheet.lisp Message-ID: <20051230180242.146108858F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory common-lisp.net:/tmp/cvs-serv3468/Backends/PostScript Modified Files: graphics.lisp sheet.lisp Log Message: Postscript backend fixes, from Tim Daly's "typos and postscript backend" message on free-clim 2005-12-23. (wow, this is almost timely) Date: Fri Dec 30 19:02:40 2005 Author: crhodes Index: mcclim/Backends/PostScript/graphics.lisp diff -u mcclim/Backends/PostScript/graphics.lisp:1.14 mcclim/Backends/PostScript/graphics.lisp:1.15 --- mcclim/Backends/PostScript/graphics.lisp:1.14 Mon Oct 31 11:21:14 2005 +++ mcclim/Backends/PostScript/graphics.lisp Fri Dec 30 19:02:39 2005 @@ -68,7 +68,7 @@ (defvar *extra-entries* 0) -(defun write-postcript-dictionary (stream) +(defun write-postscript-dictionary (stream) ;;; FIXME: DSC (format stream "~&%%BeginProlog~%") (format stream "/~A ~D dict def ~2:*~A begin~%" Index: mcclim/Backends/PostScript/sheet.lisp diff -u mcclim/Backends/PostScript/sheet.lisp:1.10 mcclim/Backends/PostScript/sheet.lisp:1.11 --- mcclim/Backends/PostScript/sheet.lisp:1.10 Mon Oct 31 11:21:14 2005 +++ mcclim/Backends/PostScript/sheet.lisp Fri Dec 30 19:02:39 2005 @@ -89,7 +89,7 @@ (format file-stream "%%Pages: (atend)~%"))) (format file-stream "%%DocumentNeededResources: (atend)~%") (format file-stream "%%EndComments~%~%") - (write-postcript-dictionary file-stream) + (write-postscript-dictionary file-stream) (dolist (text-style (device-fonts (sheet-medium stream))) (write-font-to-postscript-stream (sheet-medium stream) text-style)) (start-page stream) @@ -107,20 +107,44 @@ (finish-output file-stream)) (destroy-port port)))) + (defun start-page (stream) (with-slots (file-stream current-page transformation) stream - (format file-stream "%%Page: ~D ~:*~D~%" (incf current-page)) - (format file-stream "~A begin~%" *dictionary-name*))) + (format file-stream "%%Page: ~D ~:*~D~%" (incf current-page)) + (format file-stream "~A begin~%" *dictionary-name*))) + +;;; We define a new output-record class and a method on +;;; replay-output-record so that we can record calls to new-page. +;;; +;;; FIXME: I (CSR) think that this works because we stuff this in a +;;; sequence-output-record, so that the output records are replayed +;;; in order. That's fine, but if someone ever gets round to implementing +;;; R-trees or similar, this method for storing the order of events might +;;; stop working. CSR, 2005-12-30 +(defclass new-page-record (climi::basic-output-record) + ()) + +(defmethod replay-output-record ((record new-page-record) stream + &optional (region nil) (x-offset 0) (y-offset 0)) + (declare (ignore region x-offset y-offset)) + (new-page stream)) (defun new-page (stream) - ;; FIXME: it is necessary to do smth with GS -- APD, 2002-02-11 - (let ((medium (sheet-medium stream))) - (postscript-restore-graphics-state medium) + (when (stream-recording-p stream) + (stream-add-output-record stream (make-instance 'new-page-record))) + (when (stream-drawing-p stream) + ;; FIXME: it is necessary to do smth with GS -- APD, 2002-02-11 + ;; FIXME^2: what do you mean by that? -- TPD, 2005-12-23 + (postscript-restore-graphics-state stream) (format (postscript-stream-file-stream stream) "end~%showpage~%") (start-page stream) - (postscript-save-graphics-state medium)) - (clear-output-record (stream-output-history stream)) - (setf (stream-cursor-position stream) (values 0 0))) + (postscript-save-graphics-state stream) + ;; If we call clear-output-record here, it wipes all remaining + ;; output, so all pages after the first are blank. But I don't + ;; know quite what the original purpose of the call was, so, + ;; FIXME. -- TPD 2005-12-23 + ;; (clear-output-record (stream-output-history stream)) + (setf (stream-cursor-position stream) (values 0 0)))) ;;;; Output Protocol