mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

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

05 Feb '08

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

1 0

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

04 Feb '08

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)

1 0

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

04 Feb '08

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

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 04 Feb '08

04 Feb '08

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

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 04 Feb '08

04 Feb '08

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

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 04 Feb '08

04 Feb '08

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

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by rschlatte 04 Feb '08

04 Feb '08

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

1 0

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

03 Feb '08

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)

1 0

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

03 Feb '08

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)

1 0

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

03 Feb '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-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)))))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs