climacs-cvs April 2005

climacs-cvs@common-lisp.net

3 participants
36 discussions

[climacs-cvs] CVS update: climacs/prolog-syntax.lisp
by crhodes＠common-lisp.net 04 Apr '05

04 Apr '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32465 Modified Files: prolog-syntax.lisp Log Message: get [] and {} more right. * separate SYNTACTIC-LEXEME from CANONICAL-NAME, which latter is defined also for empty-list and curly-brackets as well as NAMEs and OPs NOTE NOTE NOTE: giving [] and {} canonical names of "[]" and "{}" is in fact wrong, as '[]' and '{}' should not be equal to [] and {}. Date: Mon Apr 4 21:09:49 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.8 climacs/prolog-syntax.lisp:1.9 --- climacs/prolog-syntax.lisp:1.8 Mon Apr 4 17:46:31 2005 +++ climacs/prolog-syntax.lisp Mon Apr 4 21:09:49 2005 @@ -443,14 +443,21 @@ (defclass atom (prolog-nonterminal) ((value :initarg :value :accessor value))) -(defmethod syntactic-lexeme ((thing atom)) - (syntactic-lexeme (value thing))) +(defmethod canonical-name ((thing atom)) + (canonical-name (value thing))) +(defmethod canonical-name ((thing name)) + ;; FIXME: should canonize + (lexeme-string (syntactic-lexeme thing))) (defclass empty-list (prolog-nonterminal) (([ :initarg :[ :accessor [) (] :initarg :] :accessor ]))) +(defmethod canonical-name ((thing empty-list)) + "[]") (defclass curly-brackets (prolog-nonterminal) (({ :initarg :{ :accessor {) (} :initarg :} :accessor }))) +(defmethod canonical-name ((thing curly-brackets)) + "{}") (defmethod display-parse-tree ((entity atom) (syntax prolog-syntax) pane) (display-parse-tree (value entity) syntax pane)) (defmethod display-parse-tree ((entity empty-list) (syntax prolog-syntax) pane) @@ -538,8 +545,8 @@ ((name :initarg :name :accessor name) (priority :initarg :priority :accessor priority) (specifier :initarg :specifier :accessor specifier))) -(defmethod syntactic-lexeme ((thing op)) - (syntactic-lexeme (name thing))) +(defmethod canonical-name ((thing op)) + (canonical-name (name thing))) (defclass prefix-op (op) ()) (defclass binary-op (op) ()) (defclass postfix-op (op) ()) @@ -581,7 +588,7 @@ ;;; 6.2.1.1 (defun term-directive-p (term) (and (compound-term-p term) - (string= (lexeme-string (syntactic-lexeme (functor term))) ":-") + (string= (canonical-name (functor term)) ":-") (= (arity term) 1))) (define-prolog-rule (directive -> (directive-term end)) @@ -601,8 +608,7 @@ ;;; 6.3.1.2 (define-prolog-rule (term -> ((atom - (string= (lexeme-string (syntactic-lexeme atom)) - "-")) + (string= (canonical-name atom) "-")) integer)) ;; FIXME: this doesn't really look right. (make-instance 'constant-term :priority 0 :value (list atom integer))) @@ -715,14 +721,14 @@ (make-instance 'postfix-operator-compound-lterm :priority (priority op) :left term :operator op))) (define-prolog-rule (term -> ((op (eql (specifier op) :fy)) term)) - (when (and (or (not (string= (lexeme-string (syntactic-lexeme op)) "-")) + (when (and (or (not (string= (canonical-name op) "-")) (not (numeric-constant-p term))) (not (typep (first-lexeme term) 'open-ct-lexeme)) (<= (priority term) (priority op))) (make-instance 'prefix-operator-compound-term :right term :operator op :priority (priority op)))) (define-prolog-rule (lterm -> ((op (eql (specifier op) :fx)) term)) - (when (and (or (not (string= (lexeme-string (syntactic-lexeme op)) "-")) + (when (and (or (not (string= (canonical-name op) "-")) (not (numeric-constant-p term))) (not (typep (first-lexeme term) 'open-ct-lexeme)) (< (priority term) (priority op))) @@ -805,7 +811,7 @@ (def 50 :xfx ":")) (defun find-predefined-operator (name specifiers) - (find (lexeme-string (syntactic-lexeme name)) + (find (canonical-name name) (remove-if-not (lambda (x) (member (opspec-specifier x) specifiers)) *predefined-operators*) :key #'opspec-name :test #'string=))

1 0

[climacs-cvs] CVS update: climacs/prolog-syntax.lisp
by crhodes＠common-lisp.net 04 Apr '05

04 Apr '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20949 Modified Files: prolog-syntax.lisp Log Message: Support multiline lexemes. Only tested on comment lexemes, but it does seem to work. Date: Mon Apr 4 17:46:35 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.7 climacs/prolog-syntax.lisp:1.8 --- climacs/prolog-syntax.lisp:1.7 Mon Apr 4 15:39:40 2005 +++ climacs/prolog-syntax.lisp Mon Apr 4 17:46:31 2005 @@ -854,7 +854,7 @@ ;; FIXME: are we allowed to mix DO and UNTIL like this? ;; I doubt it. until (end-of-buffer-p scan) - until (mark< bot (start-offset (lexeme lexer (1- valid-lex)))) + until (mark<= bot (start-offset (lexeme lexer (1- valid-lex)))) ;; FIXME: a further criterion is when scan matches the ;; start-offset of an element in lexemes, at which point ;; we know that the entirety of the rest of the old lex @@ -874,7 +874,9 @@ ;; parse up to the limit of validity imposed by the lexer, or ;; the bottom of the visible area (loop until (= valid-parse valid-lex) - while (mark<= (end-offset (lexeme lexer valid-parse)) bot) + ;; NOTE: this ceases being the same condition as the above + ;; as soon as the FIXME note above is implemented. + until (mark<= bot (start-offset (lexeme lexer (1- valid-parse)))) do (let ((current-token (lexeme lexer (1- valid-parse))) (next-lexeme (lexeme lexer valid-parse))) (setf (slot-value next-lexeme 'state) @@ -948,12 +950,27 @@ #+nil (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)))) + (let ((string (coerce (buffer-sequence (buffer syntax) + (start-offset entity) + (end-offset entity)) + 'string))) + (with-slots (top bot) pane + (let (start end) + (setf start (max 0 (- (offset top) (start-offset entity)))) + (setf end (- (length string) (max 0 (- (end-offset entity) (offset bot))))) + (loop + (when (>= start end) + (return)) + (let ((nl (position #\Newline string + :start start :end end))) + (unless nl + (present (subseq string start end) 'string :stream pane) + (return)) + (present (subseq string start nl) 'string :stream pane) + (handle-whitespace pane (buffer pane) + (+ (start-offset entity) nl) + (+ (start-offset entity) nl 1)) + (setf start (+ nl 1)))))))))) (defmethod display-parse-tree :before ((entity prolog-lexeme) (syntax prolog-syntax) pane) (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))

1 0

[climacs-cvs] CVS update: climacs/prolog-syntax.lisp
by crhodes＠common-lisp.net 04 Apr '05

04 Apr '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv13392 Modified Files: prolog-syntax.lisp Log Message: Whoops. Unsaved change, which logically belongs to the previous commit. (uncomment out :around method on display-parse-tree to prevent display of off-the-screen stuff) Date: Mon Apr 4 15:39:40 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.6 climacs/prolog-syntax.lisp:1.7 --- climacs/prolog-syntax.lisp:1.6 Sun Apr 3 00:13:26 2005 +++ climacs/prolog-syntax.lisp Mon Apr 4 15:39:40 2005 @@ -926,7 +926,6 @@ pane (- tab-width (mod x tab-width)) 0)))) (incf start)))) -#+nil (defmethod display-parse-tree :around ((entity prolog-parse-tree) syntax pane) (with-slots (top bot) pane (when (and (end-offset entity) (mark> (end-offset entity) top)) @@ -1024,3 +1023,17 @@ (1- cursor-x) (- cursor-y (* 0.2 height)) (+ cursor-x 2) (+ cursor-y (* 0.8 height)) :ink (if current-p +red+ +blue+)))))) + +#| +(climacs-gui::define-named-command com-inspect-lex () + (with-slots (lexer) (slot-value (buffer (climacs-gui::current-window)) 'climacs-syntax::syntax) + (let ((*standard-input* *query-io*) + (*standard-output* *query-io*)) + (inspect lexer)))) + +(climacs-gui::define-named-command com-inspect-parse () + (with-slots (parser) (slot-value (buffer (climacs-gui::current-window)) 'climacs-syntax::syntax) + (let ((*standard-input* *query-io*) + (*standard-output* *query-io*)) + (inspect parser)))) +|#

1 0

[climacs-cvs] CVS update: climacs/html-syntax.lisp
by rstrandh＠common-lisp.net 04 Apr '05

04 Apr '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv3782 Modified Files: html-syntax.lisp Log Message: Defined a "string" syntactic entity where the contents are shown in italics. Defined an HREF attribute that takes a string as an argument Fixed the <a> tag to take a list of attributes, just like <html> now does. The only possible attribute for the <a> tag at the moment is HREF. Date: Mon Apr 4 13:49:05 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.21 climacs/html-syntax.lisp:1.22 --- climacs/html-syntax.lisp:1.21 Mon Apr 4 08:20:52 2005 +++ climacs/html-syntax.lisp Mon Apr 4 13:49:05 2005 @@ -149,6 +149,31 @@ (display-parse-tree items syntax pane) (display-parse-tree item syntax pane))))) +;;;;;;;;;;;;;;; string + +(defclass string-lexeme (html-lexeme) ()) + +(add-html-rule (string-lexeme -> ((html-lexeme (not (word-is html-lexeme "\"")))))) + +(defclass html-string (html-token) + ((start :initarg :start) + (lexemes :initarg :lexemes) + (end :initarg :end))) + +(define-list string-lexemes empty-string-lexeme nonempty-string-lexeme string-lexeme) + +(add-html-rule (html-string -> ((start delimiter (word-is start "\"")) + string-lexemes + (end delimiter (word-is end "\""))) + :start start :lexemes string-lexemes :end end)) + +(defmethod display-parse-tree ((entity html-string) (syntax html-syntax) pane) + (with-slots (start lexemes end) entity + (display-parse-tree start syntax pane) + (with-text-face (pane :italic) + (display-parse-tree lexemes syntax pane)) + (display-parse-tree end syntax pane))) + ;;;;;;;;;;;;;;; attributes (defclass html-attribute (html-nonterminal) @@ -195,6 +220,22 @@ (display-parse-tree dir syntax pane))) +;;;;;;;;;;;;;;; href attribute + +(defclass href-attr (html-attribute) + ((href :initarg :href))) + +(add-html-rule (href-attr -> ((name word (word-is name "href")) + (equals delimiter (and (= (end-offset name) (start-offset equals)) + (word-is equals "="))) + (href html-string)) + :name name :equals equals :href href)) + +(defmethod display-parse-tree ((entity href-attr) (syntax html-syntax) pane) + (with-slots (href) entity + (display-parse-tree href syntax pane))) + + ;;;;;;;;;;;;;;; <html>-tag (defclass <html>-attribute (html-nonterminal) @@ -295,36 +336,35 @@ ;;;;;;;;;;;;;;; <a>-tag -(defclass a-tag-item (html-nonterminal) - ((item :initarg :item))) +(defclass <a>-attribute (html-nonterminal) + ((attribute :initarg :attribute))) -(add-html-rule (a-tag-item -> (word) :item word)) -(add-html-rule (a-tag-item -> (delimiter) :item delimiter)) +(add-html-rule (<a>-attribute -> (href-attr) :attribute href-attr)) -(defmethod display-parse-tree ((entity a-tag-item) (syntax html-syntax) pane) - (with-slots (item) entity - (display-parse-tree item syntax pane))) +(defmethod display-parse-tree ((entity <a>-attribute) (syntax html-syntax) pane) + (with-slots (attribute) entity + (display-parse-tree attribute syntax pane))) -(define-list a-tag-items empty-a-tag-items nonempty-a-tag-items a-tag-item) +(define-list <a>-attributes empty-<a>-attributes nonempty-<a>-attributes <a>-attribute) (defclass <a> (html-tag) ((start :initarg :start) (name :initarg :name) - (items :initarg :items) + (attributes :initarg :attributes) (end :initarg :end))) (add-html-rule (<a> -> (tag-start - (word (and (= (end-offset tag-start) (start-offset word)) - (word-is word "a"))) - a-tag-items - tag-end) - :start tag-start :name word :items a-tag-items :end tag-end)) + (word (and (= (end-offset tag-start) (start-offset word)) + (word-is word "a"))) + <a>-attributes + tag-end) + :start tag-start :name word :attributes <a>-attributes :end tag-end)) (defmethod display-parse-tree ((entity <a>) (syntax html-syntax) pane) - (with-slots (start name items end) entity + (with-slots (start name attributes end) entity (display-parse-tree start syntax pane) (display-parse-tree name syntax pane) - (display-parse-tree items syntax pane) + (display-parse-tree attributes syntax pane) (display-parse-tree end syntax pane))) (define-end-tag </a> "a") @@ -340,7 +380,8 @@ (defmethod display-parse-tree ((entity a) (syntax html-syntax) pane) (with-slots (<a> items </a>) entity (display-parse-tree <a> syntax pane) - (display-parse-tree items syntax pane) + (with-text-face (pane :bold) + (display-parse-tree items syntax pane)) (display-parse-tree </a> syntax pane))) ;;;;;;;;;;;;;;; head

1 0

[climacs-cvs] CVS update: climacs/html-syntax.lisp
by rstrandh＠common-lisp.net 04 Apr '05

04 Apr '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17330 Modified Files: html-syntax.lisp Log Message: <html> tag now accepts LANG and DIR attributes. Date: Mon Apr 4 08:20:52 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.20 climacs/html-syntax.lisp:1.21 --- climacs/html-syntax.lisp:1.20 Sun Mar 20 09:25:21 2005 +++ climacs/html-syntax.lisp Mon Apr 4 08:20:52 2005 @@ -82,6 +82,9 @@ (defparameter *html-grammar* (grammar)) +(defmacro add-html-rule (rule) + `(add-rule (grammar-rule ,rule) *html-grammar*)) + (defun word-is (word string) (string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string) string)) @@ -90,30 +93,27 @@ `(progn (defclass ,name (html-tag) ()) - (add-rule (grammar-rule - (,name -> (tag-start - (word (and (= (end-offset tag-start) (start-offset word)) - (word-is word ,string))) - (tag-end (= (end-offset word) (start-offset tag-end)))))) - *html-grammar*))) + (add-html-rule + (,name -> (tag-start + (word (and (= (end-offset tag-start) (start-offset word)) + (word-is word ,string))) + (tag-end (= (end-offset word) (start-offset tag-end)))))))) (defmacro define-end-tag (name string) `(progn (defclass ,name (html-tag) ()) - (add-rule (grammar-rule - (,name -> (tag-start - (slash (= (end-offset tag-start) (start-offset slash))) - (word (and (= (end-offset slash) (start-offset word)) - (word-is word ,string))) - (tag-end (= (end-offset word) (start-offset tag-end)))))) - *html-grammar*))) + (add-html-rule + (,name -> (tag-start + (slash (= (end-offset tag-start) (start-offset slash))) + (word (and (= (end-offset slash) (start-offset word)) + (word-is word ,string))) + (tag-end (= (end-offset word) (start-offset tag-end)))))))) (defmacro define-tag-pair (start-name end-name string) `(progn (define-start-tag ,start-name ,string) (define-end-tag ,end-name ,string))) -(define-tag-pair <html> </html> "html") (define-tag-pair <head> </head> "head") (define-tag-pair <title> </title> "title") (define-tag-pair <body> </body> "body") @@ -133,14 +133,12 @@ ((items :initarg :items) (item :initarg :item))) - (add-rule (grammar-rule (,name -> () - (make-instance ',empty-name))) - *html-grammar*) - - (add-rule (grammar-rule (,name -> (,name ,item-name) - (make-instance ',nonempty-name - :items ,name :item ,item-name))) - *html-grammar*) + (add-html-rule (,name -> () + (make-instance ',empty-name))) + + (add-html-rule (,name -> (,name ,item-name) + (make-instance ',nonempty-name + :items ,name :item ,item-name))) (defmethod display-parse-tree ((entity ,empty-name) (syntax html-syntax) pane) (declare (ignore pane)) @@ -151,13 +149,95 @@ (display-parse-tree items syntax pane) (display-parse-tree item syntax pane))))) +;;;;;;;;;;;;;;; attributes + +(defclass html-attribute (html-nonterminal) + ((name :initarg :name) + (equals :initarg :equals))) + +(defmethod display-parse-tree :before ((entity html-attribute) (syntax html-syntax) pane) + (with-slots (name equals) entity + (display-parse-tree name syntax pane) + (display-parse-tree equals syntax pane))) + +;;;;;;;;;;;;;;; lang attribute + +(defclass lang-attr (html-attribute) + ((lang :initarg :lang))) + +(add-html-rule (lang-attr -> ((name word (word-is name "lang")) + (equals delimiter (and (= (end-offset name) (start-offset equals)) + (word-is equals "="))) + (lang word (and (= (end-offset equals) (start-offset lang)) + (= (- (end-offset lang) (start-offset lang)) + 2)))) + :name name :equals equals :lang lang)) + +(defmethod display-parse-tree ((entity lang-attr) (syntax html-syntax) pane) + (with-slots (lang) entity + (display-parse-tree lang syntax pane))) + +;;;;;;;;;;;;;;; dir attribute + +(defclass dir-attr (html-attribute) + ((dir :initarg :dir))) + +(add-html-rule (dir-attr -> ((name word (word-is name "dir")) + (equals delimiter (and (= (end-offset name) (start-offset equals)) + (word-is equals "="))) + (dir word (and (= (end-offset equals) (start-offset dir)) + (or (word-is dir "rtl") + (word-is dir "ltr"))))) + :name name :equals equals :dir dir)) + +(defmethod display-parse-tree ((entity dir-attr) (syntax html-syntax) pane) + (with-slots (dir) entity + (display-parse-tree dir syntax pane))) + + +;;;;;;;;;;;;;;; <html>-tag + +(defclass <html>-attribute (html-nonterminal) + ((attribute :initarg :attribute))) + +(defmethod display-parse-tree ((entity <html>-attribute) (syntax html-syntax) pane) + (with-slots (attribute) entity + (display-parse-tree attribute syntax pane))) + +(add-html-rule (<html>-attribute -> (lang-attr) :attribute lang-attr)) +(add-html-rule (<html>-attribute -> (dir-attr) :attribute dir-attr)) + +(define-list <html>-attributes empty-<html>-attribute nonempty-<html>-attribute <html>-attribute) + +(defclass <html> (html-tag) + ((start :initarg :start) + (name :initarg :name) + (attributes :initarg :attributes) + (end :initarg :end))) + +(add-html-rule (<html> -> (tag-start + (word (and (= (end-offset tag-start) (start-offset word)) + (word-is word "html"))) + <html>-attributes + tag-end) + :start tag-start :name word :attributes <html>-attributes :end tag-end)) + +(defmethod display-parse-tree ((entity <html>) (syntax html-syntax) pane) + (with-slots (start name attributes end) entity + (display-parse-tree start syntax pane) + (display-parse-tree name syntax pane) + (display-parse-tree attributes syntax pane) + (display-parse-tree end syntax pane))) + +(define-end-tag </html> "html") + ;;;;;;;;;;;;;;; title-item, title-items (defclass title-item (html-nonterminal) ((item :initarg :item))) -(add-rule (grammar-rule (title-item -> (word) :item word)) *html-grammar*) -(add-rule (grammar-rule (title-item -> (delimiter) :item delimiter)) *html-grammar*) +(add-html-rule (title-item -> (word) :item word)) +(add-html-rule (title-item -> (delimiter) :item delimiter)) (defmethod display-parse-tree ((entity title-item) (syntax html-syntax) pane) (with-slots (item) entity @@ -172,9 +252,8 @@ (items :initarg :items) (</title> :initarg :</title>))) -(add-rule (grammar-rule (title -> (<title> title-items </title>) - :<title> <title> :items title-items :</title> </title>)) - *html-grammar*) +(add-html-rule (title -> (<title> title-items </title>) + :<title> <title> :items title-items :</title> </title>)) (defmethod display-parse-tree ((entity title) (syntax html-syntax) pane) (with-slots (<title> items </title>) entity @@ -188,9 +267,9 @@ (defclass body-item (html-nonterminal) ((item :initarg :item))) -(add-rule (grammar-rule (body-item -> (word) :item word)) *html-grammar*) -(add-rule (grammar-rule (body-item -> (delimiter) :item delimiter)) *html-grammar*) -(add-rule (grammar-rule (body-item -> (a) :item a)) *html-grammar*) +(add-html-rule (body-item -> (word) :item word)) +(add-html-rule (body-item -> (delimiter) :item delimiter)) +(add-html-rule (body-item -> (a) :item a)) (defmethod display-parse-tree ((entity body-item) (syntax html-syntax) pane) (with-slots (item) entity @@ -205,9 +284,8 @@ (items :initarg :items) (</body> :initarg :</body>))) -(add-rule (grammar-rule (body -> (<body> body-items </body>) - :<body> <body> :items body-items :</body> </body>)) - *html-grammar*) +(add-html-rule (body -> (<body> body-items </body>) + :<body> <body> :items body-items :</body> </body>)) (defmethod display-parse-tree ((entity body) (syntax html-syntax) pane) (with-slots (<body> items </body>) entity @@ -220,8 +298,8 @@ (defclass a-tag-item (html-nonterminal) ((item :initarg :item))) -(add-rule (grammar-rule (a-tag-item -> (word) :item word)) *html-grammar*) -(add-rule (grammar-rule (a-tag-item -> (delimiter) :item delimiter)) *html-grammar*) +(add-html-rule (a-tag-item -> (word) :item word)) +(add-html-rule (a-tag-item -> (delimiter) :item delimiter)) (defmethod display-parse-tree ((entity a-tag-item) (syntax html-syntax) pane) (with-slots (item) entity @@ -235,13 +313,12 @@ (items :initarg :items) (end :initarg :end))) -(add-rule (grammar-rule (<a> -> (tag-start +(add-html-rule (<a> -> (tag-start (word (and (= (end-offset tag-start) (start-offset word)) (word-is word "a"))) a-tag-items tag-end) - :start tag-start :name word :items a-tag-items :end tag-end)) - *html-grammar*) + :start tag-start :name word :items a-tag-items :end tag-end)) (defmethod display-parse-tree ((entity <a>) (syntax html-syntax) pane) (with-slots (start name items end) entity @@ -257,9 +334,8 @@ (items :initarg :items) (</a> :initarg :</a>))) -(add-rule (grammar-rule (a -> (<a> body-items </a>) - :<a> <a> :items body-items :</a> </a>)) - *html-grammar*) +(add-html-rule (a -> (<a> body-items </a>) + :<a> <a> :items body-items :</a> </a>)) (defmethod display-parse-tree ((entity a) (syntax html-syntax) pane) (with-slots (<a> items </a>) entity @@ -274,9 +350,8 @@ (title :initarg :title) (</head> :initarg :</head>))) -(add-rule (grammar-rule (head -> (<head> title </head>) - :<head> <head> :title title :</head> </head>)) - *html-grammar*) +(add-html-rule (head -> (<head> title </head>) + :<head> <head> :title title :</head> </head>)) (defmethod display-parse-tree ((entity head) (syntax html-syntax) pane) (with-slots (<head> title </head>) entity @@ -292,9 +367,8 @@ (body :initarg :body) (</html> :initarg :</html>))) -(add-rule (grammar-rule (html -> (<html> head body </html>) - :<html> <html> :head head :body body :</html> </html>)) - *html-grammar*) +(add-html-rule (html -> (<html> head body </html>) + :<html> <html> :head head :body body :</html> </html>)) (defmethod display-parse-tree ((entity html) (syntax html-syntax) pane) (with-slots (<html> head body </html>) entity

1 0

[climacs-cvs] CVS update: climacs/prolog-syntax.lisp
by crhodes＠common-lisp.net 03 Apr '05

03 Apr '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8882 Modified Files: prolog-syntax.lisp Log Message: Prolog syntax improvements: * PRINT-OBJECT for PROLOG-LEXEMEs, for less pain while debugging; * OPEN-CT production rule from OPEN-CT-LEXEME, because we can; * rework the lexer a bit. Now UPDATE-SYNTAX just invalidates the lex as it invalidates the parse, and UPDATE-SYNTAX-FOR-DISPLAY relexes as far as it needs to; * we need operator-compound-lterm and subclasses, because we cannot create multiple nonterminals from one rule: returning (make-instance 'lterm :term (make-instance 'foo ...)) from a production rule leaves some slots in the FOO unfilled; * note my own bafflement as to why an apparently infinitely-recursive production doesn't recurse infinitely. It can be fixed when needed, but why isn't it triggering? This version still gets various aspects of multiline lexemes wrong, but it's a lot better than before. Date: Sun Apr 3 00:13:27 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.5 climacs/prolog-syntax.lisp:1.6 --- climacs/prolog-syntax.lisp:1.5 Thu Mar 31 12:16:23 2005 +++ climacs/prolog-syntax.lisp Sun Apr 3 00:13:26 2005 @@ -65,6 +65,9 @@ (defclass prolog-lexeme (prolog-token) ((state :initarg :state))) +(defmethod print-object ((o prolog-lexeme) s) + (print-unreadable-object (o s :type t) + (format s (lexeme-string o)))) (defclass start-lexeme (prolog-lexeme) ()) @@ -127,13 +130,25 @@ (def (error))) +;;; open-ct is a special case: by 6.5.1 it cannot be preceded by +;;; layout text. We could elide this and its grammar rules, but this +;;; way we get a clearer relationship between the standard and its +;;; expression here. +(defclass open-ct (prolog-nonterminal) + ((syntactic-lexeme :initarg :syntactic-lexeme :accessor syntactic-lexeme))) +(defmethod display-parse-tree ((entity open-ct) (syntax prolog-syntax) pane) + (display-parse-tree (syntactic-lexeme entity) syntax pane)) +(define-prolog-rule (open-ct -> (open-ct-lexeme)) + (make-instance 'open-ct :syntactic-lexeme open-ct-lexeme)) + ;;; 6.4.1 (define-prolog-rule (layout-text -> (comment-lexeme layout-text)) (make-instance 'layout-text :comment comment-lexeme :cont layout-text)) (define-prolog-rule (layout-text -> ()) (make-instance 'layout-text :cont nil)) -(defclass prolog-lexer (incremental-lexer) ()) +(defclass prolog-lexer (incremental-lexer) + ((valid-lex :initarg :valid-lex :accessor valid-lex :initform 1))) (defmethod next-lexeme ((lexer prolog-lexer) scan) (let ((string (make-array 0 :element-type 'character @@ -180,10 +195,10 @@ (t (fo) (return (make-instance 'error-lexeme)))) IDENTIFIER (loop until (end-of-buffer-p scan) - while (let ((object (object-after scan))) - (or (alphanumericp object) - (eql object #\_))) - do (fo)) + while (let ((object (object-after scan))) + (or (alphanumericp object) + (eql object #\_))) + do (fo)) (return (make-instance 'identifier-lexeme)) LINE-COMMENT (loop until (end-of-buffer-p scan) @@ -429,7 +444,6 @@ (defclass atom (prolog-nonterminal) ((value :initarg :value :accessor value))) (defmethod syntactic-lexeme ((thing atom)) - ;; FIXME: wrong for empty-list atom and curly-brackets atom (syntactic-lexeme (value thing))) (defclass empty-list (prolog-nonterminal) (([ :initarg :[ :accessor [) @@ -484,6 +498,42 @@ (defmethod display-parse-tree ((entity lterm) (syntax prolog-syntax) pane) (display-parse-tree (term entity) syntax pane)) +;;; FIXME: the need for these is because it is a protocol violation to +;;; create nested nonterminals from one rule. +(defclass operator-compound-lterm (lterm) + ((operator :initarg :operator :accessor operator))) +(defmethod compound-term-p ((l operator-compound-lterm)) + t) +(defmethod functor ((l operator-compound-lterm)) + (operator l)) +(defclass binary-operator-compound-lterm (operator-compound-lterm) + ((left :initarg :left :accessor left) + (right :initarg :right :accessor right))) +(defmethod arity ((l binary-operator-compound-lterm)) + 2) +(defclass prefix-operator-compound-lterm (operator-compound-lterm) + ((right :initarg :right :accessor right))) +(defmethod arity ((l prefix-operator-compound-lterm)) + 1) +(defclass postfix-operator-compound-lterm (operator-compound-lterm) + ((left :initarg :left :accessor left))) +(defmethod arity ((l postfix-operator-compound-lterm)) + 1) + +(defmethod display-parse-tree + ((entity binary-operator-compound-lterm) (syntax prolog-syntax) pane) + (display-parse-tree (left entity) syntax pane) + (display-parse-tree (operator entity) syntax pane) + (display-parse-tree (right entity) syntax pane)) +(defmethod display-parse-tree + ((entity prefix-operator-compound-lterm) (syntax prolog-syntax) pane) + (display-parse-tree (operator entity) syntax pane) + (display-parse-tree (right entity) syntax pane)) +(defmethod display-parse-tree + ((entity postfix-operator-compound-lterm) (syntax prolog-syntax) pane) + (display-parse-tree (left entity) syntax pane) + (display-parse-tree (operator entity) syntax pane)) + (defclass op (prolog-nonterminal) ((name :initarg :name :accessor name) (priority :initarg :priority :accessor priority) @@ -579,9 +629,9 @@ (make-instance 'variable-term :priority 0 :name variable)) ;;; 6.3.3 -(define-prolog-rule (term -> (atom open-ct-lexeme arg-list close)) +(define-prolog-rule (term -> (atom open-ct arg-list close)) (make-instance 'functional-compound-term :priority 0 :functor atom - :arg-list arg-list :open-ct open-ct-lexeme :close close)) + :arg-list arg-list :open-ct open-ct :close close)) (define-prolog-rule (arg-list -> (exp)) (make-instance 'arg-list :exp exp)) (define-prolog-rule (arg-list -> (exp comma arg-list)) @@ -613,17 +663,21 @@ ;;; term would be, by explicitly writing the second production rule ;;; out here, and by using inegality tests rather than equalities for ;;; priorities elsewhere. LTERMs act as containers for terms. +;;; +;;; FIXME: why on earth doesn't this cause infinite recursion? If +;;; LTERM is a subtype of TERM, as it is, this rule should surely be +;;; always applicable. (define-prolog-rule (lterm -> (term)) (make-instance 'lterm :term term :priority (1+ (priority term)))) (define-prolog-rule (term -> (open (term (<= (priority term) 1201)) close)) (make-instance 'bracketed-term :priority 0 :open open :term term :close close)) -(define-prolog-rule (term -> (open-ct-lexeme +(define-prolog-rule (term -> (open-ct (term (<= (priority term) 1201)) close)) (make-instance 'bracketed-term :priority 0 - :open open-ct-lexeme :term term :close close)) + :open open-ct :term term :close close)) ;;; 6.3.4.2 ;;; @@ -636,17 +690,15 @@ (right term))) (when (and (< (priority left) (priority op)) (< (priority right) (priority op))) - (make-instance 'lterm :priority (priority op) :term - (make-instance 'binary-operator-compound-term - :left left :operator op :right right)))) + (make-instance 'binary-operator-compound-lterm :priority (priority op) + :left left :operator op :right right))) (define-prolog-rule (lterm -> ((left lterm) (op (eql (specifier op) :yfx)) (right term))) (when (and (<= (priority left) (priority op)) (< (priority right) (priority op))) - (make-instance 'lterm :priority (priority op) :term - (make-instance 'binary-operator-compound-term - :left left :operator op :right right)))) + (make-instance 'binary-operator-compound-lterm :priority (priority op) + :left left :operator op :right right))) (define-prolog-rule (term -> ((left term) (op (eql (specifier op) :xfy)) (right term))) @@ -656,14 +708,12 @@ :left left :operator op :right right))) (define-prolog-rule (lterm -> (lterm (op (eql (specifier op) :yf)))) (when (<= (priority lterm) (priority op)) - (make-instance 'lterm :priority (priority op) :term - (make-instance 'postfix-operator-compound-term - :left lterm :operator op)))) + (make-instance 'postfix-operator-compound-lterm :priority (priority op) + :left lterm :operator op))) (define-prolog-rule (lterm -> (term (op (eql (specifier op) :xf)))) (when (< (priority term) (priority op)) - (make-instance 'lterm :priority (priority op) :term - (make-instance 'postfix-operator-compound-term - :left term :operator op)))) + (make-instance 'postfix-operator-compound-lterm :priority (priority op) + :left term :operator op))) (define-prolog-rule (term -> ((op (eql (specifier op) :fy)) term)) (when (and (or (not (string= (lexeme-string (syntactic-lexeme op)) "-")) (not (numeric-constant-p term))) @@ -676,9 +726,8 @@ (not (numeric-constant-p term))) (not (typep (first-lexeme term) 'open-ct-lexeme)) (< (priority term) (priority op))) - (make-instance 'lterm :priority (priority op) :term - (make-instance 'prefix-operator-compound-term - :right term :operator op)))) + (make-instance 'prefix-operator-compound-lterm :priority (priority op) + :right term :operator op))) ;;; 6.3.4.3 (macrolet ((def (class &rest specifiers) @@ -782,7 +831,7 @@ (and (consp value) (typep (car value) 'atom) (typep (cadr value) 'integer)))))) - + (defun first-lexeme (thing) ;; FIXME: we'll need to implement this. (declare (ignore thing)) @@ -792,25 +841,66 @@ (defmethod update-syntax-for-display (buffer (syntax prolog-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)))) + (with-slots (climacs-syntax::lexemes valid-lex) lexer + (let ((scan (clone-mark (low-mark buffer) :left))) + (setf (offset scan) + (end-offset (lexeme lexer (1- valid-lex)))) + ;; lex as far as we need. We actually win quite a lot if we + ;; can implement the splicing described in the FIXME note, + ;; below, because there's then a good chance that CLIM's + ;; incremental redisplay will Do The Right Thing (on the EQ + ;; lexemes) + (loop do (skip-inter-lexeme-objects lexer scan) + ;; FIXME: are we allowed to mix DO and UNTIL like this? + ;; I doubt it. + until (end-of-buffer-p scan) + until (mark< bot (start-offset (lexeme lexer (1- valid-lex)))) + ;; FIXME: a further criterion is when scan matches the + ;; start-offset of an element in lexemes, at which point + ;; we know that the entirety of the rest of the old lex + ;; is valid without doing any further work. + do (let* ((start-mark (clone-mark scan)) + (lexeme (next-lexeme lexer scan)) + (size (- (offset scan) (offset start-mark)))) + (setf (slot-value lexeme 'climacs-syntax::start-mark) start-mark + (slot-value lexeme 'climacs-syntax::size) size) + (insert-lexeme lexer valid-lex lexeme) + (incf valid-lex))) + ;; remove lexemes which we know to be invalid + (let ((end (end-offset (lexeme lexer (1- valid-lex))))) + (loop until (= (nb-lexemes lexer) valid-lex) + while (< (start-offset (lexeme lexer valid-lex)) end) + do (delete* climacs-syntax::lexemes valid-lex)))) + ;; parse up to the limit of validity imposed by the lexer, or + ;; the bottom of the visible area + (loop until (= valid-parse valid-lex) + 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 prolog-lexer) object) (member object '(#\Space #\Newline))) (defmethod update-syntax (buffer (syntax prolog-syntax)) (with-slots (lexer valid-parse) syntax - (let* ((low-mark (low-mark buffer)) - (high-mark (high-mark buffer))) - (when (mark<= low-mark high-mark) - (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)))))) + (let* ((low-mark (low-mark buffer)) + (high-mark (high-mark buffer))) + (when (mark<= low-mark high-mark) + (with-slots (climacs-syntax::lexemes valid-lex) lexer + (let ((start 1) + (end (nb-elements climacs-syntax::lexemes))) + (loop while (< start end) + do (let ((middle (floor (+ start end) 2))) + (if (mark< (end-offset (element* climacs-syntax::lexemes middle)) + low-mark) + (setf start (1+ middle)) + (setf end middle)))) + (setf valid-lex start) + (setf valid-parse start))))))) ;;; display @@ -866,10 +956,7 @@ 'string :stream pane)))) -;;; KLUDGE: below this line, this is just s/html/prolog/ on the -;;; definitions in html-syntax.lisp - -(defmethod display-parse-tree :before ((entity prolog-token) (syntax prolog-syntax) pane) +(defmethod display-parse-tree :before ((entity prolog-lexeme) (syntax prolog-syntax) pane) (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity)) (setf *white-space-start* (end-offset entity))) @@ -888,13 +975,16 @@ (display-parse-stack (parse-stack-symbol top) top syntax pane) (display-parse-tree (target-parse-tree state) syntax pane)))) +(defun nb-valid-lexemes (lexer) + (slot-value lexer 'valid-lex)) + (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax prolog-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))) + (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-valid-lexemes lexer))) 1.0))) ;; find the last token before bot (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1))) @@ -902,7 +992,7 @@ (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)) + (loop until (or (= end-token-index (nb-valid-lexemes lexer)) (mark> (start-offset (lexeme lexer end-token-index)) bot)) do (incf end-token-index)) (let ((start-token-index end-token-index))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

climacs-cvs April 2005