climacs-cvs

climacs-cvs@common-lisp.net

847 discussions

[climacs-cvs] CVS update: climacs/buffer-test.lisp climacs/buffer.lisp climacs/cl-syntax.lisp
by rstrandh＠common-lisp.net 25 Feb '05

25 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8126 Modified Files: buffer-test.lisp buffer.lisp cl-syntax.lisp Log Message: Changed the contract of clone mark so that the optional argument is either :left or :right forcing the return value to be a left-sticky-mark and a right-sticky-mark respectively. Altered the two calls (in test code) that actually used the optional argument to pass the right thing. Modified the implementation of clone-mark to use constant symbols for the class to instantiate, and made two methods so that the type of the argument will be known statically. Still needed an explicit test for the optional argument, but that is still much faster than using a variable class to make-instance. Date: Fri Feb 25 08:11:25 2005 Author: rstrandh Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.15 climacs/buffer-test.lisp:1.16 --- climacs/buffer-test.lisp:1.15 Thu Feb 10 01:27:07 2005 +++ climacs/buffer-test.lisp Fri Feb 25 08:11:24 2005 @@ -77,8 +77,8 @@ (high (slot-value buffer 'high-mark)) (low2 (clone-mark low)) (high2 (clone-mark high)) - (low3 (clone-mark high %%left-sticky-mark)) - (high3 (clone-mark low %%right-sticky-mark))) + (low3 (clone-mark high :left)) + (high3 (clone-mark low :right))) (and (reduce #'%all-eq (list (class-of low) (class-of low2) (class-of low3))) (reduce #'%all-eq Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.28 climacs/buffer.lisp:1.29 --- climacs/buffer.lisp:1.28 Wed Feb 23 19:15:32 2005 +++ climacs/buffer.lisp Fri Feb 25 08:11:24 2005 @@ -179,14 +179,29 @@ (setf low-mark (make-instance 'standard-left-sticky-mark :buffer buffer)) (setf high-mark (make-instance 'standard-right-sticky-mark :buffer buffer)))) -(defgeneric clone-mark (mark &optional type) - (:documentation "Clone a mark. By default (when type is NIL) the same type of mark is -returned. Otherwise type is the name of a class (subclass of the mark -class) to be used as a class of the clone.")) +(defgeneric clone-mark (mark &optional stick-to) + (:documentation "Clone a mark. By default (when stick-to is NIL) +the same type of mark is returned. Otherwise stick-to is either :left +or :right indicating whether a left-sticky or a right-sticky mark +should be created.")) -(defmethod clone-mark ((mark mark) &optional type) - (make-instance (or type (class-of mark)) - :buffer (buffer mark) :offset (offset mark))) +(defmethod clone-mark ((mark standard-left-sticky-mark) &optional stick-to) + (cond ((or (null stick-to) (eq stick-to :left)) + (make-instance 'standard-left-sticky-mark + :buffer (buffer mark) :offset (offset mark))) + ((eq stick-to :right) + (make-instance 'standard-right-sticky-mark + :buffer (buffer mark) :offset (offset mark))) + (t (error "invalid value for stick-to")))) + +(defmethod clone-mark ((mark standard-right-sticky-mark) &optional stick-to) + (cond ((or (null stick-to) (eq stick-to :right)) + (make-instance 'standard-right-sticky-mark + :buffer (buffer mark) :offset (offset mark))) + ((eq stick-to :left) + (make-instance 'standard-left-sticky-mark + :buffer (buffer mark) :offset (offset mark))) + (t (error "invalid value for stick-to")))) (defgeneric size (buffer) (:documentation "Return the number of objects in the buffer.")) Index: climacs/cl-syntax.lisp diff -u climacs/cl-syntax.lisp:1.1 climacs/cl-syntax.lisp:1.2 --- climacs/cl-syntax.lisp:1.1 Mon Feb 7 16:26:41 2005 +++ climacs/cl-syntax.lisp Fri Feb 25 08:11:24 2005 @@ -171,71 +171,71 @@ (defun next-entry (scan) (let ((start-mark (clone-mark scan))) - (flet ((make-entry (type) - (return-from next-entry - (make-instance type :start-mark start-mark :end-mark (clone-mark scan)))) - (fo () (forward-object scan))) - (loop with object = (object-after scan) - until (end-of-buffer-p scan) - do (case object - (#\( (fo) (make-entry 'list-start-entry)) - (#\) (fo) (make-entry 'list-end-entry)) - (#\; (fo) (make-entry 'comment-entry)) - (#\" (fo) (make-entry 'double-quote-entry)) - (#\' (fo) (make-entry 'quote-entry)) - (#\` (fo) (make-entry 'backquote-entry)) - (#\, (fo) (make-entry 'unquote-entry)) - (#\# (fo) - (loop until (end-of-buffer-p scan) - while (member (object-after scan) - '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) - do (fo)) - (if (end-of-buffer-p scan) - (make-entry 'error-entry) - (case (object-after scan) - (#\# (fo) (make-entry 'label-ref-entry)) - (#\= (fo) (make-entry 'label-entry)) - (#\' (fo) (make-entry 'function-entry)) - (#\| (fo) (make-entry 'balanced-comment-entry)) - (#\+ (fo) (make-entry 'read-time-conditional-plus-entry)) - (#\- (fo) (make-entry 'read-time-conditional-minus-entry)) - (#\( (fo) (make-entry 'vector-entry)) - (#\* (fo) (make-entry 'bitvector-entry)) - (#\: (fo) (make-entry 'uninterned-symbol-entry)) - (#\. (fo) (make-entry 'read-time-evaluation-entry)) - ((#\A #\a) (fo) (make-entry 'array-entry)) - ((#\B #\b) (fo) (make-entry 'binary-entry)) - ((#\C #\c) (fo) (make-entry 'complex-entry)) - ((#\O #\o) (fo) (make-entry 'octal-entry)) - ((#\P #\p) (fo) (make-entry 'pathname-entry)) - ((#\R #\r) (fo) (make-entry 'radix-n-entry)) - ((#\S #\s) (fo) (make-entry 'structure-entry)) - ((#\X #\x) (fo) (make-entry 'hex-entry)) - (#\\ (fo) - (cond ((end-of-buffer-p scan) - (make-entry 'error-entry)) - ((not (constituentp (object-after scan))) - (fo) - (make-entry 'character-entry)) - (t - (fo) - (loop until (end-of-buffer-p scan) - while (constituentp (object-after scan)) - do (fo)) - (make-entry 'character-entry)))) - (t (make-entry 'error-entry))))) - (t (cond ((whitespacep object) - (loop until (end-of-buffer-p scan) - while (whitespacep (object-after scan)) - do (fo)) - (make-entry 'whitespace-entry)) - ((constituentp object) - (loop until (end-of-buffer-p scan) - while (constituentp (object-after scan)) - do (fo)) - (make-entry 'token-entry)) - (t - (fo) (make-entry 'error-entry))))))))) + (flet ((fo () (forward-object scan))) + (macrolet ((make-entry (type) + `(return-from next-entry + (make-instance ,type :start-mark start-mark :end-mark (clone-mark scan))))) + (loop with object = (object-after scan) + until (end-of-buffer-p scan) + do (case object + (#\( (fo) (make-entry 'list-start-entry)) + (#\) (fo) (make-entry 'list-end-entry)) + (#\; (fo) (make-entry 'comment-entry)) + (#\" (fo) (make-entry 'double-quote-entry)) + (#\' (fo) (make-entry 'quote-entry)) + (#\` (fo) (make-entry 'backquote-entry)) + (#\, (fo) (make-entry 'unquote-entry)) + (#\# (fo) + (loop until (end-of-buffer-p scan) + while (member (object-after scan) + '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + do (fo)) + (if (end-of-buffer-p scan) + (make-entry 'error-entry) + (case (object-after scan) + (#\# (fo) (make-entry 'label-ref-entry)) + (#\= (fo) (make-entry 'label-entry)) + (#\' (fo) (make-entry 'function-entry)) + (#\| (fo) (make-entry 'balanced-comment-entry)) + (#\+ (fo) (make-entry 'read-time-conditional-plus-entry)) + (#\- (fo) (make-entry 'read-time-conditional-minus-entry)) + (#\( (fo) (make-entry 'vector-entry)) + (#\* (fo) (make-entry 'bitvector-entry)) + (#\: (fo) (make-entry 'uninterned-symbol-entry)) + (#\. (fo) (make-entry 'read-time-evaluation-entry)) + ((#\A #\a) (fo) (make-entry 'array-entry)) + ((#\B #\b) (fo) (make-entry 'binary-entry)) + ((#\C #\c) (fo) (make-entry 'complex-entry)) + ((#\O #\o) (fo) (make-entry 'octal-entry)) + ((#\P #\p) (fo) (make-entry 'pathname-entry)) + ((#\R #\r) (fo) (make-entry 'radix-n-entry)) + ((#\S #\s) (fo) (make-entry 'structure-entry)) + ((#\X #\x) (fo) (make-entry 'hex-entry)) + (#\\ (fo) + (cond ((end-of-buffer-p scan) + (make-entry 'error-entry)) + ((not (constituentp (object-after scan))) + (fo) + (make-entry 'character-entry)) + (t + (fo) + (loop until (end-of-buffer-p scan) + while (constituentp (object-after scan)) + do (fo)) + (make-entry 'character-entry)))) + (t (make-entry 'error-entry))))) + (t (cond ((whitespacep object) + (loop until (end-of-buffer-p scan) + while (whitespacep (object-after scan)) + do (fo)) + (make-entry 'whitespace-entry)) + ((constituentp object) + (loop until (end-of-buffer-p scan) + while (constituentp (object-after scan)) + do (fo)) + (make-entry 'token-entry)) + (t + (fo) (make-entry 'error-entry)))))))))) (defmethod update-syntax (buffer (syntax cl-syntax)) (let ((low-mark (low-mark buffer))

1 0

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

24 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv28328 Modified Files: gui.lisp Log Message: Many commands now capture their own error situations and give reasonable error messages in the minibuffer. Date: Thu Feb 24 09:30:30 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.123 climacs/gui.lisp:1.124 --- climacs/gui.lisp:1.123 Wed Feb 23 19:15:32 2005 +++ climacs/gui.lisp Thu Feb 24 09:30:28 2005 @@ -603,7 +603,10 @@ (setf (offset point) (offset point-backup))))) (define-command com-extended-command () - (let ((item (accept 'command :prompt "Extended Command"))) + (let ((item (handler-case (accept 'command :prompt "Extended Command") + (error () (progn (beep) + (display-message "No such command") + (return-from com-extended-command nil)))))) (execute-frame-command *application-frame* item))) (eval-when (:compile-toplevel :load-toplevel) @@ -729,12 +732,18 @@ (define-named-command (com-quit) () (loop for buffer in (buffers *application-frame*) when (and (needs-saving buffer) - (accept 'boolean - :prompt (format nil "Save buffer: ~a ?" (name buffer)))) + (handler-case (accept 'boolean + :prompt (format nil "Save buffer: ~a ?" (name buffer))) + (error () (progn (beep) + (display-message "Invalid answer") + (return-from com-quit nil))))) do (save-buffer buffer)) (when (or (notany #'needs-saving (buffers *application-frame*)) - (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")) + (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?") + (error () (progn (beep) + (display-message "Invalid answer") + (return-from com-quit nil))))) (frame-exit *application-frame*))) (define-named-command com-write-buffer () @@ -776,7 +785,10 @@ (with-slots (buffers) *application-frame* (let ((buffer (buffer (current-window)))) (when (and (needs-saving buffer) - (accept 'boolean :prompt "Save buffer first?")) + (handler-case (accept 'boolean :prompt "Save buffer first?") + (error () (progn (beep) + (display-message "Invalid answer") + (return-from com-kill-buffer nil))))) (com-save-buffer)) (setf buffers (remove buffer buffers)) ;; Always need one buffer. @@ -816,14 +828,20 @@ (define-named-command com-goto-position () (setf (offset (point (current-window))) - (accept 'integer :prompt "Goto Position"))) + (handler-case (accept 'integer :prompt "Goto Position") + (error () (progn (beep) + (display-message "Not a valid position") + (return-from com-goto-position nil)))))) (define-named-command com-goto-line () (loop with mark = (make-instance 'standard-right-sticky-mark ;PB :buffer (buffer (current-window))) do (end-of-line mark) until (end-of-buffer-p mark) - repeat (accept 'integer :prompt "Goto Line") + repeat (handler-case (accept 'integer :prompt "Goto Line") + (error () (progn (beep) + (display-message "Not a valid line number") + (return-from com-goto-line nil)))) do (incf (offset mark)) (end-of-line mark) finally (beginning-of-line mark) @@ -846,7 +864,10 @@ (let* ((pane (current-window)) (buffer (buffer pane))) (setf (syntax buffer) - (make-instance (accept 'syntax :prompt "Set Syntax") + (make-instance (or (accept 'syntax :prompt "Set Syntax") + (progn (beep) + (display-message "No such syntax") + (return-from com-set-syntax nil))) :buffer buffer)) (setf (offset (low-mark buffer)) 0 (offset (high-mark buffer)) (size buffer)))) @@ -1021,7 +1042,10 @@ (insert-sequence point (kill-ring-yank *kill-ring*)))) (define-named-command com-resize-kill-ring () - (let ((size (accept 'integer :prompt "New kill ring size"))) + (let ((size (handler-case (accept 'integer :prompt "New kill ring size") + (error () (progn (beep) + (display-message "Not a valid kill ring size") + (return-from com-resize-kill-ring nil)))))) (setf (kill-ring-max-size *kill-ring*) size))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1141,10 +1165,16 @@ (/= (offset mark) offset-before)))) (define-named-command com-query-replace () - (let* ((string1 (accept 'string :prompt "Query replace")) - (string2 (accept 'string - :prompt (format nil "Query replace ~A with" - string1))) + (let* ((string1 (handler-case (accept 'string :prompt "Query replace") + (error () (progn (beep) + (display-message "Empty string") + (return-from com-query-replace nil))))) + (string2 (handler-case (accept 'string + :prompt (format nil "Query replace ~A with" + string1)) + (error () (progn (beep) + (display-message "Empty string") + (return-from com-query-replace nil))))) (pane (current-window)) (point (point pane))) (when (query-replace-find-next-match point string1) @@ -1264,8 +1294,15 @@ (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))))) + (string (handler-case (accept 'string :prompt "Eval") + (error () (progn (beep) + (display-message "Empty string") + (return-from com-eval-expression nil))))) + (result (format nil "~a" + (handler-case (eval (read-from-string string)) + (error (condition) (progn (beep) + (display-message "~a" condition) + (return-from com-eval-expression nil))))))) (if insertp (insert-sequence (point (current-window)) result) (display-message result))))

1 0

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

23 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv13301 Modified Files: buffer.lisp gui.lisp packages.lisp Log Message: Implemented new conditions according to proposal on the devel list. Date: Wed Feb 23 19:15:32 2005 Author: rstrandh Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.27 climacs/buffer.lisp:1.28 --- climacs/buffer.lisp:1.27 Sat Feb 5 21:59:50 2005 +++ climacs/buffer.lisp Wed Feb 23 19:15:32 2005 @@ -81,9 +81,55 @@ (defmethod offset ((mark mark-mixin)) (cursor-pos (cursor mark))) +(define-condition no-such-offset (simple-error) + ((offset :reader condition-offset :initarg :offset)) + (:report (lambda (condition stream) + (format stream "No such offset: ~a" (condition-offset condition)))) + (:documentation "This condition is signaled whenever an attempt is +made to access buffer contents that is before the beginning or after +the end of the buffer.")) + +(define-condition offset-before-beginning (no-such-offset) + () + (:report (lambda (condition stream) + (format stream "Offset before beginning: ~a" (condition-offset condition)))) + (:documentation "This condition is signaled whenever an attempt is +made to access buffer contents that is before the beginning of the buffer.")) + +(define-condition offset-after-end (no-such-offset) + () + (:report (lambda (condition stream) + (format stream "Offset after end: ~a" (condition-offset condition)))) + (:documentation "This condition is signaled whenever an attempt is +made to access buffer contents that is after the end of the buffer.")) + +(define-condition invalid-motion (simple-error) + ((offset :reader condition-offset :initarg :offset)) + (:report (lambda (condition stream) + (format stream "Invalid motion to offset: ~a" (condition-offset condition)))) + (:documentation "This condition is signaled whenever an attempt is +made to move a mark before the beginning or after the end of the +buffer.")) + +(define-condition motion-before-beginning (invalid-motion) + () + (:report (lambda (condition stream) + (format stream "Motion before beginning: ~a" (condition-offset condition)))) + (:documentation "This condition is signaled whenever an attempt is +made to move a mark before the beginning of the buffer.")) + +(define-condition motion-after-end (invalid-motion) + () + (:report (lambda (condition stream) + (format stream "Motion after end: ~a" (condition-offset condition)))) + (:documentation "This condition is signaled whenever an attempt is +made to move a mark after the end of the buffer.")) + (defmethod (setf offset) (new-offset (mark mark-mixin)) - (assert (<= 0 new-offset (size (buffer mark))) () - (make-condition 'no-such-offset :offset new-offset)) + (assert (<= 0 new-offset) () + (make-condition 'motion-before-beginning :offset new-offset)) + (assert (<= new-offset (size (buffer mark))) () + (make-condition 'motion-after-end :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset)) (defgeneric backward-object (mark &optional count)) @@ -105,8 +151,10 @@ (defmethod initialize-instance :after ((mark standard-left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args)) - (assert (<= 0 offset (size (buffer mark))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'motion-before-beginning :offset offset)) + (assert (<= offset (size (buffer mark))) () + (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'left-sticky-flexicursor :chain (slot-value (buffer mark) 'contents) @@ -115,8 +163,10 @@ (defmethod initialize-instance :after ((mark standard-right-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args)) - (assert (<= 0 offset (size (buffer mark))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'motion-before-beginning :offset offset)) + (assert (<= offset (size (buffer mark))) () + (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'right-sticky-flexicursor :chain (slot-value (buffer mark) 'contents) @@ -138,13 +188,6 @@ (make-instance (or type (class-of mark)) :buffer (buffer mark) :offset (offset mark))) -(define-condition no-such-offset (simple-error) - ((offset :reader condition-offset :initarg :offset)) - (:report (lambda (condition stream) - (format stream "No such offset: ~a" (condition-offset condition)))) - (:documentation "This condition is signaled whenever an attempt is made at an operation -that is before the beginning or after the end of the buffer.")) - (defgeneric size (buffer) (:documentation "Return the number of objects in the buffer.")) @@ -348,8 +391,10 @@ offset will be positioned after the inserted object.")) (defmethod insert-buffer-object ((buffer standard-buffer) offset object) - (assert (<= 0 offset (size buffer)) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) (insert* (slot-value buffer 'contents) offset object)) (defgeneric insert-buffer-sequence (buffer offset sequence) @@ -380,8 +425,10 @@ no-such-offset condition is signaled.")) (defmethod delete-buffer-range ((buffer standard-buffer) offset n) - (assert (<= 0 offset (size buffer)) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) (loop repeat n do (delete* (slot-value buffer 'contents) offset))) @@ -427,8 +474,10 @@ the size of the buffer, a no-such-offset condition is signaled.")) (defmethod buffer-object ((buffer standard-buffer) offset) - (assert (<= 0 offset (1- (size buffer))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (1- (size buffer))) () + (make-condition 'offset-after-end :offset offset)) (element* (slot-value buffer 'contents) offset)) (defgeneric (setf buffer-object) (object buffer offset) @@ -437,8 +486,10 @@ the size of the buffer, a no-such-offset condition is signaled.")) (defmethod (setf buffer-object) (object (buffer standard-buffer) offset) - (assert (<= 0 offset (1- (size buffer))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (1- (size buffer))) () + (make-condition 'offset-after-end :offset offset)) (setf (element* (slot-value buffer 'contents) offset) object)) (defgeneric buffer-sequence (buffer offset1 offset2) @@ -449,10 +500,14 @@ offset1, an empty sequence will be returned.")) (defmethod buffer-sequence ((buffer standard-buffer) offset1 offset2) - (assert (<= 0 offset1 (size buffer)) () - (make-condition 'no-such-offset :offset offset1)) - (assert (<= 0 offset2 (size buffer)) () - (make-condition 'no-such-offset :offset offset2)) + (assert (<= 0 offset1) () + (make-condition 'offset-before-beginning :offset offset1)) + (assert (<= offset1 (size buffer)) () + (make-condition 'offset-after-end :offset offset1)) + (assert (<= 0 offset2) () + (make-condition 'offset-before-beginning :offset offset2)) + (assert (<= offset2 (size buffer)) () + (make-condition 'offset-after-end :offset offset2)) (if (< offset1 offset2) (loop with result = (make-array (- offset2 offset1)) for offset from offset1 below offset2 Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.122 climacs/gui.lisp:1.123 --- climacs/gui.lisp:1.122 Wed Feb 23 07:13:09 2005 +++ climacs/gui.lisp Wed Feb 23 19:15:32 2005 @@ -263,9 +263,14 @@ (flet ((do-command (command) (handler-case (execute-frame-command frame command) - (error (condition) - (beep) - (format *error-output* "~a~%" condition))) + (offset-before-beginning () + (beep) (display-message "Beginning of buffer")) + (offset-after-end () + (beep) (display-message "End of buffer")) + (motion-before-beginning () + (beep) (display-message "Beginning of buffer")) + (motion-after-end () + (beep) (display-message "End of buffer"))) (setf (previous-command *standard-output*) (if (consp command) (car command) @@ -314,8 +319,7 @@ (defmacro simple-command-loop (command-table loop-condition end-clauses) (let ((gesture (gensym)) (item (gensym)) - (command (gensym)) - (condition (gensym))) + (command (gensym))) `(progn (redisplay-frame-panes *application-frame*) (loop while ,loop-condition @@ -329,9 +333,14 @@ (handler-case (execute-frame-command *application-frame* ,command) - (error (,condition) - (beep) - (format *error-output* "~a~%" ,condition))))) + (offset-before-beginning () + (beep) (display-message "Beginning of buffer")) + (offset-after-end () + (beep) (display-message "End of buffer")) + (motion-before-beginning () + (beep) (display-message "Beginning of buffer")) + (motion-after-end () + (beep) (display-message "End of buffer"))))) (t (unread-gesture ,gesture) ,@end-clauses)) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.49 climacs/packages.lisp:1.50 --- climacs/packages.lisp:1.49 Sat Feb 12 16:34:46 2005 +++ climacs/packages.lisp Wed Feb 23 19:15:32 2005 @@ -27,7 +27,10 @@ (:export #:buffer #:standard-buffer #:mark #:left-sticky-mark #:right-sticky-mark #:standard-left-sticky-mark #:standard-right-sticky-mark - #:clone-mark #:no-such-offset #:size #:number-of-lines + #:clone-mark + #:no-such-offset #:offset-before-beginning #:offset-after-end + #:invalid-motion #:motion-before-beginning #:motion-after-end + #:size #:number-of-lines #:offset #:mark< #:mark<= #:mark= #:mark> #:mark>= #:forward-object #:backward-object #:beginning-of-buffer #:end-of-buffer

1 0

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

23 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5057 Modified Files: gui.lisp Log Message: Fixed a problem introduced by a recent change to the command loop, where the numeric argument flag was not replaced in commands. Date: Wed Feb 23 07:13:09 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.121 climacs/gui.lisp:1.122 --- climacs/gui.lisp:1.121 Tue Feb 22 12:01:38 2005 +++ climacs/gui.lisp Wed Feb 23 07:13:09 2005 @@ -285,20 +285,22 @@ (object) (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)) - (do-command command) - (return))) - (t nil)))) + 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)) + (do-command command) + (return))) + (t nil))))) (update-climacs)) (t (do-command object)

1 0

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

22 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6793 Modified Files: gui.lisp Log Message: Implement, basically from Tim Moore, a command input context for the climacs top level. (This allows presentation-to-command translators to be clickable) Date: Tue Feb 22 12:01:42 2005 Author: crhodes Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.120 climacs/gui.lisp:1.121 --- climacs/gui.lisp:1.120 Tue Feb 22 09:29:03 2005 +++ climacs/gui.lisp Tue Feb 22 12:01:38 2005 @@ -249,57 +249,65 @@ (substitute numargp *numeric-argument-p* command :test #'eq)) (defun climacs-top-level (frame &key - command-parser command-unparser - partial-command-parser prompt) + command-parser command-unparser + partial-command-parser prompt) (declare (ignore command-parser command-unparser partial-command-parser prompt)) (with-slots (windows) frame - (setf windows (list (find-climacs-pane (find-pane-named frame 'win)))) - (push (buffer (car windows)) (buffers frame)) - (let ((*standard-output* (car windows)) - (*standard-input* (find-pane-named frame 'int)) - (*print-pretty* nil) - (*abort-gestures* '((:keyboard #\g 512)))) - (redisplay-frame-panes frame :force-p t) - (loop (handler-case - (loop for gestures = '() - 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)))) - (abort-gesture () (display-message "Quit"))) - (beep) - (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)))))) + (setf windows (list (find-climacs-pane (find-pane-named frame 'win)))) + (push (buffer (car windows)) (buffers frame)) + (let ((*standard-output* (car windows)) + (*standard-input* (find-pane-named frame 'int)) + (*print-pretty* nil) + (*abort-gestures* '((:keyboard #\g 512)))) + (redisplay-frame-panes frame :force-p t) + (flet ((do-command (command) + (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))) + (update-climacs () + (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)))) + (loop + for maybe-error = t + do (handler-case + (with-input-context ('(command + :command-table 'global-climacs-table)) + (object) + (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)) + (do-command command) + (return))) + (t nil)))) + (update-climacs)) + (t + (do-command object) + (setq maybe-error nil))) + (abort-gesture () + (display-message "Quit"))) + (when maybe-error + (beep)) + (update-climacs)))))) (defmacro simple-command-loop (command-table loop-condition end-clauses) (let ((gesture (gensym))

1 0

[climacs-cvs] CVS update: climacs/README
by crhodes＠common-lisp.net 22 Feb '05

22 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6633 Modified Files: README Log Message: Minor textual changes. More major ones are probably necessary. Date: Tue Feb 22 12:00:34 2005 Author: crhodes Index: climacs/README diff -u climacs/README:1.1 climacs/README:1.2 --- climacs/README:1.1 Wed Dec 22 15:43:18 2004 +++ climacs/README Tue Feb 22 12:00:33 2005 @@ -28,7 +28,10 @@ How to contribute ----------------- -[fill this in when we have a cl.net project] +Discussion happens on the mailing lists accessible from +<URL:http://common-lisp.net/project/climacs/>; arcives are likewise +accessible. Contributions to make the framework and the editor a +nicer environment are actively sought. What to work on --------------- @@ -64,4 +67,4 @@ Installation ------------ -To install Climacs, se the INSTALL file. +To install Climacs, see the INSTALL file.

1 0

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

22 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv30769 Modified Files: gui.lisp Log Message: Give the user a message after C-g. Date: Tue Feb 22 09:29:03 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.119 climacs/gui.lisp:1.120 --- climacs/gui.lisp:1.119 Tue Feb 22 08:29:08 2005 +++ climacs/gui.lisp Tue Feb 22 09:29:03 2005 @@ -292,7 +292,7 @@ (when (null (remaining-keys *application-frame*)) (setf (executingp *application-frame*) nil) (redisplay-frame-panes frame)))) - (abort-gesture () nil)) + (abort-gesture () (display-message "Quit"))) (beep) (let ((buffer (buffer (current-window)))) (when (modified-p buffer)

1 0

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

22 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv27192 Modified Files: gui.lisp Log Message: C-g now aborts extended commands. Date: Tue Feb 22 08:29:09 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.118 climacs/gui.lisp:1.119 --- climacs/gui.lisp:1.118 Mon Feb 21 13:51:55 2005 +++ climacs/gui.lisp Tue Feb 22 08:29:08 2005 @@ -176,8 +176,6 @@ (return-from climacs-read-gesture (pop (remaining-keys *application-frame*)))) (loop for gesture = (read-gesture :stream *standard-input*) - when (event-matches-gesture-name-p gesture '(:keyboard #\g 512)) ; FIXME - do (throw 'outer-loop nil) until (or (characterp gesture) (and (typep gesture 'keyboard-event) (or (keyboard-event-character gesture) @@ -260,40 +258,41 @@ (let ((*standard-output* (car windows)) (*standard-input* (find-pane-named frame 'int)) (*print-pretty* nil) - (*abort-gestures* nil)) + (*abort-gestures* '((:keyboard #\g 512)))) (redisplay-frame-panes frame :force-p t) - (loop (catch 'outer-loop - (loop for gestures = '() - 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))))) + (loop (handler-case + (loop for gestures = '() + 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)))) + (abort-gesture () nil)) (beep) (let ((buffer (buffer (current-window)))) (when (modified-p buffer)

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

← Newer
1
...
63
64
65
66
67
68
69
...
85
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

climacs-cvs