From 91bdbf47c33d5521ab1e19068ee7af783828c20a Mon Sep 17 00:00:00 2001 From: james anderson Date: Fri, 21 Jan 2011 02:02:50 +0100 Subject: [PATCH] clean up pretty-printer to approximate .atn encoding; implement simple grapher; add explicit source package distinct from current one to isolate state machines; --- atn-classes.lisp | 54 ++++++++--- atn-graph.lisp | 181 ++++++++++++++++++++++++++++++++++++ atn-lisp-compiler.lisp | 51 +++++++--- atn-parameters.lisp | 143 +++++++++++++++++----------- ebnf-to-atn-translator.lisp | 8 +- package.lisp | 12 +++ 6 files changed, 362 insertions(+), 87 deletions(-) create mode 100644 atn-graph.lisp diff --git a/atn-classes.lisp b/atn-classes.lisp index bf827eb..cb9e928 100644 --- a/atn-classes.lisp +++ b/atn-classes.lisp @@ -50,6 +50,10 @@ (flet ((name-equal (x) (string-equal (string (atn-name x)) name))) (find-if #'name-equal (system-nets object)))) +(defmethod system-main-net ((system atn-system)) + (or (get-atn system (system-main-net-name system)) + (error "Undefined net: system ~a; net ~a" system (system-main-net-name system)))) + #| (defmethod system-lexical-rules ((system atn-system)) (lexical-rules (system-grammar system))) @@ -115,13 +119,17 @@ (defmethod print-object ((object atn) stream) (if *print-pretty* - (format stream "(defatn ~A ~A ~@[~% :nodes (~{~A~^~%~})~])" + (format stream "(defatn ~A ~A ~@[~% :nodes (~{~A~^~%~10t~})~])" (atn-name object) (atn-start object) (atn-nodes object)) (print-unreadable-object (object stream :type t) (format stream "~A {~D}" (atn-name object) (length (atn-nodes object)))))) +(defmethod atn-start-node ((net atn)) + (or (find (atn-start net) (atn-nodes net) :key #'atn-name) + (error "Undefined node: net ~a; node ~a" net (atn-start net)))) + (defMethod atn-term-cardinality ((node atn) name) (rest (assoc name (atn-terms node) :test #'string=))) @@ -163,12 +171,23 @@ (defmethod print-object ((object atn-node) stream) (if *print-pretty* - (format stream "(~A ~{~%~A~})" + (format stream "(|~A|~48t~{ ~A~})" (atn-name object) (atn-edges object)) (print-unreadable-object (object stream :type t) (write (atn-name object) :stream stream)))) +(defmethod atn-net-atn ((atn-node atn-node)) + "Return the net instance designated by the respective net in the context of the respective system" + (let ((net (atn-net atn-node)) + (system (atn-system atn-node))) + (or (get-atn system net) + (error "Undefined net: system ~a; net ~a" system net)))) + +(defmethod atn-system ((atn-node atn-node)) + (atn-system (atn-net atn-node))) + + ;;; Kanten (defclass atn-edge (atn-unit) @@ -184,8 +203,16 @@ (format stream "~s/?~s/~s" (atn-start object) (atn-test object) (atn-actions object)))) +(defmethod atn-net-atn ((edge atn-edge)) + "Return the net instance designated by the respective net in the context of the respective system" + (let* ((net (atn-net edge)) + (node (atn-node edge)) + (system (atn-system node))) + (or (get-atn system net) + (error "Undefined net: system ~a; net ~a" system net)))) + ;; 20010331.jaa added an explicit fail continuation to the transition edge. -;; otherwise an edge sequenc eis necessary, whereby the succeedor transition +;; otherwise an edge sequence is necessary, whereby the successor transition ;; in the sequence is taken both for success and failure. ;; this makes it difficult to code for tail calls when translating. (defclass atn-transition (atn-edge) @@ -206,16 +233,15 @@ (defmethod print-object ((object pop-atn-edge) stream) (if *print-pretty* - (format stream "(pop ~A)" + (format stream "(pop |~A|)" (atn-register object)) (call-next-method))) (defClass fail-atn-edge (atn-edge) ()) -(defmethod print-object ((object fail-atn-edge) stream) +(defmethod print-object ((object fail-atn-edge) stream); (break) (if *print-pretty* - (format stream "(fail ~A)" - (atn-register object)) + (format stream "#|fail|#") (call-next-method))) (defclass word-atn-edge (consume-atn-edge) @@ -236,7 +262,7 @@ (defmethod print-object ((object cat-atn-edge) stream) (if *print-pretty* - (format stream "(cat ~A ~A)" + (format stream "(cat |~A| ~A)" (atn-cat object) (atn-end object)) (call-next-method))) @@ -246,7 +272,7 @@ (defmethod print-object ((object push-atn-edge) stream) (if *print-pretty* - (format stream "(push ~A ~A)" + (format stream "(push |~A| |~A|)" (atn-net object) (atn-end object)) (call-next-method))) @@ -308,7 +334,7 @@ argument list.") (:method ((node atn)) (mapcar #'(lambda (term.cardinality &aux (c (first term.cardinality))) - (if (stringp c) (intern c) c)) + (if (stringp c) (intern c *atn-source-package*) c)) (atn-terms node))) (:method ((node pop-atn-edge)) (atn-term-names (atn-net (atn-node node)))) @@ -346,8 +372,10 @@ (elements :accessor category-elements :initarg :elements :initform nil))) (defmethod print-object ((object atn-category) stream) - (print-unreadable-object (object stream :type t :identity t) - (format stream "~A" (category-name object)))) + (if *print-pretty* + (format stream "~a" (category-name object)) + (print-unreadable-object (object stream :type t :identity t) + (format stream "~A" (category-name object))))) (defclass atn-undeclared-category (atn-category) ()) @@ -558,7 +586,7 @@ ;; this walks the net and interns the node names. it shoud not intern values ;; which are tested against input, since that package may be different from ;; the source package - ((maybe-intern (slot) `(when (stringp ,slot) (setf ,slot (intern ,slot)))) + ((maybe-intern (slot) `(when (stringp ,slot) (setf ,slot (intern ,slot *atn-source-package*)))) (maybe-intern-slots (slots instance) `(progn (with-slots ,slots ,instance ,@(mapcar #'(lambda (slot) `(maybe-intern ,slot)) slots))))) diff --git a/atn-graph.lisp b/atn-graph.lisp new file mode 100644 index 0000000..77b68d6 --- /dev/null +++ b/atn-graph.lisp @@ -0,0 +1,181 @@ +;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: bnf-parser; -*- + +;;; This file is part of the atn-parser system. It graphs atn models. + +(in-package :atn-parser) + +;; +;; +;; GRAPH-ATN-SYSTEM handles the various input forms and prints the system's net definitions to a stream. + +(defgeneric graph-atn-system (system &key) + (:documentation + "translate an atn system to its net definitions.") + + (:method ((grammar-system atn-system) + &key + ((:source-package *atn-source-package*) *package*) + (dot-pathname (error "dot-pathname is required."))) + "print an atn system." + (declare (special *atn-source-package*)) + (setq *atn-source-package* (or (find-package *atn-source-package*) + "source package is invalid: ~s." *atn-source-package*)) + (dot:context-put-graph dot-pathname grammar-system grammar-system) + grammar-system) + + (:method ((*grammar string) &rest keys + &key ((:register-words *atn-register-words) nil) + ((:token-package *atn-token-package*) *package*) + ((:source-package *atn-source-package*) *package*) + &allow-other-keys) + "translate a bnf grammar to an atn system and from there write it to a stream." + (declare (special *grammar)) + (setq *atn-source-package* (or (find-package *atn-source-package*) + "source package is invalid: ~s." *atn-source-package*)) + (setq *atn-token-package* (or (find-package *atn-token-package*) + "token package is invalid: ~s." *atn-token-package*)) + (let ((atn-system (bnf-to-atn *grammar))) + (cond (atn-system + (apply #'graph-atn-system atn-system keys)) + (t + (warn "grammar not parsed: ~s." + (subseq *grammar 0 (min (length *grammar) 128))))))) + + (:method ((stream stream) &rest keys &key &allow-other-keys) + "read a bnf grammar from a stream into a buffer and continue processing on that." + (flet ((stream->string (stream &aux (buffer (make-array 0 :element-type 'character + :adjustable t + :fill-pointer 0)) + character) + (loop (unless (setf character (read-char stream nil nil)) + (return buffer)) + (vector-push-extend character buffer)))) + (apply #'graph-atn-system (stream->string stream) keys))) + + (:method ((*grammar-pathname pathname) &rest keys + &key (dot-pathname (make-pathname :type "dot" :defaults *grammar-pathname)) + &allow-other-keys) + "read a bnf grammar from a file and compile it to a parser." + (declare (special *grammar-pathname)) + (with-open-file (stream *grammar-pathname :direction :input) + (apply #'graph-atn-system stream + :dot-pathname dot-pathname + keys)))) + + +(defgeneric dot-edge-label (edge) + (:method ((edge atn-edge)) + (with-output-to-string (stream) (write edge :stream stream :pretty t))) + (:method ((edge cat-atn-edge)) + (format nil "(cat ~A)" (category-name (atn-cat edge)))) + (:method ((object fail-atn-edge)) + "fail") + (:method ((object jump-atn-edge)) + "jump") + (:method ((object pop-atn-edge)) + "pop") + (:method ((object push-atn-edge)) + (format nil "(push ~a)" (atn-start (atn-net-atn object)))) + (:method ((edge test-atn-edge)) + (format nil "(test ~A)" (atn-test edge))) + (:method ((edge word-atn-edge)) + (format nil "(word |~A|)" (atn-word edge)))) + + +(defmethod dot:context-put-graph ((context setf.dot:stream) (name atn-system) (graph atn-system) &rest args) + (apply #'dot:context-put-graph context (system-name name) graph args)) + +(defmethod dot:context-put-graph ((context setf.dot:stream) (name t) (graph atn-system) &rest attributes) + "Encode an atn system as a .dot graph. + Encode each ATN as its own subgraph with internal links for end and fail transitions and + inter-net edges for push nodes." + + (flet ((put-atn-graph () + (context-put-atn-system-graph context graph))) + (apply #'dot:context-put-graph context name #'put-atn-graph + :fontname "courier" + :edge '(:fontname "courier") + :node '(:fontname "courier") + attributes))) + + +(defmethod dot:context-put-node ((context setf.dot:stream) (object atn) &rest attributes) + (apply #'dot:context-put-node context (atn-name object) attributes)) + +(defmethod dot:context-put-node ((context setf.dot:stream) (object atn-node) &rest attributes) + (apply #'dot:context-put-node context (atn-name object) attributes)) + +(defmethod dot:context-put-edge ((context setf.dot:stream) (from atn) (to t) &rest attributes) + (apply #'dot:context-put-edge context (atn-name from) to attributes)) + +(defmethod dot:context-put-edge ((context setf.dot:stream) (from atn-node) (to t) &rest attributes) + (apply #'dot:context-put-edge context (atn-name from) to attributes)) + + +(defgeneric context-put-atn-system-graph (context atn-system) + (:method ((context t) (system atn-system)) + (dot:context-put-node dot:*context* system :label "START") + (dolist (atn (system-nets system)) + (flet ((put-net-subgraph-nodes () + (context-put-atn-nodes context atn))) + (dot:context-put-graph context (setf (dot:context-id context atn) (gensym "cluster")) #'put-net-subgraph-nodes + :strict nil + :statement-type 'setf.dot:subgraph))) + (dolist (atn (system-nets system)) + (context-put-atn-edges context atn)) + ;; these after, in order to use the proper atn id, + (dot:context-put-edge context system (atn-start (system-main-net system))))) + + +(defgeneric context-put-atn-nodes (context atn) + (:method ((context t) (object atn)) + (dot:context-put-node context object) + (dolist (node (atn-nodes object)) + (dot:context-put-node context node)))) + +(defgeneric context-put-atn-edges (context atn) + (:method ((context t) (object atn)) + (dot:context-put-edge context object (atn-start-node object) :label "start") + (dolist (node (atn-nodes object)) + (context-put-atn-edges context node))) + + (:method ((context t) (object atn-node)) + (dolist (edge (atn-edges object)) + (dot:context-put-edge context object edge)))) + +(defmethod dot:context-put-edge ((context setf.dot:stream) (node1 t) (node2 atn) &rest args) + (apply #'dot:context-put-edge context node1 `(dot:subgraph . ,(dot:context-id context node2)) args)) + +(defmethod dot:context-put-edge ((context setf.dot:stream) (start atn-node) (edge atn-transition) &rest attributes &key (label (dot-edge-label edge)) &allow-other-keys) + (let ((fail (atn-fail edge)) + (end (atn-end edge))) + (apply #'dot:context-put-edge context (atn-name start) end :label label attributes) + (when fail + (apply #'dot:context-put-edge context (atn-name start) fail :label "fail" attributes)))) + +(defmethod dot:context-put-edge ((context setf.dot:stream) (start atn-node) (edge push-atn-edge) &rest attributes &key (label (dot-edge-label edge)) &allow-other-keys) + (let* ((net (atn-net-atn edge)) + (net-start (atn-start-node net)) + (end (atn-end edge)) + (fail (atn-fail edge))) + (apply #'dot:context-put-edge context start net-start :label label attributes) + (apply #'dot:context-put-edge context (atn-name start) end :label label attributes) + (when fail + (apply #'dot:context-put-edge context (atn-name start) fail :label "fail" attributes)))) + +(defmethod dot:context-put-edge ((context setf.dot:stream) (start atn-node) (edge pop-atn-edge) &rest attributes) + (let* ((net (atn-net start))) + (apply #'dot:context-put-edge context start (format nil "~a.pop" (atn-name net)) + :label "pop" + attributes))) + +(defmethod dot:context-put-edge ((context setf.dot:stream) (start atn-node) (edge or-atn-edge) &rest attributes) + ;; encode just the fail - the individual dependents are to be encoded on their own + (let ((fail (atn-fail edge))) + (when fail + (apply #'dot:context-put-edge context (atn-name start) fail :label "fail" attributes)))) + +(defmethod dot:context-put-edge ((context setf.dot:stream) (start atn-node) (edge atn-edge) &rest attributes) + (declare (ignore attributes)) + ;; by default do nothing for a non-specific edge + ) diff --git a/atn-lisp-compiler.lisp b/atn-lisp-compiler.lisp index f8ec165..008dc53 100644 --- a/atn-lisp-compiler.lisp +++ b/atn-lisp-compiler.lisp @@ -139,11 +139,18 @@ ;; token package, non-terminals to the current package (defun ensure-token (thing) - (unless (packagep *atn-token-package*) - (error "token package not bound: ~s" *atn-token-package*)) - (if (stringp thing) (Intern thing *atn-token-package*) thing)) + (assert (packagep *atn-token-package*) () + "invalid token package: ~s" *atn-token-package*) + (etypecase thing + (string (Intern thing *atn-token-package*)) + (symbol thing))) + (defun ensure-symbol (thing) - (if (stringp thing) (intern thing) thing)) + (assert (packagep *atn-source-package*) () + "invalid source package: ~s" *atn-source-package*) + (etypecase thing + (string (Intern thing *atn-source-package*)) + (symbol thing))) ;; ;; @@ -164,7 +171,8 @@ where no SOURCE-PATHNAME argument is provided, the current load pathname is used. should none be available, an error is signaled.
  • :EXECUTE when non-null, the definition is interpreted directly.
    • -
  • :PACKAGE (bound special to *ATN-TOKEN-PACKAGE*.) +
  • :SOURCE-PACKAGE retuired
    • +
  • :TOKEN-PACKAGE (bound special to *ATN-TOKEN-PACKAGE*.) specifies the package in which parsed tokens are to be found. this must agree with the implemented tokenizer. bound, by default, to *PACKAGE*.
  • :PATHNAME specifies the destination file for source to be used for compilation.
    • @@ -204,12 +212,13 @@ ((:ambiguous *atn-ambiguous) nil) ((:input-eof-function *atn-input-eof-function) '|input.is-at-end|) ((:input-function *atn-input-function) '|input.item|) - ((:package *atn-token-package*) *package*) + ((:token-package *atn-token-package*) *package*) + ((:source-package *atn-source-package*) *package*) ((:parser-name *parser-name) (system-parser-name *grammar-system)) ((:register-words *atn-register-words) nil) ((:start-name *atn-start-name) (system-main-net-name *grammar-system)) ((:tokenizer-name *tokenizer-name) - (intern (concatenate 'string (string *atn-start-name) "-Tokenizer"))) + (intern (concatenate 'string (string *atn-start-name) "-Tokenizer") *atn-source-package*)) ((:trace *atn-trace*) *atn-trace*) ((:wfst *atn-wfst) *atn-ambiguous) ((:word-predicate *atn-word-predicate) 'eq) @@ -217,16 +226,21 @@ &aux ;; grammar-binding (*system-lexicon (system-lexicon *grammar-system))) - "compile an atn system. may be directly evaluated oremitted to a file and compiled from there." + "compile an atn system. may be directly evaluated or emitted to a file and compiled from there." (declare (special *grammar-system *parser-name *system-lexicon *tokenizer-name)) (declare (ignore report-recursion)) ;; to permit the compiler to be used with older parser versions + (setq *atn-source-package* (or (find-package *atn-source-package*) + "source package is invalid: ~s." *atn-source-package*)) + (setq *atn-token-package* (or (find-package *atn-token-package*) + "token package is invalid: ~s." *atn-token-package*)) + (unless (or source-pathname *compile-file-pathname*) + (error "no output pathname provided.")) + (multiple-value-bind (form name) (make-lisp-form *grammar-system) #|(setf grammar-binding `(defParameter ,(intern (concatenate 'string "*" (string name) "-GRAMMAR*")) ,(system-documentation *grammar-system)))|# - (unless (or source-pathname *compile-file-pathname*) - (error "no output pathname provided.")) (let ((output-pathname (or source-pathname (make-pathname :name (format nil "~a-grammar" *atn-start-name) :directory '(:relative "ATN-LIB") @@ -237,9 +251,9 @@ ;; rebind the reader package to this package in order to improve legibility. ;; all cl and bnfp symbols should be unprefixed. only application-specifics ;; will have prefixes - (let ((*package* (find-package "BNF-PARSER")) + (let ((*package* *atn-source-package*) (*print-right-margin* 132)) - (print `(in-package ,(package-name *package*)) stream) + (print `(in-package ,(package-name *atn-source-package*)) stream) (map nil #'(lambda (definition) (when (and (consp definition) (eq (first definition) 'defun)) (let ((parameters (third definition))) @@ -273,9 +287,15 @@ (defMethod compile-atn-system ((*grammar string) &rest keys &key ((:register-words *atn-register-words) nil) + ((:token-package *atn-token-package*) *package*) + ((:source-package *atn-source-package*) *package*) &allow-other-keys) "compile a bnf grammar to an atn system and from there to a lisp parser implementation." (declare (special *grammar)) + (setq *atn-source-package* (or (find-package *atn-source-package*) + "source package is invalid: ~s." *atn-source-package*)) + (setq *atn-token-package* (or (find-package *atn-token-package*) + "token package is invalid: ~s." *atn-token-package*)) (let ((atn-system (bnf-to-atn *grammar))) (cond (atn-system (apply #'compile-atn-system atn-system keys)) @@ -894,7 +914,7 @@ (word (atn-word node)) (word-test nil) ;; intern it into the application's package - (word-register (when *atn-register-words (intern (format nil "Word-~a" word)))) + (word-register (when *atn-register-words (intern (format nil "Word-~a" word) *atn-source-package*))) (cardinality (atn-term-cardinality atn word-register)) (term-names (atn-term-names node)) (constructor-specializer (atn-constructor-specializer node))) @@ -940,7 +960,8 @@ methods to serve as second level generation operations with a distinct operator space." (let ((name (make-lisp-predicate-name category :if-does-not-exist :create)) (elements (category-elements category))) - (when (null name) (break)) + (assert (not (null name)) () + "category name may not be null: ~s." category) `(,name (item) (%atn-trace-form (and item (or ,@(mapcar #'make-lisp-subform elements))))))) @@ -1019,7 +1040,7 @@ (defMethod make-constructor-name ((node t) name) (declare (special *undefined-constructors)) - (setf name (intern (concatenate 'string (string name) "-Constructor"))) + (setf name (intern (concatenate 'string (string name) "-Constructor") *atn-source-package*)) (unless (fboundp name) ;; (break) (pushnew name *undefined-constructors)) diff --git a/atn-parameters.lisp b/atn-parameters.lisp index cb87acb..0f8d9b5 100644 --- a/atn-parameters.lisp +++ b/atn-parameters.lisp @@ -20,8 +20,8 @@ ;; those in the form * are bound within the compiler and parser only. ;; those in the form ** have global bindings. -(defMacro defUnboundVar (name &optional documentation) - `(prog1 (defVar ,name) +(defmacro defunboundvar (name &optional documentation) + `(prog1 (defvar ,name) (makunbound ',name) #+Genera(declaim (special ,name)) ,@(when documentation @@ -29,110 +29,143 @@ (defparameter *atn-words* nil) -(defParameter *class.atn* 'atn) -(defParameter *class.atn-node* 'atn-node) -(defParameter *class.push-atn-edge* 'push-atn-edge) -(defParameter *class.pop-atn-edge* 'pop-atn-edge) -(defParameter *class.fail-atn-edge* 'fail-atn-edge) -(defParameter *class.word-atn-edge* 'word-atn-edge) -(defParameter *class.or-atn-edge* 'or-atn-edge) -(defParameter *class.test-atn-edge* 'test-atn-edge) -(defParameter *class.cat-atn-edge* 'cat-atn-edge) -(defParameter *class.jump-atn-edge* 'jump-atn-edge) -(defParameter *class.cell-atn-edge* 'cell-atn-edge) -(defParameter *class.atn-lexicon* 'atn-lexicon) -(defParameter *class.atn-cell-category* 'atn-cell-category) -(defParameter *class.atn-derived-category* 'atn-derived-category) -(defParameter *class.atn-lexem* 'atn-lexem) -(defParameter *class.atn-negated-alternatives* 'atn-negated-alternatives) -(defParameter *class.atn-conjunction* 'atn-conjunction) -(defParameter *class.atn-builtin-predicate-category* 'atn-builtin-predicate-category) -(defParameter *class.atn-undeclared-category* 'atn-undeclared-category) -(defParameter *class.atn-primitive-category* 'atn-primitive-category) -(defParameter *class.atn-complement-category* 'atn-complement-category) -(defParameter *class.atn-alternative-category* 'atn-alternative-category) - -(defUnboundVar *atn-ambiguous +(defparameter *class.atn* 'atn) +(defparameter *class.atn-node* 'atn-node) +(defparameter *class.push-atn-edge* 'push-atn-edge) +(defparameter *class.pop-atn-edge* 'pop-atn-edge) +(defparameter *class.fail-atn-edge* 'fail-atn-edge) +(defparameter *class.word-atn-edge* 'word-atn-edge) +(defparameter *class.or-atn-edge* 'or-atn-edge) +(defparameter *class.test-atn-edge* 'test-atn-edge) +(defparameter *class.cat-atn-edge* 'cat-atn-edge) +(defparameter *class.jump-atn-edge* 'jump-atn-edge) +(defparameter *class.cell-atn-edge* 'cell-atn-edge) +(defparameter *class.atn-lexicon* 'atn-lexicon) +(defparameter *class.atn-cell-category* 'atn-cell-category) +(defparameter *class.atn-derived-category* 'atn-derived-category) +(defparameter *class.atn-lexem* 'atn-lexem) +(defparameter *class.atn-negated-alternatives* 'atn-negated-alternatives) +(defparameter *class.atn-conjunction* 'atn-conjunction) +(defparameter *class.atn-builtin-predicate-category* 'atn-builtin-predicate-category) +(defparameter *class.atn-undeclared-category* 'atn-undeclared-category) +(defparameter *class.atn-primitive-category* 'atn-primitive-category) +(defparameter *class.atn-complement-category* 'atn-complement-category) +(defparameter *class.atn-alternative-category* 'atn-alternative-category) + +(defunboundvar *atn-ambiguous "specifies that code be generated to parse ambiguous grammars. this entails exhaustive parsing for disjunctive phrases and collecting multiple results. otherwise code for such phrases is exclusive, with the first result only used.") -(defUnboundVar *atn-class + +(defunboundvar *atn-class "when tracing, binds the atn node type within the parser when tracing is enabled.") -(defUnboundVar *constructor-name + +(defunboundvar *constructor-name "names the function to be used to construct instances from within the parser. bound to :CONSTRUCTOR-NAME at invocation of the compiler.") -(defUnboundVar *atn-input + +(defunboundvar *atn-input "binds the parsed input source." ) -(defUnboundVar *atn-index + +(defunboundvar *atn-index "binds the position parsed input source during reduction." ) -(defUnboundVar *atn-input-eof-function + +(defunboundvar *atn-input-eof-function "binds the name of the function to test for end of file") -(defUnboundVar *atn-input-function + +(defunboundvar *atn-input-function "binds the name of the function to get input tokens") -(defUnboundVar *atn-level + +(defunboundvar *atn-level "binds the production depth within the parser.") -(defUnboundVar *atn-net + +(defunboundvar *atn-net "when tracing, binds the name of the current atn net." ) -(defUnboundVar *atn-mode + +(defunboundvar *atn-mode "controls the reduction mode in the parser: :SINGLE continues a parse with the first result only, while :MULTIPLE, the default, continues all possibilities." ) -(defUnboundVar *atn-node + +(defunboundvar *atn-node "when tracing, binds the name of current internal node within an atn net. is null initially at the start of each a net." ) -(defUnboundVar *atn-properties + +(defunboundvar *atn-properties "when tracing, binds the parsing properties of the current net or node.") -(defVar *atn-reduce* t + +(defvar *atn-reduce* t "specifies whether the parser should reduce results.") -(defVar *atn-return-structure* nil + +(defvar *atn-return-structure* nil "governs whether the parsed structure is returned when not reducing. the default value is nil, which causes the term name to be returned as a success indicator.") -(defUnboundVar *atn-register-words + +(defunboundvar *atn-register-words "specifies whether the parser should record parsed terminal words in the result. by default nil.") -(defParameter *atn-save-definitions* t + +(defparameter *atn-runtime-files* '("ATN-package" "ATN-runtime") + "defines the files which are to be made availble to the compiled parser.") + +(defparameter *atn-save-definitions* t "when non-nil, definitions for individual non-terminal functions are saved as properties of the system name. note that this applies to the active interpretation environment only. see SYMBOL-ATN-SOURCE.") -(defUnboundVar *atn-stack + +(defvar *atn-source-package* nil + "this package is used by the compiler to intern function names for reduction functions. + it is specified to the compiler as the :SOURCE-PACKAGE keyword argument.") + +(defunboundvar *atn-stack "binds a stack of non-terminal production names within the parser.") + #+Genera(declaim (special *atn-stack)) + (defun atn-stack () (declare (special *atn-stack)) (when (boundp '*atn-stack) (copy-list *atn-stack))) -(defUnboundVar *atn-start-name + +(defunboundvar *atn-start-name "names the target production for a given parser invocation.") -(defVar *atn-structure* nil + +(defvar *atn-structure* nil "binds the last reduced result in a parse.") -(defVar *atn-term* nil + +(defvar *atn-term* nil "binds the respective terms after they have been matched or parsed as substructures. in the case of a substructure the binding is effected immediately prior to reduction. the binding is global, which means it retains the last successfully parsed term. this will differ from the *ATN-NET binding for categories which do not generate their own parse functions.") -(defVar *atn-term?* nil + +(defvar *atn-term?* nil "binds the next term for which a parse or match will be attempted.") -(defVar *atn-token-package* nil + +(defvar *atn-token-package* nil "this package is used by the compiler to intern grammar tokens. the tokenizer should intern into the same package. - bound by the compiler to the :PACKAGE keyword argument") -(defParameter *atn-runtime-files* '("ATN-package" "ATN-runtime") - "defines the files which are to be made availble to the compiled parser.") -(defParameter *atn-trace* nil + it is specified to the compiler as the :TOKEN-PACKAGE keyword argument.") + +(defparameter *atn-trace* nil "specifies whether to generate and to activate tracing code. bound to the :TRACE keywords to the compiler and respective parser.") -(defParameter *atn-trace-nets* nil + +(defparameter *atn-trace-nets* nil "determines for which, if any, nets the internal node functions are traced. bound to the :TRACE-NETS keyword respective parser.") -(defVar *atn-wfst nil + +(defvar *atn-wfst nil "during a parse this binds the 'well-formed subtree' cache with the parser. the cache is bound as a property of the system name. when compiling, a non-NULL value generated code for subtree-processing. when, as by default, NULL, no wfst is used. should be set to T for recursive grammars.") -(defUnboundVar *atn-word-predicate + +(defunboundvar *atn-word-predicate "specifies the predicate used to compare words. by default EQ.") -(defUnboundVar *system-lexicon) + +(defunboundvar *system-lexicon) :EOF diff --git a/ebnf-to-atn-translator.lisp b/ebnf-to-atn-translator.lisp index a5fa16b..af23e3d 100644 --- a/ebnf-to-atn-translator.lisp +++ b/ebnf-to-atn-translator.lisp @@ -49,7 +49,7 @@ ; (inspect bnf-grammar) (setf main-net-name (intern (bnf-name bnf-grammar))) (setf (system-parser-name atn-system) - (intern (format nil "~A-Parser" main-net-name))) + (intern (format nil "~A-Parser" main-net-name) *atn-source-package*)) (unless defined-system (setf (system-name atn-system) main-net-name)) (setf (system-main-net-name atn-system) main-net-name) @@ -437,7 +437,7 @@ (return symbol))) (ecase if-does-not-exist ((nil) nil) - (:create (intern (format nil "IS-~a" name))) + (:create (intern (format nil "IS-~a" name) *atn-source-package*)) (:error (error "no predicate for name: ~a." name)) (:warn (warn "no predicate for name: ~a." name))))) (:method ((category cl:symbol) &rest args) @@ -784,7 +784,7 @@ (build-atn-nodes *netname start (bnf-rhs object) (build-node-name)) ; (map nil #'print *netnodes) (let ((net (atn-canonic-form 'defatn - (list (intern *netname) start :nodes + (list (intern *netname *atn-source-package*) start :nodes *netnodes)))) (setf (atn-procedures net) (bnf-procedures object) (atn-terms net) (sort *expression-terms* #'name-lessp @@ -800,7 +800,7 @@ (defun build-node-name (&optional to) ;; the name must always get a suffix to distinguish terms which appear more than once (declare (special *counter *netname)) - (intern (format nil "~A~@[/~a~].~d" *netname to (incf *counter)))) + (intern (format nil "~A~@[/~a~].~d" *netname to (incf *counter)) *atn-source-package*)) (defun ensure-node (node-name) (declare (special *netnodes)) diff --git a/package.lisp b/package.lisp index 0866408..7eaf9a3 100644 --- a/package.lisp +++ b/package.lisp @@ -80,6 +80,18 @@ :funcallable-standard-class :validate-superclass) (:export + :%ATN-BLOCK + :%ATN-EDGE-BLOCK + :%ATN-NODE-BLOCK + :%ATN-TRACE + :%ATN-TRACE-FORM + :ATN-PARSE-SUBSTRUCTURE* + :|wfst-initialize| + :|wfst-adjust| + :|wfst-push| + :|wfst-entry| + :|wfst-push-entry| + :*ATN-REDUCE* :*atn-class :*atn-level :*atn-net