February 2005 - climacs-cvs@common-lisp.net

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 21 Feb '05

21 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv30093 Modified Files: gui.lisp Log Message: Removed debug message and an obsolete comment. Date: Mon Feb 21 13:51:57 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.117 climacs/gui.lisp:1.118 --- climacs/gui.lisp:1.117 Mon Feb 21 09:51:03 2005 +++ climacs/gui.lisp Mon Feb 21 13:51:55 2005 @@ -856,8 +856,6 @@ ;;; ;;; Commands for splitting windows -;; put this in for real when we find a solution for the problem -;; it causes for com-delete-window (defun replace-constellation (constellation additional-constellation vertical-p) (let* ((parent (sheet-parent constellation)) (children (sheet-children parent)) @@ -865,7 +863,6 @@ (second (second children)) (third (third children)) (adjust (make-pane 'clim-extensions:box-adjuster-gadget))) - (format *query-io* "~S" children) (assert (member constellation children)) (sheet-disown-child parent constellation) (let ((new (if vertical-p

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 21 Feb '05

21 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv16960 Modified Files: gui.lisp Log Message: Fixed old problem with using adjuster gadget. Date: Mon Feb 21 09:51:03 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.116 climacs/gui.lisp:1.117 --- climacs/gui.lisp:1.116 Mon Feb 21 08:58:39 2005 +++ climacs/gui.lisp Mon Feb 21 09:51:03 2005 @@ -856,54 +856,32 @@ ;;; ;;; Commands for splitting windows -;;; put this in for real when we find a solution for the problem -;;; it causes for com-delete-window -;; (defun replace-constellation (constellation additional-constellation vertical-p) -;; (let* ((parent (sheet-parent constellation)) -;; (children (sheet-children parent)) -;; (first (first children)) -;; (second (second children)) -;; (adjust (make-pane 'clim-extensions:box-adjuster-gadget))) -;; (assert (member constellation children)) -;; (cond ((eq constellation first) -;; (sheet-disown-child parent constellation) -;; (let ((new (if vertical-p -;; (vertically () -;; constellation adjust additional-constellation) -;; (horizontally () -;; constellation adjust additional-constellation)))) -;; (sheet-adopt-child parent new) -;; (reorder-sheets parent (list new second)))) -;; (t -;; (sheet-disown-child parent constellation) -;; (let ((new (if vertical-p -;; (vertically () -;; constellation adjust additional-constellation) -;; (horizontally () -;; constellation adjust additional-constellation)))) -;; (sheet-adopt-child parent new) -;; (reorder-sheets parent (list first new))))))) - +;; put this in for real when we find a solution for the problem +;; it causes for com-delete-window (defun replace-constellation (constellation additional-constellation vertical-p) (let* ((parent (sheet-parent constellation)) (children (sheet-children parent)) (first (first children)) - (second (second children))) + (second (second children)) + (third (third children)) + (adjust (make-pane 'clim-extensions:box-adjuster-gadget))) + (format *query-io* "~S" children) (assert (member constellation children)) - (cond ((eq constellation first) - (sheet-disown-child parent constellation) - (let ((new (if vertical-p - (vertically () constellation additional-constellation) - (horizontally () constellation additional-constellation)))) - (sheet-adopt-child parent new) - (reorder-sheets parent (list new second)))) - (t - (sheet-disown-child parent constellation) - (let ((new (if vertical-p - (vertically () constellation additional-constellation) - (horizontally () constellation additional-constellation)))) - (sheet-adopt-child parent new) - (reorder-sheets parent (list first new))))))) + (sheet-disown-child parent constellation) + (let ((new (if vertical-p + (vertically () + constellation adjust additional-constellation) + (horizontally () + constellation adjust additional-constellation)))) + (sheet-adopt-child parent new) + (reorder-sheets parent + (if (eq constellation first) + (if third + (list new second third) + (list new second)) + (if third + (list first second new) + (list first new))))))) (defun parent3 (sheet) (sheet-parent (sheet-parent (sheet-parent sheet)))) @@ -967,53 +945,36 @@ (append (cdr (windows *application-frame*)) (list (car (windows *application-frame*)))))) +(define-named-command com-single-window () + (loop until (null (cdr (windows *application-frame*))) + do (rotatef (car (windows *application-frame*)) + (cadr (windows *application-frame*))) + (com-delete-window))) + (define-named-command com-delete-window () (unless (null (cdr (windows *application-frame*))) (let* ((constellation (parent3 (current-window))) (box (sheet-parent constellation)) (box-children (sheet-children box)) (other (if (eq constellation (first box-children)) - (second box-children) + (third box-children) (first box-children))) (parent (sheet-parent box)) (children (sheet-children parent)) (first (first children)) - (second (second children))) + (second (second children)) + (third (third children))) (pop (windows *application-frame*)) (sheet-disown-child box other) (sheet-disown-child parent box) - (sheet-adopt-child parent other) + (sheet-adopt-child parent other) (reorder-sheets parent (if (eq box first) - (list other second) - (list first other)))))) - -(define-named-command com-single-window () - (loop until (null (cdr (windows *application-frame*))) - do (rotatef (car (windows *application-frame*)) - (cadr (windows *application-frame*))) - (com-delete-window))) - -;; (define-named-command com-delete-window () -;; (unless (null (cdr (windows *application-frame*))) -;; (let* ((constellation (parent3 (current-window))) -;; (box (sheet-parent constellation)) -;; (box-children (sheet-children box)) -;; (other (if (eq constellation (first box-children)) -;; (third box-children) -;; (first box-children))) -;; (parent (sheet-parent box)) -;; (children (sheet-children parent)) -;; (first (first children)) -;; (second (second children)) -;; (third (third children))) -;; (pop (windows *application-frame*)) -;; (sheet-disown-child box other) -;; (sheet-disown-child parent box) -;; (sheet-adopt-child parent other) -;; (cond ((eq box first) -;; (reorder-sheets parent (list other second third))) -;; (t -;; (reorder-sheets parent (list first second other))))))) + (if third + (list other second third) + (list other second)) + (if third + (list first second other) + (list first other))))))) ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 21 Feb '05

21 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv13781 Modified Files: gui.lisp Log Message: Simplified implementation of com-delete-window Date: Mon Feb 21 08:58:40 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.115 climacs/gui.lisp:1.116 --- climacs/gui.lisp:1.115 Mon Feb 21 08:47:26 2005 +++ climacs/gui.lisp Mon Feb 21 08:58:39 2005 @@ -981,15 +981,11 @@ (second (second children))) (pop (windows *application-frame*)) (sheet-disown-child box other) - (cond ((eq box first) - (sheet-disown-child parent box) - (sheet-adopt-child parent other) - (reorder-sheets parent (list other second))) - (t - (sheet-disown-child parent box) - (sheet-adopt-child parent other) - (reorder-sheets parent (list first other))))))) - + (sheet-disown-child parent box) + (sheet-adopt-child parent other) + (reorder-sheets parent (if (eq box first) + (list other second) + (list first other)))))) (define-named-command com-single-window () (loop until (null (cdr (windows *application-frame*))) @@ -1012,13 +1008,11 @@ ;; (third (third children))) ;; (pop (windows *application-frame*)) ;; (sheet-disown-child box other) +;; (sheet-disown-child parent box) +;; (sheet-adopt-child parent other) ;; (cond ((eq box first) -;; (sheet-disown-child parent box) -;; (sheet-adopt-child parent other) ;; (reorder-sheets parent (list other second third))) ;; (t -;; (sheet-disown-child parent box) -;; (sheet-adopt-child parent other) ;; (reorder-sheets parent (list first second other))))))) ;;;;;;;;;;;;;;;;;;;;

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 21 Feb '05

21 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv13708 Modified Files: gui.lisp Log Message: Simplified implementation of com-single-window and made it independent of the clim-internals package. Date: Mon Feb 21 08:47:27 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.114 climacs/gui.lisp:1.115 --- climacs/gui.lisp:1.114 Sun Feb 20 06:39:16 2005 +++ climacs/gui.lisp Mon Feb 21 08:47:26 2005 @@ -992,25 +992,10 @@ (define-named-command com-single-window () - (unless (null (cdr (windows *application-frame*))) - (let* ((saver (parent3 (current-window))) - (top-level (do - ((n saver (setf n (sheet-parent n)))) - ((clim-internals::top-level-sheet-pane-p n) n))) - (level1 (car (sheet-children top-level))) ;; should be the only thing on level1 - (level2 (if (typep (car (sheet-children level1)) 'vrack-pane) ;;don't select raised pane - (car (sheet-children level1)) - (cadr (sheet-children level1)))) - (level2-children (sheet-children level2)) - (junker (if (typep (car level2-children) 'vrack-pane) ;;don't select minibuffer - (car level2-children) - (cadr level2-children)))) - (sheet-disown-child (sheet-parent saver) saver) - (sheet-disown-child level2 junker) - (sheet-adopt-child level2 saver) - (reorder-sheets level2 (reverse (sheet-children level2))) ;;minibuffer goes on bottom - (setf (windows *application-frame*) (list (car (windows *application-frame*))))))) - + (loop until (null (cdr (windows *application-frame*))) + do (rotatef (car (windows *application-frame*)) + (cadr (windows *application-frame*))) + (com-delete-window))) ;; (define-named-command com-delete-window () ;; (unless (null (cdr (windows *application-frame*)))

1 0

[climacs-cvs] CVS update: climacs/TODO climacs/gui.lisp
by rstrandh＠common-lisp.net 20 Feb '05

20 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv22599 Modified Files: TODO gui.lisp Log Message: Lines are no longer wrapped by CLIM. Scrolling does not work very well either though. We do need that custom scroller pane. Date: Sun Feb 20 06:39:16 2005 Author: rstrandh Index: climacs/TODO diff -u climacs/TODO:1.4 climacs/TODO:1.5 --- climacs/TODO:1.4 Sun Feb 20 06:11:39 2005 +++ climacs/TODO Sun Feb 20 06:39:15 2005 @@ -5,6 +5,4 @@ one sequence type for lines, the other for line contents), then upgrade it to an undoable buffer -- handle wrapped lines instead of making McCLIM handle them - - replace the use of the scroller pane by custom pane Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.113 climacs/gui.lisp:1.114 --- climacs/gui.lisp:1.113 Sun Feb 20 06:11:39 2005 +++ climacs/gui.lisp Sun Feb 20 06:39:16 2005 @@ -60,6 +60,7 @@ (make-pane 'extended-pane :width 900 :height 400 :name 'bla + :end-of-line-action :scroll :incremental-redisplay t :display-function 'display-win)) (info-pane @@ -916,6 +917,7 @@ (make-pane 'extended-pane :width 900 :height 400 :name 'win + :end-of-line-action :scroll :incremental-redisplay t :display-function 'display-win)) (vbox

1 0

[climacs-cvs] CVS update: climacs/TODO climacs/gui.lisp
by rstrandh＠common-lisp.net 20 Feb '05

20 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv21015 Modified Files: TODO gui.lisp Log Message: Redisplay is now invoked when the frame is resized. Date: Sun Feb 20 06:11:45 2005 Author: rstrandh Index: climacs/TODO diff -u climacs/TODO:1.3 climacs/TODO:1.4 --- climacs/TODO:1.3 Thu Feb 10 01:27:07 2005 +++ climacs/TODO Sun Feb 20 06:11:39 2005 @@ -8,5 +8,3 @@ - handle wrapped lines instead of making McCLIM handle them - replace the use of the scroller pane by custom pane - -- invoke redisplay after resize Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.112 climacs/gui.lisp:1.113 --- climacs/gui.lisp:1.112 Sat Feb 19 07:19:06 2005 +++ climacs/gui.lisp Sun Feb 20 06:11:39 2005 @@ -147,6 +147,10 @@ (declare (ignore frame)) (redisplay-pane pane (eq pane (car (windows *application-frame*))))) +(defmethod handle-repaint :before ((pane extended-pane) region) + (declare (ignore region)) + (redisplay-frame-panes *application-frame*)) + (defun find-gestures (gestures start-table) (loop with table = (find-command-table start-table) for (gesture . rest) on gestures

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp
by rstrandh＠common-lisp.net 19 Feb '05

19 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv12302 Modified Files: base.lisp gui.lisp Log Message: open-line now takes an optional count argument. com-open-line now accepts a numeric argument that it passes on to open-line. Date: Sat Feb 19 07:19:06 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.36 climacs/base.lisp:1.37 --- climacs/base.lisp:1.36 Sat Feb 19 07:09:45 2005 +++ climacs/base.lisp Sat Feb 19 07:19:06 2005 @@ -67,14 +67,16 @@ (beginning-of-line mark) (incf (offset mark) column))) -(defmethod open-line ((mark left-sticky-mark)) +(defmethod open-line ((mark left-sticky-mark) &optional (count 1)) "Create a new line in a buffer after the mark." - (insert-object mark #\Newline)) + (loop repeat count + do (insert-object mark #\Newline))) -(defmethod open-line ((mark right-sticky-mark)) +(defmethod open-line ((mark right-sticky-mark) &optional (count 1)) "Create a new line in a buffer after the mark." - (insert-object mark #\Newline) - (decf (offset mark))) + (loop repeat count + do (insert-object mark #\Newline) + (decf (offset mark)))) (defun kill-line (mark) "Remove a line from a buffer." Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.111 climacs/gui.lisp:1.112 --- climacs/gui.lisp:1.111 Sat Feb 19 07:09:45 2005 +++ climacs/gui.lisp Sat Feb 19 07:19:06 2005 @@ -462,8 +462,8 @@ (setf (slot-value win 'goal-column) (column-number point))) (next-line point (slot-value win 'goal-column) numarg))) -(define-named-command com-open-line () - (open-line (point (current-window)))) +(define-named-command com-open-line ((numarg 'integer :prompt "How many lines?")) + (open-line (point (current-window)) numarg)) (define-named-command com-kill-line ((numarg 'integer :prompt "Kill how many lines?") (numargp 'boolean :prompt "Kill entire lines?")) @@ -1348,7 +1348,7 @@ (global-set-key '(#\p :control) `(com-previous-line ,*numeric-argument-marker*)) (global-set-key '(#\l :control) 'com-full-redisplay) (global-set-key '(#\n :control) `(com-next-line ,*numeric-argument-marker*)) -(global-set-key '(#\o :control) 'com-open-line) +(global-set-key '(#\o :control) `(com-open-line ,*numeric-argument-marker*)) (global-set-key '(#\k :control) `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*)) (global-set-key '(#\t :control) 'com-transpose-objects) (global-set-key '(#\Space :control) 'com-set-mark)

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp
by rstrandh＠common-lisp.net 19 Feb '05

19 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv11536 Modified Files: base.lisp gui.lisp Log Message: next-line and previous-line now take an additional optional argument indicating how many lines to move. com-next-line and com-previous-line now take numeric arguments and pass then on to next-line and previous-line. Date: Sat Feb 19 07:09:45 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.35 climacs/base.lisp:1.36 --- climacs/base.lisp:1.35 Sat Feb 12 16:34:46 2005 +++ climacs/base.lisp Sat Feb 19 07:09:45 2005 @@ -41,31 +41,31 @@ (loop for ,offset from ,offset1 below ,offset2 do ,@body))) -(defun previous-line (mark &optional column) +(defun previous-line (mark &optional column (count 1)) "Move a mark up one line conserving horizontal position." (unless column (setf column (column-number mark))) - (beginning-of-line mark) - (if (beginning-of-buffer-p mark) - (incf (offset mark) column) - (progn (decf (offset mark)) - (when (> (column-number mark) column) - (beginning-of-line mark) - (incf (offset mark) column))))) + (loop repeat count + do (beginning-of-line mark) + until (beginning-of-buffer-p mark) + do (backward-object mark)) + (end-of-line mark) + (when (> (column-number mark) column) + (beginning-of-line mark) + (incf (offset mark) column))) -(defun next-line (mark &optional column) +(defun next-line (mark &optional column (count 1)) "Move a mark down one line conserving horizontal position." (unless column (setf column (column-number mark))) + (loop repeat count + do (end-of-line mark) + until (end-of-buffer-p mark) + do (forward-object mark)) (end-of-line mark) - (if (end-of-buffer-p mark) - (progn (beginning-of-line mark) - (incf (offset mark) column)) - (progn (incf (offset mark)) - (end-of-line mark) - (when (> (column-number mark) column) - (beginning-of-line mark) - (incf (offset mark) column))))) + (when (> (column-number mark) column) + (beginning-of-line mark) + (incf (offset mark) column))) (defmethod open-line ((mark left-sticky-mark)) "Create a new line in a buffer after the mark." Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.110 climacs/gui.lisp:1.111 --- climacs/gui.lisp:1.110 Sat Feb 19 06:45:03 2005 +++ climacs/gui.lisp Sat Feb 19 07:09:45 2005 @@ -446,21 +446,21 @@ (insert-sequence point line) (insert-object point #\Newline)))) -(define-named-command com-previous-line () +(define-named-command com-previous-line ((numarg 'integer :prompt "How many lines?")) (let* ((win (current-window)) (point (point win))) (unless (or (eq (previous-command win) 'com-previous-line) (eq (previous-command win) 'com-next-line)) (setf (slot-value win 'goal-column) (column-number point))) - (previous-line point (slot-value win 'goal-column)))) + (previous-line point (slot-value win 'goal-column) numarg))) -(define-named-command com-next-line () +(define-named-command com-next-line ((numarg 'integer :prompt "How many lines?")) (let* ((win (current-window)) (point (point win))) (unless (or (eq (previous-command win) 'com-previous-line) (eq (previous-command win) 'com-next-line)) (setf (slot-value win 'goal-column) (column-number point))) - (next-line point (slot-value win 'goal-column)))) + (next-line point (slot-value win 'goal-column) numarg))) (define-named-command com-open-line () (open-line (point (current-window)))) @@ -1345,9 +1345,9 @@ (global-set-key '(#\a :control) 'com-beginning-of-line) (global-set-key '(#\e :control) 'com-end-of-line) (global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*)) -(global-set-key '(#\p :control) 'com-previous-line) +(global-set-key '(#\p :control) `(com-previous-line ,*numeric-argument-marker*)) (global-set-key '(#\l :control) 'com-full-redisplay) -(global-set-key '(#\n :control) 'com-next-line) +(global-set-key '(#\n :control) `(com-next-line ,*numeric-argument-marker*)) (global-set-key '(#\o :control) 'com-open-line) (global-set-key '(#\k :control) `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*)) (global-set-key '(#\t :control) 'com-transpose-objects) @@ -1379,8 +1379,8 @@ (global-set-key '(#\r :control) 'com-isearch-mode-backward) (global-set-key '(#\% :shift :meta) 'com-query-replace) -(global-set-key '(:up) 'com-previous-line) -(global-set-key '(:down) 'com-next-line) +(global-set-key '(:up) `(com-previous-line ,*numeric-argument-marker*)) +(global-set-key '(:down) `(com-next-line ,*numeric-argument-marker*)) (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*)) (global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*)) (global-set-key '(:left :control) `(com-backward-word ,*numeric-argument-marker*))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 19 Feb '05

19 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10015 Modified Files: gui.lisp Log Message: Used the new *numeric-argument-p* feature to implement Emacs-like behavior for kill-line. Date: Sat Feb 19 06:45:04 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.109 climacs/gui.lisp:1.110 --- climacs/gui.lisp:1.109 Sat Feb 19 06:23:16 2005 +++ climacs/gui.lisp Sat Feb 19 06:45:03 2005 @@ -465,22 +465,28 @@ (define-named-command com-open-line () (open-line (point (current-window)))) -(define-named-command com-kill-line () +(define-named-command com-kill-line ((numarg 'integer :prompt "Kill how many lines?") + (numargp 'boolean :prompt "Kill entire lines?")) (let* ((pane (current-window)) (point (point pane)) (mark (offset point))) - (cond ((end-of-buffer-p point) nil) - ((end-of-line-p point)(forward-object point)) + (cond ((or numargp (> numarg 1)) + (loop repeat numarg + until (end-of-buffer-p point) + do (end-of-line point) + until (end-of-buffer-p point) + do (forward-object point))) (t - (end-of-line point) - (cond ((beginning-of-buffer-p point) nil) - ((beginning-of-line-p point)(forward-object point))))) - (if (eq (previous-command pane) 'com-kill-line) - (kill-ring-concatenating-push *kill-ring* - (region-to-sequence mark point)) - (kill-ring-standard-push *kill-ring* - (region-to-sequence mark point))) - (delete-region mark point))) + (cond ((end-of-buffer-p point) nil) + ((end-of-line-p point)(forward-object point)) + (t (end-of-line point))))) + (unless (mark= point mark) + (if (eq (previous-command pane) 'com-kill-line) + (kill-ring-concatenating-push *kill-ring* + (region-to-sequence mark point)) + (kill-ring-standard-push *kill-ring* + (region-to-sequence mark point))) + (delete-region mark point)))) (define-named-command com-forward-word ((count 'integer :prompt "Number of words")) (forward-word (point (current-window)) count)) @@ -1343,7 +1349,7 @@ (global-set-key '(#\l :control) 'com-full-redisplay) (global-set-key '(#\n :control) 'com-next-line) (global-set-key '(#\o :control) 'com-open-line) -(global-set-key '(#\k :control) 'com-kill-line) +(global-set-key '(#\k :control) `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*)) (global-set-key '(#\t :control) 'com-transpose-objects) (global-set-key '(#\Space :control) 'com-set-mark) (global-set-key '(#\y :control) 'com-yank)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 19 Feb '05

19 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv9176 Modified Files: gui.lisp Log Message: Implemented flag *numeric-argument-p* to detect whether a numeric argument was given att all. Implemented eval-expression, M-:, which uses numeric-argument-p to dentermine whether to show the result in the minibuffer or to insert it into the buffer itself. Date: Sat Feb 19 06:23:17 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.108 climacs/gui.lisp:1.109 --- climacs/gui.lisp:1.108 Sun Feb 13 03:52:08 2005 +++ climacs/gui.lisp Sat Feb 19 06:23:16 2005 @@ -240,6 +240,11 @@ (find-if (lambda (pane) (typep pane 'scroller-pane)) (sheet-children vbox))))))) +(defvar *numeric-argument-p* (list nil)) + +(defun substitute-numeric-argument-p (command numargp) + (substitute numargp *numeric-argument-p* command :test #'eq)) + (defun climacs-top-level (frame &key command-parser command-unparser partial-command-parser prompt) @@ -254,34 +259,36 @@ (redisplay-frame-panes frame :force-p t) (loop (catch 'outer-loop (loop for gestures = '() - for numarg = (read-numeric-argument :stream *standard-input*) - do (loop (setf *current-gesture* (climacs-read-gesture)) - (setf gestures (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures gestures 'global-climacs-table))) - (cond ((not item) - (beep) (return)) - ((eq (command-menu-item-type item) :command) - (let ((command (command-menu-item-value item))) - (unless (consp command) - (setf command (list command))) - (setf command (substitute-numeric-argument-marker command numarg)) - (handler-case - (execute-frame-command frame command) - (error (condition) - (beep) - (format *error-output* "~a~%" condition))) - (setf (previous-command *standard-output*) - (if (consp command) - (car command) - command)) - (return))) - (t nil)))) - (let ((buffer (buffer (current-window)))) - (when (modified-p buffer) - (setf (needs-saving buffer) t))) - (when (null (remaining-keys *application-frame*)) - (setf (executingp *application-frame*) nil) - (redisplay-frame-panes frame)))) + do (multiple-value-bind (numarg numargp) + (read-numeric-argument :stream *standard-input*) + (loop (setf *current-gesture* (climacs-read-gesture)) + (setf gestures (nconc gestures (list *current-gesture*))) + (let ((item (find-gestures gestures 'global-climacs-table))) + (cond ((not item) + (beep) (return)) + ((eq (command-menu-item-type item) :command) + (let ((command (command-menu-item-value item))) + (unless (consp command) + (setf command (list command))) + (setf command (substitute-numeric-argument-marker command numarg)) + (setf command (substitute-numeric-argument-p command numargp)) + (handler-case + (execute-frame-command frame command) + (error (condition) + (beep) + (format *error-output* "~a~%" condition))) + (setf (previous-command *standard-output*) + (if (consp command) + (car command) + command)) + (return))) + (t nil)))) + (let ((buffer (buffer (current-window)))) + (when (modified-p buffer) + (setf (needs-saving buffer) t))) + (when (null (remaining-keys *application-frame*)) + (setf (executingp *application-frame*) nil) + (redisplay-frame-panes frame))))) (beep) (let ((buffer (buffer (current-window)))) (when (modified-p buffer) @@ -1288,6 +1295,14 @@ (syntax (syntax (buffer pane)))) (display-message "~a" (forward-to-error point syntax)))) +(define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?")) + (let* ((*package* (find-package :climacs-gui)) + (string (accept 'string :prompt "Eval")) + (result (format nil "~a" (eval (read-from-string string))))) + (if insertp + (insert-sequence (point (current-window)) result) + (display-message result)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Global and dead-escape command tables @@ -1317,6 +1332,7 @@ (global-set-key #\Newline 'com-self-insert) (global-set-key #\Tab 'com-indent-line) +(global-set-key '(#\: :shift :meta) `(com-eval-expression ,*numeric-argument-p*)) (global-set-key '(#\j :control) 'com-newline-and-indent) (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*)) (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))

1 0