mcclim-cvs February 2008

mcclim-cvs@common-lisp.net

6 participants
86 discussions

[mcclim-cvs] CVS mcclim
by thenriksen 03 Feb '08

03 Feb '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7003 Modified Files: input-editing.lisp Log Message: Implement classic CLIM behavior for :erase keyword in with-input-editor-typeout. Doesn't mesh well with border output records, for some reason. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/03 11:35:22 1.70 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/03 12:11:13 1.71 @@ -67,6 +67,18 @@ (:documentation "A mixin implementing some useful standard behavior for input-editing streams.")) +(defmethod typeout-record :around ((stream standard-input-editing-mixin)) + ;; Can't do this in an initform, since we need to proper position... + (or (call-next-method) + (let ((record + (make-instance 'standard-sequence-output-record + :x-position 0 + :y-position (bounding-rectangle-min-y + (input-editing-stream-output-record stream))))) + (stream-add-output-record (encapsulating-stream-stream stream) + record) + (setf (typeout-record stream) record)))) + ;;; These helper functions take the arguments of ACCEPT so that they ;;; can be used directly by ACCEPT. @@ -224,39 +236,42 @@ (defmethod invoke-with-input-editor-typeout ((editing-stream standard-input-editing-mixin) (continuation function) &key erase) - (declare (ignore erase)) - (let* ((encapsulated-stream (encapsulating-stream-stream editing-stream)) - (new-typeout-record (with-output-to-output-record (encapsulated-stream) - (funcall continuation encapsulated-stream))) - (editor-record (input-editing-stream-output-record editing-stream))) - (with-accessors ((stream-typeout-record typeout-record)) editing-stream + (with-accessors ((stream-typeout-record typeout-record)) editing-stream + ;; Can't do this in an initform, as we need to set the proper + ;; output record position. + (let* ((encapsulated-stream (encapsulating-stream-stream editing-stream)) + (old-min-y (bounding-rectangle-min-y stream-typeout-record)) + (old-height (bounding-rectangle-height stream-typeout-record)) + (new-typeout-record (with-output-to-output-record (encapsulated-stream + 'standard-sequence-output-record + record) + (unless erase + ;; Steal the children of the old typeout record. + (map nil #'(lambda (child) + (setf (output-record-parent child) nil + (output-record-position child) (values 0 0)) + (add-output-record child record)) + (output-record-children stream-typeout-record)) + ;; Make sure new output is done + ;; after the stolen children. + (stream-increment-cursor-position + encapsulated-stream 0 old-height)) + (funcall continuation encapsulated-stream)))) (with-sheet-medium (medium encapsulated-stream) - (setf (output-record-position new-typeout-record) - (values 0 (bounding-rectangle-min-y (or stream-typeout-record editor-record)))) + (setf (output-record-position new-typeout-record) (values 0 old-min-y)) ;; Calculate the height difference between the old typeout and the new. - (let ((delta-y (- (bounding-rectangle-height new-typeout-record) - (if stream-typeout-record - (bounding-rectangle-height stream-typeout-record) - 0)))) + (let ((delta-y (- (bounding-rectangle-height new-typeout-record) old-height))) (multiple-value-bind (typeout-x typeout-y) (output-record-position new-typeout-record) (declare (ignore typeout-x)) - ;; Clear the old typeout. - (when stream-typeout-record - (clear-output-record stream-typeout-record)) + ;; Clear the old typeout... + (clear-output-record stream-typeout-record) + ;; Move stuff for the new typeout record... (sheet-move-output-vertically encapsulated-stream typeout-y delta-y) - ;; Reuse the old stream-typeout-record, if any. - (cond (stream-typeout-record - (add-output-record new-typeout-record stream-typeout-record)) - (t - (stream-add-output-record encapsulated-stream new-typeout-record) - (setf stream-typeout-record new-typeout-record))) + ;; Reuse the old stream-typeout-record... + (add-output-record new-typeout-record stream-typeout-record) ;; Now, let there be light! - (with-bounding-rectangle* (x1 y1 x2 y2) stream-typeout-record - (declare (ignore x2)) - (repaint-sheet encapsulated-stream - (make-bounding-rectangle - x1 y1 (bounding-rectangle-width encapsulated-stream) y2))))))))) + (repaint-sheet encapsulated-stream stream-typeout-record))))))) (defun clear-typeout (&optional (stream t)) "Blank out the input-editor typeout displayed on `stream',

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by ahefner 03 Feb '08

03 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv6324 Modified Files: dev-commands.lisp Log Message: Fix copy-list/mapcan bug that causes Show Class Slots to sometimes loop infinitely. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/31 11:06:40 1.48 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/02/03 12:08:51 1.49 @@ -532,7 +532,7 @@ (defun direct-slot-definitions (class slot-name) (let ((cpl (reverse (clim-mop:class-precedence-list class))) (direct-slots nil)) - (dolist (foo cpl) + (dolist (foo cpl) ; rewrite this (let ((dslots (clim-mop:class-direct-slots foo))) (dolist (slot dslots) (when (eq slot-name (clim-mop:slot-definition-name slot)) @@ -554,10 +554,10 @@ (initargs (clim-mop:slot-definition-initargs slot)) (initfunc (clim-mop:slot-definition-initfunction slot)) (initform (clim-mop:slot-definition-initform slot)) - (direct-slots (direct-slot-definitions class name)) - (readers (mapcan #'clim-mop:slot-definition-readers direct-slots)) - (writers (mapcan #'clim-mop:slot-definition-writers direct-slots)) - (documentation (first (mapcan (lambda (x) (list (documentation x t))) direct-slots))) + (direct-slots (direct-slot-definitions class name)) + (readers (mapcan (lambda (x) (copy-list (clim-mop:slot-definition-readers x))) direct-slots)) + (writers (mapcan (lambda (x) (copy-list (clim-mop:slot-definition-writers x))) direct-slots)) + (documentation (first (remove nil (mapcar (lambda (x) (documentation x t)) direct-slots)))) (*standard-output* stream)) (macrolet ((with-ink ((var) &body body) @@ -719,11 +719,10 @@ (error "Sorry, not supported in your CL implementation. See the function X-SPECIALIZER-DIRECT-GENERIC-FUNCTION if you are interested in fixing this.")) (defun class-funcs (class) - (let ((classes (remove-ignorable-classes (copy-list (clim-mop:class-precedence-list class)))) - (gfs nil)) - (dolist (x classes) - (setf gfs (append gfs (x-specializer-direct-generic-functions x)))) - (remove-duplicates gfs))) + (remove-duplicates + (mapcan (lambda (class) + (copy-list (x-specializer-direct-generic-functions class))) + (remove-ignorable-classes (clim-mop:class-precedence-list class))))) (defun slot-name-sortp (a b) (flet ((slot-name-symbol (x) @@ -1164,8 +1163,7 @@ :printer (lambda (x stream) (declare (ignore stream)) (pretty-pretty-pathname x *standard-output* :long-name full-names))) - (goatee::reposition-stream-cursor *standard-output*) - (vertical-gap t)) + (goatee::reposition-stream-cursor *standard-output*)) ; Hmm. (list (dolist (ent group) (let ((ent (merge-pathnames ent pathname))) ;; This is for CMUCL, see above. (fixme!) ;; And breaks some things for SBCL.. (mgr)

1 0

[mcclim-cvs] CVS mcclim
by ahefner 03 Feb '08

03 Feb '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv30581 Modified Files: input-editing.lisp Log Message: Oops, deleted an extra line along with the old comment. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/03 10:38:58 1.69 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/03 11:35:22 1.70 @@ -592,6 +592,7 @@ (progn (unread-gesture gesture :stream stream) (return-from complete-input-rescan + (values object t input))) ;; This used to be an error, but no one thought ;; that was a really great idea. (signal 'simple-completion-error

1 0

[mcclim-cvs] CVS mcclim
by ahefner 03 Feb '08

03 Feb '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17423 Modified Files: input-editing.lisp Log Message: Don't error when completion fails in complete-input-rescan. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/03 08:06:31 1.68 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/03 10:38:58 1.69 @@ -592,12 +592,9 @@ (progn (unread-gesture gesture :stream stream) (return-from complete-input-rescan - (values object t input))) - ;; Do we actually want to signal this here? I - ;; don't think we should terminate the - ;; input-editing-session just because the user - ;; tries to complete invalid input. - (error 'simple-completion-error + ;; This used to be an error, but no one thought + ;; that was a really great idea. + (signal 'simple-completion-error :format-control "complete-input: While rescanning,~ can't match ~A~A" :format-arguments (list so-far gesture)

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by ahefner 03 Feb '08

03 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv13147 Modified Files: listener.lisp Log Message: :insert-default wasn't necessary. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/02/03 10:18:32 1.40 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/02/03 10:20:04 1.41 @@ -143,7 +143,7 @@ "Specialized for the listener, read a lisp form to eval, or a command." (multiple-value-bind (object type) (let ((*command-dispatchers* '(#\,))) - (accept 'command-or-form :stream stream :prompt nil :default "hello" :default-type 'empty-input :insert-default nil)) + (accept 'command-or-form :stream stream :prompt nil :default "hello" :default-type 'empty-input)) (cond ((presentation-subtypep type 'empty-input) ;; Do nothing.

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by ahefner 03 Feb '08

03 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv13022 Modified Files: listener.lisp Log Message: Handle empty input. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/02/01 18:48:56 1.39 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/02/03 10:18:32 1.40 @@ -133,14 +133,23 @@ ;;; Lisp listener command loop +(define-presentation-type empty-input ()) + +(define-presentation-method present + (object (type empty-input) stream view &key &allow-other-keys) + (princ "" stream)) + (defmethod read-frame-command ((frame listener) &key (stream *standard-input*)) "Specialized for the listener, read a lisp form to eval, or a command." (multiple-value-bind (object type) (let ((*command-dispatchers* '(#\,))) - (accept 'command-or-form :stream stream :prompt nil :default nil)) - (if (presentation-subtypep type 'command) - object - `(com-eval ,object)))) + (accept 'command-or-form :stream stream :prompt nil :default "hello" :default-type 'empty-input :insert-default nil)) + (cond + ((presentation-subtypep type 'empty-input) + ;; Do nothing. + `(com-eval (values))) + ((presentation-subtypep type 'command) object) + (t `(com-eval ,object))))) (defun print-listener-prompt (stream frame) (declare (ignore frame))

1 0

[mcclim-cvs] CVS mcclim/Backends/PostScript
by ahefner 03 Feb '08

03 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv8059 Modified Files: class.lisp Log Message: Don't need two native-region slots in different packages, and I'm sick of SBCL whining about it. --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/class.lisp 2007/11/27 19:49:33 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/class.lisp 2008/02/03 09:43:04 1.11 @@ -72,9 +72,7 @@ (title :initarg :title) (for :initarg :for) (orientation :initarg :orientation) - (paper :initarg :paper) - (native-region :initarg :native-region - :reader sheet-native-region) + (paper :initarg :paper) (transformation :initarg :transformation :reader sheet-native-transformation) (current-page :initform 0)

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by ahefner 03 Feb '08

03 Feb '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv4395 Modified Files: wholine.lisp Log Message: Fill the background color of the wholine before painting, because AA drawing is not idempotent. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2008/01/31 08:46:44 1.4 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/wholine.lisp 2008/02/03 09:27:22 1.5 @@ -55,14 +55,15 @@ ;; window-clear method which calls the next window-clear method, ;; then calls handle-repaint to redraw the decoration. + (defmethod handle-repaint ((pane wholine-pane) region) (declare (ignore region)) (with-output-recording-options (pane :draw t :record nil) (with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region pane) + (draw-rectangle* pane x0 y0 x1 y1 :filled t :ink (pane-background pane)) (climi::draw-bordered-rectangle* (sheet-medium pane) x0 y0 x1 y1 - :style :mickey-mouse-inset) - #+NIL (draw-rectangle* (sheet-medium pane) x0 y0 x1 y1 :ink +red+)) + :style :mickey-mouse-inset)) (replay-output-record (stream-output-history pane) pane))) (defmethod window-clear ((pane wholine-pane))

1 0

[mcclim-cvs] CVS mcclim
by ahefner 03 Feb '08

03 Feb '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4115 Modified Files: recording.lisp Log Message: Eliminate %handle-repaint and repaint-sheet hack. I don't think the warnings about wholine infinite recursion are applicable anymore, either. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2008/02/02 19:03:00 1.138 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2008/02/03 09:25:42 1.139 @@ -2313,15 +2313,11 @@ (with-output-recording-options (stream :record nil) (call-next-method))) -;;; Helper function to break some infinite recursion issues with -;;; handle-repaint vs. redisplay-frame-pane (in the Listener, that -;;; is; is this the right place for the fix? ) - ;;; FIXME: Change things so the rectangle below is only drawn in response ;;; to explicit repaint requests from the user, not exposes from X ;;; FIXME: Use DRAW-DESIGN*, that is fix DRAW-DESIGN*. -(defun %handle-repaint (stream region) +(defmethod handle-repaint ((stream output-recording-stream) region) (when (output-recording-stream-p stream) (unless (region-equal region +nowhere+) ; ignore repaint requests for +nowhere+ (let ((region (if (region-equal region +everywhere+) @@ -2332,8 +2328,6 @@ (draw-rectangle* stream x1 y1 x2 y2 :filled t :ink +background-ink+))) (stream-replay stream region))))) -(defmethod handle-repaint ((stream output-recording-stream) region) - (%handle-repaint stream region)) (defmethod scroll-extent :around ((stream output-recording-stream) x y) (declare (ignore x y)) @@ -2397,14 +2391,6 @@ (setf (stream-cursor-position stream) (values cx cy))) record)))))) - - -(defmethod repaint-sheet ((sheet output-recording-stream) region) - (map-over-sheets-overlapping-region #'(lambda (s) - (%handle-repaint s region)) - sheet - region)) - ;;; ---------------------------------------------------------------------------- ;;; Baseline ;;;

1 0

[mcclim-cvs] CVS mcclim
by ahefner 03 Feb '08

03 Feb '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3722 Modified Files: package.lisp Log Message: No need to modify the autogenerated symbol list. Moved CLIM 2.2 symbols. --- /project/mcclim/cvsroot/mcclim/package.lisp 2008/01/27 22:24:07 1.65 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2008/02/03 09:24:15 1.66 @@ -353,8 +353,6 @@ ;; this list of exported symbols was automatically generated from the ;; specification as of version 1.17 of this very file, please think twice ;; before fiddling with it. thanks! --gb 2002-11-10 - ;; A good reason for fiddling with with it is to add symbols from - ;; CLIM 2.2. --thenriksen 2006-12-11 #:*abort-gestures* ;variable #:*accelerator-gestures* ;variable @@ -412,7 +410,6 @@ #:+textual-dialog-view+ ;constant #:+textual-menu-view+ ;constant #:+textual-view+ ;constant - #:+text-field-view+ ;constant (Franz User's Guide) #:+transparent-ink+ ;constant #:+white+ ;constant #:+yellow+ ;constant @@ -694,7 +691,6 @@ #:extended-output-stream-p ;predicate #:filling-output ;macro #:find-applicable-translators ;function - #:find-application-frame ;function (in Franz User's Guide) #:find-cached-output-record ;generic function #:find-child-output-record ;generic function #:find-command-from-command-line-name ;function @@ -713,7 +709,6 @@ #:float ;presentation type #:form ;presentation type #:format-graph-from-roots ;function - #:format-graph-from-root ;function #:format-items ;function #:format-textual-list ;function #:formatting-cell ;macro @@ -873,8 +868,6 @@ #:line-style-unit ;generic function #:linep ;predicate #:list-pane ;class - #:list-pane-view ;class - #:+list-pane-view+ ;constant #:lookup-keystroke-command-item ;function #:lookup-keystroke-item ;function #:make-3-point-transformation ;function @@ -1041,8 +1034,6 @@ #:open-stream-p ;generic function #:open-window-stream ;function #:option-pane ;class - #:option-pane-view ;class - #:+option-pane-view+ ;constant #:or ;presentation type #:oriented-gadget-mixin ;class #:outlined-pane ;pane @@ -1114,10 +1105,7 @@ #:pointer-event-x ;generic function #:pointer-event-y ;generic function #:pointer-exit-event ;class - #:pointer-input-rectangle ;function (in franz user guide) - #:pointer-input-rectangle* ;function (in franz user guide) #:pointer-motion-event ;class - #:pointer-place-rubber-band-line* ;function (in franz user guide) #:pointer-position ;generic function #:pointer-sheet ;generic function #:pointerp ;predicate @@ -1131,9 +1119,7 @@ #:port ;protocol class #:port ;generic function #:port-keyboard-input-focus ;generic function - #:port-modifier-state ;generic function (in franz user guide) #:port-name ;generic function - #:port-pointer ;generic function (in franz user guide) #:port-properties ;generic function #:port-server-path ;generic function #:port-type ;generic function @@ -1171,8 +1157,6 @@ #:propagate-output-record-changes-p ;generic function #:push-button ;class #:push-button-pane ;class - #:push-button-view ;class - #:+push-button-view+ ;constant #:push-button-show-as-default ;generic function #:queue-event ;generic function #:queue-repaint ;generic function @@ -1181,8 +1165,6 @@ #:radio-box-current-selection ;generic function #:radio-box-pane ;class #:radio-box-selections ;generic function - #:radio-box-view ;class - #:+radio-box-view+ ;class #:raise-frame ;generic function #:raise-mirror ;generic function #:raise-sheet ;generic function @@ -1321,8 +1303,6 @@ #:slider ;class #:slider-drag-callback ;generic function #:slider-pane ;class - #:slider-view ;slider-view - #:+slider-view+ ;constant #:space-requirement ;class #:space-requirement+ ;function #:space-requirement+* ;function @@ -1474,11 +1454,8 @@ #:text-displayed-output-record-string ;generic function #:text-editor ;class #:text-editor-pane ;class - #:text-editor-view ;class - #:+text-editor-view+ ;constant #:text-field ;class #:text-field-pane ;class - #:text-field-view ;class (Franz User's Guide) #:text-size ;generic function #:text-style ;protocol class #:text-style-ascent ;generic function @@ -1501,8 +1478,6 @@ #:toggle-button ;class #:toggle-button-indicator-type ;generic function #:toggle-button-pane ;class - #:toggle-button-view ;class - #:+toggle-button-view+ ;constant #:token-or-type ;presentation type abbrev #:tracking-pointer ;macro #:transform-distance ;generic function @@ -1656,12 +1631,39 @@ ;; stream-redisplayable-p ;; stream-restore-input-focus - ;;; Vendor extensions which are exported from the CLIM package + ;;; Vendor extensions which are exported from the CLIM package, + ;;; including CLIM 2.2 symbols. (:export - #:+pointer-wheel-up+ + ;; I forget where the wheel symbols come from. They aren't in the + ;; Franz guide. Are they from Lispworks, or did McCLIM invent them? + #:+pointer-wheel-up+ #:+pointer-wheel-down+ #:+pointer-wheel-left+ #:+pointer-wheel-right+ + ;; Franz and CLIM 2.2 Stuff: + #:+text-field-view+ ;constant (Franz User's Guide) + #:find-application-frame ;function (in Franz User's Guide) + #:format-graph-from-root ;function + #:list-pane-view ;class + #:+list-pane-view+ ;constant + #:option-pane-view ;class + #:+option-pane-view+ ;constant + #:pointer-input-rectangle ;function (in franz user guide) + #:pointer-input-rectangle* ;function (in franz user guide) + #:pointer-place-rubber-band-line* ;function (in franz user guide) + #:port-modifier-state ;generic function (in franz user guide) + #:port-pointer ;generic function (in franz user guide) + #:push-button-view ;class + #:+push-button-view+ ;constant + #:radio-box-view ;class + #:+radio-box-view+ ;class + #:slider-view ;slider-view + #:+slider-view+ ;constant + #:text-editor-view ;class + #:+text-editor-view+ ;constant + #:text-field-view ;class (Franz User's Guide) + #:toggle-button-view ;class + #:+toggle-button-view+ ;constant #:sheet-pointer-cursor) ;;; x11 color names - some are not in the spec - mikemac

1 0

← Newer
1
2
3
4
5
6
7
8
9
Older →

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs February 2008