From crhodes at common-lisp.net Sat Apr 2 22:13:43 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Sun, 3 Apr 2005 00:13:43 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp Message-ID: <20050402221343.7E9DE88665@common-lisp.net> 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)) From rstrandh at common-lisp.net Mon Apr 4 06:20:53 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 4 Apr 2005 08:20:53 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp Message-ID: <20050404062053.5363988704@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17330 Modified Files: html-syntax.lisp Log Message: 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") (define-tag-pair "head") (define-tag-pair "title") (define-tag-pair "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))) + + +;;;;;;;;;;;;;;; -tag + +(defclass -attribute (html-nonterminal) + ((attribute :initarg :attribute))) + +(defmethod display-parse-tree ((entity -attribute) (syntax html-syntax) pane) + (with-slots (attribute) entity + (display-parse-tree attribute syntax pane))) + +(add-html-rule (-attribute -> (lang-attr) :attribute lang-attr)) +(add-html-rule (-attribute -> (dir-attr) :attribute dir-attr)) + +(define-list -attributes empty--attribute nonempty--attribute -attribute) + +(defclass (html-tag) + ((start :initarg :start) + (name :initarg :name) + (attributes :initarg :attributes) + (end :initarg :end))) + +(add-html-rule ( -> (tag-start + (word (and (= (end-offset tag-start) (start-offset word)) + (word-is word "html"))) + -attributes + tag-end) + :start tag-start :name word :attributes -attributes :end tag-end)) + +(defmethod display-parse-tree ((entity ) (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") + ;;;;;;;;;;;;;;; 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) ( :initarg :))) -(add-rule (grammar-rule (title -> ( title-items ) - : <title> :items title-items : )) - *html-grammar*) +(add-html-rule (title -> ( title-items ) + : <title> :items title-items : )) (defmethod display-parse-tree ((entity title) (syntax html-syntax) pane) (with-slots ( items ) 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) ( :initarg :))) -(add-rule (grammar-rule (body -> ( body-items ) - : :items body-items : )) - *html-grammar*) +(add-html-rule (body -> ( body-items ) + : :items body-items : )) (defmethod display-parse-tree ((entity body) (syntax html-syntax) pane) (with-slots ( items ) 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 ( -> (tag-start +(add-html-rule ( -> (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 ) (syntax html-syntax) pane) (with-slots (start name items end) entity @@ -257,9 +334,8 @@ (items :initarg :items) ( :initarg :))) -(add-rule (grammar-rule (a -> ( body-items ) - : :items body-items : )) - *html-grammar*) +(add-html-rule (a -> ( body-items ) + : :items body-items : )) (defmethod display-parse-tree ((entity a) (syntax html-syntax) pane) (with-slots ( items ) entity @@ -274,9 +350,8 @@ (title :initarg :title) ( :initarg :))) -(add-rule (grammar-rule (head -> ( title ) - : :title title : )) - *html-grammar*) +(add-html-rule (head -> ( title ) + : :title title : )) (defmethod display-parse-tree ((entity head) (syntax html-syntax) pane) (with-slots ( title ) entity @@ -292,9 +367,8 @@ (body :initarg :body) ( :initarg :))) -(add-rule (grammar-rule (html -> ( head body ) - : :head head :body body : )) - *html-grammar*) +(add-html-rule (html -> ( head body ) + : :head head :body body : )) (defmethod display-parse-tree ((entity html) (syntax html-syntax) pane) (with-slots ( head body ) entity From rstrandh at common-lisp.net Mon Apr 4 11:49:06 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 4 Apr 2005 13:49:06 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp Message-ID: <20050404114906.558D6884E2@common-lisp.net> 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 tag to take a list of attributes, just like now does. The only possible attribute for the 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))) + + ;;;;;;;;;;;;;;; -tag (defclass -attribute (html-nonterminal) @@ -295,36 +336,35 @@ ;;;;;;;;;;;;;;; -tag -(defclass a-tag-item (html-nonterminal) - ((item :initarg :item))) +(defclass -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 (-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 -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 -attributes empty--attributes nonempty--attributes -attribute) (defclass (html-tag) ((start :initarg :start) (name :initarg :name) - (items :initarg :items) + (attributes :initarg :attributes) (end :initarg :end))) (add-html-rule ( -> (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"))) + -attributes + tag-end) + :start tag-start :name word :attributes -attributes :end tag-end)) (defmethod display-parse-tree ((entity ) (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") @@ -340,7 +380,8 @@ (defmethod display-parse-tree ((entity a) (syntax html-syntax) pane) (with-slots ( items ) entity (display-parse-tree syntax pane) - (display-parse-tree items syntax pane) + (with-text-face (pane :bold) + (display-parse-tree items syntax pane)) (display-parse-tree syntax pane))) ;;;;;;;;;;;;;;; head From crhodes at common-lisp.net Mon Apr 4 13:39:41 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 4 Apr 2005 15:39:41 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp Message-ID: <20050404133941.35C27884E2@common-lisp.net> 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)))) +|# From crhodes at common-lisp.net Mon Apr 4 15:46:35 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 4 Apr 2005 17:46:35 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp Message-ID: <20050404154635.25C35884E2@common-lisp.net> 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)) From crhodes at common-lisp.net Mon Apr 4 19:09:50 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 4 Apr 2005 21:09:50 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp Message-ID: <20050404190950.21DD2880E1@common-lisp.net> 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=)) From crhodes at common-lisp.net Mon Apr 4 21:00:57 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 4 Apr 2005 23:00:57 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp Message-ID: <20050404210057.192FC880E1@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6433 Modified Files: prolog-syntax.lisp Log Message: Just comment fixups Date: Mon Apr 4 23:00:45 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.9 climacs/prolog-syntax.lisp:1.10 --- climacs/prolog-syntax.lisp:1.9 Mon Apr 4 21:09:49 2005 +++ climacs/prolog-syntax.lisp Mon Apr 4 23:00:42 2005 @@ -452,11 +452,13 @@ (([ :initarg :[ :accessor [) (] :initarg :] :accessor ]))) (defmethod canonical-name ((thing empty-list)) + ;; FIXME: this clashes with the canonical name for the atom '[]' "[]") (defclass curly-brackets (prolog-nonterminal) (({ :initarg :{ :accessor {) (} :initarg :} :accessor }))) (defmethod canonical-name ((thing curly-brackets)) + ;; FIXME: see comment in CANONICAL-NAME (EMPTY-LIST) "{}") (defmethod display-parse-tree ((entity atom) (syntax prolog-syntax) pane) (display-parse-tree (value entity) syntax pane)) @@ -857,8 +859,6 @@ ;; 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 From crhodes at common-lisp.net Tue Apr 5 20:28:30 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Tue, 5 Apr 2005 22:28:30 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp Message-ID: <20050405202830.95D5C8866B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv24772 Modified Files: prolog-syntax.lisp Log Message: Enable incremental-redisplay / updating-output This isn't as big a win as it could be, because of the invalidation of lexemes without attempting to splice in the results of a previous lex. (see FIXME comments in update-syntax-for-redisplay) Date: Tue Apr 5 22:28:30 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.10 climacs/prolog-syntax.lisp:1.11 --- climacs/prolog-syntax.lisp:1.10 Mon Apr 4 23:00:42 2005 +++ climacs/prolog-syntax.lisp Tue Apr 5 22:28:29 2005 @@ -56,7 +56,7 @@ ()) (defclass prolog-token (prolog-parse-tree) - ()) + ((ink) (face))) (defclass prolog-operator (prolog-token) ()) @@ -942,18 +942,15 @@ (defmethod display-parse-tree ((entity prolog-token) (syntax prolog-syntax) pane) (flet ((cache-test (t1 t2) (and (eq t1 t2) - #+nil (eq (slot-value t1 'ink) (medium-ink (sheet-medium pane))) - #+nil (eq (slot-value t1 'face) (text-style-face (medium-text-style (sheet-medium pane))))))) -#| (updating-output (pane :unique-id entity + (updating-output (pane :unique-id entity :id-test #'eq :cache-value entity - :cache-test #'cache-test)|# - (with-slots (#|ink face|#) entity - #+nil + :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)))) (let ((string (coerce (buffer-sequence (buffer syntax) @@ -976,7 +973,7 @@ (handle-whitespace pane (buffer pane) (+ (start-offset entity) nl) (+ (start-offset entity) nl 1)) - (setf start (+ 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)) From rstrandh at common-lisp.net Wed Apr 6 05:31:54 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 6 Apr 2005 07:31:54 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/pane.lisp Message-ID: <20050406053154.CEB0388665@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv25110 Modified Files: pane.lisp Log Message: Fixed the redisplay bug reported by Christophe Rhodes. Date: Wed Apr 6 07:31:54 2005 Author: rstrandh Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.23 climacs/pane.lisp:1.24 --- climacs/pane.lisp:1.23 Sat Mar 19 23:08:31 2005 +++ climacs/pane.lisp Wed Apr 6 07:31:53 2005 @@ -361,6 +361,7 @@ (let ((nb-lines-in-pane (nb-lines-in-pane pane))) (with-slots (top bot cache) pane (setf (offset bot) (offset top)) + (end-of-line bot) (loop until (end-of-buffer-p bot) repeat (1- nb-lines-in-pane) do (forward-object bot) @@ -392,8 +393,8 @@ ;;; Make the cache reflect the contents of the buffer starting at top, ;;; trying to preserve contents as much as possible, and inserting a ;;; nil entry where buffer contents is unknonwn. The size of the -;;; cache size at the end may be smaller than, equal to, or greater -;;; than the number of lines in the pane. +;;; cache at the end may be smaller than, equal to, or greater than +;;; the number of lines in the pane. (defun adjust-cache (pane) (let* ((buffer (buffer pane)) (high-mark (high-mark buffer)) From crhodes at common-lisp.net Wed Apr 6 09:30:20 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Wed, 6 Apr 2005 11:30:20 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp Message-ID: <20050406093020.0962D18C6CB@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5794 Modified Files: prolog-syntax.lisp Log Message: implement CANONICAL-NAME for commas (fixes crash on "1,2") Date: Wed Apr 6 11:30:19 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.11 climacs/prolog-syntax.lisp:1.12 --- climacs/prolog-syntax.lisp:1.11 Tue Apr 5 22:28:29 2005 +++ climacs/prolog-syntax.lisp Wed Apr 6 11:30:19 2005 @@ -448,6 +448,8 @@ (defmethod canonical-name ((thing name)) ;; FIXME: should canonize (lexeme-string (syntactic-lexeme thing))) +(defmethod canonical-name ((thing comma)) + ",") (defclass empty-list (prolog-nonterminal) (([ :initarg :[ :accessor [) (] :initarg :] :accessor ]))) From crhodes at common-lisp.net Wed Apr 6 11:54:27 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Wed, 6 Apr 2005 13:54:27 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp Message-ID: <20050406115427.E3ABA880E1@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14737 Modified Files: prolog-syntax.lisp Log Message: Implement incremental lexing. The contract is that * UPDATE-SYNTAX notes the latest possible position that is known to be valid. * UPDATE-SYNTAX-FOR-DISPLAY, within the display bounds, attempts to revalidate the previous lex if possible, or relex if not. After UPDATE-SYNTAX-FOR-DISPLAY has finished, the entirety of the remaining lexemes are known valid (all the rest have been deleted). This may be wrong: it may be that, since lexing takes essentially no time at all, the whole buffer should be relexed each time. Date: Wed Apr 6 13:54:27 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.12 climacs/prolog-syntax.lisp:1.13 --- climacs/prolog-syntax.lisp:1.12 Wed Apr 6 11:30:19 2005 +++ climacs/prolog-syntax.lisp Wed Apr 6 13:54:27 2005 @@ -148,7 +148,7 @@ (make-instance 'layout-text :cont nil)) (defclass prolog-lexer (incremental-lexer) - ((valid-lex :initarg :valid-lex :accessor valid-lex :initform 1))) + ((valid-lex :initarg :valid-lex :initform 1))) (defmethod next-lexeme ((lexer prolog-lexer) scan) (let ((string (make-array 0 :element-type 'character @@ -852,21 +852,26 @@ (defmethod update-syntax-for-display (buffer (syntax prolog-syntax) top bot) (with-slots (parser lexer valid-parse) syntax (with-slots (climacs-syntax::lexemes valid-lex) lexer - (let ((scan (clone-mark (low-mark buffer) :left))) + (let ((scan (clone-mark (low-mark buffer) :left)) + (high-mark (high-mark buffer))) (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) + (loop named relex + do (skip-inter-lexeme-objects lexer scan) 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 (when (mark>= scan high-mark) + (do () + ((= (nb-lexemes lexer) valid-lex)) + (let ((l (lexeme lexer i))) + (cond + ((mark< scan (start-offset l)) + (return nil)) + ((mark= scan (start-offset l)) + (setf valid-lex (nb-lexemes lexer)) + (return-from relex)) + (t + (delete* climacs-syntax::lexemes valid-lex)))))) do (let* ((start-mark (clone-mark scan)) (lexeme (next-lexeme lexer scan)) (size (- (offset scan) (offset start-mark)))) @@ -874,16 +879,18 @@ (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)))) + ;; remove lexemes which we know to be invalid. + ;; + ;; If we wanted some additional complexity, we could maintain + ;; the possibility of not matching a start lexeme in the + ;; visible region, but possibly elsewhere instead; however, + ;; for now, simply assume that the VALID-LEX from above is + ;; definitive. + (loop until (= (nb-lexemes lexer) valid-lex) + 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 + ;; the bottom of the visible area, whichever comes sooner (loop until (= valid-parse valid-lex) - ;; 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))) @@ -900,7 +907,8 @@ (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 + (with-slots (climacs-syntax::lexemes valid-lex) + lexer (let ((start 1) (end (nb-elements climacs-syntax::lexemes))) (loop while (< start end) From crhodes at common-lisp.net Wed Apr 6 16:23:22 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Wed, 6 Apr 2005 18:23:22 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp Message-ID: <20050406162322.9C17C18C6F5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31107 Modified Files: prolog-syntax.lisp Log Message: Use left-recursion rather than right-recursion. (Be careful to adjust the DISPLAY-PARSE-TREE methods when making changes of this kind!) A couple of minor fixes (well, minor except that they were totally broken before) * VALID-LEX, not (undefined) I; * MARK>, not MARK>=, to get Backspace right. Date: Wed Apr 6 18:23:21 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.13 climacs/prolog-syntax.lisp:1.14 --- climacs/prolog-syntax.lisp:1.13 Wed Apr 6 13:54:27 2005 +++ climacs/prolog-syntax.lisp Wed Apr 6 18:23:21 2005 @@ -58,9 +58,6 @@ (defclass prolog-token (prolog-parse-tree) ((ink) (face))) -(defclass prolog-operator (prolog-token) - ()) - ;;; lexer (defclass prolog-lexeme (prolog-token) @@ -78,11 +75,11 @@ (cont :initarg :cont :accessor cont))) (defmethod display-parse-tree ((entity layout-text) (syntax prolog-syntax) pane) + (when (cont entity) + (display-parse-tree (cont entity) syntax pane)) (when (comment entity) (with-drawing-options (pane :ink (make-rgb-color 0.7 0.0 0.0)) - (display-parse-tree (comment entity) syntax pane))) - (when (cont entity) - (display-parse-tree (cont entity) syntax pane))) + (display-parse-tree (comment entity) syntax pane)))) (defgeneric syntactic-lexeme (thing)) (defmethod syntactic-lexeme ((lexeme prolog-lexeme)) @@ -142,7 +139,7 @@ (make-instance 'open-ct :syntactic-lexeme open-ct-lexeme)) ;;; 6.4.1 -(define-prolog-rule (layout-text -> (comment-lexeme layout-text)) +(define-prolog-rule (layout-text -> (layout-text comment-lexeme)) (make-instance 'layout-text :comment comment-lexeme :cont layout-text)) (define-prolog-rule (layout-text -> ()) (make-instance 'layout-text :cont nil)) @@ -301,13 +298,13 @@ nil) (defmethod display-parse-tree ((entity clause-prolog-text) (syntax prolog-syntax) pane) - (display-parse-tree (clause entity) syntax pane) - (display-parse-tree (text-rest entity) syntax pane)) + (display-parse-tree (text-rest entity) syntax pane) + (display-parse-tree (clause entity) syntax pane)) (defmethod display-parse-tree ((entity directive-prolog-text) (syntax prolog-syntax) pane) + (display-parse-tree (text-rest entity) syntax pane) (with-text-face (pane :italic) - (display-parse-tree (directive entity) syntax pane)) - (display-parse-tree (text-rest entity) syntax pane)) + (display-parse-tree (directive entity) syntax pane))) (defclass directive (prolog-nonterminal) ((directive-term :initarg :directive-term :accessor directive-term) @@ -581,10 +578,10 @@ (display-parse-tree (tlist entity) syntax pane)) ;;; 6.2.1 -(define-prolog-rule (prolog-text -> (directive prolog-text)) +(define-prolog-rule (prolog-text -> (prolog-text directive)) (make-instance 'directive-prolog-text :directive directive :text-rest prolog-text)) -(define-prolog-rule (prolog-text -> (clause prolog-text)) +(define-prolog-rule (prolog-text -> (prolog-text clause)) (make-instance 'clause-prolog-text :clause clause :text-rest prolog-text)) (define-prolog-rule (prolog-text -> ()) (make-instance 'empty-prolog-text)) @@ -860,10 +857,10 @@ do (skip-inter-lexeme-objects lexer scan) until (end-of-buffer-p scan) until (mark<= bot (start-offset (lexeme lexer (1- valid-lex)))) - do (when (mark>= scan high-mark) + do (when (mark> scan high-mark) (do () ((= (nb-lexemes lexer) valid-lex)) - (let ((l (lexeme lexer i))) + (let ((l (lexeme lexer valid-lex))) (cond ((mark< scan (start-offset l)) (return nil)) @@ -985,7 +982,7 @@ (+ (start-offset entity) nl 1)) (setf start (+ nl 1))))))))))) -(defmethod display-parse-tree :before ((entity prolog-lexeme) (syntax prolog-syntax) pane) +(defmethod display-parse-tree :before ((entity prolog-token) (syntax prolog-syntax) pane) (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity)) (setf *white-space-start* (end-offset entity))) From crhodes at common-lisp.net Wed Apr 6 17:00:21 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Wed, 6 Apr 2005 19:00:21 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp Message-ID: <20050406170021.86D6018C6F5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv365 Modified Files: prolog-syntax.lisp Log Message: Because of multiline tokens, we must redraw on various criteria other than the ink and face changing: specifically, if the substring of the token that we are to draw is different, we cannot simply displace or replay an output record. Date: Wed Apr 6 19:00:20 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.14 climacs/prolog-syntax.lisp:1.15 --- climacs/prolog-syntax.lisp:1.14 Wed Apr 6 18:23:21 2005 +++ climacs/prolog-syntax.lisp Wed Apr 6 19:00:20 2005 @@ -56,7 +56,7 @@ ()) (defclass prolog-token (prolog-parse-tree) - ((ink) (face))) + ((ink) (face) (start) (end))) ;;; lexer @@ -947,40 +947,47 @@ (call-next-method)))) (defmethod display-parse-tree ((entity prolog-token) (syntax prolog-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)))) - (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))))))))))) + (with-slots (top bot) pane + (let ((string (coerce (buffer-sequence (buffer syntax) + (start-offset entity) + (end-offset entity)) + 'string))) + (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)))) + (eq (slot-value t1 'start) + (max 0 (- (offset top) (start-offset entity)))) + (eq (slot-value t1 'end) + (- (length string) + (max 0 (- (end-offset entity) (offset bot)))))))) + (updating-output (pane :unique-id entity + :id-test #'eq + :cache-value entity + :cache-test #'cache-test) + (with-slots (ink face start end) entity + (setf ink (medium-ink (sheet-medium pane)) + face (text-style-face (medium-text-style (sheet-medium pane))) + start (max 0 (- (offset top) (start-offset entity))) + end (- (length string) + (max 0 (- (end-offset entity) (offset bot))))) + (let ((start start) + (end end)) + (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-token) (syntax prolog-syntax) pane) (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity)) From rstrandh at common-lisp.net Thu Apr 7 05:02:36 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 7 Apr 2005 07:02:36 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp Message-ID: <20050407050236.9006B18C6C5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv11719 Modified Files: html-syntax.lisp Log Message: Introduced the concept of inline element and block-level element. Reorganized the attributes into core attributes, i18n attributes and scripting events according to the HTML standard. Date: Thu Apr 7 07:02:33 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.22 climacs/html-syntax.lisp:1.23 --- climacs/html-syntax.lisp:1.22 Mon Apr 4 13:49:05 2005 +++ climacs/html-syntax.lisp Thu Apr 7 07:02:33 2005 @@ -185,9 +185,13 @@ (display-parse-tree name syntax pane) (display-parse-tree equals syntax pane))) +(defclass core-attribute (html-attribute) ()) +(defclass i18n-attribute (html-attribute) ()) +(defclass scripting-event (html-attribute) ()) + ;;;;;;;;;;;;;;; lang attribute -(defclass lang-attr (html-attribute) +(defclass lang-attr (i18n-attribute) ((lang :initarg :lang))) (add-html-rule (lang-attr -> ((name word (word-is name "lang")) @@ -204,7 +208,7 @@ ;;;;;;;;;;;;;;; dir attribute -(defclass dir-attr (html-attribute) +(defclass dir-attr (i18n-attribute) ((dir :initarg :dir))) (add-html-rule (dir-attr -> ((name word (word-is name "dir")) @@ -334,6 +338,24 @@ (display-parse-tree items syntax pane) (display-parse-tree syntax pane))) +;;;;;;;;;;;;;;; inline-element, block-level-element + +(defclass inline-element (html-nonterminal) ()) +(defclass block-level-element (html-nonterminal) ()) + +;;;;;;;;;;;;;;; inline-element-or-text + +(defclass inline-element-or-text (html-nonterminal) + ((contents :initarg contents))) + +(add-html-rule (inline-element-or-text -> (inline-element) :contents inline-element)) +(add-html-rule (inline-element-or-text -> (word) :contents word)) +(add-html-rule (inline-element-or-text -> (delimiter) :contents delimiter)) + +(defmethod display-parse-tree ((entity inline-element-or-text) (syntax html-syntax) pane) + (with-slots (contents) entity + (display-parse-tree contents syntax pane))) + ;;;;;;;;;;;;;;; -tag (defclass -attribute (html-nonterminal) @@ -369,7 +391,7 @@ (define-end-tag "a") -(defclass a (html-nonterminal) +(defclass a (inline-element) (( :initarg :) (items :initarg :items) ( :initarg :))) From rstrandh at common-lisp.net Fri Apr 8 05:59:27 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 8 Apr 2005 07:59:27 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp Message-ID: <20050408055927.E494818C6C5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1496 Modified Files: html-syntax.lisp Log Message: headings h1 -- h6 added Date: Fri Apr 8 07:59:27 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.23 climacs/html-syntax.lisp:1.24 --- climacs/html-syntax.lisp:1.23 Thu Apr 7 07:02:33 2005 +++ climacs/html-syntax.lisp Fri Apr 8 07:59:27 2005 @@ -117,9 +117,6 @@ (define-tag-pair "head") (define-tag-pair "title") (define-tag-pair "body") -(define-tag-pair

"h1") -(define-tag-pair

"h2") -(define-tag-pair

"h3") (define-tag-pair

"p") (define-tag-pair "ul") (define-tag-pair
    • "li") @@ -307,37 +304,6 @@ (display-parse-tree items syntax pane)) (display-parse-tree syntax pane))) -;;;;;;;;;;;;;;; body-item body-items - -(defclass body-item (html-nonterminal) - ((item :initarg :item))) - -(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 - (display-parse-tree item syntax pane))) - -(define-list body-items empty-body-items nonempty-body-items body-item) - -;;;;;;;;;;;;;;; body - -(defclass body (html-nonterminal) - (( :initarg :) - (items :initarg :items) - ( :initarg :))) - -(add-html-rule (body -> ( body-items ) - : :items body-items : )) - -(defmethod display-parse-tree ((entity body) (syntax html-syntax) pane) - (with-slots ( items ) entity - (display-parse-tree syntax pane) - (display-parse-tree items syntax pane) - (display-parse-tree syntax pane))) - ;;;;;;;;;;;;;;; inline-element, block-level-element (defclass inline-element (html-nonterminal) ()) @@ -346,7 +312,7 @@ ;;;;;;;;;;;;;;; inline-element-or-text (defclass inline-element-or-text (html-nonterminal) - ((contents :initarg contents))) + ((contents :initarg :contents))) (add-html-rule (inline-element-or-text -> (inline-element) :contents inline-element)) (add-html-rule (inline-element-or-text -> (word) :contents word)) @@ -356,6 +322,39 @@ (with-slots (contents) entity (display-parse-tree contents syntax pane))) +(define-list inline-things empty-inline-things nonempty-inline-things inline-element-or-text) + +;;;;;;;;;;;;;;; headings + +(defclass heading (block-level-element) + ((start :initarg :start) + (contents :initarg :contents) + (end :initarg :end))) + +(defmethod display-parse-tree ((entity heading) (syntax html-syntax) pane) + (with-slots (start contents end) entity + (display-parse-tree start syntax pane) + (display-parse-tree contents syntax pane) + (display-parse-tree end syntax pane))) + +(defmacro define-heading (class-name tag-string start-tag-name end-tag-name) + `(progn + (define-tag-pair ,start-tag-name ,end-tag-name ,tag-string) + + (defclass ,class-name (heading) ()) + + (add-html-rule + (,class-name -> (,start-tag-name inline-things ,end-tag-name) + :start ,start-tag-name :contents inline-things :end ,end-tag-name)))) + + +(define-heading h1 "h1"

    ) +(define-heading h2 "h2"

    ) +(define-heading h3 "h3"

    ) +(define-heading h4 "h4"

    ) +(define-heading h5 "h5"
    ) +(define-heading h6 "h6"
    ) + ;;;;;;;;;;;;;;; -tag (defclass -attribute (html-nonterminal) @@ -405,6 +404,37 @@ (with-text-face (pane :bold) (display-parse-tree items syntax pane)) (display-parse-tree syntax pane))) + +;;;;;;;;;;;;;;; body-item body-items + +(defclass body-item (html-nonterminal) + ((item :initarg :item))) + +(add-html-rule (body-item -> (word) :item word)) +(add-html-rule (body-item -> (delimiter) :item delimiter)) +(add-html-rule (body-item -> ((element block-level-element)) :item element)) + +(defmethod display-parse-tree ((entity body-item) (syntax html-syntax) pane) + (with-slots (item) entity + (display-parse-tree item syntax pane))) + +(define-list body-items empty-body-items nonempty-body-items body-item) + +;;;;;;;;;;;;;;; body + +(defclass body (html-nonterminal) + (( :initarg :) + (items :initarg :items) + ( :initarg :))) + +(add-html-rule (body -> ( body-items ) + : :items body-items : )) + +(defmethod display-parse-tree ((entity body) (syntax html-syntax) pane) + (with-slots ( items ) entity + (display-parse-tree syntax pane) + (display-parse-tree items syntax pane) + (display-parse-tree syntax pane))) ;;;;;;;;;;;;;;; head From rstrandh at common-lisp.net Fri Apr 8 08:30:43 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 8 Apr 2005 10:30:43 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/climacs.html climacs/html-syntax.lisp Message-ID: <20050408083043.7BB1318C6F6@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10039 Modified Files: climacs.html html-syntax.lisp Log Message: Added

    ..

    element to html-syntax Fixed climacs.html to conform to the HTML 4.0 standard. Date: Fri Apr 8 10:30:42 2005 Author: rstrandh Index: climacs/climacs.html diff -u climacs/climacs.html:1.3 climacs/climacs.html:1.4 --- climacs/climacs.html:1.3 Thu Dec 16 07:29:01 2004 +++ climacs/climacs.html Fri Apr 8 10:30:42 2005 @@ -2,7 +2,7 @@ -English version. +

    English version.

    Climacs, une version moderne de l'?diteur Emacs

    Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.24 climacs/html-syntax.lisp:1.25 --- climacs/html-syntax.lisp:1.24 Fri Apr 8 07:59:27 2005 +++ climacs/html-syntax.lisp Fri Apr 8 10:30:42 2005 @@ -117,34 +117,35 @@ (define-tag-pair "head") (define-tag-pair "title") (define-tag-pair "body") -(define-tag-pair

    "p") (define-tag-pair "ul") (define-tag-pair
    • "li") -(defmacro define-list (name empty-name nonempty-name item-name) - `(progn - (defclass ,name (html-nonterminal) ()) - (defclass ,empty-name (,name) ()) - - (defclass ,nonempty-name (,name) - ((items :initarg :items) - (item :initarg :item))) - - (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)) - nil) - - (defmethod display-parse-tree ((entity ,nonempty-name) (syntax html-syntax) pane) - (with-slots (items item) entity - (display-parse-tree items syntax pane) - (display-parse-tree item syntax pane))))) +(defmacro define-list (name item-name) + (let ((empty-name (gensym)) + (nonempty-name (gensym))) + `(progn + (defclass ,name (html-nonterminal) ()) + (defclass ,empty-name (,name) ()) + + (defclass ,nonempty-name (,name) + ((items :initarg :items) + (item :initarg :item))) + + (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)) + nil) + + (defmethod display-parse-tree ((entity ,nonempty-name) (syntax html-syntax) pane) + (with-slots (items item) entity + (display-parse-tree items syntax pane) + (display-parse-tree item syntax pane)))))) ;;;;;;;;;;;;;;; string @@ -157,7 +158,7 @@ (lexemes :initarg :lexemes) (end :initarg :end))) -(define-list string-lexemes empty-string-lexeme nonempty-string-lexeme string-lexeme) +(define-list string-lexemes string-lexeme) (add-html-rule (html-string -> ((start delimiter (word-is start "\"")) string-lexemes @@ -182,9 +183,13 @@ (display-parse-tree name syntax pane) (display-parse-tree equals syntax pane))) -(defclass core-attribute (html-attribute) ()) -(defclass i18n-attribute (html-attribute) ()) -(defclass scripting-event (html-attribute) ()) +(defclass common-attribute (html-attribute) ()) + +(defclass core-attribute (common-attribute) ()) +(defclass i18n-attribute (common-attribute) ()) +(defclass scripting-event (common-attribute) ()) + +(define-list common-attributes common-attribute) ;;;;;;;;;;;;;;; lang attribute @@ -237,43 +242,7 @@ (display-parse-tree href syntax pane))) -;;;;;;;;;;;;;;; -tag - -(defclass -attribute (html-nonterminal) - ((attribute :initarg :attribute))) - -(defmethod display-parse-tree ((entity -attribute) (syntax html-syntax) pane) - (with-slots (attribute) entity - (display-parse-tree attribute syntax pane))) - -(add-html-rule (-attribute -> (lang-attr) :attribute lang-attr)) -(add-html-rule (-attribute -> (dir-attr) :attribute dir-attr)) - -(define-list -attributes empty--attribute nonempty--attribute -attribute) - -(defclass (html-tag) - ((start :initarg :start) - (name :initarg :name) - (attributes :initarg :attributes) - (end :initarg :end))) - -(add-html-rule ( -> (tag-start - (word (and (= (end-offset tag-start) (start-offset word)) - (word-is word "html"))) - -attributes - tag-end) - :start tag-start :name word :attributes -attributes :end tag-end)) - -(defmethod display-parse-tree ((entity ) (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") - -;;;;;;;;;;;;;;; title-item, title-items +;;;;;;;;;;;;;;; title (defclass title-item (html-nonterminal) ((item :initarg :item))) @@ -285,9 +254,7 @@ (with-slots (item) entity (display-parse-tree item syntax pane))) -(define-list title-items empty-title-items nonempty-title-items title-item) - -;;;;;;;;;;;;;;; title +(define-list title-items title-item) (defclass title (html-nonterminal) (( :initarg :<title>) @@ -322,7 +289,7 @@ (with-slots (contents) entity (display-parse-tree contents syntax pane))) -(define-list inline-things empty-inline-things nonempty-inline-things inline-element-or-text) +(define-list inline-things inline-element-or-text) ;;;;;;;;;;;;;;; headings @@ -355,7 +322,7 @@ (define-heading h5 "h5" <h5> </h5>) (define-heading h6 "h6" <h6> </h6>) -;;;;;;;;;;;;;;; <a>-tag +;;;;;;;;;;;;;;; a element (defclass <a>-attribute (html-nonterminal) ((attribute :initarg :attribute))) @@ -366,7 +333,7 @@ (with-slots (attribute) entity (display-parse-tree attribute syntax pane))) -(define-list <a>-attributes empty-<a>-attributes nonempty-<a>-attributes <a>-attribute) +(define-list <a>-attributes <a>-attribute) (defclass <a> (html-tag) ((start :initarg :start) @@ -390,22 +357,60 @@ (define-end-tag </a> "a") -(defclass a (inline-element) +(defclass a-element (inline-element) ((<a> :initarg :<a>) (items :initarg :items) (</a> :initarg :</a>))) -(add-html-rule (a -> (<a> body-items </a>) - :<a> <a> :items body-items :</a> </a>)) +(add-html-rule (a-element -> (<a> inline-things </a>) + :<a> <a> :items inline-things :</a> </a>)) -(defmethod display-parse-tree ((entity a) (syntax html-syntax) pane) +(defmethod display-parse-tree ((entity a-element) (syntax html-syntax) pane) (with-slots (<a> items </a>) entity (display-parse-tree <a> syntax pane) (with-text-face (pane :bold) (display-parse-tree items syntax pane)) (display-parse-tree </a> syntax pane))) -;;;;;;;;;;;;;;; body-item body-items +;;;;;;;;;;;;;;; p element + +(defclass <p> (html-tag) + ((start :initarg :start) + (name :initarg :name) + (attributes :initarg :attributes) + (end :initarg :end))) + +(add-html-rule (<p> -> (tag-start + (word (and (= (end-offset tag-start) (start-offset word)) + (word-is word "p"))) + common-attributes + tag-end) + :start tag-start :name word :attributes common-attributes :end tag-end)) + +(defmethod display-parse-tree ((entity <p>) (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 </p> "p") + +(defclass p-element (block-level-element) + ((<p> :initarg :<p>) + (contents :initarg :contents) + (</p> :initarg :</p>))) + +(add-html-rule (p-element -> (<p> inline-things </p>) + :<p> <p> :contents inline-things :</p> </p>)) + +(defmethod display-parse-tree ((entity p-element) (syntax html-syntax) pane) + (with-slots (<p> contents </p>) entity + (display-parse-tree <p> syntax pane) + (display-parse-tree contents syntax pane) + (display-parse-tree </p> syntax pane))) + +;;;;;;;;;;;;;;; body element (defclass body-item (html-nonterminal) ((item :initarg :item))) @@ -418,9 +423,7 @@ (with-slots (item) entity (display-parse-tree item syntax pane))) -(define-list body-items empty-body-items nonempty-body-items body-item) - -;;;;;;;;;;;;;;; body +(define-list body-items body-item) (defclass body (html-nonterminal) ((<body> :initarg :<body>) @@ -453,6 +456,40 @@ (display-parse-tree </head> syntax pane))) ;;;;;;;;;;;;;;; html + +(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 <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") (defclass html (html-nonterminal) ((<html> :initarg :<html>) From rstrandh at common-lisp.net Fri Apr 8 14:37:01 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 8 Apr 2005 16:37:01 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/climacs-en.html climacs/climacs.html climacs/html-syntax.lisp Message-ID: <20050408143701.5608318C6F6@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31704 Modified Files: climacs-en.html climacs.html html-syntax.lisp Log Message: Added <ul>...</ul> and <li>...</li> elements. Modified some html files to be conform. Date: Fri Apr 8 16:37:00 2005 Author: rstrandh Index: climacs/climacs-en.html diff -u climacs/climacs-en.html:1.3 climacs/climacs-en.html:1.4 --- climacs/climacs-en.html:1.3 Thu Dec 16 07:29:01 2004 +++ climacs/climacs-en.html Fri Apr 8 16:36:59 2005 @@ -1,7 +1,7 @@ <HTML><HEAD><TITLE>Climacs, a modern version of the Emacs editor -Version fran?aise. +

    Version fran?aise.

    Climacs, a modern version of the Emacs editor

    @@ -11,33 +11,33 @@ problems today. :

    @@ -67,5 +67,5 @@
  • Description of the "syntax" protocol
  • Lisp code
    • - + Index: climacs/climacs.html diff -u climacs/climacs.html:1.4 climacs/climacs.html:1.5 --- climacs/climacs.html:1.4 Fri Apr 8 10:30:42 2005 +++ climacs/climacs.html Fri Apr 8 16:36:59 2005 @@ -12,36 +12,36 @@ l'?poque posent quelques probl?mes aujourd'hui :

    @@ -71,7 +71,5 @@
  • Description du protocole "syntax"
  • Code Lisp
    • - - - + Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.25 climacs/html-syntax.lisp:1.26 --- climacs/html-syntax.lisp:1.25 Fri Apr 8 10:30:42 2005 +++ climacs/html-syntax.lisp Fri Apr 8 16:36:59 2005 @@ -117,8 +117,6 @@ (define-tag-pair "head") (define-tag-pair "title") (define-tag-pair "body") -(define-tag-pair "ul") -(define-tag-pair
    • "li") (defmacro define-list (name item-name) (let ((empty-name (gensym)) @@ -301,7 +299,8 @@ (defmethod display-parse-tree ((entity heading) (syntax html-syntax) pane) (with-slots (start contents end) entity (display-parse-tree start syntax pane) - (display-parse-tree contents syntax pane) + (with-text-face (pane :bold) + (display-parse-tree contents syntax pane)) (display-parse-tree end syntax pane))) (defmacro define-heading (class-name tag-string start-tag-name end-tag-name) @@ -410,6 +409,103 @@ (display-parse-tree contents syntax pane) (display-parse-tree

    syntax pane))) +;;;;;;;;;;;;;;; li element + +(defclass
  • (html-tag) + ((start :initarg :start) + (name :initarg :name) + (attributes :initarg :attributes) + (end :initarg :end))) + +(add-html-rule (
  • -> (tag-start + (word (and (= (end-offset tag-start) (start-offset word)) + (word-is word "li"))) + common-attributes + tag-end) + :start tag-start + :name word + :attributes common-attributes + :end tag-end)) + +(defmethod display-parse-tree ((entity
  • ) (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
    • "li") + +(defclass li-item (html-nonterminal) + ((item :initarg :item))) + +(add-html-rule (li-item -> (block-level-element) :item block-level-element)) +(add-html-rule (li-item -> (inline-element) :item inline-element)) + +(defmethod display-parse-tree ((entity li-item) (syntax html-syntax) pane) + (with-slots (item) entity + (display-parse-tree item syntax pane))) + +(define-list li-items li-item) + +(defclass li-element (html-nonterminal) + ((
  • :initarg :
  • ) + (items :initarg :items) + (
    • :initarg :))) + +(add-html-rule (li-element -> (
  • li-items
    • ) + :
  • :items li-items :
    • )) + +(defmethod display-parse-tree ((entity li-element) (syntax html-syntax) pane) + (with-slots (
  • items
    • ) entity + (display-parse-tree
  • syntax pane) + (display-parse-tree items syntax pane) + (display-parse-tree
    • syntax pane))) + + +;;;;;;;;;;;;;;; ul element + +(defclass