From thenriksen at common-lisp.net Mon Apr 3 20:51:51 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 3 Apr 2006 16:51:51 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060403205151.6237E4D00C@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv24499 Modified Files: lisp-syntax.lisp Log Message: Added new `form-operator' utility function, added some minor performance improvements and made the paren-matcher highlight both matching parens. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/03/01 19:32:07 1.46 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/03 20:51:51 1.47 @@ -1252,7 +1252,7 @@ (defmethod display-parse-tree (parse-symbol syntax pane) (loop for child in (children parse-symbol) - do (display-parse-tree child syntax pane))) + do (display-parse-tree child syntax pane))) (defmethod display-parse-tree ((parse-symbol error-symbol) (syntax lisp-syntax) pane) (let ((children (children parse-symbol))) @@ -1282,7 +1282,7 @@ (or (symbolp object) (stringp object))) (defmethod display-parse-tree ((parse-symbol token-mixin) (syntax lisp-syntax) pane) - (if (> (end-offset parse-symbol) (start-offset parse-symbol)) + (if (> (the fixnum (end-offset parse-symbol)) (the fixnum (start-offset parse-symbol))) (let ((string (coerce (buffer-sequence (buffer syntax) (start-offset parse-symbol) (end-offset parse-symbol)) @@ -1431,13 +1431,22 @@ #'eval-fc conditionals))))))))) (defmethod display-parse-tree ((parse-symbol complete-list-form) (syntax lisp-syntax) pane) - (let ((children (children parse-symbol))) - (if (= (end-offset parse-symbol) (offset (point pane))) + (let* ((children (children parse-symbol)) + (point-offset (the fixnum (offset (point pane)))) + ;; The following is set to true if the location if the point + ;; warrants highlighting of a set of matching parantheses. + (should-highlight (or (= (the fixnum (end-offset parse-symbol)) point-offset) + (= (the fixnum (start-offset parse-symbol)) point-offset)))) + (if should-highlight (with-text-face (pane :bold) (display-parse-tree (car children) syntax pane)) (display-parse-tree (car children) syntax pane)) - (loop for child in (cdr children) - do (display-parse-tree child syntax pane)))) + (loop for child-list on (cdr children) + if (and should-highlight (null (cdr child-list))) do + (with-text-face (pane :bold) + (display-parse-tree (car child-list) syntax pane)) + else do + (display-parse-tree (car child-list) syntax pane)))) (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax lisp-syntax) current-p) (with-slots (top bot) pane @@ -1447,7 +1456,7 @@ (setf *white-space-start* (offset top))) (let ((*current-faces* *standard-faces*)) (with-slots (stack-top) syntax - (display-parse-tree stack-top syntax pane))) + (display-parse-tree stack-top syntax pane))) (when (mark-visible-p pane) (display-mark pane syntax)) (display-cursor pane syntax current-p)) @@ -1665,6 +1674,17 @@ (defun in-comment-p (mark syntax) (in-type-p mark syntax 'comment)) +(defgeneric form-operator (form syntax) + (:documentation "Return the operator of `form' as a +symbol. Returns nil if none can be found.") + (:method (form syntax) nil)) + +(defmethod form-operator ((form list-form) syntax) + (let* ((operator-token (first-form (rest (children form)))) + (operator-symbol (when operator-token + (token-to-symbol syntax operator-token)))) + operator-symbol)) + ;;; shamelessly replacing SWANK code ;; We first work through the string removing the characters and noting ;; which ones are escaped. We then replace each character with the From thenriksen at common-lisp.net Sat Apr 8 22:34:09 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 8 Apr 2006 18:34:09 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060408223409.299615E0CC@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv15002 Modified Files: esa.asd Log Message: Added somewhat proper file dependencies. --- /project/climacs/cvsroot/esa/esa.asd 2006/03/25 00:08:07 1.1.1.1 +++ /project/climacs/cvsroot/esa/esa.asd 2006/04/08 22:34:09 1.2 @@ -8,5 +8,5 @@ :components ((:file "packages") (:file "colors" :depends-on ("packages")) (:file "esa" :depends-on ("colors" "packages")) - (:file "esa-buffer" :depends-on ("packages")) - (:file "esa-io" :depends-on ("packages")))) + (:file "esa-buffer" :depends-on ("packages" "esa")) + (:file "esa-io" :depends-on ("packages" "esa")))) From thenriksen at common-lisp.net Sat Apr 8 23:36:44 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 8 Apr 2006 19:36:44 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060408233644.69101111CA@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv22755 Modified Files: packages.lisp esa.lisp Log Message: Added `with-minibuffer-stream' and switched implementation of minibuffer to use an output record instead of a string. --- /project/climacs/cvsroot/esa/packages.lisp 2006/03/25 00:08:07 1.1.1.1 +++ /project/climacs/cvsroot/esa/packages.lisp 2006/04/08 23:36:44 1.2 @@ -1,6 +1,7 @@ (defpackage :esa (:use :clim-lisp :clim) (:export #:minibuffer-pane #:display-message + #:with-minibuffer-stream #:esa-pane-mixin #:previous-command #:info-pane #:master-pane #:esa-frame-mixin #:windows #:recordingp #:executingp --- /project/climacs/cvsroot/esa/esa.lisp 2006/03/27 15:38:19 1.5 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/04/08 23:36:44 1.6 @@ -42,30 +42,49 @@ displayed." ) (defclass minibuffer-pane (application-pane) - ((message :initform nil :accessor message) - (message-time :initform 0 :accessor message-time)) + ((message :initform nil + :accessor message + :documentation "An output record containing whatever + message is supposed to be displayed in the + minibuffer.") + (message-time :initform 0 + :accessor message-time + :documentation "The universal time at which the + current message was set.")) (:default-initargs - :scroll-bars nil - :display-function 'display-minibuffer)) - -(defun display-minibuffer (frame pane) - (declare (ignore frame)) - (with-slots (message) pane - (unless (null message) - (princ message pane) - (when (> (get-universal-time) - (+ *minimum-message-time* (message-time pane))) - (setf message nil))))) + :scroll-bars nil + :display-function 'display-minibuffer)) (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args) (declare (ignore type args)) (window-clear pane)) +(defun display-minibuffer (frame pane) + (declare (ignore frame)) + (when (message pane) + (if (> (get-universal-time) + (+ *minimum-message-time* (message-time pane))) + (setf (message pane) nil) + (replay-output-record (message pane) pane)))) + +(defmacro with-minibuffer-stream ((stream-symbol) + &body body) + "Bind `stream-symbol' to the minibuffer stream and evaluate + `body'. This macro makes sure to setup the initial blanking of + the minibuffer as well as taking care of for how long the + message should be displayed." + `(let ((,stream-symbol *standard-input*)) + (setf (message ,stream-symbol) + (with-output-to-output-record (,stream-symbol) + (window-clear ,stream-symbol) + (setf (message-time ,stream-symbol) (get-universal-time)) + , at body)))) + (defun display-message (format-string &rest format-args) - (setf (message *standard-input*) - (apply #'format nil format-string format-args)) - (setf (message-time *standard-input*) - (get-universal-time))) + "Display a message in the minibuffer. Composes the string based +on the `format-string' and the `format-args'." + (with-minibuffer-stream (minibuffer) + (apply #'format minibuffer format-string format-args))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -323,6 +342,7 @@ ;; for presentation-to-command-translators, ;; which are searched for in ;; (frame-command-table *application-frame*) + (redisplay-frame-pane frame (frame-standard-input frame) :force-p t) (setf (frame-command-table frame) command-table) (process-gestures-or-command frame command-table)) (abort-gesture () From thenriksen at common-lisp.net Wed Apr 12 18:52:00 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 12 Apr 2006 14:52:00 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060412185200.35C572608C@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv29577 Modified Files: lisp-syntax.lisp Log Message: Changed `first-form', `rest-forms' etc. to `first-noncomment', `rest-noncomments' (since that's what the functions do). --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/03 20:51:51 1.47 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/12 18:52:00 1.48 @@ -1080,7 +1080,7 @@ (let ((buffer (buffer syntax))) (flet ((test (x) (when (typep x 'complete-list-form) - (let ((candidate (second-form (children x)))) + (let ((candidate (second-noncomment (children x)))) (and (typep candidate 'token-mixin) (eq (parse-symbol (coerce (buffer-sequence (buffer syntax) (start-offset candidate) @@ -1090,7 +1090,7 @@ (with-slots (stack-top) syntax (let ((form (find-if #'test (children stack-top)))) (when form - (let ((package-form (third-form (children form)))) + (let ((package-form (third-noncomment (children form)))) (when package-form (let ((package-name (typecase package-form @@ -1109,14 +1109,14 @@ (quote-form (coerce (buffer-sequence buffer - (start-offset (second-form (children package-form))) - (end-offset (second-form (children package-form)))) + (start-offset (second-noncomment (children package-form))) + (end-offset (second-noncomment (children package-form)))) 'string)) (uninterned-symbol-form (coerce (buffer-sequence buffer - (start-offset (second-form (children package-form))) - (end-offset (second-form (children package-form)))) + (start-offset (second-noncomment (children package-form))) + (end-offset (second-noncomment (children package-form)))) 'string)) (t 'nil)))) (when package-name @@ -1150,11 +1150,11 @@ ;;; ;;; accessing parser forms -(defun first-form (list) +(defun first-noncomment (list) "Returns the first non-comment in list." (find-if-not #'(lambda (item) (typep item 'comment)) list)) -(defun rest-forms (list) +(defun rest-noncomments (list) "Returns the remainder of the list after the first non-comment, stripping leading comments." (loop for rest on list @@ -1163,7 +1163,7 @@ until (= forms 2) finally (return rest))) -(defun nth-form (n list) +(defun nth-noncomment (n list) "Returns the nth non-comment in list." (loop for item in list count (not (typep item 'comment)) @@ -1171,17 +1171,17 @@ until (> forms n) finally (return item))) -(defun elt-form (list n) +(defun elt-noncomment (list n) "Returns the nth non-comment in list." - (nth-form n list)) + (nth-noncomment n list)) -(defun second-form (list) +(defun second-noncomment (list) "Returns the second non-comment in list." - (nth-form 1 list)) + (nth-noncomment 1 list)) -(defun third-form (list) +(defun third-noncomment (list) "Returns the third non-comment in list." - (nth-form 2 list)) + (nth-noncomment 2 list)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1372,7 +1372,7 @@ (defmethod display-parse-tree ((parse-symbol reader-conditional-positive-form) (syntax lisp-syntax) pane) - (let ((conditional (second-form (children parse-symbol)))) + (let ((conditional (second-noncomment (children parse-symbol)))) (if (eval-feature-conditional conditional syntax) (call-next-method) (let ((*current-faces* *reader-conditional-faces*)) @@ -1381,7 +1381,7 @@ (defmethod display-parse-tree ((parse-symbol reader-conditional-negative-form) (syntax lisp-syntax) pane) - (let ((conditional (second-form (children parse-symbol)))) + (let ((conditional (second-noncomment (children parse-symbol)))) (if (eval-feature-conditional conditional syntax) (let ((*current-faces* *reader-conditional-faces*)) (with-face (:reader-conditional) @@ -1408,10 +1408,10 @@ (defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax)) (let ((children (children conditional))) - (when (third-form children) + (when (third-noncomment children) (flet ((eval-fc (conditional) (funcall #'eval-feature-conditional conditional syntax))) - (let* ((type (second-form children)) + (let* ((type (second-noncomment children)) (conditionals (butlast (nthcdr 2 @@ -1473,10 +1473,10 @@ (form-before-in-children (children first) offset)))) ((and (>= offset (end-offset first)) (or (null rest) - ;; `first-form' may return NIL if there are nothing but + ;; `first-noncomment' may return NIL if there are nothing but ;; comments left; in that case, just take a comment ;; with `first'. - (<= offset (start-offset (or (first-form rest) + (<= offset (start-offset (or (first-noncomment rest) (first rest)))))) (return (let ((potential-form (when (typep first 'list-form) @@ -1680,7 +1680,7 @@ (:method (form syntax) nil)) (defmethod form-operator ((form list-form) syntax) - (let* ((operator-token (first-form (rest (children form)))) + (let* ((operator-token (first-noncomment (rest (children form)))) (operator-symbol (when operator-token (token-to-symbol syntax operator-token)))) operator-symbol)) @@ -1840,8 +1840,8 @@ (and (null (cdr path)) (zerop (car path)))) (values tree 0)) ((null (cdr path)) - (values (elt-form (children tree) (1- (car path))) 0)) - (t (indent-form syntax (elt-form (children tree) (car path)) (cdr path))))) + (values (elt-noncomment (children tree) (1- (car path))) 0)) + (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) ;; FIXME: The next two methods are basically identical to the above definition, ;; something should be done about this duplication. @@ -1851,22 +1851,22 @@ (and (null (cdr path)) (zerop (car path)))) (values tree 0)) ((null (cdr path)) - (values (elt-form (children tree) (1- (car path))) 0)) - (t (indent-form syntax (elt-form (children tree) (car path)) (cdr path))))) + (values (elt-noncomment (children tree) (1- (car path))) 0)) + (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) (defmethod indent-form ((syntax lisp-syntax) (tree reader-conditional-negative-form) path) (cond ((or (null path) (and (null (cdr path)) (zerop (car path)))) (values tree 0)) ((null (cdr path)) - (values (elt-form (children tree) (1- (car path))) 0)) - (t (indent-form syntax (elt-form (children tree) (car path)) (cdr path))))) + (values (elt-noncomment (children tree) (1- (car path))) 0)) + (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) (defmethod indent-form ((syntax lisp-syntax) (tree list-form) path) (if (= (car path) 1) ;; before first element (values tree 1) - (let ((first-child (elt-form (children tree) 1))) + (let ((first-child (elt-noncomment (children tree) 1))) (cond ((and (typep first-child 'token-mixin) (token-to-symbol syntax first-child)) (compute-list-indentation syntax (token-to-symbol syntax first-child) tree path)) @@ -1874,12 +1874,12 @@ ;; top level (if (= (car path) 2) ;; indent like first element - (values (elt-form (children tree) 1) 0) + (values (elt-noncomment (children tree) 1) 0) ;; indent like second element - (values (elt-form (children tree) 2) 0))) + (values (elt-noncomment (children tree) 2) 0))) (t ;; inside a subexpression - (indent-form syntax (elt-form (children tree) (car path)) (cdr path))))))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))))) (defmethod indent-form ((syntax lisp-syntax) (tree string-form) path) (values tree 1)) @@ -1894,10 +1894,10 @@ (values tree 0)) (defmethod indent-form ((syntax lisp-syntax) (tree quote-form) path) - (indent-form syntax (elt-form (children tree) (car path)) (cdr path))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))) (defmethod indent-form ((syntax lisp-syntax) (tree backquote-form) path) - (indent-form syntax (elt-form (children tree) (car path)) (cdr path))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))) (defmethod indent-binding ((syntax lisp-syntax) tree path) (if (null (cdr path)) @@ -1907,11 +1907,11 @@ (values tree 1)) ((= (car path) 2) ;; between variable and value - (values (elt-form (children tree) 1) 0)) + (values (elt-noncomment (children tree) 1) 0)) (t ;; after value - (values (elt-form (children tree) 2) 0))) - (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))) + (values (elt-noncomment (children tree) 2) 0))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod indent-bindings ((syntax lisp-syntax) tree path) (if (null (cdr path)) @@ -1920,20 +1920,20 @@ ;; before first binding, indent 1 (values tree 1) ;; after some bindings, align with first binding - (values (elt-form (children tree) 1) 0)) + (values (elt-noncomment (children tree) 1) 0)) ;; inside a bind form - (indent-binding syntax (elt-form (children tree) (car path)) (cdr path)))) + (indent-binding syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod compute-list-indentation ((syntax lisp-syntax) symbol tree path) (if (null (cdr path)) ;; top level (if (= (car path) 2) ;; indent like first child - (values (elt-form (children tree) 1) 0) + (values (elt-noncomment (children tree) 1) 0) ;; indent like second child - (values (elt-form (children tree) 2) 0)) + (values (elt-noncomment (children tree) 2) 0)) ;; inside a subexpression - (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmacro define-list-indentor (name element-indentor) `(defun ,name (syntax tree path) @@ -1943,9 +1943,9 @@ ;; indent one more than the list (values tree 1) ;; indent like the first element - (values (elt-form (children tree) 1) 0)) + (values (elt-noncomment (children tree) 1) 0)) ;; inside an element - (,element-indentor syntax (elt-form (children tree) (car path)) (cdr path))))) + (,element-indentor syntax (elt-noncomment (children tree) (car path)) (cdr path))))) ;;; line up the elements vertically (define-list-indentor indent-list indent-list) @@ -1967,8 +1967,8 @@ ,@(loop for fun in (cdr template) for i from 2 collect `((= (car path) ,i) - (,fun syntax (elt-form (children tree) ,i) (cdr path)))) - (t (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))))) + (,fun syntax (elt-noncomment (children tree) ,i) (cdr path)))) + (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (define-simple-indentor (progn)) (define-simple-indentor (prog1 indent-form)) @@ -2003,13 +2003,13 @@ (case (car path) ((2 3) ;; in the class name or superclasses respectively - (indent-list syntax (elt-form (children tree) (car path)) (cdr path))) + (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path))) (4 ;; in the slot specs - (indent-slot-specs syntax (elt-form (children tree) 4) (cdr path))) + (indent-slot-specs syntax (elt-noncomment (children tree) 4) (cdr path))) (t ;; this is an approximation, might want to do better - (indent-list syntax (elt-form (children tree) (car path)) (cdr path)))))) + (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'defgeneric)) tree path) @@ -2019,13 +2019,13 @@ (case (car path) (2 ;; in the function name - (indent-list syntax (elt-form (children tree) 2) (cdr path))) + (indent-list syntax (elt-noncomment (children tree) 2) (cdr path))) (3 ;; in the lambda-list - (indent-ordinary-lambda-list syntax (elt-form (children tree) 3) (cdr path))) + (indent-ordinary-lambda-list syntax (elt-noncomment (children tree) 3) (cdr path))) (t ;; in the options or method specifications - (indent-list syntax (elt-form (children tree) (car path)) (cdr path)))))) + (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'defmethod)) tree path) @@ -2040,11 +2040,11 @@ 2))) ((or (null lambda-list-pos) (< (car path) lambda-list-pos)) - (indent-list syntax (elt-form (children tree) (car path)) (cdr path))) + (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path))) ((= (car path) lambda-list-pos) - (indent-ordinary-lambda-list syntax (elt-form (children tree) (car path)) (cdr path))) + (indent-ordinary-lambda-list syntax (elt-noncomment (children tree) (car path)) (cdr path))) (t - (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (defun indent-clause (syntax tree path) (if (null (cdr path)) @@ -2052,8 +2052,8 @@ (case (car path) (1 (values tree 1)) (2 (values tree 1)) - (t (values (elt-form (children tree) 2) 0))) - (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))) + (t (values (elt-noncomment (children tree) 2) 0))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'cond)) tree path) @@ -2063,9 +2063,9 @@ ;; after `cond' (values tree 2) ;; indent like the first clause - (values (elt-form (children tree) 2) 0)) + (values (elt-noncomment (children tree) 2) 0)) ;; inside a clause - (indent-clause syntax (elt-form (children tree) (car path)) (cdr path)))) + (indent-clause syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (macrolet ((def (symbol) `(defmethod compute-list-indentation @@ -2074,8 +2074,8 @@ (case (car path) (2 (values tree 4)) (3 (values tree 2)) - (t (values (elt-form (children tree) 3) 0))) - (indent-clause syntax (elt-form (children tree) (car path)) (cdr path)))))) + (t (values (elt-noncomment (children tree) 3) 0))) + (indent-clause syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (def case) (def ccase) (def ecase) @@ -2091,10 +2091,10 @@ ;; the symbol existing in the current image. (Arguably, too, ;; this is a broken indentation form because it doesn't carry ;; over to the implicit tagbodies in macros such as DO. - (if (typep (elt-form (children tree) (car path)) 'token-mixin) + (if (typep (elt-noncomment (children tree) (car path)) 'token-mixin) (values tree 2) (values tree 4)) - (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod indent-local-function-definition ((syntax lisp-syntax) tree path) (cond ((null (cdr path)) @@ -2104,14 +2104,14 @@ (values tree 1)) ((= (car path) 2) ;; between name and lambda list, indent 4 - (values (elt-form (children tree) 1) 4)) + (values (elt-noncomment (children tree) 1) 4)) (t ;; after lambda list, indent 2 - (values (elt-form (children tree) 1) 2)))) + (values (elt-noncomment (children tree) 1) 2)))) ((= (car path) 1) ;; inside lambda list - (indent-ordinary-lambda-list syntax (elt-form (children tree) 1) (cdr path))) - (t (indent-form syntax (elt-form (children tree) (car path)) (cdr path))))) + (indent-ordinary-lambda-list syntax (elt-noncomment (children tree) 1) (cdr path))) + (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) (define-list-indentor indent-local-function-definitions indent-local-function-definition) @@ -2132,12 +2132,12 @@ (defun compute-path-in-trees (trees n offset) (cond ((or (null trees) - (>= (start-offset (first-form trees)) offset)) + (>= (start-offset (first-noncomment trees)) offset)) (list n)) - ((or (< (start-offset (first-form trees)) offset (end-offset (first-form trees))) - (typep (first-form trees) 'incomplete-form-mixin)) - (cons n (compute-path-in-tree (first-form trees) offset))) - (t (compute-path-in-trees (rest-forms trees) (1+ n) offset)))) + ((or (< (start-offset (first-noncomment trees)) offset (end-offset (first-noncomment trees))) + (typep (first-noncomment trees) 'incomplete-form-mixin)) + (cons n (compute-path-in-tree (first-noncomment trees) offset))) [12 lines skipped] From thenriksen at common-lisp.net Wed Apr 12 19:37:23 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 12 Apr 2006 15:37:23 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060412193723.D75A230000@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv3490 Modified Files: lisp-syntax.lisp Log Message: Added `first-form', `rest-forms' functions that work as expected, changed `package-of' to use them. Also removed call to Clouseau (oops). --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/12 18:52:00 1.48 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/12 19:37:23 1.49 @@ -1080,17 +1080,14 @@ (let ((buffer (buffer syntax))) (flet ((test (x) (when (typep x 'complete-list-form) - (let ((candidate (second-noncomment (children x)))) + (let ((candidate (first-form (children x)))) (and (typep candidate 'token-mixin) - (eq (parse-symbol (coerce (buffer-sequence (buffer syntax) - (start-offset candidate) - (end-offset candidate)) - 'string)) + (eq (token-to-symbol syntax candidate) 'cl:in-package)))))) (with-slots (stack-top) syntax (let ((form (find-if #'test (children stack-top)))) (when form - (let ((package-form (third-noncomment (children form)))) + (let ((package-form (second-form (children form)))) (when package-form (let ((package-name (typecase package-form @@ -1183,6 +1180,39 @@ "Returns the third non-comment in list." (nth-noncomment 2 list)) +(defun rest-forms (list) + "Returns the remainder of the list after the first form, +stripping leading non-forms." + (loop for rest on list + count (typep (car rest) 'form) + into forms + until (= forms 2) + finally (return rest))) + +(defun nth-form (n list) + "Returns the nth form in list." + (loop for item in list + count (typep item 'form) + into forms + until (> forms n) + finally (return item))) + +(defun elt-form (list n) + "Returns the nth form in list." + (nth-form n list)) + +(defun first-form (list) + "Returns the first form in list." + (nth-form 0 list)) + +(defun second-form (list) + "Returns the second form in list." + (nth-form 1 list)) + +(defun third-form (list) + "Returns the third formw in list." + (nth-form 2 list)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display @@ -2165,7 +2195,6 @@ (beginning-of-line mark) (with-slots (stack-top) syntax (let ((path (compute-path syntax (offset mark)))) - (clouseau:inspector path) (multiple-value-bind (tree offset) (indent-form syntax stack-top path) (setf (offset mark) (start-offset tree)) From thenriksen at common-lisp.net Thu Apr 13 09:25:41 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 13 Apr 2006 05:25:41 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060413092541.CC4C57D000@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv11930 Modified Files: lisp-syntax.lisp Log Message: Check whether the `package' slot of the syntax object is bound in `token-to-symbol'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/12 19:37:23 1.49 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/13 09:25:41 1.50 @@ -1851,7 +1851,8 @@ (values nil nil))))) (defun token-to-symbol (syntax token) - (let ((package (if (and (slot-value syntax 'package) + (let ((package (if (and (slot-boundp syntax 'package) + (slot-value syntax 'package) (typep (slot-value syntax 'package) 'package)) (slot-value syntax 'package) (find-package :common-lisp))) From thenriksen at common-lisp.net Thu Apr 13 10:47:48 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 13 Apr 2006 06:47:48 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060413104748.9398678001@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv22566 Modified Files: lisp-syntax.lisp Log Message: Fixed inheritance hierarchy for vector forms and made `nth-form' not return invalid values. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/13 09:25:41 1.50 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/13 10:47:48 1.51 @@ -636,8 +636,8 @@ ;;; parse trees (defclass simple-vector-form (list-form) ()) -(defclass complete-simple-vector-form (complete-list-form) ()) -(defclass incomplete-simple-vector-form (incomplete-list-form) ()) +(defclass complete-simple-vector-form (complete-list-form simple-vector-form) ()) +(defclass incomplete-simple-vector-form (incomplete-list-form simple-vector-form) ()) (define-parser-state |#( form* | (lexer-list-state form-may-follow) ()) (define-parser-state |#( form* ) | (lexer-toplevel-state parser-state) ()) @@ -1190,12 +1190,13 @@ finally (return rest))) (defun nth-form (n list) - "Returns the nth form in list." + "Returns the nth form in list or `nil'." (loop for item in list count (typep item 'form) into forms until (> forms n) - finally (return item))) + finally (when (> forms n) + (return item)))) (defun elt-form (list n) "Returns the nth form in list." From thenriksen at common-lisp.net Sun Apr 23 12:11:26 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 23 Apr 2006 08:11:26 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060423121126.CE3C244057@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28674 Modified Files: syntax.lisp packages.lisp misc-commands.lisp lisp-syntax.lisp file-commands.lisp climacs.asd Log Message: Added support for local options lines (the -*- ... -*- stuff), the generic option Syntax/Mode and Base and Package options for Lisp syntax. --- /project/climacs/cvsroot/climacs/syntax.lisp 2005/11/14 16:30:13 1.61 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/04/23 12:11:26 1.62 @@ -208,6 +208,38 @@ (:default-initargs :command-table ',command-table , at default-initargs) , at defclass-options)))) +(defgeneric eval-option (syntax name value) + (:documentation "Evaluate the option `name' with the specified + `value' for `syntax'.") + (:method (syntax name value) + ;; We do not want to error out if an invalid option is + ;; specified. Signal a condition? For now, silently ignore. + (declare (ignore syntax name value)))) + +(defmethod eval-option :around (syntax (name string) value) + ;; Convert the name to a keyword symbol... + (eval-option syntax (intern name (find-package :keyword)) + value)) + +(defmacro define-option-for-syntax + (syntax option-name (syntax-symbol value-symbol) &body body) + "Define an option for the syntax specified by the symbol + `syntax'. `Option-name' should be a string that will be the + name of the option. The name will automatically be converted to + uppercase. When the option is being evaluated, `body' will be + run, with `syntax-symbol' bound to the syntax object the option + is being evaluated for, and `value-symbol' bound to the value + of the option." + ;; The name is converted to a keyword symbol which is used for all + ;; further identification. + (let ((name-symbol (gensym)) + (symbol (intern (string-upcase option-name) + (find-package :keyword)))) + `(defmethod eval-option ((,syntax-symbol ,syntax) + (,name-symbol (eql ,symbol)) + ,value-symbol) + , at body))) + #+nil (defmacro define-syntax (class-name (name superclasses) &body body) `(progn (push '(,name . ,class-name) *syntaxes*) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/03/26 14:14:48 1.87 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/04/23 12:11:26 1.88 @@ -94,6 +94,8 @@ (defpackage :climacs-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) (:export #:syntax #:define-syntax + #:eval-option + #:define-option-for-syntax #:syntax-from-name #:basic-syntax #:update-syntax #:update-syntax-for-display --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/03/26 14:14:48 1.5 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/04/23 12:11:26 1.6 @@ -28,6 +28,13 @@ (in-package :climacs-gui) +(define-command (com-reload-local-options-line + :name t + :command-table buffer-table) + () + "Reload the local options line." + (evaluate-local-options-line (current-buffer))) + (define-command (com-overwrite-mode :name t :command-table editing-table) () (with-slots (overwrite-mode) (current-window) (setf overwrite-mode (not overwrite-mode)))) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/13 10:47:48 1.51 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 12:11:26 1.52 @@ -42,11 +42,31 @@ (current-start-mark) (current-size) (scan) - (package)) + (package) + (base :accessor base + :initform 10 + :documentation "The base which numbers in the buffer are + expected to be in.") + (option-specified-package :accessor option-specified-package + :initform nil + :documentation "The package + specified in the local options + line (may be overridden + by (in-package) forms).")) (:name "Lisp") (:pathname-types "lisp" "lsp" "cl") (:command-table lisp-table)) +(define-option-for-syntax lisp-syntax "Package" (syntax package-name) + (let ((specified-package (find-package package-name))) + (when specified-package + (setf (option-specified-package syntax) specified-package)))) + +(define-option-for-syntax lisp-syntax "Base" (syntax base) + (let ((integer-base (parse-integer base :junk-allowed t))) + (when integer-base + (setf (base syntax) integer-base)))) + (defmethod initialize-instance :after ((syntax lisp-syntax) &rest args) (declare (ignore args)) (with-slots (buffer scan) syntax --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/03/27 15:43:17 1.5 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 12:11:26 1.6 @@ -129,6 +129,67 @@ :key #'climacs-syntax::syntax-description-pathname-types)) 'basic-syntax)) +(defun parse-local-options-line (line) + "Parse the local options line `line' and return an alist + mapping options to values. All option names will be coerced to + uppercase. `Line' must be stripped of the leading and + terminating -*- tokens." + (loop for pair in (split-sequence:split-sequence #\; line) + when (find #\: pair) + collect (destructuring-bind (key value) + (loop for elem in (split-sequence:split-sequence #\: pair) + collecting (string-trim " " elem)) + (list (string-upcase key) value)))) + +(defun evaluate-local-options (buffer options) + "Evaluate the local options `options' and modify `buffer' as + appropriate. `Options' should be an alist mapping option names + to their values." + ;; First, check whether we need to change the syntax (via the SYNTAX + ;; option). MODE is an alias for SYNTAX for compatibility with + ;; Emacs. If there is more than one option with one of these names, + ;; only the first will be acted upon. + (let ((specified-syntax + (syntax-from-name + (second (find-if #'(lambda (name) + (or (string= name "SYNTAX") + (string= name "MODE"))) + options + :key #'first))))) + (when specified-syntax + (setf (syntax buffer) + (make-instance specified-syntax + :buffer buffer)))) + ;; Now we iterate through the options (discarding SYNTAX and MODE + ;; options). + (loop for (name value) in options + unless (or (string= name "SYNTAX") + (string= name "MODE")) + do (eval-option (syntax buffer) name value))) + +(defun evaluate-local-options-line (buffer) + "Evaluate the local options line of `buffer'. If `buffer' does + not have a local options line, this function is a no-op." + ;; This could be simplified a bit by using regexps. + (let* ((beginning-mark (beginning-of-buffer + (clone-mark (point buffer)))) + (end-mark (end-of-line (clone-mark beginning-mark))) + (line (buffer-sequence buffer (offset beginning-mark) (offset end-mark))) + (first-occurence (search "-*-" line)) + (second-occurence + (when first-occurence + (search "-*-" line :start2 (1+ first-occurence))))) + (when (and first-occurence + second-occurence) + ;; Strip away the -*-s. + (let ((cleaned-options-line (coerce (subseq line + (+ first-occurence 3) + second-occurence) + 'string))) + (evaluate-local-options + buffer + (parse-local-options-line cleaned-options-line)))))) + ;; Adapted from cl-fad/PCL (defun directory-pathname-p (pathspec) "Returns NIL if PATHSPEC does not designate a directory." @@ -153,13 +214,19 @@ (pane (current-window))) (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer (current-window)) buffer) - (setf (syntax buffer) - (make-instance (syntax-class-name-for-filepath filepath) - :buffer buffer)) ;; Don't want to create the file if it doesn't exist. (when (probe-file filepath) (with-open-file (stream filepath :direction :input) - (input-from-stream stream buffer 0))) + (input-from-stream stream buffer 0)) + ;; A file! That means we may have a local options + ;; line to parse. + (evaluate-local-options-line buffer)) + ;; If the local options line didn't set a syntax, do + ;; it now. + (when (null (syntax buffer)) + (setf (syntax buffer) + (make-instance (syntax-class-name-for-filepath filepath) + :buffer buffer))) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (needs-saving buffer) nil) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/03/25 21:15:21 1.43 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/04/23 12:11:26 1.44 @@ -28,7 +28,7 @@ (defparameter *climacs-directory* (directory-namestring *load-truename*)) (defsystem :climacs - :depends-on (:mcclim :flexichain :esa) + :depends-on (:mcclim :flexichain :esa :split-sequence) :components ((:module "cl-automaton" :components ((:file "automaton-package") From thenriksen at common-lisp.net Sun Apr 23 12:36:19 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 23 Apr 2006 08:36:19 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060423123619.8E19B7D002@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv1333 Modified Files: file-commands.lisp Log Message: Set (syntax buffer) to NIL so we can check whether or not the local options line has set a syntax. --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 12:11:26 1.6 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 12:36:19 1.7 @@ -212,6 +212,7 @@ (switch-to-buffer existing-buffer) (let ((buffer (make-buffer)) (pane (current-window))) + (setf (syntax buffer) nil) (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer (current-window)) buffer) ;; Don't want to create the file if it doesn't exist. From thenriksen at common-lisp.net Sun Apr 23 12:40:32 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 23 Apr 2006 08:40:32 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060423124032.081DB7C005@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv1476 Modified Files: buffer.lisp Log Message: Converted the mark movement functions return the mark instead of the modified offset. This is both more logical and far more useful. --- /project/climacs/cvsroot/climacs/buffer.lisp 2005/05/10 16:28:53 1.31 +++ /project/climacs/cvsroot/climacs/buffer.lisp 2006/04/23 12:40:31 1.32 @@ -132,12 +132,26 @@ (make-condition 'motion-after-end :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset)) -(defgeneric backward-object (mark &optional count)) +(defgeneric backward-object (mark &optional count) + (:documentation "Move `mark' `count' objects backwards. Returns + `mark'.")) + +(defmethod backward-object :around (mark &optional count) + (declare (ignore count)) + (call-next-method) + mark) (defmethod backward-object ((mark mark-mixin) &optional (count 1)) (decf (offset mark) count)) -(defgeneric forward-object (mark &optional count)) +(defgeneric forward-object (mark &optional count) + (:documentation "Move `mark' `count' objects forwards. Returns + `mark'")) + +(defmethod forward-object :around (mark &optional count) + (declare (ignore count)) + (call-next-method) + mark) (defmethod forward-object ((mark mark-mixin) &optional (count 1)) (incf (offset mark) count)) @@ -297,21 +311,32 @@ (>= mark1 (offset mark2))) (defgeneric beginning-of-buffer (mark) - (:documentation "Move the mark to the beginning of the buffer. This is equivalent to - (setf (offset mark) 0)")) + (:documentation "Move the mark to the beginning of the buffer. + This is equivalent to (setf (offset mark) 0), but returns + mark.")) + +;; Easy way to make sure mark is always returned. +(defmethod beginning-of-buffer :around (mark) + (call-next-method) + mark) (defmethod beginning-of-buffer ((mark mark-mixin)) (setf (offset mark) 0)) (defgeneric end-of-buffer (mark) - (:documentation "Move the mark to the end of the buffer.")) + (:documentation "Move the mark to the end of the buffer and + return mark.")) + +(defmethod end-of-buffer :around (mark) + (call-next-method) + mark) (defmethod end-of-buffer ((mark mark-mixin)) (setf (offset mark) (size (buffer mark)))) (defgeneric beginning-of-buffer-p (mark) - (:documentation "Return t if the mark is at the beginning of the buffer, nil - otherwise.")) + (:documentation "Return t if the mark is at the beginning of + the buffer, nil otherwise.")) (defmethod beginning-of-buffer-p ((mark mark-mixin)) (zerop (offset mark))) @@ -344,7 +369,11 @@ (:documentation "Move the mark to the beginning of the line. The mark will be positioned either immediately after the closest preceding newline character, or at the beginning of the buffer if no preceding newline - character exists.")) + character exists. Returns mark.")) + +(defmethod beginning-of-line :around (mark) + (call-next-method) + mark) (defmethod beginning-of-line ((mark mark-mixin)) (loop until (beginning-of-line-p mark) @@ -353,7 +382,11 @@ (defgeneric end-of-line (mark) (:documentation "Move the mark to the end of the line. The mark will be positioned either immediately before the closest following newline character, or -at the end of the buffer if no following newline character exists.")) +at the end of the buffer if no following newline character exists. Returns mark.")) + +(defmethod end-of-line :around (mark) + (call-next-method) + mark) (defmethod end-of-line ((mark mark-mixin)) (let* ((offset (offset mark)) From thenriksen at common-lisp.net Sun Apr 23 14:38:57 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 23 Apr 2006 10:38:57 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060423143857.B1A136400A@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv15857 Modified Files: lisp-syntax.lisp Log Message: Made `lex-token' able to discern between numbers and symbols. Also made `package-of' read the package defined in the local options line if no (in-package) forms can be found. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 12:11:26 1.52 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 14:38:57 1.53 @@ -380,7 +380,7 @@ (#\| (fo) (make-instance 'multiple-escape-start-lexeme)) (t (cond ((or (constituentp object) (eql object #\\)) - (lex-token scan)) + (lex-token syntax scan)) (t (fo) (make-instance 'error-lexeme)))))))) (defmethod lex ((syntax lisp-syntax) (state lexer-list-state) scan) @@ -446,25 +446,54 @@ (make-instance 'word-lexeme)) (t (fo) (make-instance 'delimiter-lexeme))))) -(defun lex-token (scan) - (macrolet ((fo () `(forward-object scan))) - (tagbody - start - (when (end-of-buffer-p scan) - (return-from lex-token (make-instance 'complete-token-lexeme))) - (when (constituentp (object-after scan)) - (fo) - (go start)) - (when (eql (object-after scan) #\\) - (fo) - (when (end-of-buffer-p scan) - (return-from lex-token (make-instance 'incomplete-lexeme))) - (fo) - (go start)) - (when (eql (object-after scan) #\|) - (fo) - (return-from lex-token (make-instance 'multiple-escape-start-lexeme))) - (return-from lex-token (make-instance 'complete-token-lexeme))))) +(defun lex-token (syntax scan) + ;; May need more work. Can recognize symbols and numbers. + (flet ((fo () (forward-object scan))) + (let ((could-be-number t) + sign-seen dot-seen slash-seen) + (flet ((return-token-or-number-lexeme () + (return-from lex-token + (if could-be-number + (make-instance 'number-lexeme) + (make-instance 'complete-token-lexeme)))) + (this-object () + (object-after scan))) + (tagbody + START + (when (end-of-buffer-p scan) + (return-token-or-number-lexeme)) + (when (constituentp (object-after scan)) + (cond ((or (eql (this-object) #\+) + (eql (this-object) #\-)) + (when sign-seen + (setf could-be-number nil)) + (setf sign-seen t)) + ((eql (this-object) #\.) + (when dot-seen + (setf could-be-number nil)) + (setf dot-seen t)) + ((eql (this-object) #\/) + (when slash-seen + (setf could-be-number nil)) + (setf slash-seen t)) + ;; We obey the base specified in the file when + ;; determining whether or not this character is an + ;; integer. + ((not (digit-char-p (this-object) + (base syntax))) + (setf could-be-number nil))) + (fo) + (go START)) + (when (eql (object-after scan) #\\) + (fo) + (when (end-of-buffer-p scan) + (return-from lex-token (make-instance 'incomplete-lexeme))) + (fo) + (go START)) + (when (eql (object-after scan) #\|) + (fo) + (return-from lex-token (make-instance 'multiple-escape-start-lexeme))) + (return-token-or-number-lexeme)))))) (defmethod lex ((syntax lisp-syntax) (state lexer-escaped-token-state) scan) (let ((bars-seen 0)) @@ -1106,40 +1135,41 @@ 'cl:in-package)))))) (with-slots (stack-top) syntax (let ((form (find-if #'test (children stack-top)))) - (when form - (let ((package-form (second-form (children form)))) - (when package-form - (let ((package-name - (typecase package-form - (token-mixin - (coerce (buffer-sequence - buffer - (start-offset package-form) - (end-offset package-form)) - 'string)) - (complete-string-form - (coerce (buffer-sequence - buffer - (1+ (start-offset package-form)) - (1- (end-offset package-form))) - 'string)) - (quote-form - (coerce (buffer-sequence - buffer - (start-offset (second-noncomment (children package-form))) - (end-offset (second-noncomment (children package-form)))) - 'string)) - (uninterned-symbol-form - (coerce (buffer-sequence - buffer - (start-offset (second-noncomment (children package-form))) - (end-offset (second-noncomment (children package-form)))) - 'string)) - (t 'nil)))) - (when package-name - (let ((package-symbol (parse-token package-name))) - (or (find-package package-symbol) - package-symbol)))))))))))) + (or (when form + (let ((package-form (second-form (children form)))) + (when package-form + (let ((package-name + (typecase package-form + (token-mixin + (coerce (buffer-sequence + buffer + (start-offset package-form) + (end-offset package-form)) + 'string)) + (complete-string-form + (coerce (buffer-sequence + buffer + (1+ (start-offset package-form)) + (1- (end-offset package-form))) + 'string)) + (quote-form + (coerce (buffer-sequence + buffer + (start-offset (second-noncomment (children package-form))) + (end-offset (second-noncomment (children package-form)))) + 'string)) + (uninterned-symbol-form + (coerce (buffer-sequence + buffer + (start-offset (second-noncomment (children package-form))) + (end-offset (second-noncomment (children package-form)))) + 'string)) + (t 'nil)))) + (when package-name + (let ((package-symbol (parse-token package-name))) + (or (find-package package-symbol) + package-symbol))))))) + (option-specified-package syntax))))))) (defmethod update-syntax (buffer (syntax lisp-syntax)) (let* ((low-mark (low-mark buffer)) From thenriksen at common-lisp.net Sun Apr 23 15:04:52 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 23 Apr 2006 11:04:52 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060423150452.AC2606F23C@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv19077 Modified Files: lisp-syntax.lisp Log Message: Fixed the `form-{before, after, around}-in-children' functions. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 14:38:57 1.53 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 15:04:52 1.54 @@ -1547,25 +1547,26 @@ (defun form-before-in-children (children offset) (loop for (first . rest) on children - unless (typep first 'comment) - do (cond ((< (start-offset first) offset (end-offset first)) - (return (if (null (children first)) - nil - (form-before-in-children (children first) offset)))) - ((and (>= offset (end-offset first)) - (or (null rest) - ;; `first-noncomment' may return NIL if there are nothing but - ;; comments left; in that case, just take a comment - ;; with `first'. - (<= offset (start-offset (or (first-noncomment rest) - (first rest)))))) - (return (let ((potential-form - (when (typep first 'list-form) - (form-before-in-children (children first) offset)))) - (or potential-form - (when (typep first 'form) - first))))) - (t nil)))) + if (typep first 'form) + do + (cond ((< (start-offset first) offset (end-offset first)) + (return (if (null (children first)) + nil + (form-before-in-children (children first) offset)))) + ((and (>= offset (end-offset first)) + (or (null (first-form rest)) + (<= offset (start-offset (first-form rest))))) + (return (let ((potential-form + (when (typep first 'list-form) + (form-before-in-children (children first) offset)))) + (if (not (null potential-form)) + (if (<= (end-offset first) + (end-offset potential-form)) + potential-form + first) + (when (typep first 'form) + first))))) + (t nil)))) (defun form-before (syntax offset) (with-slots (stack-top) syntax @@ -1576,17 +1577,21 @@ (defun form-after-in-children (children offset) (loop for child in children - unless (typep child 'comment) - do (cond ((< (start-offset child) offset (end-offset child)) - (return (if (null (children child)) - nil - (form-after-in-children (children child) offset)))) - ((<= offset (start-offset child)) - (return (let ((potential-form (form-after-in-children (children child) offset))) - (or potential-form - (when (typep child 'form) - child))))) - (t nil)))) + if (typep child 'form) + do (cond ((< (start-offset child) offset (end-offset child)) + (return (if (null (children child)) + nil + (form-after-in-children (children child) offset)))) + ((<= offset (start-offset child)) + (return (let ((potential-form (form-after-in-children (children child) offset))) + (if (not (null potential-form)) + (if (<= (start-offset child) + (start-offset potential-form)) + child + potential-form) + (when (typep child 'form) + child))))) + (t nil)))) (defun form-after (syntax offset) (with-slots (stack-top) syntax @@ -1597,13 +1602,15 @@ (defun form-around-in-children (children offset) (loop for child in children - unless (typep child 'comment) - do (cond ((< (start-offset child) offset (end-offset child)) - (return (if (null (children child)) + if (typep child 'form) + do (cond ((<= (start-offset child) offset (end-offset child)) + (return (if (null (first-form (children child))) (when (typep child 'form) child) - (form-around-in-children (children child) offset)))) - ((<= offset (start-offset child)) + (or (form-around-in-children (children child) offset) + (when (typep child 'form) + child))))) + ((< offset (start-offset child)) (return nil)) (t nil)))) From thenriksen at common-lisp.net Sun Apr 23 15:14:49 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 23 Apr 2006 11:14:49 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060423151449.3D0FD3064@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv19479 Modified Files: lisp-syntax.lisp Log Message: Added `token-to-object' function that will convert parser tokens to Lisp objects (for example, a `complete-list-form' to a list). Fixed a comment and some indentation. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 15:04:52 1.54 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 15:14:49 1.55 @@ -380,7 +380,7 @@ (#\| (fo) (make-instance 'multiple-escape-start-lexeme)) (t (cond ((or (constituentp object) (eql object #\\)) - (lex-token syntax scan)) + (lex-token syntax scan)) (t (fo) (make-instance 'error-lexeme)))))))) (defmethod lex ((syntax lisp-syntax) (state lexer-list-state) scan) @@ -1249,7 +1249,7 @@ (return item)))) (defun elt-form (list n) - "Returns the nth form in list." + "Returns the nth form in list or `nil'." (nth-form n list)) (defun first-form (list) @@ -1897,28 +1897,108 @@ (parse-token input readtable-case)))))) |# +(defun token-string (syntax token) + "Return the string that specifies `token' in the buffer of + `syntax'." + (coerce (buffer-sequence (buffer syntax) + (start-offset token) + (end-offset token)) + 'string)) + (defun parse-symbol (string &optional (package *package*)) "Find the symbol named STRING. -Return the symbol and a flag indicating whether the symbol was found." +Return the symbol and a flag indicating whether the symbol was +found in the package. Note that a symbol may be returned even if +it was not found in a package." (multiple-value-bind (symbol-name package-name) (parse-token string) (let ((package (cond ((string= package-name "") +keyword-package+) (package-name (find-package package-name)) (t package)))) - (if package - (find-symbol symbol-name package) - (values nil nil))))) + (or (and package + (find-symbol symbol-name package)) + (values (make-symbol symbol-name) nil))))) (defun token-to-symbol (syntax token) - (let ((package (if (and (slot-boundp syntax 'package) - (slot-value syntax 'package) - (typep (slot-value syntax 'package) 'package)) - (slot-value syntax 'package) - (find-package :common-lisp))) - (token-string (coerce (buffer-sequence (buffer syntax) - (start-offset token) - (end-offset token)) - 'string))) - (parse-symbol token-string package))) + "Return the symbol `token' represents. If `token' represents +anything else than a symbol, or it cannot be correctly converted +to a symbol, return nil. If the symbol cannot be found in a +package, an uninterned symbol will be returned." + (let ((result (token-to-object syntax token t))) + (when (symbolp result) + result))) + +;; FIXME? This generic function often errors on erroneous input. Since +;; we are an editor, we might consider being a bit more lenient. Also, +;; it will never intern symbols itself, but return NIL for uninterned +;; symbols. +(defgeneric token-to-object (syntax token &optional no-error) + (:documentation "Return the Lisp object `token' would evaluate + to if read. An attempt will be made to construct objects from + incomplete tokens. This function may signal an error if + `no-error' is nil and `token' cannot be converted to a Lisp + object. Otherwise, nil will be returned.") + (:method :around (syntax token &optional no-error) + ;; Ensure that every symbol that is READ will be looked up + ;; in the correct package. + (handler-case (let ((*package* (if (and (slot-boundp syntax 'package) + (slot-value syntax 'package) + (typep (slot-value syntax 'package) 'package)) + (slot-value syntax 'package) + (find-package :common-lisp)))) + (call-next-method)) + (t () + (unless no-error + (error "Cannot convert token to Lisp object: ~A" token))))) + (:method (syntax (token t) &optional no-error) + (declare (ignore no-error)) + ;; We ignore `no-error' as it is truly a bug in Climacs if no + ;; handler method is specialized on this form. + (error "Cannot convert token to Lisp object: ~A" + token)) + (:method (syntax (token incomplete-form-mixin) &optional no-error) + (unless no-error + (error "Cannot convert incomplete form to Lisp object: ~A" + token)))) + +(defmethod token-to-object (syntax (token complete-token-lexeme) &optional no-error) + (declare (ignore no-error)) + (parse-symbol (token-string syntax token))) + +(defmethod token-to-object (syntax (token number-lexeme) &optional no-error) + (declare (ignore no-error)) + (let ((*read-base* (base syntax))) + (read-from-string (token-string syntax token)))) + +(defmethod token-to-object (syntax (token list-form) &optional no-error) + (declare (ignore no-error)) + (mapcar #'(lambda (form) + (token-to-object syntax form)) + (remove-if-not #'(lambda (form) + (typep form 'form)) + (children token)))) + +(defmethod token-to-object (syntax (token simple-vector-form) &optional no-error) + (declare (ignore no-error)) + (apply #'vector + (mapcar #'(lambda (form) + (token-to-object syntax form)) + (remove-if-not #'(lambda (form) + (typep form 'form)) + (children token))))) + +(defmethod token-to-object (syntax (token incomplete-string-form) &optional no-error) + (declare (ignore no-error)) + (read-from-string (concatenate 'string + (token-string syntax token) + "\""))) + +(defmethod token-to-object (syntax (token complete-string-form) &optional no-error) + (declare (ignore no-error)) + (read-from-string (token-string syntax token))) + +(defmethod token-to-object (syntax (token quote-form) &optional no-error) + (list 'cl:quote + (token-to-object syntax (second (children token)) no-error))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Sun Apr 23 15:17:17 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 23 Apr 2006 11:17:17 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060423151717.BC79A13001@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv20924 Modified Files: lisp-syntax.lisp Log Message: Added convenience functions for picking out elements of forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 15:14:49 1.55 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 15:17:17 1.56 @@ -1264,6 +1264,36 @@ "Returns the third formw in list." (nth-form 2 list)) +(defgeneric form-operator (form syntax) + (:documentation "Return the operator of `form' as a Lisp +object. Returns nil if none can be found.") + (:method (form syntax) nil)) + +(defmethod form-operator ((form list-form) syntax) + (let* ((operator-token (first-form (rest (children form)))) + (operator-symbol (when operator-token + (token-to-object syntax operator-token t)))) + operator-symbol)) + +(defgeneric form-operands (form syntax) + (:documentation "Returns the operands of `form' as a list of + Lisp objects. Returns nil if none can be found.") + (:method (form syntax) nil)) + +(defmethod form-operands ((form list-form) syntax) + ;; If *anything' goes wrong, just assume that we could not find any + ;; operands and return nil. + (mapcar #'(lambda (operand) + (if (typep operand 'form) + (token-to-object syntax operand t))) + (rest-forms (children form)))) + +(defun form-toplevel (form syntax) + "Return the top-level form of `form'." + (if (null (parent (parent form))) + form + (form-toplevel (parent form) syntax))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display From thenriksen at common-lisp.net Sun Apr 23 18:38:03 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 23 Apr 2006 14:38:03 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060423183803.C2F9830018@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12015 Modified Files: file-commands.lisp Log Message: Added code to clear the pane before loading the new buffer into it. --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 12:36:19 1.7 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 18:38:03 1.8 @@ -212,6 +212,10 @@ (switch-to-buffer existing-buffer) (let ((buffer (make-buffer)) (pane (current-window))) + ;; Clear the pane, otherwise residue from the + ;; previously displayed buffer may under certain + ;; circumstances be displayed. + (window-clear pane) (setf (syntax buffer) nil) (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer (current-window)) buffer) From thenriksen at common-lisp.net Sun Apr 23 19:37:58 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 23 Apr 2006 15:37:58 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060423193758.9E78B62010@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv22484 Modified Files: pane.lisp packages.lisp file-commands.lisp Log Message: Added code to clear the cache of panes (the previous `clear-pane' invocation was apparently too naive). --- /project/climacs/cvsroot/climacs/pane.lisp 2006/03/27 19:24:07 1.36 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/04/23 19:37:58 1.37 @@ -286,6 +286,14 @@ (:default-initargs :default-view +climacs-textual-view+)) +(defgeneric clear-cache (pane) + (:documentation "Clear the cache for `pane.'")) + +(defmethod clear-cache ((pane climacs-pane)) + (with-slots (cache) pane + (setf cache (let ((cache (make-instance 'standard-flexichain))) + (insert* cache 0 nil) + cache)))) (defmethod tab-width ((pane climacs-pane)) (tab-width (stream-default-view pane))) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/04/23 12:11:26 1.88 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/04/23 19:37:58 1.89 @@ -147,6 +147,7 @@ (:export #:climacs-buffer #:needs-saving #:filepath #:read-only-p #:buffer-read-only #:climacs-pane #:point #:mark + #:clear-cache #:redisplay-pane #:full-redisplay #:display-cursor #:display-mark --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 18:38:03 1.8 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 19:37:58 1.9 @@ -212,10 +212,10 @@ (switch-to-buffer existing-buffer) (let ((buffer (make-buffer)) (pane (current-window))) - ;; Clear the pane, otherwise residue from the + ;; Clear the panes cache; otherwise residue from the ;; previously displayed buffer may under certain ;; circumstances be displayed. - (window-clear pane) + (clear-cache pane) (setf (syntax buffer) nil) (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer (current-window)) buffer) From thenriksen at common-lisp.net Sun Apr 23 21:36:23 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 23 Apr 2006 17:36:23 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060423213623.3A2DB2E188@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv5923 Modified Files: lisp-syntax.lisp Log Message: Oops. Removed blasting of secondary return value from `parse-symbol'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 15:17:17 1.56 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 21:36:23 1.57 @@ -1944,18 +1944,19 @@ (let ((package (cond ((string= package-name "") +keyword-package+) (package-name (find-package package-name)) (t package)))) - (or (and package - (find-symbol symbol-name package)) - (values (make-symbol symbol-name) nil))))) + (multiple-value-bind (symbol status) + (when package + (find-symbol symbol-name package)) + (if symbol + (values symbol status) + (values (make-symbol symbol-name) nil)))))) (defun token-to-symbol (syntax token) "Return the symbol `token' represents. If `token' represents anything else than a symbol, or it cannot be correctly converted to a symbol, return nil. If the symbol cannot be found in a package, an uninterned symbol will be returned." - (let ((result (token-to-object syntax token t))) - (when (symbolp result) - result))) + (token-to-object syntax token t)) ;; FIXME? This generic function often errors on erroneous input. Since ;; we are an editor, we might consider being a bit more lenient. Also, From crhodes at common-lisp.net Mon Apr 24 19:52:56 2006 From: crhodes at common-lisp.net (crhodes) Date: Mon, 24 Apr 2006 15:52:56 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060424195256.F404B23003@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv8220 Modified Files: esa.lisp Log Message: Don't handle all errors in com-extended-command --- /project/climacs/cvsroot/esa/esa.lisp 2006/04/08 23:36:44 1.6 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/04/24 19:52:56 1.7 @@ -472,9 +472,10 @@ (accept `(command :command-table ,(find-applicable-command-table *application-frame*)) :prompt "Extended Command") - (error () (progn (beep) - (display-message "No such command") - (return-from com-extended-command nil)))))) + ((or command-not-accessible command-not-present) () + (beep) + (display-message "No such command") + (return-from com-extended-command nil))))) (execute-frame-command *application-frame* item))) (set-key 'com-extended-command 'global-esa-table '((#\x :meta))) From thenriksen at common-lisp.net Sun Apr 30 11:59:03 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 30 Apr 2006 07:59:03 -0400 (EDT) Subject: [climacs-cvs] CVS esa Message-ID: <20060430115903.E3E9A68001@common-lisp.net> Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv10537 Modified Files: esa.lisp Log Message: Made `gesture-name' return more sensible names and fixed bug in `find-keystrokes-for-command'. --- /project/climacs/cvsroot/esa/esa.lisp 2006/04/24 19:52:56 1.7 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/04/30 11:59:03 1.8 @@ -510,8 +510,11 @@ (defgeneric gesture-name (gesture)) (defmethod gesture-name ((char character)) - (or (char-name char) - char)) + (if (and (graphic-char-p char) + (not (char= char #\Space))) + (string char) + (or (char-name char) + char))) (defun translate-name-and-modifiers (key-name modifiers) (with-output-to-string (s) @@ -525,8 +528,7 @@ when (plusp (logand modifier modifiers)) do (princ name s)) (princ (if (typep key-name 'character) - (or (char-name key-name) - key-name) + (gesture-name key-name) key-name) s))) (defmethod gesture-name ((ev keyboard-event)) @@ -547,6 +549,7 @@ #'(lambda (menu-name keystroke item) (declare (ignore menu-name)) (cond ((and (eq (command-menu-item-type item) :command) + (listp (command-menu-item-value item)) (eq (car (command-menu-item-value item)) command)) (push (cons keystroke prefix) keystrokes)) ((eq (command-menu-item-type item) :menu) From thenriksen at common-lisp.net Sun Apr 30 15:12:05 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 30 Apr 2006 11:12:05 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060430151205.787AF6F23D@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv3929 Modified Files: misc-commands.lisp base.lisp Log Message: Fixed `indent-region': Update syntax for each indented line. Alsp prevent infinite loops in `do-buffer-region-lines'. --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/04/23 12:11:26 1.6 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/04/30 15:12:05 1.7 @@ -552,7 +552,12 @@ line tab-space-count syntax))) - (indent-line line indentation tab-width))))) + (indent-line line indentation tab-width)) + ;; We need to update the syntax every time we perform an + ;; indentation, so that subsequent indentations will be + ;; correctly indented (this matters in list forms). FIXME: This + ;; should probably happen automatically. + (update-syntax buffer syntax)))) (define-command (com-indent-region :name t :command-table indent-table) () "Indent every line of the current region as specified by the --- /project/climacs/cvsroot/climacs/base.lisp 2006/03/26 14:14:48 1.46 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/04/30 15:12:05 1.47 @@ -50,12 +50,13 @@ (let ((mark-sym (gensym)) (mark2-sym (gensym))) `(progn - (when (mark< ,mark2 ,mark1) - (rotatef ,mark1 ,mark2)) - (let ((,mark-sym (clone-mark ,mark1)) - (,mark2-sym (clone-mark ,mark2))) - (loop while (mark<= ,mark-sym ,mark2-sym) - do + (let* ((,mark-sym (clone-mark ,mark1)) + (,mark2-sym (clone-mark ,mark2))) + (when (mark< ,mark2-sym ,mark-sym) + (rotatef ,mark-sym ,mark2-sym)) + (loop while (and (mark<= ,mark-sym ,mark2-sym) + (not (end-of-buffer-p ,mark-sym))) + do (let ((,line-var (clone-mark ,mark-sym))) , at body) (end-of-line ,mark-sym) From thenriksen at common-lisp.net Sun Apr 30 15:20:46 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 30 Apr 2006 11:20:46 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060430152046.ABE4A3064@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv5841 Modified Files: packages.lisp buffer.lisp Log Message: Added `buffer-substring' function. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/04/23 19:37:58 1.89 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/04/30 15:20:46 1.90 @@ -40,6 +40,7 @@ #:buffer-line-number #:buffer-column-number #:line-number #:column-number #:insert-buffer-object #:insert-buffer-sequence + #:buffer-substring #:insert-object #:insert-sequence #:delete-buffer-range #:delete-range #:delete-region --- /project/climacs/cvsroot/climacs/buffer.lisp 2006/04/23 12:40:31 1.32 +++ /project/climacs/cvsroot/climacs/buffer.lisp 2006/04/30 15:20:46 1.33 @@ -562,7 +562,12 @@ for i upfrom 0 do (setf (aref result i) (buffer-object buffer offset)) finally (return result)) - (make-array 0))) + (make-array 0))) + +(defun buffer-substring (buffer start end) + "Return a string of the contents of buffer from `start' to +`end', which must be offsets." + (coerce (buffer-sequence buffer start end) 'string)) (defgeneric object-before (mark) (:documentation "Return the object that is immediately before the mark. If mark is at