Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv24081/Drei

Modified Files: packages.lisp lisp-syntax.lisp lisp-syntax-swine.lisp lisp-syntax-commands.lisp input-editor.lisp Log Message: Improved the Lisp syntax module, in particular, the `form-to-object' function (previously `token-to-object') should now be as capable as a proper Lisp reader. This has been used to implement some (in my opinion) neat behavior for the expression accept method.

Also added some test cases for the function.

--- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/12/09 23:55:37 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/12/10 19:28:49 1.10 @@ -432,8 +432,12 @@ (: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) - (:export #:lisp-string - #:edit-definition) + (:export #:lisp-syntax + #:lisp-string + #:edit-definition + #:form + #:form-to-object + #:form-conversion-error) (:shadow clim:form))

(defpackage :drei-commands --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/06 11:31:12 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/10 19:28:49 1.12 @@ -243,7 +243,7 @@

(defclass lexer-state () () - (:documentation "These states are used to determine how the lexer + (:documentation "These states are used to determine how the lexer should behave."))

(defmacro define-lexer-state (name superclasses &body body) @@ -257,23 +257,23 @@

(define-lexer-state lexer-toplevel-state () () - (:documentation "In this state, the lexer assumes it can skip + (:documentation "In this state, the lexer assumes it can skip whitespace and should recognize ordinary lexemes of the language except for the right parenthesis"))

(define-lexer-state lexer-list-state (lexer-toplevel-state) () - (:documentation "In this state, the lexer assumes it can skip + (:documentation "In this state, the lexer assumes it can skip whitespace and should recognize ordinary lexemes of the language"))

(define-lexer-state lexer-string-state () () - (:documentation "In this state, the lexer is working inside a string + (:documentation "In this state, the lexer is working inside a string delimited by double quote characters."))

(define-lexer-state lexer-line-comment-state () () - (:documentation "In this state, the lexer is working inside a line + (:documentation "In this state, the lexer is working inside a line comment (starting with a semicolon."))

(define-lexer-state lexer-long-comment-state () @@ -314,7 +314,7 @@ (defclass parser-state () ())

(defmacro define-parser-state (name superclasses &body body) - `(progn + `(progn (defclass ,name ,superclasses ,@body) (defvar ,name (make-instance ',name)))) @@ -336,12 +336,12 @@ (end (find-if-not #'null children :key #'end-offset :from-end t))) (when start (setf start-mark (slot-value start 'start-mark) - size (- (end-offset end) (start-offset start))))))) + size (- (end-offset end) (start-offset start)))))))

;;; until here ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

-(defclass lisp-nonterminal (nonterminal) ()) +(defclass lisp-nonterminal (nonterminal) ()) (defclass form (lisp-nonterminal) ()) (defclass complete-form-mixin () ()) (defclass incomplete-form-mixin () ()) @@ -411,7 +411,7 @@ (setf (offset scan) start-offset) (setf start-mark scan size new-size)) - lexeme))) + lexeme)))

(defmethod lex ((syntax lisp-syntax) (state lexer-toplevel-state) scan) (macrolet ((fo () `(forward-object scan))) @@ -439,7 +439,7 @@ (## (fo) (cond ((end-of-buffer-p scan) (make-instance 'incomplete-lexeme)) - (t + (t (let ((prefix 0)) (loop until (end-of-buffer-p scan) while (digit-char-p (object-after scan)) @@ -450,7 +450,7 @@ (if (end-of-buffer-p scan) (make-instance 'incomplete-lexeme) (case (object-after scan) - ((#\Backspace #\Tab #\Newline #\Linefeed + ((#\Backspace #\Tab #\Newline #\Linefeed #\Page #\Return #\Space #)) (fo) (make-instance 'error-lexeme)) @@ -487,6 +487,9 @@ ((#\O #\o) 8) ((#\X #\x) 16)))) (fo) + (when (char= (object-after scan) + #-) + (fo)) (loop until (end-of-buffer-p scan) while (digit-char-p (object-after scan) radix) do (fo))) @@ -666,31 +669,33 @@ (defmethod lex ((syntax lisp-syntax) (state lexer-escaped-token-state) scan) (let ((bars-seen 0)) (macrolet ((fo () `(forward-object scan))) - (tagbody - start - (when (end-of-buffer-p scan) - (return-from lex (make-instance 'text-lexeme))) - (when (eql (object-after scan) #\) - (fo) - (when (end-of-buffer-p scan) - (return-from lex (make-instance 'incomplete-lexeme))) - (fo) - (go start)) - (when (eql (object-after scan) #|) - (incf bars-seen) - (fo) - (go start)) - (if (evenp bars-seen) - (unless (whitespacep syntax (object-after scan)) - (fo) - (go start)) - (when (constituentp (object-after scan)) - (fo) - (go start))) - (return-from lex - (if (oddp bars-seen) - (make-instance 'multiple-escape-end-lexeme) - (make-instance 'text-lexeme))))))) + (flet ((end () + (return-from lex + (if (oddp bars-seen) + (make-instance 'multiple-escape-end-lexeme) + (make-instance 'text-lexeme))))) + (tagbody + start + (when (end-of-buffer-p scan) + (end)) + (when (eql (object-after scan) #\) + (fo) + (when (end-of-buffer-p scan) + (return-from lex (make-instance 'incomplete-lexeme))) + (fo) + (go start)) + (when (eql (object-after scan) #|) + (incf bars-seen) + (fo) + (go start)) + (if (evenp bars-seen) + (unless (whitespacep syntax (object-after scan)) + (fo) + (go start)) + (when (constituentp (object-after scan)) + (fo) + (go start))) + (end))))))

(defmethod lex ((syntax lisp-syntax) (state lexer-error-state) scan) (macrolet ((fo () `(forward-object scan))) @@ -703,7 +708,7 @@ ;;; nonterminals

(defclass line-comment (lisp-nonterminal) ()) -(defclass long-comment (lisp-nonterminal) ()) +(defclass long-comment (lisp-nonterminal) ()) (defclass error-symbol (lisp-nonterminal) ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -772,13 +777,13 @@ (with-slots (start-mark size) result (setf start-mark (clone-mark scan :right) size 0)))) - result)) + result))

(define-parser-state error-state (lexer-error-state parser-state) ()) (define-parser-state error-reduce-state (lexer-toplevel-state parser-state) ())

(define-lisp-action (error-reduce-state (eql nil)) - (throw 'done nil)) + (throw 'done nil))

;;; the default action for any lexeme is shift (define-lisp-action (t lisp-lexeme) @@ -791,14 +796,14 @@ ;;; the default new state is the error state (define-new-lisp-state (t parser-symbol) error-state)

-;;; the new state when an error-state +;;; the new state when an error-state (define-new-lisp-state (t error-symbol) error-reduce-state)

-;;;;;;;;;;;;;;;; Top-level +;;;;;;;;;;;;;;;; Top-level

#| rules - form* -> + form* -> form* -> form* form |#

@@ -818,7 +823,7 @@ (reduce-all form*))

(define-new-lisp-state (|initial-state | form*) |form* | ) - + (define-lisp-action (|form* | (eql nil)) (throw 'done nil))

@@ -927,7 +932,7 @@ (define-lisp-action (|" word* " | t) (reduce-until-type complete-string-form string-start-lexeme))

-;;; reduce at the end of the buffer +;;; reduce at the end of the buffer (define-lisp-action (|" word* | (eql nil)) (reduce-until-type incomplete-string-form string-start-lexeme))

@@ -1125,7 +1130,7 @@ (define-new-lisp-state (|#- form | form) |#- form form |) (define-new-lisp-state (|#- | comment) |#- |) (define-new-lisp-state (|#- form | comment) |#- form |) - + (define-lisp-action (|#+ form form | t) (reduce-until-type reader-conditional-positive-form reader-conditional-positive-lexeme))

@@ -1292,7 +1297,7 @@ (t (loop with new-tree = (cadr (member tree siblings :test #'eq)) until (null (children new-tree)) do (setf new-tree (car (children new-tree))) - finally (return new-tree))))))) + finally (return new-tree)))))))

(defun find-last-valid-lexeme (parse-tree offset) (cond ((or (null parse-tree) (null (start-offset parse-tree))) nil) @@ -1302,7 +1307,7 @@ (find-last-valid-lexeme (car (last (children parse-tree))) offset)) ((>= (end-offset parse-tree) offset) (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset)) - (t parse-tree))) + (t parse-tree)))

(defun find-first-potentially-valid-lexeme (parse-trees offset) (cond ((null parse-trees) nil) @@ -1322,7 +1327,7 @@ (and (eq (class-of tree1) (class-of tree2)) (eq (parser-state tree1) (parser-state tree2)) (= (end-offset tree1) (end-offset tree2)))) - + (defmethod print-object ((mark mark) stream) (print-unreadable-object (mark stream :type t :identity t) (format stream "~s" (offset mark)))) @@ -1350,7 +1355,7 @@ (>= (start-offset potentially-valid-trees) (end-offset stack-top))) do (setf potentially-valid-trees - (next-tree potentially-valid-trees))))))) + (next-tree potentially-valid-trees)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1435,7 +1440,7 @@ (typep x 'complete-list-form)) (let ((candidate (first-form (children x)))) (and (form-token-p candidate) - (eq (token-to-object syntax candidate + (eq (form-to-object syntax candidate :no-error t) 'cl:in-package))))))) (with-slots (stack-top) syntax @@ -1457,12 +1462,12 @@ (when (form-list-p x) (let ((candidate (first-form (children x)))) (and (form-token-p candidate) - (eq (token-to-object syntax candidate + (eq (form-to-object syntax candidate :no-error t) 'cl:in-package))))) (extract (x) (let ((designator (second-form (children x)))) - (token-to-object syntax designator + (form-to-object syntax designator :no-error t)))) (with-slots (stack-top) syntax (loop for child in (children stack-top) @@ -1672,18 +1677,18 @@ "Return the text of the definition at mark." (let ((definition (definition-at-mark mark syntax))) (buffer-substring (buffer mark) - (start-offset definition) + (start-offset definition) (end-offset definition)))) - + (defun text-of-expression-at-mark (mark-or-offset syntax) "Return the text of the expression at `mark-or-offset'." (let ((expression (expression-at-mark mark-or-offset syntax))) - (token-string syntax expression))) + (form-string syntax expression)))

(defun symbol-name-at-mark (mark-or-offset syntax) "Return the text of the symbol at `mark-or-offset'." (let ((token (symbol-at-mark mark-or-offset syntax))) - (when token (token-string syntax token)))) + (when token (form-string syntax token))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1711,6 +1716,7 @@ (define-form-predicate form-quoted-p (quote-form backquote-form)) (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 comment-p (comment))

@@ -1805,16 +1811,16 @@ (defmethod display-parse-tree :around (parse-symbol stream (drei drei) (syntax lisp-syntax)) (with-slots (top bot) drei - (when (and (start-offset parse-symbol) + (when (and (start-offset parse-symbol) (mark< (start-offset parse-symbol) bot) (mark> (end-offset parse-symbol) top)) - (call-next-method)))) + (call-next-method))))

(defmethod display-parse-tree (parse-symbol stream (drei drei) (syntax lisp-syntax)) (with-slots (top bot) drei (loop for child in (children parse-symbol) - when (and (start-offset child) + when (and (start-offset child) (mark> (end-offset child) top)) do (if (mark< (start-offset child) bot) (display-parse-tree child stream drei syntax) @@ -1850,9 +1856,9 @@

(defmethod display-parse-tree ((parse-symbol token-mixin) stream (drei drei) (syntax lisp-syntax)) (if (> (the fixnum (end-offset parse-symbol)) (the fixnum (start-offset parse-symbol))) - (let ((string (token-string syntax parse-symbol))) + (let ((string (form-string syntax parse-symbol))) (multiple-value-bind (symbol status) - (token-to-object syntax parse-symbol :no-error t) + (form-to-object syntax parse-symbol :no-error t) (with-output-as-presentation (stream (if status symbol string) (if status 'symbol 'unknown-symbol) @@ -1881,7 +1887,7 @@ :id-test #'equal :cache-value parser-symbol :cache-test #'eql) - (let ((object (token-to-object syntax parser-symbol))) + (let ((object (form-to-object syntax parser-symbol))) (present object (presentation-type-of object) :stream stream))))

(defmethod display-parse-tree ((parser-symbol lisp-lexeme) stream (drei drei) @@ -1900,15 +1906,15 @@ (with-slots (ink face) parser-symbol (setf ink (medium-ink (sheet-medium stream)) face (text-style-face (medium-text-style (sheet-medium stream)))) - (let ((string (token-string syntax parser-symbol))) + (let ((string (form-string syntax parser-symbol))) (present string 'string :stream stream)))))) - + (defmethod display-parse-tree :before ((parse-symbol lisp-lexeme) stream (drei drei) (syntax lisp-syntax)) (handle-whitespace stream (buffer drei) *white-space-start* (start-offset parse-symbol)) (setf *white-space-start* (end-offset parse-symbol)))

-(define-presentation-type lisp-string () +(define-presentation-type lisp-string () :description "lisp string")

(defmethod display-parse-tree ((parse-symbol complete-string-form) stream (drei drei) (syntax lisp-syntax)) @@ -1980,7 +1986,7 @@ "The KEYWORD package.")

(defmethod eval-feature-conditional ((conditional token-mixin) (syntax lisp-syntax)) - (let* ((string (token-string syntax conditional)) + (let* ((string (form-string syntax conditional)) (symbol (parse-symbol string :package +keyword-package+))) (member symbol *features*)))

@@ -1996,7 +2002,7 @@ (remove-if #'comment-p children)))) - (type-string (token-string syntax type)) + (type-string (form-string syntax type)) (type-symbol (parse-symbol type-string :package +keyword-package+))) (case type-symbol (:and (funcall #'every #'eval-fc conditionals)) @@ -2004,7 +2010,7 @@ (:not (when conditionals

[820 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/12/04 20:07:53 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/12/10 19:28:49 1.4 @@ -417,7 +417,7 @@ indexing-start-arg operator-form)) (preceding-arg-obj (when preceding-arg-token - (token-to-object syntax preceding-arg-token + (form-to-object syntax preceding-arg-token :no-error t)))) (values preceding-arg-obj argument-indices))))

@@ -461,7 +461,7 @@ argument" is defined as an argument that would be directly bound to a symbol when evaluating the operators body, or as an argument that would be a direct component of a &body or &rest argument." - (let ((operator (token-to-object syntax operator-form))) + (let ((operator (form-to-object syntax operator-form))) (and ;; An operator is not an argument to itself. (not (eq arg-form @@ -790,11 +790,11 @@ ;; If we cannot find a form, there's no point in looking ;; up any of this stuff. (,operator-sym (when (and ,form-sym (form-list-p ,form-sym)) - (token-to-object ,syntax (form-operator ,syntax ,form-sym)))) + (form-to-object ,syntax (form-operator ,syntax ,form-sym)))) (,operands-sym (when (and ,form-sym (form-list-p ,form-sym)) (mapcar #'(lambda (operand) (when operand - (token-to-object ,syntax operand))) + (form-to-object ,syntax operand))) (form-operands ,syntax ,form-sym))))) (declare (ignorable ,form-sym ,operator-sym ,operands-sym)) (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym) @@ -1022,7 +1022,7 @@ (start-offset token) (offset mark))) (if useful-token - (token-string syntax token) + (form-string syntax token) "")) (if completions (if (= (length completions) 1) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/12/04 20:07:53 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/12/10 19:28:49 1.4 @@ -98,7 +98,7 @@ (mark (point pane)) (token (this-form mark syntax))) (if (and token (form-token-p token)) - (com-lookup-arglist (token-to-object syntax token)) + (com-lookup-arglist (form-to-object syntax token)) (display-message "Could not find symbol at point."))))

(define-command (com-lookup-arglist :name t :command-table lisp-table) @@ -189,7 +189,7 @@ (with-syntax-package (*current-syntax* *current-point*) (let ((*read-base* (base *current-syntax*))) (drei-commands::com-eval-expression - (token-to-object *current-syntax* token :read t) + (form-to-object *current-syntax* token :read t) insertp))) (display-message "Nothing to evaluate."))))

--- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/07 14:34:14 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/10 19:28:49 1.13 @@ -841,11 +841,19 @@ do (with-activation-gestures (nil :override t) (stream-process-gesture stream gesture nil)) finally (unread-gesture gesture :stream stream) - (let* ((object (drei-lisp-syntax::token-to-object syntax form - :read t - :package *package*)) - (ptype (presentation-type-of object))) - (return-from control-loop - (values object - (if (presentation-subtypep ptype 'expression) - ptype 'expression)))))))) + (let* ((object (handler-case + (drei-lisp-syntax:form-to-object syntax form + :read t + :package *package*) + (drei-lisp-syntax:form-conversion-error (e) + ;; Move point to the problematic form + ;; and signal a rescan. + (setf (activation-gesture stream) nil) + (handle-drei-condition drei e) + (display-drei drei) + (immediate-rescan stream)))) + (ptype (presentation-type-of object))) + (return-from control-loop + (values object + (if (presentation-subtypep ptype 'expression) + ptype 'expression))))))))