[mcclim-cvs] CVS mcclim/Drei
thenriksen
thenriksen at common-lisp.net
Fri Apr 27 21:37:15 UTC 2007
Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv19364/Drei
Modified Files:
editing.lisp lisp-syntax.lisp motion.lisp packages.lisp
Added Files:
lr-syntax.lisp
Log Message:
Merged splittist's work on splitting the general parts of the Lisp
syntax's LR parser into an abstract syntax type. Also some supporting
(mostly package) fixes needed to make it all still roll.
--- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/29 09:59:00 1.4
+++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2007/04/27 21:37:14 1.5
@@ -364,3 +364,9 @@
(define-edit-fns expression)
(define-edit-fns definition)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; List editing
+
+(define-edit-fns list)
--- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/04/09 23:06:55 1.27
+++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/04/27 21:37:14 1.28
@@ -49,14 +49,8 @@
;;;
;;; the syntax object
-(define-syntax lisp-syntax (fundamental-syntax)
- ((stack-top :initform nil)
- (potentially-valid-trees)
- (lookahead-lexeme :initform nil :accessor lookahead-lexeme)
- (current-state)
- (current-start-mark)
- (current-size)
- (package-list :accessor package-list
+(define-syntax lisp-syntax (lr-syntax-mixin fundamental-syntax)
+ ((package-list :accessor package-list
:documentation "An alist mapping the end offset
of (in-package) forms to a string of the package designator in
the form. The list is sorted with the earliest (in-package) forms
@@ -79,7 +73,8 @@
syntax should be run."))
(:name "Lisp")
(:pathname-types "lisp" "lsp" "cl")
- (:command-table lisp-table))
+ (:command-table lisp-table)
+ (:default-initargs :initial-state |initial-state |))
(defgeneric base (syntax)
(:documentation "Get the base `syntax' should interpret numbers
@@ -112,11 +107,6 @@
0)))))
(cons :base (format nil "~A" (base syntax)))))
-(defmethod initialize-instance :after ((syntax lisp-syntax) &rest args)
- (declare (ignore args))
- (with-slots (buffer scan) syntax
- (setf scan (clone-mark (low-mark buffer) :left))))
-
(defmethod name-for-info-pane ((syntax lisp-syntax) &key pane)
(format nil "Lisp~@[:~(~A~)~]"
(provided-package-name-at-mark syntax (point pane))))
@@ -232,36 +222,7 @@
(:method (image symbol-name default-package &optional limit)
(declare (ignore image symbol-name default-package limit))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; lexer
-
-(defgeneric skip-inter (syntax state scan)
- (:documentation "advance scan until the beginning of a new
- lexeme. Return T if one can be found and NIL otherwise."))
-
-(defgeneric lex (syntax state scan)
- (:documentation "Return the next lexeme starting at scan."))
-
-(defclass lexer-state ()
- ()
- (:documentation "These states are used to determine how the lexer
- should behave."))
-
-(defmacro define-lexer-state (name superclasses &body body)
- `(defclass ,name (, at superclasses lexer-state)
- , at body))
-
-(define-lexer-state lexer-error-state ()
- ()
- (:documentation "In this state, the lexer returns error lexemes
- consisting of entire lines of text"))
-
-(define-lexer-state lexer-toplevel-state ()
- ()
- (:documentation "In this state, the lexer assumes it can skip
- whitespace and should recognize ordinary lexemes of the language
- except for the right parenthesis"))
+;;; Lexing
(define-lexer-state lexer-list-state (lexer-toplevel-state)
()
@@ -288,61 +249,6 @@
(:documentation "In this state, the lexer is accumulating a token
and an odd number of multiple escapes have been seen."))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; this should go in syntax.lisp or lr-syntax.lisp
-;;; and should inherit from parse-tree
-
-(defclass parser-symbol ()
- ((start-mark :initform nil :initarg :start-mark :reader start-mark)
- (size :initform nil :initarg :size)
- (parent :initform nil :accessor parent)
- (children :initform '() :initarg :children :reader children)
- (preceding-parse-tree :initform nil :reader preceding-parse-tree)
- (parser-state :initform nil :initarg :parser-state :reader parser-state)))
-
-(defmethod start-offset ((state parser-symbol))
- (let ((mark (start-mark state)))
- (when mark
- (offset mark))))
-
-(defmethod end-offset ((state parser-symbol))
- (with-slots (start-mark size) state
- (when start-mark
- (+ (offset start-mark) size))))
-
-(defgeneric action (syntax state lexeme))
-(defgeneric new-state (syntax state parser-symbol))
-
-(defclass parser-state () ())
-
-(defmacro define-parser-state (name superclasses &body body)
- `(progn
- (defclass ,name ,superclasses
- , at body)
- (defvar ,name (make-instance ',name))))
-
-(defclass lexeme (parser-symbol) ())
-
-(defmethod print-object ((lexeme lexeme) stream)
- (print-unreadable-object (lexeme stream :type t :identity t)
- (format stream "~s ~s" (start-offset lexeme) (end-offset lexeme))))
-
-(defclass nonterminal (parser-symbol) ())
-
-(defmethod initialize-instance :after ((parser-symbol nonterminal) &rest args)
- (declare (ignore args))
- (with-slots (children start-mark size) parser-symbol
- (loop for child in children
- do (setf (parent child) parser-symbol))
- (let ((start (find-if-not #'null children :key #'start-offset))
- (end (find-if-not #'null children :key #'end-offset :from-end t)))
- (when start
- (setf start-mark (slot-value start 'start-mark)
- size (- (end-offset end) (start-offset start)))))))
-
-;;; until here
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(defclass lisp-nonterminal (nonterminal) ())
(defclass form (lisp-nonterminal) ())
(defclass complete-form-mixin () ())
@@ -404,17 +310,6 @@
do (fo)
finally (return t))))
-(defmethod lex :around (syntax state scan)
- (when (skip-inter syntax state scan)
- (let* ((start-offset (offset scan))
- (lexeme (call-next-method))
- (new-size (- (offset scan) start-offset)))
- (with-slots (start-mark size) lexeme
- (setf (offset scan) start-offset)
- (setf start-mark scan
- size new-size))
- lexeme)))
-
(defmethod lex ((syntax lisp-syntax) (state lexer-toplevel-state) scan)
(macrolet ((fo () `(forward-object scan)))
(let ((object (object-after scan)))
@@ -725,65 +620,6 @@
`(defmethod new-state ((syntax lisp-syntax) (state ,state) (tree ,parser-symbol))
, at body))
-(defun pop-one (syntax)
- (with-slots (stack-top current-state) syntax
- (with-slots (preceding-parse-tree parser-state) stack-top
- (prog1 stack-top
- (setf current-state parser-state
- stack-top preceding-parse-tree)))))
-
-(defun pop-number (syntax how-many)
- (loop with result = '()
- repeat how-many
- do (push (pop-one syntax) result)
- finally (return result)))
-
-(defmacro reduce-fixed-number (symbol nb-children)
- `(let ((result (make-instance ',symbol :children (pop-number syntax ,nb-children))))
- (when (zerop ,nb-children)
- (with-slots (scan) syntax
- (with-slots (start-mark size) result
- (setf start-mark (clone-mark scan :right)
- size 0))))
- result))
-
-(defun pop-until-type (syntax type)
- (with-slots (stack-top) syntax
- (loop with result = '()
- for child = stack-top
- do (push (pop-one syntax) result)
- until (typep child type)
- finally (return result))))
-
-(defmacro reduce-until-type (symbol type)
- `(let ((result (make-instance ',symbol
- :children (pop-until-type syntax ',type))))
- (when (null (children result))
- (with-slots (scan) syntax
- (with-slots (start-mark size) result
- (setf start-mark (clone-mark scan :right)
- size 0))))
- result))
-
-(defun pop-all (syntax)
- (with-slots (stack-top) syntax
- (loop with result = '()
- until (null stack-top)
- do (push (pop-one syntax) result)
- finally (return result))))
-
-(defmacro reduce-all (symbol)
- `(let ((result (make-instance ',symbol :children (pop-all syntax))))
- (when (null (children result))
- (with-slots (scan) syntax
- (with-slots (start-mark size) result
- (setf start-mark (clone-mark scan :right)
- size 0))))
- result))
-
-(define-parser-state error-state (lexer-error-state parser-state) ())
-(define-parser-state error-reduce-state (lexer-toplevel-state parser-state) ())
-
(define-lisp-action (error-reduce-state (eql nil))
(throw 'done nil))
@@ -1271,102 +1107,6 @@
(define-lisp-action (|#<other> form | t)
(reduce-fixed-number undefined-reader-macro-form 2))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; parser step
-
-(defgeneric parser-step (syntax))
-
-(defmethod parser-step ((syntax lisp-syntax))
- (with-slots (lookahead-lexeme stack-top current-state scan) syntax
- (setf lookahead-lexeme (lex syntax current-state (clone-mark scan :right)))
- (let* ((new-parser-symbol (action syntax current-state lookahead-lexeme))
- (new-state (new-state syntax current-state new-parser-symbol)))
- (with-slots (parser-state parser-symbol preceding-parse-tree children) new-parser-symbol
- (setf parser-state current-state
- current-state new-state
- preceding-parse-tree stack-top
- stack-top new-parser-symbol)))
- (setf (offset scan) (end-offset stack-top))))
-
-(defun prev-tree (tree)
- (assert (not (null tree)))
- (if (null (children tree))
- (preceding-parse-tree tree)
- (car (last (children tree)))))
-
-(defun next-tree (tree)
- (assert (not (null tree)))
- (if (null (parent tree))
- nil
- (let* ((parent (parent tree))
- (siblings (children parent)))
- (cond ((null parent) nil)
- ((eq tree (car (last siblings))) parent)
- (t (loop with new-tree = (cadr (member tree siblings :test #'eq))
- until (null (children new-tree))
- do (setf new-tree (car (children new-tree)))
- finally (return new-tree)))))))
-
-(defun find-last-valid-lexeme (parse-tree offset)
- (cond ((or (null parse-tree) (null (start-offset parse-tree))) nil)
- ((> (start-offset parse-tree) offset)
- (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset))
- ((not (typep parse-tree 'lexeme))
- (find-last-valid-lexeme (car (last (children parse-tree))) offset))
- ((>= (end-offset parse-tree) offset)
- (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset))
- (t parse-tree)))
-
-(defun find-first-potentially-valid-lexeme (parse-trees offset)
- (cond ((null parse-trees) nil)
- ((or (null (start-offset (car parse-trees)))
- (< (end-offset (car parse-trees)) offset))
- (find-first-potentially-valid-lexeme (cdr parse-trees) offset))
- ((not (typep (car parse-trees) 'lexeme))
- (find-first-potentially-valid-lexeme (children (car parse-trees)) offset))
- ((<= (start-offset (car parse-trees)) offset)
- (loop with tree = (next-tree (car parse-trees))
- until (or (null tree) (> (start-offset tree) offset))
- do (setf tree (next-tree tree))
- finally (return tree)))
- (t (car parse-trees))))
-
-(defun parse-tree-equal (tree1 tree2)
- (and (eq (class-of tree1) (class-of tree2))
- (eq (parser-state tree1) (parser-state tree2))
- (= (end-offset tree1) (end-offset tree2))))
-
-(defmethod print-object ((mark mark) stream)
- (print-unreadable-object (mark stream :type t :identity t)
- (format stream "~s" (offset mark))))
-
-(defun parse-patch (syntax)
- (with-slots (current-state stack-top scan potentially-valid-trees) syntax
- (parser-step syntax)
- (finish-output *trace-output*)
- (cond ((parse-tree-equal stack-top potentially-valid-trees)
- (unless (or (null (parent potentially-valid-trees))
- (eq potentially-valid-trees
- (car (last (children (parent potentially-valid-trees))))))
- (loop for tree = (cadr (member potentially-valid-trees
- (children (parent potentially-valid-trees))
- :test #'eq))
- then (car (children tree))
- until (null tree)
- do (setf (slot-value tree 'preceding-parse-tree)
- stack-top))
- (setf stack-top (prev-tree (parent potentially-valid-trees))))
- (setf potentially-valid-trees (parent potentially-valid-trees))
- (setf current-state (new-state syntax (parser-state stack-top) stack-top))
- (setf (offset scan) (end-offset stack-top)))
- (t (loop until (or (null potentially-valid-trees)
- (>= (start-offset potentially-valid-trees)
- (end-offset stack-top)))
- do (setf potentially-valid-trees
- (next-tree potentially-valid-trees)))))))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; update syntax
@@ -1486,27 +1226,9 @@
(extract child))
(package-list syntax))))))
-(defmethod update-syntax (buffer (syntax lisp-syntax))
- (let* ((low-mark (low-mark buffer))
- (high-mark (high-mark buffer)))
- (when (mark<= low-mark high-mark)
- (catch 'done
- (with-slots (current-state stack-top scan potentially-valid-trees) syntax
- (setf potentially-valid-trees
- (if (null stack-top)
- nil
- (find-first-potentially-valid-lexeme (children stack-top)
- (offset high-mark))))
- (setf stack-top (find-last-valid-lexeme stack-top (offset low-mark)))
- (setf (offset scan) (if (null stack-top) 0 (end-offset stack-top))
- current-state (if (null stack-top)
- |initial-state |
- (new-state syntax
- (parser-state stack-top)
- stack-top)))
- (loop do (parse-patch syntax)))))
- (when (need-to-update-package-list-p buffer syntax)
- (update-package-list buffer syntax))))
+(defmethod update-syntax :after (buffer (syntax lisp-syntax))
+ (when (need-to-update-package-list-p buffer syntax)
+ (update-package-list buffer syntax)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
--- /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2006/11/30 17:00:09 1.3
+++ /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2007/04/27 21:37:14 1.4
@@ -499,6 +499,26 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
+;;; List motion
+
+(defgeneric backward-one-list (mark syntax)
+ (:documentation
+ "Move MARK backward by one list.
+Return T if successful, or NIL if the buffer limit was reached.")
+ (:method (mark syntax)
+ (error 'no-such-operation)))
+
+(defgeneric forward-one-list (mark syntax)
+ (:documentation
+ "Move MARK forward by one list.
+Return T if successful, or NIL if the buffer limit was reached.")
+ (:method (mark syntax)
+ (error 'no-such-operation)))
+
+(define-motion-fns list)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
;;; Sentence motion
(defgeneric backward-one-sentence (mark syntax)
--- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/02/13 12:14:12 1.13
+++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/04/27 21:37:14 1.14
@@ -160,13 +160,9 @@
#:name-for-info-pane
#:display-syntax-name
#:syntax-line-indentation
- #:forward-expression #:backward-expression
#:eval-defun
#:record-line-vertical-offset
#:line-vertical-offset
- #:backward-paragraph #:forward-paragraph
- #:backward-sentence #:forward-sentence
- #:forward-list #:backward-list
#:syntax-line-comment-string
#:line-comment-region #:comment-region
#:line-uncomment-region #:uncomment-region
@@ -331,7 +327,13 @@
#:forward-one-sentence
#:backward-one-sentence
#:forward-sentence
- #:backward-sentence)
+ #:backward-sentence
+
+ ;; Lists
+ #:forward-one-list
+ #:backward-one-list
+ #:forward-list
+ #:backward-list)
(:documentation "Functions and facilities for moving a mark
around by syntactical elements. The functions in this package are
syntax-aware, and their behavior is based on the semantics
@@ -384,7 +386,12 @@
;; Sentences
#:forward-delete-sentence #:backward-delete-sentence
#:forward-kill-sentence #:backward-kill-sentence
- #:transpose-sentences)
+ #:transpose-sentences
+
+ ;; Lists
+ #:forward-delete-list #:backward-delete-list
+ #:forward-kill-list #:backward-kill-list
+ #:transpose-list)
(:documentation "Functions and facilities for changing the
buffer contents by syntactical elements. The functions in this
package are syntax-aware, and their behavior is based on the
@@ -437,17 +444,33 @@
(:documentation "Implementation of the basic syntax module for
editing plain text."))
+(defpackage :drei-lr-syntax
+ (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base
+ :drei-syntax :drei-fundamental-syntax)
+ (:export #:lr-syntax-mixin #:stack-top #:initial-state
+ #:skip-inter #:lex #:define-lexer-state
+ #:lexer-toplevel-state #:lexer-error-state
+ #:parser-symbol #:parent #:children
+ #:start-offset #:end-offset #:parser-state
+ #:preceding-parse-tree
+ #:define-parser-state
+ #:lexeme #:nonterminal
+ #:action #:new-state #:done
+ #:reduce-fixed-number #:reduce-until-type #:reduce-all
+ #:error-state #:error-reduce-state)
+ (:documentation "Underlying LR parsing functionality."))
+
(defpackage :drei-lisp-syntax
(:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base
:drei-syntax :drei-fundamental-syntax :flexichain :drei
- :drei-motion :drei-editing :esa-utils :esa :drei-core :esa-io)
+ :drei-motion :drei-editing :esa-utils :esa :drei-core :esa-io
+ :drei-lr-syntax)
(:export #:lisp-syntax
#:lisp-string
#:edit-definition
#:form
#:form-to-object
- #:form-conversion-error
- #:forward-one-list #:backward-one-list #:forward-list #:backward-list)
+ #:form-conversion-error)
(:shadow clim:form)
(:documentation "Implementation of the syntax module used for
editing Common Lisp code."))
--- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2007/04/27 21:37:15 NONE
+++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2007/04/27 21:37:15 1.1
;; -*- Mode: Lisp; Package: DREI-LR-SYNTAX -*-
;;; (c) copyright 2005 by
;;; Robert Strandh (strandh at labri.fr)
;;; (c) copyright 2006 by
;;; Troels Henriksen (athas at sigkill.dk)
;;; (c) copyright 2007 by
;;; John Q Splittist (splittist at gmail.com)
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
;;; Base lexing and parsing functionality of
;;; syntax modules for analysing languages
(in-package :drei-lr-syntax)
(defclass lr-syntax-mixin ()
((stack-top :initform nil)
(potentially-valid-trees)
(lookahead-lexeme :initform nil :accessor lookahead-lexeme)
(current-state)
(initial-state :initarg :initial-state)
(current-start-mark)
(current-size)))
(defmethod initialize-instance :after ((syntax lr-syntax-mixin) &rest args)
(declare (ignore args))
(with-slots (buffer scan) syntax
(setf scan (clone-mark (low-mark buffer) :left))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; lexer
(defgeneric skip-inter (syntax state scan)
(:documentation "advance scan until the beginning of a new
lexeme. Return T if one can be found and NIL otherwise."))
(defgeneric lex (syntax state scan)
(:documentation "Return the next lexeme starting at scan."))
(defmethod lex :around (syntax state scan)
(when (skip-inter syntax state scan)
(let* ((start-offset (offset scan))
(lexeme (call-next-method))
(new-size (- (offset scan) start-offset)))
(with-slots (start-mark size) lexeme
(setf (offset scan) start-offset)
(setf start-mark scan
size new-size))
lexeme)))
(defclass lexer-state ()
()
(:documentation "These states are used to determine how the lexer
should behave."))
(defmacro define-lexer-state (name superclasses &body body)
`(defclass ,name (, at superclasses lexer-state)
, at body))
(define-lexer-state lexer-error-state ()
()
(:documentation "In this state, the lexer returns error lexemes
consisting of entire lines of text"))
(define-lexer-state lexer-toplevel-state ()
()
(:documentation "In this state, the lexer assumes it can skip
whitespace and should recognize ordinary lexemes of the language."))
(defclass parser-symbol ()
((start-mark :initform nil :initarg :start-mark :reader start-mark)
(size :initform nil :initarg :size)
(parent :initform nil :accessor parent)
(children :initform '() :initarg :children :reader children)
(preceding-parse-tree :initform nil :reader preceding-parse-tree)
(parser-state :initform nil :initarg :parser-state :reader parser-state)))
(defmethod start-offset ((state parser-symbol))
(let ((mark (start-mark state)))
(when mark
(offset mark))))
(defmethod end-offset ((state parser-symbol))
(with-slots (start-mark size) state
(when start-mark
(+ (offset start-mark) size))))
(defgeneric action (syntax state lexeme))
(defgeneric new-state (syntax state parser-symbol))
(defclass parser-state () ())
(defmacro define-parser-state (name superclasses &body body)
`(progn
(defclass ,name ,superclasses
, at body)
(defvar ,name (make-instance ',name))))
(defclass lexeme (parser-symbol) ())
(defmethod print-object ((lexeme lexeme) stream)
(print-unreadable-object (lexeme stream :type t :identity t)
(format stream "~s ~s" (start-offset lexeme) (end-offset lexeme))))
(defclass nonterminal (parser-symbol) ())
(defmethod initialize-instance :after ((parser-symbol nonterminal) &rest args)
(declare (ignore args))
(with-slots (children start-mark size) parser-symbol
(loop for child in children
do (setf (parent child) parser-symbol))
(let ((start (find-if-not #'null children :key #'start-offset))
(end (find-if-not #'null children :key #'end-offset :from-end t)))
(when start
(setf start-mark (slot-value start 'start-mark)
size (- (end-offset end) (start-offset start)))))))
(defun pop-one (syntax)
(with-slots (stack-top current-state) syntax
(with-slots (preceding-parse-tree parser-state) stack-top
(prog1 stack-top
(setf current-state parser-state
stack-top preceding-parse-tree)))))
(defun pop-number (syntax how-many)
(loop with result = '()
repeat how-many
do (push (pop-one syntax) result)
finally (return result)))
(defmacro reduce-fixed-number (symbol nb-children)
`(let ((result (make-instance ',symbol :children (pop-number syntax ,nb-children))))
(when (zerop ,nb-children)
(with-slots (scan) syntax
(with-slots (start-mark size) result
(setf start-mark (clone-mark scan :right)
size 0))))
result))
(defun pop-until-type (syntax type)
(with-slots (stack-top) syntax
(loop with result = '()
for child = stack-top
do (push (pop-one syntax) result)
until (typep child type)
finally (return result))))
(defmacro reduce-until-type (symbol type)
`(let ((result (make-instance ',symbol
:children (pop-until-type syntax ',type))))
(when (null (children result))
(with-slots (scan) syntax
(with-slots (start-mark size) result
(setf start-mark (clone-mark scan :right)
size 0))))
result))
(defun pop-all (syntax)
(with-slots (stack-top) syntax
(loop with result = '()
until (null stack-top)
do (push (pop-one syntax) result)
finally (return result))))
(defmacro reduce-all (symbol)
`(let ((result (make-instance ',symbol :children (pop-all syntax))))
(when (null (children result))
(with-slots (scan) syntax
(with-slots (start-mark size) result
(setf start-mark (clone-mark scan :right)
size 0))))
result))
(define-parser-state error-state (lexer-error-state parser-state) ())
(define-parser-state error-reduce-state (lexer-toplevel-state parser-state) ())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; parser step
(defgeneric parser-step (syntax))
(defmethod parser-step ((syntax lr-syntax-mixin))
(with-slots (lookahead-lexeme stack-top current-state scan) syntax
(setf lookahead-lexeme (lex syntax current-state (clone-mark scan :right)))
(let* ((new-parser-symbol (action syntax current-state lookahead-lexeme))
(new-state (new-state syntax current-state new-parser-symbol)))
(with-slots (parser-state parser-symbol preceding-parse-tree children) new-parser-symbol
(setf parser-state current-state
current-state new-state
preceding-parse-tree stack-top
stack-top new-parser-symbol)))
(setf (offset scan) (end-offset stack-top))))
(defun prev-tree (tree)
(assert (not (null tree)))
(if (null (children tree))
(preceding-parse-tree tree)
(car (last (children tree)))))
(defun next-tree (tree)
(assert (not (null tree)))
(if (null (parent tree))
nil
(let* ((parent (parent tree))
(siblings (children parent)))
(cond ((null parent) nil)
((eq tree (car (last siblings))) parent)
(t (loop with new-tree = (cadr (member tree siblings :test #'eq))
until (null (children new-tree))
do (setf new-tree (car (children new-tree)))
finally (return new-tree)))))))
(defun find-last-valid-lexeme (parse-tree offset)
(cond ((or (null parse-tree) (null (start-offset parse-tree))) nil)
((> (start-offset parse-tree) offset)
(find-last-valid-lexeme (preceding-parse-tree parse-tree) offset))
((not (typep parse-tree 'lexeme))
(find-last-valid-lexeme (car (last (children parse-tree))) offset))
((>= (end-offset parse-tree) offset)
(find-last-valid-lexeme (preceding-parse-tree parse-tree) offset))
(t parse-tree)))
(defun find-first-potentially-valid-lexeme (parse-trees offset)
(cond ((null parse-trees) nil)
((or (null (start-offset (car parse-trees)))
(< (end-offset (car parse-trees)) offset))
(find-first-potentially-valid-lexeme (cdr parse-trees) offset))
((not (typep (car parse-trees) 'lexeme))
(find-first-potentially-valid-lexeme (children (car parse-trees)) offset))
((<= (start-offset (car parse-trees)) offset)
(loop with tree = (next-tree (car parse-trees))
until (or (null tree) (> (start-offset tree) offset))
do (setf tree (next-tree tree))
finally (return tree)))
(t (car parse-trees))))
(defun parse-tree-equal (tree1 tree2)
(and (eq (class-of tree1) (class-of tree2))
(eq (parser-state tree1) (parser-state tree2))
(= (end-offset tree1) (end-offset tree2))))
(defmethod print-object ((mark mark) stream)
(print-unreadable-object (mark stream :type t :identity t)
(format stream "~s" (offset mark))))
(defun parse-patch (syntax)
(with-slots (current-state stack-top scan potentially-valid-trees) syntax
(parser-step syntax)
(finish-output *trace-output*)
(cond ((parse-tree-equal stack-top potentially-valid-trees)
(unless (or (null (parent potentially-valid-trees))
(eq potentially-valid-trees
(car (last (children (parent potentially-valid-trees))))))
(loop for tree = (cadr (member potentially-valid-trees
(children (parent potentially-valid-trees))
:test #'eq))
then (car (children tree))
until (null tree)
do (setf (slot-value tree 'preceding-parse-tree)
stack-top))
(setf stack-top (prev-tree (parent potentially-valid-trees))))
(setf potentially-valid-trees (parent potentially-valid-trees))
(setf current-state (new-state syntax (parser-state stack-top) stack-top))
(setf (offset scan) (end-offset stack-top)))
(t (loop until (or (null potentially-valid-trees)
(>= (start-offset potentially-valid-trees)
(end-offset stack-top)))
do (setf potentially-valid-trees
(next-tree potentially-valid-trees)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; update syntax
(defmethod update-syntax-for-display (buffer (syntax lr-syntax-mixin) top bot)
nil)
(defmethod update-syntax (buffer (syntax lr-syntax-mixin))
(let* ((low-mark (low-mark buffer))
(high-mark (high-mark buffer)))
(when (mark<= low-mark high-mark)
(catch 'done
(with-slots (current-state stack-top scan potentially-valid-trees
initial-state) syntax
(setf potentially-valid-trees
(if (null stack-top)
nil
(find-first-potentially-valid-lexeme (children stack-top)
(offset high-mark))))
(setf stack-top (find-last-valid-lexeme stack-top (offset low-mark)))
(setf (offset scan) (if (null stack-top) 0 (end-offset stack-top))
current-state (if (null stack-top)
initial-state
(new-state syntax
(parser-state stack-top)
stack-top)))
(loop do (parse-patch syntax)))))))
More information about the Mcclim-cvs
mailing list