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.: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