[climacs-cvs] CVS update: climacs/cl-syntax.lisp
Pascal Fong Kye
pfong at common-lisp.net
Sat Apr 23 11:40:14 UTC 2005
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))
More information about the Climacs-cvs
mailing list