From dlichteblau at common-lisp.net Sat Dec 1 12:59:51 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sat, 1 Dec 2007 07:59:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Lisp-Dep Message-ID: <20071201125951.442A74F01C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory clnet:/tmp/cvs-serv5990 Modified Files: fix-sbcl.lisp Log Message: Read fix-sbcl.lisp into CL-USER so that its fasl does not look for user packages at load time (which might not exist anymore). --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/fix-sbcl.lisp 2005/09/22 11:40:29 1.10 +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/fix-sbcl.lisp 2007/12/01 12:59:51 1.11 @@ -1,3 +1,5 @@ +(in-package :cl-user) + (eval-when (:compile-toplevel :execute) (when (find-package "SB-MOP") (pushnew :sb-mop *features*))) From thenriksen at common-lisp.net Sat Dec 8 08:53:48 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 8 Dec 2007 03:53:48 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20071208085348.D20EC5C16F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv13736/ESA Modified Files: utils.lisp packages.lisp esa.lisp esa-buffer.lisp Log Message: Changed Drei to use a view-based paradigm, didn't make any significant changes to ESA just yet. --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2007/08/13 21:56:04 1.3 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2007/12/08 08:53:48 1.4 @@ -18,7 +18,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; Miscellaneous utilities used in Climacs. +;;; Miscellaneous utilities used in ESA. (in-package :esa-utils) @@ -212,3 +212,99 @@ specifiers." (some (lambda (x) (subtypep x `(and , at types))) types)) + +(defclass observable-mixin () + ((%observers :accessor observers + :initform '())) + (:documentation "A mixin class that adds the capability for a +subclass to have a list of \"event subscribers\" (observers) that +can be informed via callback (the function `observer-notified') +whenever the state of the object changes. The order in which +observers will be notified is undefined.")) + +(defgeneric add-observer (observable observer) + (:documentation "Add an observer to an observable object. If +the observer is already observing `observable', it will not be +added again.")) + +(defmethod add-observer ((observable observable-mixin) observer) + ;; Linear in complexity, perhaps a transparent switch to a hash + ;; table would be a good idea for large amounts of observers. + (pushnew observer (observers observable))) + +(defgeneric remove-observer (observable observer) + (:documentation "Remove an observer from an observable +object. If observer is not in the list of observers of +`observable', nothing will happen.")) + +(defmethod remove-observer ((observable observable-mixin) observer) + (setf (observers observable) + (delete observer (observers observable)))) + +(defgeneric observer-notified (observer observable data) + (:documentation "This function is called by `observable' when +its state changes on each observer that is observing +it. `Observer' is the observing object, `observable' is the +observed object. `Data' is arbitrary data that might be of +interest to `observer', it is recommended that subclasses of +`observable-mixin' specify exactly which form this data will +take, the observer protocol does not guarantee anything. It is +non-&optional so that methods may be specialised on it, if +applicable. The default method on this function is a no-op, so it +is never an error to not define a method on this generic function +for an observer.") + (:method (observer (observable observable-mixin) data) + ;; Never a no-applicable-method error. + nil)) + +(defgeneric notify-observers (observable &optional data-fn) + (:documentation "Notify each observer of `observable' by +calling `observer-notified' on them. `Data-fn' will be called, +with the observer as the single argument, to obtain the `data' +argument to `observer-notified'. The default value of `data-fn' +should cause the `data' argument to be NIL.")) + +(defmethod notify-observers ((observable observable-mixin) + &optional (data-fn (constantly nil))) + (dolist (observer (observers observable)) + (observer-notified observer observable + (funcall data-fn observer)))) + +(defclass name-mixin () + ((%name :accessor name + :initarg :name + :type string + :documentation "The name of the named object.")) + (:documentation "A class used for defining named objects.")) + +(defclass subscriptable-name-mixin (name-mixin) + ((%subscript :accessor subscript + :documentation "The subscript of the named object.") + (%subscript-generator :accessor subscript-generator + :initarg :subscript-generator + :initform (constantly 1) + :documentation "A function used for +finding the subscript of a `name-mixin' whenever the name is +set (including during object initialization). This function will +be called with the name as the single argument.")) + (:documentation "A class used for defining named objects. A +facility is provided for assigning a named object a \"subscript\" +uniquely identifying the object if there are other objects of the +same name in its collection (in particular, if an editor has two +buffers with the same name).")) + +(defmethod initialize-instance :after ((name-mixin subscriptable-name-mixin) + &rest initargs) + (declare (ignore initargs)) + (setf (subscript name-mixin) + (funcall (subscript-generator name-mixin) (name name-mixin)))) + +(defmethod subscripted-name ((name-mixin subscriptable-name-mixin)) + ;; Perhaps this could be written as a single format statement? + (if (/= (subscript name-mixin) 1) + (format nil "~A <~D>" (name name-mixin) (subscript name-mixin)) + (name name-mixin))) + +(defmethod (setf name) :after (new-name (name-mixin subscriptable-name-mixin)) + (setf (subscript name-mixin) + (funcall (subscript-generator name-mixin) new-name))) --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2007/11/19 20:34:10 1.5 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2007/12/08 08:53:48 1.6 @@ -41,7 +41,12 @@ #:invoke-with-dynamic-bindings-1 #:invoke-with-dynamic-bindings #:maptree - #:subtype-compatible-p)) + #:subtype-compatible-p + #:observable-mixin + #:add-observer #:remove-observer + #:observer-notified #:notify-observers + #:name-mixin #:name + #:subscriptable-name-mixin #:subscripted-name #:subscript #:subscript-generator)) (defpackage :esa (:use :clim-lisp :clim :esa-utils) --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/11/19 20:28:43 1.11 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/12/08 08:53:48 1.12 @@ -41,10 +41,18 @@ (defgeneric esa-current-buffer (esa) (:documentation "Return the current buffer of APPLICATION-FRAME.")) +(defgeneric (setf esa-current-buffer) (new-buffer esa) + (:documentation "Replace the current buffer of +APPLICATION-FRAME with NEW-BUFFER.")) + (defun current-buffer () "Return the currently active buffer of the running ESA." (esa-current-buffer *esa-instance*)) +(defun (setf current-buffer) (new-buffer) + "Return the currently active buffer of the running ESA." + (setf (esa-current-buffer *esa-instance*) new-buffer)) + (defgeneric windows (esa) (:documentation "Return a list of all the windows of the ESA.") (:method ((esa application-frame)) --- /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp 2007/11/13 13:05:38 1.2 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp 2007/12/08 08:53:48 1.3 @@ -45,10 +45,10 @@ representation" (frame-save-buffer-to-stream *application-frame* buffer stream)) -(defclass esa-buffer-mixin () +(defclass esa-buffer-mixin (name-mixin) ((%filepath :initform nil :accessor filepath) - (%name :initarg :name :initform "*scratch*" :accessor name) (%needs-saving :initform nil :accessor needs-saving) (%file-write-time :initform nil :accessor file-write-time) (%file-saved-p :initform nil :accessor file-saved-p) - (%read-only-p :initform nil :accessor read-only-p))) + (%read-only-p :initform nil :accessor read-only-p)) + (:default-initargs :name "*scratch*")) From thenriksen at common-lisp.net Sat Dec 8 08:53:49 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 8 Dec 2007 03:53:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Persistent Message-ID: <20071208085349.C3EE9620CD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Persistent In directory clnet:/tmp/cvs-serv13736/Drei/Persistent Modified Files: persistent-buffer.lisp Log Message: Changed Drei to use a view-based paradigm, didn't make any significant changes to ESA just yet. --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-buffer.lisp 2006/11/08 01:15:32 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-buffer.lisp 2007/12/08 08:53:49 1.2 @@ -62,10 +62,7 @@ (setf (slot-value cursor 'pos) position)) (defclass persistent-buffer (buffer) - ((low-mark :reader low-mark) - (high-mark :reader high-mark) - (cursors :accessor cursors :initform nil) - (modified :initform nil :reader modified-p)) + ((cursors :accessor cursors :initform nil)) (:documentation "The Climacs persistent buffer base class \(non-instantiable).")) @@ -196,31 +193,6 @@ :buffer (buffer mark) :position offset))) -(defmethod initialize-instance :after ((buffer binseq-buffer) &rest args) - "Create the low-mark and high-mark." - (declare (ignorable args)) - (with-slots (low-mark high-mark) buffer - (setf low-mark (make-instance 'persistent-left-sticky-mark :buffer buffer)) - (setf high-mark (make-instance 'persistent-right-sticky-mark - :buffer buffer)))) - -(defmethod initialize-instance :after ((buffer obinseq-buffer) &rest args) - "Create the low-mark and high-mark." - (declare (ignorable args)) - (with-slots (low-mark high-mark) buffer - (setf low-mark (make-instance 'persistent-left-sticky-mark :buffer buffer)) - (setf high-mark (make-instance 'persistent-right-sticky-mark - :buffer buffer)))) - -(defmethod initialize-instance :after ((buffer binseq2-buffer) &rest args) - "Create the low-mark and high-mark." - (declare (ignorable args)) - (with-slots (low-mark high-mark) buffer - (setf low-mark - (make-instance 'persistent-left-sticky-line-mark :buffer buffer)) - (setf high-mark - (make-instance 'persistent-right-sticky-line-mark :buffer buffer)))) - (defmethod clone-mark ((mark persistent-left-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) @@ -436,7 +408,7 @@ (assert (<= 0 offset) () (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () - (make-condition 'offset-after-end :offset offset)) + (make-condition 'offset-after-end :offset offset)) (setf (slot-value buffer 'contents) (binseq2-insert2 (slot-value buffer 'contents) offset object))) @@ -478,6 +450,8 @@ (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) + (assert (<= (+ offset n) (size buffer)) () + (make-condition 'offset-after-end :offset (+ offset n))) (setf (slot-value buffer 'contents) (binseq-remove* (slot-value buffer 'contents) offset n))) @@ -486,6 +460,8 @@ (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) + (assert (<= (+ offset n) (size buffer)) () + (make-condition 'offset-after-end :offset (+ offset n))) (setf (slot-value buffer 'contents) (obinseq-remove* (slot-value buffer 'contents) offset n))) @@ -494,6 +470,8 @@ (make-condition 'offset-before-beginning :offset offset)) (assert (<= offset (size buffer)) () (make-condition 'offset-after-end :offset offset)) + (assert (<= (+ offset n) (size buffer)) () + (make-condition 'offset-after-end :offset (+ offset n))) (setf (slot-value buffer 'contents) (binseq2-remove*2 (slot-value buffer 'contents) offset n))) @@ -639,48 +617,6 @@ (rotatef offset1 offset2)) (buffer-sequence (buffer mark1) offset1 offset2))) -;;; Buffer modification protocol - -(defmethod (setf buffer-object) - :before (object (buffer persistent-buffer) offset) - (declare (ignore object)) - (setf (offset (low-mark buffer)) - (min (offset (low-mark buffer)) offset)) - (setf (offset (high-mark buffer)) - (max (offset (high-mark buffer)) offset)) - (setf (slot-value buffer 'modified) t)) - -(defmethod insert-buffer-object - :before ((buffer persistent-buffer) offset object) - (declare (ignore object)) - (setf (offset (low-mark buffer)) - (min (offset (low-mark buffer)) offset)) - (setf (offset (high-mark buffer)) - (max (offset (high-mark buffer)) offset)) - (setf (slot-value buffer 'modified) t)) - -(defmethod insert-buffer-sequence - :before ((buffer persistent-buffer) offset sequence) - (declare (ignore sequence)) - (setf (offset (low-mark buffer)) - (min (offset (low-mark buffer)) offset)) - (setf (offset (high-mark buffer)) - (max (offset (high-mark buffer)) offset)) - (setf (slot-value buffer 'modified) t)) - -(defmethod delete-buffer-range - :before ((buffer persistent-buffer) offset n) - (setf (offset (low-mark buffer)) - (min (offset (low-mark buffer)) offset)) - (setf (offset (high-mark buffer)) - (max (offset (high-mark buffer)) (+ offset n))) - (setf (slot-value buffer 'modified) t)) - -(defmethod clear-modify ((buffer persistent-buffer)) - (beginning-of-buffer (high-mark buffer)) - (end-of-buffer (low-mark buffer)) - (setf (slot-value buffer 'modified) nil)) - (defmacro filter-and-update (l filter-fn update-fn) (let ((prev (gensym)) (curr (gensym)) @@ -731,3 +667,10 @@ (defmethod delete-buffer-range :after ((buffer persistent-buffer) offset n) (adjust-cursors-on-delete buffer offset n)) + +(defmethod make-buffer-mark ((buffer persistent-buffer) + &optional (offset 0) (stick-to :left)) + (make-instance (ecase stick-to + (:left 'persistent-left-sticky-mark) + (:right 'persistent-right-sticky-mark)) + :offset offset :buffer buffer)) From thenriksen at common-lisp.net Sat Dec 8 08:53:59 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 8 Dec 2007 03:53:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20071208085359.EAB8E2B144@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv13736/Doc Modified Files: drei.texi Log Message: Changed Drei to use a view-based paradigm, didn't make any significant changes to ESA just yet. --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2007/11/19 20:38:10 1.9 +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2007/12/08 08:53:58 1.10 @@ -42,23 +42,25 @@ We call a specific instance of the Drei editor substrate a @i{Drei instance}. A @i{Drei variant} is a specific subclass of @class{drei} that implements a specific kind of editor, such as an input-editor or a -gadget. A given Drei instance has a single buffer associated with it, -but this buffer need not be unique to the Drei instance, and may be -changed at any time. The Drei instance has two marks into the buffer, -called the @i{top} and @i{bottom} mark. These marks delimit the visible -region of the buffer - for some Drei variants, this is always the entire -buffer, while others may only have a smaller visible region. Note that -not all of the visible region necessarily is on display on the screen -(parts, or all, of it may be hidden due to scrolling, for example), but -nothing outside the visible region is on display, though remember that -the same buffer may be used in several Drei instances, and that each of -these instances may have their own idea about what the visible region -is. The Drei instance also maintains marks for the current @i{point} and - at i{mark}. This means that different Drei instances sharing the same -buffer may have different points and marks. Every Drei instance also has -a @i{kill ring} object which contains object sequences that have been -killed from the buffer, and can be yanked back in at the users -behest. These are generally not shared. +gadget. A given Drei instance has a single view associated with it, this +view must be unique to the Drei instance (though this is not enforced), +but may be changed at any time. The most typical view is one that has a +buffer and maintains syntax information about the buffer contents. A +buffer need not be unique to a buffer-view, and may be changed at any +time. The view instance has two marks into the buffer, called the + at i{top} and @i{bottom} mark. These marks delimit the visible region of +the buffer - for some Drei variants, this is always the entire buffer, +while others may only have a smaller visible region. Note that not all +of the visible region necessarily is on display on the screen (parts, or +all, of it may be hidden due to scrolling, for example), but nothing +outside the visible region is on display, though remember that the same +buffer may be used in several vires, and that each of these views may +have their own idea about what the visible region is. Most views also +maintain marks for the current @i{point} and @i{mark}. This means that +different views sharing the same buffer may have different points and +marks. Every Drei instance also has a @i{kill ring} object which +contains object sequences that have been killed from the buffer, and can +be yanked back in at the users behest. These are generally not shared. Every Drei instance is associated with an editor pane - this must be a CLIM stream pane that is used for redisplay (@pxref{Redisplay @@ -100,6 +102,7 @@ all parts of the Drei state, but for convenience, a number of utility functions providing access to commonly used objects have been defined. + at include fun-drei-current-view.texi @include fun-esa-current-buffer.texi @include fun-drei-point.texi @include fun-drei-mark.texi @@ -174,11 +177,11 @@ large sequence of objects, most of which are expected to be characters (the full Unicode character set is supported). However, Drei buffers can contain any Common Lisp objects, as long as the -syntax module knows how to render them. +redisplay engine knows how to render them. -The Drei buffer implementation differs from that of a vector, -because it allows for very efficient editing operations, such as -inserting and removing objects at arbitrary offsets. +The Drei buffer implementation differs from that of a vector, because it +allows for very efficient editing operations, such as inserting and +removing objects at arbitrary offsets. In addition, the Drei buffer protocols defines that concept of a mark. @@ -352,36 +355,15 @@ @node Buffer Modification Protocol @subsection Buffer Modification Protocol -The buffer maintains two marks, the low mark and the high mark: - - at include fun-drei-buffer-low-mark.texi - - at include fun-drei-buffer-high-mark.texi - -The low mark is a left-sticky mark and high mark is a right-sticky -mark. Whenever a modification is made to the buffer, the offset of -the low mark is set to the minimum of its current value and the -position of the modification. Similarly, whenever a modification is -made to the buffer, the offset of the high mark is set to the maximum -of its current value and the position of the modification. - -The redisplay module may use these values to determine what part of -the screen needs to be updated. These values can also be used to -update information about syntax highlighting and other cached -information. - -In addition to these marks, the buffer maintains a modification flag -that determines. Whether the buffer has been modified since the last -call to clear-modify. - - at include fun-drei-buffer-modified-p.texi - - at include fun-drei-buffer-clear-modify.texi - -This function is used by the redisplay module after all of the panes -on display have been redisplayed properly. A call to this function -concludes the interaction loop and Drei is again ready to read and -execute commands. +The buffer modification protocol is based on the ESA observer/observable +facility, which is in return a fairly ordinary Model-View +implementation. + + at include class-drei-buffer-observable-buffer-mixin.texi + +Syntax-views use this information to determine what part of the buffer +needs to be reparsed. This automatically happens whenever a request is +made for information that might depend on outdated parsing data. @node DREI-BASE Package @subsection DREI-BASE Package From thenriksen at common-lisp.net Sat Dec 8 08:54:00 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 8 Dec 2007 03:54:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071208085400.E6FC574343@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv13736 Modified Files: mcclim.asd Log Message: Changed Drei to use a view-based paradigm, didn't make any significant changes to ESA just yet. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/11/16 09:28:47 1.62 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/08 08:53:59 1.63 @@ -284,19 +284,20 @@ (:file "editing" :depends-on ("packages" "buffer" "syntax" "motion" "kill-ring")) (:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring")) (:file "syntax" :depends-on ("packages" "buffer" "base")) - (:file "drei" :depends-on ("packages" "syntax" "buffer" "base" - "persistent-undo" "persistent-buffer" "abbrev" - "delegating-buffer" "undo" "motion" "editing")) + (:file "views" :depends-on ("packages" "buffer" "base" "syntax" "persistent-undo" + "persistent-buffer" "undo" "abbrev" + "delegating-buffer")) + (:file "drei" :depends-on ("packages" "views" "motion" "editing")) (:file "drei-clim" :depends-on ("drei")) (:file "drei-redisplay" :depends-on ("drei-clim")) (:file "input-editor" :depends-on ("drei-redisplay" "lisp-syntax" "core")) - (:file "fundamental-syntax" :depends-on ("packages" "drei-redisplay")) (:file "abbrev" :depends-on ("packages")) (:file "kill-ring" :depends-on ("packages")) (:file "undo" :depends-on ("packages")) (:file "delegating-buffer" :depends-on ("packages" "buffer")) (:file "basic-commands" :depends-on ("drei-clim" "motion" "editing")) (:file "core" :depends-on ("drei")) + (:file "fundamental-syntax" :depends-on ("packages" "drei-redisplay" "core")) (:file "buffer-streams" :depends-on ("core")) (:file "rectangle" :depends-on ("core")) (:file "targets" :depends-on ("core")) From thenriksen at common-lisp.net Sat Dec 8 11:18:20 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 8 Dec 2007 06:18:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20071208111820.CBAE0761AC@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv8610/Apps/Inspector Modified Files: inspector.lisp Log Message: Make clouseau:inspector return the inspected object, for easier debugging. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2007/02/08 05:47:46 1.35 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2007/12/08 11:18:20 1.36 @@ -71,7 +71,8 @@ (clim-sys:make-process #'run :name (format nil "Inspector Clouseau: ~S" obj)) - (run)))) + (run)) + obj)) (defparameter *inspected-objects* '() "A list of objects which are currently being inspected with From ahefner at common-lisp.net Sat Dec 8 23:25:23 2007 From: ahefner at common-lisp.net (ahefner) Date: Sat, 8 Dec 2007 18:25:23 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071208232523.BFCB870E1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26248 Modified Files: core-commands.lisp core.lisp lisp-syntax-commands.lisp packages.lisp Log Message: Fix insert-pair, add move-past-close-and-reindent, bind M-), C-M-Delete, and C-M-Backspace as expected. --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/12/08 08:53:50 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/12/08 23:25:23 1.8 @@ -611,9 +611,7 @@ (wrap-p 'boolean :prompt "Wrap expressions?")) "Insert a pair of parentheses, leaving point in between. With a numeric argument, enclose that many expressions -forward (backward if negative). - -FIXME: no it doesn't." +forward (backward if negative)." (unless wrap-p (setf count 0)) (insert-parentheses (point) (current-syntax) count)) @@ -626,6 +624,15 @@ (setf (region-visible-p *drei-instance*) (not (region-visible-p *drei-instance*)))) +(define-command (com-move-past-close-and-reindent :name t :command-table editing-table) + () + "Move past the next `)' and reindent" + (move-past-close-and-reindent (current-view) (point))) + +(set-key `(com-move-past-close-and-reindent) + 'editing-table + '((#\) :meta))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Rectangle editing --- /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/12/08 08:53:50 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/12/08 23:25:23 1.9 @@ -81,16 +81,27 @@ (setf count (- count)) (loop repeat count do (backward-expression mark syntax)))) (unless (or (beginning-of-buffer-p mark) - (whitespacep syntax (object-before mark))) + (char= open (object-before mark)) + (whitespacep syntax (object-before mark))) (insert-object mark #\Space)) (insert-object mark open) - (let ((here (clone-mark mark))) + (let ((saved-offset (offset mark))) (loop repeat count - do (forward-expression here syntax)) - (insert-object here close) - (unless (or (end-of-buffer-p here) - (whitespacep syntax (object-after here))) - (insert-object here #\Space)))) + do (forward-expression mark syntax)) + (insert-object mark close) + + (unless (or (end-of-buffer-p mark) + (char= close (object-after mark)) + (whitespacep syntax + (object-after mark))) + (insert-object mark #\Space)) + (setf (offset mark) saved-offset))) + +(defun move-past-close-and-reindent (view point) + (loop until (eql (object-after point) #\)) + do (forward-object point)) + (forward-object point) + (indent-current-line view point)) (defun goto-position (mark pos) (setf (offset mark) pos)) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/12/08 08:53:50 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/12/08 23:25:23 1.12 @@ -243,3 +243,12 @@ (set-key `(com-eval-last-expression ,*numeric-argument-p*) 'pane-lisp-table '((#\c :control) (#\e :control))) + +(set-key `(com-backward-kill-expression ,*numeric-argument-marker*) + 'lisp-table + '((#\Backspace :control :meta))) + +(set-key `(com-kill-expression ,*numeric-argument-marker*) + 'lisp-table + '((#\Delete :control :meta))) + --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/08 08:53:49 1.19 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/08 23:25:23 1.20 @@ -422,6 +422,7 @@ #:delete-horizontal-space #:indent-current-line #:insert-pair + #:move-past-close-and-reindent #:downcase-word #:upcase-word #:capitalize-word #:indent-region #:fill-line #:fill-region From rstrandh at common-lisp.net Mon Dec 10 05:25:20 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 10 Dec 2007 00:25:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071210052520.09A804B055@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv19487 Modified Files: drei-redisplay.lisp Log Message: The function tab-width was called with one argument but requires two. This fixed made it necessary to add the view as an additional argument to offset-x-displacement, because the view is a subclass of tabify-mixin which is what the second argument of tab-width has to be. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/12/08 08:53:50 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/12/10 05:25:19 1.11 @@ -178,7 +178,7 @@ (* text-style-height (- line-number (1- found-line-number)))))))))) -(defun offset-x-displacement (pane line-beg-mark offset) +(defun offset-x-displacement (pane view line-beg-mark offset) (with-sheet-medium (medium pane) (let ((displacement 0) (style (medium-text-style pane))) @@ -205,7 +205,7 @@ while go-again if (eql object #\Tab) do (progn (incf displacement (string-size array)) - (incf displacement (tab-width pane)) + (incf displacement (tab-width pane view)) (setf (fill-pointer array) 0)) else if (and (characterp object) (not (eql object #\Tab))) @@ -238,7 +238,7 @@ (descent (text-style-descent style pane)) (height (+ ascent descent)) (y (line-vertical-offset pane view line-number)) - (x (offset-x-displacement pane line-beg offset))) + (x (offset-x-displacement pane view line-beg offset))) (values x y height style-width)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From rstrandh at common-lisp.net Mon Dec 10 05:27:46 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 10 Dec 2007 00:27:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071210052746.E4E1B4B052@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv19615 Modified Files: views.lisp Log Message: Changed the :initarg of the %tab-space-count slot from nil to 8, which makes tab-width systematically computed as 8 times the space width. This is probably a temporary fix, but it makes Drei behave more like Emacs in the presence of TABs. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/08 08:53:49 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/10 05:27:46 1.2 @@ -47,7 +47,7 @@ "If non-NIL, use tabs when indenting lines. Otherwise, use spaces.") (defclass tabify-mixin () - ((%tab-space-count :initform nil + ((%tab-space-count :initform 8 :accessor tab-space-count :initarg :tab-space-count) ;; We save the old values for performance. Doesn't take text-style From thenriksen at common-lisp.net Mon Dec 10 19:33:18 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 10 Dec 2007 14:33:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071210193318.662E35F058@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3621 Modified Files: commands.lisp Log Message: Added some slightly more useful command-table errors. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2007/03/20 01:39:29 1.71 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2007/12/10 19:33:18 1.72 @@ -96,9 +96,23 @@ (defparameter *command-tables* (make-hash-table :test #'eq)) (define-condition command-table-error (simple-error) - () + ((command-table-name :reader error-command-table-name + :initform nil + :initarg :command-table-name)) (:default-initargs :format-control "" :format-arguments nil)) +(defmethod print-object ((object command-table-error) stream) + (print-unreadable-object (object stream :type t :identity t) + (when (error-command-table-name object) + (princ (error-command-table-name object) stream)))) + +(defun command-table-designator-as-name (designator) + "Return the name of `designator' if it is a command table, +`designator' otherwise." + (if (typep designator 'standard-command-table) + (command-table-name designator) + designator)) + (define-condition command-table-not-found (command-table-error) ()) @@ -117,7 +131,7 @@ (defun find-command-table (name &key (errorp t)) (cond ((command-table-p name) name) ((gethash name *command-tables*)) - (errorp (error 'command-table-not-found)) + (errorp (error 'command-table-not-found :command-table-name name)) (t nil))) (define-presentation-method present (object (type command-table) stream @@ -164,7 +178,7 @@ (unless inherit-from (setq inherit-from '(global-command-table))) (if (and name errorp (gethash name *command-tables*)) - (error 'command-table-already-exists) + (error 'command-table-already-exists :command-table-name name) (let ((result (make-instance 'standard-command-table :name name :inherit-from inherit-from :menu (menu-items-from-list menu)))) @@ -194,7 +208,7 @@ (item (gethash command-name (commands table)))) (if (null item) (when errorp - (error 'command-not-present)) + (error 'command-not-present :command-table-name (command-table-name command-table))) (progn (when (typep item '%menu-item) (remove-menu-item-from-command-table table @@ -243,7 +257,7 @@ :command-line-name name))) (after (getf menu-options :after))) (when (and errorp (gethash command-name (commands table))) - (error 'command-already-present)) + (error 'command-already-present :command-table-name command-table)) (remove-command-from-command-table command-name table :errorp nil) (setf (gethash command-name (commands table)) item) (when name @@ -304,7 +318,7 @@ (values value table))))) (find-command-table command-table)) (if errorp - (error 'command-not-accessible))) + (error 'command-not-accessible :command-table-name command-table))) (defun command-line-name-for-command (command-name command-table &key (errorp t)) @@ -317,7 +331,8 @@ (cond ((eq errorp :create) (command-name-from-symbol command-name)) (errorp - (error 'command-not-accessible)) + (error 'command-not-accessible :command-table-name + (command-table-designator-as-name table))) (t nil))) (defun find-menu-item (menu-name command-table &key (errorp t)) @@ -325,7 +340,8 @@ (mem (member menu-name (slot-value table 'menu) :key #'command-menu-item-name :test #'string-equal))) (cond (mem (values (car mem) command-table)) - (errorp (error 'command-not-accessible)) + (errorp (error 'command-not-accessible :command-table-name + (command-table-designator-as-name table))) (t nil)))) (defun remove-menu-item-from-command-table (command-table string @@ -334,7 +350,8 @@ (item (find-menu-item string command-table :errorp nil))) (with-slots (menu) table (if (and errorp (not item)) - (error 'command-not-present) + (error 'command-not-present :command-table-name + (command-table-designator-as-name table)) (setf menu (delete string menu :key #'command-menu-item-name :test #'string-equal)))))) @@ -388,7 +405,8 @@ (let* ((table (find-command-table command-table)) (old-item (find-menu-item string command-table :errorp nil))) (cond ((and errorp old-item) - (error 'command-already-present)) + (error 'command-already-present :command-table-name + (command-table-designator-as-name table))) (old-item (remove-menu-item-from-command-table command-table string)) (t nil)) @@ -417,7 +435,8 @@ (multiple-value-list (realize-gesture-spec :keyboard gesture)))) (in-table (position gesture keystroke-accelerators :test #'equal))) (when (and in-table errorp) - (error 'command-already-present)) + (error 'command-already-present :command-table-name + (command-table-designator-as-name table))) (if in-table (setf (nth in-table keystroke-items) item) (progn @@ -454,7 +473,8 @@ (setf (cdr accel-tail) (cddr accel-tail)) (setf (cdr items-tail) (cddr items-tail)))) (when errorp - (error 'command-not-present)))))) + (error 'command-not-present :command-table-name + (command-table-designator-as-name table))))))) nil) (defun map-over-command-table-keystrokes (function command-table) @@ -478,7 +498,8 @@ if (funcall test gesture keystroke) do (return-from find-keystroke-item (values item command-table))) (if errorp - (error 'command-not-present) + (error 'command-not-present :command-table-name + (command-table-designator-as-name table)) nil))) (defun lookup-keystroke-item (gesture command-table @@ -504,7 +525,8 @@ (defun partial-command-from-name (command-name) (let ((parser (gethash command-name *command-parser-table*))) (if (null parser) - (error 'command-not-present) + (error 'command-not-present :command-table-name + (command-table-designator-as-name table)) (cons command-name (mapcar #'(lambda (foo) (declare (ignore foo)) From thenriksen at common-lisp.net Mon Dec 10 21:25:13 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 10 Dec 2007 16:25:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071210212513.0CFB174016@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv24255/Drei Modified Files: core.lisp drei-clim.lisp drei-redisplay.lisp drei.lisp lisp-syntax.lisp lr-syntax.lisp packages.lisp syntax.lisp views.lisp Log Message: Make Drei support nonstandard views somewhat. --- /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/12/08 23:25:23 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/12/10 21:25:12 1.10 @@ -325,16 +325,16 @@ specified syntax. `syntax' may be a string containing the name of a known syntax.")) -(defmethod set-syntax ((view textual-drei-syntax-view) (syntax syntax)) +(defmethod set-syntax ((view drei-syntax-view) (syntax syntax)) (setf (syntax view) syntax)) -(defmethod set-syntax ((view textual-drei-syntax-view) (syntax symbol)) +(defmethod set-syntax ((view drei-syntax-view) (syntax symbol)) (set-syntax view (make-syntax-for-view view syntax))) -(defmethod set-syntax ((view textual-drei-syntax-view) (syntax class)) +(defmethod set-syntax ((view drei-syntax-view) (syntax class)) (set-syntax view (make-syntax-for-view view syntax))) -(defmethod set-syntax ((view textual-drei-syntax-view) (syntax string)) +(defmethod set-syntax ((view drei-syntax-view) (syntax string)) (let ((syntax-class (syntax-from-name syntax))) (cond (syntax-class (set-syntax view (make-syntax-for-view view syntax-class))) --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/12/08 08:53:50 1.23 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/12/10 21:25:12 1.24 @@ -400,12 +400,13 @@ (syntax nil) (initial-contents "") (minibuffer t) (border-width 1) (scroll-bars :horizontal) - (drei-class 'drei-gadget-pane)) + (drei-class 'drei-gadget-pane) + (view 'textual-drei-syntax-view)) (check-type initial-contents array) (check-type border-width integer) (check-type scroll-bars (member t :both :vertical :horizontal nil)) (with-keywords-removed (args (:minibuffer :scroll-bars :border-width - :syntax :drei-class)) + :syntax :drei-class :view)) (let* ((borderp (and border-width (plusp border-width))) (minibuffer-pane (cond ((eq minibuffer t) (make-pane 'drei-minibuffer-pane)) @@ -416,11 +417,13 @@ (t (error "Provided minibuffer is not T, NIL or a `minibuffer-pane'.")))) (drei-pane (apply #'make-pane-1 fm frame drei-class - :minibuffer minibuffer-pane args)) + :minibuffer minibuffer-pane + :view (make-instance view) + args)) (pane drei-pane) (view (view drei-pane))) (letf (((read-only-p (buffer view)) nil)) - (insert-sequence (point view) initial-contents)) + (insert-buffer-sequence (buffer view) 0 initial-contents)) (if syntax (setf (syntax view) (make-instance (or (when (syntaxp syntax) --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/12/10 05:25:19 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/12/10 21:25:12 1.12 @@ -103,17 +103,17 @@ (letf (((stream-default-view stream) view)) (call-next-method))))) -(defmethod display-drei-view-cursor ((stream extended-output-stream) (view textual-drei-syntax-view) +(defmethod display-drei-view-cursor ((stream extended-output-stream) + (view drei-view) (cursor drei-cursor)) - (let ((mark (mark cursor))) - (multiple-value-bind (cursor-x cursor-y line-height) - (offset-to-screen-position stream view (offset mark)) - (updating-output (stream :unique-id (list stream :cursor) - :cache-value (list* cursor-x cursor-y line-height)) - (draw-rectangle* stream - (1- cursor-x) cursor-y - (+ cursor-x 2) (+ cursor-y line-height) - :ink (ink cursor)))))) + (multiple-value-bind (cursor-x cursor-y line-height) + (offset-to-screen-position stream view (offset (mark cursor))) + (updating-output (stream :unique-id (list stream :cursor) + :cache-value (list* cursor-x cursor-y line-height)) + (draw-rectangle* stream + (1- cursor-x) cursor-y + (+ cursor-x 2) (+ cursor-y line-height) + :ink (ink cursor))))) (defmethod display-drei-view-cursor :after ((stream extended-output-stream) (view drei-view) (cursor point-cursor)) @@ -431,14 +431,15 @@ (setf (offset (point view)) (offset bot)) (beginning-of-line (point view)))))) -(defgeneric fix-pane-viewport (pane)) +(defgeneric fix-pane-viewport (pane view) + (:documentation "Fix the size and scrolling of `pane', which +has `view'.")) -(defmethod fix-pane-viewport ((pane drei-pane)) +(defmethod fix-pane-viewport ((pane drei-pane) (view drei-view)) (let* ((output-width (bounding-rectangle-width (stream-current-output-record pane))) (viewport (pane-viewport pane)) (viewport-width (and viewport (bounding-rectangle-width viewport))) - (pane-width (bounding-rectangle-width pane)) - (view (view pane))) + (pane-width (bounding-rectangle-width pane))) ;; If the width of the output is greater than the width of the ;; sheet, make the sheet wider. If the sheet is wider than the ;; viewport, but doesn't really need to be, make it thinner. @@ -446,42 +447,53 @@ (and viewport (> pane-width viewport-width) (>= viewport-width output-width))) - (change-space-requirements pane :width output-width)) - (when (and viewport (active pane)) - (multiple-value-bind (cursor-x cursor-y) (offset-to-screen-position pane view (offset (point view))) - (declare (ignore cursor-y)) - (let ((x-position (abs (transform-position (sheet-transformation pane) 0 0))) - (viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane)))) - (cond ((> cursor-x (+ x-position viewport-width)) - (move-sheet pane (round (- (- cursor-x viewport-width))) 0)) - ((> x-position cursor-x) - (move-sheet pane (if (> viewport-width cursor-x) - 0 - (round (- cursor-x))) - 0)))))))) + (change-space-requirements pane :width output-width)))) + +(defmethod fix-pane-viewport :after ((pane drei-pane) (view point-mark-view)) + (when (and (pane-viewport pane) (active pane)) + (multiple-value-bind (cursor-x cursor-y) (offset-to-screen-position pane view (offset (point view))) + (declare (ignore cursor-y)) + (let ((x-position (abs (transform-position (sheet-transformation pane) 0 0))) + (viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane)))) + (cond ((> cursor-x (+ x-position viewport-width)) + (move-sheet pane (round (- (- cursor-x viewport-width))) 0)) + ((> x-position cursor-x) + (move-sheet pane (if (> viewport-width cursor-x) + 0 + (round (- cursor-x))) + 0))))))) (defmethod handle-repaint :before ((pane drei-pane) region) (declare (ignore region)) (redisplay-frame-pane (pane-frame pane) pane)) +(defgeneric fully-redisplay-pane (pane view) + (:documentation "Fully redisplay `pane' showing `view', finally +setting the `full-redisplay-p' flag to false.") + (:method :after (pane (view drei-view)) + (setf (full-redisplay-p view) nil))) + +(defmethod fully-redisplay-pane ((drei-pane drei-pane) + (view point-mark-view)) + (reposition-pane drei-pane) + (adjust-pane-bot drei-pane) + (setf (full-redisplay-p view) nil)) + (defun display-drei-pane (frame drei-pane) "Display `pane'. If `pane' has focus, `current-p' should be non-NIL." (declare (ignore frame)) (let ((view (view drei-pane))) - (with-accessors ((buffer buffer) (top top) (bot bot)) (view drei-pane) - (if (full-redisplay-p view) - (progn (reposition-pane drei-pane) - (adjust-pane-bot drei-pane) - (setf (full-redisplay-p view) nil)) - (adjust-pane drei-pane)) - #+nil(update-syntax-for-display buffer syntax top bot) + (with-accessors ((buffer buffer) (top top) (bot bot)) view + (when (typep view 'point-mark-view) + (if (full-redisplay-p view) + (fully-redisplay-pane drei-pane view) + (adjust-pane drei-pane))) (display-drei-view-contents drei-pane view) ;; Point must be on top of all other cursors. - (display-drei-view-cursor drei-pane view (point-cursor drei-pane)) (dolist (cursor (cursors drei-pane)) (display-drei-view-cursor drei-pane view cursor)) - (fix-pane-viewport drei-pane)))) + (fix-pane-viewport drei-pane (view drei-pane))))) (defgeneric full-redisplay (pane) (:documentation "Queue a full redisplay for `pane'.")) --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/08 08:53:50 1.20 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/10 21:25:12 1.21 @@ -210,11 +210,10 @@ (additional-command-tables *drei-instance* command-table)) (defmethod command-table-inherit-from ((table drei-command-table)) - (let ((syntax-table (command-table (current-syntax)))) - (append `(,syntax-table) - (additional-command-tables *drei-instance* table) - (when (use-editor-commands-p syntax-table) - '(editor-table))))) + (append (view-command-tables (current-view)) + (additional-command-tables *drei-instance* table) + (when (use-editor-commands-p (current-view)) + '(editor-table)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/08 08:53:50 1.33 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/10 21:25:12 1.34 @@ -116,12 +116,16 @@ (defmethod name-for-info-pane ((syntax lisp-syntax) &key view) (format nil "Lisp~@[:~(~A~)~]" - (provided-package-name-at-mark syntax (point view)))) + (provided-package-name-at-mark syntax (if (typep view 'point-mark-view) + (point view) + 0)))) (defmethod display-syntax-name ((syntax lisp-syntax) (stream extended-output-stream) &key view) (princ "Lisp:" stream) ; FIXME: should be `present'ed ; as something. - (let ((package-name (provided-package-name-at-mark syntax (point view)))) + (let ((package-name (provided-package-name-at-mark syntax (if (typep view 'point-mark-view) + (point view) + 0)))) (if (find-package package-name) (with-output-as-presentation (stream (find-package package-name) 'expression) (princ package-name stream)) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2007/12/08 08:53:50 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2007/12/10 21:25:12 1.4 @@ -39,8 +39,7 @@ (defmethod initialize-instance :after ((syntax lr-syntax-mixin) &rest args) (declare (ignore args)) (with-accessors ((buffer buffer) (scan scan)) syntax - (setf scan (make-buffer-mark buffer 0 :left)) - (update-syntax syntax 0 0))) + (setf scan (make-buffer-mark buffer 0 :left)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/08 23:25:23 1.20 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/10 21:25:12 1.21 @@ -138,7 +138,7 @@ (defpackage :drei-syntax (:use :clim-lisp :clim :drei-buffer :drei-base :flexichain :esa-utils) (:export #:syntax #:update-parse #:syntaxp #:define-syntax #:*default-syntax* #:cursor-positions - #:syntax-command-table #:use-editor-commands-p #:additional-command-tables #:define-syntax-command-table + #:syntax-command-table #:additional-command-tables #:define-syntax-command-table #:eval-option #:define-option-for-syntax #:current-attributes-for-syntax @@ -210,6 +210,7 @@ #:drei-view #:modified-p #:no-cursors #:drei-buffer-view #:buffer #:top #:bot #:drei-syntax-view #:syntax + #:point-mark-view #:textual-drei-syntax-view #:tab-space-count #:space-width #:tab-width #:auto-fill-mode #:auto-fill-column @@ -221,7 +222,10 @@ #:prefix-start-offset #:overwrite-mode #:goal-column - + + #:view-command-tables + #:use-editor-commands-p + #:synchronize-view #:create-view-cursors #:clone-view #:make-syntax-for-view --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2007/12/08 08:53:49 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2007/12/10 21:25:12 1.8 @@ -88,20 +88,6 @@ available when Lisp syntax is used in Climacs (or another editor), but not anywhere else.")) -(defgeneric use-editor-commands-p (command-table) - (:documentation "If `command-table' is supposed to include -standard editor commands (for inserting objects, moving cursor, -etc), this function will return T (the default). If you want your -syntax to use standard editor commands, you should *not* inherit -from `editor-table' - the command tables containing the editor -commands will be added automatically, as long as this function -returns true. For most syntax command tables, you do not need to -define a method for this generic function, you really do want the -standard editor commands for all but the most esoteric -syntaxes.") - (:method ((command-table standard-command-table)) - t)) - (defgeneric additional-command-tables (editor command-table) (:method-combination append) (:documentation "Return a list of additional command tables --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/10 05:27:46 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/10 21:25:12 1.3 @@ -142,7 +142,7 @@ buffer contents at a specific offset.")) (defclass insert-record (simple-undo-record) - ((objects :initarg :objects + ((objects :initarg :objects :documentation "The sequence of objects that are to be inserted whenever flip-undo-record is called on an instance of insert-record.")) @@ -421,7 +421,21 @@ :initarg :no-cursors :initform nil :documentation "True if the view does not display -cursors.")) +cursors.") + (%full-redisplay-p :accessor full-redisplay-p + :initform nil + :documentation "True if the view should be +fully redisplayed the next time it is redisplayed.") + (%use-editor-commands :accessor use-editor-commands-p + :initarg :use-editor-commands + :initform nil + :documentation "If the view is supposed +to support standard editor commands (for inserting objects, +moving cursor, etc), this will be true. If you want your view to +support standard editor commands, you should *not* inherit from +`editor-table' - the command tables containing the editor +commands will be added automatically, as long as this value is +true.")) (:documentation "The base class for all Drei views. A view observes some other object and provides a visual representation for Drei.") @@ -433,6 +447,13 @@ arguments are supported, is up to the individual view subclass.")) +(defgeneric view-command-tables (view) + (:documentation "Return a list of command tables containing +commands relevant for `view'.") + (:method-combination append) + (:method append ((view drei-view)) + '())) + (defgeneric create-view-cursors (output-stream view) (:documentation "Create cursors for `view' that are to be displayed on `output-stream'.") @@ -464,8 +485,9 @@ nconc (list slot-initarg (slot-value view slot-name))))))) (defclass drei-buffer-view (drei-view) - ((%buffer :initform (make-instance 'drei-buffer) - :initarg :buffer :accessor buffer + ((%buffer :accessor buffer + :initform (make-instance 'drei-buffer) + :initarg :buffer :type drei-buffer :accessor buffer) (%top :accessor top @@ -557,6 +579,11 @@ suffix-size) (modified-p view) t))) +(defmethod synchronize-view :around ((view drei-syntax-view) &key) + ;; If nothing changed, then don't call the other methods. + (unless (= (prefix-size view) (suffix-size view) (size (buffer view))) + (call-next-method))) + (defmethod synchronize-view ((view drei-syntax-view) &key (begin 0) (end (size (buffer view)))) "Synchronize the syntax view with the underlying @@ -565,13 +592,12 @@ size of the buffer respectively." (let ((prefix-size (prefix-size view)) (suffix-size (suffix-size view))) - (unless (= prefix-size suffix-size (size (buffer view))) - ;; Reset here so if `update-syntax' calls `update-parse' itself, - ;; we won't end with infinite recursion. - (setf (prefix-size view) (size (buffer view)) - (suffix-size view) (size (buffer view))) - (update-syntax (syntax view) prefix-size suffix-size - begin end)))) + ;; Reset here so if `update-syntax' calls `update-parse' itself, + ;; we won't end with infinite recursion. + (setf (prefix-size view) (size (buffer view)) + (suffix-size view) (size (buffer view))) + (update-syntax (syntax view) prefix-size suffix-size + begin end))) (defun make-syntax-for-view (view syntax-symbol &rest args) (apply #'make-instance syntax-symbol @@ -580,28 +606,13 @@ (synchronize-view view :begin begin :end end))) args)) -(defclass textual-drei-syntax-view (drei-syntax-view textual-view) +(defclass point-mark-view (drei-buffer-view) ((%point :initform nil :initarg :point :accessor point-of) - (%mark :initform nil :initarg :mark :accessor mark-of) - (%auto-fill-mode :initform nil :accessor auto-fill-mode) - (%auto-fill-column :initform 70 :accessor auto-fill-column) - (%region-visible-p :initform nil :accessor region-visible-p) - (%full-redisplay-p :initform nil :accessor full-redisplay-p) - ;; for next-line and previous-line commands - (%goal-column :initform nil :accessor goal-column) - ;; for dynamic abbrev expansion - (%original-prefix :initform nil :accessor original-prefix) - (%prefix-start-offset :initform nil :accessor prefix-start-offset) - (%dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark) - (%overwrite-mode :initform nil :accessor overwrite-mode) - (%point-cursor :accessor point-cursor - :initarg :point-cursor - :type drei-cursor - :documentation "The cursor object associated -with point. This is guaranteed to be displayed -on top of all other cursors."))) + (%mark :initform nil :initarg :mark :accessor mark-of)) + (:documentation "A view class containing a point and a mark +into its buffer.")) -(defmethod initialize-instance :after ((view textual-drei-syntax-view) +(defmethod initialize-instance :after ((view point-mark-view) &rest args) (declare (ignore args)) (with-accessors ((point point) (mark mark) @@ -609,19 +620,38 @@ (setf point (clone-mark (point buffer))) (setf mark (clone-mark (point buffer))))) -(defmethod (setf buffer) :before ((buffer drei-buffer) (view textual-drei-syntax-view)) +(defmethod (setf buffer) :before ((buffer drei-buffer) (view point-mark-view)) ;; Set the point of the old buffer to the current point of the view, ;; so the next time the buffer is revealed, it will remember its ;; point. (setf (point (buffer view)) (point view))) -(defmethod (setf buffer) :after ((buffer drei-buffer) (view textual-drei-syntax-view)) +(defmethod (setf buffer) :after ((buffer drei-buffer) (view point-mark-view)) (with-accessors ((point point) (mark mark)) view (setf point (clone-mark (point buffer)) mark (clone-mark (point buffer) :right)))) +(defclass textual-drei-syntax-view (drei-syntax-view point-mark-view textual-view) + ((%auto-fill-mode :initform nil :accessor auto-fill-mode) + (%auto-fill-column :initform 70 :accessor auto-fill-column) + (%region-visible-p :initform nil :accessor region-visible-p) + ;; for next-line and previous-line commands + (%goal-column :initform nil :accessor goal-column) + ;; for dynamic abbrev expansion + (%original-prefix :initform nil :accessor original-prefix) + (%prefix-start-offset :initform nil :accessor prefix-start-offset) + (%dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark) + (%overwrite-mode :initform nil :accessor overwrite-mode)) + (:default-initargs :use-editor-commands t)) + (defmethod create-view-cursors nconc ((output-stream extended-output-stream) (view textual-drei-syntax-view)) (unless (no-cursors view) - (list (make-instance 'mark-cursor :view view :output-stream output-stream) - (make-instance 'point-cursor :view view :output-stream output-stream)))) + (list (make-instance 'point-cursor :view view :output-stream output-stream) + (make-instance 'mark-cursor :view view :output-stream output-stream)))) + +(defmethod view-command-tables append ((view textual-drei-syntax-view)) + (list (command-table (syntax view)))) + +(defmethod use-editor-commands-p ((view textual-drei-syntax-view)) + t) From thenriksen at common-lisp.net Tue Dec 11 18:46:27 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 11 Dec 2007 13:46:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071211184627.4FBB531041@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13252/Drei Modified Files: lisp-syntax.lisp lisp-syntax-swank.lisp Log Message: I broke the Swank-using code in Drei, now unbroke it. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/10 21:25:12 1.34 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/11 18:46:27 1.35 @@ -165,26 +165,27 @@ (declare (ignore image)) (eval form))) -(defgeneric compile-string-for-drei (image string package syntax buffer-mark) +(defgeneric compile-string-for-drei (image string package view buffer-mark) (:documentation "Compile and evaluate `string' in `package'. Two values are returned: The result of evaluating `string' and a list of compiler notes. `Buffer' and `buffer-mark' will be used for hyperlinking the compiler notes to the source code.") - (:method (image string package syntax buffer-mark) + (:method (image (string string) package (view drei-buffer-view) + (buffer-mark mark)) (error "Backend insufficient for this operation"))) -(defgeneric compile-form-for-drei (image form syntax buffer-mark) +(defgeneric compile-form-for-drei (image form view buffer-mark) (:documentation "Compile and evaluate `form', which must be a valid Lisp form. Two values are returned: The result of evaluating `string' and a list of compiler notes. `Buffer' and `buffer-mark' will be used for hyperlinking the compiler notes to the source code.") - (:method (image form syntax buffer-mark) + (:method (image form (view drei-syntax-view) (buffer-mark mark)) (compile-string-for-drei image - (let ((*print-base* (base syntax))) + (let ((*print-base* (base (syntax view)))) (write-to-string form)) - *package* syntax buffer-mark))) + *package* view buffer-mark))) (defgeneric compile-file-for-drei (image filepath package &optional load-p) (:documentation "Compile the file at `filepath' in --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/12/08 08:53:50 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/12/11 18:46:27 1.7 @@ -28,6 +28,11 @@ (defclass swank-local-image () ()) +;; We need these modules loaded. +(eval-when (:compile-toplevel :load-toplevel :execute) + (load (swank::find-module "swank-c-p-c")) + (load (swank::find-module "swank-arglists"))) + ;; If this file is loaded, make local Swank the default way of ;; interacting with the image. @@ -59,7 +64,7 @@ (swank::*buffer-package* package) (swank::*buffer-readtable* *readtable*)) (let ((result (swank::compile-string-for-emacs - string view-name (offset buffer-mark) buffer-file-name)) + string view-name (offset buffer-mark) (princ-to-string buffer-file-name))) (notes (loop for note in (swank::compiler-notes-for-emacs) collect (make-compiler-note note)))) (values result notes)))) From thenriksen at common-lisp.net Thu Dec 13 07:30:38 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 13 Dec 2007 02:30:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071213073038.BE3FB330CA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9823/Drei Modified Files: lisp-syntax.lisp Log Message: Make sure the parse is up-to-date when asked for package information in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/11 18:46:27 1.35 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/13 07:30:37 1.36 @@ -1152,6 +1152,7 @@ form can be found, return the package specified in the attribute list. If no such package is specified, return \"CLIM-USER\"." (as-offsets ((offset mark-or-offset)) + (update-parse syntax 0 mark-or-offset) (flet ((normalise (designator) (typecase designator (symbol @@ -1160,12 +1161,12 @@ designator) (package (package-name designator))))) - (let* ((designator (rest (find offset (package-list syntax) - :key #'first - :test #'>=)))) - (normalise (or designator - (option-specified-package syntax) - :clim-user)))))) + (let* ((designator (rest (find offset (package-list syntax) + :key #'first + :test #'>=)))) + (normalise (or designator + (option-specified-package syntax) + :clim-user)))))) (defmacro with-syntax-package ((syntax offset) &body body) From thenriksen at common-lisp.net Thu Dec 13 07:30:55 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 13 Dec 2007 02:30:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071213073055.D5AFC330CC@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9906/Drei Modified Files: views.lisp Log Message: Always update the syntax of a view at least once, even when the buffer is always empty. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/10 21:25:12 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/13 07:30:53 1.4 @@ -560,15 +560,17 @@ bot (make-buffer-mark buffer (size buffer) :right)) ;; We resynchronize here, instead of delaying a potentially large ;; reparse until the next time some hapless command (or redisplay - ;; function) needs a parse tree. - (synchronize-view view))) + ;; function) needs a parse tree. Force the resynchronisation so + ;; that even if the buffer is empty, `update-syntax' will still be + ;; called. + (synchronize-view view :force-p t))) (defmethod (setf syntax) :after (syntax (view drei-syntax-view)) ;; We need to reparse the buffer completely. Might as well do it ;; now. (setf (prefix-size view) 0 (suffix-size view) 0) - (synchronize-view view)) + (synchronize-view view :force-p t)) (defmethod observer-notified ((view drei-syntax-view) (buffer drei-buffer) changed-region) @@ -579,9 +581,11 @@ suffix-size) (modified-p view) t))) -(defmethod synchronize-view :around ((view drei-syntax-view) &key) +(defmethod synchronize-view :around ((view drei-syntax-view) &key + force-p) ;; If nothing changed, then don't call the other methods. - (unless (= (prefix-size view) (suffix-size view) (size (buffer view))) + (unless (and (= (prefix-size view) (suffix-size view) (size (buffer view))) + (not force-p)) (call-next-method))) (defmethod synchronize-view ((view drei-syntax-view) From thenriksen at common-lisp.net Thu Dec 13 07:57:15 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 13 Dec 2007 02:57:15 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071213075715.8E6476A1E1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13512/Drei Modified Files: input-editor.lisp Log Message: Make the form-reading method for Drei signal an appropriate error when an activation gesture is invoked with no input. Changed the Listener to provide NIL as a default. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/12/08 08:53:50 1.20 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/12/13 07:57:15 1.21 @@ -805,6 +805,7 @@ (with-delimiter-gestures (nil :override t) (loop named control-loop + with start-scan-pointer = (stream-scan-pointer stream) with drei = (drei-instance stream) with syntax = (syntax (view drei)) ;; The input context permits the user to mouse-select displayed @@ -836,8 +837,18 @@ ;; #\Newline characters in the input will not cause premature ;; activation. until (and (activation-gesture-p gesture) - freshly-inserted - (drei-lisp-syntax::form-complete-p form)) + (or (and freshly-inserted + (drei-lisp-syntax::form-complete-p form)))) + when (and (activation-gesture-p gesture) + (null form)) + do ;; We have to remove the buffer contents (whitespace, + ;; comments or error states, if this happens) or code + ;; above us will not believe us when we tell them that the + ;; input is empty + (delete-buffer-range (buffer (view drei)) start-scan-pointer + (stream-scan-pointer stream)) + (setf (stream-scan-pointer stream) start-scan-pointer) + (simple-parse-error "Empty input") ;; We only want to process the gesture if it is fresh, because ;; if it isn't, it has already been processed at some point in ;; the past. From thenriksen at common-lisp.net Thu Dec 13 07:57:15 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 13 Dec 2007 02:57:15 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20071213075715.A1E5E6A1BD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv13512/Apps/Listener Modified Files: listener.lisp Log Message: Make the form-reading method for Drei signal an appropriate error when an activation gesture is invoked with no input. Changed the Listener to provide NIL as a default. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/06/02 20:30:53 1.35 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/12/13 07:57:15 1.36 @@ -137,7 +137,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)) + (accept 'command-or-form :stream stream :prompt nil :default nil)) (if (presentation-subtypep type 'command) object `(com-eval ,object)))) From rstrandh at common-lisp.net Sat Dec 15 07:23:54 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Sat, 15 Dec 2007 02:23:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071215072354.A040844061@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv28149 Modified Files: views.lisp Log Message: Facilitate debugging by printing subscriptable views with the name and the subscript. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/13 07:30:53 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/15 07:23:54 1.5 @@ -441,6 +441,10 @@ for Drei.") (:default-initargs :name "*scratch*")) +(defmethod print-object ((view drei-view) stream) + (print-unreadable-object (view stream :type t :identity t) + (format stream "name: ~a ~a" (name view) (subscript view)))) + (defgeneric synchronize-view (view &key &allow-other-keys) (:documentation "Synchronize the view with the object under observation - what exactly this entails, and what keyword From thenriksen at common-lisp.net Sat Dec 15 10:18:16 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 15 Dec 2007 05:18:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20071215101816.1AE22A146@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv26063/ESA Modified Files: esa-buffer.lisp esa-io.lisp Log Message: Added my copyright statement to a bunch of ESA files. --- /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp 2007/12/08 08:53:48 1.3 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp 2007/12/15 10:18:15 1.4 @@ -2,6 +2,8 @@ ;;; (c) copyright 2006 by ;;; Robert Strandh (strandh at labri.fr) +;;; (c) copyright 2007 by +;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2006/11/23 19:53:53 1.3 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2007/12/15 10:18:16 1.4 @@ -2,6 +2,8 @@ ;;; (c) copyright 2006 by ;;; Robert Strandh (strandh at labri.fr) +;;; (c) copyright 2007 by +;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public From thenriksen at common-lisp.net Sun Dec 16 14:27:22 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 16 Dec 2007 09:27:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071216142722.B6EA72F00A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv21764 Modified Files: panes.lisp Log Message: Fixed the space-requirements of label-pane so that it no longer has a max-width of the width of the actual label text. It still has a max-height, however, I'm not sure whether that's correct. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2007/08/21 21:45:49 1.184 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2007/12/16 14:27:22 1.185 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.184 2007/08/21 21:45:49 thenriksen Exp $ +;;; $Id: panes.lisp,v 1.185 2007/12/16 14:27:22 thenriksen Exp $ (in-package :clim-internals) @@ -2334,7 +2334,7 @@ (t (incf w m0) (incf w m0) - (let ((sr1 (make-space-requirement :width w :min-width w :max-width w + (let ((sr1 (make-space-requirement :width w :min-width w :height h :min-height h :max-height h))) (when (sheet-children pane) (let ((sr2 (compose-space (first (sheet-children pane))))) From thenriksen at common-lisp.net Sun Dec 16 14:42:08 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 16 Dec 2007 09:42:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071216144208.1E13B12060@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv24695 Modified Files: lisp-syntax-swine.lisp Log Message: Added `parameter-match-p' case where no arg indices are available. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2007/12/08 08:53:50 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2007/12/16 14:42:07 1.10 @@ -67,6 +67,8 @@ (defgeneric parameter-match-p (parameter arg-indices &key &allow-other-keys) (:method ((parameter parameter) (arg-indices list) &key) + nil) + (:method :around ((parameter parameter) (arg-indices null) &key) nil)) (defmethod parameter-match-p ((parameter named-parameter) (arg-indices list) &key) From dlichteblau at common-lisp.net Sun Dec 16 20:02:08 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 16 Dec 2007 15:02:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20071216200208.4F3CB2F068@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv15810 Modified Files: mcclim-freetype.asd Log Message: Depend explictly on mcclim in mcclim-freetype.asd. Otherwise user code depending on mcclim-freetype has to be careful in ordering the dependencies to mcclim and mcclim-freetype. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2006/03/15 09:31:31 1.5 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2007/12/16 20:02:08 1.6 @@ -28,7 +28,7 @@ "lisp") (defsystem :mcclim-freetype - :depends-on (:clim-clx) + :depends-on (:clim-clx :mcclim) :serial t :components ((:file "freetype-package") From dlichteblau at common-lisp.net Sun Dec 16 22:41:51 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 16 Dec 2007 17:41:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071216224151.D2B2532038@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14369 Modified Files: input.lisp Log Message: In EVENT-QUEUE-READ-WITH-TIMEOUT, warn about the WAIT-FUNCTION being ignored only if a WAIT-FUNCTION was specified. --- /project/mcclim/cvsroot/mcclim/input.lisp 2006/07/09 06:23:22 1.37 +++ /project/mcclim/cvsroot/mcclim/input.lisp 2007/12/16 22:41:51 1.38 @@ -88,7 +88,6 @@ (defmethod event-queue-read-with-timeout ((eq standard-event-queue) timeout wait-function) - (declare (ignore wait-function)) (let ((lock (event-queue-lock eq))) (with-lock-held (lock) (loop @@ -96,7 +95,8 @@ (let ((res (event-queue-read-no-hang/locked eq))) (when res (return res)) - (warn "event-queue-read-with-timeout ignoring predicate") + (when wait-function + (warn "event-queue-read-with-timeout ignoring predicate")) (condition-wait (event-queue-processes eq) lock timeout)))))) (defmethod event-queue-append ((eq standard-event-queue) item) From dlichteblau at common-lisp.net Sun Dec 16 23:17:27 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 16 Dec 2007 18:17:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20071216231727.284CB76042@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv21826 Modified Files: port.lisp Log Message: Install a graft into the gtkairo port. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2007/02/07 12:44:19 1.17 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2007/12/16 23:17:26 1.18 @@ -71,6 +71,7 @@ (setf (events-head port) (list nil)) (setf (events-tail port) (events-head port)) (setf (port-pointer port) (make-instance 'gtkairo-pointer :port port)) + (push (make-graft port) (climi::port-grafts port)) ;; FIXME: it seems bizarre for this to be necessary (push (make-instance 'gtkairo-frame-manager :port port) (slot-value port 'climi::frame-managers)) From dlichteblau at common-lisp.net Sun Dec 16 23:20:11 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 16 Dec 2007 18:20:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071216232011.7EC5E4085@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22271 Modified Files: input.lisp Log Message: Fixed EVENT-QUEUE-READ-WITH-TIMEOUT to return on timeout. Previously it would just continue silently. * input.lisp (EVENT-QUEUE-READ-WITH-TIMEOUT): return if condition-wait returns nil. * Lisp-Dep/mp-sbcl.lisp (CONDITION-WAIT): Return T from a normalcondition wait and NIL from a timeout, like mp-acl.lisp does it. --- /project/mcclim/cvsroot/mcclim/input.lisp 2007/12/16 22:41:51 1.38 +++ /project/mcclim/cvsroot/mcclim/input.lisp 2007/12/16 23:20:10 1.39 @@ -97,7 +97,8 @@ (return res)) (when wait-function (warn "event-queue-read-with-timeout ignoring predicate")) - (condition-wait (event-queue-processes eq) lock timeout)))))) + (unless (condition-wait (event-queue-processes eq) lock timeout) + (return))))))) (defmethod event-queue-append ((eq standard-event-queue) item) "Append the item at the end of the queue. Does event compression." From dlichteblau at common-lisp.net Sun Dec 16 23:20:12 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 16 Dec 2007 18:20:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Lisp-Dep Message-ID: <20071216232012.C531870C8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory clnet:/tmp/cvs-serv22271/Lisp-Dep Modified Files: mp-sbcl.lisp Log Message: Fixed EVENT-QUEUE-READ-WITH-TIMEOUT to return on timeout. Previously it would just continue silently. * input.lisp (EVENT-QUEUE-READ-WITH-TIMEOUT): return if condition-wait returns nil. * Lisp-Dep/mp-sbcl.lisp (CONDITION-WAIT): Return T from a normalcondition wait and NIL from a timeout, like mp-acl.lisp does it. --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2007/11/28 08:11:12 1.10 +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2007/12/16 23:20:11 1.11 @@ -202,11 +202,12 @@ (if timeout (handler-case (sb-ext:with-timeout timeout - (sb-thread:condition-wait cv lock)) + (sb-thread:condition-wait cv lock) + t) (sb-ext:timeout (c) (declare (ignore c)) nil)) - (sb-thread:condition-wait cv lock))) + (progn (sb-thread:condition-wait cv lock) t))) (defun condition-notify (cv) (sb-thread:condition-notify cv)) From rstrandh at common-lisp.net Mon Dec 17 06:29:38 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 17 Dec 2007 01:29:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071217062938.5F6A212084@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11340 Modified Files: core-commands.lisp drei.lisp Log Message: Added additional documentation of *drei-instance* because it took me a while to figure out what type it was supposed to be. Auto-fill-mode is now a flag in the view, but com-auto-fill-mode called the accessor with *drei-instance* which is a pane. I fixed com-auto-fill-mode to call the accessor with the (current-view) instead. --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/12/08 23:25:23 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/12/17 06:29:37 1.9 @@ -259,8 +259,9 @@ '((#\^ :shift :meta))) (define-command (com-auto-fill-mode :name t :command-table fill-table) () - (setf (auto-fill-mode *drei-instance*) - (not (auto-fill-mode *drei-instance*)))) + (let ((view (current-view))) + (setf (auto-fill-mode view) + (not (auto-fill-mode view))))) (define-command (com-fill-paragraph :name t :command-table fill-table) () (let ((begin-mark (clone-mark (point))) --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/10 21:25:12 1.21 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/17 06:29:37 1.22 @@ -64,7 +64,7 @@ ;;; Convenience stuff. (defvar *drei-instance* nil - "The currently running Drei instance.") + "The currently running Drei instance. The value is a subclass of pane.") (defun current-view (&optional (object *drei-instance*)) "Return the view of the provided object. If no object is From rstrandh at common-lisp.net Mon Dec 17 06:47:13 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 17 Dec 2007 01:47:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071217064713.E35C77E01C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv14501 Modified Files: core-commands.lisp lisp-syntax-commands.lisp Log Message: Fixed two more instances where the value of *drei-instance* was used directly whereas a view was required. --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/12/17 06:29:37 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/12/17 06:47:13 1.10 @@ -48,7 +48,7 @@ (defun set-fill-column (column) (if (> column 1) - (setf (auto-fill-column *drei-instance*) column) + (setf (auto-fill-column (current-view)) column) (progn (beep) (display-message "Set Fill Column requires an explicit argument.")))) (define-command (com-set-fill-column :name t :command-table fill-table) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/12/08 23:25:23 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/12/17 06:47:13 1.13 @@ -56,7 +56,7 @@ "Fill paragraph at point. Will have no effect unless there is a string at point." (let* ((token (form-around (current-syntax) (offset (point)))) - (fill-column (auto-fill-column *drei-instance*))) + (fill-column (auto-fill-column (current-view)))) (when (form-string-p token) (with-accessors ((offset1 start-offset) (offset2 end-offset)) token From thenriksen at common-lisp.net Tue Dec 18 08:39:43 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 18 Dec 2007 03:39:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071218083943.950CE4F026@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv2245/Drei Modified Files: views.lisp packages.lisp Log Message: Changed the tab-indentation code a bit. Whether or not to indent with tabs is now a property of the view, not the buffer. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/15 07:23:54 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/18 08:39:43 1.6 @@ -57,7 +57,10 @@ (%tab-width :accessor recorded-tab-width :initform nil) (%recorded-stream :accessor recorded-stream - :initform nil))) + :initform nil) + (%use-tabs :accessor use-tabs + :initform *use-tabs-for-indentation* + :initarg :use-tabs))) (defun maybe-update-recordings (stream tabify) (with-accessors ((space-width recorded-space-width) @@ -368,10 +371,7 @@ (defclass drei-buffer (delegating-buffer esa-buffer-mixin observable-buffer-mixin) - ((point :initarg :point :initform nil :accessor point-of) - (indent-tabs-mode :initarg :indent-tabs-mode - :initform *use-tabs-for-indentation* - :accessor indent-tabs-mode)) + ((point :initarg :point :initform nil :accessor point-of)) (:default-initargs :implementation (make-instance 'extended-standard-buffer))) (defmethod initialize-instance :after ((buffer drei-buffer) &rest args --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/10 21:25:12 1.21 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/18 08:39:43 1.22 @@ -185,7 +185,6 @@ #:display-drei #:display-drei-pane #:display-drei-area #:full-redisplay #:offset-to-screen-position #:page-down #:page-up - #:indent-tabs-mode #:isearch-state #:search-string #:search-mark #:search-buffer #:search-forward-p #:search-success-p #:query-replace-state #:string1 #:string2 #:targets #:occurrences @@ -212,7 +211,7 @@ #:drei-syntax-view #:syntax #:point-mark-view #:textual-drei-syntax-view - #:tab-space-count #:space-width #:tab-width + #:tab-space-count #:space-width #:tab-width #:use-tabs #:auto-fill-mode #:auto-fill-column #:isearch-mode #:isearch-states #:isearch-previous-string #:query-replace-mode From rschlatte at common-lisp.net Tue Dec 18 10:54:21 2007 From: rschlatte at common-lisp.net (rschlatte) Date: Tue, 18 Dec 2007 05:54:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071218105421.9735446181@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv30166 Modified Files: mcclim.asd Log Message: Beagle backend fixes * functionality not tested, but it loads under clozure cl snapshot * Patches by Greg Pfeil Signed-off-by: Rudi Schlatte --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/08 08:53:59 1.63 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/18 10:54:21 1.64 @@ -82,6 +82,12 @@ (defsystem :clx :class requireable-system)) +;;; Required for the beagle backend (not activated by default) +#+clozure-common-lisp +(progn + (require :cocoa) + (require :objc-support)) + (defmacro clim-defsystem ((module &key depends-on) &rest components) `(progn (asdf:defsystem ,module @@ -377,6 +383,71 @@ (:file "graft" :depends-on ("port" "package")) (:file "frame-manager" :depends-on ("medium" "port" "package")))))) +(defsystem :clim-beagle + :depends-on (clim) + :components + ((:module "Backends" + :components + ((:module "beagle" + :serial t + :components + ((:file "package") + (:module "native" + :components ((:file "lisp-bezier-path") + (:file "lisp-window") + (:file "lisp-window-delegate") + (:file "lisp-view" + :depends-on ("lisp-bezier-path")) + (:file "lisp-view-additional" + :depends-on ("lisp-view")) + (:file "lisp-scroller") + (:file "lisp-slider") + (:file "lisp-button") + (:file "lisp-image"))) + (:file "cocoa-util") + (:module "windowing" + :depends-on ("native") + :components ((:file "port") + (:file "frame-manager") + (:file "mirror") + (:file "graft"))) + (:module "native-panes" + :components ((:file "beagle-scroll-bar-pane") + (:file "beagle-slider-pane") + ;; Basic buttons - not collections of buttons + (:file "beagle-fundamental-button-pane") + ;; Button collections (radio + checkbox) + ;; (:file "beagle-button-collection-pane") + (:file "scroller-pane-fix"))) + (:module "output" + :depends-on ("windowing") + :components ((:file "medium") + (:file "fonts"))) + (:module "input" + :depends-on ("windowing") + :components ((:file "events") + (:file "keysymdef"))) + (:module "glimpse" + :components ((:file "glimpse") + (:file "glimpse-support") + (:file "glimpse-command-tables") + (:file "glimpse-present-process" + :depends-on ("glimpse" "glimpse-support")) + (:file "glimpse-present-window" + :depends-on ("glimpse" "glimpse-support")) + (:file "glimpse-modeless-commands" + :depends-on ("glimpse" "glimpse-support")) + (:file "glimpse-process-commands" + :depends-on ("glimpse" "glimpse-support")) + (:file "glimpse-window-commands" + :depends-on ("glimpse" "glimpse-support")))) + (:module "profile" + :components ((:file "profile"))) + (:module "tests" + :components ((:file "drawing-tests") + (:file "graft-tests")))))))) +) + (defsystem :clim-null :depends-on (:clim) :components From rschlatte at common-lisp.net Tue Dec 18 10:54:21 2007 From: rschlatte at common-lisp.net (rschlatte) Date: Tue, 18 Dec 2007 05:54:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle Message-ID: <20071218105421.D2B9A4A000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory clnet:/tmp/cvs-serv30166/Backends/beagle Modified Files: package.lisp Removed Files: beagle-backend.asd Log Message: Beagle backend fixes * functionality not tested, but it loads under clozure cl snapshot * Patches by Greg Pfeil Signed-off-by: Rudi Schlatte --- /project/mcclim/cvsroot/mcclim/Backends/beagle/package.lisp 2006/03/30 12:07:59 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/package.lisp 2007/12/18 10:54:21 1.6 @@ -1,6 +1,8 @@ - ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :cocoa)) + ;;; START - Cribbed from framework/cocoa-support.lisp (in-package "CCL") (defun nslog (c) @@ -24,7 +26,6 @@ #:port-event-process #:port-grafts - #:%set-port-keyboard-focus #:set-sheet-pointer-cursor ;; #:update-mirror-geometry @@ -63,7 +64,6 @@ #:width ;dito #:coordinate= #:get-transformation - #:keyboard-input-focus #:port-grab-pointer #:port-ungrab-pointer ;; @@ -100,4 +100,3 @@ #:with-nsstr) (:export #:beagle-standard-frame-manager #:beagle-aqua-frame-manager)) - \ No newline at end of file From rschlatte at common-lisp.net Tue Dec 18 10:54:22 2007 From: rschlatte at common-lisp.net (rschlatte) Date: Tue, 18 Dec 2007 05:54:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/input Message-ID: <20071218105422.11BBA4A000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/input In directory clnet:/tmp/cvs-serv30166/Backends/beagle/input Modified Files: events.lisp Log Message: Beagle backend fixes * functionality not tested, but it loads under clozure cl snapshot * Patches by Greg Pfeil Signed-off-by: Rudi Schlatte --- /project/mcclim/cvsroot/mcclim/Backends/beagle/input/events.lisp 2006/03/24 11:18:27 1.11 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/input/events.lisp 2007/12/18 10:54:21 1.12 @@ -28,7 +28,7 @@ #|| -$Id: events.lisp,v 1.11 2006/03/24 11:18:27 tmoore Exp $ +$Id: events.lisp,v 1.12 2007/12/18 10:54:21 rschlatte Exp $ Events in Cocoa --------------- @@ -162,9 +162,8 @@ ;;; (there is no event process calling process-next-event). #-(and) (defmethod get-next-event ((port beagle-port) &key wait-function (timeout nil)) - (declare (special *mcclim-event-queue* *beagle-port*) + (declare (special *mcclim-event-queue*) (ignore wait-function)) - (setf *beagle-port* port) ; TODO: don't think this <- is needed. ;; When event queue is empty, wait for an event to be posted. (if (eq timeout nil) (ccl:wait-on-semaphore (beagle-port-event-semaphore port)) @@ -571,9 +570,11 @@ (frame (pane-frame target-sheet)) ;; Works out which sheet *should* be the focus, not which ;; is currently... or at least, so I think. - (focus (climi::keyboard-input-focus frame))) + (focus (port-frame-keyboard-input-focus *beagle-port* + frame))) (unless (null target-sheet) - (setf (port-keyboard-input-focus *beagle-port*) focus)))) + (setf (port-frame-keyboard-input-focus *beagle-port* frame) + focus)))) nil) ((eq :did-expose n-type) (make-instance 'window-repaint-event From rschlatte at common-lisp.net Tue Dec 18 10:54:22 2007 From: rschlatte at common-lisp.net (rschlatte) Date: Tue, 18 Dec 2007 05:54:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/output Message-ID: <20071218105422.9D9544F01A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output In directory clnet:/tmp/cvs-serv30166/Backends/beagle/output Modified Files: fonts.lisp Log Message: Beagle backend fixes * functionality not tested, but it loads under clozure cl snapshot * Patches by Greg Pfeil Signed-off-by: Rudi Schlatte --- /project/mcclim/cvsroot/mcclim/Backends/beagle/output/fonts.lisp 2006/03/23 15:27:24 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/output/fonts.lisp 2007/12/18 10:54:22 1.4 @@ -226,11 +226,11 @@ (text-size medium (string s) :text-style text-style :start start :end end)) (defmethod text-size ((medium beagle-medium) (string string) - &key (text-style (medium-text-style medium)) - (start 0) - ( end (length string))) + &key text-style (start 0) end) (declare (special *default-text-style*)) ;; Check for 'empty string' case + (unless end (setf end (length string))) + (unless text-style (setf text-style (medium-text-style medium))) (when (>= start end) ;; XXX is 0 value for the baseline correct? (return-from text-size (values 0 0 0 0 0))) From rschlatte at common-lisp.net Tue Dec 18 10:54:22 2007 From: rschlatte at common-lisp.net (rschlatte) Date: Tue, 18 Dec 2007 05:54:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/windowing Message-ID: <20071218105422.D8ECF554B7@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory clnet:/tmp/cvs-serv30166/Backends/beagle/windowing Modified Files: port.lisp Log Message: Beagle backend fixes * functionality not tested, but it loads under clozure cl snapshot * Patches by Greg Pfeil Signed-off-by: Rudi Schlatte --- /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/port.lisp 2006/03/24 11:18:27 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/port.lisp 2007/12/18 10:54:22 1.7 @@ -234,3 +234,11 @@ (declare (ignore port)) nil) +(defmethod port-frame-keyboard-input-focus ((port beagle-port) frame) + (declare (ignore frame)) + (beagle-port-key-focus port)) + +(defmethod (setf port-frame-keyboard-input-focus) + (focus (port beagle-port) frame) + (declare (ignore frame)) + (%set-port-keyboard-focus port focus)) From afuchs at common-lisp.net Wed Dec 19 01:15:31 2007 From: afuchs at common-lisp.net (afuchs) Date: Tue, 18 Dec 2007 20:15:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071219011531.949A43D0B6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv17976/Drei Modified Files: lisp-syntax-swank.lisp Log Message: Change the (load (swank::find-module ...)) forms to use swank-require. Suggested by Stelian Ionescu. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/12/11 18:46:27 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/12/19 01:15:31 1.8 @@ -30,8 +30,8 @@ ;; We need these modules loaded. (eval-when (:compile-toplevel :load-toplevel :execute) - (load (swank::find-module "swank-c-p-c")) - (load (swank::find-module "swank-arglists"))) + (swank:swank-require "swank-c-p-c") + (swank:swank-require "swank-arglists")) ;; If this file is loaded, make local Swank the default way of ;; interacting with the image. From afuchs at common-lisp.net Wed Dec 19 01:19:26 2007 From: afuchs at common-lisp.net (afuchs) Date: Tue, 18 Dec 2007 20:19:26 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071219011926.B604A3F011@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv18203 Modified Files: lisp-syntax-swank.lisp Log Message: Use keywords to name modules instead of lower-case strings. Stelian Ionescu again: lc strings mess up the check whether a module is loaded already. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/12/19 01:15:31 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/12/19 01:19:26 1.9 @@ -30,8 +30,8 @@ ;; We need these modules loaded. (eval-when (:compile-toplevel :load-toplevel :execute) - (swank:swank-require "swank-c-p-c") - (swank:swank-require "swank-arglists")) + (swank:swank-require :swank-c-p-c) + (swank:swank-require :swank-arglists)) ;; If this file is loaded, make local Swank the default way of ;; interacting with the image. From thenriksen at common-lisp.net Wed Dec 19 10:22:17 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 19 Dec 2007 05:22:17 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071219102217.23D023702A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv20615 Modified Files: core.lisp Log Message: Forgot to commit this part of my tabify-changes. --- /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/12/10 21:25:12 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/12/19 10:22:16 1.11 @@ -69,7 +69,7 @@ (defun indent-current-line (view point) (indent-line point (proper-line-indentation view point) - (and (indent-tabs-mode (buffer view)) + (and (use-tabs view) (tab-space-count view)))) (defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\))) @@ -178,7 +178,8 @@ function." (do-buffer-region-lines (line mark1 mark2) (let ((indentation (proper-line-indentation view line))) - (indent-line line indentation (tab-space-count view))))) + (indent-line line indentation (and (use-tabs view) + (tab-space-count view)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Wed Dec 19 11:02:01 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 19 Dec 2007 06:02:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20071219110201.C129870DF@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv29422/ESA Modified Files: esa.lisp esa-command-parser.lisp Log Message: Use the default value of the parameter for parameters specified to use the value of the numeric argument, when no numeric argument is provided. Changed Drei command definitions to handle this. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/12/08 08:53:48 1.12 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/12/19 11:01:57 1.13 @@ -353,8 +353,6 @@ "While a command is being run, this symbol will be dynamically bound to the current command processor.") -(defvar *numeric-argument-p* (list nil)) - (defun find-gestures (gestures start-table) (loop with table = (find-command-table start-table) for (gesture . rest) on gestures @@ -623,9 +621,6 @@ (t (values 1 nil (when first-gesture (cons first-gesture gestures))))))) -(defun substitute-numeric-argument-p (command numargp) - (substitute numargp *numeric-argument-p* command :test #'eq)) - (defgeneric process-gestures (command-processor) (:documentation "Process the gestures accumulated in `command-processor', returning T if there are no gestures @@ -655,14 +650,14 @@ (*current-gesture* (first (last gestures)))) (unless (consp command) (setf command (list command))) - (setf command (substitute-numeric-argument-marker command prefix-arg)) - (setf command (substitute-numeric-argument-p command prefix-p)) - (unwind-protect (when (member *unsupplied-argument-marker* command :test #'eq) - (setq command - (funcall - *partial-command-parser* - (command-table command-processor) - *standard-input* command 0))) + ;; 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) @@ -1316,8 +1311,7 @@ (mapcar #'(lambda (arg) (cond ((eq arg *unsupplied-argument-marker*) "unsupplied-argument") - ((or (eq arg *numeric-argument-marker*) - (eq arg *numeric-argument-p*)) + ((eq arg *numeric-argument-marker*) "numeric-argument") (t arg))) command-args))) (terpri stream) @@ -1402,7 +1396,7 @@ #'sort-by-keystrokes #'sort-by-name)))) -(set-key `(com-describe-bindings ,*numeric-argument-p*) 'help-table '((#\h :control) (#\b))) +(set-key `(com-describe-bindings ,*numeric-argument-marker*) 'help-table '((#\h :control) (#\b))) (define-command (com-describe-key :name t :command-table help-table) () --- /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2006/11/08 01:10:16 1.1 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2007/12/19 11:02:00 1.2 @@ -89,7 +89,8 @@ (push (esa-parse-one-arg stream name ptype args) result) (maybe-clear-input))))))))) -(defun esa-partial-command-parser (command-table stream command position) +(defun esa-partial-command-parser (command-table stream command position + &optional numeric-argument) (declare (ignore command-table position)) (let ((command-name (car command)) (command-args (cdr command))) @@ -114,8 +115,10 @@ (command-arg (car command-args) (car command-args))) ((null required-args) (cons command-name (nreverse result))) (destructuring-bind (name ptype &rest args) arg - (push (if (eq command-arg *unsupplied-argument-marker*) - (esa-parse-one-arg stream name ptype args) - command-arg) + (push (cond ((eq command-arg *unsupplied-argument-marker*) + (esa-parse-one-arg stream name ptype args)) + ((eq command-arg *numeric-argument-marker*) + (or numeric-argument (getf args :default))) + (t command-arg)) result) (maybe-clear-input))))))))) From thenriksen at common-lisp.net Wed Dec 19 11:02:11 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 19 Dec 2007 06:02:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071219110211.6BE5F7A00D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29422/Drei Modified Files: unicode-commands.lisp misc-commands.lisp lisp-syntax-commands.lisp editing.lisp core-commands.lisp basic-commands.lisp Log Message: Use the default value of the parameter for parameters specified to use the value of the numeric argument, when no numeric argument is provided. Changed Drei command definitions to handle this. --- /project/mcclim/cvsroot/mcclim/Drei/unicode-commands.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/unicode-commands.lisp 2007/12/19 11:02:01 1.2 @@ -34,7 +34,7 @@ 'self-insert-table (list (code-char i)))) (define-command (com-insert-charcode :name t :command-table self-insert-table) - ((code 'integer :prompt "Code point") (count 'integer)) + ((code 'integer :prompt "Code point") (count 'integer :default 1)) (let ((char (code-char code))) (loop repeat count do (insert-character char)))) --- /project/mcclim/cvsroot/mcclim/Drei/misc-commands.lisp 2007/11/19 20:28:43 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/misc-commands.lisp 2007/12/19 11:02:01 1.4 @@ -32,7 +32,7 @@ (define-command (com-eval-expression :name t :command-table editor-table) ((exp 'expression :prompt "Eval") - (insertp 'boolean :prompt "Insert?")) + (insertp 'boolean :prompt "Insert?" :default nil)) "Prompt for and evaluate a lisp expression. With a numeric argument inserts the result at point as a string; otherwise prints the result." @@ -66,7 +66,7 @@ (chars (abs (- (offset (point)) (offset (mark)))))) (display-message "Region has ~D line~:P, ~D character~:P." (1+ lines) chars))) -(set-key `(com-eval-expression ,*unsupplied-argument-marker* ,*numeric-argument-p*) +(set-key `(com-eval-expression ,*unsupplied-argument-marker* ,*numeric-argument-marker*) 'editor-table '((#\: :shift :meta))) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/12/17 06:47:13 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/12/19 11:02:02 1.14 @@ -70,7 +70,7 @@ t))))) (define-command (com-indent-expression :name t :command-table lisp-table) - ((count 'integer :prompt "Number of expressions")) + ((count 'integer :prompt "Number of expressions" :default 1)) (let ((mark (point))) (if (plusp count) (loop repeat count do (forward-expression mark (current-syntax))) @@ -150,7 +150,7 @@ (eval-region mark point (current-syntax)))) (define-command (com-eval-last-expression :name t :command-table pane-lisp-table) - ((insertp 'boolean :prompt "Insert?")) + ((insertp 'boolean :prompt "Insert?" :default nil)) "Evaluate the expression before point in the local Lisp image." (let ((token (form-before (current-syntax) (offset (point))))) (if token @@ -240,7 +240,7 @@ 'pane-lisp-table '((#\c :control) (#\r :control))) -(set-key `(com-eval-last-expression ,*numeric-argument-p*) +(set-key `(com-eval-last-expression ,*numeric-argument-marker*) 'pane-lisp-table '((#\c :control) (#\e :control))) --- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2007/12/08 08:53:50 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2007/12/19 11:02:02 1.8 @@ -254,7 +254,7 @@ (defun backward-kill-object (mark &optional (count 1) concatenate-p limit-action) "Kill `count' objects backwards beginning from `mark'." (let ((start (offset mark))) - (handler-case (progn (forward-object mark count) + (handler-case (progn (backward-object mark count) (if concatenate-p (if (plusp count) (kill-ring-concatenating-push --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/12/17 06:47:13 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/12/19 11:02:05 1.11 @@ -99,7 +99,7 @@ '((#\z :meta))) (define-command (com-open-line :name t :command-table editing-table) - ((numarg 'integer :prompt "How many lines?")) + ((numarg 'integer :prompt "How many lines?" :default 1)) "Insert a #\Newline and leave point before it. With a numeric argument greater than 1, insert that many #\Newlines." (open-line (point) numarg)) @@ -125,7 +125,7 @@ `(define-command (,(symbol "COM-MARK-" unit) :name t :command-table ,command-table) - ((count 'integer :prompt ,(concat "Number of " plural))) + ((count 'integer :prompt ,(concat "Number of " plural) :default 1)) ,(if (not (null move-point)) (concat "Place point and mark around the current " noun ". Put point at the beginning of the current " noun ", and mark at the end. @@ -349,17 +349,17 @@ (define-command (com-delete-horizontal-space :name t :command-table deletion-table) ((backward-only-p - 'boolean :prompt "Delete backwards only?")) + 'boolean :prompt "Delete backwards only?" :default nil)) "Delete whitespace around point. With a numeric argument, only delete whitespace before point." (delete-horizontal-space (point) (current-syntax) backward-only-p)) -(set-key `(com-delete-horizontal-space ,*numeric-argument-p*) +(set-key `(com-delete-horizontal-space ,*numeric-argument-marker*) 'deletion-table '((#\\ :meta))) (define-command (com-just-one-space :name t :command-table deletion-table) - ((count 'integer :prompt "Number of spaces")) + ((count 'integer :prompt "Number of spaces" :default 1)) "Delete whitespace around point, leaving a single space. With a positive numeric argument, leave that many spaces. @@ -402,7 +402,7 @@ '((#\x :control) (#\x :control))) (define-command (com-sort-lines :name t :command-table editing-table) - ((sort-ascending 'boolean :prompt "Sort in ascending order")) + ((sort-ascending 'boolean :prompt "Sort in ascending order" :default nil)) "Sort the lines in the region delimited by current point and mark. The lines will be lexicographically sorted, ignoring all non-character objects in the lines. When the command is run, it @@ -481,7 +481,7 @@ '((#\y :meta))) (define-command (com-resize-kill-ring :name t :command-table editing-table) - ((size 'integer :prompt "New kill ring size")) + ((size 'integer :prompt "New kill ring size" :default 5)) "Prompt for a new size for the kill ring. The default is 5. A number less than 5 will be replaced by 5." (setf (kill-ring-max-size *kill-ring*) size)) @@ -572,8 +572,8 @@ '((#\/ :meta))) (define-command (com-mark-page :name t :command-table marking-table) - ((count 'integer :prompt "Move how many pages") - (numargp 'boolean :prompt "Move to another page?")) + ((count 'integer :prompt "Move how many pages" :default 1) + (numargp 'boolean :prompt "Move to another page?" :default nil)) "Place point and mark around the current page. With a numeric argument, move point that many pages forward (backward if negative) before marking the @@ -589,7 +589,7 @@ (setf (offset (mark)) (offset (point))) (forward-page (mark) (current-syntax) 1)) -(set-key `(com-mark-page ,*numeric-argument-marker* ,*numeric-argument-p*) +(set-key `(com-mark-page ,*numeric-argument-marker* ,*numeric-argument-marker*) 'marking-table '((#\x :control) (#\p :control))) @@ -608,15 +608,15 @@ (insert-pair mark syntax count #\( #\))) (define-command (com-insert-parentheses :name t :command-table editing-table) - ((count 'integer :prompt "Number of expressions") - (wrap-p 'boolean :prompt "Wrap expressions?")) + ((count 'integer :prompt "Number of expressions" :default 1) + (wrap-p 'boolean :prompt "Wrap expressions?" :default nil)) "Insert a pair of parentheses, leaving point in between. With a numeric argument, enclose that many expressions forward (backward if negative)." (unless wrap-p (setf count 0)) (insert-parentheses (point) (current-syntax) count)) -(set-key `(com-insert-parentheses ,*numeric-argument-marker* ,*numeric-argument-p*) +(set-key `(com-insert-parentheses ,*numeric-argument-marker* ,*numeric-argument-marker*) 'editing-table '((#\( :meta))) --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2007/12/08 08:53:50 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2007/12/19 11:02:05 1.9 @@ -85,7 +85,7 @@ `(PROGN (DEFINE-COMMAND (,com-forward :NAME T :COMMAND-TABLE ,command-table) - ((COUNT 'INTEGER :PROMPT ,(concat "Number of " plural))) + ((COUNT 'INTEGER :PROMPT ,(concat "Number of " plural) :default 1)) ,(concat "Move point forward by one " noun ". With a numeric argument N, move point forward by N " plural ". With a negative argument -N, move point backward by N " plural ".") @@ -93,10 +93,9 @@ (,forward (point) (current-syntax) COUNT))) - (DEFINE-COMMAND (,com-backward - :NAME T + (DEFINE-COMMAND (,com-backward :NAME T :COMMAND-TABLE ,command-table) - ((COUNT 'INTEGER :PROMPT ,(concat "Number of " plural))) + ((COUNT 'INTEGER :PROMPT ,(concat "Number of " plural) :default 1)) ,(concat "Move point backward by one " noun ". With a numeric argument N, move point backward by N " plural ". With a negative argument -N, move point forward by N " plural ".") @@ -119,7 +118,7 @@ ;; and BACKWARD-OBJECT is part of the buffer protocol, not the ;; high-level motion abstraction. (define-command (com-forward-object :name t :command-table movement-table) - ((count 'integer :prompt "Number of objects")) + ((count 'integer :prompt "Number of objects" :default 1)) "Move point forward by one object. With a numeric argument N, move point forward by N objects. With a negative argument -N, move point backward by M objects." @@ -128,7 +127,7 @@ count))) (define-command (com-backward-object :name t :command-table movement-table) - ((count 'integer :prompt "number of objects")) + ((count 'integer :prompt "number of objects" :default 1)) "Move point backward by one object. With a numeric argument N, move point backward by N objects. With a negative argument -N, move point forward by N objects." @@ -278,7 +277,7 @@ ;; Kill Unit (define-command (,com-kill :name t :command-table ,command-table) - ((count 'integer :prompt ,(concat "Number of " plural))) + ((count 'integer :prompt ,(concat "Number of " plural) :default 1)) ,(concat "Kill " plural " up to the next " noun " end. With a numeric argument, kill forward (backward if negative) that many " plural ". @@ -294,7 +293,7 @@ (define-command (,com-backward-kill :name t :command-table ,command-table) - ((count 'integer :prompt ,(concat "Number of " plural))) + ((count 'integer :prompt ,(concat "Number of " plural) :default 1)) ,(concat "Kill from point until the previous " noun " beginning. With a numeric argument, kill backward (forward, if negative) that many " plural ". @@ -308,14 +307,14 @@ ;; Delete Unit (define-command (,com-delete :name t :command-table ,command-table) - ((count 'integer :prompt ,(concat "Number of " plural))) + ((count 'integer :prompt ,(concat "Number of " plural) :default 1)) ,(concat "Delete from point until the next " noun " end. With a positive numeric argument, delete that many " plural " forward.") (,backward-delete (point) (current-syntax) count)) ;; Backward Delete Unit (define-command (,com-backward-delete :name t :command-table ,command-table) - ((count 'integer :prompt ,(concat "Number of " plural))) + ((count 'integer :prompt ,(concat "Number of " plural) :default 1)) ,(concat "Delete from point until the previous " noun " beginning. With a positive numeric argument, delete that many " plural " backward.") (,backward-delete (point) (current-syntax) count))))))) @@ -363,8 +362,8 @@ (transpose-objects (point))) (define-command (com-delete-object :name t :command-table deletion-table) - ((count 'integer :prompt "Number of Objects") - (killp 'boolean :prompt "Kill?")) + ((count 'integer :prompt "Number of Objects" :default 1) + (killp 'boolean :prompt "Kill?" :default nil)) "Delete the object after point. With a numeric argument, kill that many objects after (or before, if negative) point." @@ -374,8 +373,8 @@ (forward-delete-object (point) count)))) (define-command (com-backward-delete-object :name t :command-table deletion-table) - ((count 'integer :prompt "Number of Objects") - (killp 'boolean :prompt "Kill?")) + ((count 'integer :prompt "Number of Objects" :default 1) + (killp 'boolean :prompt "Kill?" :default nil)) "Delete the object before point. With a numeric argument, kills that many objects before (or after, if negative) point." @@ -415,8 +414,8 @@ (delete-region start mark)))) (define-command (com-kill-line :name t :command-table deletion-table) - ((numarg 'integer :prompt "Kill how many lines?") - (numargp 'boolean :prompt "Kill entire lines?")) + ((numarg 'integer :prompt "Kill how many lines?" :default 1) + (numargp 'boolean :prompt "Kill entire lines?" :default nil)) "Kill the objects on the current line after point. When at the end of a line, kill the #\\Newline. With a numeric argument of 0, kill the objects on the current line before point. @@ -456,17 +455,17 @@ '((#\x :control) (#\t :control))) (set-key `(com-delete-object ,*numeric-argument-marker* - ,*numeric-argument-p*) + ,*numeric-argument-marker*) 'deletion-table '(#\Rubout)) (set-key `(com-delete-object ,*numeric-argument-marker* - ,*numeric-argument-p*) + ,*numeric-argument-marker*) 'deletion-table '((#\d :control))) (set-key `(com-backward-delete-object ,*numeric-argument-marker* - ,*numeric-argument-p*) + ,*numeric-argument-marker*) 'deletion-table '(#\Backspace)) @@ -474,7 +473,7 @@ 'editing-table '((#\t :control))) -(set-key `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*) +(set-key `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-marker*) 'deletion-table '((#\k :control))) @@ -485,7 +484,7 @@ ;;; These are what do the basic keypress->character inserted in buffer ;;; mapping. -(define-command com-self-insert ((count 'integer)) +(define-command com-self-insert ((count 'integer :default 1)) (loop repeat count do (insert-character *current-gesture*))) (loop for code from (char-code #\Space) to (char-code #\~) From thenriksen at common-lisp.net Wed Dec 19 15:10:20 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 19 Dec 2007 10:10:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20071219151020.D74EF5556E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv18011/ESA Modified Files: packages.lisp Log Message: *numeric-argument-p* no longer exists, so don't export it. --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2007/12/08 08:53:48 1.6 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2007/12/19 15:10:20 1.7 @@ -59,7 +59,7 @@ #:esa-pane-mixin #:previous-command #:info-pane #:master-pane #:esa-frame-mixin #:recordingp #:executingp - #:*esa-abort-gestures* #:*numeric-argument-p* #:*current-gesture* #:*command-processor* + #:*esa-abort-gestures* #:*current-gesture* #:*command-processor* #:unbound-gesture-sequence #:gestures #:command-processor #:instant-macro-execution-mixin #:asynchronous-command-processor #:command-loop-command-processor From thenriksen at common-lisp.net Wed Dec 19 17:17:37 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 19 Dec 2007 12:17:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20071219171737.7362672095@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv9380/Drei/Tests Modified Files: lisp-syntax-tests.lisp motion-tests.lisp Log Message: Added a bunch of neat convenience functions to Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/12/08 08:53:48 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/12/19 17:17:37 1.9 @@ -834,7 +834,10 @@ (motion-fun-one-test up (nil nil (13 14 12) "(defun list () (&rest elements) -(append elements nil))" :syntax lisp-syntax)) +(append elements nil))" :syntax lisp-syntax) + (nil nil (17 19 12) + "(defun list (x y z) +(list x y z))" :syntax lisp-syntax)) (motion-fun-one-test definition (51 52 (35 51 0) "(defun list (&rest elements) @@ -844,12 +847,12 @@ (test in-string-p "Test the `in-string-p' function of Lisp syntax." (testing-lisp-syntax (" \"foobar!\" ") - (is-false (drei-lisp-syntax::in-string-p 0 (current-syntax))) - (is-false (drei-lisp-syntax::in-string-p 1 (current-syntax))) - (is-true (drei-lisp-syntax::in-string-p 2 (current-syntax))) - (is-true (drei-lisp-syntax::in-string-p 6 (current-syntax))) - (is-true (drei-lisp-syntax::in-string-p 9 (current-syntax))) - (is-false (drei-lisp-syntax::in-string-p 10 (current-syntax))))) + (is-false (in-string-p (current-syntax) 0)) + (is-false (in-string-p (current-syntax) 1)) + (is-true (in-string-p (current-syntax) 2)) + (is-true (in-string-p (current-syntax) 6)) + (is-true (in-string-p (current-syntax) 9)) + (is-false (in-string-p (current-syntax) 10)))) (test in-comment-p "Test the `in-comment-p' function of Lisp syntax." @@ -858,17 +861,98 @@ #| I'm a - BLOCK - comment |#") - (is-false (drei-lisp-syntax::in-comment-p 0 (current-syntax))) - (is-false (drei-lisp-syntax::in-comment-p 1 (current-syntax))) - (is-true (drei-lisp-syntax::in-comment-p 2 (current-syntax))) - (is-false (drei-lisp-syntax::in-comment-p 16 (current-syntax))) - (is-false (drei-lisp-syntax::in-comment-p 17 (current-syntax))) - (is-true (drei-lisp-syntax::in-comment-p 18 (current-syntax))) - (is-false (drei-lisp-syntax::in-comment-p 40 (current-syntax))) - (is-true (drei-lisp-syntax::in-comment-p 41 (current-syntax))) - (is-true (drei-lisp-syntax::in-comment-p 50 (current-syntax))) - (is-true (drei-lisp-syntax::in-comment-p 60 (current-syntax))) - (is-false (drei-lisp-syntax::in-comment-p 69 (current-syntax))))) + (is-false (in-comment-p (current-syntax) 0)) + (is-false (in-comment-p (current-syntax) 1)) + (is-true (in-comment-p (current-syntax) 2)) + (is-true (in-comment-p (current-syntax) 16)) + (is-false (in-comment-p (current-syntax) 17)) + (is-true (in-comment-p (current-syntax) 18)) + (is-false (in-comment-p (current-syntax) 40)) + (is-false (in-comment-p (current-syntax) 41)) + (is-true (in-comment-p (current-syntax) 50)) + (is-true (in-comment-p (current-syntax) 60)) + (is-false (in-comment-p (current-syntax) 68)) + (is-false (in-comment-p (current-syntax) 69)))) + +(test in-character-p + "Test the `in-character-p' function of Lisp syntax." + (testing-lisp-syntax ("#\\C #\\( +#\\# +#\\ +hello") + (is-false (in-character-p (current-syntax) 0)) + (is-false (in-character-p (current-syntax) 1)) + (is-true (in-character-p (current-syntax) 2)) + (is-false (in-character-p (current-syntax) 4)) + (is-false (in-character-p (current-syntax) 5)) + (is-true (in-character-p (current-syntax) 6)) + (is-true (in-character-p (current-syntax) 10)) + (is-true (in-character-p (current-syntax) 14)) + (is-false (in-character-p (current-syntax) 16)))) + +(test location-at-beginning-of-form-list + "Test the `location-at-beginning-of-form' function for lists." + (testing-lisp-syntax ("(a b c (d e f) g") + (is-false (location-at-beginning-of-form (current-syntax) 0)) + (is-true (location-at-beginning-of-form (current-syntax) 1)) + (is-false (location-at-beginning-of-form (current-syntax) 2)) + (is-false (location-at-beginning-of-form (current-syntax) 7)) + (is-true (location-at-beginning-of-form (current-syntax) 8)))) + +(test location-at-end-of-form-list + "Test the `location-at-end-of-form' function for lists." + (testing-lisp-syntax ("(a b c (d e f) g)") + (is-false (location-at-end-of-form (current-syntax) 0)) + (is-false (location-at-end-of-form (current-syntax) 1)) + (is-false (location-at-end-of-form (current-syntax) 12)) + (is-true (location-at-end-of-form (current-syntax) 13)) + (is-false (location-at-end-of-form (current-syntax) 14)) + (is-true (location-at-end-of-form (current-syntax) 16)))) + +(test location-at-beginning-of-form-string + "Test the `location-at-beginning-of-form' function for strings." + (testing-lisp-syntax ("\"a b c \"d e f\" g") + (is-false (location-at-beginning-of-form (current-syntax) 0)) + (is-true (location-at-beginning-of-form (current-syntax) 1)) + (is-false (location-at-beginning-of-form (current-syntax) 2)) + (is-false (location-at-beginning-of-form (current-syntax) 7)) + (is-false (location-at-beginning-of-form (current-syntax) 8)) + (is-true (location-at-beginning-of-form (current-syntax) 14)) + (is-false (location-at-beginning-of-form (current-syntax) 15)))) + +(test location-at-end-of-form-string + "Test the `location-at-end-of-form' function for strings." + (testing-lisp-syntax ("\"a b c \"d e f\" g)\"") + (is-false (location-at-end-of-form (current-syntax) 0)) + (is-false (location-at-end-of-form (current-syntax) 1)) + (is-false (location-at-end-of-form (current-syntax) 6)) + (is-true (location-at-end-of-form (current-syntax) 7)) + (is-false (location-at-end-of-form (current-syntax) 8)) + (is-false (location-at-end-of-form (current-syntax) 16)) + (is-true (location-at-end-of-form (current-syntax) 17)) + (is-false (location-at-end-of-form (current-syntax) 18)))) + +(test location-at-beginning-of-form-simple-vector + "Test the `location-at-beginning-of-form' function for simple +vectors." + (testing-lisp-syntax ("#(a b c #(d e f) g") + (is-false (location-at-beginning-of-form (current-syntax) 0)) + (is-false (location-at-beginning-of-form (current-syntax) 1)) + (is-true (location-at-beginning-of-form (current-syntax) 2)) + (is-false (location-at-beginning-of-form (current-syntax) 3)) + (is-false (location-at-beginning-of-form (current-syntax) 9)) + (is-true (location-at-beginning-of-form (current-syntax) 10)))) + +(test location-at-end-of-form-simple-vector + "Test the `location-at-end-of-form' function for simple-vectors." + (testing-lisp-syntax ("#(a b c #(d e f) g)") + (is-false (location-at-end-of-form (current-syntax) 0)) + (is-false (location-at-end-of-form (current-syntax) 1)) + (is-false (location-at-end-of-form (current-syntax) 2)) + (is-false (location-at-end-of-form (current-syntax) 14)) + (is-true (location-at-end-of-form (current-syntax) 15)) + (is-false (location-at-end-of-form (current-syntax) 16)) + (is-true (location-at-end-of-form (current-syntax) 18)))) ;; For some tests, we need various functions, classes and ;; macros. Define them here and pray we don't clobber anything --- /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/12/08 08:53:48 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/12/19 17:17:37 1.6 @@ -86,74 +86,79 @@ (backward-to-word-boundary m2r syntax) (is (= (offset m2r) 0)))))) -(defmacro motion-fun-one-test (unit (forward-begin-offset - backward-end-offset - (offset goal-forward-offset goal-backward-offset) - initial-contents - &key (syntax 'drei-fundamental-syntax:fundamental-syntax))) - (check-type forward-begin-offset (or integer null)) - (check-type backward-end-offset (or integer null)) - (check-type offset integer) - (check-type goal-forward-offset integer) - (check-type goal-backward-offset integer) +(defmacro motion-fun-one-test (unit &rest test-specs) (let ((forward (intern (format nil "FORWARD-ONE-~S" unit))) (backward (intern (format nil "BACKWARD-ONE-~S" unit)))) `(progn - (test ,(intern (format nil "~A-~A" syntax forward) #.*package*) - (with-buffer (buffer :initial-contents ,initial-contents) - (with-view (view :buffer buffer :syntax ',syntax) - (let ((syntax (syntax view)) - (m0l (make-buffer-mark buffer 0 :left)) - (m0r (make-buffer-mark buffer 0 :right)) - (m1l (make-buffer-mark buffer ,offset :left)) - (m1r (make-buffer-mark buffer ,offset :right)) - (m2l (make-buffer-mark buffer (size buffer) :left)) - (m2r (make-buffer-mark buffer (size buffer) :right))) - (declare (ignore ,@(unless forward-begin-offset '(m0l)) - ,@(unless backward-end-offset '(m0r)))) - ,(when forward-begin-offset - `(progn - (is-true (,forward m0l syntax)) - (is (= ,forward-begin-offset (offset m0l))))) - ,(when backward-end-offset - `(progn - (is-true (,forward m0r syntax)) - (is (= ,forward-begin-offset (offset m0r))))) - (is-true (,forward m1l syntax)) - (is (= ,goal-forward-offset (offset m1l))) - (is-true (,forward m1r syntax)) - (is (= ,goal-forward-offset (offset m1r))) - (is-false (,forward m2l syntax)) - (is (= (size buffer) (offset m2l))) - (is-false (,forward m2r syntax)) - (is (= (size buffer) (offset m2r))))))) - (test ,(intern (format nil "~A-~A" syntax backward) #.*package*) - (with-buffer (buffer :initial-contents ,initial-contents) - (with-view (view :buffer buffer :syntax ',syntax) - (let ((syntax (syntax view)) - (m0l (make-buffer-mark buffer 0 :left)) - (m0r (make-buffer-mark buffer 0 :right)) - (m1l (make-buffer-mark buffer ,offset :left)) - (m1r (make-buffer-mark buffer ,offset :right)) - (m2l (make-buffer-mark buffer (size buffer) :left)) - (m2r (make-buffer-mark buffer (size buffer) :right))) - (declare (ignore ,@(unless backward-end-offset '(m2l m2r)))) - (is-false (,backward m0l syntax)) - (is (= 0 (offset m0l))) - (is-false (,backward m0r syntax)) - (is (= 0 (offset m0r))) - (is-true (,backward m1l syntax)) - (is (= ,goal-backward-offset (offset m1l))) - (is-true (,backward m1r syntax)) - (is (= ,goal-backward-offset (offset m1r))) - ,(when backward-end-offset - `(progn - (is-true (,backward m2l syntax)) - (is (= ,backward-end-offset (offset m2l))))) - ,(when backward-end-offset - `(progn - (is-true (,backward m2r syntax)) - (is (= ,backward-end-offset (offset m2r)))))))))))) + ,@(loop for test in test-specs + nconc + (destructuring-bind (forward-begin-offset + backward-end-offset + (offset goal-forward-offset goal-backward-offset) + initial-contents + &key (syntax 'drei-fundamental-syntax::fundamental-syntax)) + test + (check-type forward-begin-offset (or integer null)) + (check-type backward-end-offset (or integer null)) + (check-type offset integer) + (check-type goal-forward-offset integer) + (check-type goal-backward-offset integer) + (list + `(test ,(intern (format nil "~A-~A" syntax forward) #.*package*) + (with-buffer (buffer :initial-contents ,initial-contents) + (with-view (view :buffer buffer :syntax ',syntax) + (let ((syntax (syntax view)) + (m0l (make-buffer-mark buffer 0 :left)) + (m0r (make-buffer-mark buffer 0 :right)) + (m1l (make-buffer-mark buffer ,offset :left)) + (m1r (make-buffer-mark buffer ,offset :right)) + (m2l (make-buffer-mark buffer (size buffer) :left)) + (m2r (make-buffer-mark buffer (size buffer) :right))) + (declare (ignore ,@(unless forward-begin-offset '(m0l)) + ,@(unless backward-end-offset '(m0r)))) + ,(when forward-begin-offset + `(progn + (is-true (,forward m0l syntax)) + (is (= ,forward-begin-offset (offset m0l))))) + ,(when backward-end-offset + `(progn + (is-true (,forward m0r syntax)) + (is (= ,forward-begin-offset (offset m0r))))) + (is-true (,forward m1l syntax)) + (is (= ,goal-forward-offset (offset m1l))) + (is-true (,forward m1r syntax)) + (is (= ,goal-forward-offset (offset m1r))) + (is-false (,forward m2l syntax)) + (is (= (size buffer) (offset m2l))) + (is-false (,forward m2r syntax)) + (is (= (size buffer) (offset m2r))))))) + `(test ,(intern (format nil "~A-~A" syntax backward) #.*package*) + (with-buffer (buffer :initial-contents ,initial-contents) + (with-view (view :buffer buffer :syntax ',syntax) + (let ((syntax (syntax view)) + (m0l (make-buffer-mark buffer 0 :left)) + (m0r (make-buffer-mark buffer 0 :right)) + (m1l (make-buffer-mark buffer ,offset :left)) + (m1r (make-buffer-mark buffer ,offset :right)) + (m2l (make-buffer-mark buffer (size buffer) :left)) + (m2r (make-buffer-mark buffer (size buffer) :right))) + (declare (ignore ,@(unless backward-end-offset '(m2l m2r)))) + (is-false (,backward m0l syntax)) + (is (= 0 (offset m0l))) + (is-false (,backward m0r syntax)) + (is (= 0 (offset m0r))) + (is-true (,backward m1l syntax)) + (is (= ,goal-backward-offset (offset m1l))) + (is-true (,backward m1r syntax)) + (is (= ,goal-backward-offset (offset m1r))) + ,(when backward-end-offset + `(progn + (is-true (,backward m2l syntax)) + (is (= ,backward-end-offset (offset m2l))))) + ,(when backward-end-offset + `(progn + (is-true (,backward m2r syntax)) + (is (= ,backward-end-offset (offset m2r))))))))))))))) (motion-fun-one-test word (9 10 (5 9 2) " climacs From thenriksen at common-lisp.net Wed Dec 19 17:17:37 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 19 Dec 2007 12:17:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071219171737.D05CC7320B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9380/Drei Modified Files: lisp-syntax.lisp lr-syntax.lisp packages.lisp views.lisp Log Message: Added a bunch of neat convenience functions to Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/13 07:30:37 1.36 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/19 17:17:37 1.37 @@ -1315,6 +1315,10 @@ "Returns the third formw in list." (nth-form 2 list)) +(defun form-children (form) + "Return the children of `form' that are themselves forms." + (remove-if-not #'formp (children form))) + (defgeneric form-operator (syntax form) (:documentation "Return the operator of `form' as a token. Returns nil if none can be found.") @@ -1448,6 +1452,9 @@ (define-form-predicate form-comma-p (comma-form)) (define-form-predicate form-comma-at-p (comma-at-form)) (define-form-predicate form-comma-dot-p (comma-dot-form)) +(define-form-predicate form-character-p (complete-character-lexeme + incomplete-character-lexeme)) +(define-form-predicate form-simple-vector-p (simple-vector-form)) (define-form-predicate comment-p (comment)) @@ -1460,6 +1467,176 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Asking about parse state at some point + +(defun in-type-p-in-children (children offset type) + (loop for child in children + do (cond ((<= (start-offset child) offset (end-offset child)) + (return (if (typep child type) + child + (in-type-p-in-children (children child) offset type)))) + ((<= offset (start-offset child)) + (return nil)) + (t nil)))) + +(defun in-type-p (syntax mark-or-offset type) + (as-offsets ((offset mark-or-offset)) + (update-parse syntax 0 offset) + (with-slots (stack-top) syntax + (if (or (null (start-offset stack-top)) + (> offset (end-offset stack-top)) + (< offset (start-offset stack-top))) + nil + (in-type-p-in-children (children stack-top) offset type))))) + +(defun in-string-p (syntax mark-or-offset) + "Return true if `mark-or-offset' is inside a Lisp string." + (as-offsets ((offset mark-or-offset)) + (let ((string (in-type-p syntax offset 'string-form))) + (and string + (< (start-offset string) offset) + (< offset (end-offset string)))))) + +(defun in-comment-p (syntax mark-or-offset) + "Return true if `mark-or-offset' is inside a Lisp +comment (line-based or long form)." + (as-offsets ((offset mark-or-offset)) + (let ((comment (in-type-p syntax mark-or-offset 'comment))) + (and comment + (or (when (typep comment 'line-comment-form) + (< (start-offset comment) offset)) + (when (typep comment 'complete-long-comment-form) + (< (1+ (start-offset comment) ) offset + (1- (end-offset comment)))) + (when (typep comment 'incomplete-long-comment-form) + (< (1+ (start-offset comment)) offset))))))) + +(defun in-character-p (syntax mark-or-offset) + "Return true if `mark-or-offset' is inside a Lisp character lexeme." + (as-offsets ((offset mark-or-offset)) + (let ((form (form-around syntax offset))) + (typecase form + (complete-character-lexeme + (> (end-offset form) offset (+ (start-offset form) 1))) + (incomplete-character-lexeme + (= offset (end-offset form))))))) + +(defgeneric at-beginning-of-form-p (syntax form offset) + (:documentation "Return true if `offset' is at the beginning of +the list-like `form', false otherwise. \"Beginning\" is defined +at the earliest point the contents could be entered, for example +right after the opening parenthesis for a list.") + (:method ((syntax lisp-syntax) (form form) (offset integer)) + nil) + (:method :before ((syntax lisp-syntax) (form form) (offset integer)) + (update-parse syntax 0 offset))) + +(defgeneric at-end-of-form-p (syntax form offset) + (:documentation "Return true if `offset' is at the end of the +list-like `form', false otherwise.") + (:method ((syntax lisp-syntax) (form form) (offset integer)) + nil) + (:method :before ((syntax lisp-syntax) (form form) (offset integer)) + (update-parse syntax 0 offset))) + +(defmethod at-beginning-of-form-p ((syntax lisp-syntax) (form list-form) + (offset integer)) + (= offset (1+ (start-offset form)))) + +(defmethod at-end-of-form-p ((syntax lisp-syntax) (form list-form) + (offset integer)) + (= offset (1- (end-offset form)))) + +(defmethod at-beginning-of-form-p ((syntax lisp-syntax) (form string-form) + (offset integer)) + (= offset (1+ (start-offset form)))) + +(defmethod at-end-of-form-p ((syntax lisp-syntax) (form string-form) + (offset integer)) + (= offset (1- (end-offset form)))) + +(defmethod at-beginning-of-form-p ((syntax lisp-syntax) (form simple-vector-form) + (offset integer)) + (= offset (+ 2 (start-offset form)))) + +(defmethod at-end-of-form-p ((syntax lisp-syntax) (form simple-vector-form) + (offset integer)) + (= offset (1- (end-offset form)))) + +(defun location-at-beginning-of-form (syntax mark-or-offset) + "Return true if the position `mark-or-offset' is at the +beginning of some structural form, false otherwise. \"Beginning\" +is defined by what type of form is at `mark-or-offset', but for a +list form, it would be right after the opening parenthesis." + (as-offsets ((offset mark-or-offset)) + (update-parse syntax 0 offset) + (let ((form-around (form-around syntax offset))) + (when form-around + (labels ((recurse (form) + (or (at-beginning-of-form-p syntax form offset) + (unless (form-at-top-level-p form) + (recurse (parent form)))))) + (recurse form-around)))))) + +(defun location-at-end-of-form (syntax mark-or-offset) + "Return true if the position `mark-or-offset' is at the +end of some structural form, false otherwise. \"End\" +is defined by what type of form is at `mark-or-offset', but for a +list form, it would be right before the closing parenthesis." + (as-offsets ((offset mark-or-offset)) + (update-parse syntax 0 offset) + (let ((form-around (form-around syntax offset))) + (when form-around + (labels ((recurse (form) + (or (at-end-of-form-p syntax form offset) + (unless (form-at-top-level-p form) + (recurse (parent form)))))) + (recurse form-around)))))) + +(defun at-beginning-of-list-p (syntax mark-or-offset) + "Return true if the position `mark-or-offset' is at the +beginning of a list-like form, false otherwise. \"Beginning\" is +defined as the earliest point the contents could be entered, for +example right after the opening parenthesis for a list." + (as-offsets ((offset mark-or-offset)) + (update-parse syntax 0 offset) + (let ((form-around (form-around syntax offset))) + (when (form-list-p form-around) + (at-beginning-of-form-p syntax form-around offset))))) + +(defun at-end-of-list-p (syntax mark-or-offset) + "Return true if the position `mark-or-offset' is at the end of +a list-like form, false otherwise. \"End\" is defined as the +latest point the contents could be entered, for example right +before the closing parenthesis for a list." + (as-offsets ((offset mark-or-offset)) + (update-parse syntax 0 offset) + (let ((form-around (form-around syntax offset))) + (when (form-list-p form-around) + (at-end-of-form-p syntax (form-around syntax offset) offset))))) + +(defun at-beginning-of-string-p (syntax mark-or-offset) + "Return true if the position `mark-or-offset' is at the +beginning of a string form, false otherwise. \"Beginning\" is +right after the opening double-quote." + (as-offsets ((offset mark-or-offset)) + (update-parse syntax 0 offset) + (let ((form-around (form-around syntax offset))) + (when (form-string-p form-around) + (at-beginning-of-form-p syntax form-around offset))))) + +(defun at-end-of-string-p (syntax mark-or-offset) + "Return true if the position `mark-or-offset' is at the end of +a list-like form, false otherwise. \"End\" is right before the +ending double-quote." + (as-offsets ((offset mark-or-offset)) + (update-parse syntax 0 offset) + (let ((form-around (form-around syntax offset))) + (when (form-string-p form-around) + (at-end-of-form-p syntax form-around offset))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Useful functions for modifying forms based on the mark. (defgeneric replace-symbol-at-mark (syntax mark string) @@ -1832,7 +2009,7 @@ a list parent cannot be found, return nil" (let ((parent (parent form))) (typecase parent - (list-form (funcall fn form)) + (list-form (funcall fn parent)) ((or form* null) nil) (t (find-list-parent-offset parent fn))))) @@ -1956,31 +2133,6 @@ do (setf (offset mark) (end-offset form)) and do (return t)))) -(defun in-type-p-in-children (children offset type) - (loop for child in children - do (cond ((< (start-offset child) offset (end-offset child)) - (return (if (typep child type) - child - (in-type-p-in-children (children child) offset type)))) - ((<= offset (start-offset child)) - (return nil)) - (t nil)))) - -(defun in-type-p (mark-or-offset syntax type) - (as-offsets ((offset mark-or-offset)) - (with-slots (stack-top) syntax - (if (or (null (start-offset stack-top)) - (>= offset (end-offset stack-top)) - (<= offset (start-offset stack-top))) - nil) - (in-type-p-in-children (children stack-top) offset type)))) - -(defun in-string-p (mark-or-offset syntax) - (in-type-p mark-or-offset syntax 'string-form)) - -(defun in-comment-p (mark-or-offset syntax) - (in-type-p mark-or-offset syntax 'comment)) - (defmethod eval-defun ((mark mark) (syntax lisp-syntax)) (with-slots (stack-top) syntax (loop for form in (children stack-top) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2007/12/10 21:25:12 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2007/12/19 17:17:37 1.5 @@ -84,7 +84,7 @@ (defclass parser-symbol () ((start-mark :initform nil :initarg :start-mark :reader start-mark) - (size :initform nil :initarg :size) + (size :initform nil :initarg :size :reader size) (parent :initform nil :accessor parent) (children :initform '() :initarg :children :reader children) (preceding-parse-tree :initform nil :reader preceding-parse-tree) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/18 08:39:43 1.22 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/19 17:17:37 1.23 @@ -492,12 +492,49 @@ :drei-syntax :drei-fundamental-syntax :flexichain :drei :drei-motion :drei-editing :esa-utils :esa :drei-core :esa-io :drei-lr-syntax) - (:export #:lisp-syntax + (:export #:lisp-syntax #:lisp-table #:lisp-string #:edit-definition #:form #:form-to-object + ;; Selecting forms based on mark + #:form-around #:form-before #:form-after + #:expression-at-mark + #:definition-at-mark + #:symbol-at-mark + #:fully-quoted-form + #:fully-unquoted-form + #:this-form + + ;; Querying forms + #:formp #:form-list-p + #:form-incomplete-p #:form-complete-p + #:form-token-p #:form-string-p + #:form-quoted-p + #:form-comma-p #:form-comma-at-p #:form-comma-dot-p + #:form-character-p + #:form-simple-vector-p + #:comment-p + #:form-at-top-level-p + + ;; Querying form data + #:form-children + #:form-operator #:form-operands + #:form-toplevel + #:form-operator-p + + ;; Querying about state at mark + #:in-string-p + #:in-comment-p + #:in-character-p + #:location-at-beginning-of-form + #:location-at-end-of-form + #:at-beginning-of-list-p + #:at-end-of-list-p + #:at-beginning-of-string-p + #:at-end-of-string-p + ;; Lambda list classes. #:lambda-list #:semiordinary-lambda-list --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/18 08:39:43 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/19 17:17:37 1.7 @@ -520,7 +520,11 @@ (%suffix-size :accessor suffix-size :initform 0 :documentation "The number of unchanged objects -at the end of the buffer.")) +at the end of the buffer.") + (%recorded-buffer-size :accessor buffer-size + :initform 0 + :documentation "The size of the buffer +the last time the view was synchronized.")) (:documentation "A buffer-view that maintains a parse tree of the buffer, or otherwise pays attention to the syntax of the buffer.")) @@ -552,6 +556,7 @@ (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) @@ -559,6 +564,7 @@ view-syntax (make-syntax-for-view view (class-of view-syntax)) prefix-size 0 suffix-size 0 + buffer-size (size buffer) ;; Also set the top and bot marks. top (make-buffer-mark buffer 0 :left) bot (make-buffer-mark buffer (size buffer) :right)) @@ -573,7 +579,8 @@ ;; We need to reparse the buffer completely. Might as well do it ;; now. (setf (prefix-size view) 0 - (suffix-size view) 0) + (suffix-size view) 0 + (buffer-size view) (size (buffer view))) (synchronize-view view :force-p t)) (defmethod observer-notified ((view drei-syntax-view) (buffer drei-buffer) @@ -588,7 +595,8 @@ (defmethod synchronize-view :around ((view drei-syntax-view) &key force-p) ;; If nothing changed, then don't call the other methods. - (unless (and (= (prefix-size view) (suffix-size view) (size (buffer view))) + (unless (and (= (prefix-size view) (suffix-size view) + (size (buffer view)) (buffer-size view)) (not force-p)) (call-next-method))) @@ -603,7 +611,8 @@ ;; Reset here so if `update-syntax' calls `update-parse' itself, ;; we won't end with infinite recursion. (setf (prefix-size view) (size (buffer view)) - (suffix-size view) (size (buffer view))) + (suffix-size view) (size (buffer view)) + (buffer-size view) (size (buffer view))) (update-syntax (syntax view) prefix-size suffix-size begin end))) From thenriksen at common-lisp.net Thu Dec 20 08:07:16 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 20 Dec 2007 03:07:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071220080716.AFD35490AD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8545 Modified Files: mcclim.asd Log Message: Made base.lisp depend on delegating-buffer.lisp --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/18 10:54:21 1.64 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/20 08:07:16 1.65 @@ -286,9 +286,11 @@ (:module "Drei" :depends-on ("cl-automaton" "Persistent") :components ((:file "packages") (:file "buffer" :depends-on ("packages")) + (:file "delegating-buffer" :depends-on ("packages" "buffer")) (:file "motion" :depends-on ("packages" "buffer" "syntax")) (:file "editing" :depends-on ("packages" "buffer" "syntax" "motion" "kill-ring")) - (:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring")) + (:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring" + "delegating-buffer")) (:file "syntax" :depends-on ("packages" "buffer" "base")) (:file "views" :depends-on ("packages" "buffer" "base" "syntax" "persistent-undo" "persistent-buffer" "undo" "abbrev" @@ -300,7 +302,6 @@ (:file "abbrev" :depends-on ("packages")) (:file "kill-ring" :depends-on ("packages")) (:file "undo" :depends-on ("packages")) - (:file "delegating-buffer" :depends-on ("packages" "buffer")) (:file "basic-commands" :depends-on ("drei-clim" "motion" "editing")) (:file "core" :depends-on ("drei")) (:file "fundamental-syntax" :depends-on ("packages" "drei-redisplay" "core")) From thenriksen at common-lisp.net Thu Dec 20 10:33:35 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 20 Dec 2007 05:33:35 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20071220103335.C1A38405F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv4077/Apps/Inspector Modified Files: inspector.lisp Log Message: Fixed some problems with retrieving forms in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2007/12/08 11:18:20 1.36 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2007/12/20 10:33:35 1.37 @@ -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 Thu Dec 20 10:33:36 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 20 Dec 2007 05:33:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20071220103336.0641570E1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv4077/Drei/Tests Modified Files: lisp-syntax-tests.lisp motion-tests.lisp Log Message: Fixed some problems with retrieving forms in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/12/19 17:17:37 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/12/20 10:33:35 1.10 @@ -820,29 +820,36 @@ (buffer-is "(with-output-to-string (s \"foo\" :element-type 'character ") (is (= 45 (offset mark)))))) -(motion-fun-one-test expression (51 0 (11 28 7) - "(defun list (&rest elements) -(append elements nil))" :syntax lisp-syntax)) - -(motion-fun-one-test list (64 4 (22 41 11) - "foo (defun (barbaz) list (&rest elements) -(append elements nil))" :syntax lisp-syntax)) - -(motion-fun-one-test down (1 53 (15 16 13) - "(defun list () (&rest elements) -(append elements nil))" :syntax lisp-syntax)) - -(motion-fun-one-test up (nil nil (13 14 12) - "(defun list () (&rest elements) -(append elements nil))" :syntax lisp-syntax) - (nil nil (17 19 12) - "(defun list (x y z) -(list x y z))" :syntax lisp-syntax)) - -(motion-fun-one-test definition (51 52 (35 51 0) - "(defun list (&rest elements) -(append elements nil)) (defun second (list) (cadr list))" -:syntax lisp-syntax)) +(motion-fun-one-test (expression lisp-syntax) + (51 0 (11 28 7) + "(defun list (&rest elements) +(append elements nil))")) + +(motion-fun-one-test (list lisp-syntax) + (64 4 (22 41 11) + "foo (defun (barbaz) list (&rest elements) +(append elements nil))")) + +(motion-fun-one-test (down lisp-syntax) + (1 53 (15 16 13) + "(defun list () (&rest elements) +(append elements nil))")) + +(motion-fun-one-test (up lisp-syntax) + (nil nil (13 14 12) + "(defun list () (&rest elements) +(append elements nil))") + (nil nil (17 19 12) + "(defun list (x y z) +(list x y z))" ) + (nil nil (21 24 0) + "(defun list (x y z) + )")) + +(motion-fun-one-test (definition lisp-syntax) + (51 52 (35 51 0) + "(defun list (&rest elements) +(append elements nil)) (defun second (list) (cadr list))")) (test in-string-p "Test the `in-string-p' function of Lisp syntax." --- /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/12/19 17:17:37 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/12/20 10:33:35 1.7 @@ -86,96 +86,106 @@ (backward-to-word-boundary m2r syntax) (is (= (offset m2r) 0)))))) -(defmacro motion-fun-one-test (unit &rest test-specs) +(defmacro motion-fun-one-test ((unit &optional (syntax 'drei-fundamental-syntax::fundamental-syntax)) + &body test-specs) (let ((forward (intern (format nil "FORWARD-ONE-~S" unit))) (backward (intern (format nil "BACKWARD-ONE-~S" unit)))) `(progn ,@(loop for test in test-specs nconc - (destructuring-bind (forward-begin-offset - backward-end-offset - (offset goal-forward-offset goal-backward-offset) - initial-contents - &key (syntax 'drei-fundamental-syntax::fundamental-syntax)) - test - (check-type forward-begin-offset (or integer null)) - (check-type backward-end-offset (or integer null)) - (check-type offset integer) - (check-type goal-forward-offset integer) - (check-type goal-backward-offset integer) - (list - `(test ,(intern (format nil "~A-~A" syntax forward) #.*package*) - (with-buffer (buffer :initial-contents ,initial-contents) - (with-view (view :buffer buffer :syntax ',syntax) - (let ((syntax (syntax view)) - (m0l (make-buffer-mark buffer 0 :left)) - (m0r (make-buffer-mark buffer 0 :right)) - (m1l (make-buffer-mark buffer ,offset :left)) - (m1r (make-buffer-mark buffer ,offset :right)) - (m2l (make-buffer-mark buffer (size buffer) :left)) - (m2r (make-buffer-mark buffer (size buffer) :right))) - (declare (ignore ,@(unless forward-begin-offset '(m0l)) - ,@(unless backward-end-offset '(m0r)))) - ,(when forward-begin-offset - `(progn - (is-true (,forward m0l syntax)) - (is (= ,forward-begin-offset (offset m0l))))) - ,(when backward-end-offset - `(progn - (is-true (,forward m0r syntax)) - (is (= ,forward-begin-offset (offset m0r))))) - (is-true (,forward m1l syntax)) - (is (= ,goal-forward-offset (offset m1l))) - (is-true (,forward m1r syntax)) - (is (= ,goal-forward-offset (offset m1r))) - (is-false (,forward m2l syntax)) - (is (= (size buffer) (offset m2l))) - (is-false (,forward m2r syntax)) - (is (= (size buffer) (offset m2r))))))) - `(test ,(intern (format nil "~A-~A" syntax backward) #.*package*) - (with-buffer (buffer :initial-contents ,initial-contents) - (with-view (view :buffer buffer :syntax ',syntax) - (let ((syntax (syntax view)) - (m0l (make-buffer-mark buffer 0 :left)) - (m0r (make-buffer-mark buffer 0 :right)) - (m1l (make-buffer-mark buffer ,offset :left)) - (m1r (make-buffer-mark buffer ,offset :right)) - (m2l (make-buffer-mark buffer (size buffer) :left)) - (m2r (make-buffer-mark buffer (size buffer) :right))) - (declare (ignore ,@(unless backward-end-offset '(m2l m2r)))) - (is-false (,backward m0l syntax)) - (is (= 0 (offset m0l))) - (is-false (,backward m0r syntax)) - (is (= 0 (offset m0r))) - (is-true (,backward m1l syntax)) - (is (= ,goal-backward-offset (offset m1l))) - (is-true (,backward m1r syntax)) - (is (= ,goal-backward-offset (offset m1r))) - ,(when backward-end-offset - `(progn - (is-true (,backward m2l syntax)) - (is (= ,backward-end-offset (offset m2l))))) - ,(when backward-end-offset - `(progn - (is-true (,backward m2r syntax)) - (is (= ,backward-end-offset (offset m2r))))))))))))))) + (list + `(test ,(intern (format nil "~A-~A" syntax forward) #.*package*) + ,@(loop for test in test-specs + collecting + (destructuring-bind (forward-begin-offset + backward-end-offset + (offset goal-forward-offset goal-backward-offset) + initial-contents) + test + (check-type forward-begin-offset (or integer null)) + (check-type backward-end-offset (or integer null)) + (check-type offset integer) + (check-type goal-forward-offset integer) + (check-type goal-backward-offset integer) + `(with-buffer (buffer :initial-contents ,initial-contents) + (with-view (view :buffer buffer :syntax ',syntax) + (let ((syntax (syntax view)) + (m0l (make-buffer-mark buffer 0 :left)) + (m0r (make-buffer-mark buffer 0 :right)) + (m1l (make-buffer-mark buffer ,offset :left)) + (m1r (make-buffer-mark buffer ,offset :right)) + (m2l (make-buffer-mark buffer (size buffer) :left)) + (m2r (make-buffer-mark buffer (size buffer) :right))) + (declare (ignore ,@(unless forward-begin-offset '(m0l)) + ,@(unless backward-end-offset '(m0r)))) + ,(when forward-begin-offset + `(progn + (is-true (,forward m0l syntax)) + (is (= ,forward-begin-offset (offset m0l))))) + ,(when backward-end-offset + `(progn + (is-true (,forward m0r syntax)) + (is (= ,forward-begin-offset (offset m0r))))) + (is-true (,forward m1l syntax)) + (is (= ,goal-forward-offset (offset m1l))) + (is-true (,forward m1r syntax)) + (is (= ,goal-forward-offset (offset m1r))) + (is-false (,forward m2l syntax)) + (is (= (size buffer) (offset m2l))) + (is-false (,forward m2r syntax)) + (is (= (size buffer) (offset m2r))))))))) + `(test ,(intern (format nil "~A-~A" syntax backward) #.*package*) + ,@(loop for test in test-specs + collecting + (destructuring-bind (forward-begin-offset + backward-end-offset + (offset goal-forward-offset goal-backward-offset) + initial-contents) + test + (declare (ignore forward-begin-offset goal-forward-offset)) + `(with-buffer (buffer :initial-contents ,initial-contents) + (with-view (view :buffer buffer :syntax ',syntax) + (let ((syntax (syntax view)) + (m0l (make-buffer-mark buffer 0 :left)) + (m0r (make-buffer-mark buffer 0 :right)) + (m1l (make-buffer-mark buffer ,offset :left)) + (m1r (make-buffer-mark buffer ,offset :right)) + (m2l (make-buffer-mark buffer (size buffer) :left)) + (m2r (make-buffer-mark buffer (size buffer) :right))) + (declare (ignore ,@(unless backward-end-offset '(m2l m2r)))) + (is-false (,backward m0l syntax)) + (is (= 0 (offset m0l))) + (is-false (,backward m0r syntax)) + (is (= 0 (offset m0r))) + (is-true (,backward m1l syntax)) + (is (= ,goal-backward-offset (offset m1l))) + (is-true (,backward m1r syntax)) + (is (= ,goal-backward-offset (offset m1r))) + ,(when backward-end-offset + `(progn + (is-true (,backward m2l syntax)) + (is (= ,backward-end-offset (offset m2l))))) + ,(when backward-end-offset + `(progn + (is-true (,backward m2r syntax)) + (is (= ,backward-end-offset (offset m2r)))))))))))))))) -(motion-fun-one-test word (9 10 (5 9 2) +(motion-fun-one-test (word) (9 10 (5 9 2) " climacs climacs")) -(motion-fun-one-test line (17 22 (25 47 8) +(motion-fun-one-test (line) (17 22 (25 47 8) "Climacs-Climacs! climacsclimacsclimacs... Drei!")) -(motion-fun-one-test page (19 42 (22 40 21) +(motion-fun-one-test (page) (19 42 (22 40 21) "This is about Drei! Drei is Cool Stuff. ")) -(motion-fun-one-test paragraph (21 67 (30 64 23) +(motion-fun-one-test (paragraph) (21 67 (30 64 23) "Climacs is an editor. It is based on the Drei editor substrate. From thenriksen at common-lisp.net Thu Dec 20 10:33:36 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 20 Dec 2007 05:33:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071220103336.4234C70E1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv4077/Drei Modified Files: lisp-syntax.lisp Log Message: Fixed some problems with retrieving forms in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/19 17:17:37 1.37 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/20 10:33:36 1.38 @@ -2103,11 +2103,14 @@ (defun up-list (mark syntax fn) (let ((form (form-around syntax (offset mark)))) - (when form - (let ((new-offset (find-list-parent-offset form fn))) - (when new-offset - (setf (offset mark) new-offset) - t))))) + (when (if (and (form-list-p form) + (/= (start-offset form) (offset mark)) + (/= (end-offset form) (offset mark))) + (setf (offset mark) (funcall fn form)) + (let ((new-offset (find-list-parent-offset form fn))) + (when new-offset + (setf (offset mark) new-offset)))) + t))) (defmethod backward-one-up (mark (syntax lisp-syntax)) (up-list mark syntax #'start-offset)) From thenriksen at common-lisp.net Thu Dec 20 10:46:55 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 20 Dec 2007 05:46:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20071220104655.0E1AF7A00A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv7200/Apps/Inspector Modified Files: inspector.lisp Log Message: Oops, didn't mean to remove the Interactor pane from the Inspector with my last commit. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2007/12/20 10:33:35 1.37 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/inspector.lisp 2007/12/20 10:46:54 1.38 @@ -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 Fri Dec 21 12:31:56 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 21 Dec 2007 07:31:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071221123156.9FD5E5D101@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv32321 Modified Files: mcclim.asd Log Message: Added nasty hack to inform CLISP users of their sub-par CLX, and offer a fix. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/20 08:07:16 1.65 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/21 12:31:56 1.66 @@ -383,6 +383,19 @@ (:file "medium" :depends-on ("port" "keysyms" "package")) (:file "graft" :depends-on ("port" "package")) (:file "frame-manager" :depends-on ("medium" "port" "package")))))) +#+clisp +(defmethod asdf::traverse :around ((op compile-op) (c (eql (find-system :clim-clx)))) + ;; Just some random symbol I know is unexported in CLISP's CLX. + (if (eq (nth-value 1 (find-symbol "SET-SELECTION-OWNER" :xlib)) + :external) + (call-next-method) + (restart-case (error "Your CLX is not capable of running the McCLIM CLX backend") + (load-clx-via-asdf () + :report "Try replacing your CLX with a CLX loaded through ASDF, hopefully this will be Telent CLX." + (ext:without-package-lock ("XLIB") + (delete-package :xlib) + (asdf:oos 'asdf:load-op :clx)) + (call-next-method))))) (defsystem :clim-beagle :depends-on (clim) From thenriksen at common-lisp.net Fri Dec 21 14:22:07 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 21 Dec 2007 09:22:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071221142207.BE8C53202E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv28772/Drei Modified Files: basic-commands.lisp editing.lisp Log Message: Fixed some problems with editing functions not returning T when succesful, and editing commands not handling the proper errors. --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2007/12/19 11:02:05 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2007/12/21 14:22:07 1.10 @@ -310,14 +310,16 @@ ((count 'integer :prompt ,(concat "Number of " plural) :default 1)) ,(concat "Delete from point until the next " noun " end. With a positive numeric argument, delete that many " plural " forward.") - (,backward-delete (point) (current-syntax) count)) + (handling-motion-limit-errors (,plural) + (,backward-delete (point) (current-syntax) count))) ;; Backward Delete Unit (define-command (,com-backward-delete :name t :command-table ,command-table) ((count 'integer :prompt ,(concat "Number of " plural) :default 1)) ,(concat "Delete from point until the previous " noun " beginning. With a positive numeric argument, delete that many " plural " backward.") - (,backward-delete (point) (current-syntax) count))))))) + (handling-motion-limit-errors (,plural) + (,backward-delete (point) (current-syntax) count)))))))) (defmacro define-editing-commands (unit command-table &key noun --- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2007/12/19 11:02:02 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2007/12/21 14:22:07 1.9 @@ -82,8 +82,9 @@ (mark syntax &optional (count 1) (limit-action #'error-limit-action)) (let ((mark2 (clone-mark mark))) - (,forward mark2 syntax count limit-action) - (delete-region mark mark2))) + (when (,forward mark2 syntax count limit-action) + (delete-region mark mark2) + t))) (defmethod ,forward-delete :around (mark syntax &optional (count 1) (limit-action #'error-limit-action)) @@ -100,8 +101,9 @@ (mark syntax &optional (count 1) (limit-action #'error-limit-action)) (let ((mark2 (clone-mark mark))) - (,backward mark2 syntax count limit-action) - (delete-region mark mark2))) + (when (,backward mark2 syntax count limit-action) + (delete-region mark mark2) + t))) (defmethod ,backward-delete :around (mark syntax &optional (count 1) (limit-action #'error-limit-action)) @@ -128,7 +130,8 @@ (region-to-sequence start mark))) (kill-ring-standard-push *kill-ring* (region-to-sequence start mark))) - (delete-region start mark)))) + (delete-region start mark) + t))) (defmethod ,forward-kill :around (mark syntax &optional (count 1) concatenate-p (limit-action #'error-limit-action)) @@ -156,7 +159,8 @@ (region-to-sequence start mark))) (kill-ring-standard-push *kill-ring* (region-to-sequence start mark))) - (delete-region start mark)))) + (delete-region start mark) + t))) (defmethod ,backward-kill :around (mark syntax &optional (count 1) concatenate-p (limit-action #'error-limit-action)) From dlichteblau at common-lisp.net Fri Dec 21 15:02:32 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Fri, 21 Dec 2007 10:02:32 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071221150232.9189317041@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4004 Modified Files: mcclim.asd Log Message: Fixed McCLIM on OpenMCL/Linux. ... don't require cocoa by default. ... instead, conditionalize on CLIM-BEAGLE --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/21 12:31:56 1.66 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/21 15:02:32 1.67 @@ -83,7 +83,7 @@ :class requireable-system)) ;;; Required for the beagle backend (not activated by default) -#+clozure-common-lisp +#+clim-beagle (progn (require :cocoa) (require :objc-support)) @@ -530,16 +530,13 @@ ;; If we're on an implementation that ships CLX, use ;; it. Same if the user has loaded CLX already. #+(and (or sbcl scl openmcl ecl clx allegro) - (not (or gtkairo clim-graphic-forms))) + (not (or gtkairo clim-graphic-forms clim-beagle))) :clim-clx #+clim-graphic-forms :clim-graphic-forms #+gl :clim-opengl ;; OpenMCL and MCL support the beagle backend (native ;; OS X look&feel on OS X). - - ;; But until it's ready, it's no use forcing users to - ;; cope with possible bugs. - ;; #+(or openmcl mcl) :clim-beagle + #+clim-beagle :clim-beagle #+gtkairo :clim-gtkairo From dlichteblau at common-lisp.net Fri Dec 21 15:18:30 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Fri, 21 Dec 2007 10:18:30 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071221151830.244B81B027@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5363 Modified Files: mcclim.asd Log Message: Renamed the GTKAIRO feature to CLIM-GTKAIRO ... for consistency with CLIM-GRAPHIC-FORMS and CLIM-BEAGLE ... also CLIM-GL --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/21 15:02:32 1.67 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/21 15:18:29 1.68 @@ -62,7 +62,7 @@ (extensions:without-package-locks (load "gray-streams:gray-streams-library")) (load "gray-streams:gray-streams-library"))) - #-(or clx gtkairo clim-graphic-forms) + #-(or clx clim-gtkairo clim-graphic-forms) (require :clx) #+mp (when (eq mp::*initial-process* mp::*current-process*) (format t "~%~%You need to run (mp::startup-idle-and-top-level-loops) to start up the multiprocessing support.~%~%"))) @@ -530,20 +530,20 @@ ;; If we're on an implementation that ships CLX, use ;; it. Same if the user has loaded CLX already. #+(and (or sbcl scl openmcl ecl clx allegro) - (not (or gtkairo clim-graphic-forms clim-beagle))) + (not (or clim-gtkairo clim-graphic-forms clim-beagle))) :clim-clx #+clim-graphic-forms :clim-graphic-forms - #+gl :clim-opengl + #+clim-gl :clim-opengl ;; OpenMCL and MCL support the beagle backend (native ;; OS X look&feel on OS X). #+clim-beagle :clim-beagle - #+gtkairo :clim-gtkairo + #+clim-gtkairo :clim-gtkairo ;; null backend :clim-null ) - :components (#-(or gtkairo clim-graphic-forms) + :components (#-(or clim-gtkairo clim-graphic-forms) (:file "Looks/pixie" :pathname #.(make-pathname :directory '(:relative "Looks") :name "pixie" :type "lisp")))) From dlichteblau at common-lisp.net Fri Dec 21 15:21:28 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Fri, 21 Dec 2007 10:21:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071221152128.9E8552826B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7470 Modified Files: mcclim.asd Log Message: Don't compile the pixie look if CLIM-BEAGLE is set. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/21 15:18:29 1.68 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/21 15:21:28 1.69 @@ -543,7 +543,7 @@ ;; null backend :clim-null ) - :components (#-(or clim-gtkairo clim-graphic-forms) + :components (#-(or clim-gtkairo clim-graphic-forms clim-beagle) (:file "Looks/pixie" :pathname #.(make-pathname :directory '(:relative "Looks") :name "pixie" :type "lisp")))) From dlichteblau at common-lisp.net Fri Dec 21 15:27:47 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Fri, 21 Dec 2007 10:27:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20071221152747.C6BC53202E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv8013 Modified Files: mcclim-freetype.asd Removed Files: mcclim-freetype-cffi.asd Log Message: Merged mcclim-freetype-cffi.asd into mcclim-freetype.asd. ... use the CFFI code for non-SBCL ... for now, keep the old alien code for SBCL --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2007/12/16 20:02:08 1.6 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2007/12/21 15:27:47 1.7 @@ -28,12 +28,17 @@ "lisp") (defsystem :mcclim-freetype - :depends-on (:clim-clx :mcclim) + :depends-on (:clim-clx :mcclim #-sbcl :cffi) :serial t :components + #+sbcl ((:file "freetype-package") (:uncompiled-cl-source-file "freetype-ffi") - (:file "freetype-fonts"))) + (:file "freetype-fonts")) + #-sbcl + ((:file "freetype-package-cffi") + (:uncompiled-cl-source-file "freetype-cffi") + (:file "freetype-fonts-cffi"))) ;;; Freetype autodetection @@ -75,4 +80,16 @@ #-sbcl (defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) - (warn-about-unset-font-path)) + (unless + (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype)) + (find-bitstream-fonts)) + (warn-about-unset-font-path))) + +#-sbcl +(defun find-bitstream-fonts () + (with-input-from-string + (s (with-output-to-string (asdf::*verbose-out*) + (let ((code (asdf:run-shell-command "fc-match -v Bitstream Vera"))) + (unless (zerop code) + (warn "~&fc-match failed with code ~D.~%" code))))) + (parse-fontconfig-output s))) From thenriksen at common-lisp.net Fri Dec 21 23:10:49 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 21 Dec 2007 18:10:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071221231049.AFFD8330E1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv5211/Drei Modified Files: lisp-syntax.lisp packages.lisp Log Message: Added some more nifty utility functions to Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/20 10:33:36 1.38 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/21 23:10:49 1.39 @@ -1386,6 +1386,16 @@ `mark-or-offset' is returned." (form-toplevel syntax (expression-at-mark syntax mark-or-offset))) +(defun list-at-mark (syntax mark-or-offset) + "Return the list form that `mark-or-offset' is inside, or NIL +if no such form exists." + (as-offsets ((offset mark-or-offset)) + (let ((form-around (form-around syntax offset))) + (if (and (form-list-p form-around) + (> offset (start-offset form-around))) + form-around + (find-list-parent form-around))))) + (defun symbol-at-mark (syntax mark-or-offset &optional (form-fetcher 'expression-at-mark)) "Return a symbol token at `mark-or-offset'. This function will @@ -2002,16 +2012,23 @@ nil (form-around-in-children syntax (children stack-top) offset)))))) +(defun find-list-parent (form) + "Find a list parent of `form' and return it. If a list parent +cannot be found, return nil" + (let ((parent (parent form))) + (typecase parent + (list-form parent) + ((or form* null) nil) + (t (find-list-parent-offset parent))))) + (defun find-list-parent-offset (form fn) "Find a list parent of `form' and return `fn' applied to this parent token. `Fn' should be a function that returns an offset when applied to a token (eg. `start-offset' or `end-offset'). If a list parent cannot be found, return nil" - (let ((parent (parent form))) - (typecase parent - (list-form (funcall fn parent)) - ((or form* null) nil) - (t (find-list-parent-offset parent fn))))) + (let ((list-parent (find-list-parent form))) + (when list-parent + (funcall fn list-parent)))) (defun find-list-child-offset (form fn &optional (min-offset 0)) "Find a list child of `token' with a minimum start @@ -2032,6 +2049,7 @@ (funcall fn list-child))))) (defmethod backward-one-expression (mark (syntax lisp-syntax)) + (update-syntax syntax 0 0) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) (when (and (not (null potential-form)) @@ -2039,6 +2057,7 @@ (setf (offset mark) (start-offset potential-form))))) (defmethod forward-one-expression (mark (syntax lisp-syntax)) + (update-parse syntax 0 (offset mark)) (let ((potential-form (or (form-after syntax (offset mark)) (form-around syntax (offset mark))))) (when (and (not (null potential-form)) @@ -2050,6 +2069,7 @@ Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-list (mark (syntax lisp-syntax)) + (update-parse syntax 0 (offset mark)) (loop for start = (offset mark) then (end-offset potential-form) for potential-form = (or (form-after syntax start) @@ -2067,6 +2087,7 @@ successful, or NIL if the buffer limit was reached.")) (defmethod backward-one-list (mark (syntax lisp-syntax)) + (update-parse syntax 0 (offset mark)) (loop for start = (offset mark) then (start-offset potential-form) for potential-form = (or (form-before syntax start) @@ -2082,6 +2103,7 @@ (drei-motion:define-motion-fns list) (defun down-list (mark syntax selector next-offset-fn target-offset-fn) + (update-parse syntax 0 (offset mark)) (labels ((find-offset (potential-form) (typecase potential-form (list-form (funcall target-offset-fn potential-form)) @@ -2094,14 +2116,17 @@ t)))) (defmethod forward-one-down ((mark mark) (syntax lisp-syntax)) + (update-parse syntax 0 (offset mark)) (when (down-list mark syntax #'form-after #'end-offset #'start-offset) (forward-object mark))) (defmethod backward-one-down ((mark mark) (syntax lisp-syntax)) + (update-parse syntax 0 (offset mark)) (when (down-list mark syntax #'form-before #'start-offset #'end-offset) (backward-object mark))) (defun up-list (mark syntax fn) + (update-parse syntax 0 (offset mark)) (let ((form (form-around syntax (offset mark)))) (when (if (and (form-list-p form) (/= (start-offset form) (offset mark)) @@ -2113,12 +2138,15 @@ t))) (defmethod backward-one-up (mark (syntax lisp-syntax)) + (update-parse syntax 0 (offset mark)) (up-list mark syntax #'start-offset)) (defmethod forward-one-up (mark (syntax lisp-syntax)) + (update-parse syntax 0 (offset mark)) (up-list mark syntax #'end-offset)) (defmethod backward-one-definition ((mark mark) (syntax lisp-syntax)) + (update-parse syntax 0 (offset mark)) (with-slots (stack-top) syntax ;; FIXME? This conses! I'm over it already. I don't think it ;; matters much, but if someone is bored, please profile it. @@ -2129,6 +2157,7 @@ and do (return t)))) (defmethod forward-one-definition ((mark mark) (syntax lisp-syntax)) + (update-parse syntax 0 (offset mark)) (with-slots (stack-top) syntax (loop for form in (children stack-top) when (and (formp form) @@ -2137,6 +2166,7 @@ and do (return t)))) (defmethod eval-defun ((mark mark) (syntax lisp-syntax)) + (update-parse syntax 0 (offset mark)) (with-slots (stack-top) syntax (loop for form in (children stack-top) when (and (mark<= (start-offset form) mark) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/19 17:17:37 1.23 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/21 23:10:49 1.24 @@ -500,8 +500,10 @@ ;; Selecting forms based on mark #:form-around #:form-before #:form-after + #:find-list-parent #:expression-at-mark #:definition-at-mark + #:list-at-mark #:symbol-at-mark #:fully-quoted-form #:fully-unquoted-form From thenriksen at common-lisp.net Fri Dec 21 23:38:20 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 21 Dec 2007 18:38:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071221233820.B1CA84B059@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9368/Drei Modified Files: lisp-syntax.lisp Log Message: Fixed case of treatment of mark as offset in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/21 23:10:49 1.39 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/21 23:38:20 1.40 @@ -1152,7 +1152,7 @@ form can be found, return the package specified in the attribute list. If no such package is specified, return \"CLIM-USER\"." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 mark-or-offset) + (update-parse syntax 0 offset) (flet ((normalise (designator) (typecase designator (symbol From thenriksen at common-lisp.net Sun Dec 23 00:40:36 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 22 Dec 2007 19:40:36 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071223004036.8F04132023@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv19783/Drei Modified Files: drei-clim.lisp Log Message: Gadget-value for Drei gadgets works again now. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/12/10 21:25:12 1.24 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/12/23 00:40:36 1.25 @@ -223,8 +223,8 @@ ;; literal objects. We return a string if we can, an array ;; otherwise. This is a bit slow, as we cons up the array and then ;; probably a new one for the string, most of the time. - (let ((contents (buffer-sequence (buffer gadget) - 0 (size (buffer gadget))))) + (let ((contents (buffer-sequence (buffer (view gadget)) + 0 (size (buffer (view gadget)))))) (if (every #'characterp contents) (coerce contents 'string) contents))) From thenriksen at common-lisp.net Sun Dec 23 18:17:55 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 23 Dec 2007 13:17:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071223181755.81A8B3001D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26890/Drei Modified Files: lisp-syntax.lisp Log Message: Fixed some bugs in Lisp syntax movement-by-expression methods. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/21 23:38:20 1.40 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/23 18:17:55 1.41 @@ -1390,11 +1390,13 @@ "Return the list form that `mark-or-offset' is inside, or NIL if no such form exists." (as-offsets ((offset mark-or-offset)) + (update-parse syntax 0 offset) (let ((form-around (form-around syntax offset))) - (if (and (form-list-p form-around) - (> offset (start-offset form-around))) - form-around - (find-list-parent form-around))))) + (when form-around + (if (and (form-list-p form-around) + (> offset (start-offset form-around))) + form-around + (find-list-parent form-around)))))) (defun symbol-at-mark (syntax mark-or-offset &optional (form-fetcher 'expression-at-mark)) @@ -1645,6 +1647,40 @@ (when (form-string-p form-around) (at-end-of-form-p syntax form-around offset))))) +(defun at-beginning-of-children-p (form mark-or-offset) + "Return true if `mark-or-offset' structurally is at the +beginning of (precedes) the children of `form'. True if `form' +has no children." + (as-offsets ((offset mark-or-offset)) + (let ((first-child (first (form-children form)))) + (and (null first-child) + (>= (start-offset first-child) offset))))) + +(defun at-end-of-children-p (form mark-or-offset) + "Return true if `mark-or-offset' structurally is at the end +of (is preceded by) the children of `form'. True if `form' has no +children." + (as-offsets ((offset mark-or-offset)) + (let ((last-child (first (last (form-children form))))) + (or (null last-child) + (>= offset (end-offset last-child)))))) + +(defun structurally-at-beginning-of-list-p (syntax mark-or-offset) + "Return true if `mark-or-offset' structurally is at the +beginning of (precedes) the children of the enclosing list. False +if there is no enclosing list. True if the list has no children." + (as-offsets ((offset mark-or-offset)) + (let ((enclosing-list (list-at-mark syntax offset))) + (and enclosing-list (at-beginning-of-children-p enclosing-list offset))))) + +(defun structurally-at-end-of-list-p (syntax mark-or-offset) + "Return true if `mark-or-offset' structurally is at the end +of (is preceded by) the children of the enclosing list. False if +there is no enclosing list. True of the list has no children." + (as-offsets ((offset mark-or-offset)) + (let ((enclosing-list (list-at-mark syntax offset))) + (and enclosing-list (at-end-of-children-p enclosing-list offset))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Useful functions for modifying forms based on the mark. @@ -2064,6 +2100,61 @@ (not (= (offset mark) (end-offset potential-form)))) (setf (offset mark) (end-offset potential-form))))) +(defmethod forward-delete-expression (mark (syntax lisp-syntax) &optional (count 1) + (limit-action #'error-limit-action)) + (let ((mark2 (clone-mark mark))) + (when (and (not (structurally-at-end-of-list-p (current-syntax) mark)) + (forward-expression mark2 syntax count limit-action)) + (delete-region mark mark2) + t))) + +(defmethod backward-delete-expression (mark (syntax lisp-syntax) &optional (count 1) + (limit-action #'error-limit-action)) + (let ((mark2 (clone-mark mark))) + (when (and (not (structurally-at-end-of-list-p (current-syntax) mark)) + (backward-expression mark2 syntax count limit-action)) + (delete-region mark mark2) + t))) + +(defmethod forward-kill-expression (mark (syntax lisp-syntax) &optional (count 1) concatenate-p + (limit-action #'error-limit-action)) + (let ((start (offset mark))) + (forward-expression mark syntax count limit-action) + (unless (mark= mark start) + (if concatenate-p + (if (plusp count) + (kill-ring-concatenating-push + *kill-ring* + (region-to-sequence start + mark)) + (kill-ring-reverse-concatenating-push + *kill-ring* + (region-to-sequence + start mark))) + (kill-ring-standard-push + *kill-ring* + (region-to-sequence start mark))) + (delete-region start mark) + t))) + +(defmethod backward-kill-expression (mark (syntax lisp-syntax) &optional (count 1) concatenate-p + (limit-action #'error-limit-action)) + (let ((start (offset mark))) + (backward-expression mark syntax count limit-action) + (unless (mark= mark start) + (if concatenate-p + (if (plusp count) + (kill-ring-concatenating-push *kill-ring* + (region-to-sequence start + mark)) + (kill-ring-reverse-concatenating-push *kill-ring* + (region-to-sequence + start mark))) + (kill-ring-standard-push *kill-ring* + (region-to-sequence start mark))) + (delete-region start mark) + t))) + (defgeneric forward-one-list (mark syntax) (:documentation "Move `mark' forward by one list. Return T if successful, or NIL if the buffer limit was reached.")) From rstrandh at common-lisp.net Tue Dec 25 06:46:21 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Tue, 25 Dec 2007 01:46:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071225064621.C1350620C4@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv7595 Modified Files: drei.lisp Log Message: Undid incorrect addition to docstring. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/17 06:29:37 1.22 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/25 06:46:21 1.23 @@ -64,7 +64,7 @@ ;;; Convenience stuff. (defvar *drei-instance* nil - "The currently running Drei instance. The value is a subclass of pane.") + "The currently running Drei instance.") (defun current-view (&optional (object *drei-instance*)) "Return the view of the provided object. If no object is From thenriksen at common-lisp.net Thu Dec 27 13:39:26 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 27 Dec 2007 08:39:26 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071227133926.14DCC761AD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv24676/Drei Modified Files: base.lisp core-commands.lisp packages.lisp Log Message: Added kill-region function to DREI-BASE. --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2007/12/08 08:53:50 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2007/12/27 13:39:25 1.8 @@ -373,6 +373,14 @@ (insert-sequence mark (make-string (- column set-column) :initial-element #\Space))))) +(defun kill-region (mark1 mark2) + "Kill the objects between `mark1' and `mark2', one of which may optionally be an offset. +That is, push the objects of the delimited region onto +`*kill-ring*', and delete them from the buffer." + (kill-ring-standard-push + *kill-ring* (region-to-sequence mark1 mark2)) + (delete-region mark1 mark2)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/12/19 11:02:05 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/12/27 13:39:25 1.12 @@ -441,9 +441,7 @@ (define-command (com-kill-region :name t :command-table editing-table) () "Kill the objects between point and mark. That is, push them onto the kill ring, and delete them from the buffer." - (kill-ring-standard-push - *kill-ring* (region-to-sequence (mark) (point))) - (delete-region (mark) (point))) + (kill-region (mark) (point))) (set-key 'com-kill-region 'editing-table --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/21 23:10:49 1.24 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/27 13:39:25 1.25 @@ -104,6 +104,7 @@ #:constituentp #:just-n-spaces #:move-to-column + #:kill-region #:buffer-whitespacep #:buffer-region-case #:buffer-looking-at #:looking-at @@ -491,7 +492,7 @@ (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base :drei-syntax :drei-fundamental-syntax :flexichain :drei :drei-motion :drei-editing :esa-utils :esa :drei-core :esa-io - :drei-lr-syntax) + :drei-lr-syntax :drei-kill-ring) (:export #:lisp-syntax #:lisp-table #:lisp-string #:edit-definition From thenriksen at common-lisp.net Thu Dec 27 15:22:54 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 27 Dec 2007 10:22:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071227152254.C3F1E5B096@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15485/Drei Modified Files: lisp-syntax.lisp packages.lisp Log Message: Added a few more facilities to Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/23 18:17:55 1.41 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/12/27 15:22:54 1.42 @@ -1469,6 +1469,8 @@ (define-form-predicate form-simple-vector-p (simple-vector-form)) (define-form-predicate comment-p (comment)) +(define-form-predicate line-comment-p (line-comment-form)) +(define-form-predicate long-comment-p (long-comment-form)) (defgeneric form-at-top-level-p (form) (:documentation "Return NIL if `form' is not a top-level-form, @@ -1523,6 +1525,25 @@ (when (typep comment 'incomplete-long-comment-form) (< (1+ (start-offset comment)) offset))))))) +(defun in-line-comment-p (syntax mark-or-offset) + "Return true if `mark-or-offset' is inside a Lisp line +comment." + (as-offsets ((offset mark-or-offset)) + (let ((comment (in-type-p syntax mark-or-offset 'line-comment-form))) + (when comment + (< (start-offset comment) offset))))) + +(defun in-long-comment-p (syntax mark-or-offset) + "Return true if `mark-or-offset' is inside a Lisp +long comment." + (as-offsets ((offset mark-or-offset)) + (let ((comment (in-type-p syntax mark-or-offset 'long-comment-form))) + (and comment + (or (if (typep comment 'complete-long-comment-form) + (< (1+ (start-offset comment)) offset + (1- (end-offset comment))) + (< (1+ (start-offset comment)) offset))))))) + (defun in-character-p (syntax mark-or-offset) "Return true if `mark-or-offset' is inside a Lisp character lexeme." (as-offsets ((offset mark-or-offset)) @@ -1670,16 +1691,20 @@ beginning of (precedes) the children of the enclosing list. False if there is no enclosing list. True if the list has no children." (as-offsets ((offset mark-or-offset)) - (let ((enclosing-list (list-at-mark syntax offset))) - (and enclosing-list (at-beginning-of-children-p enclosing-list offset))))) + (let ((enclosing-list (list-at-mark syntax offset))) + (and enclosing-list (at-beginning-of-children-p enclosing-list offset))))) (defun structurally-at-end-of-list-p (syntax mark-or-offset) "Return true if `mark-or-offset' structurally is at the end of (is preceded by) the children of the enclosing list. False if there is no enclosing list. True of the list has no children." (as-offsets ((offset mark-or-offset)) - (let ((enclosing-list (list-at-mark syntax offset))) - (and enclosing-list (at-end-of-children-p enclosing-list offset))))) + (let ((enclosing-list (list-at-mark syntax offset))) + (and enclosing-list (at-end-of-children-p enclosing-list offset))))) + +(defun comment-at-mark (syntax mark-or-offset) + "Return the comment at `mark-or-offset'." + (in-type-p syntax mark-or-offset 'comment)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/27 13:39:25 1.25 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/27 15:22:54 1.26 @@ -518,7 +518,7 @@ #:form-comma-p #:form-comma-at-p #:form-comma-dot-p #:form-character-p #:form-simple-vector-p - #:comment-p + #:comment-p #:line-comment-p #:long-comment-p #:form-at-top-level-p ;; Querying form data @@ -530,6 +530,8 @@ ;; Querying about state at mark #:in-string-p #:in-comment-p + #:in-line-comment-p + #:in-long-comment-p #:in-character-p #:location-at-beginning-of-form #:location-at-end-of-form @@ -537,6 +539,11 @@ #:at-end-of-list-p #:at-beginning-of-string-p #:at-end-of-string-p + #:at-beginning-of-children-p + #:at-end-of-children-p + #:structurally-at-beginning-of-children-p + #:structurally-at-end-of-children-p + #:comment-at-mark ;; Lambda list classes. #:lambda-list From thenriksen at common-lisp.net Thu Dec 27 16:34:59 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 27 Dec 2007 11:34:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20071227163459.8B0E8554BD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv28931/ESA Modified Files: esa-io.lisp Log Message: Make ESA's com-find-file only try to retrieve the filepath of the current buffer if there is a current buffer. --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2007/12/15 10:18:16 1.4 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2007/12/27 16:34:59 1.5 @@ -85,7 +85,8 @@ (make-pathname :directory (pathname-directory - (or (filepath (current-buffer)) + (or (and (current-buffer) + (filepath (current-buffer))) (user-homedir-pathname))))) (define-command (com-find-file :name t :command-table esa-io-table) From thenriksen at common-lisp.net Thu Dec 27 20:31:56 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 27 Dec 2007 15:31:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20071227203156.4F16C65115@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv12393/ESA Modified Files: esa-command-parser.lisp Log Message: Replace numeric arguments in ESA command parser even if the command is not actually a command. --- /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2007/12/19 11:02:00 1.2 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2007/12/27 20:31:56 1.3 @@ -102,23 +102,27 @@ (read-gesture :stream stream))))) (with-delimiter-gestures (*command-argument-delimiters* :override t) ;; FIXME, except we can't: use of CLIM-INTERNALS. - (let* ((info (gethash command-name climi::*command-parser-table*)) - (required-args (climi::required-args info)) - (keyword-args (climi::keyword-args info))) - ;; keyword arguments not yet supported - (declare (ignore keyword-args)) - (let (result) - ;; only required args for now. - (do* ((required-args required-args (cdr required-args)) - (arg (car required-args) (car required-args)) - (command-args command-args (cdr command-args)) - (command-arg (car command-args) (car command-args))) - ((null required-args) (cons command-name (nreverse result))) - (destructuring-bind (name ptype &rest args) arg - (push (cond ((eq command-arg *unsupplied-argument-marker*) - (esa-parse-one-arg stream name ptype args)) - ((eq command-arg *numeric-argument-marker*) - (or numeric-argument (getf args :default))) - (t command-arg)) - result) - (maybe-clear-input))))))))) + (let ((info (gethash command-name climi::*command-parser-table*))) + (if (null info) + ;; `command' is not a real command! Well, we can still + ;; replace numeric argument markers. + (substitute-numeric-argument-marker command numeric-argument) + (let ((required-args (climi::required-args info)) + (keyword-args (climi::keyword-args info))) + ;; keyword arguments not yet supported + (declare (ignore keyword-args)) + (let (result) + ;; only required args for now. + (do* ((required-args required-args (cdr required-args)) + (arg (car required-args) (car required-args)) + (command-args command-args (cdr command-args)) + (command-arg (car command-args) (car command-args))) + ((null required-args) (cons command-name (nreverse result))) + (destructuring-bind (name ptype &rest args) arg + (push (cond ((eq command-arg *unsupplied-argument-marker*) + (esa-parse-one-arg stream name ptype args)) + ((eq command-arg *numeric-argument-marker*) + (or numeric-argument (getf args :default))) + (t command-arg)) + result) + (maybe-clear-input))))))))))) From thenriksen at common-lisp.net Fri Dec 28 10:08:50 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 28 Dec 2007 05:08:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071228100850.A05C63001B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv2026/Drei Modified Files: drei.lisp packages.lisp syntax.lisp views.lisp Added Files: modes.lisp Log Message: Added support for "modes" (roughly similar to Emacs' minor-modes) to Drei. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/25 06:46:21 1.23 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/28 10:08:28 1.24 @@ -219,7 +219,7 @@ ;;; ;;; The basic Drei class. -(defclass drei () +(defclass drei (modual-mixin) ((%view :initform (make-instance 'textual-drei-syntax-view) :initarg :view :accessor view @@ -288,6 +288,25 @@ (defmethod (setf active) (new-val (drei drei)) (setf (active (view drei)) new-val)) +(defmethod available-modes append ((modual drei)) + (available-modes (view modual))) + +(defmethod mode-applicable-p or ((modual drei) mode-name) + (mode-applicable-p (view modual) mode-name)) + +(defmethod mode-enabled-p or ((modual drei) mode-name) + (mode-enabled-p (view modual) mode-name)) + +(defmethod enable-mode ((modual drei) mode-name &rest initargs) + (if (mode-applicable-p (view modual) mode-name) + (apply #'enable-mode (view modual) mode-name initargs) + (call-next-method))) + +(defmethod disable-mode ((modual drei) mode-name) + (if (mode-applicable-p (view modual) mode-name) + (disable-mode (view modual) mode-name) + (call-next-method))) + (defun add-view-cursors (drei) "Add the cursors desired by the Drei view to the editor-pane of the Drei instance." --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/27 15:22:54 1.26 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/12/28 10:08:33 1.27 @@ -138,7 +138,8 @@ (defpackage :drei-syntax (:use :clim-lisp :clim :drei-buffer :drei-base :flexichain :esa-utils) - (:export #:syntax #:update-parse #:syntaxp #:define-syntax #:*default-syntax* #:cursor-positions + (:export #:syntax #:syntax-command-tables #:update-parse #:syntaxp + #:define-syntax #:*default-syntax* #:cursor-positions #:syntax-command-table #:additional-command-tables #:define-syntax-command-table #:eval-option #:define-option-for-syntax @@ -277,7 +278,12 @@ #:*foreground-color* #:*background-color* #:*show-mark* - #:*use-tabs-for-indentation*)) + #:*use-tabs-for-indentation* + + #:view-mode #:syntax-mode + #:applicable-modes + #:define-mode #:define-view-mode #:define-syntax-mode + #:define-mode-toggle-commands)) (defpackage :drei-motion (:use :clim-lisp :drei-base :drei-buffer :drei-syntax) --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2007/12/10 21:25:12 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2007/12/28 10:08:34 1.9 @@ -22,7 +22,7 @@ (in-package :drei-syntax) -(defclass syntax (name-mixin) +(defclass syntax (name-mixin modual-mixin) ((%buffer :initarg :buffer :reader buffer) (%command-table :initarg :command-table :initform (error "A command table has not been provided for this syntax") @@ -32,6 +32,13 @@ :accessor updater-fns)) (:documentation "The base class for all syntaxes.")) +(defgeneric syntax-command-tables (syntax) + (:documentation "Returns additional command tables provided by +`syntax'.") + (:method-combination append) + (:method append ((syntax syntax)) + (list (command-table syntax)))) + (defun syntaxp (object) "Return T if `object' is an instance of a syntax, NIL otherwise." --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/19 17:17:37 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2007/12/28 10:08:35 1.8 @@ -403,7 +403,7 @@ ;;; ;;; View classes. -(defclass drei-view (tabify-mixin subscriptable-name-mixin) +(defclass drei-view (tabify-mixin subscriptable-name-mixin modual-mixin) ((%active :accessor active :initform t :initarg :active @@ -445,6 +445,12 @@ (print-unreadable-object (view stream :type t :identity t) (format stream "name: ~a ~a" (name view) (subscript view)))) +(defmethod available-modes append ((modual drei-view)) + *global-modes*) + +(defmethod mode-applicable-p or ((modual drei-view) mode-name) + (mode-applicable-p (syntax modual) mode-name)) + (defgeneric synchronize-view (view &key &allow-other-keys) (:documentation "Synchronize the view with the object under observation - what exactly this entails, and what keyword @@ -583,6 +589,19 @@ (buffer-size view) (size (buffer view))) (synchronize-view view :force-p t)) +(defmethod mode-enabled-p or ((modual drei-syntax-view) mode-name) + (mode-enabled-p (syntax modual) mode-name)) + +(defmethod enable-mode ((modual drei-syntax-view) mode-name &rest initargs) + (if (mode-applicable-p (syntax modual) mode-name) + (apply #'enable-mode (syntax modual) mode-name initargs) + (call-next-method))) + +(defmethod disable-mode ((modual drei-syntax-view) mode-name) + (if (mode-applicable-p (syntax modual) mode-name) + (disable-mode (syntax modual) mode-name) + (call-next-method))) + (defmethod observer-notified ((view drei-syntax-view) (buffer drei-buffer) changed-region) (with-accessors ((prefix-size prefix-size) @@ -668,7 +687,7 @@ (make-instance 'mark-cursor :view view :output-stream output-stream)))) (defmethod view-command-tables append ((view textual-drei-syntax-view)) - (list (command-table (syntax view)))) + (syntax-command-tables (syntax view))) (defmethod use-editor-commands-p ((view textual-drei-syntax-view)) t) --- /project/mcclim/cvsroot/mcclim/Drei/modes.lisp 2007/12/28 10:08:50 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/modes.lisp 2007/12/28 10:08:50 1.1 ;;; -*- Mode: Lisp; Package: DREI -*- ;;; (c) copyright 2007-2008 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; ;;; This file contains the implementation of the infrastructure for ;;; Drei "modes", loosely equivalent to Emacs minor modes. They modify ;;; aspects of the behavior of a view or syntax. (in-package :drei) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The general mode protocol and macros. (defvar *global-modes* '() "A list of the names of modes globally available to Drei instances. Do not use this list to retrieve modes, use the function `available-modes' instead. The modes on this list are available to all Drei variants.") (defun applicable-modes (drei) "Return a list of the names of all modes applicable for `drei'." (remove-if-not #'(lambda (mode) (mode-applicable-p (view drei) mode)) (available-modes drei))) (defclass view-mode (mode) () (:documentation "The superclass for all view modes.")) (defclass syntax-mode (mode) () (:documentation "The superclass for all syntax modes.")) (defmacro define-mode (name (&rest superclasses) (&rest slot-specs) &rest options) "Define a toggable Drei mode. It is essentially a class, with the provided `name', `superclasses', `slot-specs' and `options'. It will automatically be a subclass of `mode'. Apart from the normal class options, `options' can also have a `:global' option, which when true signifies that the mode is globally available to all Drei instances. This option is true by default. Note that modes created via this macro are not applicable to anything." (let ((global t) (actual-options '())) (dolist (option options) (case (first option) (:global (setf global (second option))) (t (push option actual-options)))) `(progn (defclass ,name (, at superclasses mode) (, at slot-specs) , at actual-options) (defmethod enabled-modes append ((modual ,name)) '(,name)) ,(when global `(push ',name *global-modes*))))) (defmacro define-view-mode (name (&rest superclasses) (&rest slot-specs) &rest options) "Define a mode (as `define-mode') that is applicable to views. Apart from taking the same options as `define-mode', it also takes an `:applicable-views' option (nil by default) that is a list of views the mode should be applicable to. Multiple uses of this option are cumulative." (let ((applicable-views '()) (actual-options '())) (dolist (option options) (case (first option) (:applicable-views (setf applicable-views (append applicable-views (rest option)))) (t (push option actual-options)))) `(progn (define-mode ,name (, at superclasses view-mode) (, at slot-specs) , at actual-options) ,@(loop for view in applicable-views collecting `(defmethod mode-directly-applicable-p or ((view ,view) (mode-name (eql ',name))) t))))) (defmacro define-syntax-mode (name (&rest superclasses) (&rest slot-specs) &rest options) "Define a mode (as `define-mode') that is applicable to syntaxes. Apart from taking the same options as `define-mode', it also takes an `:applicable-syntaxes' option (nil by default) that is a list of syntaxes the mode should be applicable to. Multiple uses of this option are cumulative." (let ((applicable-syntaxes '()) (actual-options '())) (dolist (option options) (case (first option) (:applicable-syntaxes (setf applicable-syntaxes (append applicable-syntaxes (rest option)))) (t (push option actual-options)))) `(progn (define-mode ,name (, at superclasses syntax-mode) (, at slot-specs) , at actual-options) ,@(loop for syntax in applicable-syntaxes collecting `(defmethod mode-directly-applicable-p or ((syntax ,syntax) (mode-name (eql ',name))) t))))) (defmacro define-mode-toggle-commands (command-name (mode-name &optional (string-form (capitalize (string mode-name)))) &key (name t) command-table) "Define a simple command (named `command-name') for toggling the mode named by `mode-name' on and off. `String-form' is the name of the mode that will be put in the docstring, `name' and `command-table' work as in `define-command'." (check-type command-name symbol) (check-type mode-name symbol) (check-type string-form string) `(define-command (,command-name :name ,name :command-table ,command-table) () ,(concatenate 'string "Toggle " string-form " mode.") (if (mode-enabled-p *drei-instance* ',mode-name) (disable-mode *drei-instance* ',mode-name) (enable-mode *drei-instance* ',mode-name)))) From thenriksen at common-lisp.net Fri Dec 28 10:08:58 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 28 Dec 2007 05:08:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20071228100858.D63D0554BD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv2026/ESA Modified Files: packages.lisp utils.lisp Log Message: Added support for "modes" (roughly similar to Emacs' minor-modes) to Drei. --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2007/12/19 15:10:20 1.7 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2007/12/28 10:08:52 1.8 @@ -42,11 +42,21 @@ #:invoke-with-dynamic-bindings #:maptree #:subtype-compatible-p + #:capitalize #:observable-mixin #:add-observer #:remove-observer #:observer-notified #:notify-observers #:name-mixin #:name - #:subscriptable-name-mixin #:subscripted-name #:subscript #:subscript-generator)) + #:subscriptable-name-mixin #:subscripted-name #:subscript #:subscript-generator + #:mode #:modual-mixin + #:available-modes + #:mode-directly-applicable-p #:mode-applicable-p + #:mode-enabled-p + #:enabled-modes + #:nonapplicable-mode + #:change-class-for-enabled-mode + #:change-class-for-disabled-mode + #:enable-mode #:disable-mode)) (defpackage :esa (:use :clim-lisp :clim :esa-utils) --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2007/12/08 08:53:48 1.4 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2007/12/28 10:08:52 1.5 @@ -213,6 +213,12 @@ (some (lambda (x) (subtypep x `(and , at types))) types)) +(defun capitalize (string) + "Return `string' with the first character +capitalized (destructively modified)." + (setf (elt string 0) (char-upcase (elt string 0))) + string) + (defclass observable-mixin () ((%observers :accessor observers :initform '())) @@ -308,3 +314,165 @@ (defmethod (setf name) :after (new-name (name-mixin subscriptable-name-mixin)) (setf (subscript name-mixin) (funcall (subscript-generator name-mixin) new-name))) + +;;; "Modes" are a generally useful concept, so let's define some +;;; primitives for them here. + +(defclass mode () + () + (:documentation "A superclass for all modes.")) + +(defclass modual-mixin () + ((%original-class-name :accessor original-class-name + :documentation "The original name of the +class the `modual-mixin' is part of, the actual name will change +as modes are added and removed.")) + (:documentation "A mixin for objects supporting modes.")) + +(defmethod initialize-instance :after ((object modual-mixin) &rest initargs) + (declare (ignore initargs)) + (setf (original-class-name object) (class-name (class-of object)))) + +(defgeneric available-modes (modual) + (:documentation "Return all available modes for `modual'. Not +all of the modes may be applicable, use the `applicable-modes' +function if you're only interested in these.") + (:method-combination append) + (:method append ((modual modual-mixin)) + '())) + +(defgeneric mode-directly-applicable-p (modual mode-name) + (:documentation "Return true if the mode of the name +`mode-name' can be directly enabled for `modual'. If the mode of +name `mode-name' is unapplicable, an error of type +`nonapplicable-mode' will be signalled. This allows a sort of +\"opt-out\" where a mode can forcefully prevent another specific +mode from being enabled. ") + (:method-combination or) + (:method or ((modual modual-mixin) mode-name) + nil)) + +(defgeneric mode-applicable-p (modual mode-name) + (:documentation "Return true if the mode of the name +`mode-name' can be enabled for `modual' or some sub-object of +`modual'. If the mode of name `mode-name' is unapplicable, an +error of type `nonapplicable-mode' will be signalled. This allows +a sort of \"opt-out\" where a mode can forcefully prevent another +specific mode from being enabled. ") + (:method-combination or) + (:method or ((modual modual-mixin) mode-name) + (mode-directly-applicable-p modual mode-name))) + +(defgeneric enabled-modes (modual) + (:documentation "Return a list of the names of the modes +directly enabled for `modual'.") + (:method-combination append) + (:method append ((modual modual-mixin)) + '())) + +(defgeneric mode-enabled-p (modual mode-name) + (:documentation "Return true if `mode-name' is enabled for +`modual' or any modual \"sub-objects\"." ) + (:method-combination or) + (:method or ((modual modual-mixin) mode-name) + (member mode-name (enabled-modes modual) :test #'equal))) + +(define-condition nonapplicable-mode (error) + ((%modual :accessor modual + :initarg :modual + :initform (error "The modual used in the error-causing operation must be supplied") + :documentation "The modual that the mode is attempted to be enabled for") + (%mode-name :accessor mode-name + :initarg :mode-name + :initform (error "The name of the problematic mode must be supplied") + :documentation "The name of the mode that cannot be enabled for the view")) + (:documentation "This error is signalled if a mode is attempted +enabled for a modual that the mode is not applicable to.") + (:report (lambda (condition stream) + (format + stream "The mode ~A is not applicable for ~A" + (mode-name condition) (modual condition))))) + +(defun nonapplicable-mode (modual mode-name) + "Signal an error of type `nonapplicable-mode' with `modual' and +`mode-name' as arguments." + (error 'nonapplicable-mode :modual modual :mode-name mode-name)) + +(defgeneric enable-mode (modual mode-name &rest initargs) + (:documentation "Enable the mode of the name `mode-name' for +`modual', using `initargs' as options for the mode. If the mode +is already enabled, do nothing. If the mode is not applicable to +`modual', signal an `nonapplicable-mode' error.") + (:method :around ((modual modual-mixin) mode-name &rest initargs) + (declare (ignore initargs)) + (unless (mode-enabled-p modual mode-name) + (call-next-method)))) + +(defgeneric disable-mode (modual mode-name) + (:documentation "Disable the mode of the name `mode-name' for +`modual'. If a mode of the provided name is not enabled, do +nothing.") + (:method :around ((modual modual-mixin) mode-name) + (when (mode-enabled-p modual mode-name) + (call-next-method)))) + +;;; In a perfect world, we would just combine `change-class' with +;;; anonymous classes to transparently add and remove mode classes +;;; (the "stealth mixin" concept). However, anonymous classes are the +;;; ugly child of CL, not well supported at all, so we'll have to do +;;; some ugly hacks involving the `eval'ing of constructed `defclass' +;;; forms, and caching the created classes to prevent memory leaking. + +(defvar *class-cache* (make-hash-table :test #'equal) + "A hash table mapping the name of a \"modual\" class to a +second hash table. This second hash table maps a list of mode +names to a class implementing this particular set of modes for +the modual class. Note that the order in which the modes appear +in the list is significant.") + +(defun make-class-implementing-modes (modual modes) + "Generate a class that is a subclass of `modual' that +implements all the modes listed as names in `modes'." + ;; Avert thine eyes, thy of gentle spirit. + (if (null modes) + (find-class modual) + (eval `(defclass ,(gensym) (,modual , at modes) ())))) + +(defun find-class-implementing-modes (modual modes) + "Find, possibly create, the class implementing `modual' (a +class name) with `modes' (a list of mode names) as the enabled +modes." + (let* ((modual-cache-hit (gethash modual *class-cache*)) + (modes-cache-hit (and modual-cache-hit + (gethash modes modual-cache-hit)))) + (or modes-cache-hit + (setf (gethash modes + (or modual-cache-hit + (setf (gethash modual *class-cache*) + (make-hash-table :test #'equal)))) + (make-class-implementing-modes modual modes))))) + +(defun change-class-for-enabled-mode (modual mode-name &rest initargs) + "Change the class of `modual' so that it has a mode of name +`mode-name', created with the provided `initargs'." + (apply #'change-class modual (find-class-implementing-modes + (original-class-name modual) + (cons mode-name (enabled-modes modual))) + initargs)) + +(defun change-class-for-disabled-mode (modual mode-name) + "Change the class of `modual' so that it does not have a mode +of name `mode-name'." + (change-class modual (find-class-implementing-modes + (original-class-name modual) + (remove mode-name (enabled-modes modual) + :test #'equal)))) + +(defmethod enable-mode ((modual modual-mixin) mode-name &rest initargs) + (if (mode-directly-applicable-p modual mode-name) + (apply #'change-class-for-enabled-mode modual mode-name initargs) + (nonapplicable-mode modual mode-name))) + +(defmethod disable-mode ((modual modual-mixin) mode-name) + (when (mode-directly-applicable-p modual mode-name) + (change-class-for-disabled-mode modual mode-name))) From thenriksen at common-lisp.net Fri Dec 28 10:08:59 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 28 Dec 2007 05:08:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071228100859.B4DFE5D101@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv2026 Modified Files: mcclim.asd Log Message: Added support for "modes" (roughly similar to Emacs' minor-modes) to Drei. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/21 15:21:28 1.69 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/12/28 10:08:58 1.70 @@ -292,9 +292,10 @@ (:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring" "delegating-buffer")) (:file "syntax" :depends-on ("packages" "buffer" "base")) + (:file "modes" :depends-on ("packages" "syntax")) (:file "views" :depends-on ("packages" "buffer" "base" "syntax" "persistent-undo" "persistent-buffer" "undo" "abbrev" - "delegating-buffer")) + "delegating-buffer" "modes")) (:file "drei" :depends-on ("packages" "views" "motion" "editing")) (:file "drei-clim" :depends-on ("drei")) (:file "drei-redisplay" :depends-on ("drei-clim")) From ahefner at common-lisp.net Mon Dec 31 23:34:53 2007 From: ahefner at common-lisp.net (ahefner) Date: Mon, 31 Dec 2007 18:34:53 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20071231233453.5E4912826D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv21458 Modified Files: listener.lisp Log Message: Call disown-frame, so that the window doesn't linger after it is supposed to have closed. This is necessary because run-listener passes a :frame-manager argument to make-application-frame, which causes adoption to occur there rather than run-frame-top-level, and the logic in run-frame-top-level wants to revert the frame to the state it was in upon entering, which is adopted and disabled, rather than disowned. That is, if the frame was adopted before entering run-frame-top-level (and in this instance, the spec requires that make-application-frame do so), it unreasonable to expect run-frame-top-level to disown it, implying we must do it ourself. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/12/13 07:57:15 1.36 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/12/31 23:34:53 1.37 @@ -158,13 +158,14 @@ port frame-manager (process-name "Listener")) - (let* ((fm (or frame-manager - (find-frame-manager :port (or port (find-port))))) + (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 () (run-frame-top-level frame))) + (flet ((run () + (unwind-protect (run-frame-top-level frame) + (disown-frame fm frame)))) (if new-process (values (clim-sys:make-process #'run :name process-name) frame)