[climacs-cvs] CVS update: climacs/cl-syntax.lisp
Pascal Fong Kye
pfong at common-lisp.net
Wed Apr 20 15:39:16 UTC 2005
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 at labri.fr)
-
+;;; Nada Ayad (nada.ayad at etu.u-bordeaux1.fr)
+;;; Julien Cazaban (bizounorc at hotmail.com)
+;;; Pascal Fong Kye (pfongkye at yahoo.com)
+;;; Bruno Mery (mery at 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+))))))
+
+
+
More information about the Climacs-cvs
mailing list