Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13162
Modified Files: lisp-syntax.lisp lisp-syntax-swine.lisp lisp-syntax-swank.lisp Log Message: Tightened the nuts and bolts of Lisp syntax and added a bunch of tests to make relatively sure there are no regressions. No tests for Swine yet, but "it seems to work". Also fixes very major performance issue with redisplay of literal objects in Lisp syntax.
--- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/06 10:03:16 1.23 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/02/17 17:54:06 1.24 @@ -387,7 +387,7 @@ (defclass pathname-start-lexeme (lisp-lexeme) ()) (defclass undefined-reader-macro-lexeme (lisp-lexeme) ()) (defclass bit-vector-form (form-lexeme complete-form-mixin) ()) -(defclass number-lexeme (form-lexeme complete-form-mixin) ()) +(defclass number-lexeme (complete-token-lexeme) ()) (defclass token-mixin () ()) (defclass literal-object-form (form-lexeme complete-form-mixin) ()) (defclass complete-token-lexeme (token-mixin form-lexeme complete-form-mixin) ()) @@ -1011,15 +1011,19 @@
(define-parser-state |' | (form-may-follow) ()) (define-parser-state |' form | (lexer-toplevel-state parser-state) ()) +(define-parser-state |' incomplete-form | (lexer-toplevel-state parser-state) ())
(define-new-lisp-state (form-may-follow quote-lexeme) |' |) (define-new-lisp-state (|' | complete-form-mixin) |' form |) +(define-new-lisp-state (|' | incomplete-form-mixin) |' incomplete-form |) (define-new-lisp-state (|' | comment) |' |) (define-new-lisp-state (|' | unmatched-right-parenthesis-lexeme) |( form* ) |)
;;; reduce according to the rule form -> ' form (define-lisp-action (|' form | t) (reduce-until-type complete-quote-form quote-lexeme)) +(define-lisp-action (|' incomplete-form | t) + (reduce-until-type incomplete-quote-form quote-lexeme))
(define-lisp-action (|' | right-parenthesis-lexeme) (reduce-until-type incomplete-quote-form quote-lexeme)) @@ -1090,8 +1094,8 @@
;;; parse trees (defclass function-form (form) ()) -(defclass complete-function-form (form complete-form-mixin) ()) -(defclass incomplete-function-form (form incomplete-form-mixin) ()) +(defclass complete-function-form (function-form complete-form-mixin) ()) +(defclass incomplete-function-form (function-form incomplete-form-mixin) ())
(define-parser-state |#' | (form-may-follow) ()) (define-parser-state |#' form | (lexer-toplevel-state parser-state) ()) @@ -1142,7 +1146,7 @@ ;;;;;;;;;;;;;;;; uninterned symbol
;;; parse trees -(defclass uninterned-symbol-form (form complete-form-mixin) ()) +(defclass uninterned-symbol-form (complete-token-form) ())
(define-parser-state |#: | (form-may-follow) ()) (define-parser-state |#: form | (lexer-toplevel-state parser-state) ()) @@ -1237,14 +1241,18 @@
(define-parser-state |#P | (form-may-follow) ()) (define-parser-state |#P form | (lexer-toplevel-state parser-state) ()) +(define-parser-state |#P incomplete-form | (lexer-toplevel-state parser-state) ())
(define-new-lisp-state (form-may-follow pathname-start-lexeme) |#P |) (define-new-lisp-state (|#P | complete-form-mixin) |#P form |) +(define-new-lisp-state (|#P | incomplete-form-mixin) |#P incomplete-form |) (define-new-lisp-state (|#P | comment) |#P |)
;;; reduce according to the rule form -> #P form (define-lisp-action (|#P form | t) (reduce-until-type complete-pathname-form pathname-start-lexeme)) +(define-lisp-action (|#P incomplete-form | t) + (reduce-until-type incomplete-pathname-form pathname-start-lexeme)) (define-lisp-action (|#P | (eql nil)) (reduce-until-type incomplete-pathname-form pathname-start-lexeme))
@@ -1593,21 +1601,21 @@ (defmethod form-operands (syntax (form list-form)) (remove-if-not #'formp (rest-forms (children form))))
-(defun form-toplevel (form syntax) +(defun form-toplevel (syntax form) "Return the top-level form of `form'." (if (null (parent (parent form))) form - (form-toplevel (parent form) syntax))) + (form-toplevel syntax (parent form))))
-(defgeneric form-operator-p (token syntax) - (:documentation "Return true if `token' is the operator of its form. Otherwise, - return nil.") - (:method (token syntax) +(defgeneric form-operator-p (syntax token) + (:documentation "Return true if `token' is the operator of its + form. Otherwise, return nil.") + (:method ((syntax lisp-syntax) (token lisp-lexeme)) (with-accessors ((pre-token preceding-parse-tree)) token (cond ((typep pre-token 'left-parenthesis-lexeme) t) ((comment-p pre-token) - (form-operator-p pre-token syntax)) + (form-operator-p syntax pre-token)) (t nil)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1615,15 +1623,20 @@ ;;; Useful functions for selecting forms based on the mark.
(defun expression-at-mark (syntax mark-or-offset) - "Return the form at `mark-or-offset'. If `mark-or-offset' is just after, -or inside, a top-level-form, or if there are no forms after -`mark-or-offset', the form preceding `mark-or-offset' is -returned. Otherwise, the form following `mark-or-offset' is -returned." + "Return the form closest to `mark-or-offset'." (as-offsets ((offset mark-or-offset)) - (or (form-around syntax offset) - (form-after syntax offset) - (form-before syntax offset)))) + (flet ((distance (form) + (max (abs (- (start-offset form) mark-or-offset)) + (abs (- (end-offset form) mark-or-offset))))) + (reduce #'(lambda (form1 form2) + (cond ((null form1) form2) + ((null form2) form1) + ((> (distance form1) (distance form2)) + form2) + (t form1))) + (list (form-around syntax offset) + (form-after syntax offset) + (form-before syntax offset))))))
(defun definition-at-mark (syntax mark-or-offset) "Return the top-level form at `mark-or-offset'. If `mark-or-offset' is just after, @@ -1631,7 +1644,7 @@ `mark-or-offset', the top-level-form preceding `mark-or-offset' is returned. Otherwise, the top-level-form following `mark-or-offset' is returned." - (form-toplevel (expression-at-mark mark-or-offset syntax) syntax)) + (form-toplevel syntax (expression-at-mark syntax mark-or-offset)))
(defun symbol-at-mark (syntax mark-or-offset &optional (form-fetcher 'expression-at-mark)) @@ -1641,12 +1654,10 @@ must be a function with the same signature as `expression-at-mark', and will be used to retrieve the initial form at `mark'." (as-offsets (mark-or-offset) - (labels ((unwrap-form (form) - (cond ((form-quoted-p form) - (unwrap-form (first-form (children form)))) - ((form-token-p form) - form)))) - (unwrap-form (funcall form-fetcher syntax mark-or-offset))))) + (let ((unwrapped-form (fully-unquoted-form + (funcall form-fetcher syntax mark-or-offset)))) + (when (form-token-p unwrapped-form) + unwrapped-form))))
(defun fully-quoted-form (token) "Return the top token object for `token', return `token' or the @@ -1673,29 +1684,6 @@ (or (form-around syntax offset) (form-before syntax offset))))
-(defun preceding-form (syntax mark-or-offset) - "Return a form at `mark-or-offset'." - (as-offsets ((offset mark-or-offset)) - (or (form-before syntax offset) - (form-around syntax offset)))) - -(defun text-of-definition-at-mark (syntax mark) - "Return the text of the definition at mark." - (let ((definition (definition-at-mark mark syntax))) - (buffer-substring (buffer mark) - (start-offset definition) - (end-offset definition)))) - -(defun text-of-expression-at-mark (syntax mark-or-offset) - "Return the text of the expression at `mark-or-offset'." - (let ((expression (expression-at-mark mark-or-offset syntax))) - (form-string syntax expression))) - -(defun symbol-name-at-mark (syntax mark-or-offset) - "Return the text of the symbol at `mark-or-offset'." - (let ((token (symbol-at-mark syntax mark-or-offset))) - (when token (form-string syntax token)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Querying forms for data @@ -1744,8 +1732,8 @@
(defmethod replace-symbol-at-mark ((syntax lisp-syntax) (mark mark) (string string)) - (let ((token (symbol-at-mark syntax mark #'form-around))) - (when (and token (form-token-p token)) + (let ((token (symbol-at-mark syntax mark))) + (when token (setf (offset mark) (start-offset token)) (forward-delete-expression mark syntax)) (insert-sequence mark string))) @@ -1873,12 +1861,14 @@ ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #&) (with-face (:lambda-list-keyword) (call-next-method))) - ((and (macro-function symbol) - (form-operator-p parse-symbol syntax)) + ((and (symbolp symbol) + (macro-function symbol) + (form-operator-p syntax parse-symbol)) (with-face (:macro) (call-next-method))) - ((and (special-operator-p symbol) - (form-operator-p parse-symbol syntax)) + ((and (symbolp symbol) + (special-operator-p symbol) + (form-operator-p syntax parse-symbol)) (with-face (:special-form) (call-next-method))) (t (call-next-method))))) @@ -2095,6 +2085,10 @@ (t nil))))
(defun form-before (syntax offset) + (assert (>= (size (buffer syntax)) offset) nil + "Offset past buffer end") + (assert (>= offset 0) nil + "Offset before buffer start") (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (<= offset (start-offset stack-top))) @@ -2120,6 +2114,10 @@ (t nil))))
(defun form-after (syntax offset) + (assert (>= (size (buffer syntax)) offset) nil + "Offset past buffer end") + (assert (>= offset 0) nil + "Offset before buffer start") (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (>= offset (end-offset stack-top))) @@ -2133,16 +2131,18 @@ (= offset (end-offset child)) (= offset (start-offset child))) (return (if (null (first-form (children child))) - (when (formp child) - child) + child (or (form-around-in-children (children child) offset) - (when (formp child) - child))))) + child)))) ((< offset (start-offset child)) (return nil)) (t nil))))
(defun form-around (syntax offset) + (assert (>= (size (buffer syntax)) offset) nil + "Offset past buffer end") + (assert (>= offset 0) nil + "Offset before buffer start") (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (> offset (end-offset stack-top)) @@ -2151,16 +2151,14 @@ (form-around-in-children (children stack-top) offset))))
(defun find-list-parent-offset (form fn) - "Find a list parent of `token' 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 `fn' applied to `form'." + "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 - (form* (funcall fn form)) (list-form (funcall fn form)) - (null (funcall fn form)) + ((or form* null) nil) (t (find-list-parent-offset parent fn)))))
(defun find-list-child-offset (form fn &optional (min-offset 0)) @@ -2196,8 +2194,7 @@ (setf (offset mark) (end-offset potential-form)))))
(defgeneric forward-one-list (mark syntax) - (:documentation - "Move `mark' forward by one list. + (:documentation "Move `mark' forward by one list. Return T if successful, or NIL if the buffer limit was reached."))
(defmethod forward-one-list (mark (syntax lisp-syntax)) @@ -2214,9 +2211,8 @@ (return t)))
(defgeneric backward-one-list (mark syntax) - (:documentation - "Move `mark' backward by one list. Return T if successful, or -NIL if the buffer limit was reached.")) + (:documentation "Move `mark' backward by one list. Return T if +successful, or NIL if the buffer limit was reached."))
(defmethod backward-one-list (mark (syntax lisp-syntax)) (loop for start = (offset mark) @@ -2233,103 +2229,91 @@
(drei-motion:define-motion-fns list)
-(defun down-list-by-fn (mark syntax fn) - (let* ((offset (offset mark)) - (potential-form (form-after syntax offset))) - (let ((new-offset (typecase potential-form - (list-form (start-offset potential-form)) - (null nil) - (t (find-list-child-offset - (parent potential-form) - fn - offset))))) +(defun down-list (mark syntax selector next-offset-fn target-offset-fn) + (labels ((find-offset (potential-form) + (typecase potential-form + (list-form (funcall target-offset-fn potential-form)) + (null nil) + (t (find-offset (funcall selector syntax + (funcall next-offset-fn potential-form))))))) + (let ((new-offset (find-offset (funcall selector syntax (offset mark))))) (when new-offset - (progn (setf (offset mark) (1+ new-offset)) t))))) + (setf (offset mark) new-offset) + t))))
-(defmethod forward-one-down (mark (syntax lisp-syntax)) - (down-list-by-fn mark syntax #'start-offset)) +(defmethod forward-one-down ((mark mark) (syntax lisp-syntax)) + (when (down-list mark syntax #'form-after #'end-offset #'start-offset) + (forward-object mark))) + +(defmethod backward-one-down ((mark mark) (syntax lisp-syntax)) + (when (down-list mark syntax #'form-before #'start-offset #'end-offset) + (backward-object mark)))
-(defmethod backward-one-down (mark (syntax lisp-syntax)) - (down-list-by-fn mark syntax #'end-offset) - (backward-object mark syntax)) - -(defun up-list-by-fn (mark syntax fn) - (let ((form (or (form-before syntax (offset mark)) - (form-after syntax (offset mark)) - (form-around syntax (offset mark))))) +(defun up-list (mark syntax fn) + (let ((form (form-around syntax (offset mark)))) (when form - (let ((parent (parent form))) - (when (not (null parent)) - (let ((new-offset (find-list-parent-offset parent fn))) - (when new-offset - (setf (offset mark) new-offset)))))))) + (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-by-fn mark syntax #'start-offset)) + (up-list mark syntax #'start-offset))
(defmethod forward-one-up (mark (syntax lisp-syntax)) - (up-list-by-fn mark syntax #'end-offset)) + (up-list mark syntax #'end-offset))
-(defmethod eval-defun (mark (syntax lisp-syntax)) +(defmethod backward-one-definition ((mark mark) (syntax lisp-syntax)) (with-slots (stack-top) syntax - (loop for form in (children stack-top) - when (and (mark<= (start-offset form) mark) - (mark<= mark (end-offset form))) - do (return (eval-form-for-drei - (get-usable-image syntax) - (form-to-object syntax form :read t)))))) + ;; FIXME? This conses! I'm over it already. I don't think it + ;; matters much, but if someone is bored, please profile it. + (loop for form in (reverse (children stack-top)) + when (and (formp form) + (mark> mark (start-offset form))) + do (setf (offset mark) (start-offset form)) + and do (return t))))
-(defmethod backward-one-definition (mark (syntax lisp-syntax)) +(defmethod forward-one-definition ((mark mark) (syntax lisp-syntax)) (with-slots (stack-top) syntax (loop for form in (children stack-top) - with last-toplevel-list = nil - when (and (formp form) - (mark< mark (end-offset form))) - do (if (mark< (start-offset form) mark) - (setf (offset mark) (start-offset form)) - (when last-toplevel-list form - (setf (offset mark) (start-offset last-toplevel-list)))) - (return t) - when (formp form) - do (setf last-toplevel-list form)
[325 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2007/02/06 09:25:08 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2007/02/17 17:54:06 1.6 @@ -328,7 +328,8 @@ provided-args)))
(defun cleanup-arglist (arglist) - "Remove elements of `arglist' that we are not interested in." + "Remove elements of `arglist' that we are not interested in, +including implementation-specific lambda list keywords." (loop for arg in arglist with in-&aux ; If non-NIL, we are in the @@ -349,6 +350,11 @@ else collect arg))
+(defun canonicalize-arglist (arglist) + "Convert `arglist' to the Grand Unified Arglist Format used by +Drei, and signal errors if the arglist is found to be invalid." + arglist) + (defun find-argument-indices-for-operand (syntax operand-form operator-form) "Return a list of argument indices for `argument-form' relative to `operator-form'. These lists take the form of (n m p), which @@ -783,7 +789,7 @@ `(let* ((,form-sym ;; Find a form with a valid (fboundp) operator. (let ((immediate-form - (preceding-form ,syntax ,mark-or-offset))) + (this-form ,syntax ,mark-or-offset))) (unless (null immediate-form) (or (find-applicable-form ,syntax immediate-form) ;; If nothing else can be found, and `arg-form' --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/01/07 19:48:16 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/02/17 17:54:06 1.3 @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Package: DREI-LISP-SYNTAX; -*-
-;;; (c) copyright 2005-2006 by +;;; (c) copyright 2005-2007 by ;;; Robert Strandh (strandh@labri.fr) ;;; David Murray (splittist@yahoo.com) ;;; Troels Henriksen (athas@sigkill.dk)