From thenriksen at common-lisp.net Fri Feb 1 00:22:04 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 31 Jan 2008 19:22:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080201002204.643761B028@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8334 Modified Files: dialog.lisp Log Message: Always finalize the input-editing stream used in accepting-values. --- /project/mcclim/cvsroot/mcclim/dialog.lisp 2007/07/21 13:06:45 1.28 +++ /project/mcclim/cvsroot/mcclim/dialog.lisp 2008/02/01 00:22:04 1.29 @@ -240,6 +240,8 @@ (finalize-query-records *accepting-values-stream*) (setf (last-pass *accepting-values-stream*) t) (redisplay arecord stream))) + (dolist (query (queries *accepting-values-stream*)) + (finalize (editing-stream (record query)) nil)) (erase-output-record arecord stream) (setf (stream-cursor-position stream) (values cx cy))))))) From thenriksen at common-lisp.net Fri Feb 1 00:23:38 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 31 Jan 2008 19:23:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080201002338.2905630039@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8775/Drei Modified Files: input-editor.lisp Log Message: Improved the implementation of with-input-editor-typeout yet again. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/01/31 19:17:56 1.34 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/01 00:23:36 1.35 @@ -756,40 +756,68 @@ ;;; ;;; `With-input-editor-typeout' ;;; +;;; Clears some space above the input-editing stream, moving other +;;; output records on the sheet down, and prints the output. Nothing +;;; is displayed until after the with-input-editor-typeout body is +;;; done. + +(defun sheet-move-output-vertically (sheet y delta-y) + "Move the output records of `sheet', starting at vertical +device unit offset `y' or below, down by `delta-y' device units, +then repaint `sheet'." + (unless (zerop delta-y) + (with-bounding-rectangle* (sheet-x1 sheet-y1 sheet-x2 sheet-y2) sheet + (declare (ignore sheet-x1 sheet-y1)) + (map-over-output-records-overlapping-region + #'(lambda (record) + (multiple-value-bind (record-x record-y) (output-record-position record) + (when (>= record-y y) + (setf (output-record-position record) + (values record-x (+ record-y delta-y)))))) + (stream-output-history sheet) + (make-bounding-rectangle 0 y sheet-x2 sheet-y2)) + ;; Only repaint within the visible region... + (with-bounding-rectangle* (viewport-x1 viewport-y1 viewport-x2 viewport-y2) + (or (pane-viewport-region sheet) sheet) + (declare (ignore viewport-y1)) + (repaint-sheet sheet (make-bounding-rectangle viewport-x1 (- y (abs delta-y)) + viewport-x2 viewport-y2)))))) (defmethod climi::invoke-with-input-editor-typeout ((editing-stream drei-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 (drei-instance editing-stream))) (with-accessors ((stream-typeout-record typeout-record)) editing-stream (with-sheet-medium (medium encapsulated-stream) - (with-bounding-rectangle* (x1 y1 x2 y2) editor-record - ;; Clear the input-editor display. - (draw-rectangle* medium x1 y1 x2 y2 :ink +background-ink+) - (setf (output-record-position new-typeout-record) - (output-record-position (or stream-typeout-record editor-record)) - (output-record-position editor-record) - (values x1 (+ y1 (- (bounding-rectangle-height new-typeout-record) - (if stream-typeout-record - (bounding-rectangle-height stream-typeout-record) - 0))))) - (when erase - (with-bounding-rectangle* (x1 y1 x2 y2) new-typeout-record - (draw-rectangle* medium x1 y1 x2 y2 :ink +background-ink+))) - ;; Reuse the old stream-typeout-record, if any. - (cond (stream-typeout-record - ;; Blank the old one. - (with-bounding-rectangle* (x1 y1 x2 y2) stream-typeout-record - (draw-rectangle* medium x1 y1 (1+ x2) y2 :ink +background-ink+)) - (clear-output-record 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))) - ;; Now, let there be light! - (replay stream-typeout-record encapsulated-stream)))))) + (setf (output-record-position new-typeout-record) + (values 0 (bounding-rectangle-min-y (or stream-typeout-record editor-record)))) + ;; 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)))) + (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)) + (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))) + ;; 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))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Fri Feb 1 10:53:55 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Feb 2008 05:53:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080201105355.381B437055@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17391 Modified Files: input-editing.lisp Log Message: Completions are lists, not cons cells. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/01/31 19:17:57 1.63 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/01 10:53:54 1.64 @@ -537,8 +537,7 @@ nil) (defun possibilities-for-menu (possibilities) - (loop for p in possibilities - for (display . object) = p + (loop for (display object) in possibilities collect `(,display :value ,object))) (defun possibility-printer (possibility ptype stream) @@ -782,7 +781,7 @@ (length initial-string)) initial-len) (incf nmatches) - (push (cons str obj) possibilities)))) + (push (list str obj) possibilities)))) (funcall generator initial-string #'suggester) (if (and (eql nmatches 1) (string-equal initial-string (caar possibilities))) @@ -798,7 +797,7 @@ (action :complete) (predicate (constantly t)) (name-key #'car) - (value-key #'cadr)) + (value-key #'cadar)) (flet ((generator (input-string suggester) (declare (ignore input-string)) (do-sequence (possibility completions) From thenriksen at common-lisp.net Fri Feb 1 12:01:10 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Feb 2008 07:01:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080201120110.CBE484814D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3669 Modified Files: input-editing.lisp Log Message: Added in-line completion using input-editor typeout instead of calling menu-choose. Does not work in Goatee. May fail under some circumstances that input-editor typeout doesn't handle well yet. May behave illogically because the list of completions is kept alive for fairly long, yet the presentations on it become untouchable almost immediately. This is because they are of a specially created completion presentation type, and not the more general presentation type of the object they represent. This knowledge is not accessible to the input-editing machinery (also, it seems presentation type options are compared for equality using EQ/EQL, so two content-wise identical possibility-lists can have different completion presentation types). --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/01 10:53:54 1.64 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/01 12:01:10 1.65 @@ -544,9 +544,30 @@ "A default function for printing a possibility. Suitable for used as value of `:possibility-printer' in calls to `complete-input'" - (destructuring-bind (string object) possibility - (with-output-as-presentation (stream object ptype) - (write-string string stream)))) + (with-output-as-presentation (stream possibility ptype) + (write-string (first possibility) stream))) + +(defun print-possibilities (possibilities possibility-printer stream) + "Write `possibitilies' to `stream', using +`possibility-printer'. `Possibilities' must be a list of +input-completion possibilities. `Stream' must be an input-editing +stream. Output will be done to its typeout." + (with-input-editor-typeout (stream :erase t) + (surrounding-output-with-border (stream :shape :drop-shadow :background +cornsilk1+) + (surrounding-output-with-border (stream :shape :rectangle) + (let* ((possibility-count (length possibilities)) + (row-length (sqrt possibility-count)) + (ptype `(completion ,possibilities))) + (formatting-table (stream) + (loop until (null possibilities) + do (formatting-row (stream) + (loop for cell-index from 0 below row-length + until (null possibilities) + do (formatting-cell (stream) + (funcall possibility-printer + (pop possibilities) + ptype + stream))))))))))) ;;; Helper returns gesture (or nil if gesture shouldn't be part of the input) ;;; and completion mode, if any. @@ -631,23 +652,17 @@ (format *trace-output* "nmatches = ~A, mode = ~A~%" nmatches mode)) (when (and (> nmatches 0) (eq mode :possibilities)) - (multiple-value-bind (menu-object item event) - (menu-choose (possibilities-for-menu possibilities) - :label "Possibilities" - :n-columns 1 - :printer #'(lambda (possibility stream) - ;; We have to get a - ;; presentation type from - ;; somewhere... - (destructuring-bind (string &key value) possibility - (funcall possibility-printer - (list string value) - (presentation-type-of value) - stream)))) - (declare (ignore event)) - (if item + (print-possibilities possibilities possibility-printer stream) + (let ((possibility + (handler-case + (with-input-context (`(completion ,possibilities) :override nil) + (object type event) + (prog1 nil (read-gesture :stream stream :peek-p t)) + (t object)) + (abort-gesture () nil)))) + (if possibility (setf (values input success object nmatches) - (values (car item) t menu-object 1)) + (values (first possibility) t (second possibility) 1)) (setf success nil nmatches 0)))) (unless (and (eq mode :complete) (not success)) From thenriksen at common-lisp.net Fri Feb 1 16:30:41 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Feb 2008 11:30:41 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080201163041.0F8A750044@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12728/Drei Modified Files: drei-redisplay.lisp Log Message: Fix redisplay bug where NIL would be used as a number. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/30 20:43:39 1.55 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/01 16:30:40 1.56 @@ -486,7 +486,7 @@ of the stroke." (loop with parts = (analyse-stroke-string stroke-string) with width = 0 - with widths = (make-array 1 :adjustable t :fill-pointer t) + with widths = (make-array 1 :adjustable t :fill-pointer t :initial-element 0) with tab-width for (start end object) in parts do (cond ((eql object #\Tab) From thenriksen at common-lisp.net Fri Feb 1 16:50:31 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Feb 2008 11:50:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080201165031.E5DA650030@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv19569/Drei Modified Files: input-editor.lisp Log Message: When adding input-editor typeout, also move down output records that only partially overlap with the typeout. This makes excessively grotesque and highly implementor-unfriendly prompts (like the one in, say, Beirc) move down as well. Remaining bugs seem to be about miscalculating the bounding rectangle of output borders. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/01 00:23:36 1.35 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/01 16:50:31 1.36 @@ -771,7 +771,7 @@ (map-over-output-records-overlapping-region #'(lambda (record) (multiple-value-bind (record-x record-y) (output-record-position record) - (when (>= record-y y) + (when (>= (+ record-y (bounding-rectangle-height record)) y) (setf (output-record-position record) (values record-x (+ record-y delta-y)))))) (stream-output-history sheet) From thenriksen at common-lisp.net Fri Feb 1 17:02:56 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Feb 2008 12:02:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080201170256.6640D48217@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25030 Modified Files: presentation-defs.lisp presentations.lisp Log Message: Moved with-input-context and related machinery to to presentations.lisp. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/01/31 12:14:05 1.74 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/02/01 17:02:55 1.75 @@ -685,122 +685,6 @@ (unless (and top-ptype (eql object top-object) (equal ptype top-ptype)) (presentation-history-insert history object ptype)))) -;;; Context-dependent input -;;; An input context is a cons of a presentation type and a continuation to -;;; call to return a presentation to that input context. - -(defvar *input-context* nil) - -(defun input-context-type (context-entry) - (car context-entry)) - -;;; Many presentation functions, internal and external, take an input -;;; context as an argument, but they really only need to look at one -;;; presentation type. -(defun make-fake-input-context (ptype) - (list (cons (expand-presentation-type-abbreviation ptype) - #'(lambda (object type event options) - (declare (ignore event options)) - (error "Fake input context called with object ~S type ~S. ~ - This shouldn't happen!" - object type))))) - -(defun input-context-wait-test (stream) - (let* ((queue (stream-input-buffer stream)) - (event (event-queue-peek queue))) - (when event - (let ((sheet (event-sheet event))) - (when (and (output-recording-stream-p sheet) - (or (typep event 'pointer-event) - (typep event 'keyboard-event)) - (not (gadgetp sheet))) - (return-from input-context-wait-test t)))) - nil)) - -(defun highlight-applicable-presentation (frame stream input-context - &optional (prefer-pointer-window t)) - (let* ((queue (stream-input-buffer stream)) - (event (event-queue-peek queue))) - (when (and event - (or (and (typep event 'pointer-event) - (or prefer-pointer-window - (eq stream (event-sheet event)))) - (typep event 'keyboard-event))) - ;; Stream only needs to see button press events. - ;; XXX Need to think about this more. Should any pointer events be - ;; passed through? If there's no presentation, maybe? - (unless (typep event 'keyboard-event) - (event-queue-read queue)) - (progn - (frame-input-context-track-pointer frame - input-context - (event-sheet event) - event) - (when (typep event 'pointer-button-press-event) - (funcall *pointer-button-press-handler* stream event))) - #+nil - (if (and (typep event 'pointer-motion-event) - (pointer-event-button event)) - (frame-drag frame input-context (event-sheet event) event) - )))) - -(defun input-context-event-handler (stream) - (highlight-applicable-presentation *application-frame* - stream - *input-context*)) - -(defun input-context-button-press-handler (stream button-event) - (declare (ignore stream)) - (frame-input-context-button-press-handler *application-frame* - (event-sheet button-event) - button-event)) - -(defun highlight-current-presentation (frame input-context) - (let ((event (synthesize-pointer-motion-event (port-pointer - (port - *application-frame*))))) - (when event - (frame-input-context-track-pointer frame - input-context - (event-sheet event) - event)))) - -(defmacro with-input-context ((type &key override) - (&optional (object-var (gensym)) - (type-var (gensym)) - event-var - options-var) - form - &body pointer-cases) - (let ((vars `(,object-var - ,type-var - ,@(and event-var `(,event-var)) - ,@(and options-var `(,options-var)))) - (return-block (gensym "RETURN-BLOCK")) - (context-block (gensym "CONTEXT-BLOCK"))) - `(block ,return-block - (multiple-value-bind ,vars - (block ,context-block - (let ((*input-context* - (cons (cons (expand-presentation-type-abbreviation ,type) - #'(lambda (object type event options) - (return-from ,context-block - (values object type event options)))) - ,(if override nil '*input-context*))) - (*pointer-button-press-handler* - #'input-context-button-press-handler) - (*input-wait-test* #'input-context-wait-test) - (*input-wait-handler* #'input-context-event-handler)) - (return-from ,return-block ,form ))) - (declare (ignorable , at vars)) - (highlight-current-presentation *application-frame* *input-context*) - (cond ,@(mapcar #'(lambda (pointer-case) - (destructuring-bind (case-type &body case-body) - pointer-case - `((presentation-subtypep ,type-var ',case-type) - , at case-body))) - pointer-cases)))))) - (define-presentation-generic-function %accept accept (type-key parameters options type stream view &key)) --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2008/01/31 12:14:05 1.84 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2008/02/01 17:02:55 1.85 @@ -1978,4 +1978,120 @@ (map-over-output-records (lambda (child) (highlight-output-record child stream state)) - record)) \ No newline at end of file + record)) + +;;; Context-dependent input +;;; An input context is a cons of a presentation type and a continuation to +;;; call to return a presentation to that input context. + +(defvar *input-context* nil) + +(defun input-context-type (context-entry) + (car context-entry)) + +;;; Many presentation functions, internal and external, take an input +;;; context as an argument, but they really only need to look at one +;;; presentation type. +(defun make-fake-input-context (ptype) + (list (cons (expand-presentation-type-abbreviation ptype) + #'(lambda (object type event options) + (declare (ignore event options)) + (error "Fake input context called with object ~S type ~S. ~ + This shouldn't happen!" + object type))))) + +(defun input-context-wait-test (stream) + (let* ((queue (stream-input-buffer stream)) + (event (event-queue-peek queue))) + (when event + (let ((sheet (event-sheet event))) + (when (and (output-recording-stream-p sheet) + (or (typep event 'pointer-event) + (typep event 'keyboard-event)) + (not (gadgetp sheet))) + (return-from input-context-wait-test t)))) + nil)) + +(defun highlight-applicable-presentation (frame stream input-context + &optional (prefer-pointer-window t)) + (let* ((queue (stream-input-buffer stream)) + (event (event-queue-peek queue))) + (when (and event + (or (and (typep event 'pointer-event) + (or prefer-pointer-window + (eq stream (event-sheet event)))) + (typep event 'keyboard-event))) + ;; Stream only needs to see button press events. + ;; XXX Need to think about this more. Should any pointer events be + ;; passed through? If there's no presentation, maybe? + (unless (typep event 'keyboard-event) + (event-queue-read queue)) + (progn + (frame-input-context-track-pointer frame + input-context + (event-sheet event) + event) + (when (typep event 'pointer-button-press-event) + (funcall *pointer-button-press-handler* stream event))) + #+nil + (if (and (typep event 'pointer-motion-event) + (pointer-event-button event)) + (frame-drag frame input-context (event-sheet event) event) + )))) + +(defun input-context-event-handler (stream) + (highlight-applicable-presentation *application-frame* + stream + *input-context*)) + +(defun input-context-button-press-handler (stream button-event) + (declare (ignore stream)) + (frame-input-context-button-press-handler *application-frame* + (event-sheet button-event) + button-event)) + +(defun highlight-current-presentation (frame input-context) + (let ((event (synthesize-pointer-motion-event (port-pointer + (port + *application-frame*))))) + (when event + (frame-input-context-track-pointer frame + input-context + (event-sheet event) + event)))) + +(defmacro with-input-context ((type &key override) + (&optional (object-var (gensym)) + (type-var (gensym)) + event-var + options-var) + form + &body pointer-cases) + (let ((vars `(,object-var + ,type-var + ,@(and event-var `(,event-var)) + ,@(and options-var `(,options-var)))) + (return-block (gensym "RETURN-BLOCK")) + (context-block (gensym "CONTEXT-BLOCK"))) + `(block ,return-block + (multiple-value-bind ,vars + (block ,context-block + (let ((*input-context* + (cons (cons (expand-presentation-type-abbreviation ,type) + #'(lambda (object type event options) + (return-from ,context-block + (values object type event options)))) + ,(if override nil '*input-context*))) + (*pointer-button-press-handler* + #'input-context-button-press-handler) + (*input-wait-test* #'input-context-wait-test) + (*input-wait-handler* #'input-context-event-handler)) + (return-from ,return-block ,form ))) + (declare (ignorable , at vars)) + (highlight-current-presentation *application-frame* *input-context*) + (cond ,@(mapcar #'(lambda (pointer-case) + (destructuring-bind (case-type &body case-body) + pointer-case + `((presentation-subtypep ,type-var ',case-type) + , at case-body))) + pointer-cases)))))) From thenriksen at common-lisp.net Fri Feb 1 17:10:53 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Feb 2008 12:10:53 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080201171053.BA85D461B5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27677/Drei Modified Files: drei-clim.lisp Log Message: Explicitly rebind *standard-input* for Drei gadget panes. Some truly non-CLIM-like applications may never define an interactor or anything like that, and so may inherit the *standard-input* from SLIME or something like that. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/31 16:50:07 1.39 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/02/01 17:10:53 1.40 @@ -288,7 +288,8 @@ (defmethod handle-gesture ((drei drei-gadget-pane) gesture) (let ((*command-processor* drei) - (*abort-gestures* *esa-abort-gestures*)) + (*abort-gestures* *esa-abort-gestures*) + (*standard-input* drei)) (accepting-from-user (drei) (handler-case (process-gesture drei gesture) (unbound-gesture-sequence (c) From pw at snoopy.mv.com Fri Feb 1 17:34:07 2008 From: pw at snoopy.mv.com (Paul Werkowski) Date: Fri, 01 Feb 2008 12:34:07 -0500 Subject: [mcclim-cvs] CVS mcclim/Drei In-Reply-To: <20080201171053.BA85D461B5@common-lisp.net> References: <20080201171053.BA85D461B5@common-lisp.net> Message-ID: <47A3580F.6080108@snoopy.mv.com> thenriksen wrote: > Update of /project/mcclim/cvsroot/mcclim/Drei > In directory clnet:/tmp/cvs-serv27677/Drei > > Modified Files: > drei-clim.lisp > Log Message: > Explicitly rebind *standard-input* for Drei gadget panes. > > Some truly non-CLIM-like applications may never define an interactor > or anything like that, and so may inherit the *standard-input* from > SLIME or something like that. > "truly non-CLIM apps"? Maybe that should be "truly non-McCLIM apps". If fact, I have never written a CLIM application that used an interactor pane. Mostly I use application-pane or subclass thereof and occasionaly throw in an accept-values-pane. Input is from presentation interaction or accepting-values dialog. I seem to remember that not having interactor pane caused me some difficulties trying to port these apps to McCLIM. Paul From athas at sigkill.dk Fri Feb 1 17:56:22 2008 From: athas at sigkill.dk (Troels Henriksen) Date: Fri, 01 Feb 2008 18:56:22 +0100 Subject: [mcclim-cvs] CVS mcclim/Drei In-Reply-To: <47A3580F.6080108@snoopy.mv.com> (Paul Werkowski's message of "Fri, 01 Feb 2008 12:34:07 -0500") References: <20080201171053.BA85D461B5@common-lisp.net> <47A3580F.6080108@snoopy.mv.com> Message-ID: <87ir18r261.fsf@lambda.athas.dyndns.dk> Paul Werkowski writes: > "truly non-CLIM apps"? Maybe that should be "truly non-McCLIM apps". Oh, I know that most real CLIM applications don't support my rather opinionated view of what a CLIM program is. :-) > If fact, I have never written a CLIM application that used an interactor > pane. Mostly I use application-pane or subclass thereof and > occasionaly throw in an accept-values-pane. Input is from > presentation interaction or accepting-values dialog. > > I seem to remember that not having interactor pane caused me some > difficulties trying to port these apps to McCLIM. If problems like these still exist, they are considered bugs. Please report them, so that they can be fixed. -- \ Troels /\ Henriksen From thenriksen at common-lisp.net Fri Feb 1 18:12:31 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Feb 2008 13:12:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080201181231.8985B461AA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv11347 Modified Files: mcclim.asd Log Message: Moved bordered-output.lisp and table-formatting.lisp earlier in the loading process. (antifuchs, please save me from this maze of twisty dependencies! They'are all alike!) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/31 12:14:05 1.75 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/02/01 18:12:31 1.76 @@ -219,15 +219,13 @@ :components ((:file "text-formatting") (:file "defresource") (:file "presentations") - (:file "input-editing" :depends-on ("presentations")) + (:file "bordered-output" :depends-on ("presentations")) + (:file "table-formatting" :depends-on ("presentations")) + (:file "input-editing" :depends-on ("presentations" "bordered-output" "table-formatting")) (:file "pointer-tracking" :depends-on ("input-editing")) (:file "graph-formatting") (:file "frames" :depends-on ("commands" "presentations" "presentation-defs" "pointer-tracking" "incremental-redisplay")) - (:file "table-formatting" :depends-on ("presentation-defs" "panes" - "presentations" "input-editing")) - (:file "bordered-output" :depends-on ("input-editing" "incremental-redisplay" - "presentation-defs" "panes")) (:file "dialog-views" :depends-on ("presentations" "incremental-redisplay" "bordered-output" "presentation-defs")) (:file "presentation-defs" :depends-on ("input-editing" "presentations")) From thenriksen at common-lisp.net Fri Feb 1 18:48:56 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Feb 2008 13:48:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080201184856.B73501F112@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv23245/Apps/Listener Modified Files: listener.lisp Log Message: Replace the sharp bracket in the Listener prompt by an actual arrow. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/01/06 01:33:25 1.38 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/02/01 18:48:56 1.39 @@ -145,9 +145,18 @@ (defun print-listener-prompt (stream frame) (declare (ignore frame)) (with-text-face (stream :italic) - (with-output-as-presentation (stream *package* 'package :single-box t) - (print-package-name stream)) - (princ "> " stream))) + (let* ((text-style-width (text-style-width (medium-default-text-style stream) stream)) + (arrow-width (* 2 text-style-width)) + (prompt-height + (bounding-rectangle-height + (with-output-as-presentation (stream *package* 'package :single-box t) + (print-package-name stream))))) + (multiple-value-bind (x y) (stream-cursor-position stream) + (draw-arrow* stream x (+ y (/ prompt-height 2)) + (+ x arrow-width) (+ y (/ prompt-height 2)) + :head-length (/ text-style-width 2) + :head-width (floor (/ prompt-height 2)))) + (stream-increment-cursor-position stream (+ arrow-width text-style-width) 0)))) (defmethod frame-standard-output ((frame listener)) (get-frame-pane frame 'interactor)) From thenriksen at common-lisp.net Fri Feb 1 20:28:46 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Feb 2008 15:28:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080201202846.26F6F46123@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv19045/Drei Modified Files: input-editor.lisp Log Message: Implemented generic input-editor typeout, provided we can get an output record for the input editor. Theoretically, the nice typeout implementation should now also work for Goatee, though I seem to have broken it at some other point. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/01 16:50:31 1.36 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/01 20:28:45 1.37 @@ -46,13 +46,7 @@ :initform nil :documentation "After a command has been executed, the contents of the Drei area instance shall be -replaced by the contents of this array, if non-NIL.") - (%typeout-record :accessor typeout-record - :initform nil - :documentation "The output record (if any) -that is the typeout information for this Drei-based -input-editing-stream. `With-input-editor-typeout' manages this -output record.")) +replaced by the contents of this array, if non-NIL.")) (:documentation "An mixin that helps in implementing Drei-based input-editing streams. This class should not be directly instantiated.")) @@ -754,73 +748,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; `With-input-editor-typeout' -;;; -;;; Clears some space above the input-editing stream, moving other -;;; output records on the sheet down, and prints the output. Nothing -;;; is displayed until after the with-input-editor-typeout body is -;;; done. - -(defun sheet-move-output-vertically (sheet y delta-y) - "Move the output records of `sheet', starting at vertical -device unit offset `y' or below, down by `delta-y' device units, -then repaint `sheet'." - (unless (zerop delta-y) - (with-bounding-rectangle* (sheet-x1 sheet-y1 sheet-x2 sheet-y2) sheet - (declare (ignore sheet-x1 sheet-y1)) - (map-over-output-records-overlapping-region - #'(lambda (record) - (multiple-value-bind (record-x record-y) (output-record-position record) - (when (>= (+ record-y (bounding-rectangle-height record)) y) - (setf (output-record-position record) - (values record-x (+ record-y delta-y)))))) - (stream-output-history sheet) - (make-bounding-rectangle 0 y sheet-x2 sheet-y2)) - ;; Only repaint within the visible region... - (with-bounding-rectangle* (viewport-x1 viewport-y1 viewport-x2 viewport-y2) - (or (pane-viewport-region sheet) sheet) - (declare (ignore viewport-y1)) - (repaint-sheet sheet (make-bounding-rectangle viewport-x1 (- y (abs delta-y)) - viewport-x2 viewport-y2)))))) - -(defmethod climi::invoke-with-input-editor-typeout ((editing-stream drei-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 (drei-instance editing-stream))) - (with-accessors ((stream-typeout-record typeout-record)) editing-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)))) - ;; 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)))) - (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)) - (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))) - ;; 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))))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; Presentation type specialization. ;;; When starting out with reading `command-or-form', we use Lisp From thenriksen at common-lisp.net Fri Feb 1 20:28:46 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Feb 2008 15:28:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080201202846.9D4515004C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19045 Modified Files: commands.lisp input-editing-drei.lisp input-editing-goatee.lisp input-editing.lisp Log Message: Implemented generic input-editor typeout, provided we can get an output record for the input editor. Theoretically, the nice typeout implementation should now also work for Goatee, though I seem to have broken it at some other point. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2008/01/29 22:27:11 1.75 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/02/01 20:28:46 1.76 @@ -1225,7 +1225,7 @@ ;;; In order for this to work, the input-editing-stream must implement ;;; a method for the nonstandard function -;;; `input-editing-stream-bounding-rectangle'. +;;; `input-editing-stream-output-record'. (defun command-line-read-remaining-arguments-for-partial-command (command-table stream partial-command start-position) (declare (ignore start-position)) @@ -1233,8 +1233,7 @@ *command-parser-table*)))) (if (encapsulating-stream-p stream) (let ((interactor (encapsulating-stream-stream stream))) - (multiple-value-bind (x1 y1 x2 y2) - (input-editing-stream-bounding-rectangle stream) + (with-bounding-rectangle (x1 y1 x2 y2) (input-editing-stream-output-record stream) (declare (ignore y1 x2)) ;; Start the dialog below the editor area (letf (((stream-cursor-position interactor) (values x1 y2))) --- /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/01/31 19:17:57 1.11 +++ /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/02/01 20:28:46 1.12 @@ -31,6 +31,7 @@ (defclass standard-input-editing-stream (drei:drei-input-editing-mixin empty-input-mixin + standard-input-editing-mixin input-editing-stream standard-encapsulating-stream) ((scan-pointer :accessor stream-scan-pointer :initform 0) @@ -119,7 +120,7 @@ ((stream-drawing-p real-stream) (replay record real-stream) )) (setf (stream-cursor-position real-stream) - (values 0 (nth-value 3 (input-editing-stream-bounding-rectangle stream)))))) + (values 0 (bounding-rectangle-max-y (input-editing-stream-output-record stream)))))) ;; XXX: We are supposed to implement input editing for all ;; "interactive streams", but that's not really reasonable. We only @@ -152,8 +153,8 @@ (setf (rescan-queued stream) nil) (immediate-rescan stream))) -(defmethod input-editing-stream-bounding-rectangle ((stream standard-input-editing-stream)) - (bounding-rectangle* (view (drei:drei-instance stream)))) +(defmethod input-editing-stream-output-record ((stream standard-input-editing-stream)) + (drei:drei-instance stream)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/input-editing-goatee.lisp 2008/01/30 15:58:14 1.2 +++ /project/mcclim/cvsroot/mcclim/input-editing-goatee.lisp 2008/02/01 20:28:46 1.3 @@ -27,6 +27,7 @@ (defclass goatee-input-editing-stream (empty-input-mixin goatee:goatee-input-editing-mixin + standard-input-editing-mixin input-editing-stream standard-encapsulating-stream) ((buffer :reader stream-input-buffer @@ -149,5 +150,5 @@ (setf (rescan-queued stream) nil) (immediate-rescan stream))) -(defmethod input-editing-stream-bounding-rectangle ((stream goatee-input-editing-stream)) - (bounding-rectangle* (area stream))) \ No newline at end of file +(defmethod input-editing-stream-output-record ((stream goatee-input-editing-stream)) + (area stream)) --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/01 12:01:10 1.65 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/01 20:28:46 1.66 @@ -57,6 +57,16 @@ (:method (stream) (cl:interactive-stream-p stream)))) +(defclass standard-input-editing-mixin () + ((%typeout-record :accessor typeout-record + :initform nil + :documentation "The output record (if any) +that is the typeout information for this +input-editing-stream. `With-input-editor-typeout' manages this +output record.")) + (:documentation "A mixin implementing some useful standard +behavior for input-editing streams.")) + ;;; These helper functions take the arguments of ACCEPT so that they ;;; can be used directly by ACCEPT. @@ -167,6 +177,93 @@ do (return t) finally (return nil))) +(defmacro with-input-editor-typeout ((&optional (stream t) &rest args + &key erase) + &body body) + "Clear space above the input-editing stream `stream' and +evaluate `body', capturing output done to `stream'. Place will be +obtained above the input-editing area and the output put +there. Nothing will be displayed until `body' finishes. `Stream' +is not evaluated and must be a symbol. If T (the default), +`*standard-input*' will be used. `Stream' will be bound to an +`extended-output-stream' while `body' is being evaluated." + (declare (ignore erase)) + (check-type stream symbol) + (let ((stream (if (eq stream t) '*standard-output* stream))) + `(invoke-with-input-editor-typeout + ,stream + #'(lambda (,stream) + , at body) + , at args))) + +(defgeneric invoke-with-input-editor-typeout (stream continuation &key erase) + (:documentation "Call `continuation' with a single argument, a +stream to do input-editor-typeout on.")) + +(defun sheet-move-output-vertically (sheet y delta-y) + "Move the output records of `sheet', starting at vertical +device unit offset `y' or below, down by `delta-y' device units, +then repaint `sheet'." + (unless (zerop delta-y) + (with-bounding-rectangle* (sheet-x1 sheet-y1 sheet-x2 sheet-y2) sheet + (declare (ignore sheet-x1 sheet-y1)) + (map-over-output-records-overlapping-region + #'(lambda (record) + (multiple-value-bind (record-x record-y) (output-record-position record) + (when (>= (+ record-y (bounding-rectangle-height record)) y) + (setf (output-record-position record) + (values record-x (+ record-y delta-y)))))) + (stream-output-history sheet) + (make-bounding-rectangle 0 y sheet-x2 sheet-y2)) + ;; Only repaint within the visible region... + (with-bounding-rectangle* (viewport-x1 viewport-y1 viewport-x2 viewport-y2) + (or (pane-viewport-region sheet) sheet) + (declare (ignore viewport-y1)) + (repaint-sheet sheet (make-bounding-rectangle viewport-x1 (- y (abs delta-y)) + viewport-x2 viewport-y2)))))) + +(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-sheet-medium (medium encapsulated-stream) + (setf (output-record-position new-typeout-record) + (values 0 (bounding-rectangle-min-y (or stream-typeout-record editor-record)))) + ;; 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)))) + (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)) + (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))) + ;; 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))))))))) + +(defun clear-typeout (&optional (stream t)) + "Blank out the input-editor typeout displayed on `stream', +defaulting to T for `*standard-output*'." + (with-input-editor-typeout (stream :erase t) + (declare (ignore stream)))) + (defmacro with-input-editing ((&optional (stream t) &rest args &key input-sensitizer (initial-contents "") @@ -219,27 +316,6 @@ (stream-scan-pointer ,stream-var)))) , at body))) -(defmacro with-input-editor-typeout ((&optional (stream t) &rest args - &key erase) - &body body) - "`Stream' is not evaluated and must be a symbol. If T (the -default), `*standard-input*' will be used. `Stream' will be bound -to an `extended-output-stream' while `body' is being evaluated." - (declare (ignore erase)) - (check-type stream symbol) - (let ((stream (if (eq stream t) '*standard-output* stream))) - `(invoke-with-input-editor-typeout - ,stream - #'(lambda (,stream) - , at body) - , at args))) - -(defun clear-typeout (&optional (stream t)) - "Blank out the input-editor typeout displayed on `stream', -defaulting to T for `*standard-output*'." - (with-input-editor-typeout (stream :erase t) - (declare (ignore stream)))) - (defun input-editing-rescan-loop (editing-stream continuation) (let ((start-scan-pointer (stream-scan-pointer editing-stream))) (loop (block rescan @@ -301,14 +377,11 @@ (with-activation-gestures (*standard-activation-gestures*) (call-next-method))) -(defgeneric invoke-with-input-editor-typeout (stream continuation &key erase) - (:documentation "Call `continuation' with a single argument, a -stream to do input-editor-typeout on.")) - -(defgeneric input-editing-stream-bounding-rectangle (stream) - (:documentation "Return the bounding rectangle of `stream' as -four values. This function does not appear in the spec but is -used by the command processing code for layout.")) +(defgeneric input-editing-stream-output-record (stream) + (:documentation "Return the output record showing the display of the +input-editing stream `stream' values. This function does not +appear in the spec but is used by the command processing code for +layout and to implement a general with-input-editor-typeout.")) (defmethod input-editor-format ((stream t) format-string &rest format-args) (unless (and (typep stream '#.*string-input-stream-class*) From thenriksen at common-lisp.net Fri Feb 1 22:28:24 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Feb 2008 17:28:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080201222824.102CE70EB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv24346/Drei Modified Files: drei-redisplay.lisp Log Message: Make Drei a nicer CLIM citizen by not drawing white rectangles over large swaths of the output pane. (Unless it has to.) --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/01 16:30:40 1.56 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/01 22:28:15 1.57 @@ -641,11 +641,14 @@ (setf (stroke-start-offset stroke) nil)))) (defun draw-line-strokes (pane view initial-pump-state - start-offset cursor-x cursor-y) + start-offset cursor-x cursor-y + view-width) "Pump strokes from `view', using `initial-pump-state' to begin with, and draw them on `pane'. The line is set to start at the buffer offset `start-offset', and will be drawn starting -at (`cursor-x', `cursor-y')." +at (`cursor-x', `cursor-y'). `View-width' is the width of the +view in device units, as calculated by the previous output +iteration." (let* ((line (line-information view (displayed-lines-count view))) (orig-x-offset cursor-x) (offset-change (- start-offset (line-start-offset line))) @@ -687,7 +690,7 @@ (maybe-clear last-clear-x (x1 stroke-dimensions)) (setf last-clear-x (x2 stroke-dimensions))) ;; This clears from end of line to the end of the sheet. - finally (maybe-clear last-clear-x (bounding-rectangle-width pane)))) + finally (maybe-clear last-clear-x (+ last-clear-x view-width)))) ;; Now actually draw them in a way that makes sure they all ;; touch the bottom of the line. (loop for stroke-index below (line-stroke-count line) @@ -699,12 +702,10 @@ (incf (displayed-lines-count view)) (return (values pump-state line-height)))))))) -(defun clear-stale-lines (pane view) +(defun clear-stale-lines (pane view old-width old-height) "Clear from the last displayed line to the end of `pane' and -mark undisplayed line objects as dirty." - (let ((line-dimensions (line-dimensions (last-displayed-line view)))) - (clear-rectangle* pane (x1 line-dimensions) (y2 line-dimensions) - (bounding-rectangle-width pane) (bounding-rectangle-height pane))) +mark undisplayed line objects as dirty. `Old-width'/`old-height' +are the old dimensions of the display of `view' in device units." ;; This way, strokes of lines that have at one point been left ;; undisplayed will always be considered modified when they are ;; filled again. The return is for optimisation, we know that an @@ -714,7 +715,11 @@ (do-undisplayed-line-strokes (stroke line) (if (null (stroke-start-offset stroke)) (return) - (setf (stroke-start-offset stroke) nil))))) + (setf (stroke-start-offset stroke) nil)))) + (with-bounding-rectangle* (x1 y1 x2 y2) view + (declare (ignore x2)) + (when (> old-height (- y2 y1)) + (clear-rectangle* pane x1 y2 (+ x1 old-width) (+ y1 old-height))))) (defvar *maximum-chunk-size* 100 "The maximum amount of objects put into a stroke by a @@ -798,25 +803,29 @@ actual-end-offset))) (defmethod display-drei-view-contents ((pane basic-pane) (view drei-buffer-view)) - (setf (displayed-lines-count view) 0 - (max-line-width view) 0) - (multiple-value-bind (cursor-x cursor-y) (stream-cursor-position pane) - (with-output-recording-options (pane :record nil :draw t) - (loop with start-offset = (offset (beginning-of-line (top view))) - with pump-state = (pump-state-for-offset view start-offset) - with pane-height = (bounding-rectangle-height (or (pane-viewport pane) pane)) - for line = (line-information view (displayed-lines-count view)) - do (multiple-value-bind (new-pump-state line-height) - (draw-line-strokes pane view pump-state start-offset cursor-x cursor-y) - (setf pump-state new-pump-state - start-offset (1+ (line-end-offset line))) - (incf cursor-y (+ line-height (stream-vertical-spacing pane)))) - when (or (and (not (extend-pane-bottom view)) - (>= (y2 (line-dimensions line)) pane-height)) - (= (line-end-offset line) (size (buffer view)))) - return (progn - (setf (offset (bot view)) (line-end-offset line)) - (clear-stale-lines pane view)))))) + (with-bounding-rectangle* (x1 y1 x2 y2) view + (let ((old-width (- x2 x1)) + (old-height (- y2 y1))) + (setf (displayed-lines-count view) 0 + (max-line-width view) 0) + (multiple-value-bind (cursor-x cursor-y) (stream-cursor-position pane) + (with-output-recording-options (pane :record nil :draw t) + (loop with start-offset = (offset (beginning-of-line (top view))) + with pump-state = (pump-state-for-offset view start-offset) + with pane-height = (bounding-rectangle-height (or (pane-viewport pane) pane)) + for line = (line-information view (displayed-lines-count view)) + do (multiple-value-bind (new-pump-state line-height) + (draw-line-strokes pane view pump-state start-offset + cursor-x cursor-y old-width) + (setf pump-state new-pump-state + start-offset (1+ (line-end-offset line))) + (incf cursor-y (+ line-height (stream-vertical-spacing pane)))) + when (or (and (not (extend-pane-bottom view)) + (>= (y2 (line-dimensions line)) pane-height)) + (= (line-end-offset line) (size (buffer view)))) + return (progn + (setf (offset (bot view)) (line-end-offset line)) + (clear-stale-lines pane view old-width old-height)))))))) (defun offset-in-stroke-position (stream view stroke offset) "Calculate the position in device units of `offset' in @@ -947,7 +956,12 @@ ((coordinates-intersects-dimensions (stroke-dimensions stroke) x1 y1 x2 y2) (setf (stroke-dirty stroke) t) - (setf (stroke-modified stroke) t)))))))))))) + (setf (stroke-modified stroke) t)))))))) + (with-bounding-rectangle* (vx1 vy1 vx2 vy2) view + (declare (ignore vy1 vx2 vy2)) + (setf (max-line-width view) + (max (max-line-width view) + (- x2 vx1)))))))) (defmethod display-drei-view-cursor ((stream extended-output-stream) (view drei-buffer-view) @@ -982,20 +996,8 @@ (defun drei-bounding-rectangle* (drei-instance) "Return the bounding rectangle of the visual appearance of -`drei-instance' as four values, just as -`bounding-rectangle*'. Takes the cursors of `drei-instance' into -account." - (multiple-value-bind (x1 y1 x2 y2) - (bounding-rectangle* (view drei-instance)) - (dolist (cursor (cursors drei-instance)) - (multiple-value-bind (cursor-x1 cursor-y1 cursor-x2 cursor-y2) - (bounding-rectangle* cursor) - (unless (= cursor-x1 cursor-y1 cursor-x2 cursor-y2 0) - (setf x1 (min x1 cursor-x1) - y1 (min y1 cursor-y1) - x2 (max x2 cursor-x2) - y2 (max y2 cursor-y2))))) - (values x1 y1 x2 y2))) +`drei-instance' as four values, just as `bounding-rectangle*'." + (bounding-rectangle* (view drei-instance))) (defun drei-bounding-rectangle-width (drei-instance) "Return the width of the bounding rectangle of `drei-instance', From thenriksen at common-lisp.net Sat Feb 2 00:10:19 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 1 Feb 2008 19:10:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080202001019.3AE5350044@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20235 Modified Files: commands.lisp Log Message: Fix typo, with-bounding-rectangle -> with-bounding-rectangle*. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2008/02/01 20:28:46 1.76 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/02/02 00:10:18 1.77 @@ -1233,7 +1233,7 @@ *command-parser-table*)))) (if (encapsulating-stream-p stream) (let ((interactor (encapsulating-stream-stream stream))) - (with-bounding-rectangle (x1 y1 x2 y2) (input-editing-stream-output-record stream) + (with-bounding-rectangle* (x1 y1 x2 y2) (input-editing-stream-output-record stream) (declare (ignore y1 x2)) ;; Start the dialog below the editor area (letf (((stream-cursor-position interactor) (values x1 y2))) From thenriksen at common-lisp.net Sat Feb 2 19:02:05 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 2 Feb 2008 14:02:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080202190205.24BEF461BB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27256/Drei Modified Files: input-editor.lisp Log Message: Fixed copy/pasting of text containing spaces in Drei. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/01 20:28:45 1.37 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/02 19:02:03 1.38 @@ -483,62 +483,59 @@ (activation-gesture activation-gesture)) stream (let ((buffer (buffer (view (drei-instance stream)))) (last-was-noisy nil)) ; T if last passed gesture is noise-string - (loop - (loop - while (< scan-pointer insertion-pointer) - while (< scan-pointer (size buffer)) - do (let ((gesture (buffer-object buffer scan-pointer))) - ;; Skip noise strings. - (cond ((typep gesture 'noise-string) - (incf scan-pointer) - (setf last-was-noisy t)) - ((and (not peek-p) - (typep gesture 'accept-result)) - (incf scan-pointer) - #+(or mcclim building-mcclim) - (climi::throw-object-ptype (object gesture) - (result-type gesture))) - ;; Note that this implies that - ;; `stream-read-gesture' may return accept - ;; results, which might as well be arbitrary - ;; objects to the code calling - ;; `stream-read-gesture', since it can't really - ;; do anything with them except for asserting - ;; that they exist. According to the spec, - ;; "accept results are treated as a single - ;; gesture", and this kind of behavior is - ;; necessary to make sure `stream-read-gesture' - ;; doesn't simply claim that there are no more - ;; gestures in the input-buffer when the - ;; remaining gesture(s) is an accept result. - ((typep gesture 'accept-result) - (return-from stream-read-gesture gesture)) - (t - (unless peek-p - (incf scan-pointer)) - (return-from stream-read-gesture gesture)) - (t (incf scan-pointer) - (setf last-was-noisy nil))))) - (unless last-was-noisy ; This prevents double-prompting. - (setf (stream-rescanning stream) nil)) - (when activation-gesture - (return-from stream-read-gesture - (prog1 activation-gesture - (unless peek-p - (setf activation-gesture nil))))) - ;; In McCLIM, stream-process-gesture is responsible for - ;; inserting characters into the buffer, changing the - ;; insertion pointer and possibly setting up the - ;; activation-gesture slot. - (loop - with gesture and type - do (setf (values gesture type) - (apply #'stream-read-gesture - (encapsulating-stream-stream stream) rest-args)) - when (null gesture) - do (return-from stream-read-gesture (values gesture type)) - when (stream-process-gesture stream gesture type) - do (loop-finish))))))) + (loop (loop while (< scan-pointer insertion-pointer) + while (< scan-pointer (size buffer)) + do (let ((gesture (buffer-object buffer scan-pointer))) + ;; Skip noise strings. + (cond ((typep gesture 'noise-string) + (incf scan-pointer) + (setf last-was-noisy t)) + ((and (not peek-p) + (typep gesture 'accept-result)) + (incf scan-pointer) + #+(or mcclim building-mcclim) + (climi::throw-object-ptype (object gesture) + (result-type gesture))) + ;; Note that this implies that + ;; `stream-read-gesture' may return accept + ;; results, which might as well be arbitrary + ;; objects to the code calling + ;; `stream-read-gesture', since it can't really + ;; do anything with them except for asserting + ;; that they exist. According to the spec, + ;; "accept results are treated as a single + ;; gesture", and this kind of behavior is + ;; necessary to make sure `stream-read-gesture' + ;; doesn't simply claim that there are no more + ;; gestures in the input-buffer when the + ;; remaining gesture(s) is an accept result. + ((typep gesture 'accept-result) + (return-from stream-read-gesture gesture)) + (t + (unless peek-p + (incf scan-pointer)) + (return-from stream-read-gesture gesture)) + (t (incf scan-pointer) + (setf last-was-noisy nil))))) + (unless last-was-noisy ; This prevents double-prompting. + (setf (stream-rescanning stream) nil)) + (when activation-gesture + (return-from stream-read-gesture + (prog1 activation-gesture + (unless peek-p + (setf activation-gesture nil))))) + ;; In McCLIM, stream-process-gesture is responsible for + ;; inserting characters into the buffer, changing the + ;; insertion pointer and possibly setting up the + ;; activation-gesture slot. + (loop with gesture and type + do (setf (values gesture type) + (apply #'stream-read-gesture + (encapsulating-stream-stream stream) rest-args)) + when (null gesture) + do (return-from stream-read-gesture (values gesture type)) + when (stream-process-gesture stream gesture type) + do (loop-finish))))))) (defmethod stream-unread-gesture ((stream drei-input-editing-mixin) gesture) From thenriksen at common-lisp.net Sat Feb 2 19:02:05 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 2 Feb 2008 14:02:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080202190205.A3DEB55531@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv27256/ESA Modified Files: esa-command-parser.lisp Log Message: Fixed copy/pasting of text containing spaces in Drei. --- /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2008/01/04 21:56:29 1.4 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2008/02/02 19:02:05 1.5 @@ -111,7 +111,7 @@ (keyword-args (climi::keyword-args info))) ;; keyword arguments not yet supported (declare (ignore keyword-args)) - (let (result) + (let (result arg-parsed) ;; only required args for now. (do* ((required-args required-args (cdr required-args)) (arg (car required-args) (car required-args)) @@ -120,9 +120,11 @@ ((null required-args) (cons command-name (nreverse result))) (destructuring-bind (name ptype &rest args) arg (push (cond ((eq command-arg *unsupplied-argument-marker*) + (setf arg-parsed t) (esa-parse-one-arg stream name ptype args)) ((eq command-arg *numeric-argument-marker*) (or numeric-argument (getf args :default))) (t (eval command-arg))) result) - (maybe-clear-input))))))))))) + (when arg-parsed + (maybe-clear-input)))))))))))) From thenriksen at common-lisp.net Sat Feb 2 19:03:00 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 2 Feb 2008 14:03:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080202190300.7F7D47C067@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv27372 Modified Files: recording.lisp Log Message: Output recording bandaids: Use CLIM 2.2 region default for replay. Don't assume every parent output record is a compound-output-record. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2008/01/21 22:24:32 1.137 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2008/02/02 19:03:00 1.138 @@ -401,7 +401,8 @@ (with-bounding-rectangle* (min-x min-y max-x max-y) record (call-next-method) (let ((parent (output-record-parent record))) - (when (and parent (not (slot-value parent 'in-moving-p))) + (when (and parent (not (and (typep parent 'compound-output-record) + (slot-value parent 'in-moving-p)))) ; XXX (recompute-extent-for-changed-child parent record min-x min-y max-x max-y)))) (values nx ny)) @@ -461,7 +462,8 @@ (gs-ink-mixin gs-clip-mixin gs-line-style-mixin gs-text-style-mixin) ()) -(defun replay (record stream &optional region) +(defun replay (record stream &optional (region (or (pane-viewport-region stream) + (sheet-region stream)))) (if (typep stream 'encapsulating-stream) (replay record (encapsulating-stream-stream stream) region) (progn From thenriksen at common-lisp.net Sat Feb 2 19:03:16 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 2 Feb 2008 14:03:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080202190316.BF9117C067@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv27411 Modified Files: input-editing.lisp Log Message: Redraw the input buffer after displaying typeout, causes scrolling and stuff if necessary. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/01 20:28:46 1.66 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/02 19:03:16 1.67 @@ -726,6 +726,7 @@ nmatches mode)) (when (and (> nmatches 0) (eq mode :possibilities)) (print-possibilities possibilities possibility-printer stream) + (redraw-input-buffer stream) (let ((possibility (handler-case (with-input-context (`(completion ,possibilities) :override nil) From thenriksen at common-lisp.net Sat Feb 2 19:03:26 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 2 Feb 2008 14:03:26 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080202190326.4107D461BC@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27440/Drei Modified Files: drei-clim.lisp drei-redisplay.lisp Log Message: Implement "cursors are children of their Drei instance (if applicable)"-policy. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/02/01 17:10:53 1.40 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/02/02 19:03:26 1.41 @@ -56,11 +56,12 @@ ;;; of what CLIM already provides. That seemed a bit (=a lot) hairy, ;;; though. -;;; Cursors are output records. When a cursor is created, it adds -;;; itself to its output stream. The owner of the cursor (a Drei -;;; instance) is responsible for removing the cursor once it is done -;;; with it. Cursors can be active/inactive and enabled/disabled and -;;; have the same activity-status as their associated view. +;;; Cursors are output records. After a cursor is created, The owning +;;; Drei instance instnace should add it to the output stream. The +;;; owner of the cursor (a Drei instance) is responsible for removing +;;; the cursor once it is done with it. Cursors can be active/inactive +;;; and enabled/disabled and have the same activity-status as their +;;; associated view. (defclass drei-cursor (standard-sequence-output-record) ((%view :reader view :initarg :view @@ -96,10 +97,6 @@ Drei buffer. The most important role for instances of subclasses of this class is to visually represent the position of point.")) -(defmethod initialize-instance :after ((object drei-cursor) &rest initargs) - (declare (ignore initargs)) - (stream-add-output-record (output-stream object) object)) - (defgeneric active (cursor) (:documentation "Whether the cursor is active or not. An active cursor is drawn using the active ink, and an @@ -204,6 +201,14 @@ (defmethod (setf view) :after (new-val (drei drei-pane)) (window-clear drei)) +(defmethod (setf cursors) :around (new-cursors (drei drei-pane)) + (let ((old-cursors (cursors drei))) + (call-next-method) + (dolist (old-cursor old-cursors) + (erase-output-record old-cursor drei nil)) + (dolist (new-cursor new-cursors) + (stream-add-output-record drei new-cursor)))) + (defmethod note-sheet-grafted :after ((pane drei-pane)) (setf (stream-default-view pane) (view pane))) @@ -374,6 +379,10 @@ (defmethod (setf view) :after ((new-view drei-view) (drei drei-area)) (setf (extend-pane-bottom new-view) t)) +(defmethod (setf cursors) :after (new-cursors (drei drei-area)) + (dolist (new-cursor (cursors drei)) + (setf (output-record-parent new-cursor) drei))) + (defmethod esa-current-window ((drei drei-area)) (editor-pane drei)) @@ -415,24 +424,28 @@ +foreground-ink+) (defmethod output-record-children ((record drei-area)) - '()) + (cursors record)) (defmethod output-record-count ((record drei-area)) - 0) + (length (cursors record))) (defmethod map-over-output-records-containing-position (function (record drei-area) x y &optional (x-offset 0) (y-offset 0) &rest function-args) - (declare (ignore function x y x-offset y-offset function-args)) - nil) + (declare (ignore x-offset y-offset)) + (dolist (cursor (cursors record)) + (when (region-contains-position-p cursor x y) + (apply function cursor function-args)))) (defmethod map-over-output-records-overlapping-region (function (record drei-area) region &optional (x-offset 0) (y-offset 0) &rest function-args) - (declare (ignore function region x-offset y-offset function-args)) - nil) + (declare (ignore x-offset y-offset)) + (dolist (cursor (cursors record)) + (when (region-intersects-region-p cursor region) + (apply function cursor function-args)))) (defmethod bounding-rectangle* ((drei drei-area)) (with-accessors ((pane editor-pane) @@ -457,6 +470,16 @@ (t 0))) (max y2 (+ y1 height))))))) +(defmethod replay-output-record :after ((drei drei-area) (stream extended-output-stream) + &optional (x-offset 0) (y-offset 0) (region +everywhere+)) + (declare (ignore x-offset y-offset region)) + (dolist (cursor (cursors drei)) + (replay cursor stream))) + +(defmethod recompute-extent-for-changed-child ((drei drei-area) (child output-record) + old-min-x old-min-y old-max-x old-max-y) + nil) + (defmethod rectangle-edges* ((rectangle drei-area)) (bounding-rectangle* rectangle)) --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/01 22:28:15 1.57 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/02 19:03:26 1.58 @@ -930,18 +930,18 @@ (change-space-requirements pane :width (max (bounding-rectangle-max-x cursor) (bounding-rectangle-max-x pane)) - :width (max (if (extend-pane-bottom view) - (bounding-rectangle-max-y cursor) - 0) - (bounding-rectangle-max-y pane))) + :height (max (if (extend-pane-bottom view) + (bounding-rectangle-max-y cursor) + 0) + (bounding-rectangle-max-y pane))) ;; And draw the cursor again. (call-next-method))) (defmethod display-drei-view-cursor :around ((stream extended-output-stream) (view drei-buffer-view) (cursor drei-cursor)) + (clear-output-record cursor) (when (visible-p cursor) - (clear-output-record cursor) (prog1 (call-next-method) (with-bounding-rectangle* (x1 y1 x2 y2) cursor (do-displayed-lines (line view) @@ -1011,13 +1011,6 @@ ;;; ;;; Drei area redisplay. -(defmethod erase-output-record :after ((drei drei-area) (stream extended-output-stream) - &optional (errorp nil errorp-supplied)) - (dolist (cursor (cursors drei)) - (apply #'erase-output-record cursor stream - (when errorp-supplied - (list errorp))))) - ;; XXX: Full redraw for every replay, should probably use the `region' ;; parameter to only invalidate some strokes. (defmethod replay-output-record ((drei drei-area) (stream extended-output-stream) &optional @@ -1025,14 +1018,11 @@ (declare (ignore x-offset y-offset region)) (letf (((stream-cursor-position stream) (output-record-start-cursor-position drei))) (invalidate-all-strokes (view drei)) - (display-drei-view-contents stream (view drei))) - (dolist (cursor (cursors drei)) - (replay cursor stream))) + (display-drei-view-contents stream (view drei)))) (defmethod replay-output-record ((cursor drei-cursor) stream &optional (x-offset 0) (y-offset 0) (region +everywhere+)) (declare (ignore x-offset y-offset region)) - (clear-output-record cursor) (with-output-recording-options (stream :record t :draw t) (display-drei-view-cursor stream (view cursor) cursor))) From thenriksen at common-lisp.net Sat Feb 2 19:03:35 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 2 Feb 2008 14:03:35 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080202190335.8A16E461BD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv27482/ESA Modified Files: packages.lisp Log Message: Fixed ambiguous symbol import in ESA-UTILS on CLISP. --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/29 22:59:30 1.15 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/02/02 19:03:35 1.16 @@ -24,6 +24,7 @@ (defpackage :esa-utils (:use :clim-lisp :clim-mop :clim) + (:shadowing-import-from :clim-lisp #:describe-object) (:export #:with-gensyms #:once-only #:unlisted From dmurray at common-lisp.net Sun Feb 3 07:16:50 2008 From: dmurray at common-lisp.net (dmurray) Date: Sun, 3 Feb 2008 02:16:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080203071650.486C31F117@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11501/Drei Modified Files: views.lisp drei-redisplay.lisp core-commands.lisp Log Message: Slightly more general tab-stops. May break the tabify abstraction - which I don't understand - but doesn't seem to break the code. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/31 08:34:15 1.33 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/03 07:16:48 1.34 @@ -60,7 +60,12 @@ :initform nil) (%use-tabs :accessor use-tabs :initform *use-tabs-for-indentation* - :initarg :use-tabs))) + :initarg :use-tabs) + (%tab-stops :accessor tab-stops + :initform '() + :initarg :tab-stops + :documentation "A list of tab-stops in device units. +If empty, tabs every TAB-WIDTH are assumed."))) (defun maybe-update-recordings (stream tabify) (with-accessors ((space-width recorded-space-width) @@ -87,7 +92,28 @@ (* (tab-space-count tabify) (space-width stream tabify)) (recorded-tab-width tabify)))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric next-tab-stop (stream tabify x) + (:documentation "Return the distance to the next tab-stop after `x' +on `stream' in device units (most likely pixels).") + (:method ((stream extended-output-stream) (tabify tabify-mixin) x) + (flet ((round-up (x width) + (- width (mod x width)))) + (if (tab-stops tabify) + (let ((next (find-if (lambda (pos) (> pos x)) (tab-stops tabify)))) + (or (and next (- next x)) (round-up x (space-width stream tabify)))) + (round-up x (tab-width stream tabify)))))) + +(defgeneric (setf tab-stop-columns) (column-list tabify) + (:documentation "Set the TAB-STOPS of view at the character column offsets +in `column-list'.") + (:method (column-list (tabify tabify-mixin)) + (setf (tab-stops tabify) + (and column-list + (sort (mapcar (lambda (col) (* col (space-width (recorded-stream tabify) tabify))) + column-list) + #'<))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Undo --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/02 19:03:26 1.58 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/03 07:16:49 1.59 @@ -487,13 +487,11 @@ (loop with parts = (analyse-stroke-string stroke-string) with width = 0 with widths = (make-array 1 :adjustable t :fill-pointer t :initial-element 0) - with tab-width for (start end object) in parts do (cond ((eql object #\Tab) - (incf width - (- (or tab-width - (setf tab-width (tab-width stream (stream-default-view stream)))) - (mod (+ width x-position) tab-width))) + (incf width + (next-tab-stop stream (stream-default-view stream) + (+ width x-position))) (vector-push-extend width widths)) (object (multiple-value-bind (w) --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/01/30 11:48:40 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2008/02/03 07:16:49 1.17 @@ -222,6 +222,12 @@ (untabify-region (mark) (point) (tab-space-count (current-view)))) +(define-command (com-set-tab-stops :name t :command-table editing-table) + ((tab-stops '(sequence (integer 0)) :prompt "List of tab stops")) + "Accept a list of tab positions (in columns) for the view." + (setf (drei::tab-stop-columns (current-view)) + tab-stops)) + (define-command (com-indent-line :name t :command-table indent-table) () (indent-current-line (current-view) (point))) From thenriksen at common-lisp.net Sun Feb 3 08:06:31 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Feb 2008 03:06:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080203080631.C8B351F00C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv20204 Modified Files: input-editing.lisp Log Message: Fix minor bug in complete-from-possibilities. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/02 19:03:16 1.67 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/03 08:06:31 1.68 @@ -886,7 +886,7 @@ (action :complete) (predicate (constantly t)) (name-key #'car) - (value-key #'cadar)) + (value-key #'second)) (flet ((generator (input-string suggester) (declare (ignore input-string)) (do-sequence (possibility completions) From thenriksen at common-lisp.net Sun Feb 3 08:38:26 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Feb 2008 03:38:26 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080203083826.46D906F24E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26552/Drei Modified Files: basic-commands.lisp drei.lisp Log Message: Changed how self-insert gestures work in Drei a bit. --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2008/01/18 11:00:22 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2008/02/03 08:38:25 1.12 @@ -511,14 +511,20 @@ ;;; These are what do the basic keypress->character inserted in buffer ;;; mapping. -(define-command com-self-insert ((count 'integer :default 1)) - (loop repeat count do (insert-character *current-gesture*))) +(define-command com-self-insert + ((count 'integer :default 1)) + "Insert the gesture used to invoke this command into the +current buffer `count' times. `Count' should get its value from +the numeric arguments." + (loop repeat count + do (insert-character *current-gesture*))) -(loop for code from (char-code #\Space) to (char-code #\~) - do (set-key `(com-self-insert ,*numeric-argument-marker*) - 'self-insert-table - (list (list (code-char code))))) +(defmethod command-for-unbound-gestures ((view textual-drei-syntax-view) gestures) + (when (and (= (length gestures)) + (characterp (first gestures)) + (graphic-char-p (first gestures))) + `(com-self-insert ,*numeric-argument-marker*))) (set-key `(com-self-insert ,*numeric-argument-marker*) - 'self-insert-table + 'self-insert-table '((#\Newline))) --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/30 21:21:43 1.36 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/02/03 08:38:25 1.37 @@ -381,6 +381,9 @@ (print-unreadable-object (object stream :type t :identity t) (format stream "~A" (type-of (view object))))) +(defmethod command-for-unbound-gestures ((drei drei) gestures) + (command-for-unbound-gestures (view drei) gestures)) + ;; Main redisplay entry point. (defgeneric display-drei (drei &key redisplay-minibuffer) (:documentation "`Drei' must be an object of type `drei' and From thenriksen at common-lisp.net Sun Feb 3 08:38:27 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Feb 2008 03:38:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080203083827.92F2B7D190@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv26552/ESA Modified Files: esa.lisp packages.lisp Log Message: Changed how self-insert gestures work in Drei a bit. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/29 22:59:30 1.18 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/02/03 08:38:26 1.19 @@ -459,6 +459,19 @@ (:method ((command-processor command-processor)) (null (overriding-handler command-processor)))) +(defgeneric command-for-unbound-gestures (thing gestures) + (:documentation "Called when `gestures' is input by the user +and there is no associated command in the current command +table. The function should return either a (possibly incomplete) +command or NIL. In the latter case (which is handled by a default +method), the gestures will be treated as actual unbound +gestures. `Thing' is something that might be interested in +commands, at the beginning usually a command processor, but it +can call the function for other objects it knows in order to get +their opinion. `Gestures' is a list of gestures.") + (:method (thing gestures) + nil)) + (defclass instant-macro-execution-mixin () () (:documentation "Subclasses of this class will immediately @@ -637,38 +650,43 @@ (multiple-value-bind (prefix-arg prefix-p gestures) (process-gestures-for-numeric-argument (accumulated-gestures command-processor)) - (cond ((null gestures) - t) - (t - (let* ((command-table (command-table command-processor)) - (item (find-gestures-with-inheritance gestures command-table))) - (cond - ((not item) - (setf (accumulated-gestures command-processor) nil) - (error 'unbound-gesture-sequence :gestures gestures)) - ((eq (command-menu-item-type item) :command) - (let ((command (command-menu-item-value item)) - (*current-gesture* (first (last gestures)))) - (unless (consp command) - (setf command (list command))) - ;; Call `*partial-command-parser*' to handle numeric - ;; argument. - (unwind-protect (setq command - (funcall - *partial-command-parser* - (command-table command-processor) - *standard-input* command 0 (when prefix-p - prefix-arg))) - ;; If we are macrorecording, store whatever the user - ;; did to invoke this command. - (when (recordingp command-processor) - (setf (recorded-keys command-processor) - (append (accumulated-gestures command-processor) - (recorded-keys command-processor)))) - (setf (accumulated-gestures command-processor) nil)) - (funcall (command-executor command-processor) command-processor command) - nil)) - (t t))))))) + (flet ((commandp (object) + (or (listp object) (symbolp object)))) + (cond ((null gestures) + t) + (t + (let* ((command-table (command-table command-processor)) + (item (or (find-gestures-with-inheritance gestures command-table) + (command-for-unbound-gestures command-processor gestures)))) + (cond + ((not item) + (setf (accumulated-gestures command-processor) nil) + (error 'unbound-gesture-sequence :gestures gestures)) + ((or (commandp item) ; c-f-u-g does not return a menu-item. + (eq (command-menu-item-type item) :command)) + (let ((command (if (commandp item) item + (command-menu-item-value item))) + (*current-gesture* (first (last gestures)))) + (unless (consp command) + (setf command (list command))) + ;; Call `*partial-command-parser*' to handle numeric + ;; argument. + (unwind-protect (setq command + (funcall + *partial-command-parser* + (command-table command-processor) + *standard-input* command 0 (when prefix-p + prefix-arg))) + ;; If we are macrorecording, store whatever the user + ;; did to invoke this command. + (when (recordingp command-processor) + (setf (recorded-keys command-processor) + (append (accumulated-gestures command-processor) + (recorded-keys command-processor)))) + (setf (accumulated-gestures command-processor) nil)) + (funcall (command-executor command-processor) command-processor command) + nil)) + (t t)))))))) (defmethod process-gesture :around ((command-processor command-processor) gesture) (with-accessors ((overriding-handler overriding-handler)) command-processor --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/02/02 19:03:35 1.16 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/02/03 08:38:26 1.17 @@ -79,6 +79,7 @@ #:command-processor #:instant-macro-execution-mixin #:asynchronous-command-processor #:command-loop-command-processor #:overriding-handler #:directly-processing-p #:process-gesture #:process-gestures-or-command + #:command-for-unbound-gestures #:*extended-command-prompt* #:define-esa-top-level #:esa-top-level #:simple-command-loop #:convert-to-gesture #:gesture-name From thenriksen at common-lisp.net Sun Feb 3 08:55:02 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Feb 2008 03:55:02 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080203085502.5B1E516054@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29732/Drei Modified Files: basic-commands.lisp Log Message: Fixed typo. --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2008/02/03 08:38:25 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2008/02/03 08:55:01 1.13 @@ -520,7 +520,7 @@ do (insert-character *current-gesture*))) (defmethod command-for-unbound-gestures ((view textual-drei-syntax-view) gestures) - (when (and (= (length gestures)) + (when (and (= (length gestures) 1) (characterp (first gestures)) (graphic-char-p (first gestures))) `(com-self-insert ,*numeric-argument-marker*))) From thenriksen at common-lisp.net Sun Feb 3 09:10:45 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Feb 2008 04:10:45 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080203091045.341C21F120@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv32766 Modified Files: frames.lisp Log Message: Added some convenient restarts for when the output history gets messed up due to errors. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2008/01/30 11:48:40 1.131 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2008/02/03 09:10:45 1.132 @@ -395,22 +395,32 @@ (let ((pane-object (if (typep pane 'pane) pane (find-pane-named frame pane)))) - (multiple-value-bind (redisplayp clearp) - (pane-needs-redisplay pane-object) - (when force-p - (setq redisplayp (or redisplayp t) - clearp t)) - (when redisplayp - (let ((hilited (frame-hilited-presentation frame))) - (when hilited - (highlight-presentation-1 (car hilited) (cdr hilited) :unhighlight) - (setf (frame-hilited-presentation frame) nil))) - (with-possible-double-buffering (frame pane-object) - (when clearp - (window-clear pane-object)) - (call-next-method)) - (unless (or (eq redisplayp :command-loop) (eq redisplayp :no-clear)) - (setf (pane-needs-redisplay pane-object) nil)))))) + (restart-case + (multiple-value-bind (redisplayp clearp) + (pane-needs-redisplay pane-object) + (when force-p + (setq redisplayp (or redisplayp t) + clearp t)) + (when redisplayp + (let ((hilited (frame-hilited-presentation frame))) + (when hilited + (highlight-presentation-1 (car hilited) (cdr hilited) :unhighlight) + (setf (frame-hilited-presentation frame) nil))) + (with-possible-double-buffering (frame pane-object) + (when clearp + (window-clear pane-object)) + (call-next-method)) + (unless (or (eq redisplayp :command-loop) (eq redisplayp :no-clear)) + (setf (pane-needs-redisplay pane-object) nil)))) + (clear-pane-try-again () + :report "Clear the output history of the pane and reattempt forceful redisplay" + (window-clear pane) + (redisplay-frame-pane frame pane :force-p t)) + (clear-pane () + :report "Clear the output history of the pane, but don't redisplay" + (window-clear pane)) + (skip-redisplay () + :report "Skip this redisplay")))) (defmethod run-frame-top-level ((frame application-frame) &key &allow-other-keys) From ahefner at common-lisp.net Sun Feb 3 09:24:15 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 04:24:15 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080203092415.E71231F123@common-lisp.net> 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 From ahefner at common-lisp.net Sun Feb 3 09:25:43 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 04:25:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080203092543.367927323F@common-lisp.net> 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 ;;; From ahefner at common-lisp.net Sun Feb 3 09:27:22 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 04:27:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080203092722.C45377323F@common-lisp.net> 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)) From ahefner at common-lisp.net Sun Feb 3 09:43:04 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 04:43:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/PostScript Message-ID: <20080203094304.7C0A85F05B@common-lisp.net> 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) From ahefner at common-lisp.net Sun Feb 3 10:18:34 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 05:18:34 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080203101834.0DD8876357@common-lisp.net> 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)) From ahefner at common-lisp.net Sun Feb 3 10:20:05 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 05:20:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080203102005.B18EC76357@common-lisp.net> 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. From ahefner at common-lisp.net Sun Feb 3 10:38:58 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 05:38:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080203103858.B05D97D198@common-lisp.net> 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) From ahefner at common-lisp.net Sun Feb 3 11:35:24 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 06:35:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080203113524.9F934A15D@common-lisp.net> 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 From ahefner at common-lisp.net Sun Feb 3 12:08:51 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 07:08:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080203120851.38B6632040@common-lisp.net> 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) From thenriksen at common-lisp.net Sun Feb 3 12:11:13 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Feb 2008 07:11:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080203121113.0057337006@common-lisp.net> 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', From ahefner at common-lisp.net Sun Feb 3 12:22:44 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 07:22:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080203122244.BE35E310C0@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv9564 Modified Files: dev-commands.lisp Log Message: Eliminate questionable call to a function in goatee. Change list styles to keywords. For once, Athas' naive aversion toward double colons was not misguided. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/02/03 12:08:51 1.49 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/02/03 12:22:38 1.50 @@ -1123,7 +1123,7 @@ (show-hidden 'boolean :default nil :prompt "show hidden") (hide-garbage 'boolean :default t :prompt "hide garbage") (show-all 'boolean :default nil :prompt "show all") - (style '(member items list) :default 'items :prompt "listing style") + (style '(member :items :list) :default 'items :prompt "listing style") (group-directories 'boolean :default t :prompt "group directories?") (full-names 'boolean :default nil :prompt "show full name?") (list-all-direct-subdirectories 'boolean :default nil :prompt "list all direct subdirectories?")) @@ -1139,7 +1139,7 @@ (with-text-family (t :sans-serif) (invoke-as-heading (lambda () - (format t "Directory contents of ") + (format t "Contents of ") (present (directory-namestring pathname) 'pathname) (when (pathname-type pathname) (format t " (only files of type ~a)" (pathname-type pathname))))) @@ -1153,18 +1153,14 @@ (unless show-all (setf group (filter-garbage-pathnames group show-hidden hide-garbage))) (ecase style - (items (abbreviating-format-items group :row-wise nil :x-spacing " " :y-spacing 1 - :printer (lambda (x stream) - (declare (ignore stream)) - (pretty-pretty-pathname x *standard-output* - :long-name full-names))) - #+NIL - (format-items group :row-wise nil :x-spacing " " :y-spacing 1 - :printer (lambda (x stream) - (declare (ignore stream)) - (pretty-pretty-pathname x *standard-output* :long-name full-names))) - (goatee::reposition-stream-cursor *standard-output*)) ; Hmm. - (list (dolist (ent group) + (:items + (abbreviating-format-items group :row-wise nil :x-spacing " " :y-spacing 1 + :printer (lambda (x stream) + (pretty-pretty-pathname x stream + :long-name full-names))) + (multiple-value-bind (x y) (stream-cursor-position *standard-output*) + (setf (stream-cursor-position *standard-output*) (values 0 y)))) + (:list (dolist (ent group) (let ((ent (merge-pathnames ent pathname))) ;; This is for CMUCL, see above. (fixme!) ;; And breaks some things for SBCL.. (mgr) (pretty-pretty-pathname ent *standard-output* :long-name full-names))))))))) From ahefner at common-lisp.net Sun Feb 3 12:47:04 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 07:47:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080203124704.4202E72143@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv20175 Modified Files: util.lisp file-types.lisp Log Message: In keeping with McCLIM tradition, "clean up" code and see what breaks. Random pathname-related chanegs, and deleted chunks of old code from the bad old days when SBCL's cl:directory was useless and sb-posix didn't even have stat. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/01/31 11:06:40 1.23 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/02/03 12:47:04 1.24 @@ -29,23 +29,6 @@ `(let ((,tmp (multiple-value-list ,(first forms)))) (if (first ,tmp) (values-list ,tmp) (mv-or ,@(rest forms))))))) - -;; DEBUGF is useful, I can sleep better knowing it's in the image. -(defmacro debugf (&rest stuff) - `(progn (fresh-line *trace-output*) - ,@(reduce #'append - (mapcar #'(lambda (x) - (cond - ((stringp x) `((princ ,x *trace-output*))) - (t `((princ ',x *trace-output*) - (princ "=" *trace-output*) - (write ,x :stream *trace-output*) - (princ #\space *trace-output*))))) - - stuff)) - (terpri *trace-output*))) - - ; There has to be a better way.. (defun directoryp (pathname) "Returns pathname when supplied with a directory, otherwise nil" @@ -65,19 +48,18 @@ #+clisp (ext:getenv var) nil)) -;; Need to strip filename/type/version from directory?.. FIXME? (defun change-directory (pathname) "Ensure that the current directory seen by RUN-PROGRAM has changed, and update *default-pathname-defaults*" #+CMU (unix:unix-chdir (namestring pathname)) #+scl (unix:unix-chdir (ext:unix-namestring pathname)) #+clisp (ext:cd pathname) - ; SBCL FIXME? + #+sbcl (sb-posix:chdir (namestring pathname)) (setf *default-pathname-defaults* pathname)) (defun resolve-stream-designator (desi default) (if (eq desi t) default - (or desi default))) + (or desi default))) ;;; LIST-DIRECTORY is a wrapper for the CL DIRECTORY function, which really doesn't ;;; do what I'd like (resolves symbolic links, tends to be horribly buggy, etc.) @@ -86,48 +68,10 @@ (defun list-directory (pathname) (directory pathname :truenamep nil)) - -#+SBCL -(defun sbcl-frob-to-pathname (pathname string) - "This just keeps getting more disgusting." - (let* ((parent (strip-filespec pathname)) - (pn (merge-pathnames (make-pathname :name (subseq string 0 (position #\. string :start 1 :from-end t)) - :type (let ((x (position #\. string :start 1 :from-end t))) - (if x (subseq string (1+ x)) nil))) - parent)) - (dir (ignore-errors (sb-posix:opendir (namestring pn))))) - - - (cond ((or (string= string ".") - (string= string "..")) - (unless (or (null dir) (sb-alien:null-alien dir)) - (sb-posix:closedir dir)) - nil) - ((or (null dir) - (sb-alien:null-alien dir)) - pn) - (T - (sb-posix:closedir dir) - (merge-pathnames (parse-namestring (concatenate 'string string "/")) - parent))))) - #+SBCL (defun list-directory (pathname) - (directory pathname) - #+nil ;; ugh. is too ughy. (mgr) - (let* ((pathname (strip-filespec pathname)) ;; ugh. - (dir (sb-posix:opendir pathname)) - (list nil)) - (loop - (let ((dirent (sb-posix:readdir dir))) - (unwind-protect - (if (sb-alien:null-alien dirent) - (return-from list-directory - (nreverse list)) - (let ((pn (sbcl-frob-to-pathname pathname (sb-posix::dirent-name dirent)))) - (when pn (push pn list)))) - #+nil ; dirents should not be freed, they belong to the DIR. - (sb-posix::free-dirent dirent)))))) + ;; Wow. When did SBCL's cl:directory become sane? This is great news! + (directory pathname)) #+openmcl (defun list-directory (pathname) @@ -246,21 +190,11 @@ (add-output-record record (stream-output-history stream-pane)) (repaint-sheet stream-pane record))) -;;; Pathname evil -;;; Fixme: Invent some more useful operators for manipulating pathnames, add a -;;; pinch of syntactic sugar, and cut the LOC here down to a fraction. +;;; Pathnames are awful. (defun gen-wild-pathname (pathname) "Build a pathname with appropriate :wild components for the directory listing." - (make-pathname :name (or (pathname-name pathname) :wild) - :type (or (pathname-type pathname) :wild) - :version (or #+allegro :unspecific - :wild - ;#-SBCL (pathname-version pathname) - ;#+SBCL :newest - ) - #+scl :query #+scl nil - :defaults pathname)) + (merge-pathnames pathname (make-pathname :name :wild :type :wild :version :wild))) (defun strip-filespec (pathname) "Removes name, type, and version components from a pathname." @@ -283,6 +217,8 @@ ;;;; Abbreviating item formatter +;;; FIXME: This would work a lot better if the + (defparameter *abbreviating-minimum-items* 6 "Minimum number of items needed to invoke abbreviation. This must be at least one.") (defparameter *abbreviating-outlier-threshold* 2.0 @@ -315,11 +251,6 @@ (if (= count 1) result nil) (or text-style (medium-text-style (slot-value record 'climi::medium))))))) -;; This logic could be useful in McCLIM's stream-output.lisp, for computing -;; line breaks. At the time, I didn't feel like writing it, but now I do. -;; Even so, the binary search I used there is probably good enough, but this -;; would improve the quality of the guess, particularly for the extreme case -;; of throwing many lines of text at CLIM within one string. (defun abbrev-guess-pos (medium string text-style desired-width start end) "Makes a guess where to split STRING between START and END in order to fit within WIDTH. Returns the ending character index." (let* ((length (- end start)) @@ -348,8 +279,6 @@ (subseq string 0 (abbrev-guess-pos medium string text-style working-width 0 (length string))) "..."))) -(defvar *tmp* nil) - (defun abbreviate-record (stream record width abbreviator) "Attempts to abbreviate the text contained in an output RECORD on STREAM to fit within WIDTH, using the function ABBREVIATOR to produce a shortened string." (declare (optimize (debug 3))) @@ -489,7 +418,10 @@ (run-program name (transform-program-arguments args) :wait *program-wait* :output (resolve-stream-designator *run-output* *standard-output*) - :input nil #+NIL (resolve-stream-designator *run-input* *standard-input*)))) + :input nil #+NIL (resolve-stream-designator *run-input* *standard-input*)) + ;; It might be useful to return the exit status of the process, but our run-program + ;; wrapper doesn't + (values))) (defun read-stringlet (stream) (with-output-to-string (out) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2007/02/05 03:41:37 1.11 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2008/02/03 12:47:04 1.12 @@ -105,7 +105,6 @@ (key (if type (concatenate 'string name "." type) ; Why did I do it this way? name)) (item (gethash key *magic-name-mappings*))) -; (when item (hef:debugf item pathname)) item)) (defun pathname-mime-type (pathname) @@ -147,7 +146,6 @@ ; (call-next-method))) (let ((cpl (clim-mop:class-precedence-list (class-of obj)))) (dolist (class cpl) -; (debugf " " class) (let ((icon (gethash (class-name class) *icon-mapping*))) (when icon (return-from icon-of icon))))) (call-next-method)) @@ -547,7 +545,7 @@ (cond ((eql d #\s) (princ (quote-shell-characters (namestring (truename pathname))) out)) ((eql d #\t) (princ (gethash :type spec) out)) ((eql d #\u) (princ (pathname-to-uri-string pathname) out)) - (t (debugf "Ignoring unknown % syntax." d)))) + (t (format *trace-output* "Ignoring unknown syntax ~W" d)))) (write-char c out)))))) (defun find-viewspec (pathname) @@ -577,7 +575,7 @@ (format t "Sorry, the viewer app needs a terminal (fixme!)~%") (progn (when test - (debugf "Sorry, ignoring TEST option right now.. " test)) + (format *trace-output* "Sorry, ignoring TEST option ~W for ~A viewer " test type)) (if view-command (run-program "/bin/sh" `("-c" ,(gen-view-command-line def pathname) "&")) (format t "~&No view-command!~%")))))))) From thenriksen at common-lisp.net Sun Feb 3 18:49:56 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Feb 2008 13:49:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080203184956.EF51072126@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv1041/Drei Modified Files: drei-redisplay.lisp Log Message: Export OUTPUT-RECORD-BASELINE from CLIM-EXTENSIONS. Use OUTPUT-RECORD-BASELINE to make Drei more inteligent. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/03 07:16:49 1.59 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/03 18:49:56 1.60 @@ -730,6 +730,7 @@ region, which will be presented with its appropriate presentation type (found via `presentation-type-of') to generate output." (let (output-record + baseline (widths (make-array 2 :initial-contents (list 0 0))) (parts (list 0 1))) #'(lambda (stream view stroke cursor-x cursor-y @@ -741,7 +742,8 @@ (when (or (null output-record) (stroke-modified stroke)) (setf output-record (with-output-to-output-record (stream) - (present object (presentation-type-of object) :stream stream)))) + (present object (presentation-type-of object) :stream stream)) + baseline (clim-extensions:output-record-baseline output-record))) ;; You will not believe this! If `cursor-x' is 0, it seems ;; like the changing position is ignored. So add some ;; minuscule amount to it, and all will be well. 0.1 @@ -749,14 +751,14 @@ (let ((width (bounding-rectangle-width output-record)) (height (bounding-rectangle-height output-record))) (setf (output-record-position output-record) - (values (+ cursor-x 0.1) (- cursor-y height))) + (values (+ cursor-x 0.1) (- cursor-y baseline))) (when draw (replay output-record stream)) (setf (aref widths 1) width) (record-stroke stroke parts widths cursor-x (- cursor-y height) (+ width cursor-x) cursor-y - draw height))))))) + draw baseline))))))) (defmethod pump-state-for-offset ((view drei-buffer-view) (offset integer)) "For a `drei-buffer-view' a pump-state is merely an offset into From thenriksen at common-lisp.net Sun Feb 3 18:49:57 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Feb 2008 13:49:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080203184957.388097903C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv1041 Modified Files: package.lisp Log Message: Export OUTPUT-RECORD-BASELINE from CLIM-EXTENSIONS. Use OUTPUT-RECORD-BASELINE to make Drei more inteligent. --- /project/mcclim/cvsroot/mcclim/package.lisp 2008/02/03 09:24:15 1.66 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2008/02/03 18:49:57 1.67 @@ -1941,6 +1941,7 @@ #:with-output-to-pointer-documentation #:frame-display-pointer-documentation-string #:list-pane-items + #:output-record-baseline #:draw-output-border-over #:draw-output-border-under From ahefner at common-lisp.net Sun Feb 3 19:07:51 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 14:07:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080203190751.75E1F1F00C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv5452 Modified Files: listener.lisp Log Message: Veto'd! --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/02/03 10:20:04 1.41 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/02/03 19:07:51 1.42 @@ -143,8 +143,9 @@ "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)) - (cond + (accept 'command-or-form :stream stream :prompt nil + :default "hello" :default-type 'empty-input)) + (cond ((presentation-subtypep type 'empty-input) ;; Do nothing. `(com-eval (values))) @@ -153,19 +154,9 @@ (defun print-listener-prompt (stream frame) (declare (ignore frame)) - (with-text-face (stream :italic) - (let* ((text-style-width (text-style-width (medium-default-text-style stream) stream)) - (arrow-width (* 2 text-style-width)) - (prompt-height - (bounding-rectangle-height - (with-output-as-presentation (stream *package* 'package :single-box t) - (print-package-name stream))))) - (multiple-value-bind (x y) (stream-cursor-position stream) - (draw-arrow* stream x (+ y (/ prompt-height 2)) - (+ x arrow-width) (+ y (/ prompt-height 2)) - :head-length (/ text-style-width 2) - :head-width (floor (/ prompt-height 2)))) - (stream-increment-cursor-position stream (+ arrow-width text-style-width) 0)))) + (with-output-as-presentation (stream *package* 'package :single-box t) + (print-package-name stream)) + (princ "> " stream)) (defmethod frame-standard-output ((frame listener)) (get-frame-pane frame 'interactor)) From thenriksen at common-lisp.net Sun Feb 3 19:17:26 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Feb 2008 14:17:26 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080203191726.9FEB05F074@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv7023/Drei Modified Files: drei-redisplay.lisp Log Message: The brave new world of output records with baselines was not properly interned everywhere. Fixed. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/03 18:49:56 1.60 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/03 19:17:26 1.61 @@ -57,9 +57,7 @@ object, or display the `princ'ed representation.)") (:method :around ((stream extended-output-stream) (view drei-view)) (letf (((stream-default-view stream) view)) - (call-next-method))) - (:method ((stream extended-output-stream) (view drei-syntax-view)) - (call-next-method))) + (call-next-method)))) (defgeneric display-drei-view-cursor (stream view cursor) (:documentation "The purpose of this function is to display a @@ -748,15 +746,14 @@ ;; like the changing position is ignored. So add some ;; minuscule amount to it, and all will be well. 0.1 ;; device units shouldn't even be visible. - (let ((width (bounding-rectangle-width output-record)) - (height (bounding-rectangle-height output-record))) + (let ((width (bounding-rectangle-width output-record))) (setf (output-record-position output-record) (values (+ cursor-x 0.1) (- cursor-y baseline))) (when draw (replay output-record stream)) (setf (aref widths 1) width) (record-stroke stroke parts widths - cursor-x (- cursor-y height) + cursor-x (- cursor-y baseline) (+ width cursor-x) cursor-y draw baseline))))))) From ahefner at common-lisp.net Sun Feb 3 20:51:47 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 15:51:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080203205147.E8060340A3@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv27936 Modified Files: dev-commands.lisp Log Message: Somehow failed to change the default for style arg to a keyword. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/02/03 12:22:38 1.50 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/02/03 20:51:47 1.51 @@ -1123,7 +1123,7 @@ (show-hidden 'boolean :default nil :prompt "show hidden") (hide-garbage 'boolean :default t :prompt "hide garbage") (show-all 'boolean :default nil :prompt "show all") - (style '(member :items :list) :default 'items :prompt "listing style") + (style '(member :items :list) :default :items :prompt "listing style") (group-directories 'boolean :default t :prompt "group directories?") (full-names 'boolean :default nil :prompt "show full name?") (list-all-direct-subdirectories 'boolean :default nil :prompt "list all direct subdirectories?")) From ahefner at common-lisp.net Sun Feb 3 22:54:14 2008 From: ahefner at common-lisp.net (ahefner) Date: Sun, 3 Feb 2008 17:54:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080203225414.D1BC85B0A9@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv28338 Modified Files: recording.lisp Log Message: Fix various bounding rectangle bugs. 1) After clear-output-record, recompute bounds of parent. 2) Fix bug in recompute-extent-for-new-child, which was noted in the source. 3) In %tree-recompute-extent*, don't include empty rectangles. Also twiddled comments, add assertions, and remarked on output-record-children for tree records. --- /project/mcclim/cvsroot/mcclim/recording.lisp 2008/02/03 09:25:42 1.139 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2008/02/03 22:54:13 1.140 @@ -397,15 +397,15 @@ (values nx ny)) (defmethod* (setf output-record-position) :around - (nx ny (record basic-output-record)) + (nx ny (record basic-output-record)) (with-bounding-rectangle* (min-x min-y max-x max-y) record - (call-next-method) + (call-next-method) (let ((parent (output-record-parent record))) (when (and parent (not (and (typep parent 'compound-output-record) (slot-value parent 'in-moving-p)))) ; XXX (recompute-extent-for-changed-child parent record - min-x min-y max-x max-y)))) - (values nx ny)) + min-x min-y max-x max-y))) + (values nx ny))) (defmethod* (setf output-record-position) :before (nx ny (record compound-output-record)) @@ -616,10 +616,17 @@ (when sheet (map-over-output-records #'note-output-record-lost-sheet record 0 0 sheet)))) +(defmethod clear-output-record :around ((record compound-output-record)) + (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* record) + (call-next-method) + (assert (null-bounding-rectangle-p record)) + (when (output-record-parent record) + (recompute-extent-for-changed-child + (output-record-parent record) record x1 y1 x2 y2)))) + (defmethod clear-output-record :after ((record compound-output-record)) ;; XXX banish x and y - (with-slots (x y) - record + (with-slots (x y) record (setf (rectangle-edges* record) (values x y x y)))) (defmethod output-record-count ((record displayed-output-record)) @@ -700,20 +707,20 @@ ((record compound-output-record) child) (unless (null-bounding-rectangle-p child) (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record - ;; I expect there's a bug here. If you create a record A, add an empty child B - ;; then add a displayed-output-record C, the code below will use min/max to - ;; grow the all-zero bounds of A, typically giving a bogus x1,y1 of 0,0. --Hefner - (if (eql 1 (output-record-count record)) - (setf (rectangle-edges* record) (bounding-rectangle* child)) - (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) - child - (setf (rectangle-edges* record) - (values (min old-x1 x1-child) (min old-y1 y1-child) - (max old-x2 x2-child) (max old-y2 y2-child))))) + (cond + ((null-bounding-rectangle-p record) + (setf (rectangle-edges* record) (bounding-rectangle* child))) + ((not (null-bounding-rectangle-p child)) + (assert (not (null-bounding-rectangle-p record))) ; important. + (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) + child + (setf (rectangle-edges* record) + (values (min old-x1 x1-child) (min old-y1 y1-child) + (max old-x2 x2-child) (max old-y2 y2-child)))))) (let ((parent (output-record-parent record))) - (when parent - (recompute-extent-for-changed-child - parent record old-x1 old-y1 old-x2 old-y2))))) + (when parent + (recompute-extent-for-changed-child + parent record old-x1 old-y1 old-x2 old-y2))))) record) (defmethod %tree-recompute-extent* ((record compound-output-record)) @@ -725,16 +732,17 @@ (first-time t)) (map-over-output-records (lambda (child) - (if first-time - (progn - (multiple-value-setq (new-x1 new-y1 new-x2 new-y2) - (bounding-rectangle* child)) - (setq first-time nil)) - (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child - (minf new-x1 cx1) - (minf new-y1 cy1) - (maxf new-x2 cx2) - (maxf new-y2 cy2)))) + (unless (null-bounding-rectangle-p child) + (if first-time + (progn + (multiple-value-setq (new-x1 new-y1 new-x2 new-y2) + (bounding-rectangle* child)) + (setq first-time nil)) + (with-bounding-rectangle* (cx1 cy1 cx2 cy2) child + (minf new-x1 cx1) + (minf new-y1 cy1) + (maxf new-x2 cx2) + (maxf new-y2 cy2))))) record) (if first-time ;; XXX banish x y @@ -790,10 +798,13 @@ (cond ;; The child has been deleted; who knows what the ;; new bounding box might be. + ;; This case shouldn't be really necessary. ((not (output-record-parent changed-child)) (%tree-recompute-extent* record)) ;; Only one child of record, and we already have the bounds. ((eql (output-record-count record) 1) + ;; See output-record-children for why this assert breaks: + ;; (assert (eq changed-child (elt (output-record-children record) 0))) (values cx1 cy1 cx2 cy2)) ;; If our record occupied no space (had no children, or had only ;; children similarly occupying no space, hackishly determined by @@ -805,15 +816,13 @@ ;; In the following cases, we can grow the new bounding rectangle ;; from its previous state: ((or - ;; If the child was originally empty, it should not have affected + ;; If the child was originally empty, it could not have affected ;; previous computation of our bounding rectangle. ;; This is hackish for reasons similar to the above. - (and (zerop old-min-x) (zerop old-min-y) - (zerop old-max-x) (zerop old-max-y)) - ;; For each old child coordinate, either it was not - ;; involved in determining the bounding rectangle of the - ;; parent, or else it is the same as the corresponding - ;; new child coordinate. + (and (= old-min-x old-max-x) (= old-min-y old-max-y)) + ;; For each edge of the original child bounds, if it was within + ;; its respective edge of the old parent bounding rectangle, + ;; or if it has not changed: (and (or (> old-min-x ox1) (= old-min-x cx1)) (or (> old-min-y oy1) (= old-min-y cy1)) (or (< old-max-x ox2) (= old-max-x cx2)) @@ -843,11 +852,6 @@ ox1 oy1 ox2 oy2))))))) record) -;; There was once an :around method on recompute-extent-for-changed-child here, -;; but I've eliminated it. Its function was to notify the parent OR in case -;; the bounding rect here changed - I've merged this into the above method. -;; --Hefner, 8/7/02 - (defmethod tree-recompute-extent ((record compound-output-record)) (tree-recompute-extent-aux record) record) @@ -989,8 +993,21 @@ (defmethod output-record-children ((record standard-tree-output-record)) (map 'list #'tree-output-record-entry-record - (spatial-trees:search (%record-to-spatial-tree-rectangle record) - (%tree-record-children record)))) + (spatial-trees:search + (%record-to-spatial-tree-rectangle record) + ;; The form below intends to fix output-record-children not + ;; reporting empty children, which may lie outside the reported + ;; bounding rectangle of their parent. + ;; Assumption: null bounding records are always at the origin. + ;; I've never noticed this violated, but it's out of line with + ;; what null-bounding-rectangle-p checks, and setf of + ;; output-record-position may invalidate it. Seems to work, but + ;; fix that and try again later. + #+NIL + (rectangles:make-rectangle + :lows (list 0 0) #| `(,(bounding-rectangle-min-x r) ,(bounding-rectangle-min-y r)) |# + :highs `(,(bounding-rectangle-max-x record) ,(bounding-rectangle-max-y record))) + (%tree-record-children record)))) (defmethod add-output-record (child (record standard-tree-output-record)) (let ((entry (make-tree-output-record-entry child (incf (last-insertion-nr record))))) From thenriksen at common-lisp.net Sun Feb 3 23:42:01 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Feb 2008 18:42:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20080203234201.1F23515011@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv11584/Apps/Inspector Modified Files: inspector.lisp Log Message: Added some security to Clouseau to assist in my primitive debugging methods. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/01/05 12:20:34 1.41 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/02/03 23:42:01 1.42 @@ -85,10 +85,18 @@ (*print-level* 10)) (run-frame-top-level (make-application-frame 'inspector :obj obj))))) + + (when (typep *application-frame* 'inspector) + (restart-case (error "Clouseau called from inside Clouseau, possibly infinite recursion") + (continue () + :report "Continue by starting a new Clouseau instance") + (abort-clouseau () + :report "Abort this call to Clouseau" + (return-from inspector)))) (if new-process (clim-sys:make-process #'run - :name (format nil "Inspector Clouseau: ~S" - obj)) + :name (format nil "Inspector Clouseau: ~S" + obj)) (run)) obj)) @@ -766,7 +774,8 @@ (frame-exit *application-frame*)) (define-inspector-command (com-inspect :name t) () - (let ((obj (accept t :prompt "Select an object"))) + (let ((obj (accept t :prompt "Select an object")) + (*application-frame* nil)) ; To get around security. (inspector obj :new-process t))) (define-inspector-command (com-toggle-show-list-cells :name t) From thenriksen at common-lisp.net Sun Feb 3 23:49:24 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 3 Feb 2008 18:49:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080203234924.7B6C655358@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12868/Drei Modified Files: input-editor.lisp Log Message: Sometimes, the input-position may be larger than the size of the buffer. Handle this without erroring. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/02 19:02:03 1.38 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/03 23:49:24 1.39 @@ -572,7 +572,9 @@ ;; input-position, so the user will not be able to ;; delete arguments prompts or other things. (drei-core:with-narrowed-buffer (drei - (loop for index from (1- (input-position stream)) above 0 + (loop for index from + (1- (min (input-position stream) + (size (buffer (View drei))))) above 0 when (typep (buffer-object (buffer (view drei)) index) 'noise-string) return (1+ index) From rschlatte at common-lisp.net Mon Feb 4 03:17:40 2008 From: rschlatte at common-lisp.net (rschlatte) Date: Sun, 3 Feb 2008 22:17:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080204031740.0B6D512060@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv4347/Apps/Listener Modified Files: dev-commands.lisp util.lisp Log Message: ,Change Directory foo now changes to foo/ --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/02/03 20:51:47 1.51 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/02/04 03:17:39 1.52 @@ -1128,9 +1128,9 @@ (full-names 'boolean :default nil :prompt "show full name?") (list-all-direct-subdirectories 'boolean :default nil :prompt "list all direct subdirectories?")) - (let* ((pathname (if (wild-pathname-p pathname) ; Forgot why I did this.. - (merge-pathnames pathname) - pathname)) + (let* ((pathname + ;; helpfully fix things if trailing slash wasn't entered + (directorify-pathname pathname)) (wild-pathname (gen-wild-pathname pathname)) (dir (if list-all-direct-subdirectories (list-directory-with-all-direct-subdirectories wild-pathname) @@ -1181,12 +1181,12 @@ :menu t :command-table filesystem-commands) ((pathname 'pathname :prompt "pathname")) - (let ((pathname (merge-pathnames pathname))) - (cond ((not (probe-file pathname)) - (note "~A does not exist." pathname)) - ((not (directoryp pathname)) - (note "~A is not a directory." pathname)) - (t (change-directory (merge-pathnames pathname))) ))) + (let ((pathname (merge-pathnames + ;; helpfully fix things if trailing slash wasn't entered + (directorify-pathname pathname)))) + (if (not (probe-file pathname)) + (note "~A does not exist.~%" pathname) + (change-directory pathname)))) (define-command (com-up-directory :name "Up Directory" :menu t @@ -1312,15 +1312,12 @@ (define-command (com-push-directory :name "Push Directory" :menu t :command-table directory-stack-commands) - ((pathname 'pathname :prompt "pathname")) - (let ((pathname (merge-pathnames pathname))) - (if (and (probe-file pathname) - (directoryp pathname));; FIXME: Need smart conversion to directories, here and elsewhere. + ((pathname 'pathname :prompt "directory")) + (let ((pathname (merge-pathnames (directorify-pathname pathname)))) + (if (not (probe-file pathname)) + (note "~A does not exist.~%" pathname) (progn (push *default-pathname-defaults* *directory-stack*) - (com-change-directory pathname)) - (italic (t) - (fresh-line) (present (truename pathname)) - (format t " does not exist or is not a directory.~%")) )) + (com-change-directory pathname)))) (compute-dirstack-command-eligibility *application-frame*)) (defun comment-on-dir-stack () --- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/02/03 12:47:04 1.24 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2008/02/04 03:17:39 1.25 @@ -214,6 +214,16 @@ (merge-pathnames (make-pathname :directory '(:relative :back)) (truename pathname)))))) +(defun directorify-pathname (pathname) + "Convert a pathname with name/version into a pathname with a +similarly-named last directory component. Used for user input that +lacks the final #\\/." + (if (directoryp pathname) + pathname + ;; doing this the primitive way instead of trying to grok name, + ;; type, version and trying to reconstruct what the user + ;; actually typed. I think I'm going to hell for this one. + (pathname (concatenate 'string (namestring pathname) "/")))) ;;;; Abbreviating item formatter From thenriksen at common-lisp.net Mon Feb 4 17:20:31 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Feb 2008 12:20:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080204172031.393503C078@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31373/Drei Modified Files: input-editor.lisp Log Message: Replace hack with general fix. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/03 23:49:24 1.39 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/04 17:20:29 1.40 @@ -573,8 +573,7 @@ ;; delete arguments prompts or other things. (drei-core:with-narrowed-buffer (drei (loop for index from - (1- (min (input-position stream) - (size (buffer (View drei))))) above 0 + (1- (input-position stream)) above 0 when (typep (buffer-object (buffer (view drei)) index) 'noise-string) return (1+ index) @@ -640,8 +639,9 @@ (defmethod reset-scan-pointer ((stream drei-input-editing-mixin) &optional (scan-pointer 0)) - (setf (stream-scan-pointer stream) scan-pointer) - (setf (stream-rescanning stream) t)) + (setf (stream-scan-pointer stream) scan-pointer + (stream-rescanning stream) t + (input-position stream) (min scan-pointer (input-position stream)))) ;; This has been cribbed from SPLIT-SEQUENCE and lightly modified. (defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) From thenriksen at common-lisp.net Mon Feb 4 17:44:50 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Feb 2008 12:44:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080204174450.2DCE472137@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv7321/Drei Modified Files: lisp-syntax-swine.lisp Log Message: Fixed lambda-list display where a space character would not be printed where it is necessary. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/11 07:52:03 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/04 17:44:50 1.15 @@ -710,7 +710,7 @@ (format stream "&KEY ") (show-parameters (keyword-parameters lambda-list)))))) (format stream "(~A" operator) - (when (required-parameters lambda-list) + (when (all-parameters lambda-list) (princ #\Space stream)) (show-lambda-list lambda-list) (format stream ")"))) From thenriksen at common-lisp.net Mon Feb 4 19:06:17 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Feb 2008 14:06:17 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080204190617.BCC6A2332B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29112/Drei Modified Files: input-editor.lisp Log Message: Fixed some random input-editor bugs. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/04 17:20:29 1.40 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/04 19:06:17 1.41 @@ -349,7 +349,7 @@ (length old-contents)))) ;; We have to return "the position in the input buffer". We ;; return the insertion position. - buffer-start))) + (stream-insertion-pointer stream)))) (defun present-acceptably-to-string (object type view for-context-type) "Return two values - a string containing the printed From thenriksen at common-lisp.net Mon Feb 4 19:06:18 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Feb 2008 14:06:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080204190618.D6BDE28182@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv29112 Modified Files: input-editing-drei.lisp input-editing.lisp Log Message: Fixed some random input-editor bugs. --- /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/02/01 20:28:46 1.12 +++ /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2008/02/04 19:06:17 1.13 @@ -135,7 +135,7 @@ :input-sensitizer input-sensitizer :initial-contents initial-contents :class class) - (funcall continuation editing-stream)) + (input-editing-rescan-loop editing-stream continuation)) (finalize editing-stream input-sensitizer)))) (defmethod immediate-rescan ((stream standard-input-editing-stream)) --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/03 12:11:13 1.71 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/04 19:06:17 1.72 @@ -336,9 +336,9 @@ (loop (block rescan (handler-bind ((rescan-condition #'(lambda (c) + (declare (ignore c)) (reset-scan-pointer editing-stream start-scan-pointer) ;; Input-editing contexts above may be interested... - (signal c) (return-from rescan nil)))) (return-from input-editing-rescan-loop (funcall continuation editing-stream))))))) @@ -372,7 +372,7 @@ (first initial-contents) (second initial-contents) (stream-default-view stream)))) - (input-editing-rescan-loop stream continuation)) + (call-next-method)) (defmethod invoke-with-input-editing :around ((stream extended-output-stream) continuation From thenriksen at common-lisp.net Mon Feb 4 19:15:35 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 4 Feb 2008 14:15:35 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080204191535.618E67A014@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv30180 Modified Files: input-editing.lisp Log Message: Fix bug that sometimes caused previous prompts to be covered by typeout. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/04 19:06:17 1.72 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/04 19:15:35 1.73 @@ -222,7 +222,7 @@ (map-over-output-records-overlapping-region #'(lambda (record) (multiple-value-bind (record-x record-y) (output-record-position record) - (when (>= (+ record-y (bounding-rectangle-height record)) y) + (when (> (+ record-y (bounding-rectangle-height record)) y) (setf (output-record-position record) (values record-x (+ record-y delta-y)))))) (stream-output-history sheet) From thenriksen at common-lisp.net Tue Feb 5 08:53:10 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 5 Feb 2008 03:53:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080205085310.0C27E30068@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv26133 Modified Files: frames.lisp Log Message: Added restart for re-executing commands. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2008/02/03 09:10:45 1.132 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2008/02/05 08:53:09 1.133 @@ -563,7 +563,13 @@ ;; frames command loop. Perhaps looking ath the process slot? ;; --GB 2005-11-28 (cond ((eq *application-frame* frame) - (apply (command-name command) (command-arguments command))) + (restart-case + (apply (command-name command) (command-arguments command)) + (try-again () + :report (lambda (stream) + (format stream "Try executing the command ~A again" + (command-name command))) + (execute-frame-command frame command)))) (t (let ((eq (sheet-event-queue (frame-top-level-sheet frame)))) (event-queue-append eq (make-instance 'execute-command-event From thenriksen at common-lisp.net Tue Feb 5 12:59:56 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 5 Feb 2008 07:59:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim-website Message-ID: <20080205125956.50B846A004@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim-website In directory clnet:/tmp/cvs-serv17802 Modified Files: index.html Log Message: Added mention of what McCLIM actually is. --- /project/mcclim/cvsroot/mcclim-website/index.html 2008/01/29 11:49:53 1.2 +++ /project/mcclim/cvsroot/mcclim-website/index.html 2008/02/05 12:59:56 1.3 @@ -24,8 +24,12 @@

What is McCLIM?

- McCLIM is an open source implementation of the - Common Lisp Interface Manager specification. + McCLIM is an open source implementation of the Common Lisp + Interface + Manager specification, + a powerful toolkit for writing GUIs in Common Lisp.

It is licensed under the GNU Library General Public License. @@ -136,7 +140,7 @@


-$Date: 2008/01/29 11:49:53 $ +$Date: 2008/02/05 12:59:56 $ From thenriksen at common-lisp.net Tue Feb 5 13:00:37 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 5 Feb 2008 08:00:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim-website Message-ID: <20080205130037.B7F1337006@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim-website In directory clnet:/tmp/cvs-serv18433 Modified Files: index.html Log Message: Name => title. --- /project/mcclim/cvsroot/mcclim-website/index.html 2008/02/05 12:59:56 1.3 +++ /project/mcclim/cvsroot/mcclim-website/index.html 2008/02/05 13:00:32 1.4 @@ -28,7 +28,7 @@ Interface Manager specification, - a powerful toolkit for writing GUIs in Common Lisp.

@@ -140,7 +140,7 @@

-$Date: 2008/02/05 12:59:56 $ +$Date: 2008/02/05 13:00:32 $ From thenriksen at common-lisp.net Tue Feb 5 13:44:33 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 5 Feb 2008 08:44:33 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080205134433.2F8532F062@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4120 Modified Files: menu-choose.lisp Log Message: Changed menu-choose to only much around with the position of the menu if it's a pane we created ourselves. --- /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2008/01/30 23:22:45 1.21 +++ /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2008/02/05 13:44:33 1.22 @@ -157,6 +157,10 @@ :cell-align-y (or cell-align-y :top) :row-wise row-wise)) +(defclass menu-pane (clim-stream-pane) + () + (:default-initargs :background *3d-normal-color*)) + ;; Spec macro. (defmacro with-menu ((menu &optional associated-window &key (deexpose t) label scroll-bars) @@ -179,8 +183,7 @@ *application-frame*)) (fm (frame-manager associated-frame))) (with-look-and-feel-realization (fm associated-frame) ; hmm... checkme - (let* ((menu-stream (make-pane-1 fm associated-frame 'clim-stream-pane - :background *3d-normal-color* #+NIL +gray80+)) + (let* ((menu-stream (make-pane-1 fm associated-frame 'menu-pane)) (container (scrolling (:scroll-bar scroll-bars) menu-stream)) (frame (make-menu-frame (raising () @@ -280,7 +283,7 @@ (values (min x2 max-width) (min y2 max-height))))) -(defmethod adjust-menu-size-and-position ((menu clim-stream-pane) +(defmethod adjust-menu-size-and-position ((menu menu-pane) &key x-position y-position) ;; Make sure the menu isn't higher or wider than the screen. (multiple-value-bind (menu-width menu-height) From thenriksen at common-lisp.net Tue Feb 5 16:58:51 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 5 Feb 2008 11:58:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080205165851.E89617212B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv23781 Modified Files: menu-choose.lisp Log Message: Don't kill the menu-choose popup at any gesture. --- /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2008/02/05 13:44:33 1.22 +++ /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2008/02/05 16:58:51 1.23 @@ -374,7 +374,7 @@ (handler-case (with-input-context (`(or ,presentation-type blank-area) :override t) (object type event) - (prog1 nil (read-gesture :stream menu)) + (prog1 nil (loop (read-gesture :stream menu))) (blank-area nil) (t (values object event))) (abort-gesture () nil))))) From thenriksen at common-lisp.net Tue Feb 5 21:51:29 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 5 Feb 2008 16:51:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080205215129.B2B6E3C0DA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv30487/Drei Modified Files: lisp-syntax-swine.lisp Log Message: Use frame-manager-menu-choose and find-frame-manager instead of menu-choose when asking for symbol completion. This permits Drei variants to use with-frame-manager to provide their own look and feel for the menu. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/04 17:44:50 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/05 21:51:29 1.16 @@ -868,15 +868,20 @@ t) (t (replace-symbol-at-mark syntax mark - (or (menu-choose (mapcar - #'(lambda (completion) - (if (listp completion) - (cons completion - (first completion)) - completion)) - completions) - :label "Possible completions" - :scroll-bars :vertical) + (or (when (or useful-token + (accept 'boolean + :prompt "You are asking for a list of all exported symbols, proceed?")) + (frame-manager-menu-choose + (find-frame-manager) + (mapcar + #'(lambda (completion) + (if (listp completion) + (cons completion + (first completion)) + completion)) + completions) + :label "Possible completions" + :scroll-bars :vertical)) longest)) t)))))) From thenriksen at common-lisp.net Thu Feb 7 20:20:06 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 7 Feb 2008 15:20:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080207202006.62DEC140F2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4973 Modified Files: input-editing.lisp Log Message: Use `format-items' when displaying inline completions. This makes it work better in the ESA minibuffer. --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/04 19:15:35 1.73 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/07 20:20:04 1.74 @@ -641,19 +641,14 @@ (with-input-editor-typeout (stream :erase t) (surrounding-output-with-border (stream :shape :drop-shadow :background +cornsilk1+) (surrounding-output-with-border (stream :shape :rectangle) - (let* ((possibility-count (length possibilities)) - (row-length (sqrt possibility-count)) - (ptype `(completion ,possibilities))) - (formatting-table (stream) - (loop until (null possibilities) - do (formatting-row (stream) - (loop for cell-index from 0 below row-length - until (null possibilities) - do (formatting-cell (stream) - (funcall possibility-printer - (pop possibilities) - ptype - stream))))))))))) + (let ((ptype `(completion ,possibilities))) + (format-items possibilities + :stream stream + :printer #'(lambda (possibility stream) + (funcall possibility-printer + possibility + ptype + stream)))))))) ;;; Helper returns gesture (or nil if gesture shouldn't be part of the input) ;;; and completion mode, if any. From thenriksen at common-lisp.net Fri Feb 8 10:37:46 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 8 Feb 2008 05:37:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080208103746.5FC366200B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv1392/Drei Modified Files: lisp-syntax-swank.lisp Log Message: Let's try not rebinding *standard-output* when asking Swank to compile stuff for us. This makes C-c C-c'ing in Climacs much more verbose. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2008/01/09 22:15:49 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2008/02/08 10:37:46 1.12 @@ -61,9 +61,6 @@ (view drei-buffer-view) (buffer-mark mark)) (let* ((view-name (name view)) (buffer-file-name (filepath (buffer view))) - ;; swank::compile-string-for-emacs binds *compile-verbose* to t - ;; so we need to do this to avoid scribbles on the pane - (*standard-output* *debug-io*) (swank::*buffer-package* package) (swank::*buffer-readtable* *readtable*)) (let ((result (swank::compile-string-for-emacs From thenriksen at common-lisp.net Fri Feb 8 11:17:09 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 8 Feb 2008 06:17:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080208111709.5DFD276337@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11149/Drei Modified Files: input-editor.lisp Log Message: Fixed obscure input-editing issue where the input position was sometimes set erroneously. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/04 19:06:17 1.41 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 11:17:08 1.42 @@ -161,17 +161,17 @@ (stream-scan-pointer stream)) (call-next-method)) (setf (stream-insertion-pointer stream) (offset ip-clone))) - (redraw-input-buffer stream)) - ;; We skip ahead of any noise strings to put us past the - ;; prompt. This is safe, because the noise strings are to be - ;; ignored anyway, but we need to be ahead to set the input - ;; position properly (ie. after the prompt). - (loop with buffer = (buffer (view (drei-instance stream))) - until (>= (stream-scan-pointer stream) (size buffer)) - while (or (typep #1=(buffer-object buffer (stream-scan-pointer stream)) 'noise-string) - (delimiter-gesture-p #1#)) - do (incf (stream-scan-pointer stream))) - (setf (input-position stream) (stream-scan-pointer stream)))) + (redraw-input-buffer stream))) + ;; We skip ahead of any noise strings to put us past the + ;; prompt. This is safe, because the noise strings are to be + ;; ignored anyway, but we need to be ahead to set the input + ;; position properly (ie. after the prompt). + (loop with buffer = (buffer (view (drei-instance stream))) + until (>= (stream-scan-pointer stream) (size buffer)) + while (or (typep #1=(buffer-object buffer (stream-scan-pointer stream)) 'noise-string) + (delimiter-gesture-p #1#)) + do (incf (stream-scan-pointer stream))) + (setf (input-position stream) (stream-scan-pointer stream))) (defmethod stream-accept :after ((stream drei-input-editing-mixin) type &key &allow-other-keys) ;; If we end up asking for more input using the stream, we do not @@ -514,9 +514,7 @@ (t (unless peek-p (incf scan-pointer)) - (return-from stream-read-gesture gesture)) - (t (incf scan-pointer) - (setf last-was-noisy nil))))) + (return-from stream-read-gesture gesture))))) (unless last-was-noisy ; This prevents double-prompting. (setf (stream-rescanning stream) nil)) (when activation-gesture From thenriksen at common-lisp.net Fri Feb 8 11:29:17 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 8 Feb 2008 06:29:17 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080208112917.999C61131@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv14662/Drei Modified Files: input-editor.lisp Log Message: Removed stale hack. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 11:17:08 1.42 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 11:29:17 1.43 @@ -625,15 +625,9 @@ (setf (activation-gesture stream) gesture) (rescan-if-necessary stream) (return-from stream-process-gesture gesture)) - ;; XXX: The problem is that `*original-stream*' is a subclass of - ;; DREI-INPUT-EDITING-MIXIN (`stream', actually) at this point, - ;; which has an array as input buffer (as demanded by the spec), - ;; while the `stream-unread-gesture' method expects an event queue. - (let ((*original-stream* nil) - (*standard-input* (encapsulating-stream-stream stream))) - (when (proper-gesture-p gesture) - (unread-gesture gesture)) - (read-gestures-and-act stream gesture type))) + (when (proper-gesture-p gesture) + (unread-gesture gesture :stream (encapsulating-stream-stream stream))) + (read-gestures-and-act stream gesture type)) (defmethod reset-scan-pointer ((stream drei-input-editing-mixin) &optional (scan-pointer 0)) From thenriksen at common-lisp.net Fri Feb 8 11:36:37 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 8 Feb 2008 06:36:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080208113637.14AC3610B2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv16323/Drei Modified Files: input-editor.lisp Log Message: Fixed yet another random input-editor issue. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 11:29:17 1.43 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 11:36:35 1.44 @@ -594,7 +594,7 @@ ;; No change actually took place, even though IP may ;; have moved. nil) - ((< first-mismatch (stream-scan-pointer stream)) + ((<= first-mismatch (stream-scan-pointer stream)) ;; Eek, change before scan pointer - this probably ;; changes the scan, so we'll have to rescan ;; everything. Bummer! From thenriksen at common-lisp.net Fri Feb 8 12:43:59 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 8 Feb 2008 07:43:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080208124359.3F5E81C09F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv2460/Drei Modified Files: input-editor.lisp Log Message: Now actually fixed some more things. Net result: input-editing should be more stable and predictable. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 11:36:35 1.44 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 12:43:59 1.45 @@ -556,6 +556,7 @@ `stream-read-gesture' for the stream encapsulated by `stream'. The second return value of this function will be `type' if stuff is inserted after the insertion pointer." + (assert (<= (input-position stream) (stream-scan-pointer stream))) (let* ((drei (drei-instance stream)) (*command-processor* drei) (was-directly-processing (directly-processing-p drei)) @@ -588,13 +589,14 @@ (when was-directly-processing (display-message "Aborted"))))))) (update-drei-buffer stream)) - (let ((first-mismatch (prefix-size (view drei)))) + (let ((first-mismatch (when (plusp (prefix-size (view drei))) + (prefix-size (view drei))))) (display-drei drei :redisplay-minibuffer t) (cond ((null first-mismatch) ;; No change actually took place, even though IP may ;; have moved. nil) - ((<= first-mismatch (stream-scan-pointer stream)) + ((< first-mismatch (stream-scan-pointer stream)) ;; Eek, change before scan pointer - this probably ;; changes the scan, so we'll have to rescan ;; everything. Bummer! From thenriksen at common-lisp.net Fri Feb 8 13:24:49 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 8 Feb 2008 08:24:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080208132449.30BE1610B8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv19251/Drei Modified Files: input-editor.lisp Log Message: Finally make that ridiculously complated input-editor do as I want it do to! Slowish, but who cares? Perhaps the input-editor needs a special buffer implementation... --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 12:43:59 1.45 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/02/08 13:24:48 1.46 @@ -558,9 +558,11 @@ if stuff is inserted after the insertion pointer." (assert (<= (input-position stream) (stream-scan-pointer stream))) (let* ((drei (drei-instance stream)) + (buffer (buffer (view drei))) (*command-processor* drei) (was-directly-processing (directly-processing-p drei)) - (*drei-input-editing-stream* stream)) + (*drei-input-editing-stream* stream) + (old-buffer-contents (buffer-sequence buffer 0 (size buffer)))) (with-bound-drei-special-variables (drei :prompt "M-x ") (update-drei-buffer stream) ;; Commands are permitted to signal immediate rescans, but @@ -573,7 +575,7 @@ (drei-core:with-narrowed-buffer (drei (loop for index from (1- (input-position stream)) above 0 - when (typep (buffer-object (buffer (view drei)) index) + when (typep (buffer-object buffer index) 'noise-string) return (1+ index) finally (return 0)) @@ -589,8 +591,7 @@ (when was-directly-processing (display-message "Aborted"))))))) (update-drei-buffer stream)) - (let ((first-mismatch (when (plusp (prefix-size (view drei))) - (prefix-size (view drei))))) + (let ((first-mismatch (buffer-array-mismatch buffer old-buffer-contents))) (display-drei drei :redisplay-minibuffer t) (cond ((null first-mismatch) ;; No change actually took place, even though IP may From thenriksen at common-lisp.net Fri Feb 8 18:05:51 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 8 Feb 2008 13:05:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080208180551.827A46400A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31674/Drei Modified Files: lisp-syntax-commands.lisp Log Message: Added argument hinting for Lisp when entering newlines and right parentheses. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2008/01/17 11:29:55 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2008/02/08 18:05:51 1.17 @@ -90,16 +90,21 @@ "Show argument list for a given symbol." (show-arglist (current-syntax) symbol)) -(define-command (com-space :command-table lisp-table) +(define-command (com-self-insert-then-arglist :command-table lisp-table) () - "Insert a space and display argument hints in the minibuffer." - (insert-character #\Space) - ;; We must update the syntax in order to reflect any changes to - ;; the parse tree our insertion of a space character may have - ;; done. + "Insert the gesture used to invoke this command and display +argument hints in the minibuffer." + (insert-character *current-gesture*) (show-arglist-for-form-at-mark (point) (current-syntax)) (clear-completions)) +(define-command (com-newline-indent-then-arglist :command-table lisp-table) () + "Inserts a newline, indents the new line, then displays +argument hints in the minibuffer." + (insert-object (point) #\Newline) + (indent-current-line (current-view) (point)) + (show-arglist-for-form-at-mark (point) (current-syntax))) + (define-command (com-complete-symbol :name t :command-table lisp-table) () "Attempt to complete the symbol at mark. If successful, move point @@ -216,10 +221,14 @@ 'lisp-table '((#\c :control) (#\d :control) (#\a))) -(set-key 'com-space +(set-key 'com-self-insert-then-arglist 'lisp-table '((#\Space))) +(set-key 'com-self-insert-then-arglist + 'lisp-table + '((#\)))) + (set-key 'com-complete-symbol 'lisp-table '((#\Tab :meta))) @@ -232,7 +241,7 @@ 'lisp-table '((#\Tab))) -(set-key 'drei-commands::com-newline-and-indent +(set-key 'com-newline-indent-then-arglist 'lisp-table '(#\Newline)) From thenriksen at common-lisp.net Fri Feb 8 18:37:32 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 8 Feb 2008 13:37:32 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080208183732.CE4A5610EE@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6421/Drei Modified Files: syntax.lisp Log Message: Fixed command table inheritance so syntax modes take precedence over the syntax itself. --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/30 11:48:40 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/02/08 18:37:32 1.18 @@ -43,7 +43,7 @@ (defgeneric syntax-command-tables (syntax) (:documentation "Returns additional command tables provided by `syntax'.") - (:method-combination append) + (:method-combination append :most-specific-last) (:method append ((syntax syntax)) (list (command-table syntax)))) From thenriksen at common-lisp.net Sun Feb 10 00:42:03 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 9 Feb 2008 19:42:03 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080210004203.7AD7A12061@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv32363/Drei Modified Files: lisp-syntax.lisp lr-syntax.lisp Log Message: Added notion of "sticky" highlighting rules to LR syntax. Used this to add syntax highlighting for reader conditionals in Lisp syntax. Has instant gratification - faster than SLIME! (Ok, we cheat, and can just look at the running Lisp, but anyway.) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/31 18:44:36 1.73 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/02/10 00:42:03 1.74 @@ -994,7 +994,8 @@ ;;;;;;;;;;;;;;;; Reader conditionals ;;; parse trees -(defclass reader-conditional-form (form) ()) +(defclass reader-conditional-form (form) + ((%conditional-true-p :accessor conditional-true-p))) (defclass reader-conditional-positive-form (reader-conditional-form) ()) (defclass reader-conditional-negative-form (reader-conditional-form) ()) @@ -1833,6 +1834,20 @@ (progn (cache-symbol-info syntax symbol-form) (global-boundp symbol-form)))) +(defun cache-conditional-info (syntax form) + "Cache information about the reader conditional `symbol-form' represents, +so that it can be quickly looked up later." + (setf (conditional-true-p form) + (eval-feature-conditional (second-noncomment (children form)) syntax))) + +(defun reader-conditional-true (syntax form) + "Return true if the reader conditional `form' has a true +condition." + (if (slot-boundp form '%conditional-true-p) + (conditional-true-p form) + (progn (cache-conditional-info syntax form) + (conditional-true-p form)))) + (defun parenthesis-highlighter (view form) "Return the drawing style with which the parenthesis lexeme `form' should be highlighted." @@ -1844,6 +1859,23 @@ +bold-face-drawing-options+ +default-drawing-options+)) +(defun reader-conditional-rule-fn (positive comment-options) + "Return a function for use as a syntax highlighting +rule-generator for reader conditionals. If `positive', the +function will be for positive +reader-conditionals. `Comment-options' is the drawing options +object that will be returned when the conditional is not +fulfilled." + (if positive + #'(lambda (view form) + (if (reader-conditional-true (syntax view) form) + +default-drawing-options+ + (values comment-options t))) + #'(lambda (view form) + (if (not (reader-conditional-true (syntax view) form)) + +default-drawing-options+ + (values comment-options t))))) + (define-syntax-highlighting-rules emacs-style-highlighting (error-lexeme (*error-drawing-options*)) (string-form (*string-drawing-options*)) @@ -1857,18 +1889,29 @@ ((symbol-form-is-boundp (syntax view) form) *special-variable-drawing-options*) (t +default-drawing-options+))))) - (parenthesis-lexeme (:function #'parenthesis-highlighter))) + (parenthesis-lexeme (:function #'parenthesis-highlighter)) + (reader-conditional-positive-form + (:function (reader-conditional-rule-fn t *comment-drawing-options*))) + (reader-conditional-negative-form + (:function (reader-conditional-rule-fn nil *comment-drawing-options*)))) + +(defvar *retro-comment-drawing-options* + (make-drawing-options :face (make-face :ink +dimgray+)) + "The drawing options used for retro-highlighting in Lisp syntax.") (define-syntax-highlighting-rules retro-highlighting (error-symbol (*error-drawing-options*)) (string-form (:options :face +italic-face+)) - (comment (:face :ink +dimgray+)) + (comment (*retro-comment-drawing-options*)) (literal-object-form (:options :function (object-drawer))) (complete-token-form (:function #'(lambda (syntax form) (cond ((symbol-form-is-macrobound-p syntax form) +bold-face-drawing-options+) (t +default-drawing-options+))))) - ;; XXX: Ugh, copied from above. + (reader-conditional-positive-form + (:function (reader-conditional-rule-fn t *retro-comment-drawing-options*))) + (reader-conditional-negative-form + (:function (reader-conditional-rule-fn nil *retro-comment-drawing-options*))) (parenthesis-lexeme (:function #'parenthesis-highlighter))) (defparameter *syntax-highlighting-rules* 'emacs-style-highlighting --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/09 11:14:08 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/02/10 00:42:03 1.17 @@ -443,7 +443,18 @@ Alternatively, `type' can be any object (usually a dynamically bound symbol), in which case it will be evaluated to get the -drawing options." +drawing options. + +`Type' can also be a list, in which case the first element will +be interpreted as described above, and the remaining elements +will be considered keyword arguments. The following keyword +arguments are supported: + + `:sticky': if true, the syntax highlighting options defined by + this rule will apply to all children as well, effectively + overriding their options. The default is false. For a + `:function', `:sticky' will not work. Instead, return a true + secondary value from the function." (check-type name symbol) `(progn (fmakunbound ',name) @@ -451,18 +462,20 @@ (:method (view (parser-symbol parser-symbol)) nil)) ,@(flet ((make-rule-exp (type args) - (case type - (:face `(let ((options (make-drawing-options :face (make-face , at args)))) - #'(lambda (view parser-symbol) - (declare (ignore view parser-symbol)) - options))) - (:options `#'(lambda (view parser-symbol) - (declare (ignore view parser-symbol)) - (make-drawing-options , at args))) - (:function (first args)) - (t `#'(lambda (view parser-symbol) - (declare (ignore view parser-symbol)) - ,type))))) + (let ((actual-type (first (listed type)))) + (destructuring-bind (&key sticky) (rest (listed type)) + (case actual-type + (:face `(let ((options (make-drawing-options :face (make-face , at args)))) + #'(lambda (view parser-symbol) + (declare (ignore view parser-symbol)) + (values options ,sticky)))) + (:options `#'(lambda (view parser-symbol) + (declare (ignore view parser-symbol)) + (values (make-drawing-options , at args) ,sticky))) + (:function (first args)) + (t `#'(lambda (view parser-symbol) + (declare (ignore view parser-symbol)) + (values ,actual-type ,sticky)))))))) (loop for (parser-symbol (type . args)) in rules collect `(let ((rule ,(make-rule-exp type args))) (defmethod ,name (view (parser-symbol ,parser-symbol)) @@ -499,6 +512,18 @@ parser-symbol offset drawing-options highlighting-rules) +(defstruct (drawing-options-frame + (:constructor make-drawing-options-frame + (end-offset drawing-options sticky-p)) + (:conc-name frame-)) + "An entry in the drawing options stack maintained by the +`pump-state' structure. `End-offset' is the end buffer offset +for the frame, `drawing-options' is the drawing options that +should be used until that offset, and if `sticky-p' is true it +will not be possible to put other frames on top of this one in +the stack." + end-offset drawing-options sticky-p) + (defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) (syntax lr-syntax-mixin) (offset integer)) (update-parse syntax 0 (size (buffer view))) @@ -506,15 +531,18 @@ (highlighting-rules (syntax-highlighting-rules syntax))) (labels ((initial-drawing-options (parser-symbol) (if (null parser-symbol) - (cons (size (buffer view)) +default-drawing-options+) - (let ((drawing-options - (get-drawing-options highlighting-rules view parser-symbol))) + (make-drawing-options-frame + (size (buffer view)) +default-drawing-options+ nil) + (multiple-value-bind (drawing-options sticky) + (get-drawing-options highlighting-rules view parser-symbol) (if (null drawing-options) (initial-drawing-options (parent parser-symbol)) - (cons (end-offset parser-symbol) drawing-options)))))) + (make-drawing-options-frame (end-offset parser-symbol) + drawing-options sticky)))))) (make-pump-state parser-symbol offset (list (initial-drawing-options parser-symbol) - (cons (1+ (size (buffer view))) +default-drawing-options+)) + (make-drawing-options-frame + (1+ (size (buffer view))) +default-drawing-options+ nil)) highlighting-rules)))) (defun find-next-stroke-end (view pump-state) @@ -527,15 +555,16 @@ (highlighting-rules pump-state-highlighting-rules)) pump-state (let ((line (line-containing-offset (syntax view) offset))) - (flet ((finish (offset symbol &optional stroke-drawing-options) + (flet ((finish (new-offset symbol &optional stroke-drawing-options sticky-p) (setf start-symbol symbol) - (loop until (> (car (first drawing-options)) offset) - do (pop drawing-options)) (unless (null stroke-drawing-options) - (push (cons (end-offset symbol) stroke-drawing-options) + (push (if (frame-sticky-p (first drawing-options)) + (make-drawing-options-frame + (end-offset symbol) (frame-drawing-options (first drawing-options)) t) + (make-drawing-options-frame + (end-offset symbol) stroke-drawing-options sticky-p)) drawing-options)) - (return-from find-next-stroke-end - offset))) + (return-from find-next-stroke-end new-offset))) (cond ((null start-symbol) ;; This means that all remaining lines are blank. (finish (line-end-offset line) nil)) @@ -543,28 +572,38 @@ (= offset (start-offset start-symbol))) (finish (end-offset start-symbol) start-symbol nil)) (t - (or (do-parse-symbols-forward (symbol offset start-symbol) - (let ((symbol-drawing-options - (get-drawing-options highlighting-rules view symbol))) - (cond ((> (start-offset symbol) (line-end-offset line)) - (finish (line-end-offset line) start-symbol)) - ((and (typep symbol 'literal-object-mixin)) - (finish (start-offset symbol) symbol - (or symbol-drawing-options - (make-drawing-options :function (object-drawer))))) - ((and (> (start-offset symbol) offset) - (not (drawing-options-equal (or symbol-drawing-options - +default-drawing-options+) - (cdr (first drawing-options)))) - (if (null symbol-drawing-options) - (>= (start-offset symbol) (car (first drawing-options))) - t)) - (finish (start-offset symbol) symbol symbol-drawing-options)) - ((and (= (start-offset symbol) offset) - symbol-drawing-options - (not (drawing-options-equal symbol-drawing-options - (cdr (first drawing-options))))) - (finish (start-offset symbol) symbol symbol-drawing-options))))) + (or (let* ((current-frame (first drawing-options)) + (currently-used-options (frame-drawing-options current-frame))) + (do-parse-symbols-forward (symbol offset start-symbol) + (multiple-value-bind (symbol-drawing-options sticky) + (get-drawing-options highlighting-rules view symbol) + ;; Remove frames that are no longer applicable... + (loop until (> (frame-end-offset (first drawing-options)) + (start-offset symbol)) + do (pop drawing-options)) + (let ((options-to-be-used (if (frame-sticky-p (first drawing-options)) + (frame-drawing-options (first drawing-options)) + symbol-drawing-options))) + (cond ((> (start-offset symbol) (line-end-offset line)) + (finish (line-end-offset line) start-symbol)) + ((and (typep symbol 'literal-object-mixin)) + (finish (start-offset symbol) symbol + (or symbol-drawing-options + (make-drawing-options :function (object-drawer))))) + ((and (> (start-offset symbol) offset) + (not (drawing-options-equal (or options-to-be-used + +default-drawing-options+) + currently-used-options)) + (if (null symbol-drawing-options) + (>= (start-offset symbol) (frame-end-offset current-frame)) + t)) + (finish (start-offset symbol) symbol symbol-drawing-options sticky)) + ((and (= (start-offset symbol) offset) + symbol-drawing-options + (not (drawing-options-equal + options-to-be-used + (frame-drawing-options (first drawing-options))))) + (finish (start-offset symbol) symbol symbol-drawing-options sticky))))))) ;; If there are no more parse symbols, we just go ;; line-by-line from here. This should mean that all ;; remaining lines are blank. @@ -578,11 +617,15 @@ (with-accessors ((offset pump-state-offset) (current-drawing-options pump-state-drawing-options)) pump-state - (let ((old-drawing-options (cdr (first current-drawing-options))) - (end-offset (find-next-stroke-end view pump-state))) + (let ((old-drawing-options (frame-drawing-options (first current-drawing-options))) + (end-offset (find-next-stroke-end view pump-state)) + (old-offset offset)) (setf (stroke-start-offset stroke) offset (stroke-end-offset stroke) end-offset (stroke-drawing-options stroke) old-drawing-options offset (if (offset-end-of-line-p (buffer view) end-offset) (1+ end-offset) - end-offset)))))) + end-offset)) + ;; Don't use empty strokes, try again... + (when (= old-offset offset) + (stroke-pump-with-syntax view syntax stroke pump-state)))))) From thenriksen at common-lisp.net Mon Feb 11 19:26:34 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 11 Feb 2008 14:26:34 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim-website Message-ID: <20080211192634.0A0B381027@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim-website In directory clnet:/tmp/cvs-serv18182 Modified Files: index.html Log Message: Some more Google-optimisation. --- /project/mcclim/cvsroot/mcclim-website/index.html 2008/02/05 13:00:32 1.4 +++ /project/mcclim/cvsroot/mcclim-website/index.html 2008/02/11 19:26:32 1.5 @@ -1,15 +1,20 @@ - McCLIM + McCLIM - A powerful GUI toolkit for Common Lisp + +
-

Welcome

+

A GUI toolkit for Common Lisp

@@ -140,7 +145,7 @@

-$Date: 2008/02/05 13:00:32 $ +$Date: 2008/02/11 19:26:32 $ From thenriksen at common-lisp.net Mon Feb 11 22:50:04 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 11 Feb 2008 17:50:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20080211225004.CF12A5D168@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv23082/Apps/Inspector Modified Files: inspector.lisp Log Message: Flayed Fundamental syntax, most of what it used to do is now done by the drei-buffer-view directly. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/02/03 23:42:01 1.42 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/02/11 22:50:04 1.43 @@ -47,7 +47,7 @@ :display-function 'display-app) (int :interactor :width 600 :height 100 :max-height 100)) (:layouts - (default (vertically () (scrolling () app) int)))) + (default (vertically () (scrolling () app) #+nil int)))) (defmethod initialize-instance :after ((frame inspector) &rest args) (declare (ignore args)) From thenriksen at common-lisp.net Mon Feb 11 22:50:09 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 11 Feb 2008 17:50:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080211225009.6D123601A8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23082/Drei Modified Files: fundamental-syntax.lisp lr-syntax.lisp packages.lisp views.lisp Log Message: Flayed Fundamental syntax, most of what it used to do is now done by the drei-buffer-view directly. --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/07 22:01:53 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/02/11 22:50:04 1.12 @@ -34,119 +34,22 @@ ;;; The syntax object and misc stuff. (define-syntax fundamental-syntax (syntax) - ((lines :initform (make-instance 'standard-flexichain) - :reader lines) - (scan :accessor scan)) + () (:command-table fundamental-table) (:name "Fundamental")) -(defmethod initialize-instance :after ((syntax fundamental-syntax) &rest args) - (declare (ignore args)) - (with-accessors ((buffer buffer) (scan scan)) syntax - (setf scan (make-buffer-mark buffer 0 :left)))) - (setf *default-syntax* 'fundamental-syntax) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; update syntax -(defclass line-object () - ((%start-mark :reader start-mark - :initarg :start-mark) - (%line-length :reader line-length - :initarg :line-length) - (%chunks :accessor chunks - :initform (make-array 5 - :adjustable t - :fill-pointer 0) - :documentation "A list of cons-cells, with the car -being a buffer offset relative to the `start-mark' of the line, -and the cdr being T if the chunk covers a non-character, and NIL -if it covers a character sequence."))) - -(defun line-end-offset (line) - "Return the end buffer offset of `line'." - (+ (offset (start-mark line)) (line-length line))) - -(defun get-chunk (buffer line-start-offset chunk-start-offset line-end-offset) - "Return a chunk in the form of a cons cell. The chunk will -start at `chunk-start-offset' and extend no further than -`line-end-offset'." - (let* ((chunk-end-offset (buffer-find-nonchar - buffer chunk-start-offset - (min (+ *maximum-chunk-size* - chunk-start-offset) - line-end-offset)))) - (cond ((= chunk-start-offset line-end-offset) - (cons (- chunk-end-offset - line-start-offset) nil)) - ((or (not (= chunk-end-offset chunk-start-offset)) - (and (offset-beginning-of-line-p buffer chunk-start-offset) - (offset-end-of-line-p buffer chunk-end-offset))) - (cons (- chunk-end-offset - line-start-offset) nil)) - ((not (characterp (buffer-object buffer chunk-end-offset))) - (cons (- (1+ chunk-end-offset) - line-start-offset) t))))) - (defmethod update-syntax values-max-min ((syntax fundamental-syntax) prefix-size suffix-size &optional begin end) (declare (ignore begin end)) - (let ((low-mark (make-buffer-mark (buffer syntax) prefix-size :left)) - (high-mark (make-buffer-mark - (buffer syntax) (- (size (buffer syntax)) suffix-size) :left))) - (when (mark<= low-mark high-mark) - (beginning-of-line low-mark) - (end-of-line high-mark) - (with-slots (lines scan) syntax - (let ((low-index 0) - (high-index (nb-elements lines))) - ;; Binary search for the start of changed lines. - (loop while (< low-index high-index) - do (let* ((middle (floor (+ low-index high-index) 2)) - (line-start (start-mark (element* lines middle)))) - (cond ((mark> low-mark line-start) - (setf low-index (1+ middle))) - (t - (setf high-index middle))))) - ;; Discard lines that have to be re-analyzed. - (loop while (and (< low-index (nb-elements lines)) - (mark<= (start-mark (element* lines low-index)) - high-mark)) - do (delete* lines low-index)) - ;; Analyze new lines. - (setf (offset scan) (offset low-mark)) - (loop while (mark<= scan high-mark) - for i from low-index - do (progn (let ((line-start-mark (clone-mark scan))) - (insert* lines i (make-instance - 'line-object - :start-mark line-start-mark - :line-length (- (offset (end-of-line scan)) - (offset line-start-mark)))) - (if (end-of-buffer-p scan) - (loop-finish) - ;; skip newline - (forward-object scan)))))))) - ;; Fundamental syntax always parses the entire buffer. - (values 0 (size (buffer syntax))))) - -(defmethod initialize-instance :after ((line line-object) - &rest initargs) - (declare (ignore initargs)) - (loop with buffer = (buffer (start-mark line)) - with line-start-offset = (offset (start-mark line)) - with line-end-offset = (+ line-start-offset (line-length line)) - with chunk-start-offset = line-start-offset - for chunk-info = (get-chunk buffer - line-start-offset - chunk-start-offset line-end-offset) - do (vector-push-extend chunk-info (chunks line)) - (setf chunk-start-offset (+ (car chunk-info) - line-start-offset)) - when (= chunk-start-offset line-end-offset) - do (loop-finish))) + ;; We do nothing. Technically, Fundamental syntax always parses the + ;; entire buffer, though. + (values 0 (size (buffer syntax)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -165,20 +68,19 @@ (defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) (syntax fundamental-syntax) (offset integer)) - (update-parse syntax 0 offset) ;; Perform binary search looking for line starting with `offset'. - (with-accessors ((lines lines)) syntax + (with-accessors ((lines lines)) view (loop with low-index = 0 - with high-index = (nb-elements lines) - for middle = (floor (+ low-index high-index) 2) - for line-start = (start-mark (element* lines middle)) - do (cond ((mark> offset line-start) - (setf low-index (1+ middle))) - ((mark< offset line-start) - (setf high-index middle)) - ((mark= offset line-start) - (loop-finish))) - finally (return (make-pump-state middle offset 0))))) + with high-index = (nb-elements lines) + for middle = (floor (+ low-index high-index) 2) + for line-start = (start-mark (element* lines middle)) + do (cond ((mark> offset line-start) + (setf low-index (1+ middle))) + ((mark< offset line-start) + (setf high-index middle)) + ((mark= offset line-start) + (loop-finish))) + finally (return (make-pump-state middle offset 0))))) (defun fetch-chunk (line chunk-index) "Retrieve the `chunk-index'th chunk from `line'. The return @@ -199,9 +101,8 @@ (with-accessors ((line-index pump-state-line-index) (offset pump-state-offset) (chunk-index pump-state-chunk-index)) pump-state - (update-parse syntax 0 offset) (let* ((chunk (fetch-chunk - (element* (lines syntax) line-index) chunk-index)) + (element* (lines view) line-index) chunk-index)) (drawing-options (if (functionp chunk) (make-drawing-options :function chunk) +default-drawing-options+)) @@ -222,31 +123,6 @@ ;;; ;;; exploit the parse -(defun offset-in-line-p (line offset) - "Return true if `offset' is in the buffer region delimited by -`line'." - (<= (offset (start-mark line)) offset - (line-end-offset line))) - -(defun line-containing-offset (syntax mark-or-offset) - "Return the line `mark-or-offset' is in for `syntax'. `Syntax' -must be a `fundamental-syntax' object." - ;; Perform binary search looking for line containing `offset1'. - (as-offsets ((offset mark-or-offset)) - (with-accessors ((lines lines)) syntax - (loop with low-index = 0 - with high-index = (nb-elements lines) - for middle = (floor (+ low-index high-index) 2) - for this-line = (element* lines middle) - for line-start = (start-mark this-line) - do (cond ((offset-in-line-p this-line offset) - (loop-finish)) - ((mark> offset line-start) - (setf low-index (1+ middle))) - ((mark< offset line-start) - (setf high-index middle))) - finally (return this-line))))) - ;; do this better (defmethod syntax-line-indentation ((syntax fundamental-syntax) mark tab-width) 0) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/02/10 00:42:03 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/02/11 22:50:05 1.18 @@ -35,7 +35,8 @@ (current-state) (initial-state :initarg :initial-state) (current-start-mark) - (current-size))) + (current-size) + (scan :accessor scan))) (defmethod initialize-instance :after ((syntax lr-syntax-mixin) &rest args) (declare (ignore args)) @@ -554,7 +555,8 @@ (drawing-options pump-state-drawing-options) (highlighting-rules pump-state-highlighting-rules)) pump-state - (let ((line (line-containing-offset (syntax view) offset))) + (let* ((line (line-containing-offset view offset)) + (line-end-offset (end-offset line))) (flet ((finish (new-offset symbol &optional stroke-drawing-options sticky-p) (setf start-symbol symbol) (unless (null stroke-drawing-options) @@ -567,7 +569,7 @@ (return-from find-next-stroke-end new-offset))) (cond ((null start-symbol) ;; This means that all remaining lines are blank. - (finish (line-end-offset line) nil)) + (finish line-end-offset nil)) ((and (typep start-symbol 'literal-object-mixin) (= offset (start-offset start-symbol))) (finish (end-offset start-symbol) start-symbol nil)) @@ -584,8 +586,8 @@ (let ((options-to-be-used (if (frame-sticky-p (first drawing-options)) (frame-drawing-options (first drawing-options)) symbol-drawing-options))) - (cond ((> (start-offset symbol) (line-end-offset line)) - (finish (line-end-offset line) start-symbol)) + (cond ((> (start-offset symbol) line-end-offset) + (finish line-end-offset start-symbol)) ((and (typep symbol 'literal-object-mixin)) (finish (start-offset symbol) symbol (or symbol-drawing-options @@ -607,7 +609,7 @@ ;; If there are no more parse symbols, we just go ;; line-by-line from here. This should mean that all ;; remaining lines are blank. - (finish (line-end-offset line) nil)))))))) + (finish line-end-offset nil)))))))) (defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) (syntax lr-syntax-mixin) stroke --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/31 12:14:05 1.50 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/11 22:50:05 1.51 @@ -217,11 +217,18 @@ ;; Views and their facilities. #:drei-view #:modified-p #:no-cursors + #:drei-buffer-view #:buffer #:top #:bot #:buffer-view-p + #:lines + #:buffer-line #:start-mark #:line-length #:chunks #:end-offset + #:line-containing-offset #:offset-in-line-p + #:drei-syntax-view #:syntax #:syntax-view-p #:pump-state-for-offset-with-syntax #:stroke-pump-with-syntax + #:point-mark-view #:point-mark-view-p + #:textual-drei-syntax-view #:tab-space-count #:space-width #:tab-width #:use-tabs #:auto-fill-mode #:auto-fill-column @@ -509,9 +516,7 @@ (defpackage :drei-fundamental-syntax (:use :clim-lisp :clim :drei-buffer :drei-base :drei-syntax :flexichain :drei :drei-core :esa-utils) - (:export #:fundamental-syntax #:scan - #:start-mark #:line-length #:line-end-offset - #:line-containing-offset #:offset-in-line-p) + (:export #:fundamental-syntax) (:documentation "Implementation of the basic syntax module for editing plain text.")) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/03 07:16:48 1.34 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/11 22:50:05 1.35 @@ -550,6 +550,10 @@ (:documentation "Scroll `view', which is displayed on `pane', a page up.")) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Buffer view + (defclass drei-buffer-view (drei-view) ((%buffer :accessor buffer :initarg :buffer @@ -595,7 +599,11 @@ :documentation "A list of (start . end) conses of buffer offsets, delimiting the regions of the buffer that have changed since the last redisplay. The regions are not -overlapping, and are sorted in ascending order.")) +overlapping, and are sorted in ascending order.") + (lines :initform (make-instance 'standard-flexichain) + :reader lines + :documentation "The lines of the buffer, stored in a +format that makes it easy to retrieve information about them.")) (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' object. The buffer is displayed on a simple line-by-line basis, @@ -615,7 +623,8 @@ :read-only read-only :initial-contents initial-contents))) (setf top (make-buffer-mark (buffer view) 0 :left) - bot (make-buffer-mark (buffer view) (size (buffer view)) :right)))) + bot (make-buffer-mark (buffer view) (size (buffer view)) :right)) + (update-line-data view 0 (size (buffer view))))) (defmethod (setf top) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view)) @@ -674,11 +683,143 @@ list)))) (setf (changed-regions view) (worker (changed-regions view))))) +(defclass buffer-line () + ((%start-mark :reader start-mark + :initarg :start-mark + :documentation "The mark at which this line starts.") + (%line-length :reader line-length + :initarg :line-length + :documentation "The length of the line described by this object.") + (%chunks :accessor chunks + :initform (make-array 5 + :adjustable t + :fill-pointer 0) + :documentation "A list of cons-cells, with the car +being a buffer offset relative to the `start-mark' of the line, +and the cdr being T if the chunk covers a non-character, and NIL +if it covers a character sequence.")) + (:documentation "An object describing a single line in the +buffer associated with a `drei-buffer-view'")) + +(defmethod initialize-instance :after ((line buffer-line) + &rest initargs) + (declare (ignore initargs)) + (loop with buffer = (buffer (start-mark line)) + with line-start-offset = (offset (start-mark line)) + with line-end-offset = (+ line-start-offset (line-length line)) + with chunk-start-offset = line-start-offset + for chunk-info = (get-chunk buffer + line-start-offset + chunk-start-offset line-end-offset) + do (vector-push-extend chunk-info (chunks line)) + (setf chunk-start-offset (+ (car chunk-info) + line-start-offset)) + when (= chunk-start-offset line-end-offset) + do (loop-finish))) + +(defmethod end-offset ((line buffer-line)) + "Return the end buffer offset of `line'." + (+ (offset (start-mark line)) (line-length line))) + +(defun get-chunk (buffer line-start-offset chunk-start-offset line-end-offset) + "Return a chunk in the form of a cons cell. The chunk will +start at `chunk-start-offset' and extend no further than +`line-end-offset'." + (let* ((chunk-end-offset (buffer-find-nonchar + buffer chunk-start-offset + (min (+ *maximum-chunk-size* + chunk-start-offset) + line-end-offset)))) + (cond ((= chunk-start-offset line-end-offset) + (cons (- chunk-end-offset + line-start-offset) nil)) + ((or (not (= chunk-end-offset chunk-start-offset)) + (and (offset-beginning-of-line-p buffer chunk-start-offset) + (offset-end-of-line-p buffer chunk-end-offset))) + (cons (- chunk-end-offset + line-start-offset) nil)) + ((not (characterp (buffer-object buffer chunk-end-offset))) + (cons (- (1+ chunk-end-offset) + line-start-offset) t))))) + +(defun update-line-data (view start end) + "Update the sequence of lines stored by the `drei-buffer-view' +`view'. `Start' and `end' are buffer offsets delimiting the +region that has changed since the last update." + (let ((low-mark (make-buffer-mark (buffer view) start :left)) + (high-mark (make-buffer-mark (buffer view) end :left))) + (when (mark<= low-mark high-mark) + (beginning-of-line low-mark) + (end-of-line high-mark) + (with-accessors ((lines lines)) view + (let ((low-index 0) + (high-index (nb-elements lines))) + ;; Binary search for the start of changed lines. + (loop while (< low-index high-index) + do (let* ((middle (floor (+ low-index high-index) 2)) + (line-start (start-mark (element* lines middle)))) + (cond ((mark> low-mark line-start) + (setf low-index (1+ middle))) + (t + (setf high-index middle))))) + ;; Discard lines that have to be re-analyzed. + (loop while (and (< low-index (nb-elements lines)) + (mark<= (start-mark (element* lines low-index)) + high-mark)) + do (delete* lines low-index)) + ;; Analyze new lines. + (loop while (mark<= low-mark high-mark) + for i from low-index + do (progn (let ((line-start-mark (clone-mark low-mark))) + (insert* lines i (make-instance + 'buffer-line + :start-mark line-start-mark + :line-length (- (offset (end-of-line low-mark)) + (offset line-start-mark)))) + (if (end-of-buffer-p low-mark) + (loop-finish) + ;; skip newline + (forward-object low-mark)))))))))) + (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) ;; If something has been redisplayed, and there have been changes to ;; some of those lines, mark them as dirty. - (remember-changed-region view (car changed-region) (cdr changed-region))) + (remember-changed-region view (car changed-region) (cdr changed-region)) + ;; I suspect it's most efficient to keep this always up to date, + ;; even for small changes. + (update-line-data view (car changed-region) (cdr changed-region))) + +;;; Exploit the stored line information. + +(defun offset-in-line-p (line offset) + "Return true if `offset' is in the buffer region delimited by +`line'." + (<= (offset (start-mark line)) offset + (end-offset line))) + +(defun line-containing-offset (view mark-or-offset) + "Return the line `mark-or-offset' is in for `view'. `View' +must be a `drei-buffer-view'." + ;; Perform binary search looking for line containing `offset1'. + (as-offsets ((offset mark-or-offset)) + (with-accessors ((lines lines)) view + (loop with low-index = 0 + with high-index = (nb-elements lines) + for middle = (floor (+ low-index high-index) 2) + for this-line = (element* lines middle) + for line-start = (start-mark this-line) + do (cond ((offset-in-line-p this-line offset) + (loop-finish)) + ((mark> offset line-start) + (setf low-index (1+ middle))) + ((mark< offset line-start) + (setf high-index middle))) + finally (return this-line))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Syntax views (defclass drei-syntax-view (drei-buffer-view) ((%syntax :accessor syntax From thenriksen at common-lisp.net Mon Feb 11 22:51:42 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 11 Feb 2008 17:51:42 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20080211225142.81C5781004@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv23316/Apps/Inspector Modified Files: inspector.lisp Log Message: Once again accidentally committed local debugging hack... --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/02/11 22:50:04 1.43 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2008/02/11 22:51:42 1.44 @@ -47,7 +47,7 @@ :display-function 'display-app) (int :interactor :width 600 :height 100 :max-height 100)) (:layouts - (default (vertically () (scrolling () app) #+nil int)))) + (default (vertically () (scrolling () app) int)))) (defmethod initialize-instance :after ((frame inspector) &rest args) (declare (ignore args)) From thenriksen at common-lisp.net Mon Feb 11 23:05:24 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 11 Feb 2008 18:05:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080211230524.AC1A47A01F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27656/Drei Modified Files: drei-redisplay.lisp fundamental-syntax.lisp packages.lisp Log Message: Replace the old and inefficient generic buffer view redisplay with new one based on functionality stolen from Fundamental syntax. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/03 19:17:26 1.61 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/11 23:05:21 1.62 @@ -757,48 +757,6 @@ (+ width cursor-x) cursor-y draw baseline))))))) -(defmethod pump-state-for-offset ((view drei-buffer-view) (offset integer)) - "For a `drei-buffer-view' a pump-state is merely an offset into -the buffer determining where the next stroke should start." - offset) - -(defun fetch-chunk (buffer chunk-start-offset) - "Retrieve a chunk from `buffer', with the chunk starting at -`chunk-start-offset'. The chunk is a cons, with the car being the -start-offset of the chunk as an integer, and the cdr being either -the end-offset of the chunk as an integer, or a function. If a -function, the chunk is a one-object non-string chunk, and the -function is the drawing function for the chunk." - (let* ((line-end-offset (end-of-line-offset - buffer chunk-start-offset)) - (chunk-end-offset (buffer-find-nonchar - buffer chunk-start-offset - (min (+ *maximum-chunk-size* - chunk-start-offset) - line-end-offset)))) - (cond ((or (not (= chunk-end-offset chunk-start-offset)) - (and (offset-beginning-of-line-p buffer chunk-start-offset) - (offset-end-of-line-p buffer chunk-end-offset))) - (cons chunk-start-offset - chunk-end-offset)) - ((not (characterp (buffer-object buffer chunk-end-offset))) - (cons chunk-end-offset (object-drawer)))))) - -(defmethod stroke-pump ((view drei-buffer-view) stroke pump-state) - (let* ((chunk (fetch-chunk (buffer view) pump-state)) - (drawing-options (if (functionp (cdr chunk)) - (make-drawing-options :function (cdr chunk)) - +default-drawing-options+)) - (actual-end-offset (if (functionp (cdr chunk)) - (1+ (car chunk)) - (cdr chunk)))) - (setf (stroke-start-offset stroke) (car chunk) - (stroke-end-offset stroke) actual-end-offset - (stroke-drawing-options stroke) drawing-options) - (if (offset-end-of-line-p (buffer view) actual-end-offset) - (1+ actual-end-offset) - actual-end-offset))) - (defmethod display-drei-view-contents ((pane basic-pane) (view drei-buffer-view)) (with-bounding-rectangle* (x1 y1 x2 y2) view (let ((old-width (- x2 x1)) @@ -824,6 +782,82 @@ (setf (offset (bot view)) (line-end-offset line)) (clear-stale-lines pane view old-width old-height)))))))) +;;; A default redisplay implementation that should work for subclasses +;;; of `drei-buffer-view'. Syntaxes that don't want to implement their +;;; own redisplay behavior can just call these. + +(defstruct (pump-state + (:constructor make-pump-state + (line-index offset chunk-index))) + "A pump state object used by the `drei-buffer-view'. `Line' is +the line object `offset' is in, and `line-index' is the index of +`line' in the list of lines maintained by the view that created +this pump state." + line-index offset chunk-index) + +(defun buffer-view-pump-state-for-offset (view offset) + "Return a pump state usable for pumpting strokes for `view' (a +`drei-buffer-view') from `offset'." + ;; Perform binary search looking for line starting with `offset'. + (with-accessors ((lines lines)) view + (loop with low-index = 0 + with high-index = (nb-elements lines) + for middle = (floor (+ low-index high-index) 2) + for line-start = (start-mark (element* lines middle)) + do (cond ((mark> offset line-start) + (setf low-index (1+ middle))) + ((mark< offset line-start) + (setf high-index middle)) + ((mark= offset line-start) + (loop-finish))) + finally (return (make-pump-state middle offset 0))))) + +(defun fetch-chunk (line chunk-index) + "Retrieve the `chunk-index'th chunk from `line'. The return +value is either an integer, in which case it specifies the +end-offset of a string chunk relative to the start of the line, +or a function, in which case it is the drawing function for a +single-object non-character chunk." + (destructuring-bind (relative-chunk-end-offset . objectp) + (aref (chunks line) chunk-index) + (if objectp (object-drawer) (+ relative-chunk-end-offset + (offset (start-mark line)))))) + +(defun buffer-view-stroke-pump (view stroke pump-state) + "Pump redisplay data into `stroke' based on `pump-state' and +the information managed by `view', which must be a +`drei-buffer-view'." + ;; `Pump-state' will be destructively modified. + (prog1 pump-state + (with-accessors ((line-index pump-state-line-index) + (offset pump-state-offset) + (chunk-index pump-state-chunk-index)) pump-state + (let* ((chunk (fetch-chunk + (element* (lines view) line-index) chunk-index)) + (drawing-options (if (functionp chunk) + (make-drawing-options :function chunk) + +default-drawing-options+)) + (end-offset (if (functionp chunk) + (1+ offset) + chunk))) + (setf (stroke-start-offset stroke) offset + (stroke-end-offset stroke) end-offset + (stroke-drawing-options stroke) drawing-options) + (if (offset-end-of-line-p (buffer view) end-offset) + (setf line-index (1+ line-index) + chunk-index 0 + offset (1+ end-offset)) + (setf chunk-index (1+ chunk-index) + offset end-offset)))))) + +(defmethod pump-state-for-offset ((view drei-buffer-view) (offset integer)) + (buffer-view-pump-state-for-offset view offset)) + +(defmethod stroke-pump ((view drei-buffer-view) stroke pump-state) + (buffer-view-stroke-pump view stroke pump-state)) + +;;; Cursor handling. + (defun offset-in-stroke-position (stream view stroke offset) "Calculate the position in device units of `offset' in `stroke', relative to the starting position of `stroke'. `Offset' --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/02/11 22:50:04 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/02/11 23:05:22 1.13 @@ -53,71 +53,18 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; display - -(defstruct (pump-state - (:constructor make-pump-state - (line-index offset chunk-index))) - "A pump state object used in the fundamental syntax. `Line' is -the line object `offset' is in, and `line-index' is the index of -`line' in the list of lines maintained by the syntax that created -this pump state." - line-index - offset - chunk-index) +;;; Redisplay +;;; +;;; Just uses the default buffer-view redisplay behavior. (defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) (syntax fundamental-syntax) (offset integer)) - ;; Perform binary search looking for line starting with `offset'. - (with-accessors ((lines lines)) view - (loop with low-index = 0 - with high-index = (nb-elements lines) - for middle = (floor (+ low-index high-index) 2) - for line-start = (start-mark (element* lines middle)) - do (cond ((mark> offset line-start) - (setf low-index (1+ middle))) - ((mark< offset line-start) - (setf high-index middle)) - ((mark= offset line-start) - (loop-finish))) - finally (return (make-pump-state middle offset 0))))) - -(defun fetch-chunk (line chunk-index) - "Retrieve the `chunk-index'th chunk from `line'. The return -value is either an integer, in which case it specifies the -end-offset of a string chunk relative to the start of the line, -or a function, in which case it is the drawing function for a -single-object non-character chunk." - (destructuring-bind (relative-chunk-end-offset . objectp) - (aref (chunks line) chunk-index) - (if objectp (object-drawer) (+ relative-chunk-end-offset - (offset (start-mark line)))))) + (buffer-view-pump-state-for-offset view offset)) (defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) (syntax fundamental-syntax) stroke - (pump-state pump-state)) - ;; `Pump-state' will be destructively modified. - (prog1 pump-state - (with-accessors ((line-index pump-state-line-index) - (offset pump-state-offset) - (chunk-index pump-state-chunk-index)) pump-state - (let* ((chunk (fetch-chunk - (element* (lines view) line-index) chunk-index)) - (drawing-options (if (functionp chunk) - (make-drawing-options :function chunk) - +default-drawing-options+)) - (end-offset (if (functionp chunk) - (1+ offset) - chunk))) - (setf (stroke-start-offset stroke) offset - (stroke-end-offset stroke) end-offset - (stroke-drawing-options stroke) drawing-options) - (if (offset-end-of-line-p (buffer view) end-offset) - (setf line-index (1+ line-index) - chunk-index 0 - offset (1+ end-offset)) - (setf chunk-index (1+ chunk-index) - offset end-offset)))))) + pump-state) + (buffer-view-stroke-pump view stroke pump-state)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/11 22:50:05 1.51 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/11 23:05:22 1.52 @@ -222,6 +222,8 @@ #:lines #:buffer-line #:start-mark #:line-length #:chunks #:end-offset #:line-containing-offset #:offset-in-line-p + #:buffer-view-pump-state-for-offset + #:buffer-view-stroke-pump #:drei-syntax-view #:syntax #:syntax-view-p #:pump-state-for-offset-with-syntax From thenriksen at common-lisp.net Tue Feb 12 19:22:38 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 12 Feb 2008 14:22:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080212192238.0F8C77A022@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv20991/Drei Modified Files: drei-redisplay.lisp views.lisp Log Message: Changed how buffer changes are registered by the redisplay module. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/11 23:05:21 1.62 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/12 19:22:37 1.63 @@ -272,6 +272,37 @@ do (invalidate-line-strokes line :modified modified :cleared cleared))) +(defun invalidate-strokes-in-region (view start-offset end-offset + &key modified cleared) + "Invalidate all the strokes of `view' that overlap the region +`start-offset'/`end-offset' by setting their dirty-bit to +true. If `modified' or `cleared' is true, also set their +modified-bit to true. If `cleared' is true, inform the strokes +that their previous output has been cleared by someone, and that +they do not need to clear it themselves during their next +redisplay." + ;; If the region is outside the visible region, no-op. + (when (overlaps start-offset end-offset + (offset (top view)) (offset (bot view))) + (let ((line1-index (index-of-displayed-line-containing-offset view start-offset)) + (line2-index (index-of-displayed-line-containing-offset view end-offset))) + (loop for line = (line-information view line1-index) + when (<= start-offset + (line-start-offset line) (line-end-offset line) + end-offset) + ;; The entire line is within the region. + do (invalidate-line-strokes line :modified modified + :cleared cleared) + ;; Only part of the line is within the region. + else do (do-displayed-line-strokes (stroke line) + (when (overlaps start-offset end-offset + (stroke-start-offset stroke) + (stroke-end-offset stroke)) + (invalidate-stroke stroke :modified modified + :cleared cleared))) + if (= line1-index line2-index) do (loop-finish) + else do (incf line1-index))))) + (defmacro do-displayed-lines ((line-sym view) &body body) "Loop over lines on display for `view', evaluating `body' with `line-sym' bound to the `displayed-line' object for each line." @@ -328,10 +359,11 @@ (end-offset (stroke-end-offset stroke)))) (return stroke)))))) -(defun find-index-of-line-containing-offset (view offset) - "Return the index of the line containing `offset'. If `offset' -is before the displayed lines, return 0. If `offset' is after the -displayed lines, return the index of the last line." +(defun index-of-displayed-line-containing-offset (view offset) + "Return the index of the `displayed-line' object containing +`offset'. If `offset' is before the displayed lines, return 0. If +`offset' is after the displayed lines, return the index of the +last line." (with-accessors ((lines displayed-lines)) view (cond ((< offset (line-start-offset (aref lines 0))) 0) @@ -340,18 +372,18 @@ (t ;; Binary search for the line. (loop with low-index = 0 - with high-index = (displayed-lines-count view) - for middle = (floor (+ low-index high-index) 2) - for this-line = (aref lines middle) - for line-start = (line-start-offset this-line) - for line-end = (line-end-offset this-line) - do (cond ((<= line-start offset line-end) - (loop-finish)) - ((mark> offset line-start) - (setf low-index (1+ middle))) - ((mark< offset line-start) - (setf high-index middle))) - finally (return middle)))))) + with high-index = (displayed-lines-count view) + for middle = (floor (+ low-index high-index) 2) + for this-line = (aref lines middle) + for line-start = (line-start-offset this-line) + for line-end = (line-end-offset this-line) + do (cond ((<= line-start offset line-end) + (loop-finish)) + ((> offset line-start) + (setf low-index (1+ middle))) + ((< offset line-start) + (setf high-index middle))) + finally (return middle)))))) (defun ensure-line-information-size (view min-size) "Ensure that the array of lines for `view' contains at least @@ -402,24 +434,14 @@ (let* ((stroke (line-stroke-information line (line-stroke-count line))) (old-start-offset (stroke-start-offset stroke)) (old-end-offset (stroke-end-offset stroke)) - (old-drawing-options (stroke-drawing-options stroke)) - (changed-region (first (changed-regions view)))) + (old-drawing-options (stroke-drawing-options stroke))) (prog1 (stroke-pump view stroke pump-state) (unless (and old-start-offset (= (+ old-start-offset line-change) (stroke-start-offset stroke)) (= (+ old-end-offset line-change) (stroke-end-offset stroke)) (drawing-options-equal old-drawing-options - (stroke-drawing-options stroke)) - (or (null changed-region) - (not (overlaps (stroke-start-offset stroke) (stroke-end-offset stroke) - (car changed-region) (cdr changed-region))))) + (stroke-drawing-options stroke))) (invalidate-stroke stroke :modified t)) - ;; Move to the next changed region, if it is not possible for - ;; more stroks to overlap with the current one. - (loop while (and (first (changed-regions view)) - (>= (stroke-end-offset stroke) - (cdr (first (changed-regions view))))) - do (pop (changed-regions view))) (incf (line-stroke-count line)) (setf (line-end-offset line) (stroke-end-offset stroke))))) @@ -634,7 +656,8 @@ (do-undisplayed-line-strokes (stroke line) (if (null (stroke-start-offset stroke)) (return) - (setf (stroke-start-offset stroke) nil)))) + (progn (setf (stroke-start-offset stroke) nil) + (invalidate-stroke stroke :modified t))))) (defun draw-line-strokes (pane view initial-pump-state start-offset cursor-x cursor-y @@ -711,7 +734,8 @@ (do-undisplayed-line-strokes (stroke line) (if (null (stroke-start-offset stroke)) (return) - (setf (stroke-start-offset stroke) nil)))) + (progn (setf (stroke-start-offset stroke) nil) + (invalidate-stroke stroke :modified t))))) (with-bounding-rectangle* (x1 y1 x2 y2) view (declare (ignore x2)) (when (> old-height (- y2 y1)) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/11 22:50:05 1.35 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/12 19:22:37 1.36 @@ -594,12 +594,6 @@ :type number :documentation "The width of the longest displayed line in device units.") - (%changed-regions :accessor changed-regions - :initform nil - :documentation "A list of (start . end) conses -of buffer offsets, delimiting the regions of the buffer that have -changed since the last redisplay. The regions are not -overlapping, and are sorted in ascending order.") (lines :initform (make-instance 'standard-flexichain) :reader lines :documentation "The lines of the buffer, stored in a @@ -632,8 +626,11 @@ (defmethod (setf bot) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view)) -(defmethod (setf buffer) :after (new-value (view drei-buffer-view)) - (invalidate-all-strokes view)) +(defmethod (setf buffer) :after (buffer (view drei-buffer-view)) + (invalidate-all-strokes view) + (with-accessors ((top top) (bot bot)) view + (setf top (make-buffer-mark buffer 0 :left) + bot (make-buffer-mark buffer (size buffer) :right)))) (defmethod (setf syntax) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view :modified t)) @@ -657,32 +654,6 @@ (<= y1 x1 x2 y2) (<= x1 y1 y1 x2))) -(defun remember-changed-region (view start end) - "Note that the buffer region delimited by the offset `start' -and `end' has been modified." - (labels ((worker (list) - ;; Return a new changed-regions list. Try to extend old - ;; regions instead of adding new ones. - (cond ((null list) - (list (cons start end))) - ;; If start/end overlaps with (first list), extend - ;; (first list) - ((overlaps start end (car (first list)) (cdr (first list))) - (setf (car (first list)) (min start (car (first list))) - (cdr (first list)) (max end (cdr (first list)))) - list) - ;; If start/end is wholly before (first list), push - ;; on a new region. - ((< start (car (first list))) - (cons (cons start end) list)) - ;; If start/end is wholly before (first list), go - ;; further down list. If at end of list, add new - ;; element. - ((< (cdr (first list)) end) - (setf (rest list) (worker (rest list))) - list)))) - (setf (changed-regions view) (worker (changed-regions view))))) - (defclass buffer-line () ((%start-mark :reader start-mark :initarg :start-mark @@ -783,12 +754,14 @@ (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) - ;; If something has been redisplayed, and there have been changes to - ;; some of those lines, mark them as dirty. - (remember-changed-region view (car changed-region) (cdr changed-region)) - ;; I suspect it's most efficient to keep this always up to date, - ;; even for small changes. - (update-line-data view (car changed-region) (cdr changed-region))) + (destructuring-bind (start-offset . end-offset) changed-region + ;; If something has been redisplayed, and there have been changes + ;; to some of those strokes, mark them as dirty. + (invalidate-strokes-in-region + view start-offset end-offset :modified t) + ;; I suspect it's most efficient to keep this always up to date, + ;; even for small changes. + (update-line-data view start-offset end-offset))) ;;; Exploit the stored line information. @@ -866,21 +839,11 @@ ;; We need a new syntax object of the same type as the old one, and ;; to zero out the unchanged-prefix-values. (with-accessors ((view-syntax syntax) - (point point) (mark mark) (suffix-size suffix-size) (prefix-size prefix-size) (buffer-size buffer-size) (bot bot) (top top)) view - (setf point (clone-mark (point buffer)) - mark (clone-mark (point buffer) :right) - (offset mark) 0 - view-syntax (make-syntax-for-view view (class-of view-syntax)) - prefix-size 0 - suffix-size 0 - buffer-size -1 ; For reparse even if buffer is empty. - ;; Also set the top and bot marks. - top (make-buffer-mark buffer 0 :left) - bot (make-buffer-mark buffer (size buffer) :right)))) + (setf view-syntax (make-syntax-for-view view (class-of view-syntax))))) (defmethod (setf syntax) :after (syntax (view drei-syntax-view)) (setf (prefix-size view) 0 From thenriksen at common-lisp.net Wed Feb 13 21:58:50 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 13 Feb 2008 16:58:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080213215850.6D41339165@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15222/Drei Modified Files: drei-redisplay.lisp views.lisp Log Message: Some general cleanups in Drei redisplay. No functionality changes. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/12 19:22:37 1.63 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/13 21:58:50 1.64 @@ -272,37 +272,6 @@ do (invalidate-line-strokes line :modified modified :cleared cleared))) -(defun invalidate-strokes-in-region (view start-offset end-offset - &key modified cleared) - "Invalidate all the strokes of `view' that overlap the region -`start-offset'/`end-offset' by setting their dirty-bit to -true. If `modified' or `cleared' is true, also set their -modified-bit to true. If `cleared' is true, inform the strokes -that their previous output has been cleared by someone, and that -they do not need to clear it themselves during their next -redisplay." - ;; If the region is outside the visible region, no-op. - (when (overlaps start-offset end-offset - (offset (top view)) (offset (bot view))) - (let ((line1-index (index-of-displayed-line-containing-offset view start-offset)) - (line2-index (index-of-displayed-line-containing-offset view end-offset))) - (loop for line = (line-information view line1-index) - when (<= start-offset - (line-start-offset line) (line-end-offset line) - end-offset) - ;; The entire line is within the region. - do (invalidate-line-strokes line :modified modified - :cleared cleared) - ;; Only part of the line is within the region. - else do (do-displayed-line-strokes (stroke line) - (when (overlaps start-offset end-offset - (stroke-start-offset stroke) - (stroke-end-offset stroke)) - (invalidate-stroke stroke :modified modified - :cleared cleared))) - if (= line1-index line2-index) do (loop-finish) - else do (incf line1-index))))) - (defmacro do-displayed-lines ((line-sym view) &body body) "Loop over lines on display for `view', evaluating `body' with `line-sym' bound to the `displayed-line' object for each line." @@ -348,6 +317,39 @@ (+ (line-stroke-count ,line) ,stroke-index)))) , at body))))) +(defun invalidate-strokes-in-region (view start-offset end-offset + &key modified cleared) + "Invalidate all the strokes of `view' that overlap the region +`start-offset'/`end-offset' by setting their dirty-bit to +true. If `modified' or `cleared' is true, also set their +modified-bit to true. If `cleared' is true, inform the strokes +that their previous output has been cleared by someone, and that +they do not need to clear it themselves during their next +redisplay." + (as-region (start-offset end-offset) + ;; If the region is outside the visible region, no-op. + (when (and (plusp (displayed-lines-count view)) ; If there is any display... + (overlaps start-offset end-offset + (offset (top view)) (offset (bot view)))) + (let ((line1-index (index-of-displayed-line-containing-offset view start-offset)) + (line2-index (index-of-displayed-line-containing-offset view end-offset))) + (loop for line = (line-information view line1-index) + when (<= start-offset + (line-start-offset line) (line-end-offset line) + end-offset) + ;; The entire line is within the region. + do (invalidate-line-strokes line :modified modified + :cleared cleared) + ;; Only part of the line is within the region. + else do (do-displayed-line-strokes (stroke line) + (when (overlaps start-offset end-offset + (stroke-start-offset stroke) + (stroke-end-offset stroke)) + (invalidate-stroke stroke :modified modified + :cleared cleared))) + if (= line1-index line2-index) do (loop-finish) + else do (incf line1-index)))))) + (defun find-stroke-containing-offset (view offset) "Find the stroke of `view' that displays the buffer offset `offset'. If no such stroke can be found, this function returns @@ -430,7 +432,8 @@ `view', and add it to the sequence of displayed strokes in `line'. `Line-change' should be a relative offset specifying how much the start-offset of `line' has changed since the last time -it was redisplayed." +it was redisplayed. `Offset' is the offset at which the next +stroke will start." (let* ((stroke (line-stroke-information line (line-stroke-count line))) (old-start-offset (stroke-start-offset stroke)) (old-end-offset (stroke-end-offset stroke)) @@ -678,19 +681,21 @@ ;; ugly, just complex. (multiple-value-bind (line-width baseline descent pump-state) ;; Pump all the line strokes and calculate their dimensions. - (loop for index from 0 - for stroke = (line-stroke-information line index) - for stroke-dimensions = (stroke-dimensions stroke) - for pump-state = (put-stroke view line initial-pump-state offset-change) then - (put-stroke view line pump-state offset-change) - do (update-stroke-dimensions pane view stroke cursor-x cursor-y) - (setf cursor-x (x2 stroke-dimensions)) - maximizing (- (dimensions-height stroke-dimensions) - (center stroke-dimensions)) into descent - maximizing (+ (center stroke-dimensions) cursor-y) into baseline - summing (dimensions-width stroke-dimensions) into line-width - when (stroke-at-end-of-line (buffer view) stroke) - return (values line-width baseline descent pump-state)) + (loop with offset = start-offset + for index from 0 + for stroke = (line-stroke-information line index) + for stroke-dimensions = (stroke-dimensions stroke) + for pump-state = (put-stroke view line initial-pump-state offset-change) + then (put-stroke view line pump-state offset-change) + do (update-stroke-dimensions pane view stroke cursor-x cursor-y) + (setf cursor-x (x2 stroke-dimensions)) + (setf offset (stroke-end-offset stroke)) + maximizing (- (dimensions-height stroke-dimensions) + (center stroke-dimensions)) into descent + maximizing (+ (center stroke-dimensions) cursor-y) into baseline + summing (dimensions-width stroke-dimensions) into line-width + when (stroke-at-end-of-line (buffer view) stroke) + return (values line-width baseline descent pump-state)) (let ((line-height (- (+ baseline descent) cursor-y))) ;; Loop over the strokes and clear the parts of the pane that ;; has to be redrawn, trying to minimise the number of calls to @@ -783,16 +788,19 @@ (defmethod display-drei-view-contents ((pane basic-pane) (view drei-buffer-view)) (with-bounding-rectangle* (x1 y1 x2 y2) view - (let ((old-width (- x2 x1)) - (old-height (- y2 y1))) + (let* ((old-width (- x2 x1)) + (old-height (- y2 y1)) + (start-offset (offset (beginning-of-line (top view)))) + (pump-state (pump-state-for-offset view start-offset)) + (pane-height (bounding-rectangle-height (or (pane-viewport pane) pane)))) + ;; For invalidation of the parts of the display that have + ;; changed. + (synchronize-view view :begin (offset (top view)) :end (offset (bot view))) (setf (displayed-lines-count view) 0 (max-line-width view) 0) (multiple-value-bind (cursor-x cursor-y) (stream-cursor-position pane) (with-output-recording-options (pane :record nil :draw t) - (loop with start-offset = (offset (beginning-of-line (top view))) - with pump-state = (pump-state-for-offset view start-offset) - with pane-height = (bounding-rectangle-height (or (pane-viewport pane) pane)) - for line = (line-information view (displayed-lines-count view)) + (loop for line = (line-information view (displayed-lines-count view)) do (multiple-value-bind (new-pump-state line-height) (draw-line-strokes pane view pump-state start-offset cursor-x cursor-y old-width) @@ -823,17 +831,19 @@ "Return a pump state usable for pumpting strokes for `view' (a `drei-buffer-view') from `offset'." ;; Perform binary search looking for line starting with `offset'. + (synchronize-view view :begin offset) (with-accessors ((lines lines)) view (loop with low-index = 0 with high-index = (nb-elements lines) for middle = (floor (+ low-index high-index) 2) - for line-start = (start-mark (element* lines middle)) - do (cond ((mark> offset line-start) + for this-line = (element* lines middle) + for line-start = (start-mark this-line) + do (cond ((offset-in-line-p this-line offset) + (loop-finish)) + ((mark> offset line-start) (setf low-index (1+ middle))) ((mark< offset line-start) - (setf high-index middle)) - ((mark= offset line-start) - (loop-finish))) + (setf high-index middle))) finally (return (make-pump-state middle offset 0))))) (defun fetch-chunk (line chunk-index) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/12 19:22:37 1.36 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/13 21:58:50 1.37 @@ -578,7 +578,7 @@ the string is accessed through the reader.") (%displayed-lines :accessor displayed-lines :initform (make-array 0 :element-type 'displayed-line - :initial-element (make-displayed-line)) + :initial-element (make-displayed-line)) :type array :documentation "An array of the `displayed-line' objects displayed by the view. Not all of these @@ -594,10 +594,18 @@ :type number :documentation "The width of the longest displayed line in device units.") - (lines :initform (make-instance 'standard-flexichain) - :reader lines - :documentation "The lines of the buffer, stored in a -format that makes it easy to retrieve information about them.")) + (%lines :initform (make-instance 'standard-flexichain) + :reader lines + :documentation "The lines of the buffer, stored in a +format that makes it easy to retrieve information about them.") + (%lines-prefix :accessor lines-prefix-size + :documentation "The number of unchanged +objects at the start of the buffer since the list of lines was +last updated.") + (%lines-suffix :accessor lines-suffix-size + :documentation "The number of unchanged objects +at the end of the buffer since since the list of lines was last +updated.")) (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' object. The buffer is displayed on a simple line-by-line basis, @@ -608,7 +616,9 @@ &key buffer single-line read-only initial-contents) (declare (ignore initargs)) - (with-accessors ((top top) (bot bot)) view + (with-accessors ((top top) (bot bot) + (lines-prefix lines-prefix-size) + (lines-suffix lines-suffix-size)) view (unless buffer ;; So many fun things are defined on (setf buffer) that we use ;; slot-value here. This is just a glorified initform anyway. @@ -617,8 +627,9 @@ :read-only read-only :initial-contents initial-contents))) (setf top (make-buffer-mark (buffer view) 0 :left) - bot (make-buffer-mark (buffer view) (size (buffer view)) :right)) - (update-line-data view 0 (size (buffer view))))) + bot (clone-mark top :right) + lines-prefix 0 + lines-suffix 0))) (defmethod (setf top) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view)) @@ -628,12 +639,13 @@ (defmethod (setf buffer) :after (buffer (view drei-buffer-view)) (invalidate-all-strokes view) - (with-accessors ((top top) (bot bot)) view - (setf top (make-buffer-mark buffer 0 :left) - bot (make-buffer-mark buffer (size buffer) :right)))) - -(defmethod (setf syntax) :after (new-value (view drei-buffer-view)) - (invalidate-all-strokes view :modified t)) + (with-accessors ((top top) (bot bot) + (lines-prefix lines-prefix-size) + (lines-suffix lines-suffix-size)) view + (setf top (make-buffer-mark buffer 0 :left) + bot (clone-mark top :right) + lines-prefix 0 + lines-suffix 0))) (defmethod cache-string :around ((view drei-buffer-view)) (let ((string (call-next-method))) @@ -713,55 +725,59 @@ (cons (- (1+ chunk-end-offset) line-start-offset) t))))) -(defun update-line-data (view start end) +(defun update-line-data (view) "Update the sequence of lines stored by the `drei-buffer-view' -`view'. `Start' and `end' are buffer offsets delimiting the -region that has changed since the last update." - (let ((low-mark (make-buffer-mark (buffer view) start :left)) - (high-mark (make-buffer-mark (buffer view) end :left))) - (when (mark<= low-mark high-mark) - (beginning-of-line low-mark) - (end-of-line high-mark) - (with-accessors ((lines lines)) view - (let ((low-index 0) - (high-index (nb-elements lines))) - ;; Binary search for the start of changed lines. - (loop while (< low-index high-index) - do (let* ((middle (floor (+ low-index high-index) 2)) - (line-start (start-mark (element* lines middle)))) - (cond ((mark> low-mark line-start) - (setf low-index (1+ middle))) - (t - (setf high-index middle))))) - ;; Discard lines that have to be re-analyzed. - (loop while (and (< low-index (nb-elements lines)) - (mark<= (start-mark (element* lines low-index)) - high-mark)) - do (delete* lines low-index)) - ;; Analyze new lines. - (loop while (mark<= low-mark high-mark) - for i from low-index - do (progn (let ((line-start-mark (clone-mark low-mark))) - (insert* lines i (make-instance - 'buffer-line - :start-mark line-start-mark - :line-length (- (offset (end-of-line low-mark)) - (offset line-start-mark)))) - (if (end-of-buffer-p low-mark) - (loop-finish) - ;; skip newline - (forward-object low-mark)))))))))) +`view'." + (with-accessors ((prefix-size lines-prefix-size) + (suffix-size lines-suffix-size)) view + (when (<= prefix-size (- (size (buffer view)) suffix-size)) + (let ((low-mark (make-buffer-mark (buffer view) prefix-size :left)) + (high-mark (make-buffer-mark + (buffer view) (- (size (buffer view)) suffix-size) :left))) + (beginning-of-line low-mark) + (end-of-line high-mark) + (with-accessors ((lines lines)) view + (let ((low-index 0) + (high-index (nb-elements lines))) + ;; Binary search for the start of changed lines. + (loop while (< low-index high-index) + do (let* ((middle (floor (+ low-index high-index) 2)) + (line-start (start-mark (element* lines middle)))) + (cond ((mark> low-mark line-start) + (setf low-index (1+ middle))) + (t + (setf high-index middle))))) + ;; Discard lines that have to be re-analyzed. + (loop while (and (< low-index (nb-elements lines)) + (mark<= (start-mark (element* lines low-index)) + high-mark)) + do (delete* lines low-index)) + ;; Analyze new lines. + (loop while (mark<= low-mark high-mark) + for i from low-index + do (progn (let ((line-start-mark (clone-mark low-mark))) + (insert* lines i (make-instance + 'buffer-line + :start-mark line-start-mark + :line-length (- (offset (end-of-line low-mark)) + (offset line-start-mark)))) + (if (end-of-buffer-p low-mark) + (loop-finish) + ;; skip newline + (forward-object low-mark))))))))) + (setf prefix-size (size (buffer view)) + suffix-size (size (buffer view))))) (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) (destructuring-bind (start-offset . end-offset) changed-region - ;; If something has been redisplayed, and there have been changes - ;; to some of those strokes, mark them as dirty. - (invalidate-strokes-in-region - view start-offset end-offset :modified t) - ;; I suspect it's most efficient to keep this always up to date, - ;; even for small changes. - (update-line-data view start-offset end-offset))) + (with-accessors ((prefix-size lines-prefix-size) + (suffix-size lines-suffix-size)) view + (setf prefix-size (min start-offset prefix-size) + suffix-size (min (- (size buffer) end-offset) suffix-size))))) + +(defmethod synchronize-view ((view drei-buffer-view) &key) + (update-line-data view)) ;;; Exploit the stored line information. @@ -771,24 +787,32 @@ (<= (offset (start-mark line)) offset (end-offset line))) +(defun index-of-line-containing-offset (view mark-or-offset) + "Return the index of the line `mark-or-offset' is in for +`view'. `View' must be a `drei-buffer-view'." + ;; Perform binary search looking for line containing `offset1'. + (as-offsets ((offset mark-or-offset)) + (with-accessors ((lines lines)) view + (loop with low-index = 0 + with high-index = (nb-elements lines) + for middle = (floor (+ low-index high-index) 2) + for this-line = (element* lines middle) + for line-start = (start-mark this-line) + do (cond ((offset-in-line-p this-line offset) + (loop-finish)) + ((mark> offset line-start) + (setf low-index (1+ middle))) + ((mark< offset line-start) + (setf high-index middle))) + finally (return middle))))) + (defun line-containing-offset (view mark-or-offset) "Return the line `mark-or-offset' is in for `view'. `View' must be a `drei-buffer-view'." ;; Perform binary search looking for line containing `offset1'. (as-offsets ((offset mark-or-offset)) (with-accessors ((lines lines)) view - (loop with low-index = 0 - with high-index = (nb-elements lines) - for middle = (floor (+ low-index high-index) 2) - for this-line = (element* lines middle) - for line-start = (start-mark this-line) - do (cond ((offset-in-line-p this-line offset) - (loop-finish)) - ((mark> offset line-start) - (setf low-index (1+ middle))) - ((mark< offset line-start) - (setf high-index middle))) - finally (return this-line))))) + (element* lines (index-of-line-containing-offset view offset))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -838,11 +862,7 @@ (add-observer buffer view) ;; We need a new syntax object of the same type as the old one, and ;; to zero out the unchanged-prefix-values. - (with-accessors ((view-syntax syntax) - (suffix-size suffix-size) - (prefix-size prefix-size) - (buffer-size buffer-size) - (bot bot) (top top)) view + (with-accessors ((view-syntax syntax)) view (setf view-syntax (make-syntax-for-view view (class-of view-syntax))))) (defmethod (setf syntax) :after (syntax (view drei-syntax-view)) @@ -869,17 +889,18 @@ (defmethod observer-notified ((view drei-syntax-view) (buffer drei-buffer) changed-region) - (with-accessors ((prefix-size prefix-size) - (suffix-size suffix-size)) view - (setf prefix-size (min (car changed-region) prefix-size) - suffix-size (min (- (size buffer) (cdr changed-region)) - suffix-size) - (modified-p view) t)) + (destructuring-bind (start-offset . end-offset) changed-region + (with-accessors ((prefix-size prefix-size) + (suffix-size suffix-size) + (modified-p modified-p)) view + (setf prefix-size (min start-offset prefix-size) + suffix-size (min (- (size buffer) end-offset) suffix-size) + modified-p t))) (call-next-method)) (defun needs-resynchronization (view) "Return true if the the view of the buffer of `view' is -potentially out of date. Return false otherwise." +potentially out of date. Return false otherwise." (not (= (prefix-size view) (suffix-size view) (buffer-size view) (size (buffer view))))) From thenriksen at common-lisp.net Thu Feb 14 08:15:02 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 14 Feb 2008 03:15:02 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080214081502.EC6D264105@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31883/Drei Modified Files: views.lisp Log Message: Oops, accidentally reintroduced old bug. Pick up on buffer changes affecting strokes. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/13 21:58:50 1.37 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/14 08:15:01 1.38 @@ -771,6 +771,7 @@ (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) (destructuring-bind (start-offset . end-offset) changed-region + (invalidate-strokes-in-region view start-offset end-offset :modified t) (with-accessors ((prefix-size lines-prefix-size) (suffix-size lines-suffix-size)) view (setf prefix-size (min start-offset prefix-size) From rschlatte at common-lisp.net Fri Feb 15 09:49:01 2008 From: rschlatte at common-lisp.net (rschlatte) Date: Fri, 15 Feb 2008 04:49:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080215094901.5900B7A01C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv8522/Apps/Listener Modified Files: README TODO listener.lisp Log Message: Use clim-user as default package in new listener. Document current prompting behaviour in README --- /project/mcclim/cvsroot/mcclim/Apps/Listener/README 2005/05/12 01:37:20 1.5 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/README 2008/02/15 09:48:37 1.6 @@ -49,13 +49,10 @@ Usage ----- -After starting the listener, a typical lisp prompt will be displayed, with -the package name preceding the prompt. You may type lisp forms or commands to -this prompt. The listener will treat alphabetical characters as beginning a -command name, and most other characters as the beginning of a lisp form. If for -some reason you had a special variable with a name such as FOO which would be -interpreted as a command, you can use a comma before the variable name as an -escape character. +After starting the listener, a typical lisp prompt will be displayed, with the +package name preceding the prompt. You may type lisp forms or commands to this +prompt. The , (comma) character starts a command, every other input will be +treated by the listener as a form to be evaluated. At the bottom of the window is a wholine which shows various things such as the username/hostname, package, current directory (*default-pathname-defaults*), --- /project/mcclim/cvsroot/mcclim/Apps/Listener/TODO 2005/05/12 01:37:20 1.2 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/TODO 2008/02/15 09:48:41 1.3 @@ -14,7 +14,6 @@ to distinguish between subtypes in methods. - Flesh out icons - support multiple sizes in separate subdirectories of icons/ - Implement sorting and other options to Show Directory - - Do something about Edit File and Show File - Copy File, Delete File, etc. - Debugger integration --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/02/03 19:07:51 1.42 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2008/02/15 09:48:41 1.43 @@ -71,6 +71,7 @@ (defmethod stream-present :around ((stream listener-interactor-pane) object type &rest args &key (single-box nil sbp) &allow-other-keys) + (declare (ignore single-box sbp)) (apply #'call-next-method stream object type :single-box t args) ;; we would do this, but CLIM:PRESENT calls STREAM-PRESENT with all ;; the keyword arguments explicitly. *sigh*. @@ -166,15 +167,17 @@ (height 550) port frame-manager - (process-name "Listener")) + (process-name "Listener") + (package :clim-user)) (let* ((fm (or frame-manager (find-frame-manager :port (or port (find-port))))) (frame (make-application-frame 'listener :frame-manager fm :width width :height height))) (flet ((run () - (unwind-protect (run-frame-top-level frame) - (disown-frame fm frame)))) + (let ((*package* (find-package package))) + (unwind-protect (run-frame-top-level frame) + (disown-frame fm frame))))) (if new-process (values (clim-sys:make-process #'run :name process-name) frame) From thenriksen at common-lisp.net Fri Feb 15 13:16:17 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 15 Feb 2008 08:16:17 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080215131617.94AA32332C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6104/Drei Modified Files: drei-redisplay.lisp lisp-syntax.lisp packages.lisp syntax.lisp views.lisp Log Message: Improved Drei redisplay performance by 66% in most cases. The main difference is that syntaxes are now supposed to report which parts of the display may need to be updated, previously their view of the display was computed for every redisplay iteration, and any changes drawn. Of course, no syntaxes do that yet, so if you use Lisp block-comments or string-quoting, you will see "delayed" redrawing of some parts of the display. Just like Emacs! Currently, a heuristic is used that invalidates parts of the display corresponding to buffer regions that have actually been changed, so it does work fine for the common cases. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/13 21:58:50 1.64 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/15 13:16:17 1.65 @@ -427,24 +427,21 @@ some point)." (aref (line-strokes line) (1- (line-stroke-count line)))) -(defun put-stroke (view line pump-state line-change) +(defun put-stroke (view line pump-state line-change offset) "Use `stroke-pump' with `pump-state' to get a new stroke for `view', and add it to the sequence of displayed strokes in `line'. `Line-change' should be a relative offset specifying how much the start-offset of `line' has changed since the last time it was redisplayed. `Offset' is the offset at which the next stroke will start." - (let* ((stroke (line-stroke-information line (line-stroke-count line))) - (old-start-offset (stroke-start-offset stroke)) - (old-end-offset (stroke-end-offset stroke)) - (old-drawing-options (stroke-drawing-options stroke))) + (let ((stroke (line-stroke-information line (line-stroke-count line)))) + (unless (stroke-modified stroke) + (incf (stroke-start-offset stroke) line-change) + (incf (stroke-end-offset stroke) line-change) + (when (or (null (stroke-start-offset stroke)) + (/= (stroke-start-offset stroke) offset)) + (invalidate-stroke stroke :modified t))) (prog1 (stroke-pump view stroke pump-state) - (unless (and old-start-offset - (= (+ old-start-offset line-change) (stroke-start-offset stroke)) - (= (+ old-end-offset line-change) (stroke-end-offset stroke)) - (drawing-options-equal old-drawing-options - (stroke-drawing-options stroke))) - (invalidate-stroke stroke :modified t)) (incf (line-stroke-count line)) (setf (line-end-offset line) (stroke-end-offset stroke))))) @@ -685,8 +682,8 @@ for index from 0 for stroke = (line-stroke-information line index) for stroke-dimensions = (stroke-dimensions stroke) - for pump-state = (put-stroke view line initial-pump-state offset-change) - then (put-stroke view line pump-state offset-change) + for pump-state = (put-stroke view line initial-pump-state offset-change offset) + then (put-stroke view line pump-state offset-change offset) do (update-stroke-dimensions pane view stroke cursor-x cursor-y) (setf cursor-x (x2 stroke-dimensions)) (setf offset (stroke-end-offset stroke)) @@ -795,7 +792,8 @@ (pane-height (bounding-rectangle-height (or (pane-viewport pane) pane)))) ;; For invalidation of the parts of the display that have ;; changed. - (synchronize-view view :begin (offset (top view)) :end (offset (bot view))) + (synchronize-view view :begin (offset (top view)) :end (max (offset (bot view)) + (offset (top view)))) (setf (displayed-lines-count view) 0 (max-line-width view) 0) (multiple-value-bind (cursor-x cursor-y) (stream-cursor-position pane) @@ -890,6 +888,35 @@ (defmethod stroke-pump ((view drei-buffer-view) stroke pump-state) (buffer-view-stroke-pump view stroke pump-state)) +;;; The following is the equivalent of a turbocharger for the +;;; redisplay engine. +(defstruct (skipalong-pump-state + (:constructor make-skipalong-pump-state (offset))) + "A pump state for fast skipalong that doesn't involve +the (potentially expensive) actual stroke pump. It transparently +turns into a real pump state when it happens across invalid +strokes. `Offset' is the offset of the next stroke to be pumped." + offset) + +(defmethod stroke-pump :around ((view drei-buffer-view) (stroke displayed-stroke) + (pump-state skipalong-pump-state)) + (with-accessors ((state-offset skipalong-pump-state-offset)) pump-state + (if (or (stroke-modified stroke) + (/= (stroke-start-offset stroke) state-offset)) + (stroke-pump view stroke (pump-state-for-offset view state-offset)) + (progn (setf state-offset + (+ (stroke-end-offset stroke) + (if (offset-end-of-line-p + (buffer view) (stroke-end-offset stroke)) + 1 0))) + pump-state)))) + +(defmethod stroke-pump :around ((view drei-buffer-view) (stroke displayed-stroke) + pump-state) + (if (stroke-modified stroke) + (call-next-method) + (stroke-pump view stroke (make-skipalong-pump-state (stroke-start-offset stroke))))) + ;;; Cursor handling. (defun offset-in-stroke-position (stream view stroke offset) @@ -1170,7 +1197,7 @@ (setf (offset top) (offset bot)) (beginning-of-line top) (setf (offset (point view)) (offset top)) - (invalidate-all-strokes view)))) + (invalidate-all-strokes view :modified t)))) (defmethod page-up (pane (view drei-buffer-view)) (with-accessors ((top top) (bot bot)) view --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/02/10 00:42:03 1.74 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/02/15 13:16:17 1.75 @@ -1921,6 +1921,24 @@ (defmethod syntax-highlighting-rules ((syntax lisp-syntax)) *syntax-highlighting-rules*) +(defmethod invalidate-strokes ((view textual-drei-syntax-view) (syntax lisp-syntax)) + ;; Invalidate the area touched by parenthesis highlighting, if + ;; applicable. Cheap test to do coarse elimination... + (when (or (and (not (end-of-buffer-p (point view))) + (equal (object-after (point view)) #\()) + (and (not (beginning-of-buffer-p (point view))) + (equal (object-before (point view)) #\)))) + ;; Might still be a fake match, so do the semiexpensive proper test. + (let ((form (form-around syntax (offset (point view))))) + (when form + (let ((start-offset (start-offset form)) + (end-offset (end-offset form))) + (when (or (mark= start-offset (point view)) + (mark= end-offset (point view))) + ;; We actually have parenthesis highlighting. + (list (cons start-offset (1+ start-offset)) + (cons (1- end-offset) end-offset)))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; exploit the parse --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/11 23:05:22 1.52 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/15 13:16:17 1.53 @@ -220,7 +220,7 @@ #:drei-buffer-view #:buffer #:top #:bot #:buffer-view-p #:lines - #:buffer-line #:start-mark #:line-length #:chunks #:end-offset + #:buffer-line #:start-mark #:end-mark #:line-length #:chunks #:line-containing-offset #:offset-in-line-p #:buffer-view-pump-state-for-offset #:buffer-view-stroke-pump @@ -243,6 +243,8 @@ #:overwrite-mode #:goal-column + #:invalidate-strokes + #:view-command-tables #:use-editor-commands-p #:synchronize-view @@ -538,6 +540,8 @@ #:action #:new-state #:done #:reduce-fixed-number #:reduce-until-type #:reduce-all #:error-state #:error-reduce-state + #:do-parse-symbols-forward + #:parser-symbol-containing-offset #:define-syntax-highlighting-rules #:syntax-highlighting-rules) (:documentation "Underlying LR parsing functionality.")) --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/02/08 18:37:32 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/02/15 13:16:17 1.19 @@ -22,7 +22,7 @@ (in-package :drei-syntax) -(defclass syntax (name-mixin) +(defclass syntax (name-mixin observable-mixin) ((%buffer :initarg :buffer :reader buffer) (%command-table :initarg :command-table :initform (error "A command table has not been provided for this syntax") --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/14 08:15:01 1.38 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/15 13:16:17 1.39 @@ -605,7 +605,10 @@ (%lines-suffix :accessor lines-suffix-size :documentation "The number of unchanged objects at the end of the buffer since since the list of lines was last -updated.")) +updated.") + (%last-seen-buffer-size :accessor last-seen-buffer-size + :documentation "The buffer size the +last time a change to the buffer was registered.")) (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' object. The buffer is displayed on a simple line-by-line basis, @@ -618,7 +621,8 @@ (declare (ignore initargs)) (with-accessors ((top top) (bot bot) (lines-prefix lines-prefix-size) - (lines-suffix lines-suffix-size)) view + (lines-suffix lines-suffix-size) + (buffer-size last-seen-buffer-size)) view (unless buffer ;; So many fun things are defined on (setf buffer) that we use ;; slot-value here. This is just a glorified initform anyway. @@ -629,7 +633,8 @@ (setf top (make-buffer-mark (buffer view) 0 :left) bot (clone-mark top :right) lines-prefix 0 - lines-suffix 0))) + lines-suffix 0 + buffer-size (size (buffer view))))) (defmethod (setf top) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view)) @@ -641,11 +646,13 @@ (invalidate-all-strokes view) (with-accessors ((top top) (bot bot) (lines-prefix lines-prefix-size) - (lines-suffix lines-suffix-size)) view + (lines-suffix lines-suffix-size) + (buffer-size last-seen-buffer-size)) view (setf top (make-buffer-mark buffer 0 :left) bot (clone-mark top :right) lines-prefix 0 - lines-suffix 0))) + lines-suffix 0 + buffer-size 0))) (defmethod cache-string :around ((view drei-buffer-view)) (let ((string (call-next-method))) @@ -670,9 +677,9 @@ ((%start-mark :reader start-mark :initarg :start-mark :documentation "The mark at which this line starts.") - (%line-length :reader line-length - :initarg :line-length - :documentation "The length of the line described by this object.") + (%end-mark :reader end-mark + :initarg :end-mark + :documentation "The mark at which this line ends.") (%chunks :accessor chunks :initform (make-array 5 :adjustable t @@ -700,9 +707,15 @@ when (= chunk-start-offset line-end-offset) do (loop-finish))) +(defmethod start-offset ((line buffer-line)) + (offset (start-mark line))) + (defmethod end-offset ((line buffer-line)) - "Return the end buffer offset of `line'." - (+ (offset (start-mark line)) (line-length line))) + (offset (end-mark line))) + +(defun line-length (line) + "Return the length of the `buffer-line' object `line'." + (- (end-offset line) (start-offset line))) (defun get-chunk (buffer line-start-offset chunk-start-offset line-end-offset) "Return a chunk in the form of a cons cell. The chunk will @@ -755,12 +768,11 @@ ;; Analyze new lines. (loop while (mark<= low-mark high-mark) for i from low-index - do (progn (let ((line-start-mark (clone-mark low-mark))) - (insert* lines i (make-instance - 'buffer-line + do (progn (let ((line-start-mark (clone-mark low-mark :left)) + (line-end-mark (clone-mark (end-of-line low-mark) :right))) + (insert* lines i (make-instance 'buffer-line :start-mark line-start-mark - :line-length (- (offset (end-of-line low-mark)) - (offset line-start-mark)))) + :end-mark line-end-mark)) (if (end-of-buffer-p low-mark) (loop-finish) ;; skip newline @@ -770,12 +782,40 @@ (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) + (declare (optimize (debug 3))) (destructuring-bind (start-offset . end-offset) changed-region - (invalidate-strokes-in-region view start-offset end-offset :modified t) (with-accessors ((prefix-size lines-prefix-size) - (suffix-size lines-suffix-size)) view - (setf prefix-size (min start-offset prefix-size) - suffix-size (min (- (size buffer) end-offset) suffix-size))))) + (suffix-size lines-suffix-size) + (buffer-size last-seen-buffer-size)) view + ;; Figure out whether the change involved insertion or deletion of + ;; a newline. + (let* ((line-index (index-of-line-containing-offset view start-offset)) + (line (element* (lines view) line-index)) + (newline-change + (or (loop for index from start-offset below end-offset + when (equal (buffer-object (buffer view) index) #\Newline) + return t) + ;; If the line is joined with the one before or + ;; after it, a newline object has been removed. + (or (when (/= line-index (nb-elements (lines view))) + (= (start-offset (element* (lines view) (1+ line-index))) + (end-offset line))) + (when (plusp line-index) + (= (end-offset (element* (lines view) (1- line-index))) + (start-offset line))))))) + ;; If the line structure changed, everything after the newline is suspect. + (invalidate-strokes-in-region view start-offset + (if newline-change + (max start-offset (offset (bot view))) + end-offset) + :modified t) + (setf prefix-size (min start-offset prefix-size) + suffix-size (min (- (size buffer) end-offset) suffix-size) + buffer-size (size buffer)) + ;; If the line structure changed, we need to update the line + ;; data, or we can't pick up future changes correctly. + (when newline-change + (update-line-data view)))))) (defmethod synchronize-view ((view drei-buffer-view) &key) (update-line-data view)) @@ -844,13 +884,14 @@ &key (syntax *default-syntax*)) (declare (ignore args)) (check-type syntax (or symbol syntax)) - (with-accessors ((view-syntax syntax) - (buffer buffer) + (with-accessors ((buffer buffer) (suffix-size suffix-size) (prefix-size prefix-size)) view - (setf view-syntax (if (symbolp syntax) - (make-syntax-for-view view syntax) - syntax)) + (setf (slot-value view '%syntax) + (if (symbolp syntax) + (make-syntax-for-view view syntax) + syntax)) + (add-observer (syntax view) view) (add-observer buffer view))) (defmethod (setf buffer) :before ((buffer drei-buffer) (view drei-syntax-view)) @@ -866,7 +907,11 @@ (with-accessors ((view-syntax syntax)) view (setf view-syntax (make-syntax-for-view view (class-of view-syntax))))) +(defmethod (setf syntax) :before (syntax (view drei-syntax-view)) + (remove-observer (syntax view) view)) + (defmethod (setf syntax) :after (syntax (view drei-syntax-view)) + (add-observer syntax view) (setf (prefix-size view) 0 (suffix-size view) 0 (buffer-size view) -1)) @@ -899,6 +944,11 @@ modified-p t))) (call-next-method)) +(defmethod observer-notified ((view drei-syntax-view) (syntax syntax) + changed-region) + (destructuring-bind (start-offset . end-offset) changed-region + (invalidate-strokes-in-region view start-offset end-offset :modified t))) + (defun needs-resynchronization (view) "Return true if the the view of the buffer of `view' is potentially out of date. Return false otherwise." @@ -1018,6 +1068,37 @@ highlighting, and maintains point and mark marks into the buffer, in order to permit useful editing commands.")) +(defgeneric invalidate-strokes (view syntax) + (:documentation "Called just before redisplay of the +`textual-drei-syntax-view' `view' in order to give `syntax', +which is the syntax of `view', a chance to mark part of the +display as invalid due to do something not caused by buffer +modification (for example, parenthesis matching). This function +should return a list of pairs of buffer offsets, each pair +delimiting a buffer region that should be redrawn.") + (:method ((view textual-drei-syntax-view view) (syntax syntax)) + nil)) + +(defun invalidate-as-appropriate (view invalid-regions) + "Invalidate strokes of `view' overlapping regions in +`invalid-regions'. `Invalid-regions' is a list of conses of +buffer offsets delimiting regions." + (loop with top-offset = (offset (top view)) + with bot-offset = (offset (bot view)) + for (start . end) in invalid-regions + do (as-region (start end) + (when (overlaps start end top-offset bot-offset) + (invalidate-strokes-in-region view start end :modified t))))) + +(defmethod display-drei-view-contents :around (stream (view textual-drei-syntax-view)) + (let ((invalid-regions (invalidate-strokes view (syntax view)))) + (invalidate-as-appropriate view invalid-regions) + (call-next-method) + ;; We do not expect whatever ephemeral state that caused + ;; invalidation to stick around until the next redisplay, so + ;; whatever it imposed on us, mark as dirty immediately. + (invalidate-as-appropriate view invalid-regions))) + (defmethod create-view-cursors nconc ((output-stream extended-output-stream) (view textual-drei-syntax-view)) (unless (no-cursors view) From thenriksen at common-lisp.net Fri Feb 15 13:17:58 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 15 Feb 2008 08:17:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080215131758.E2EB223348@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6346/Drei Modified Files: views.lisp Log Message: Fixed range check on access to the flexichain of lines. Oops. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/15 13:16:17 1.39 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/15 13:17:54 1.40 @@ -797,7 +797,7 @@ return t) ;; If the line is joined with the one before or ;; after it, a newline object has been removed. - (or (when (/= line-index (nb-elements (lines view))) + (or (when (< (1+ line-index) (nb-elements (lines view))) (= (start-offset (element* (lines view) (1+ line-index))) (end-offset line))) (when (plusp line-index) From thenriksen at common-lisp.net Sat Feb 16 10:30:11 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 16 Feb 2008 05:30:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080216103011.323821F0FA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8962/Drei Modified Files: drei-redisplay.lisp views.lisp Log Message: Fixed somewhat-rare Drei redisplay issue where strokes that were changed weren't invalidated. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/15 13:16:17 1.65 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/16 10:30:10 1.66 @@ -318,14 +318,16 @@ , at body))))) (defun invalidate-strokes-in-region (view start-offset end-offset - &key modified cleared) + &key modified cleared to-line-end) "Invalidate all the strokes of `view' that overlap the region `start-offset'/`end-offset' by setting their dirty-bit to true. If `modified' or `cleared' is true, also set their modified-bit to true. If `cleared' is true, inform the strokes that their previous output has been cleared by someone, and that they do not need to clear it themselves during their next -redisplay." +redisplay. If `to-line-end' is true, if a line is in the region, +strokes in it will be invalidated until the end, even if line-end +is beyond the region." (as-region (start-offset end-offset) ;; If the region is outside the visible region, no-op. (when (and (plusp (displayed-lines-count view)) ; If there is any display... @@ -342,9 +344,11 @@ :cleared cleared) ;; Only part of the line is within the region. else do (do-displayed-line-strokes (stroke line) - (when (overlaps start-offset end-offset - (stroke-start-offset stroke) - (stroke-end-offset stroke)) + (when (if to-line-end + (<= start-offset (stroke-start-offset stroke)) + (overlaps start-offset end-offset + (stroke-start-offset stroke) + (stroke-end-offset stroke))) (invalidate-stroke stroke :modified modified :cleared cleared))) if (= line1-index line2-index) do (loop-finish) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/15 13:17:54 1.40 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/16 10:30:10 1.41 @@ -782,7 +782,6 @@ (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) - (declare (optimize (debug 3))) (destructuring-bind (start-offset . end-offset) changed-region (with-accessors ((prefix-size lines-prefix-size) (suffix-size lines-suffix-size) @@ -808,7 +807,8 @@ (if newline-change (max start-offset (offset (bot view))) end-offset) - :modified t) + :modified t + :to-line-end t) (setf prefix-size (min start-offset prefix-size) suffix-size (min (- (size buffer) end-offset) suffix-size) buffer-size (size buffer)) From thenriksen at common-lisp.net Sat Feb 16 21:33:40 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 16 Feb 2008 16:33:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080216213340.4CEAB43215@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6197/Drei Modified Files: drei-clim.lisp Log Message: Patch from Thomas Persson to make Drei gadgets inherit the command table of their application frame. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/02/02 19:03:26 1.41 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/02/16 21:33:40 1.42 @@ -337,7 +337,8 @@ (defmethod additional-command-tables append ((drei drei-gadget-pane) (table drei-command-table)) - `(exclusive-gadget-table)) + `(exclusive-gadget-table + ,(frame-command-table *application-frame*))) (defclass drei-area (drei displayed-output-record region command-processor From thenriksen at common-lisp.net Sat Feb 16 22:06:10 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 16 Feb 2008 17:06:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080216220610.2737016041@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13651/Drei Modified Files: lisp-syntax-commands.lisp lisp-syntax-swine.lisp Log Message: Added Remove Definition command to Lisp syntax. Bound to C-c C-u. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2008/02/08 18:05:51 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2008/02/16 22:06:09 1.18 @@ -169,6 +169,37 @@ (define-command (com-eval-defun :name t :command-table pane-lisp-table) () (eval-defun (point) (current-syntax))) +(define-command (com-remove-definition :name t :command-table lisp-table) + () + "Remove the definition point is in. + +The operator of the definition form will be used to determine +what kind of definition it is. The user will be asked for +confirmation before anything is actually done." + (let ((definition-form (definition-at-mark (current-syntax) (point)))) + (if (or (null definition-form) + (mark> (point) (end-offset definition-form)) + (mark< (point) (start-offset definition-form))) + (display-message "No definition found at point.") + (handler-case + (let* ((definition-type (form-to-object (current-syntax) + (form-operator definition-form))) + (undefiner (get-undefiner definition-type))) + (if (null undefiner) + (display-message "Doesn't know how to undefine ~S." definition-type) + (handler-case + (when (accept 'boolean + :prompt (format nil "Undefine the ~A ~S?" + (undefiner-type undefiner) + (definition-name undefiner (current-syntax) definition-form)) + :default t :insert-default t) + (undefine undefiner (current-syntax) definition-form)) + (form-conversion-error (e) + (display-message "Could not undefine ~S form: ~A" definition-type (problem e)))))) + (form-conversion-error (e) + (display-message "Couldn't turn \"~A\" into valid operator: ~A" + (form-string (current-syntax) (form e)) (problem e))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Gesture bindings @@ -261,3 +292,6 @@ 'lisp-table '((#\Delete :control :meta))) +(set-key 'com-remove-definition + 'lisp-table + '((#\c :control) (#\u :control))) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/05 21:51:29 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/16 22:06:09 1.17 @@ -927,3 +927,141 @@ (result (apply #'format nil "~{{~:[No values~;~:*~{~S~^,~}~]}~}" values))) (esa:display-message result))))) + +(defclass undefiner () + () + (:documentation "A base class for classes that contain logic +for undefining Lisp constructs. Subclasses of `undefiner' must +implement the undefiner protocol. An instance of `undefiner' +works on a specific kind of definition (a `defun', `defclass', +`defgeneric', etc).")) + +(defgeneric undefiner-type (undefiner) + (:documentation "Return the kind of definition undefined by +`undefiner'. The return value is a string - a textual, +user-oriented description.")) + +(defgeneric definition-name (undefiner syntax definition-form) + (:documentation "Return the name of the definition described by +`definition-form', as per the kind of definition `undefiner' +handles. `Syntax' is the Lisp syntax object that has +`definition-form'. The name returned is an actual Lisp +object. `Form-conversion-error' is signalled if the form +describing the name cannot be converted to an object, or if the +form is otherwise inappropriate.")) + +(defgeneric undefine (undefiner syntax definition-form) + (:documentation "Undefine whatever `definition-form' defines, +provided `definition-form' is the kind of definition handled by +`undefiner'. If it isn't, the results are undefined. `Syntax' is +the Lisp syntax object that has `definition-form'.")) + +(defclass simple-undefiner (undefiner) + ((%undefiner-type :reader undefiner-type + :initform (error "A description must be provided.") + :type string + :documentation "A textual, user-oriented name +for the type of definition handled by this +undefiner." + :initarg :undefiner-type) + (%undefiner-function :reader undefiner-function + :initform (error "An undefiner function must be provided.") + :documentation "A function of three +arguments: the syntax object, the name of the definition to be +undefined and the form to be undefined." + :initarg :undefiner-function))) + +(defmethod definition-name ((undefiner simple-undefiner) (syntax lisp-syntax) (form form)) + (form-conversion-error syntax form "Form ~A cannot define a ~A." (undefiner-type undefiner))) + +(defmethod definition-name ((undefiner simple-undefiner) (syntax lisp-syntax) (form list-form)) + (if (>= (length (form-children form)) 2) + (form-to-object syntax (second-form (children form))) + (call-next-method))) + +(defmethod undefine ((undefiner simple-undefiner) (syntax lisp-syntax) (form form)) + (funcall (undefiner-function undefiner) syntax + (definition-name undefiner syntax form) + form)) + +(defvar *undefiners* (make-hash-table) + "A hash table mapping operators to undefiners. The undefiners +are instances of `undefiner'.") + +(defun get-undefiner (definition-type) + "Return the undefiner for `definition-type', which must be a +symbol. Returns NIL if there is no undefiner of the given type." + (values (gethash definition-type *undefiners*))) + +(defmacro define-simple-undefiner (definition-spec (syntax-sym name-sym form-sym) &body body) + "Define a way to undefine some definition. `Definition-spec' is +the operator (like `defun', `defclass', etc), and `syntax-sym', +`name-sym' and `form-sym' will be bound to the Lisp syntax +instance, the name of the definition to be undefined and the +entire form of the definition, when the undefinition is invoked +by the user. Syntactical problems (such as an incomplete or +invalid `form') should be signalled via `form-conversion-error'." + (check-type definition-spec (or list symbol)) + (let* ((definition-type (unlisted definition-spec)) + (undefiner-name (if (listp definition-spec) + (second definition-spec) + (string-downcase definition-type)))) + (check-type definition-type symbol) + `(setf (gethash ',definition-type *undefiners*) + (make-instance 'simple-undefiner + :undefiner-type ,undefiner-name + :undefiner-function #'(lambda (,syntax-sym ,name-sym ,form-sym) + (declare (ignorable ,syntax-sym ,name-sym ,form-sym)) + , at body))))) + +(define-simple-undefiner (defun "function") (syntax name form) + (fmakunbound name)) + +(define-simple-undefiner (defgeneric "generic function") (syntax name form) + (fmakunbound name)) + +(define-simple-undefiner (defmacro "macro") (syntax name form) + (fmakunbound name)) + +(define-simple-undefiner (cl:defclass "class") (syntax name form) + (setf (find-class name nil) nil)) + +(define-simple-undefiner (clim-lisp:defclass "class") (syntax name form) + (setf (find-class name nil) nil)) + +(define-simple-undefiner (defmethod "method") (syntax name form) + (let ((function (fdefinition name))) + (labels ((get-qualifiers (maybe-qualifiers) + (unless (or (null maybe-qualifiers) + (form-list-p (first maybe-qualifiers))) + (cons (form-to-object syntax (first maybe-qualifiers)) + (get-qualifiers (rest maybe-qualifiers))))) + (get-specializers (maybe-specializers) + (cond ((null maybe-specializers) + (form-conversion-error syntax form "~A form invalid." 'defmethod)) + ;; Map across the elements in the lambda list. + ((form-list-p (first maybe-specializers)) + (mapcar #'(lambda (ll-form) + (if (and (form-list-p ll-form) + (second-form (children ll-form))) + (form-to-object syntax (second-form (children ll-form))) + t)) + (form-children (first maybe-specializers)))) + ;; Skip the qualifiers to get the lambda-list. + (t (get-specializers (rest maybe-specializers)))))) + (remove-method function (find-method function + (get-qualifiers (cddr (form-children form))) + (get-specializers (cddr (form-children form))) + nil))))) + +(define-simple-undefiner (defvar "special variable") (syntax name form) + (makunbound name)) + +(define-simple-undefiner (defparameter "special variable") (syntax name form) + (makunbound name)) + +(define-simple-undefiner (defconstant "constant") (syntax name form) + (makunbound name)) + +(define-simple-undefiner (defpackage "package") (syntax name form) + (delete-package name)) From thenriksen at common-lisp.net Sun Feb 17 14:54:47 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 17 Feb 2008 09:54:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080217145447.F2F2F5622D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23932/Drei Modified Files: drei-redisplay.lisp lr-syntax.lisp views.lisp Log Message: Fixed obscure Lisp syntax redisplay issue that could cause trouble with literal objects. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/16 10:30:10 1.66 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/17 14:54:47 1.67 @@ -442,8 +442,7 @@ (unless (stroke-modified stroke) (incf (stroke-start-offset stroke) line-change) (incf (stroke-end-offset stroke) line-change) - (when (or (null (stroke-start-offset stroke)) - (/= (stroke-start-offset stroke) offset)) + (when (/= (stroke-start-offset stroke) offset) (invalidate-stroke stroke :modified t))) (prog1 (stroke-pump view stroke pump-state) (incf (line-stroke-count line)) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/02/11 22:50:05 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/02/17 14:54:47 1.19 @@ -559,6 +559,9 @@ (line-end-offset (end-offset line))) (flet ((finish (new-offset symbol &optional stroke-drawing-options sticky-p) (setf start-symbol symbol) + (loop until (> (frame-end-offset (first drawing-options)) + new-offset) + do (pop drawing-options)) (unless (null stroke-drawing-options) (push (if (frame-sticky-p (first drawing-options)) (make-drawing-options-frame --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/16 10:30:10 1.41 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/02/17 14:54:47 1.42 @@ -1088,7 +1088,8 @@ for (start . end) in invalid-regions do (as-region (start end) (when (overlaps start end top-offset bot-offset) - (invalidate-strokes-in-region view start end :modified t))))) + (invalidate-strokes-in-region view start end + :modified t :to-line-end t))))) (defmethod display-drei-view-contents :around (stream (view textual-drei-syntax-view)) (let ((invalid-regions (invalidate-strokes view (syntax view)))) From thenriksen at common-lisp.net Mon Feb 18 10:45:26 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 18 Feb 2008 05:45:26 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080218104526.CDCD21705E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv4903/Drei Modified Files: lisp-syntax-swine.lisp Log Message: Added support for undefing command and undefiners. n metacircular uninterpreter! --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/16 22:06:09 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/18 10:45:26 1.18 @@ -956,6 +956,26 @@ `undefiner'. If it isn't, the results are undefined. `Syntax' is the Lisp syntax object that has `definition-form'.")) +(defvar *undefiners* (make-hash-table) + "A hash table mapping operators to undefiners. The undefiners +are instances of `undefiner'.") + +(defun get-undefiner (definition-type) + "Return the undefiner for `definition-type', which must be a +symbol. Returns NIL if there is no undefiner of the given type." + (values (gethash definition-type *undefiners*))) + +(defun invalid-form-for-type (syntax form type-name) + "Signal a `form-conversion-error' describing the fact that +`form' cannot define a `type-name'." + (form-conversion-error syntax form "Form cannot define a ~A." type-name)) + +(defun invalid-form (undefiner syntax form) + "Signal a `form-conversion-error' describing the fact that +`form' cannot define whatever kind of definition `undefiner' +handles." + (invalid-form-for-type syntax form (undefiner-type undefiner))) + (defclass simple-undefiner (undefiner) ((%undefiner-type :reader undefiner-type :initform (error "A description must be provided.") @@ -972,7 +992,7 @@ :initarg :undefiner-function))) (defmethod definition-name ((undefiner simple-undefiner) (syntax lisp-syntax) (form form)) - (form-conversion-error syntax form "Form ~A cannot define a ~A." (undefiner-type undefiner))) + (invalid-form undefiner syntax form)) (defmethod definition-name ((undefiner simple-undefiner) (syntax lisp-syntax) (form list-form)) (if (>= (length (form-children form)) 2) @@ -984,15 +1004,6 @@ (definition-name undefiner syntax form) form)) -(defvar *undefiners* (make-hash-table) - "A hash table mapping operators to undefiners. The undefiners -are instances of `undefiner'.") - -(defun get-undefiner (definition-type) - "Return the undefiner for `definition-type', which must be a -symbol. Returns NIL if there is no undefiner of the given type." - (values (gethash definition-type *undefiners*))) - (defmacro define-simple-undefiner (definition-spec (syntax-sym name-sym form-sym) &body body) "Define a way to undefine some definition. `Definition-spec' is the operator (like `defun', `defclass', etc), and `syntax-sym', @@ -1014,6 +1025,82 @@ (declare (ignorable ,syntax-sym ,name-sym ,form-sym)) , at body))))) +(defclass generic-undefiner (undefiner) + ((%undefiner-type :reader undefiner-type + :initform (error "A description must be provided.") + :type string + :documentation "A textual, user-oriented name +for the type of definition handled by this +undefiner." + :initarg :undefiner-type) + (%name-function :reader name-function + :initform (error "A name retrieval function must be provided.") + :documentation "A function of three arguments: +the syntax object and the form to retrieve a name from. Should +return the name as a Lisp object (probably a symbol). Should +signal a `form-conversion-error' if the form cannot define +whatever type this undefiner handles." + :initarg :name-function) + (%undefiner-function :reader undefiner-function + :initform (error "An undefiner function must be provided.") + :documentation "A function of three +arguments: the syntax object, the name of the definition to be +undefined and the form to be undefined." + :initarg :undefiner-function))) + +(defmethod definition-name ((undefiner generic-undefiner) (syntax lisp-syntax) (form form)) + (funcall (name-function undefiner) syntax form)) + +(defmethod undefine ((undefiner generic-undefiner) (syntax lisp-syntax) (form form)) + (funcall (undefiner-function undefiner) syntax + (definition-name undefiner syntax form) + form)) + +(defmacro define-undefiner (definition-spec + ((name-syntax-sym name-form-sym) &body name-body) + ((undef-syntax-sym undef-name-sym undef-form-sym) + &body undefiner-body)) + "Define a way to undefine definitions. `Definition-spec' is the +operator (like `defun', `defclass', etc) and may optionally be a +list, in which case the first element is the operator, and the +second a user-oriented name for the kind of thing defined by the +operator. `Name-body' and `Undefiner-body' will be evaluated to +retrieve the name and perform the undefinition, respectively. + +`Name-syntax-sym' and `name-form-sym' will be bound to the Lisp +syntax instance and the entire form of the definition during +evaluation of `name-body'. Syntactical problems (such as an +incomplete or invalid form) should be signalled by an +invocation `(invalid)' + +`undef-syntax-sym', `undef-name-sym' and `undef-form-sym' will be +bound to the Lisp syntax instance, the name of the definition to +be undefined and the entire form of the definition when +`undefiner-body' is evaluated. Syntactical problems (such as an +incomplete or invalid form) should be signalled by an +invocation `(invalid)'." + (check-type definition-spec (or list symbol)) + (let* ((definition-type (unlisted definition-spec)) + (undefiner-name (if (listp definition-spec) + (second definition-spec) + (string-downcase definition-type)))) + (check-type definition-type symbol) + `(setf (gethash ',definition-type *undefiners*) + (make-instance 'generic-undefiner + :undefiner-type ,undefiner-name + :name-function #'(lambda (,name-syntax-sym ,name-form-sym) + (declare (ignorable ,name-syntax-sym ,name-form-sym)) + (flet ((invalid () + (invalid-form-for-type ,name-syntax-sym ,name-form-sym ,undefiner-name))) + (declare (ignorable #'invalid)) + , at name-body)) + :undefiner-function #'(lambda (,undef-syntax-sym ,undef-name-sym ,undef-form-sym) + (declare (ignorable ,undef-syntax-sym ,undef-name-sym ,undef-form-sym)) + (flet ((invalid () + (invalid-form-for-type ,undef-syntax-sym ,undef-form-sym ,undef-name-sym))) + (declare (ignorable #'invalid)) + , at undefiner-body)))))) + (define-simple-undefiner (defun "function") (syntax name form) (fmakunbound name)) @@ -1065,3 +1152,50 @@ (define-simple-undefiner (defpackage "package") (syntax name form) (delete-package name)) + +(defun get-listed-name (syntax form) + "Retrieve the name of `form' under the assumption that the name +is the second element of `form', and if this is a list, the first +element of that list. The secondary value will be true if a name +can be found, false otherwise." + (if (and (form-list-p form) + (>= (length (form-children form)) 2)) + (let ((name-form (second (form-children form)))) + (cond ((and (form-list-p name-form) + (form-children name-form)) + (values (form-to-object syntax (first (form-children name-form))) t)) + ((form-token-p name-form) + (values (form-to-object syntax name-form) t)) + (t (values nil nil)))) + (values nil nil))) + +;; Cannot recognize the common define-FOO-command macros. +(define-undefiner (define-command "command") + ((syntax form) + (multiple-value-bind (name success) (get-listed-name syntax form) + (if success name (invalid)))) + ((syntax name form) + ;; Pick out the command table from the define-command form. The + ;; command may also be in other command tables, but we can't find + ;; those. + (let ((name-form (listed (form-to-object syntax (second (form-children form)))))) + (destructuring-bind (ignore &key command-table keystroke &allow-other-keys) name-form + (declare (ignore ignore)) + (when command-table + (remove-command-from-command-table name command-table :errorp nil) + (remove-keystroke-from-command-table command-table keystroke :errorp nil)))) + (fmakunbound name))) + +(define-undefiner (define-undefiner "undefiner") + ((syntax form) + (multiple-value-bind (name success) (get-listed-name syntax form) + (if success name (invalid)))) + ((syntax name form) + (remhash name *undefiners*))) + +(define-undefiner (define-simple-undefiner "simple undefiner") + ((syntax form) + (multiple-value-bind (name success) (get-listed-name syntax form) + (if success name (invalid)))) + ((syntax name form) + (remhash name *undefiners*))) From thenriksen at common-lisp.net Mon Feb 18 12:22:47 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 18 Feb 2008 07:22:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080218122247.C329C56234@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26794/Drei Modified Files: drei-redisplay.lisp Log Message: Fix :to-line-end keyword parameter for invalidate-strokes-in-region. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/17 14:54:47 1.67 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/02/18 12:22:47 1.68 @@ -344,11 +344,10 @@ :cleared cleared) ;; Only part of the line is within the region. else do (do-displayed-line-strokes (stroke line) - (when (if to-line-end - (<= start-offset (stroke-start-offset stroke)) - (overlaps start-offset end-offset - (stroke-start-offset stroke) - (stroke-end-offset stroke))) + (when (overlaps start-offset + (if to-line-end (line-end-offset line) end-offset) + (stroke-start-offset stroke) + (stroke-end-offset stroke)) (invalidate-stroke stroke :modified modified :cleared cleared))) if (= line1-index line2-index) do (loop-finish) From thenriksen at common-lisp.net Tue Feb 19 22:26:06 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 19 Feb 2008 17:26:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080219222606.C20435F0E5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv11072 Modified Files: gadgets.lisp Log Message: Fixed division-by-zero bug in scrollbar code. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/08/21 22:09:01 1.107 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/02/19 22:26:06 1.108 @@ -1463,7 +1463,7 @@ (let ((ts (scroll-bar-thumb-size sb))) ;; This is the right spot to handle ts = :none or perhaps NIL (multiple-value-bind (range) (gadget-range sb) - (let ((ts-in-pixels (round (* (- y3 y1) (/ ts (+ range ts)))))) ;### range + ts = 0? + (let ((ts-in-pixels (round (* (- y3 y1) (/ ts (max 1 (+ range ts))))))) ; handle range + ts = 0 (setf ts-in-pixels (min (- y3 y1) ;thumb can't be larger than the thumb bed (max +minimum-thumb-size-in-pixels+ ;but shouldn't be smaller than this. ts-in-pixels)))