climacs-cvs
Threads by month
- ----- 2025 -----
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2007 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2006 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2005 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2004 -----
- December
April 2005
- 3 participants
- 36 discussions
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv3065
Modified Files:
cl-syntax.lisp
Log Message:
fixed some bugs in balanced comment, fun-expr, vect-expr.line-comment not working as it should be
Date: Fri Apr 29 22:10:32 2005
Author: pfong
Index: climacs/cl-syntax.lisp
diff -u climacs/cl-syntax.lisp:1.11 climacs/cl-syntax.lisp:1.12
--- climacs/cl-syntax.lisp:1.11 Wed Apr 27 16:02:03 2005
+++ climacs/cl-syntax.lisp Fri Apr 29 22:10:32 2005
@@ -56,7 +56,7 @@
(defclass double-quote (cl-lexeme) ())
(defclass hex (cl-lexeme) ())
(defclass pipe (cl-lexeme) ())
-(defclass semicolon (cl-lexeme) ())
+(defclass line-comment-entry (cl-lexeme) ())
(defclass backquote (cl-lexeme) ())
(defclass at (cl-lexeme) ())
(defclass backslash (cl-lexeme) ())
@@ -88,9 +88,11 @@
(#\+ (fo) (make-instance 'plus-symbol))
(#\- (fo) (make-instance 'minus-symbol))
(#\; (fo) (loop until (end-of-buffer-p scan)
- while (eql (object-after scan) #\;)
+ until (eql (object-after scan) #\Newline)
do (fo))
- (make-instance 'semicolon))
+ (if (end-of-buffer-p scan)
+ (make-instance 'other-entry)
+ (make-instance 'line-comment-entry)))
(t (cond ((digit-char-p object)
(loop until (end-of-buffer-p scan)
while (digit-char-p (object-after scan))
@@ -161,7 +163,6 @@
(defclass empty-item (cl-entry) ())
-
(defmethod display-parse-tree ((entity empty-item) (syntax cl-syntax) pane)
(declare (ignore pane))
nil)
@@ -173,11 +174,11 @@
(add-cl-rule (token-char -> (default-item) :item default-item))
(add-cl-rule (token-char -> (comma) :item comma))
-(add-cl-rule (token-char -> (semicolon) :item semicolon))
(add-cl-rule (token-char -> (backquote) :item backquote))
(add-cl-rule (token-char -> (at) :item at))
(add-cl-rule (token-char -> (plus-symbol) :item plus-symbol))
(add-cl-rule (token-char -> (minus-symbol) :item minus-symbol))
+(add-cl-rule (token-char -> (pipe) :item pipe))
(defmethod display-parse-tree ((entity token-char) (syntax cl-syntax) pane)
(with-slots (item) entity
@@ -219,6 +220,7 @@
(add-cl-rule (string-item -> (backslash) :item backslash))
(add-cl-rule (string-item -> (slash) :item slash))
(add-cl-rule (string-item -> (dot) :item dot))
+(add-cl-rule (string-item -> (line-comment-entry) :item line-comment-entry))
(define-list string-items empty-string-items
@@ -274,28 +276,47 @@
(with-slots (item) entity
(display-parse-tree item syntax pane)))
+;;;;;;;;;;;;; line-comment
+
+(defclass line-comment (cl-item) ())
+
+(add-cl-rule (line-comment -> ((item line-comment-entry)) :item item))
+
+(defmethod display-parse-tree ((entity line-comment) (syntax cl-syntax) pane)
+ (with-slots (item) entity
+ (with-drawing-options (pane :ink (make-rgb-color 0.6 0.16 0.3))
+ (display-parse-tree item syntax pane))))
;;;;;;;;;;;;; balanced-comment
(defclass balanced-comment (cl-entry)
((start-hex :initarg :start-hex)
+ (start-pipe :initarg :start-pipe)
(item :initarg :item)
+ (end-pipe :initarg :end-pipe)
(end-hex :initarg :end-hex)))
(add-cl-rule (balanced-comment -> ((start-hex hex)
- (item identifier-compound (= (end-offset start-hex)
- (start-offset item)))
- (end-hex hex (= (end-offset item)
+ (start-pipe pipe (= (end-offset
+ start-hex)
+ (start-offset start-pipe)))
+ (item identifier-items)
+ (end-pipe pipe)
+ (end-hex hex (= (end-offset end-pipe)
(start-offset end-hex))))
:start-hex start-hex
+ :start-pipe start-pipe
:item item
+ :end-pipe end-pipe
:end-hex end-hex))
(defmethod display-parse-tree ((entity balanced-comment) (syntax cl-syntax) pane)
- (with-slots (start-hex item end-hex) entity
+ (with-slots (start-hex start-pipe item end-pipe end-hex) entity
(with-drawing-options (pane :ink (make-rgb-color 0.6 0.16 0.3))
(display-parse-tree start-hex syntax pane)
+ (display-parse-tree start-pipe syntax pane)
(display-parse-tree item syntax pane)
+ (display-parse-tree end-pipe syntax pane)
(display-parse-tree end-hex syntax pane))))
;;;;;;;;;;;;; string
@@ -697,7 +718,8 @@
(quoted-expr :initarg :quoted-expr)))
(add-cl-rule (fun-expr -> ((start hex)
- (quoted-expr quoted-expr))
+ (quoted-expr quoted-expr (= (end-offset start)
+ (start-offset quoted-expr))))
:start start :quoted-expr quoted-expr))
(defmethod display-parse-tree ((entity fun-expr) (syntax cl-syntax) pane)
@@ -714,7 +736,8 @@
(list-expr :initarg :list-expr)))
(add-cl-rule (vect-expr -> ((start hex)
- (list-expr list-expr))
+ (list-expr list-expr (= (end-offset start)
+ (start-offset list-expr))))
:start start :list-expr list-expr))
(defmethod display-parse-tree ((entity vect-expr) (syntax cl-syntax) pane)
@@ -838,6 +861,7 @@
(add-cl-rule (cl-terminal -> (read-time-conditional-plus) :item read-time-conditional-plus))
(add-cl-rule (cl-terminal -> (read-time-conditional-minus) :item read-time-conditional-minus))
(add-cl-rule (cl-terminal -> (read-time-evaluation) :item read-time-evaluation))
+(add-cl-rule (cl-terminal -> (line-comment) :item line-comment))
(define-list cl-terminals empty-cl-terminals
nonempty-cl-terminals cl-terminal)
1
0
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv19847
Modified Files:
cl-syntax.lisp
Log Message:
cl-syntax
Date: Wed Apr 27 16:02:03 2005
Author: pfong
Index: climacs/cl-syntax.lisp
diff -u climacs/cl-syntax.lisp:1.10 climacs/cl-syntax.lisp:1.11
--- climacs/cl-syntax.lisp:1.10 Tue Apr 26 11:25:36 2005
+++ climacs/cl-syntax.lisp Wed Apr 27 16:02:03 2005
@@ -157,7 +157,7 @@
(display-parse-tree item syntax pane)))))
-;;;;;;;;;;;;;;;;;;;; token-items
+;;;;;;;;;;;;; token-items
(defclass empty-item (cl-entry) ())
@@ -207,7 +207,7 @@
(define-list token-items empty-token-items nonempty-token-items token-item)
-;;;;;;;;;;;;;;;;;;string-items
+;;;;;;;;;;;;; string-items
(defclass string-item (cl-item) ())
@@ -275,7 +275,7 @@
(display-parse-tree item syntax pane)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;balanced-comment
+;;;;;;;;;;;;; balanced-comment
(defclass balanced-comment (cl-entry)
((start-hex :initarg :start-hex)
@@ -298,8 +298,7 @@
(display-parse-tree item syntax pane)
(display-parse-tree end-hex syntax pane))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;string
+;;;;;;;;;;;;; string
(defclass cl-string (cl-entry)
((string-start :initarg :string-start)
@@ -519,7 +518,7 @@
(item default-item (and (string-equal
(item-head item) #\p)
(= (end-offset start)
- (start-offset header)))))
+ (start-offset item)))))
:start start :item item))
(defmethod display-parse-tree ((entity pathname-expr) (syntax cl-syntax) pane)
@@ -528,7 +527,7 @@
(display-parse-tree item syntax pane)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;characters
+;;;;;;;;;;;;; characters
(defclass char-item (cl-entry)
((start :initarg :start)
@@ -561,7 +560,7 @@
(display-parse-tree item syntax pane))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;list-expression
+;;;;;;;;;;;;; list-expression
(defclass list-expr (cl-entry)
((start :initarg :start)
@@ -582,7 +581,7 @@
(display-parse-tree end syntax pane))))
-;;;;;;;;;;;;;;;;;;;;;;; read-time-attr
+;;;;;;;;;;;;; read-time-attr
(defclass read-time-attr (cl-entry)
((read-car :initarg :read-car)
@@ -654,7 +653,7 @@
:read-car read-car :read-expr read-expr))
-;;;;;;;;;;;;;;;;;;;;;;;;;; read-time-conditional
+;;;;;;;;;;;;; read-time-conditional
(defclass read-time-conditional (cl-entry)
((start :initarg :start)
@@ -680,6 +679,7 @@
(expr cl-terminal (/= (end-offset test) (start-offset expr))))
:start start :test test :expr expr))
+
;;;;;;;;;;;;; read-time-conditional-minus
(defclass read-time-conditional-minus (read-time-conditional) ())
@@ -689,7 +689,8 @@
(expr cl-terminal (/= (end-offset test) (start-offset expr))))
:start start :test test :expr expr))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;function-expression
+
+;;;;;;;;;;;;; function-expression
(defclass fun-expr (cl-entry)
((start :initarg :start)
@@ -743,9 +744,9 @@
(display-parse-tree item syntax pane))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Quote expr
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Quoted expr
-(defclass quoted-expr (cl-entry)
+(defclass quoted-expr (cl-entry)
((start :initarg :start)
(item :initarg :item)))
@@ -844,6 +845,8 @@
(defmethod display-parse-tree ((entity cl-terminal) (syntax cl-syntax) pane)
(with-slots (item) entity
(display-parse-tree item syntax pane)))
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod initialize-instance :after ((syntax cl-syntax) &rest args)
@@ -863,7 +866,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; update syntax
-
(defmethod update-syntax-for-display (buffer (syntax cl-syntax) top bot)
(with-slots (parser lexer valid-parse) syntax
1
0
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv14904/climacs
Modified Files:
cl-syntax.lisp
Log Message:
modified cl-syntax
Date: Tue Apr 26 11:25:37 2005
Author: pfong
Index: climacs/cl-syntax.lisp
diff -u climacs/cl-syntax.lisp:1.9 climacs/cl-syntax.lisp:1.10
--- climacs/cl-syntax.lisp:1.9 Sat Apr 23 13:40:13 2005
+++ climacs/cl-syntax.lisp Tue Apr 26 11:25:36 2005
@@ -30,8 +30,8 @@
;;;
;;; grammar classes
-(defclass cl-parse-tree (parse-tree) ())
-
+(defclass cl-parse-tree (parse-tree) ())
+
(defclass cl-entry (cl-parse-tree)
((ink) (face)
(state :initarg :state)))
@@ -65,7 +65,7 @@
(defclass plus-symbol (cl-lexeme) ())
(defclass minus-symbol (cl-lexeme) ())
(defclass default-item (cl-lexeme) ())
-
+(defclass other-entry (cl-lexeme) ())
(defclass cl-lexer (incremental-lexer) ())
@@ -101,7 +101,8 @@
while (neutralcharp (object-after scan))
do (fo))
(make-instance 'default-item))
- (t (fo) (make-instance 'default-item))))))))
+ (t (fo)
+ (make-instance 'other-entry))))))))
(define-syntax cl-syntax ("Common-lisp" (basic-syntax))
@@ -115,8 +116,8 @@
#\/ #\. #\+ #\- #\Newline #\Space #\Tab)
:test #'char=))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
;;; parser
(defparameter *cl-grammar* (grammar))
@@ -124,8 +125,11 @@
(defmacro add-cl-rule (rule)
`(add-rule (grammar-rule ,rule) *cl-grammar*))
+(defun item-sequence (item)
+ (buffer-sequence (buffer item) (start-offset item) (end-offset item)))
+
(defun default-item-is (default-item string)
- (string-equal (coerce (buffer-sequence (buffer default-item) (start-offset default-item) (end-offset default-item)) 'string)
+ (string-equal (coerce (item-sequence default-item) 'string)
string))
(defmacro define-list (name empty-name nonempty-name item-name)
@@ -152,60 +156,84 @@
(display-parse-tree items syntax pane)
(display-parse-tree item syntax pane)))))
-;;;;;; string-items
+
+;;;;;;;;;;;;;;;;;;;; token-items
(defclass empty-item (cl-entry) ())
+
(defmethod display-parse-tree ((entity empty-item) (syntax cl-syntax) pane)
(declare (ignore pane))
nil)
-(defclass string-char (cl-entry)
- ((item :initarg :item)))
+(defclass cl-item (cl-entry)
+ ((item :initarg :item)))
+
+(defclass token-char (cl-item) ())
-(add-cl-rule (string-char -> (default-item) :item default-item))
-(add-cl-rule (string-char -> (paren-open) :item paren-open))
-(add-cl-rule (string-char -> (paren-close) :item paren-close))
-(add-cl-rule (string-char -> (comma) :item comma))
-(add-cl-rule (string-char -> (semicolon) :item semicolon))
-(add-cl-rule (string-char -> (backquote) :item backquote))
-(add-cl-rule (string-char -> (at) :item at))
-(add-cl-rule (string-char -> (backslash) :item backslash))
-(add-cl-rule (string-char -> (slash) :item slash))
-(add-cl-rule (string-char -> (dot) :item dot))
-(add-cl-rule (string-char -> (plus-symbol) :item plus-symbol))
-(add-cl-rule (string-char -> (minus-symbol) :item minus-symbol))
+(add-cl-rule (token-char -> (default-item) :item default-item))
+(add-cl-rule (token-char -> (comma) :item comma))
+(add-cl-rule (token-char -> (semicolon) :item semicolon))
+(add-cl-rule (token-char -> (backquote) :item backquote))
+(add-cl-rule (token-char -> (at) :item at))
+(add-cl-rule (token-char -> (plus-symbol) :item plus-symbol))
+(add-cl-rule (token-char -> (minus-symbol) :item minus-symbol))
-(defmethod display-parse-tree ((entity string-char) (syntax cl-syntax) pane)
+(defmethod display-parse-tree ((entity token-char) (syntax cl-syntax) pane)
(with-slots (item) entity
(display-parse-tree item syntax pane)))
-(defclass string-item (cl-entry)
+(defclass token-item (cl-entry)
((item :initarg :item)
(ch :initarg :ch)))
-(add-cl-rule (string-item -> ((ch string-char))
- :item (make-instance 'empty-item) :ch ch))
+(add-cl-rule (token-item -> ((ch token-char (or (alpha-char-p (coerce (item-head ch) 'character))
+ (member (item-head ch) '(#\= #\* #\+ #\> #\<) :test #'string-equal)
+ (member ch '(#\/ #\+ #\- #\*)
+ :test #'default-item-is))))
+ :item (make-instance 'empty-item) :ch ch))
+
+(add-cl-rule (token-item -> ((item token-item) (ch token-char (= (end-offset
+ item)
+ (start-offset
+ ch))))
+ :item item :ch ch))
-(add-cl-rule (string-item -> ((item string-item) (ch string-char (= (end-offset
- item)
- (start-offset
- ch))))
- :item item :ch ch))
-
-(defmethod display-parse-tree ((entity string-item) (syntax cl-syntax) pane)
+(defmethod display-parse-tree ((entity token-item) (syntax cl-syntax) pane)
(with-slots (item ch) entity
(display-parse-tree item syntax pane)
(display-parse-tree ch syntax pane)))
-(define-list string-items empty-string-items nonempty-string-items string-item)
+(define-list token-items empty-token-items nonempty-token-items token-item)
-(defclass identifier-item (cl-entry)
- ((item :initarg :item)))
+;;;;;;;;;;;;;;;;;;string-items
+
+(defclass string-item (cl-item) ())
+
+(add-cl-rule (string-item -> (token-item) :item token-item))
+(add-cl-rule (string-item -> (default-item) :item default-item))
+(add-cl-rule (string-item -> (paren-open) :item paren-open))
+(add-cl-rule (string-item -> (paren-close) :item paren-close))
+(add-cl-rule (string-item -> (hex) :item hex))
+(add-cl-rule (string-item -> (backslash) :item backslash))
+(add-cl-rule (string-item -> (slash) :item slash))
+(add-cl-rule (string-item -> (dot) :item dot))
+
+
+(define-list string-items empty-string-items
+ nonempty-string-items string-item)
+
+(defmethod display-parse-tree ((entity string-item) (syntax cl-syntax) pane)
+ (with-slots (item) entity
+ (display-parse-tree item syntax pane)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass identifier-item (cl-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))
(define-list identifier-items empty-identifier-items
@@ -232,49 +260,45 @@
(display-parse-tree end syntax pane)))
-(defclass identifier (cl-entry)
- ((item :initarg :item)))
+(defclass identifier (cl-item) ())
+
+(add-cl-rule (identifier -> ((item token-item))
+ :item item))
-(add-cl-rule (identifier -> ((item string-item
- (or (alpha-char-p (coerce
- (item-head item) 'character))
- (string-equal #\= (item-head item))
- (member item '(#\/ #\+ #\- #\*)
- :test #'default-item-is))))
+(add-cl-rule (identifier -> ((item slash))
:item item))
(add-cl-rule (identifier -> (identifier-compound) :item identifier-compound))
(defmethod display-parse-tree ((entity identifier) (syntax cl-syntax) pane)
(with-slots (item) entity
- (display-parse-tree item syntax pane)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;line-comment
-;;missing (cannot parse end of line)
+ (display-parse-tree item syntax pane)))
-(defclass line-comment (cl-entry) ())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;balanced-comment
(defclass balanced-comment (cl-entry)
((start-hex :initarg :start-hex)
- (items :initarg :items)
+ (item :initarg :item)
(end-hex :initarg :end-hex)))
(add-cl-rule (balanced-comment -> ((start-hex hex)
- (items identifier-compound)
- (end-hex hex))
+ (item identifier-compound (= (end-offset start-hex)
+ (start-offset item)))
+ (end-hex hex (= (end-offset item)
+ (start-offset end-hex))))
:start-hex start-hex
- :items items
+ :item item
:end-hex end-hex))
(defmethod display-parse-tree ((entity balanced-comment) (syntax cl-syntax) pane)
- (with-slots (start-hex items end-hex) entity
- (with-drawing-options (pane :ink +blue+)
+ (with-slots (start-hex item end-hex) entity
+ (with-drawing-options (pane :ink (make-rgb-color 0.6 0.16 0.3))
(display-parse-tree start-hex syntax pane)
- (display-parse-tree items syntax pane)
+ (display-parse-tree item syntax pane)
(display-parse-tree end-hex syntax pane))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;string
(defclass cl-string (cl-entry)
@@ -289,11 +313,12 @@
(defmethod display-parse-tree ((entity cl-string) (syntax cl-syntax) pane)
(with-slots (string-start items string-end) entity
- (with-drawing-options (pane :ink +orange+)
+ (with-drawing-options (pane :ink (make-rgb-color 0.6 0.4 0.2))
(display-parse-tree string-start syntax pane)
(display-parse-tree items syntax pane)
(display-parse-tree string-end syntax pane))))
+
;;;;;;;;;;;;;;;;;;;;; #-type constants
(defun item-head (default-item)
@@ -322,8 +347,10 @@
(defclass hexadecimal-expr (radix-expr) ())
(add-cl-rule (hexadecimal-expr -> ((start hex)
- (item string-item
- (and (string-equal (item-head item) #\x)
+ (item token-item
+ (and (= (end-offset start)
+ (start-offset item))
+ (string-equal (item-head item) #\x)
(radix-is (item-tail item) 16))))
:start start :item item))
@@ -331,17 +358,21 @@
(add-cl-rule (octal-expr -> ((start hex)
(item default-item
- (and (string-equal (item-head item) #\o)
- (radix-is (item-tail item) 8))))
+ (and (= (end-offset start)
+ (start-offset item))
+ (string-equal (item-head item) #\o)
+ (radix-is (item-tail item) 8))))
:start start :item item))
(defclass binary-expr (radix-expr) ())
(add-cl-rule (binary-expr -> ((start hex)
(item default-item
- (and (string-equal (item-head item) #\b)
+ (and (= (end-offset start)
+ (start-offset item))
+ (string-equal (item-head item) #\b)
(radix-is (item-tail
- item) 2))))
+ item) 2))))
:start start :item item))
(defclass radix-n-expr (cl-entry)
@@ -350,16 +381,17 @@
(item :initarg :item)))
(add-cl-rule (radix-n-expr -> ((start hex)
- (radix simple-number)
- (item string-item (and (string-equal
- (item-head item) #\r)
- (radix-is
- (item-tail item)
- (values (parse-integer (coerce
- (buffer-sequence (buffer radix)
- (start-offset radix)
- (end-offset radix))
- 'string)))))))
+ (radix simple-number (= (end-offset start)
+ (start-offset radix)))
+ (item default-item (and (= (end-offset radix)
+ (start-offset item))
+ (string-equal
+ (item-head item) #\r)
+ (radix-is
+ (item-tail item)
+ (values (parse-integer (coerce
+ (item-sequence radix) 'string)))))))
+
:start start :radix radix :item item))
(defmethod display-parse-tree ((entity radix-n-expr) (syntax cl-syntax) pane)
@@ -368,18 +400,16 @@
(display-parse-tree radix syntax pane)
(display-parse-tree item syntax pane)))
-(defclass simple-number (cl-entry)
- ((content :initarg :content)))
+(defclass simple-number (cl-item) ())
-(add-cl-rule (simple-number -> ((content default-item (radix-is
+(add-cl-rule (simple-number -> ((item default-item (radix-is
(coerce
- (buffer-sequence (buffer content) (start-offset content)
- (end-offset content)) 'string) 10)))
- :content content))
+ (item-sequence item) 'string) 10)))
+ :item item))
(defmethod display-parse-tree ((entity simple-number) (syntax cl-syntax) pane)
- (with-slots (content) entity
- (display-parse-tree content syntax pane)))
+ (with-slots (item) entity
+ (display-parse-tree item syntax pane)))
(defclass real-number (cl-entry)
@@ -450,11 +480,13 @@
(header :initarg :header)
(item :initarg :item)))
-(add-cl-rule (complex-expr -> ((start hex)
- (header default-item (default-item-is
- header
- #\c))
- (item complex-number))
+(add-cl-rule (complex-expr -> ((start hex)
+ (header default-item (and (default-item-is
+ header #\c)
+ (= (end-offset start)
+ (start-offset header))))
+ (item complex-number (= (end-offset header)
+ (start-offset item))))
:start start :header header :item
item))
@@ -464,29 +496,30 @@
(display-parse-tree header syntax pane)
(display-parse-tree item syntax pane)))
-(defclass number-expr (cl-entry)
- ((content :initarg :content)))
+(defclass number-expr (cl-item) ())
-(add-cl-rule (number-expr -> ((item simple-number)) :content item))
-(add-cl-rule (number-expr -> ((item real-number)) :content item))
-(add-cl-rule (number-expr -> ((item binary-expr)) :content item))
-(add-cl-rule (number-expr -> ((item octal-expr)) :content item))
-(add-cl-rule (number-expr -> ((item hexadecimal-expr)) :content item))
-(add-cl-rule (number-expr -> ((item radix-n-expr)) :content item))
-(add-cl-rule (number-expr -> ((item complex-expr)) :content item))
+(add-cl-rule (number-expr -> ((item simple-number)) :item item))
+(add-cl-rule (number-expr -> ((item real-number)) :item item))
+(add-cl-rule (number-expr -> ((item binary-expr)) :item item))
+(add-cl-rule (number-expr -> ((item octal-expr)) :item item))
+(add-cl-rule (number-expr -> ((item hexadecimal-expr)) :item item))
+(add-cl-rule (number-expr -> ((item radix-n-expr)) :item item))
+(add-cl-rule (number-expr -> ((item complex-expr)) :item item))
(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))))
+ (with-slots (item) entity
+ (with-drawing-options (pane :ink (make-rgb-color 0.14 0.0 0.86))
+ (display-parse-tree item syntax pane))))
(defclass pathname-expr (cl-entry)
((start :initarg :start)
(item :initarg :item)))
(add-cl-rule (pathname-expr -> ((start hex)
- (item default-item (string-equal
- (item-head item) #\p)))
+ (item default-item (and (string-equal
+ (item-head item) #\p)
+ (= (end-offset start)
+ (start-offset header)))))
:start start :item item))
(defmethod display-parse-tree ((entity pathname-expr) (syntax cl-syntax) pane)
@@ -522,26 +555,31 @@
(defmethod display-parse-tree ((entity char-item) (syntax cl-syntax) pane)
(with-slots (start separator item) entity
- (display-parse-tree start syntax pane)
- (display-parse-tree separator syntax pane)
- (display-parse-tree item syntax pane)))
+ (with-drawing-options (pane :ink (make-rgb-color 0.14 0.0 0.86))
+ (display-parse-tree start syntax pane)
+ (display-parse-tree separator syntax pane)
+ (display-parse-tree item syntax pane))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;list-expression
+
(defclass list-expr (cl-entry)
((start :initarg :start)
(items :initarg :items)
(end :initarg :end)))
-(add-cl-rule (list-expr -> ((start paren-open) cl-terminals (end paren-close))
- :start start :items cl-terminals
- :end end))
+(add-cl-rule (list-expr -> ((start paren-open)
+ (items cl-terminals)
+ (end paren-close))
+ :start start :items items :end end))
(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)
- (display-parse-tree end syntax pane)))
+ (with-text-face (pane :bold)
+ (display-parse-tree start syntax pane))
+ (display-parse-tree items syntax pane)
+ (with-text-face (pane :bold)
+ (display-parse-tree end syntax pane))))
;;;;;;;;;;;;;;;;;;;;;;; read-time-attr
@@ -578,8 +616,24 @@
(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)))
+ (with-drawing-options (pane :ink (make-rgb-color 0.0 0.42 0.42))
+ (display-parse-tree start syntax pane)
+ (display-parse-tree item 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))
+
+
+(defmethod display-parse-tree ((entity read-time-expr) (syntax cl-syntax) pane)
+ (with-slots (time-expr) entity
+ (display-parse-tree time-expr syntax pane)))
;;;;;;;;;;;;;; read-time-plus-attr
@@ -590,6 +644,7 @@
(read-expr read-time-expr (= (end-offset read-car) (start-offset read-expr))))
:read-car read-car :read-expr read-expr))
+
;;;;;;;;;;;;;; read-time-minus-attr
(defclass read-time-minus-attr (read-time-attr) ())
@@ -598,22 +653,9 @@
(read-expr read-time-expr (= (end-offset read-car) (start-offset read-expr))))
:read-car read-car :read-expr read-expr))
-;;;;;;;;;;;;; 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))
-
-
-(defmethod display-parse-tree ((entity read-time-expr) (syntax cl-syntax) pane)
- (with-slots (time-expr) entity
- (display-parse-tree time-expr syntax pane)))
-
;;;;;;;;;;;;;;;;;;;;;;;;;; read-time-conditional
+
(defclass read-time-conditional (cl-entry)
((start :initarg :start)
(test :initarg :test)
@@ -622,9 +664,10 @@
(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)))
+ (with-drawing-options (pane :ink (make-rgb-color 0.0 0.42 0.42))
+ (display-parse-tree start syntax pane)
+ (display-parse-tree test syntax pane)
+ (display-parse-tree expr syntax pane))))
;;;;;;;;;;;;; read-time-conditional-plus
@@ -646,7 +689,7 @@
(expr cl-terminal (/= (end-offset test) (start-offset expr))))
:start start :test test :expr expr))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;function-expression
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;function-expression
(defclass fun-expr (cl-entry)
((start :initarg :start)
@@ -658,8 +701,9 @@
(defmethod display-parse-tree ((entity fun-expr) (syntax cl-syntax) pane)
(with-slots (start quoted-expr) entity
- (display-parse-tree start syntax pane)
- (display-parse-tree quoted-expr syntax pane)))
+ (with-drawing-options (pane :ink (make-rgb-color 0.4 0.0 0.4))
+ (display-parse-tree start syntax pane)
+ (display-parse-tree quoted-expr syntax pane))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;vector-expression
@@ -674,46 +718,33 @@
(defmethod display-parse-tree ((entity vect-expr) (syntax cl-syntax) pane)
(with-slots (start list-expr) entity
- (display-parse-tree start syntax pane)
- (display-parse-tree list-expr syntax pane)))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;array-expression
-
-(defclass array-expr (cl-entry) ())
+ (with-drawing-options (pane :ink (make-rgb-color 0.14 0.0 0.86))
+ (display-parse-tree start syntax pane)
+ (display-parse-tree list-expr syntax pane))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;bitvector-expression
-(defclass bit-item (cl-entry)
- ((item :initarg :item)))
-
-(add-cl-rule (bit-item -> ((item string-item (radix-is item 2)))
- :item item))
-
-(define-list bit-items empty-bit-items nonempty-bit-items bit-item)
-
-(defclass bitvect-expr (cl-nonterminal)
- ((start :initarg :start)
- (asterisk :initarg :asterisk)
- (items :initarg :items)))
+(defclass bitvect-expr (radix-expr) ())
(add-cl-rule (bitvect-expr -> ((start hex)
- (asterisk default-item (and (= (end-offset start)
- (start-offset asterisk))
- (default-item-is asterisk #\*)))
- (items bit-items))
- :start start :asterisk asterisk :items items))
+ (item default-item
+ (and (= (end-offset start)
+ (start-offset item))
+ (string-equal (item-head item) #\*)
+ (radix-is (item-tail
+ item) 2))))
+ :start start :item item))
(defmethod display-parse-tree ((entity bitvect-expr) (syntax cl-syntax) pane)
- (with-slots (start asterisk items) entity
- (with-drawing-options (pane :ink +brown+)
+ (with-slots (start item) entity
+ (with-drawing-options (pane :ink (make-rgb-color 0.14 0.0 0.86))
(display-parse-tree start syntax pane)
- (display-parse-tree asterisk syntax pane)
- (display-parse-tree items syntax pane))))
+ (display-parse-tree item syntax pane))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Quote expr
+
(defclass quoted-expr (cl-entry)
((start :initarg :start)
(item :initarg :item)))
@@ -724,11 +755,13 @@
(defmethod display-parse-tree ((entity quoted-expr) (syntax cl-syntax) pane)
(with-slots (start item) entity
- (display-parse-tree start syntax pane)
+ (with-text-face (pane :bold)
+ (display-parse-tree start syntax pane))
(display-parse-tree item syntax pane)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Backquoted expr
+
(defclass backquoted-expr (cl-entry)
((start :initarg :start)
(item :initarg :item)))
@@ -748,7 +781,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;unquoted expr
-
(defclass unquoted-item (cl-entry)
((start :initarg :start)
(end :initarg :end)))
@@ -763,7 +795,6 @@
(display-parse-tree start syntax pane)
(display-parse-tree end syntax pane)))
-
(defclass unquoted-expr (cl-entry)
((start :initarg :start)
(item :initarg :item)))
@@ -812,7 +843,7 @@
(defmethod display-parse-tree ((entity cl-terminal) (syntax cl-syntax) pane)
(with-slots (item) entity
- (display-parse-tree item syntax pane)))
+ (display-parse-tree item syntax pane)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod initialize-instance :after ((syntax cl-syntax) &rest args)
@@ -831,7 +862,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
;;; update syntax
@@ -859,7 +889,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
;;; display
(defvar *white-space-start* nil)
@@ -961,7 +990,7 @@
syntax
pane))
;; display the lexemes
- (with-drawing-options (pane :ink +red+)
+ (with-drawing-options (pane :ink (make-rgb-color 0.7 0.7 0.7))
(loop while (< start-token-index end-token-index)
do (let ((token (lexeme lexer start-token-index)))
(display-parse-tree token syntax pane))
@@ -975,7 +1004,8 @@
(draw-rectangle* pane
(1- cursor-x) (- cursor-y (* 0.2 height))
(+ cursor-x 2) (+ cursor-y (* 0.8 height))
- :ink (if current-p +red+ +blue+))))))
+ :ink (if current-p
+ (make-rgb-color 0.7 0.7 0.7) +blue+))))))
1
0
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv604
Modified Files:
cl-syntax.lisp
Log Message:
Corrected most syntactic rules
Date: Sat Apr 23 13:40:14 2005
Author: pfong
Index: climacs/cl-syntax.lisp
diff -u climacs/cl-syntax.lisp:1.8 climacs/cl-syntax.lisp:1.9
--- climacs/cl-syntax.lisp:1.8 Thu Apr 21 17:22:11 2005
+++ climacs/cl-syntax.lisp Sat Apr 23 13:40:13 2005
@@ -30,10 +30,11 @@
;;;
;;; grammar classes
-(defclass cl-parse-tree (parse-tree) ())
-
+(defclass cl-parse-tree (parse-tree) ())
+
(defclass cl-entry (cl-parse-tree)
- ((ink) (face)))
+ ((ink) (face)
+ (state :initarg :state)))
(defclass cl-nonterminal (cl-entry) ())
@@ -45,8 +46,8 @@
;;;
;;; lexer
-(defclass cl-lexeme (cl-entry)
- ((state :initarg :state)))
+(defclass cl-lexeme (cl-entry) ())
+
(defclass start-lexeme (cl-lexeme) ())
(defclass paren-open (cl-lexeme) ())
(defclass paren-close (cl-lexeme) ())
@@ -58,6 +59,11 @@
(defclass semicolon (cl-lexeme) ())
(defclass backquote (cl-lexeme) ())
(defclass at (cl-lexeme) ())
+(defclass backslash (cl-lexeme) ())
+(defclass slash (cl-lexeme) ())
+(defclass dot (cl-lexeme) ())
+(defclass plus-symbol (cl-lexeme) ())
+(defclass minus-symbol (cl-lexeme) ())
(defclass default-item (cl-lexeme) ())
@@ -70,16 +76,24 @@
(#\( (fo) (make-instance 'paren-open))
(#\) (fo) (make-instance 'paren-close))
(#\, (fo) (make-instance 'comma))
- (#\" (fo) (make-instance 'double-quote))
+ (#\" (fo) (make-instance 'double-quote))
(#\' (fo) (make-instance 'quote-symbol))
(#\# (fo) (make-instance 'hex))
(#\| (fo) (make-instance 'pipe))
(#\` (fo) (make-instance 'backquote))
(#\@ (fo) (make-instance 'at))
- (#\; (fo) (make-instance 'semicolon))
- (t (cond ((numberp object)
+ (#\\ (fo) (make-instance 'backslash))
+ (#\/ (fo) (make-instance 'slash))
+ (#\. (fo) (make-instance 'dot))
+ (#\+ (fo) (make-instance 'plus-symbol))
+ (#\- (fo) (make-instance 'minus-symbol))
+ (#\; (fo) (loop until (end-of-buffer-p scan)
+ while (eql (object-after scan) #\;)
+ do (fo))
+ (make-instance 'semicolon))
+ (t (cond ((digit-char-p object)
(loop until (end-of-buffer-p scan)
- while (numberp (object-after scan))
+ while (digit-char-p (object-after scan))
do (fo))
(make-instance 'default-item))
((neutralcharp object)
@@ -95,15 +109,12 @@
(valid-parse :initform 1)
(parser)))
-
-
(defun neutralcharp (var)
(and (characterp var)
(not (member var '(#\( #\) #\, #\" #\' #\# #\| #\` #\@ #\; #\\
- #\. #\+ #\-)
+ #\/ #\. #\+ #\- #\Newline #\Space #\Tab)
:test #'char=))))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; parser
@@ -130,7 +141,8 @@
(add-cl-rule (,name -> (,name ,item-name)
(make-instance ',nonempty-name
- :items ,name :item ,item-name)))
+ :items ,name :item ,item-name)))
+
(defmethod display-parse-tree ((entity ,empty-name) (syntax cl-syntax) pane)
(declare (ignore pane))
nil)
@@ -140,9 +152,14 @@
(display-parse-tree items syntax pane)
(display-parse-tree item syntax pane)))))
-
;;;;;; string-items
+(defclass empty-item (cl-entry) ())
+
+(defmethod display-parse-tree ((entity empty-item) (syntax cl-syntax) pane)
+ (declare (ignore pane))
+ nil)
+
(defclass string-char (cl-entry)
((item :initarg :item)))
@@ -153,36 +170,34 @@
(add-cl-rule (string-char -> (semicolon) :item semicolon))
(add-cl-rule (string-char -> (backquote) :item backquote))
(add-cl-rule (string-char -> (at) :item at))
+(add-cl-rule (string-char -> (backslash) :item backslash))
+(add-cl-rule (string-char -> (slash) :item slash))
+(add-cl-rule (string-char -> (dot) :item dot))
+(add-cl-rule (string-char -> (plus-symbol) :item plus-symbol))
+(add-cl-rule (string-char -> (minus-symbol) :item minus-symbol))
(defmethod display-parse-tree ((entity string-char) (syntax cl-syntax) pane)
(with-slots (item) entity
(display-parse-tree item syntax pane)))
-(defclass string-part (cl-entry)
+(defclass string-item (cl-entry)
((item :initarg :item)
(ch :initarg :ch)))
-(add-cl-rule (string-part -> ((item string-part) (ch string-char (= (end-offset
+(add-cl-rule (string-item -> ((ch string-char))
+ :item (make-instance 'empty-item) :ch ch))
+
+(add-cl-rule (string-item -> ((item string-item) (ch string-char (= (end-offset
item)
(start-offset
ch))))
:item item :ch ch))
-(defmethod display-parse-tree ((entity string-part) (syntax cl-syntax) pane)
+(defmethod display-parse-tree ((entity string-item) (syntax cl-syntax) pane)
(with-slots (item ch) entity
(display-parse-tree item syntax pane)
(display-parse-tree ch syntax pane)))
-(defclass string-item (cl-entry)
- ((item :initarg :item)))
-
-(add-cl-rule (string-item -> (string-char) :item string-char))
-(add-cl-rule (string-item -> (string-part) :item string-part))
-
-(defmethod display-parse-tree ((entity string-item) (syntax cl-syntax) pane)
- (with-slots (item) entity
- (display-parse-tree item syntax pane)))
-
(define-list string-items empty-string-items nonempty-string-items string-item)
@@ -190,7 +205,7 @@
((item :initarg :item)))
(add-cl-rule (identifier-item -> (string-item) :item string-item))
-(add-cl-rule (identifier-item -> (hex) :item hex))
+(add-cl-rule (identifier-item -> (hex) :item hex))
(add-cl-rule (identifier-item -> (double-quote) :item double-quote))
(define-list identifier-items empty-identifier-items
@@ -209,6 +224,7 @@
(end pipe))
:start start :items identifier-items
:end end))
+
(defmethod display-parse-tree ((entity identifier-compound) (syntax cl-syntax) pane)
(with-slots (start items end) entity
(display-parse-tree start syntax pane)
@@ -219,7 +235,14 @@
(defclass identifier (cl-entry)
((item :initarg :item)))
-(add-cl-rule (identifier -> (string-item) :item string-item))
+(add-cl-rule (identifier -> ((item string-item
+ (or (alpha-char-p (coerce
+ (item-head item) 'character))
+ (string-equal #\= (item-head item))
+ (member item '(#\/ #\+ #\- #\*)
+ :test #'default-item-is))))
+ :item item))
+
(add-cl-rule (identifier -> (identifier-compound) :item identifier-compound))
(defmethod display-parse-tree ((entity identifier) (syntax cl-syntax) pane)
@@ -227,11 +250,9 @@
(display-parse-tree item syntax pane)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;line-comment
-
;;missing (cannot parse end of line)
-
-
+(defclass line-comment (cl-entry) ())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;balanced-comment
@@ -275,114 +296,122 @@
;;;;;;;;;;;;;;;;;;;;; #-type constants
+(defun item-head (default-item)
+ (coerce (buffer-sequence (buffer default-item)
+ (start-offset default-item)
+ (1+ (start-offset default-item))) 'string))
+
+(defun item-tail (default-item)
+ (coerce (buffer-sequence (buffer default-item)
+ (1+ (start-offset default-item))
+ (end-offset default-item)) 'string))
+
(defun radix-is (num-string radix)
- (values (parse-integer (coerce (buffer-sequence (buffer num-string)
- (start-offset
- num-string)
- (end-offset
- num-string)) 'string)
- :radix radix :junk-allowed t)))
+ (values (ignore-errors
+ (parse-integer num-string :radix radix :junk-allowed 'nil))))
-(defclass hexadecimal-expr (cl-entry)
+(defclass radix-expr (cl-entry)
((start :initarg :start)
- (header :initarg :header)
- (item :initarg :item)))
-
-(add-cl-rule (hexadecimal-expr -> ((start hex)
- (header default-item (default-item-is
- header
- #\x))
- (item string-item (radix-is
- item 16)))
- :start start :header header :item
- item))
+ (item :initarg :item)))
-(defmethod display-parse-tree ((entity hexadecimal-expr) (syntax cl-syntax) pane)
- (with-slots (start header item) entity
+(defmethod display-parse-tree ((entity radix-expr) (syntax cl-syntax) pane)
+ (with-slots (start item) entity
(display-parse-tree start syntax pane)
- (display-parse-tree header syntax pane)
(display-parse-tree item syntax pane)))
-(defclass octal-expr (cl-entry)
- ((start :initarg :start)
- (header :initarg :header)
- (item :initarg :item)))
+(defclass hexadecimal-expr (radix-expr) ())
-(add-cl-rule (octal-expr -> ((start hex)
- (header default-item (default-item-is
- header
- #\o))
- (item string-item (radix-is
- item 8)))
- :start start :header header :item
- item))
+(add-cl-rule (hexadecimal-expr -> ((start hex)
+ (item string-item
+ (and (string-equal (item-head item) #\x)
+ (radix-is (item-tail item) 16))))
+ :start start :item item))
-(defmethod display-parse-tree ((entity octal-expr) (syntax cl-syntax) pane)
- (with-slots (start header item) entity
- (display-parse-tree start syntax pane)
- (display-parse-tree header syntax pane)
- (display-parse-tree item syntax pane)))
+(defclass octal-expr (radix-expr) ())
-(defclass start-number-expr (cl-entry)
- ((start :initarg :start)
- (item :initarg :item)))
+(add-cl-rule (octal-expr -> ((start hex)
+ (item default-item
+ (and (string-equal (item-head item) #\o)
+ (radix-is (item-tail item) 8))))
+ :start start :item item))
-(defclass binary-expr (cl-entry)
- ((start :initarg :start)
- (header :initarg :header)
- (item :initarg :item)))
+(defclass binary-expr (radix-expr) ())
(add-cl-rule (binary-expr -> ((start hex)
- (header default-item (default-item-is
- header
- #\b))
- (item string-item (radix-is
- item 2)))
- :start start :header header :item
- item))
-
-(defmethod display-parse-tree ((entity binary-expr) (syntax cl-syntax) pane)
- (with-slots (start header item) entity
- (display-parse-tree start syntax pane)
- (display-parse-tree header syntax pane)
- (display-parse-tree item syntax pane)))
+ (item default-item
+ (and (string-equal (item-head item) #\b)
+ (radix-is (item-tail
+ item) 2))))
+ :start start :item item))
(defclass radix-n-expr (cl-entry)
((start :initarg :start)
(radix :initarg :radix)
- (header :initarg :header)
(item :initarg :item)))
(add-cl-rule (radix-n-expr -> ((start hex)
- (radix string-item (radix-is radix 10))
- (header default-item (default-item-is header #\r))
- (item string-item (radix-is item (second
- (multiple-value-list
- (parse-integer (coerce
- (buffer-sequence (buffer radix)
- (start-offset radix)
- (end-offset radix))
- 'string)))))))
- :start start :header header :item item))
+ (radix simple-number)
+ (item string-item (and (string-equal
+ (item-head item) #\r)
+ (radix-is
+ (item-tail item)
+ (values (parse-integer (coerce
+ (buffer-sequence (buffer radix)
+ (start-offset radix)
+ (end-offset radix))
+ 'string)))))))
+ :start start :radix radix :item item))
(defmethod display-parse-tree ((entity radix-n-expr) (syntax cl-syntax) pane)
- (with-slots (start radix header item) entity
+ (with-slots (start radix 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)))
(defclass simple-number (cl-entry)
((content :initarg :content)))
-(add-cl-rule (simple-number -> ((content string-item (radix-is
- content 10)))
+(add-cl-rule (simple-number -> ((content default-item (radix-is
+ (coerce
+ (buffer-sequence (buffer content) (start-offset content)
+ (end-offset content)) 'string) 10)))
:content content))
(defmethod display-parse-tree ((entity simple-number) (syntax cl-syntax) pane)
(with-slots (content) entity
(display-parse-tree content syntax pane)))
+
+(defclass real-number (cl-entry)
+ ((primary :initarg :primary)
+ (separator :initarg :separator)
+ (secondary :initarg :secondary)))
+
+(add-cl-rule (real-number -> ((primary simple-number)
+ (separator slash (= (end-offset primary)
+ (start-offset separator)))
+ (secondary simple-number (= (end-offset
+ separator)
+ (start-offset secondary))))
+ :primary primary :separator separator
+ :secondary secondary))
+
+(add-cl-rule (real-number -> ((primary simple-number)
+ (separator dot (= (end-offset primary)
+ (start-offset separator)))
+ (secondary simple-number (= (end-offset
+ separator)
+ (start-offset secondary))))
+ :primary primary :separator separator
+ :secondary secondary))
+
+(defmethod display-parse-tree ((entity real-number) (syntax cl-syntax) pane)
+ (with-slots (primary secondary separator) entity
+ (display-parse-tree primary syntax pane)
+ (display-parse-tree separator syntax pane)
+ (display-parse-tree secondary syntax pane)))
+
+
(defclass complex-number (cl-entry)
((start :initarg :start)
(realpart :initarg :realpart)
@@ -390,8 +419,18 @@
(end :initarg :end)))
(add-cl-rule (complex-number -> ((start paren-open)
+ (realpart real-number)
+ (imagpart real-number (/=
+ (end-offset
+ realpart)
+ (start-offset imagpart)))
+ (end paren-close))
+ :start start :realpart realpart :imagpart
+ imagpart :end end))
+
+(add-cl-rule (complex-number -> ((start paren-open)
(realpart simple-number)
- (imagpart simple-number (>
+ (imagpart simple-number (/=
(end-offset
realpart)
(start-offset imagpart)))
@@ -429,6 +468,7 @@
((content :initarg :content)))
(add-cl-rule (number-expr -> ((item simple-number)) :content item))
+(add-cl-rule (number-expr -> ((item real-number)) :content item))
(add-cl-rule (number-expr -> ((item binary-expr)) :content item))
(add-cl-rule (number-expr -> ((item octal-expr)) :content item))
(add-cl-rule (number-expr -> ((item hexadecimal-expr)) :content item))
@@ -442,18 +482,16 @@
(defclass pathname-expr (cl-entry)
((start :initarg :start)
- (header :initarg :header)
(item :initarg :item)))
(add-cl-rule (pathname-expr -> ((start hex)
- (header default-item (default-item-is header #\p))
- (item string-item))
- :start start :header header :item item))
+ (item default-item (string-equal
+ (item-head item) #\p)))
+ :start start :item item))
(defmethod display-parse-tree ((entity pathname-expr) (syntax cl-syntax) pane)
- (with-slots (start header item) entity
+ (with-slots (start item) entity
(display-parse-tree start syntax pane)
- (display-parse-tree header syntax pane)
(display-parse-tree item syntax pane)))
@@ -461,21 +499,31 @@
(defclass char-item (cl-entry)
((start :initarg :start)
- (backslash :initarg :backslash)
+ (separator :initarg :separator)
(item :initarg :item)))
(add-cl-rule (char-item -> ((start hex)
- (backslash default-item (and (= (end-offset start)
- (start-offset backslash))
- (default-item-is backslash #\\)))
- (item cl-lexeme (= (end-offset backslash)
- (start-offset item))))
- :start start :backslash backslash :item item))
+ (separator backslash (= (end-offset start)
+ (start-offset separator)))
+ (item cl-lexeme (and (= (end-offset separator)
+ (start-offset item))
+ (= (end-offset item)
+ (1+ (start-offset item))))))
+ :start start :separator separator :item item))
+
+(add-cl-rule (char-item -> ((start hex)
+ (separator backslash (= (end-offset start)
+ (start-offset separator)))
+ (item default-item (and (= (end-offset separator)
+ (start-offset item))
+ (member item
+ '("Newline" "Tab" "Space") :test #'default-item-is))))
+ :start start :separator separator :item item))
(defmethod display-parse-tree ((entity char-item) (syntax cl-syntax) pane)
- (with-slots (start backslash item) entity
+ (with-slots (start separator item) entity
(display-parse-tree start syntax pane)
- (display-parse-tree backslash syntax pane)
+ (display-parse-tree separator syntax pane)
(display-parse-tree item syntax pane)))
@@ -496,22 +544,27 @@
(display-parse-tree end syntax pane)))
-;;;;;;;;;;;;; read-time-point-attr
+;;;;;;;;;;;;;;;;;;;;;;; read-time-attr
-(defclass read-time-point-attr (cl-entry)
+(defclass read-time-attr (cl-entry)
((read-car :initarg :read-car)
(read-expr :initarg :read-expr)))
-(add-cl-rule (read-time-point-attr -> ((read-car default-item (default-item-is read-car #\.))
- (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)
+(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-point-attr
+
+(defclass read-time-point-attr (read-time-attr) ())
+
+(add-cl-rule (read-time-point-attr -> ((read-car dot)
+ (read-expr identifier (= (end-offset read-car) (start-offset read-expr))))
+ :read-car read-car :read-expr read-expr))
+
+
;;;;;;;;;;;;; read-time-evaluation
(defclass read-time-evaluation (cl-entry)
@@ -529,35 +582,21 @@
(display-parse-tree item syntax pane)))
-;;;;;;;;;;;;;;;;;;;;;;; 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 #\+))
+(add-cl-rule (read-time-plus-attr -> ((read-car plus-symbol)
(read-expr read-time-expr (= (end-offset read-car) (start-offset read-expr))))
- :read-car read-car :read-expr
- read-expr))
+ :read-car read-car :read-expr read-expr))
;;;;;;;;;;;;;; read-time-minus-attr
(defclass read-time-minus-attr (read-time-attr) ())
-(add-cl-rule (read-time-minus-attr -> ((read-car default-item (default-item-is read-car #\-))
+(add-cl-rule (read-time-minus-attr -> ((read-car minus-symbol)
(read-expr read-time-expr (= (end-offset read-car) (start-offset read-expr))))
- :read-car read-car :read-expr
- read-expr))
+ :read-car read-car :read-expr read-expr))
;;;;;;;;;;;;; read-time-expr
@@ -751,6 +790,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;cl-terminal
+(add-cl-rule (cl-terminal -> (number-expr) :item number-expr))
(add-cl-rule (cl-terminal -> (identifier) :item identifier))
(add-cl-rule (cl-terminal -> (balanced-comment) :item balanced-comment))
(add-cl-rule (cl-terminal -> (cl-string) :item cl-string))
@@ -762,7 +802,6 @@
(add-cl-rule (cl-terminal -> (fun-expr) :item fun-expr))
(add-cl-rule (cl-terminal -> (vect-expr) :item vect-expr))
(add-cl-rule (cl-terminal -> (bitvect-expr) :item bitvect-expr))
-(add-cl-rule (cl-terminal -> (number-expr) :item number-expr))
(add-cl-rule (cl-terminal -> (pathname-expr) :item pathname-expr))
(add-cl-rule (cl-terminal -> (read-time-conditional-plus) :item read-time-conditional-plus))
(add-cl-rule (cl-terminal -> (read-time-conditional-minus) :item read-time-conditional-minus))
1
0
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv2743/climacs
Modified Files:
packages.lisp
Log Message:
asdf package
Date: Fri Apr 22 10:19:12 2005
Author: pfong
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.60 climacs/packages.lisp:1.61
--- climacs/packages.lisp:1.60 Sun Mar 27 16:29:32 2005
+++ climacs/packages.lisp Fri Apr 22 10:19:11 2005
@@ -107,10 +107,6 @@
#:redisplay-pane-with-syntax
#:beginning-of-paragraph #:end-of-paragraph))
-(defpackage :climacs-cl-syntax
- (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain :climacs-syntax)
- (:export))
-
(defpackage :climacs-kill-ring
(:use :clim-lisp :flexichain)
(:export #:kill-ring #:kill-ring-length #:kill-ring-max-size
@@ -151,6 +147,11 @@
(:use :clim-lisp :clim :climacs-buffer :climacs-base
:climacs-syntax :flexichain :climacs-pane)
(:shadow "ATOM" "CLOSE" "EXP" "INTEGER" "OPEN" "VARIABLE"))
+
+(defpackage :climacs-cl-syntax
+ (:use :clim-lisp :clim :climacs-buffer :climacs-base
+ :climacs-syntax :flexichain :climacs-pane)
+ (:export))
(defpackage :climacs-gui
(:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax
1
0
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv2701/climacs
Modified Files:
climacs.asd
Log Message:
asdf dependencies
Date: Fri Apr 22 10:18:27 2005
Author: pfong
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.27 climacs/climacs.asd:1.28
--- climacs/climacs.asd:1.27 Sun Mar 27 16:29:32 2005
+++ climacs/climacs.asd Fri Apr 22 10:18:26 2005
@@ -56,12 +56,12 @@
"abbrev"
"syntax"
"text-syntax"
- "cl-syntax"
"kill-ring"
"undo"
"delegating-buffer"
"Persistent/persistent-undo"
"pane"
+ "cl-syntax"
"html-syntax"
"prolog-syntax"
"gui"
1
0
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)))))
1
0
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv18652
Modified Files:
cl-syntax.lisp
Log Message:
first version cl-syntax.lisp
Date: Wed Apr 20 17:39:11 2005
Author: pfong
Index: climacs/cl-syntax.lisp
diff -u climacs/cl-syntax.lisp:1.6 climacs/cl-syntax.lisp:1.7
--- climacs/cl-syntax.lisp:1.6 Sun Mar 13 21:51:48 2005
+++ climacs/cl-syntax.lisp Wed Apr 20 17:39:10 2005
@@ -1,8 +1,11 @@
-;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*-
+;;; -*- Mode: Lisp; Package: COMMON-LISP-SYNTAX -*-
;;; (c) copyright 2005 by
;;; Robert Strandh (strandh(a)labri.fr)
-
+;;; Nada Ayad (nada.ayad(a)etu.u-bordeaux1.fr)
+;;; Julien Cazaban (bizounorc(a)hotmail.com)
+;;; Pascal Fong Kye (pfongkye(a)yahoo.com)
+;;; Bruno Mery (mery(a)member.fsf.org)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
@@ -22,254 +25,907 @@
(in-package :climacs-cl-syntax)
-(defclass stack-entry ()
- ((start-mark :initarg :start-mark :reader start-mark)
- (size :initarg :size))
- (:documentation "A stack entry corresponds to a syntactic category"))
-(defgeneric end-offset (stack-entry))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; grammar classes
+
+(defclass cl-parse-tree (parse-tree) ())
+
+(defclass cl-entry (cl-parse-tree)
+ ((ink) (face)))
+
+(defclass cl-nonterminal (cl-entry) ())
+
+(defclass cl-terminal (cl-entry)
+ ((item :initarg :item)))
+
-(defmethod end-offset ((entry stack-entry))
- (with-slots (start-mark size) entry
- (+ (offset start-mark) size)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; lexer
+
+(defclass cl-lexeme (cl-entry)
+ ((state :initarg :state)))
+(defclass start-lexeme (cl-lexeme) ())
+(defclass paren-open (cl-lexeme) ())
+(defclass paren-close (cl-lexeme) ())
+(defclass comma (cl-lexeme) ())
+(defclass quote-symbol (cl-lexeme) ())
+(defclass double-quote (cl-lexeme) ())
+(defclass hex (cl-lexeme) ())
+(defclass pipe (cl-lexeme) ())
+(defclass semicolon (cl-lexeme) ())
+(defclass backquote (cl-lexeme) ())
+(defclass at (cl-lexeme) ())
+(defclass default-item (cl-lexeme) ())
+
+
+(defclass cl-lexer (incremental-lexer) ())
+
+(defmethod next-lexeme ((lexer cl-lexer) scan)
+ (flet ((fo () (forward-object scan)))
+ (let ((object (object-after scan)))
+ (case object
+ (#\( (fo) (make-instance 'paren-open))
+ (#\) (fo) (make-instance 'paren-close))
+ (#\, (fo) (make-instance 'comma))
+ (#\" (fo) (make-instance 'double-quote))
+ (#\' (fo) (make-instance 'quote-symbol))
+ (#\# (fo) (make-instance 'hex))
+ (#\| (fo) (make-instance 'pipe))
+ (#\` (fo) (make-instance 'backquote))
+ (#\@ (fo) (make-instance 'at))
+ (#\; (fo) (make-instance 'semicolon))
+ (t (cond ((numberp object) (fo)
+ (make-instance 'number-item))
+ (t (fo) (make-instance 'default-item))))))))
+
+
+(define-syntax cl-syntax ("Common-lisp" (basic-syntax))
+ ((lexer :reader lexer)
+ (valid-parse :initform 1)
+ (parser)))
-(defclass error-entry (stack-entry) ())
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
-;;; Terminal entries.
+;;; parser
+
+(defparameter *cl-grammar* (grammar))
+
+(defmacro add-cl-rule (rule)
+ `(add-rule (grammar-rule ,rule) *cl-grammar*))
+
+(defun default-item-is (default-item string)
+ (string-equal (coerce (buffer-sequence (buffer default-item) (start-offset default-item) (end-offset default-item)) 'string)
+ string))
+
+(defmacro define-list (name empty-name nonempty-name item-name)
+ `(progn
+ (defclass ,name (cl-entry) ())
+ (defclass ,empty-name (,name) ())
+
+ (defclass ,nonempty-name (,name)
+ ((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)))
+ (defmethod display-parse-tree ((entity ,empty-name) (syntax cl-syntax) pane)
+ (declare (ignore pane))
+ nil)
+
+ (defmethod display-parse-tree ((entity ,nonempty-name) (syntax cl-syntax) pane)
+ (with-slots (items item) entity
+ (display-parse-tree items syntax pane)
+ (display-parse-tree item syntax pane)))))
+
+
+;;;;;; string-items
+
+(defclass string-char (cl-entry)
+ ((item :initarg :item)))
+
+(add-cl-rule (string-char -> (default-item) :item default-item))
+(add-cl-rule (string-char -> (paren-open) :item paren-open))
+(add-cl-rule (string-char -> (paren-close) :item paren-close))
+(add-cl-rule (string-char -> (comma) :item comma))
+(add-cl-rule (string-char -> (semicolon) :item semicolon))
+(add-cl-rule (string-char -> (backquote) :item backquote))
+(add-cl-rule (string-char -> (at) :item at))
+
+(defmethod display-parse-tree ((entity string-char) (syntax cl-syntax) pane)
+ (with-slots (item) entity
+ (display-parse-tree item syntax pane)))
+
+(defclass string-part (cl-entry)
+ ((item :initarg :item)
+ (ch :initarg :ch)))
+
+(add-cl-rule (string-part -> ((item string-part) (ch string-char (= (end-offset
+ item)
+ (start-offset
+ 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)))
+
+(defclass string-item (cl-entry)
+ ((item :initarg :item)))
+
+(add-cl-rule (string-item -> (string-char) :item string-char))
+(add-cl-rule (string-item -> (string-part) :item string-part))
+
+(defmethod display-parse-tree ((entity string-item) (syntax cl-syntax) pane)
+ (with-slots (item) entity
+ (display-parse-tree item syntax pane)))
+
+(define-list string-items empty-string-items nonempty-string-items string-item)
+
+
+(defclass identifier-item (cl-entry)
+ ((item :initarg :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))
+
+(define-list identifier-items empty-identifier-items
+ nonempty-identifier-items identifier-item)
+
+(defmethod display-parse-tree ((entity identifier-item) (syntax cl-syntax) pane)
+ (with-slots (item) entity
+ (display-parse-tree item syntax pane)))
+
+(defclass identifier-compound (cl-entry)
+ ((start :initarg :start)
+ (items :initarg :items)
+ (end :initarg :end)))
+
+(add-cl-rule (identifier-compound -> ((start pipe) identifier-items
+ (end pipe))
+ :start start :items identifier-items
+ :end end))
+(defmethod display-parse-tree ((entity identifier-compound) (syntax cl-syntax) pane)
+ (with-slots (start items end) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree items syntax pane)
+ (display-parse-tree end syntax pane)))
+
+
+(defclass identifier (cl-entry)
+ ((item :initarg :item)))
+
+(add-cl-rule (identifier -> (string-item) :item string-item))
+(add-cl-rule (identifier -> (identifier-compound) :item identifier-compound))
+
+(defmethod display-parse-tree ((entity identifier) (syntax cl-syntax) pane)
+ (with-slots (item) entity
+ (display-parse-tree item syntax pane)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;line-comment
+;;missing (cannot parse end of line)
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;balanced-comment
+
+(defclass balanced-comment (cl-entry)
+ ((start-hex :initarg :start-hex)
+ (items :initarg :items)
+ (end-hex :initarg :end-hex)))
+
+(add-cl-rule (balanced-comment -> ((start-hex hex)
+ (items identifier-compound)
+ (end-hex hex))
+ :start-hex start-hex
+ :items items
+ :end-hex end-hex))
+
+(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+)
+ (display-parse-tree start-hex syntax pane)
+ (display-parse-tree items syntax pane)
+ (display-parse-tree end-hex syntax pane))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;string
+
+(defclass cl-string (cl-entry)
+ ((string-start :initarg :string-start)
+ (items :initarg :items)
+ (string-end :initarg :string-end)))
+
+(add-cl-rule (cl-string -> ((start double-quote) string-items (end double-quote))
+ :string-start start :items string-items
+ :string-end end))
+
+
+(defmethod display-parse-tree ((entity cl-string) (syntax cl-syntax) pane)
+ (with-slots (string-start items string-end) entity
+ (with-drawing-options (pane :ink +orange+)
+ (display-parse-tree string-start syntax pane)
+ (display-parse-tree items syntax pane)
+ (display-parse-tree string-end syntax pane))))
+
+;;;;;;;;;;;;;;;;;;;;; #-type constants
+
+(defun radix-is (num-string radix)
+ (values (parse-integer (coerce (buffer-sequence (buffer num-string)
+ (start-offset
+ num-string)
+ (end-offset
+ num-string)) 'string)
+ :radix radix :junk-allowed t)))
+
+(defclass hexadecimal-expr (cl-entry)
+ ((start :initarg :start)
+ (header :initarg :header)
+ (item :initarg :item)))
+
+(add-cl-rule (hexadecimal-expr -> ((start hex)
+ (header default-item (default-item-is
+ header
+ #\x))
+ (item string-item (radix-is
+ item 16)))
+ :start start :header header :item
+ item))
+
+(defmethod display-parse-tree ((entity hexadecimal-expr) (syntax cl-syntax) pane)
+ (with-slots (start header item) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree header syntax pane)
+ (display-parse-tree item syntax pane)))
+
+(defclass octal-expr (cl-entry)
+ ((start :initarg :start)
+ (header :initarg :header)
+ (item :initarg :item)))
+
+(add-cl-rule (octal-expr -> ((start hex)
+ (header default-item (default-item-is
+ header
+ #\o))
+ (item string-item (radix-is
+ item 8)))
+ :start start :header header :item
+ item))
+
+(defmethod display-parse-tree ((entity octal-expr) (syntax cl-syntax) pane)
+ (with-slots (start header item) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree header syntax pane)
+ (display-parse-tree item syntax pane)))
+
+(defclass binary-expr (cl-entry)
+ ((start :initarg :start)
+ (header :initarg :header)
+ (item :initarg :item)))
+
+(add-cl-rule (binary-expr -> ((start hex)
+ (header default-item (default-item-is
+ header
+ #\b))
+ (item string-item (radix-is
+ item 2)))
+ :start start :header header :item
+ item))
+
+(defmethod display-parse-tree ((entity binary-expr) (syntax cl-syntax) pane)
+ (with-slots (start header item) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree header syntax pane)
+ (display-parse-tree item syntax pane)))
+
+(defclass radix-n-expr (cl-entry)
+ ((start :initarg :start)
+ (radix :initarg :radix)
+ (header :initarg :header)
+ (item :initarg :item)))
+
+(add-cl-rule (radix-n-expr -> ((start hex)
+ (radix string-item (radix-is radix 10))
+ (header default-item (default-item-is header #\r))
+ (item string-item (radix-is item (second
+ (multiple-value-list
+ (parse-integer (coerce
+ (buffer-sequence (buffer radix)
+ (start-offset radix)
+ (end-offset radix))
+ '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)))
+
+(defclass simple-number (cl-entry)
+ ((content :initarg :content)))
+
+(add-cl-rule (simple-number -> ((content string-item (radix-is
+ 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)))
+
+(defclass complex-number (cl-entry)
+ ((start :initarg :start)
+ (realpart :initarg :realpart)
+ (imagpart :initarg :imagpart)
+ (end :initarg :end)))
+
+(add-cl-rule (complex-number -> ((start paren-open)
+ (realpart simple-number)
+ (imagpart simple-number (>
+ (end-offset
+ realpart)
+ (start-offset imagpart)))
+ (end paren-close))
+ :start start :realpart realpart :imagpart
+ imagpart :end end))
+
+(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)))
+
+(defclass complex-expr (cl-entry)
+ ((start :initarg :start)
+ (header :initarg :header)
+ (item :initarg :item)))
+
+(add-cl-rule (complex-expr -> ((start hex)
+ (header default-item (default-item-is
+ header
+ #\c))
+ (item complex-number))
+ :start start :header header :item
+ item))
+
+(defmethod display-parse-tree ((entity complex-expr) (syntax cl-syntax) pane)
+ (with-slots (start header item) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree header syntax pane)
+ (display-parse-tree item syntax pane)))
+
+(defclass number-expr (cl-entry)
+ ((content :initarg :content)))
+
+(add-cl-rule (number-expr -> ((item simple-number)) :content item))
+(add-cl-rule (number-expr -> ((item binary-expr)) :content item))
+(add-cl-rule (number-expr -> ((item octal-expr)) :content item))
+(add-cl-rule (number-expr -> ((item hexadecimal-expr)) :content item))
+(add-cl-rule (number-expr -> ((item radix-n-expr)) :content item))
+(add-cl-rule (number-expr -> ((item complex-expr)) :content item))
+
+(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))))
+
+(defclass pathname-expr (cl-entry)
+ ((start :initarg :start)
+ (header :initarg :header)
+ (item :initarg :item)))
+
+(add-cl-rule (pathname-expr -> ((start hex)
+ (header default-item (default-item-is header #\p))
+ (item string-item))
+ :start start :header header :item item))
+
+(defmethod display-parse-tree ((entity pathname-expr) (syntax cl-syntax) pane)
+ (with-slots (start header item) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree header syntax pane)
+ (display-parse-tree item syntax pane)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;characters
+
+(defclass char-item (cl-entry)
+ ((start :initarg :start)
+ (backslash :initarg :backslash)
+ (item :initarg :item)))
+
+(add-cl-rule (char-item -> ((start hex)
+ (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)))))
+ :start start :backslash backslash :item item))
+
+(defmethod display-parse-tree ((entity char-item) (syntax cl-syntax) pane)
+ (with-slots (start backslash item) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree backslash syntax pane)
+ (display-parse-tree item syntax pane)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;list-expression
+(defclass list-expr (cl-entry)
+ ((start :initarg :start)
+ (items :initarg :items)
+ (end :initarg :end)))
+
+(add-cl-rule (list-expr -> ((start paren-open) cl-terminals (end paren-close))
+ :start start :items cl-terminals
+ :end end))
+
+(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)
+ (display-parse-tree end syntax pane)))
+
+
+;;;;;;;;;;;;; read-time-point-attr
+
+(defclass read-time-point-attr (cl-entry)
+ ((read-car :initarg :read-car)
+ (read-expr :initarg :read-expr)))
+
+(add-cl-rule (read-time-point-attr -> ((read-car default-item (default-item-is read-car #\.))
+ (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)
+ ((start :initarg :start)
+ (item :initarg :item)))
+
+
+(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-car :initarg :read-car)
+ (read-expr :initarg :read-expr)))
+
+(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)))
+
+(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))
+
+
+(defmethod display-parse-tree ((entity read-time-expr) (syntax cl-syntax) pane)
+ (with-slots (time-expr) entity
+ (display-parse-tree time-expr syntax pane)))
+
+;;;;;;;;;;;;; read-time-conditional-plus
+
+(defclass read-time-conditional-plus (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)
+ (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-minus
+
+(defclass read-time-conditional-minus (cl-entry)
+ ((start :initarg :start)
+ (test :initarg :test)
+ (expr :initarg :expr)))
+
+(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)
+ ((start :initarg :start)
+ (quoted-expr :initarg :quoted-expr)))
+
+(add-cl-rule (fun-expr -> ((start hex)
+ (quoted-expr quoted-expr))
+ :start start :quoted-expr quoted-expr))
+
+(defmethod display-parse-tree ((entity fun-expr) (syntax cl-syntax) pane)
+ (with-slots (start quoted-expr) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree quoted-expr syntax pane)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;vector-expression
+
+(defclass vect-expr (cl-entry)
+ ((start :initarg :start)
+ (list-expr :initarg :list-expr)))
+
+(add-cl-rule (vect-expr -> ((start hex)
+ (list-expr list-expr))
+ :start start :list-expr list-expr))
+
+(defmethod display-parse-tree ((entity vect-expr) (syntax cl-syntax) pane)
+ (with-slots (start list-expr) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree list-expr syntax pane)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;array-expression
+
+(defclass array-expr (cl-entry) ())
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;bitvector-expression
+
+(defclass bit-item (cl-entry)
+ ((item :initarg :item)))
+
+(add-cl-rule (bit-item -> ((item string-item (radix-is item 2)))
+ :item item))
+
+(define-list bit-items empty-bit-items nonempty-bit-items bit-item)
+
+(defclass bitvect-expr (cl-nonterminal);FIXME
+ ((start :initarg :start)
+ (asterisk :initarg :asterisk)
+ (items :initarg :items)))
+
+(add-cl-rule (bitvect-expr -> ((start hex)
+ (asterisk default-item (and (= (end-offset start)
+ (start-offset 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))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Quote expr
+(defclass quoted-expr (cl-entry)
+ ((start :initarg :start)
+ (item :initarg :item)))
+
+(add-cl-rule (quoted-expr -> ((start quote-symbol)
+ (item cl-terminal))
+ :start start :item item))
+
+(defmethod display-parse-tree ((entity quoted-expr) (syntax cl-syntax) pane)
+ (with-slots (start item) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree item syntax pane)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Backquoted expr
+(defclass backquoted-expr (cl-entry)
+ ((start :initarg :start)
+ (item :initarg :item)))
+
+(add-cl-rule (backquoted-expr -> ((start backquote)
+ (item cl-terminal))
+ :start start :item item))
+(add-cl-rule (backquoted-expr -> ((start backquote)
+ (item unquoted-expr))
+ :start start :item item))
+
+(defmethod display-parse-tree ((entity backquoted-expr) (syntax cl-syntax) pane)
+ (with-slots (start item) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree item syntax pane)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;unquoted expr
+
+
+(defclass unquoted-item (cl-entry)
+ ((start :initarg :start)
+ (end :initarg :end)))
+
+(add-cl-rule (unquoted-item -> ((start comma)
+ (end at (= (end-offset start)
+ (start-offset end))))
+ :start start :end end))
+
+(defmethod display-parse-tree ((entity unquoted-item) (syntax cl-syntax) pane)
+ (with-slots (start end) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree end syntax pane)))
+
+
+(defclass unquoted-expr (cl-entry)
+ ((start :initarg :start)
+ (item :initarg :item)))
+
+(add-cl-rule (unquoted-expr -> ((start comma)
+ (item identifier))
+ :start start :item item))
+(add-cl-rule (unquoted-expr -> ((start comma)
+ (item list-expr))
+ :start start :item item))
+
+(add-cl-rule (unquoted-expr -> ((start unquoted-item)
+ (item identifier))
+ :start start :item item))
+(add-cl-rule (unquoted-expr -> ((start unquoted-item)
+ (item list-expr))
+ :start start :item item))
+
+(defmethod display-parse-tree ((entity unquoted-expr) (syntax cl-syntax) pane)
+ (with-slots (start item) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree item syntax pane)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;cl-terminal
+
+(add-cl-rule (cl-terminal -> (identifier) :item identifier))
+(add-cl-rule (cl-terminal -> (balanced-comment) :item balanced-comment))
+(add-cl-rule (cl-terminal -> (cl-string) :item cl-string))
+(add-cl-rule (cl-terminal -> (quoted-expr) :item quoted-expr))
+(add-cl-rule (cl-terminal -> (backquoted-expr) :item backquoted-expr))
+(add-cl-rule (cl-terminal -> (char-item) :item char-item))
+(add-cl-rule (cl-terminal -> (unquoted-expr) :item unquoted-expr))
+(add-cl-rule (cl-terminal -> (list-expr) :item list-expr))
+(add-cl-rule (cl-terminal -> (fun-expr) :item fun-expr))
+(add-cl-rule (cl-terminal -> (vect-expr) :item vect-expr))
+(add-cl-rule (cl-terminal -> (bitvect-expr) :item bitvect-expr))
+(add-cl-rule (cl-terminal -> (number-expr) :item number-expr))
+(add-cl-rule (cl-terminal -> (pathname-expr) :item pathname-expr))
+(add-cl-rule (cl-terminal -> (read-time-conditional-plus) :item read-time-conditional-plus))
+(add-cl-rule (cl-terminal -> (read-time-conditional-minus) :item read-time-conditional-minus))
+(add-cl-rule (cl-terminal -> (read-time-evaluation) :item read-time-evaluation))
+
+(define-list cl-terminals empty-cl-terminals
+ nonempty-cl-terminals cl-terminal)
+
+(defmethod display-parse-tree ((entity cl-terminal) (syntax cl-syntax) pane)
+ (with-slots (item) entity
+ (display-parse-tree item syntax pane)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defclass terminal-entry (stack-entry)
- ((parse-tree))
- (:documentation "Used for tokens (numbers, symbols), but also for
-macro characters that start more complex expressions."))
-
-(defclass start-entry (terminal-entry)
- ()
- (:documentation "dummy entry before all the others."))
-
-(defclass token-entry (terminal-entry)
- ()
- (:documentation "the syntactic class of tokens."))
-
-(defclass character-entry (terminal-entry)
- ()
- (:documentation "the syntactic class of characters."))
-
-(defclass double-quote-entry (terminal-entry)
- ())
-
-(defclass quote-entry (terminal-entry)
- ()
- (:documentation "syntactic class of quote inidicators."))
-
-(defclass backquote-entry (terminal-entry)
- ()
- (:documentation "syntactic class of backquote indicators. "))
-
-(defclass unquote-entry (terminal-entry)
- ()
- (:documentation "syntactic class of unquote indicators. "))
-
-(defclass comment-entry (terminal-entry)
- ()
- (:documentation "syntactic class of single-line comment indicators. "))
-
-(defclass list-start-entry (terminal-entry)
- ()
- (:documentation "syntactic class of list start indicators."))
-
-(defclass list-end-entry (terminal-entry)
- ()
- (:documentation "syntactic class of list end indicators."))
-
-(defclass label-ref-entry (terminal-entry)
- ()
- (:documentation "syntactic class of label reference indicators."))
-
-(defclass label-entry (terminal-entry)
- ()
- (:documentation "syntactic class of label indicators."))
-
-(defclass function-entry (terminal-entry)
- ()
- (:documentation "syntactic class of function indicators."))
-
-(defclass balanced-comment-entry (terminal-entry)
- ()
- (:documentation "syntactic class of balanced comment entry indicators. "))
-
-(defclass read-time-conditional-plus-entry (terminal-entry)
- ()
- (:documentation "syntactic class of read-time conditional indicators. "))
-
-(defclass read-time-conditional-minus-entry (terminal-entry)
- ()
- (:documentation "syntactic class of read-time conditional indicators. "))
-
-(defclass vector-entry (terminal-entry)
- ()
- (:documentation "syntactic class of vector indicators."))
-
-(defclass array-entry (terminal-entry)
- ()
- (:documentation "syntactic class of array indicators."))
-
-(defclass bitvector-entry (terminal-entry)
- ()
- (:documentation "syntactic class of bit vector indicators. "))
-
-(defclass uninterned-symbol-entry (terminal-entry)
- ()
- (:documentation "syntactic class of uninterned symbol indicators. "))
-
-(defclass read-time-evaluation-entry (terminal-entry)
- ()
- (:documentation "syntactic class of read-time evaluation indicators. "))
-
-(defclass complex-entry (terminal-entry)
- ()
- (:documentation "syntactic class of complex indicators."))
-
-(defclass octal-entry (terminal-entry)
- ()
- (:documentation "syntactic class of octal rational indicators."))
-
-(defclass hex-entry (terminal-entry)
- ()
- (:documentation "syntactic class of hex rational indicators."))
-
-(defclass radix-n-entry (terminal-entry)
- ()
- (:documentation "syntactic class of radix-n rational indicators."))
-
-(defclass pathname-entry (terminal-entry)
- ()
- (:documentation "syntactic class of pathname indicators."))
-
-(defclass structure-entry (terminal-entry)
- ()
- (:documentation "syntactic class of structure indicators."))
-
-(defclass binary-entry (terminal-entry)
- ()
- (:documentation "syntactic class of binary rational indicators."))
-
-(defclass unknown-entry (terminal-entry)
- ()
- (:documentation "unknown (user-defined) syntactic classes."))
-
-(define-syntax cl-syntax ("Common Lisp" (basic-syntax))
- ((elements :initform (make-instance 'standard-flexichain))
- (guess-pos :initform 1)))
-
(defmethod initialize-instance :after ((syntax cl-syntax) &rest args)
(declare (ignore args))
- (with-slots (buffer elements) syntax
- (let ((mark (clone-mark (low-mark buffer) :left)))
- (setf (offset mark) 0)
- (insert* elements 0 (make-instance 'start-entry
- :start-mark mark :size 0)))))
-
-(defun next-entry (scan)
- (let ((start-mark (clone-mark scan)))
- (flet ((fo () (forward-object scan)))
- (macrolet ((make-entry (type)
- `(return-from next-entry
- (make-instance ,type :start-mark start-mark
- :size (- (offset scan) (offset start-mark))))))
- (loop with object = (object-after scan)
- until (end-of-buffer-p scan)
- do (case object
- (#\( (fo) (make-entry 'list-start-entry))
- (#\) (fo) (make-entry 'list-end-entry))
- (#\; (loop do (fo)
- until (end-of-line-p scan))
- (make-entry 'comment-entry))
- (#\" (fo) (make-entry 'double-quote-entry))
- (#\' (fo) (make-entry 'quote-entry))
- (#\` (fo) (make-entry 'backquote-entry))
- (#\, (fo) (make-entry 'unquote-entry))
- (#\# (fo)
- (loop until (end-of-buffer-p scan)
- while (member (object-after scan)
- '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
- do (fo))
- (if (end-of-buffer-p scan)
- (make-entry 'error-entry)
- (case (object-after scan)
- (#\# (fo) (make-entry 'label-ref-entry))
- (#\= (fo) (make-entry 'label-entry))
- (#\' (fo) (make-entry 'function-entry))
- (#\| (fo) (make-entry 'balanced-comment-entry))
- (#\+ (fo) (make-entry 'read-time-conditional-plus-entry))
- (#\- (fo) (make-entry 'read-time-conditional-minus-entry))
- (#\( (fo) (make-entry 'vector-entry))
- (#\* (fo) (make-entry 'bitvector-entry))
- (#\: (fo) (make-entry 'uninterned-symbol-entry))
- (#\. (fo) (make-entry 'read-time-evaluation-entry))
- ((#\A #\a) (fo) (make-entry 'array-entry))
- ((#\B #\b) (fo) (make-entry 'binary-entry))
- ((#\C #\c) (fo) (make-entry 'complex-entry))
- ((#\O #\o) (fo) (make-entry 'octal-entry))
- ((#\P #\p) (fo) (make-entry 'pathname-entry))
- ((#\R #\r) (fo) (make-entry 'radix-n-entry))
- ((#\S #\s) (fo) (make-entry 'structure-entry))
- ((#\X #\x) (fo) (make-entry 'hex-entry))
- (#\\ (fo)
- (cond ((end-of-buffer-p scan)
- (make-entry 'error-entry))
- ((not (constituentp (object-after scan)))
- (fo)
- (make-entry 'character-entry))
- (t
- (fo)
- (loop until (end-of-buffer-p scan)
- while (constituentp (object-after scan))
- do (fo))
- (make-entry 'character-entry))))
- (t (make-entry 'error-entry)))))
- (t (cond ((constituentp object)
- (loop until (end-of-buffer-p scan)
- while (constituentp (object-after scan))
- do (fo))
- (make-entry 'token-entry))
- (t
- (fo) (make-entry 'error-entry))))))))))
+ (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))
+ (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))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; update syntax
+
+
+(defmethod update-syntax-for-display (buffer (syntax cl-syntax) top bot)
+ (with-slots (parser lexer valid-parse) syntax
+ (loop until (= valid-parse (nb-lexemes lexer))
+ 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))))
+ (incf valid-parse))))
+
+(defmethod inter-lexeme-object-p ((lexer cl-lexer) object)
+ (whitespacep object))
(defmethod update-syntax (buffer (syntax cl-syntax))
- (let ((low-mark (low-mark buffer))
- (high-mark (high-mark buffer))
- (scan))
- (with-slots (elements guess-pos) syntax
+ (with-slots (lexer valid-parse) syntax
+ (let* ((low-mark (low-mark buffer))
+ (high-mark (high-mark buffer)))
(when (mark<= low-mark high-mark)
- ;; go back to a position before low-mark
- (loop until (or (= guess-pos 1)
- (mark< (end-offset (element* elements (1- guess-pos))) low-mark))
- do (decf guess-pos))
- ;; go forward to the last position before low-mark
- (loop with nb-elements = (nb-elements elements)
- until (or (= guess-pos nb-elements)
- (mark>= (end-offset (element* elements guess-pos)) low-mark))
- do (incf guess-pos))
- ;; delete entries that must be reparsed
- (loop until (or (= guess-pos (nb-elements elements))
- (mark> (start-mark (element* elements guess-pos)) high-mark))
- do (delete* elements guess-pos))
- (let ((m (clone-mark (low-mark buffer) :left)))
- (setf (offset m)
- (if (zerop guess-pos)
- 0
- (end-offset (element* elements (1- guess-pos)))))
- (setf scan m))
- ;; scan
- (loop with start-mark = nil
- do (loop until (end-of-buffer-p scan)
- while (whitespacep (object-after scan))
- do (forward-object scan))
- until (if (end-of-buffer-p high-mark)
- (end-of-buffer-p scan)
- (mark> scan high-mark))
- do (setf start-mark (clone-mark scan))
- (insert* elements guess-pos (next-entry scan))
- (incf guess-pos))))))
+ (let ((first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark)))
+ (setf valid-parse first-invalid-position)
+ (update-lex lexer first-invalid-position high-mark))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; display
+
+(defvar *white-space-start* nil)
+
+(defvar *cursor-positions* nil)
+(defvar *current-line* 0)
+
+(defun handle-whitespace (pane buffer start end)
+ (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))))
+ (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))))
+
+(defmethod display-parse-tree ((entity cl-entry) (syntax cl-syntax) pane)
+ (flet ((cache-test (t1 t2)
+ (and (eq t1 t2)
+ (eq (slot-value t1 'ink)
+ (medium-ink (sheet-medium pane)))
+ (eq (slot-value t1 'face)
+ (text-style-face (medium-text-style (sheet-medium pane)))))))
+ (updating-output (pane :unique-id entity
+ :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)))))
+
+(defmethod display-parse-tree :before ((entity cl-entry) (syntax cl-syntax) pane)
+ (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
+ (setf *white-space-start* (end-offset entity)))
+
+(defgeneric display-parse-stack (symbol stack syntax pane))
+
+(defmethod display-parse-stack (symbol stack (syntax cl-syntax) pane)
+ (let ((next (parse-stack-next stack)))
+ (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))))
+
+(defun display-parse-state (state syntax pane)
+ (let ((top (parse-stack-top state)))
+ (if (not (null top))
+ (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)))
+ *current-line* 0
+ (aref *cursor-positions* 0) (stream-cursor-position pane))
+ (with-slots (lexer) syntax
+ (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
+ 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
+ (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))))
+ 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* ((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)))))
+ (cursor-column (column-number (point pane)))
+ (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
+ (updating-output (pane :unique-id -1)
+ (draw-rectangle* pane
+ (1- cursor-x) (- cursor-y (* 0.2 height))
+ (+ cursor-x 2) (+ cursor-y (* 0.8 height))
+ :ink (if current-p +red+ +blue+))))))
+
+
+
1
0

17 Apr '05
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv23440
Modified Files:
prolog-syntax.lisp
Log Message:
Deal with #\Tabs a bit better.
* although ISO doesn't mandate it, treat a Tab as whitespace, because
let's face it, it's pretty useless not to;
* deal with #\Tab also in lexemes (necessary whether or not Tab is whitespace
in Prolog syntax, where lexemes can contain whitespace characters);
Highlight "" char-code-lists in green
Date: Sun Apr 17 17:44:40 2005
Author: crhodes
Index: climacs/prolog-syntax.lisp
diff -u climacs/prolog-syntax.lisp:1.16 climacs/prolog-syntax.lisp:1.17
--- climacs/prolog-syntax.lisp:1.16 Tue Apr 12 23:48:19 2005
+++ climacs/prolog-syntax.lisp Sun Apr 17 17:44:39 2005
@@ -177,7 +177,7 @@
((eql object #\") (fo) (go CHAR-CODE-LIST))
((eql object #\()
(if (or (beginning-of-buffer-p scan)
- (not (member (object-before scan) '(#\Space #\Newline))))
+ (not (member (object-before scan) '(#\Space #\Tab #\Newline))))
(progn (fo) (return (make-instance 'open-ct-lexeme)))
(progn (fo) (return (make-instance 'open-lexeme)))))
((eql object #\)) (fo) (return (make-instance 'close-lexeme)))
@@ -277,7 +277,8 @@
do (fo))
(if (end-of-buffer-p scan)
(return (make-instance 'error-lexeme))
- (return (make-instance 'char-code-list-lexeme)))))))))
+ (progn (fo)
+ (return (make-instance 'char-code-list-lexeme))))))))))
;;; parser
@@ -438,6 +439,10 @@
(display-parse-tree ({ entity) syntax pane)
(display-parse-tree (term entity) syntax pane)
(display-parse-tree (} entity) syntax pane))
+(defmethod display-parse-tree
+ ((entity char-code-list-compound-term) (syntax prolog-syntax) pane)
+ (with-drawing-options (pane :ink (make-rgb-color 0.0 0.6 0.0))
+ (display-parse-tree (ccl entity) syntax pane)))
(defclass atom (prolog-nonterminal)
((value :initarg :value :accessor value)))
@@ -902,7 +907,7 @@
(incf valid-parse))))))
(defmethod inter-lexeme-object-p ((lexer prolog-lexer) object)
- (member object '(#\Space #\Newline)))
+ (member object '(#\Space #\Newline #\Tab)))
(defmethod update-syntax (buffer (syntax prolog-syntax))
(with-slots (lexer valid-parse) syntax
@@ -983,8 +988,9 @@
(loop
(when (>= start end)
(return))
- (let ((nl (position #\Newline string
- :start start :end end)))
+ (let ((nl (position-if
+ (lambda (x) (member x '(#\Tab #\Newline)))
+ string :start start :end end)))
(unless nl
(present (subseq string start end) 'string :stream pane)
(return))
@@ -1055,7 +1061,11 @@
(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)))))
- (cursor-column (column-number (point pane)))
+ (cursor-column
+ ;; FIXME: surely this should be more abstracted?
+ (buffer-display-column
+ (buffer (point pane)) (offset (point pane))
+ (round (tab-width pane) (space-width pane))))
(cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
(updating-output (pane :unique-id -1)
(draw-rectangle* pane
1
0
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv8984
Modified Files:
syntax.lisp
Log Message:
More performance improvements. The most common case of adding an item
to a parser state was during prediction when an item was derived from
a rule. We now use a bitvector in each state that indicates what
rules have been used in prediction. This avoids scanning the items in
the state for existing item-equal states.
Date: Sat Apr 16 07:20:29 2005
Author: rstrandh
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.46 climacs/syntax.lisp:1.47
--- climacs/syntax.lisp:1.46 Fri Apr 15 08:12:27 2005
+++ climacs/syntax.lisp Sat Apr 16 07:20:29 2005
@@ -204,11 +204,13 @@
(defclass rule ()
((left-hand-side :initarg :left-hand-side :reader left-hand-side)
(right-hand-side :initarg :right-hand-side :reader right-hand-side)
- (symbols :initarg :symbols :reader symbols)))
+ (symbols :initarg :symbols :reader symbols)
+ (number)))
(defclass grammar ()
((rules :initform nil :accessor rules)
- (hash :initform (make-hash-table) :accessor hash)))
+ (hash :initform (make-hash-table) :accessor hash)
+ (number-of-rules :initform 0)))
(defmacro grammar-rule ((left-hand-side arrow arglist &body body))
(declare (ignore arrow))
@@ -259,6 +261,8 @@
(defmethod add-rule (rule (grammar grammar))
(push rule (rules grammar))
+ (setf (slot-value rule 'number) (slot-value grammar 'number-of-rules))
+ (incf (slot-value grammar 'number-of-rules))
(clrhash (hash grammar))
(let (rhs-symbols)
(dolist (rule (rules grammar))
@@ -348,7 +352,17 @@
:reader incomplete-items)
(parse-trees :initform (make-hash-table :test #'eq)
:reader parse-trees)
- (last-nonempty-state :initarg :last-nonempty-state :accessor last-nonempty-state)))
+ (last-nonempty-state :initarg :last-nonempty-state :accessor last-nonempty-state)
+ (predicted-rules)))
+
+(defmethod initialize-instance :after ((state parser-state) &rest args)
+ (declare (ignore args))
+ (with-slots (predicted-rules) state
+ (setf predicted-rules
+ (make-array (slot-value (parser-grammar (parser state))
+ 'number-of-rules)
+ :element-type 'bit
+ :initial-element 0))))
(defun map-over-incomplete-items (state fun)
(maphash (lambda (key incomplete-items)
@@ -385,13 +399,17 @@
(dolist (rule (gethash (aref (symbols (rule item)) (dot-position item))
(hash (parser-grammar (parser to-state)))))
(if (functionp (right-hand-side rule))
- (handle-incomplete-item (make-instance 'incomplete-item
- :orig-state to-state
- :predicted-from item
- :rule rule
- :dot-position 0
- :suffix (right-hand-side rule))
- to-state to-state)
+ (let ((predicted-rules (slot-value to-state 'predicted-rules))
+ (rule-number (slot-value rule 'number)))
+ (when (zerop (aref predicted-rules rule-number))
+ (setf (aref predicted-rules rule-number) 1)
+ (handle-incomplete-item (make-instance 'incomplete-item
+ :orig-state to-state
+ :predicted-from item
+ :rule rule
+ :dot-position 0
+ :suffix (right-hand-side rule))
+ to-state to-state)))
(potentially-handle-parse-tree (right-hand-side rule) to-state to-state)))
(loop for parse-tree in (gethash to-state (parse-trees to-state))
do (derive-and-handle-item item parse-tree to-state to-state)))))
1
0