[climacs-cvs] CVS update: climacs/cl-syntax.lisp
Robert Strandh
rstrandh at common-lisp.net
Mon May 9 14:09:31 UTC 2005
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv13872
Modified Files:
cl-syntax.lisp
Log Message:
Improvements to CL syntax in the form of a patch from Andreas Fuchs.
Date: Mon May 9 16:09:30 2005
Author: rstrandh
Index: climacs/cl-syntax.lisp
diff -u climacs/cl-syntax.lisp:1.12 climacs/cl-syntax.lisp:1.13
--- climacs/cl-syntax.lisp:1.12 Fri Apr 29 22:10:32 2005
+++ climacs/cl-syntax.lisp Mon May 9 16:09:30 2005
@@ -53,6 +53,8 @@
(defclass paren-close (cl-lexeme) ())
(defclass comma (cl-lexeme) ())
(defclass quote-symbol (cl-lexeme) ())
+(defclass colon (cl-lexeme) ())
+(defclass ampersand (cl-lexeme) ())
(defclass double-quote (cl-lexeme) ())
(defclass hex (cl-lexeme) ())
(defclass pipe (cl-lexeme) ())
@@ -78,6 +80,8 @@
(#\, (fo) (make-instance 'comma))
(#\" (fo) (make-instance 'double-quote))
(#\' (fo) (make-instance 'quote-symbol))
+ (#\: (fo) (make-instance 'colon))
+ (#\& (fo) (make-instance 'ampersand))
(#\# (fo) (make-instance 'hex))
(#\| (fo) (make-instance 'pipe))
(#\` (fo) (make-instance 'backquote))
@@ -115,7 +119,7 @@
(defun neutralcharp (var)
(and (characterp var)
(not (member var '(#\( #\) #\, #\" #\' #\# #\| #\` #\@ #\; #\\
- #\/ #\. #\+ #\- #\Newline #\Space #\Tab)
+ #\: #\/ #\Newline #\Space #\Tab)
:test #'char=))))
@@ -783,6 +787,98 @@
(display-parse-tree start syntax pane))
(display-parse-tree item syntax pane)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Qualified symbols
+
+;; XXX: There's a bit of duplication going on here. I'm not sure if
+;; that could be reduced by clever inheritance. But then, it's only
+;; OAOOM.
+
+(defclass qualified-symbol (cl-entry)
+ ((package-name :initarg :package-name)
+ (colon1 :initarg :colon1)
+ (colon2 :initarg :colon2)
+ (symbol-name :initarg :symbol-name)))
+
+(defclass qualified-exported-symbol (cl-entry)
+ ((package-name :initarg :package-name)
+ (colon :initarg :colon)
+ (symbol-name :initarg :symbol-name)))
+
+(add-cl-rule (qualified-symbol -> ((package-name default-item)
+ (colon1 colon (= (end-offset package-name)
+ (start-offset colon1)))
+ (colon2 colon (= (end-offset colon1)
+ (start-offset colon2)))
+ (symbol-name default-item (= (end-offset colon2)
+ (start-offset symbol-name))))
+ :package-name package-name
+ :colon1 colon1
+ :colon2 colon2
+ :symbol-name symbol-name))
+
+(add-cl-rule (qualified-exported-symbol -> ((package-name default-item)
+ (colon colon (= (end-offset package-name)
+ (start-offset colon)))
+ (symbol-name default-item (= (end-offset colon)
+ (start-offset symbol-name))))
+ :package-name package-name
+ :colon colon
+ :symbol-name symbol-name))
+
+(defmethod display-parse-tree ((entity qualified-symbol) (syntax cl-syntax) pane)
+ (with-slots (package-name colon1 colon2 symbol-name) entity
+ (with-drawing-options (pane :text-style (make-text-style :fix :bold nil) :ink +purple+)
+ (display-parse-tree package-name syntax pane)
+ (display-parse-tree colon1 syntax pane)
+ (display-parse-tree colon2 syntax pane))
+ (display-parse-tree symbol-name syntax pane)))
+
+(defmethod display-parse-tree ((entity qualified-exported-symbol) (syntax cl-syntax) pane)
+ (with-slots (package-name colon symbol-name) entity
+ (display-parse-tree package-name syntax pane)
+ (with-drawing-options (pane :ink (make-rgb-color 0.0 0.0 1.0))
+ (display-parse-tree colon syntax pane))
+ (display-parse-tree symbol-name syntax pane)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Keyword symbols
+
+(defclass keyword-symbol (cl-entry)
+ ((start :initarg :start)
+ (item :initarg :item)))
+
+(add-cl-rule (keyword-symbol -> ((start colon)
+ (item identifier))
+ :start start :item item))
+
+(defmethod display-parse-tree ((entity keyword-symbol) (syntax cl-syntax) pane)
+ (with-slots (start item) entity
+ (with-text-face (pane :bold)
+ (display-parse-tree start syntax pane)
+ (display-parse-tree item syntax pane))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Lambda list Keywords
+
+(defclass lambda-list-keyword (cl-entry)
+ ((start :initarg :start)
+ (item :initarg :item)))
+
+(add-cl-rule (lambda-list-keyword -> ((start ampersand)
+ (item default-item (and
+ (= (end-offset start)
+ (start-offset item))
+ (member item
+ '( ;; ordinary LLs
+ "optional" "rest" "key" "aux" "allow-other-keys"
+ ;; macro LLs
+ "body" "whole" "environment")
+ :test #'default-item-is))))
+ :start start :item item))
+
+(defmethod display-parse-tree ((entity lambda-list-keyword) (syntax cl-syntax) pane)
+ (with-slots (start item) entity
+ (with-drawing-options (pane :ink +blue+)
+ (display-parse-tree start syntax pane)
+ (display-parse-tree item syntax pane))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Backquoted expr
@@ -850,6 +946,10 @@
(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 -> (keyword-symbol) :item keyword-symbol))
+(add-cl-rule (cl-terminal -> (lambda-list-keyword) :item lambda-list-keyword))
+(add-cl-rule (cl-terminal -> (qualified-symbol) :item qualified-symbol))
+(add-cl-rule (cl-terminal -> (qualified-exported-symbol) :item qualified-exported-symbol))
(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))
@@ -925,19 +1025,21 @@
(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))))
+ (loop while (and (< start end)
+ (whitespacep (buffer-object buffer start)))
+ 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)))
+ (#\Page nil))
+ (incf start))))
(defmethod display-parse-tree :around ((entity cl-parse-tree) syntax pane)
(with-slots (top bot) pane
More information about the Climacs-cvs
mailing list