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