Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv4684
Modified Files:
cl-syntax.lisp
Log Message:
2nd vers cl-synt
Date: Thu Apr 21 17:22:11 2005
Author: pfong
Index: climacs/cl-syntax.lisp
diff -u climacs/cl-syntax.lisp:1.7 climacs/cl-syntax.lisp:1.8
--- climacs/cl-syntax.lisp:1.7 Wed Apr 20 17:39:10 2005
+++ climacs/cl-syntax.lisp Thu Apr 21 17:22:11 2005
@@ -77,8 +77,16 @@
(#\` (fo) (make-instance 'backquote))
(#\@ (fo) (make-instance 'at))
(#\; (fo) (make-instance 'semicolon))
- (t (cond ((numberp object) (fo)
- (make-instance 'number-item))
+ (t (cond ((numberp object)
+ (loop until (end-of-buffer-p scan)
+ while (numberp (object-after scan))
+ do (fo))
+ (make-instance 'default-item))
+ ((neutralcharp object)
+ (loop until (end-of-buffer-p scan)
+ while (neutralcharp (object-after scan))
+ do (fo))
+ (make-instance 'default-item))
(t (fo) (make-instance 'default-item))))))))
@@ -88,6 +96,14 @@
(parser)))
+
+(defun neutralcharp (var)
+ (and (characterp var)
+ (not (member var '(#\( #\) #\, #\" #\' #\# #\| #\` #\@ #\; #\\
+ #\. #\+ #\-)
+ :test #'char=))))
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; parser
@@ -105,16 +121,16 @@
`(progn
(defclass ,name (cl-entry) ())
(defclass ,empty-name (,name) ())
-
+
(defclass ,nonempty-name (,name)
- ((items :initarg :items)
- (item :initarg :item)))
-
+ ((items :initarg :items)
+ (item :initarg :item)))
+
(add-cl-rule (,name -> () (make-instance ',empty-name)))
-
+
(add-cl-rule (,name -> (,name ,item-name)
- (make-instance ',nonempty-name
- :items ,name :item ,item-name)))
+ (make-instance ',nonempty-name
+ :items ,name :item ,item-name)))
(defmethod display-parse-tree ((entity ,empty-name) (syntax cl-syntax) pane)
(declare (ignore pane))
nil)
@@ -140,7 +156,7 @@
(defmethod display-parse-tree ((entity string-char) (syntax cl-syntax) pane)
(with-slots (item) entity
- (display-parse-tree item syntax pane)))
+ (display-parse-tree item syntax pane)))
(defclass string-part (cl-entry)
((item :initarg :item)
@@ -150,12 +166,12 @@
item)
(start-offset
ch))))
- :item item :ch ch))
+ :item item :ch ch))
(defmethod display-parse-tree ((entity string-part) (syntax cl-syntax) pane)
(with-slots (item ch) entity
- (display-parse-tree item syntax pane)
- (display-parse-tree ch syntax pane)))
+ (display-parse-tree item syntax pane)
+ (display-parse-tree ch syntax pane)))
(defclass string-item (cl-entry)
((item :initarg :item)))
@@ -173,8 +189,7 @@
(defclass identifier-item (cl-entry)
((item :initarg :item)))
-(add-cl-rule (identifier-item -> (string-item) :item
- string-item))
+(add-cl-rule (identifier-item -> (string-item) :item string-item))
(add-cl-rule (identifier-item -> (hex) :item hex))
(add-cl-rule (identifier-item -> (double-quote) :item double-quote))
@@ -212,6 +227,7 @@
(display-parse-tree item syntax pane)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;line-comment
+
;;missing (cannot parse end of line)
@@ -233,7 +249,7 @@
(defmethod display-parse-tree ((entity balanced-comment) (syntax cl-syntax) pane)
(with-slots (start-hex items end-hex) entity
- (with-drawing-options (pane :ink +red+)
+ (with-drawing-options (pane :ink +blue+)
(display-parse-tree start-hex syntax pane)
(display-parse-tree items syntax pane)
(display-parse-tree end-hex syntax pane))))
@@ -307,6 +323,10 @@
(display-parse-tree header syntax pane)
(display-parse-tree item syntax pane)))
+(defclass start-number-expr (cl-entry)
+ ((start :initarg :start)
+ (item :initarg :item)))
+
(defclass binary-expr (cl-entry)
((start :initarg :start)
(header :initarg :header)
@@ -342,26 +362,26 @@
(buffer-sequence (buffer radix)
(start-offset radix)
(end-offset radix))
- 'string)))))))
+ 'string)))))))
:start start :header header :item item))
(defmethod display-parse-tree ((entity radix-n-expr) (syntax cl-syntax) pane)
(with-slots (start radix header item) entity
- (display-parse-tree start syntax pane)
- (display-parse-tree radix syntax pane)
- (display-parse-tree header syntax pane)
- (display-parse-tree item syntax pane)))
+ (display-parse-tree start syntax pane)
+ (display-parse-tree radix syntax pane)
+ (display-parse-tree header syntax pane)
+ (display-parse-tree item syntax pane)))
(defclass simple-number (cl-entry)
((content :initarg :content)))
(add-cl-rule (simple-number -> ((content string-item (radix-is
- content 10)))
+ content 10)))
:content content))
(defmethod display-parse-tree ((entity simple-number) (syntax cl-syntax) pane)
(with-slots (content) entity
- (display-parse-tree content syntax pane)))
+ (display-parse-tree content syntax pane)))
(defclass complex-number (cl-entry)
((start :initarg :start)
@@ -381,10 +401,10 @@
(defmethod display-parse-tree ((entity complex-number) (syntax cl-syntax) pane)
(with-slots (start realpart imagpart end) entity
- (display-parse-tree start syntax pane)
- (display-parse-tree realpart syntax pane)
- (display-parse-tree imagpart syntax pane)
- (display-parse-tree end syntax pane)))
+ (display-parse-tree start syntax pane)
+ (display-parse-tree realpart syntax pane)
+ (display-parse-tree imagpart syntax pane)
+ (display-parse-tree end syntax pane)))
(defclass complex-expr (cl-entry)
((start :initarg :start)
@@ -418,7 +438,7 @@
(defmethod display-parse-tree ((entity number-expr) (syntax cl-syntax) pane)
(with-slots (content) entity
(with-drawing-options (pane :ink +blue+)
- (display-parse-tree content syntax pane))))
+ (display-parse-tree content syntax pane))))
(defclass pathname-expr (cl-entry)
((start :initarg :start)
@@ -448,10 +468,8 @@
(backslash default-item (and (= (end-offset start)
(start-offset backslash))
(default-item-is backslash #\\)))
- (item cl-lexeme (and (= (end-offset backslash)
- (start-offset item))
- (= (+ 1 (start-offset item))
- (end-offset item)))))
+ (item cl-lexeme (= (end-offset backslash)
+ (start-offset item))))
:start start :backslash backslash :item item))
(defmethod display-parse-tree ((entity char-item) (syntax cl-syntax) pane)
@@ -471,8 +489,7 @@
:start start :items cl-terminals
:end end))
-(defmethod display-parse-tree ((entity list-expr) (syntax cl-syntax)
-pane)
+(defmethod display-parse-tree ((entity list-expr) (syntax cl-syntax) pane)
(with-slots (start items end) entity
(display-parse-tree start syntax pane)
(display-parse-tree items syntax pane)
@@ -489,12 +506,12 @@
(read-expr identifier (= (end-offset read-car) (start-offset read-expr))))
:read-car read-car :read-expr read-expr))
-
+
(defmethod display-parse-tree ((entity read-time-point-attr) (syntax cl-syntax) pane)
(with-slots (read-car read-expr) entity
(display-parse-tree read-car syntax pane)
(display-parse-tree read-expr syntax pane)))
-
+
;;;;;;;;;;;;; read-time-evaluation
(defclass read-time-evaluation (cl-entry)
@@ -505,51 +522,50 @@
(add-cl-rule (read-time-evaluation -> ((start hex)
(item read-time-point-attr (= (end-offset start) (start-offset item))))
:start start :item item))
-
+
(defmethod display-parse-tree ((entity read-time-evaluation) (syntax cl-syntax) pane)
(with-slots (start item) entity
(display-parse-tree start syntax pane)
(display-parse-tree item syntax pane)))
-;;;;;;;;;;;;;; read-time-plus-attr
-(defclass read-time-plus-attr (cl-entry)
+;;;;;;;;;;;;;;;;;;;;;;; read-time-attr
+
+(defclass read-time-attr (cl-entry)
((read-car :initarg :read-car)
(read-expr :initarg :read-expr)))
+(defmethod display-parse-tree ((entity read-time-attr) (syntax cl-syntax) pane)
+ (with-slots (read-car read-expr) entity
+ (display-parse-tree read-car syntax pane)
+ (display-parse-tree read-expr syntax pane)))
+
+
+;;;;;;;;;;;;;; read-time-plus-attr
+
+(defclass read-time-plus-attr (read-time-attr) ())
+
(add-cl-rule (read-time-plus-attr -> ((read-car default-item (default-item-is read-car #\+))
(read-expr read-time-expr (= (end-offset read-car) (start-offset read-expr))))
:read-car read-car :read-expr
read-expr))
-(defmethod display-parse-tree ((entity read-time-plus-attr) (syntax cl-syntax) pane)
- (with-slots (read-car read-expr) entity
- (display-parse-tree read-car syntax pane)
- (display-parse-tree read-expr syntax pane)))
-
;;;;;;;;;;;;;; read-time-minus-attr
-(defclass read-time-minus-attr (cl-entry)
- ((read-car :initarg :read-car)
- (read-expr :initarg :read-expr)))
+(defclass read-time-minus-attr (read-time-attr) ())
(add-cl-rule (read-time-minus-attr -> ((read-car default-item (default-item-is read-car #\-))
(read-expr read-time-expr (= (end-offset read-car) (start-offset read-expr))))
:read-car read-car :read-expr
read-expr))
-(defmethod display-parse-tree ((entity read-time-minus-attr) (syntax cl-syntax) pane)
- (with-slots (read-car read-expr) entity
- (display-parse-tree read-car syntax pane)
- (display-parse-tree read-expr syntax pane)))
-
;;;;;;;;;;;;; read-time-expr
(defclass read-time-expr (cl-entry)
((time-expr :initarg :time-expr)))
(add-cl-rule (read-time-expr -> (list-expr) :time-expr list-expr))
-
+
(add-cl-rule (read-time-expr -> (identifier) :time-expr identifier))
@@ -557,45 +573,40 @@
(with-slots (time-expr) entity
(display-parse-tree time-expr syntax pane)))
-;;;;;;;;;;;;; read-time-conditional-plus
-(defclass read-time-conditional-plus (cl-entry)
+;;;;;;;;;;;;;;;;;;;;;;;;;; read-time-conditional
+(defclass read-time-conditional (cl-entry)
((start :initarg :start)
(test :initarg :test)
(expr :initarg :expr)))
-(add-cl-rule (read-time-conditional-plus -> ((start hex)
- (test read-time-plus-attr (= (end-offset start) (start-offset test)))
- (expr cl-terminal (/= (end-offset test) (start-offset expr))))
- :start start
- :test test
- :expr expr))
-(defmethod display-parse-tree ((entity read-time-conditional-plus) (syntax cl-syntax) pane)
+(defmethod display-parse-tree ((entity read-time-conditional) (syntax cl-syntax) pane)
(with-slots (start test expr) entity
(display-parse-tree start syntax pane)
(display-parse-tree test syntax pane)
(display-parse-tree expr syntax pane)))
+
+;;;;;;;;;;;;; read-time-conditional-plus
+
+(defclass read-time-conditional-plus (read-time-conditional) ())
+
+
+(add-cl-rule (read-time-conditional-plus -> ((start hex)
+ (test read-time-plus-attr (= (end-offset start) (start-offset test)))
+ (expr cl-terminal (/= (end-offset test) (start-offset expr))))
+ :start start :test test :expr expr))
+
;;;;;;;;;;;;; read-time-conditional-minus
-(defclass read-time-conditional-minus (cl-entry)
- ((start :initarg :start)
- (test :initarg :test)
- (expr :initarg :expr)))
+(defclass read-time-conditional-minus (read-time-conditional) ())
(add-cl-rule (read-time-conditional-minus -> ((start hex)
(test read-time-minus-attr (= (end-offset start) (start-offset test)))
(expr cl-terminal (/= (end-offset test) (start-offset expr))))
:start start :test test :expr expr))
-(defmethod display-parse-tree ((entity read-time-conditional-minus) (syntax cl-syntax) pane)
- (with-slots (start test expr) entity
- (display-parse-tree start syntax pane)
- (display-parse-tree test syntax pane)
- (display-parse-tree expr syntax pane)))
-
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;function-expression
(defclass fun-expr (cl-entry)
@@ -643,7 +654,7 @@
(define-list bit-items empty-bit-items nonempty-bit-items bit-item)
-(defclass bitvect-expr (cl-nonterminal);FIXME
+(defclass bitvect-expr (cl-nonterminal)
((start :initarg :start)
(asterisk :initarg :asterisk)
(items :initarg :items)))
@@ -651,16 +662,16 @@
(add-cl-rule (bitvect-expr -> ((start hex)
(asterisk default-item (and (= (end-offset start)
(start-offset asterisk))
- (default-item-is asterisk "*")))
+ (default-item-is asterisk #\*)))
(items bit-items))
:start start :asterisk asterisk :items items))
(defmethod display-parse-tree ((entity bitvect-expr) (syntax cl-syntax) pane)
(with-slots (start asterisk items) entity
(with-drawing-options (pane :ink +brown+)
- (display-parse-tree start syntax pane)
- (display-parse-tree asterisk syntax pane)
- (display-parse-tree items syntax pane))))
+ (display-parse-tree start syntax pane)
+ (display-parse-tree asterisk syntax pane)
+ (display-parse-tree items syntax pane))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Quote expr
@@ -768,16 +779,16 @@
(defmethod initialize-instance :after ((syntax cl-syntax) &rest args)
(declare (ignore args))
(with-slots (parser lexer buffer) syntax
- (setf parser (make-instance 'parser
- :grammar *cl-grammar*
- :target 'cl-terminals))
- (setf lexer (make-instance 'cl-lexer :buffer (buffer syntax)))
- (let ((m (clone-mark (low-mark buffer) :left))
+ (setf parser (make-instance 'parser
+ :grammar *cl-grammar*
+ :target 'cl-terminals))
+ (setf lexer (make-instance 'cl-lexer :buffer (buffer syntax)))
+ (let ((m (clone-mark (low-mark buffer) :left))
(lexeme (make-instance 'start-lexeme :state (initial-state parser))))
- (setf (offset m) 0)
- (setf (start-offset lexeme) m
- (end-offset lexeme) 0)
- (insert-lexeme lexer 0 lexeme))))
+ (setf (offset m) 0)
+ (setf (start-offset lexeme) m
+ (end-offset lexeme) 0)
+ (insert-lexeme lexer 0 lexeme))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -791,8 +802,8 @@
while (mark<= (end-offset (lexeme lexer valid-parse)) bot)
do (let ((current-token (lexeme lexer (1- valid-parse)))
(next-lexeme (lexeme lexer valid-parse)))
- (setf (slot-value next-lexeme 'state)
- (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
+ (setf (slot-value next-lexeme 'state)
+ (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
(incf valid-parse))))
(defmethod inter-lexeme-object-p ((lexer cl-lexer) object)
@@ -821,23 +832,23 @@
(let ((space-width (space-width pane))
(tab-width (tab-width pane)))
(loop while (< start end)
- do (ecase (buffer-object buffer start)
- (#\Newline (terpri pane)
- (setf (aref *cursor-positions* (incf *current-line*))
- (multiple-value-bind (x y) (stream-cursor-position pane)
- (declare (ignore x))
- y)))
- (#\Space (stream-increment-cursor-position
- pane space-width 0))
- (#\Tab (let ((x (stream-cursor-position pane)))
- (stream-increment-cursor-position
- pane (- tab-width (mod x tab-width)) 0))))
+ do (ecase (buffer-object buffer start)
+ (#\Newline (terpri pane)
+ (setf (aref *cursor-positions* (incf *current-line*))
+ (multiple-value-bind (x y) (stream-cursor-position pane)
+ (declare (ignore x))
+ y)))
+ (#\Space (stream-increment-cursor-position
+ pane space-width 0))
+ (#\Tab (let ((x (stream-cursor-position pane)))
+ (stream-increment-cursor-position
+ pane (- tab-width (mod x tab-width)) 0))))
(incf start))))
(defmethod display-parse-tree :around ((entity cl-parse-tree) syntax pane)
(with-slots (top bot) pane
- (when (and (end-offset entity) (mark> (end-offset entity) top))
- (call-next-method))))
+ (when (and (end-offset entity) (mark> (end-offset entity) top))
+ (call-next-method))))
(defmethod display-parse-tree ((entity cl-entry) (syntax cl-syntax) pane)
(flet ((cache-test (t1 t2)
@@ -850,15 +861,15 @@
:id-test #'eq
:cache-value entity
:cache-test #'cache-test)
- (with-slots (ink face) entity
- (setf ink (medium-ink (sheet-medium pane))
- face (text-style-face (medium-text-style (sheet-medium pane))))
- (present (coerce (buffer-sequence (buffer syntax)
- (start-offset entity)
- (end-offset entity))
- 'string)
- 'string
- :stream pane)))))
+ (with-slots (ink face) entity
+ (setf ink (medium-ink (sheet-medium pane))
+ face (text-style-face (medium-text-style (sheet-medium pane))))
+ (present (coerce (buffer-sequence (buffer syntax)
+ (start-offset entity)
+ (end-offset entity))
+ 'string)
+ 'string
+ :stream pane)))))
(defmethod display-parse-tree :before ((entity cl-entry) (syntax cl-syntax) pane)
(handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
@@ -871,7 +882,7 @@
(unless (null next)
(display-parse-stack (parse-stack-symbol next) next syntax pane))
(loop for parse-tree in (reverse (parse-stack-parse-trees stack))
- do (display-parse-tree parse-tree syntax pane))))
+ do (display-parse-tree parse-tree syntax pane))))
(defun display-parse-state (state syntax pane)
(let ((top (parse-stack-top state)))
@@ -879,7 +890,7 @@
(display-parse-stack (parse-stack-symbol top) top syntax pane)
(display-parse-tree (target-parse-tree state) syntax pane))))
-
+
(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax cl-syntax) current-p)
(with-slots (top bot) pane
(setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
@@ -890,32 +901,32 @@
1.0)))
;; find the last token before bot
(let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
- ;; go back to a token before bot
+ ;; go back to a token before bot
(loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
do (decf end-token-index))
;; go forward to the last token before bot
(loop until (or (= end-token-index (nb-lexemes lexer))
(mark> (start-offset (lexeme lexer end-token-index)) bot))
do (incf end-token-index))
- (let ((start-token-index end-token-index))
- ;; go back to the first token after top, or until the previous token
- ;; contains a valid parser state
- (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
- (not (parse-state-empty-p
- (slot-value (lexeme lexer (1- start-token-index)) 'state))))
+ (let ((start-token-index end-token-index))
+ ;; go back to the first token after top, or until the previous token
+ ;; contains a valid parser state
+ (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
+ (not (parse-state-empty-p
+ (slot-value (lexeme lexer (1- start-token-index)) 'state))))
do (decf start-token-index))
- (let ((*white-space-start* (offset top)))
- ;; display the parse tree if any
- (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
- (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
- syntax
- pane))
- ;; display the lexemes
- (with-drawing-options (pane :ink +red+)
- (loop while (< start-token-index end-token-index)
- do (let ((token (lexeme lexer start-token-index)))
- (display-parse-tree token syntax pane))
- (incf start-token-index))))))))
+ (let ((*white-space-start* (offset top)))
+ ;; display the parse tree if any
+ (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
+ (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
+ syntax
+ pane))
+ ;; display the lexemes
+ (with-drawing-options (pane :ink +red+)
+ (loop while (< start-token-index end-token-index)
+ do (let ((token (lexeme lexer start-token-index)))
+ (display-parse-tree token syntax pane))
+ (incf start-token-index))))))))
(let* ((cursor-line (number-of-lines-in-region top (point pane)))
(height (text-style-height (medium-text-style pane) pane))
(cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
