gecko-dev/js2/semantics/Grammar.lisp
2005-12-13 13:25:40 +00:00

1663 lines
82 KiB
Common Lisp

;;; ***** BEGIN LICENSE BLOCK *****
;;; Version: MPL 1.1/GPL 2.0/LGPL 2.1
;;;
;;; The contents of this file are subject to the Mozilla Public License Version
;;; 1.1 (the "License"); you may not use this file except in compliance with
;;; the License. You may obtain a copy of the License at
;;; http://www.mozilla.org/MPL/
;;;
;;; Software distributed under the License is distributed on an "AS IS" basis,
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
;;; for the specific language governing rights and limitations under the
;;; License.
;;;
;;; The Original Code is the Language Design and Prototyping Environment.
;;;
;;; The Initial Developer of the Original Code is
;;; Netscape Communications Corporation.
;;; Portions created by the Initial Developer are Copyright (C) 1999-2002
;;; the Initial Developer. All Rights Reserved.
;;;
;;; Contributor(s):
;;; Waldemar Horwat <waldemar@acm.org>
;;;
;;; Alternatively, the contents of this file may be used under the terms of
;;; either the GNU General Public License Version 2 or later (the "GPL"), or
;;; the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
;;; in which case the provisions of the GPL or the LGPL are applicable instead
;;; of those above. If you wish to allow use of your version of this file only
;;; under the terms of either the GPL or the LGPL, and not to allow others to
;;; use your version of this file under the terms of the MPL, indicate your
;;; decision by deleting the provisions above and replace them with the notice
;;; and other provisions required by the GPL or the LGPL. If you do not delete
;;; the provisions above, a recipient may use your version of this file under
;;; the terms of any one of the MPL, the GPL or the LGPL.
;;;
;;; ***** END LICENSE BLOCK *****
;;;
;;; LALR(1) and LR(1) grammar generator
;;;
;;; Waldemar Horwat (waldemar@acm.org)
;;;
;;; ------------------------------------------------------------------------------------------------------
;;; TERMINALSETS
;;; A set of terminals is a bitset represented by an integer, indexed by terminal numbers.
(deftype terminalset () 'integer)
(defconstant *empty-terminalset* 0)
(defconstant *full-terminalset* -1)
; Return true if terminalset is empty.
(declaim (inline terminalset-empty?))
(defun terminalset-empty? (terminalset)
(zerop terminalset))
; Return true if the two terminalsets are equal.
(declaim (inline terminalset-=))
(defun terminalset-= (terminalset1 terminalset2)
(= terminalset1 terminalset2))
; Return true if the terminalset1 is a subset of (or equal to) terminalset2.
(declaim (inline terminalset-<=))
(defun terminalset-<= (terminalset1 terminalset2)
(zerop (logandc2 terminalset1 terminalset2)))
; Return true if the two terminalsets are disjoint.
(declaim (inline terminalsets-disjoint))
(defun terminalsets-disjoint (terminalset1 terminalset2)
(zerop (logand terminalset1 terminalset2)))
; Return the complement of the terminalset.
(declaim (inline terminalset-complement))
(defun terminalset-complement (terminalset)
(lognot terminalset))
; Return the intersection of the two terminalsets.
(declaim (inline terminalset-intersection))
(defun terminalset-intersection (terminalset1 terminalset2)
(logand terminalset1 terminalset2))
(define-modify-macro terminalset-intersection-f (terminalset2) terminalset-intersection)
; Return the union of the two terminalsets.
(declaim (inline terminalset-union))
(defun terminalset-union (terminalset1 terminalset2)
(logior terminalset1 terminalset2))
(define-modify-macro terminalset-union-f (terminalset2) terminalset-union)
; Return the elements in terminalset1 that are not in terminalset2.
(declaim (inline terminalset-difference))
(defun terminalset-difference (terminalset1 terminalset2)
(logandc2 terminalset1 terminalset2))
(define-modify-macro terminalset-difference-f (terminalset2) terminalset-difference)
; Return a unique serial number for the given terminal.
(declaim (inline terminal-number))
(defun terminal-number (grammar terminal)
(assert-non-null (gethash terminal (grammar-terminal-numbers grammar))
"Can't find terminal ~S" terminal))
; Return true if the terminal is present in the terminalset.
(defun terminal-in-terminalset (grammar terminal terminalset)
(logbitp (terminal-number grammar terminal) terminalset))
; Return a one-element terminalset containing the given terminal.
(declaim (inline make-terminalset))
(defun make-terminalset (grammar terminal)
(ash 1 (terminal-number grammar terminal)))
; Return a terminalset containing all terminals in the grammar.
(defun make-full-terminalset (grammar)
(1- (ash 1 (length (grammar-terminals grammar)))))
; Call f on every terminal in the terminalset in reverse order.
(defun map-terminalset-reverse (f grammar terminalset)
(assert-true (>= terminalset 0))
(do ()
((zerop terminalset))
(let ((last (1- (integer-length terminalset))))
(funcall f (svref (grammar-terminals grammar) last))
(setq terminalset (- terminalset (ash 1 last))))))
; Return a list containing the terminals in the terminalset.
(defun terminalset-list (grammar terminalset)
(let ((terminals nil))
(map-terminalset-reverse #'(lambda (terminal) (push terminal terminals))
grammar terminalset)
terminals))
(defun print-terminalset (grammar terminalset &optional (stream t))
(let ((first t))
(dolist (terminal (terminalset-list grammar terminalset))
(if first
(setq first nil)
(format stream " ~:_"))
(write terminal :stream stream))))
;;; ------------------------------------------------------------------------------------------------------
;;; ACTIONS
;;; An action describes one semantic function associated with a production.
;;; The action code is a lisp form that evaluates to a function f that takes
;;; the following arguments:
;;; the values returned by the rhs's first grammar symbol's actions, in order of the
;;; actions of that grammar symbol;
;;; the values returned by the rhs's second grammar symbol's actions, in order of the
;;; actions of that grammar symbol;
;;; ...
;;; the values returned by the rhs's last grammar symbol's actions, in order of the
;;; actions of that grammar symbol.
;;; Function f returns one value, which is the result of this action.
(defstruct (action (:constructor make-action (type expr))
(:predicate action?))
(type nil :read-only t) ;The unparsed type of the action's result
(expr nil :read-only t)) ;The unparsed source expression that defines the action
;;; ------------------------------------------------------------------------------------------------------
;;; CONSTRAINTS
;;; A constraint modifies the rhs of a production. The constraint applies just before the pos-th
;;; general grammar symbol on the rhs of the production.
(defstruct (constraint (:constructor nil) (:copier nil) (:predicate constraint?))
(pos nil :type integer :read-only t) ;Position of this constraint; ranges between 0 and length(general-production-rhs), inclusive.
(terminalset nil :type (or null terminalset))) ;Set of allowed lookahead terminals; null until terminals are numbered
;;; A lookahead-constraint imposes a restriction on the current lookahead terminal when matching
;;; against the production. The match succeeds only if there is no following terminal or the following
;;; terminal is not present in the lookahead-constraint's list of forbidden terminals.
(defstruct (lookahead-constraint (:include constraint)
(:constructor make-lookahead-constraint (pos forbidden-terminals source))
(:predicate lookahead-constraint?))
(forbidden-terminals nil :type list :read-only t) ;List of forbidden terminals
(source nil :type list :read-only t)) ;List of grammar symbols (terminals or nonterminals) that produced the list of forbidden terminals
; Emit markup for a lookahead-constraint.
(defun depict-lookahead-constraint (markup-stream lookahead-constraint)
(depict markup-stream :begin-negative-lookahead)
(depict-list markup-stream
#'depict-production-rhs-component
(lookahead-constraint-source lookahead-constraint)
:separator ", ")
(depict markup-stream :end-negative-lookahead))
(defmethod print-object ((lookahead-constraint lookahead-constraint) stream)
(print-unreadable-object (lookahead-constraint stream)
(format stream "-~{ ~:_~W~}" (lookahead-constraint-source lookahead-constraint))))
;;; A variant-constraint succeeds only when there is no line break at the current position.
(defstruct (variant-constraint (:include constraint)
(:constructor make-variant-constraint (pos name))
(:predicate variant-constraint?))
(name nil :read-only t)) ;This variant-constraint's depict name
; Emit markup for a variant-constraint.
(defun depict-variant-constraint (markup-stream variant-constraint)
(depict markup-stream (variant-constraint-name variant-constraint)))
(defmethod print-object ((variant-constraint variant-constraint) stream)
(print-unreadable-object (variant-constraint stream)
(write (variant-constraint-name variant-constraint) :stream stream)))
;;; ------------------------------------------------------------------------------------------------------
;;; GENERALIZED PRODUCTIONS
;;; A general-production is a common base class for the production and generic-production classes.
(defstruct (general-production (:constructor nil) (:copier nil) (:predicate general-production?))
(lhs nil :type general-nonterminal :read-only t) ;The general-nonterminal on the left-hand side of this general-production
(rhs nil :type list :read-only t) ;List of general grammar symbols to which that general-nonterminal expands
(constraints nil :type list :read-only t) ;List of constraints applying to rhs, sorted by increasing pos values
(name nil :read-only t) ;This general-production's name that will be used to name the parse tree node
(highlight nil :read-only t)) ;This general-production's markup style keyword or nil if default
; If general-production is a generic-production, return its list of productions;
; if general-production is a production, return it in a one-element list.
(defun general-production-productions (general-production)
(if (production? general-production)
(list general-production)
(generic-production-productions general-production)))
; Return the general-production's rhs with constraints interleaved with the rhs general grammar symbols.
(defun general-production-rhs-components (general-production)
(labels
((merge-constraints (rhs constraints pos)
(if constraints
(let* ((constraint (first constraints))
(constraint-pos (constraint-pos constraint)))
(cond
((= constraint-pos pos)
(cons constraint (merge-constraints rhs (rest constraints) pos)))
(rhs
(cons (first rhs) (merge-constraints (rest rhs) constraints (1+ pos))))
(t (error "Bad constraint list"))))
rhs)))
(merge-constraints (general-production-rhs general-production)
(general-production-constraints general-production)
0)))
; Return the general-production's constraint's terminalset at the given position.
(defun general-production-constraint (general-production pos)
(let ((terminalset *full-terminalset*))
(dolist (constraint (general-production-constraints general-production))
(when (= (constraint-pos constraint) pos)
(terminalset-intersection-f terminalset (constraint-terminalset constraint))))
terminalset))
; Emit a markup paragraph for the left-hand-side of a general production.
(defun depict-general-production-lhs (markup-stream lhs-general-nonterminal)
(depict-paragraph (markup-stream :grammar-lhs)
(depict-general-nonterminal markup-stream lhs-general-nonterminal :definition)
(depict markup-stream " " :derives-10)))
; Emit markup for a production right-hand-side component.
(defun depict-production-rhs-component (markup-stream production-rhs-component &optional subscript)
(cond
((lookahead-constraint? production-rhs-component)
(depict-lookahead-constraint markup-stream production-rhs-component))
((variant-constraint? production-rhs-component)
(depict-variant-constraint markup-stream production-rhs-component))
(t (depict-general-grammar-symbol markup-stream production-rhs-component :reference subscript))))
; Emit a markup paragraph for the right-hand-side of a general production.
; first is true if this is the first production in a rule.
; last is true if this is the last production in a rule.
(defun depict-general-production-rhs (markup-stream general-production first last)
(depict-paragraph (markup-stream (if last :grammar-rhs-last :grammar-rhs))
(if first
(depict markup-stream :tab3)
(depict markup-stream "|" :tab2))
(let ((rhs-components (general-production-rhs-components general-production)))
(depict-list markup-stream
#'depict-production-rhs-component
rhs-components
:separator " "
:empty '(:left-angle-quote "empty" :right-angle-quote)))))
; Emit the general production, including both its left and right-hand sides.
; Include serial number subscripts on all rhs grammar symbols that both
; appear more than once in the rhs or appear in the lhs, and
; have symbols that are present in the symbols-with-subscripts list.
; link is the lhs's link type.
(defun depict-general-production (markup-stream general-production link &optional symbols-with-subscripts)
(let ((lhs (general-production-lhs general-production))
(rhs-components (general-production-rhs-components general-production))
(counts-hash (make-hash-table :test *grammar-symbol-=*)))
(when symbols-with-subscripts
(dolist (symbol symbols-with-subscripts)
(setf (gethash symbol counts-hash) 0))
(dolist (production-rhs-component (cons lhs (general-production-rhs general-production)))
(when (general-grammar-symbol? production-rhs-component)
(let ((symbol (general-grammar-symbol-symbol production-rhs-component)))
(when (gethash symbol counts-hash)
(incf (gethash symbol counts-hash))))))
(maphash #'(lambda (symbol count)
(assert-true (> count 0))
(if (> count 1)
(setf (gethash symbol counts-hash) 0)
(remhash symbol counts-hash)))
counts-hash))
(depict-general-nonterminal markup-stream lhs link (gethash (general-grammar-symbol-symbol lhs) counts-hash))
(depict markup-stream " " :derives-10)
(if rhs-components
(dolist (production-rhs-component rhs-components)
(let ((subscript nil))
(when (general-grammar-symbol? production-rhs-component)
(let ((symbol (general-grammar-symbol-symbol production-rhs-component)))
(when (gethash symbol counts-hash)
(setq subscript (incf (gethash symbol counts-hash))))))
(depict-space markup-stream)
(depict-production-rhs-component markup-stream production-rhs-component subscript)))
(depict markup-stream " " :left-angle-quote "empty" :right-angle-quote))))
;;; ------------------------------------------------------------------------------------------------------
;;; PRODUCTIONS
;;; A production describes the expansion of a nonterminal (the lhs) into
;;; a string of zero or more grammar symbols (the rhs); the rhs may also have constraints attached.
;;; Each production has a unique number. Earlier productions have smaller numbers.
;;; There is exactly one production structure for a given production, so eq can be
;;; used to test for production equality.
;;;
;;; The evaluator is a lisp form that evaluates to a function f that takes one argument --
;;; the old state of the parser's value stack -- and returns the new state of that stack.
(defstruct (production (:include general-production (lhs nil :type nonterminal :read-only t))
(:constructor make-production (lhs rhs constraints name highlight rhs-length number))
(:copier nil) (:predicate production?))
(rhs-length nil :type integer :read-only t) ;Number of grammar symbols in the rhs
(number nil :type integer :read-only t) ;This production's serial number
;The following fields are used for the action generator.
(actions nil :type list) ;List of (action-symbol . action-or-nil) in the same order as the action-symbols
; ; are listed in the grammar's action-signatures hash table for this lhs
(n-action-args nil :type (or null integer)) ;Total size of the action-signatures of all grammar symbols in the rhs
(evaluator nil :type (or null function))) ;The lisp evaluator of the action
; Return a list of terminals in this production's rhs.
; The list may contain duplicates.
(declaim (inline production-terminals))
(defun production-terminals (production)
(remove-if (complement #'terminal?) (production-rhs production)))
; Return a list of nonterminals in this production's rhs.
; The list may contain duplicates.
(declaim (inline production-nonterminals))
(defun production-nonterminals (production)
(remove-if (complement #'nonterminal?) (production-rhs production)))
(defun print-production (production &optional (stream t))
(format stream "~<~W -> ~:I~_~:[<epsilon> ~;~:*~{~W ~:_~}~]~:> ~:_[~W]"
(list (production-lhs production) (general-production-rhs-components production))
(production-name production)))
;;; ------------------------------------------------------------------------------------------------------
;;; GENERIC PRODUCTIONS
;;; A generic production describes a set of productions generated by instantiating a
;;; production with a generic nonterminal on the lhs. All productions in this set are
;;; generated by replacing the arguments in the lhs nonterminal with attributes and making
;;; corresponding replacements on the production's rhs. All productions in this set share
;;; the same name. Note that this set might not cover all productions with the same
;;; nonterminal symbol on the lhs because some parameters of the lhs nonterminal might be
;;; originally listed as attributes and not arguments.
;;; A generic production is not a production and does not have a number or actions.
(defstruct (generic-production (:include general-production (lhs nil :type generic-nonterminal :read-only t))
(:constructor make-generic-production (lhs rhs constraints name highlight productions))
(:copier nil)
(:predicate generic-production?))
(productions nil :type list :read-only t)) ;List of instantiations of this generic production
; Return a new generic-production or production with the given nonterminal argument replaced by the given attribute.
; If the resulting production isn't generic, an existing attributed production is returned.
(defun generic-production-substitute (grammar-parametrization attribute argument generic-production)
(let ((new-lhs (general-grammar-symbol-substitute attribute argument (generic-production-lhs generic-production)))
(productions (generic-production-productions generic-production)))
(if (generic-nonterminal? new-lhs)
(make-generic-production
new-lhs
(mapcar #'(lambda (grammar-symbol)
(general-grammar-symbol-substitute attribute argument grammar-symbol))
(generic-production-rhs generic-production))
(general-production-constraints generic-production)
(generic-production-name generic-production)
(generic-production-highlight generic-production)
(remove-if #'(lambda (production)
(not (general-nonterminal-is-instance? grammar-parametrization new-lhs (production-lhs production))))
productions))
(assert-non-null (find new-lhs productions :key #'production-lhs :test #'eq)))))
;;; ------------------------------------------------------------------------------------------------------
;;; GENERALIZED RULES
;;; A general-rule is a common base class for the rule and generic-rule classes.
(defstruct (general-rule (:constructor nil) (:copier nil) (:predicate general-rule?))
(productions nil :type list)) ;The list of all general productions for this rule's general nonterminal lhs
; Return this rule's lhs (which is the same for all productions).
(declaim (inline general-rule-lhs))
(defun general-rule-lhs (general-rule)
(general-production-lhs (first (general-rule-productions general-rule))))
; Return the given highlight. If it is nil, return nil and ensure that no other
; highlight (from the list given by highlights) is currently in effect in the markup-stream.
(defun check-highlight (highlight highlights markup-stream)
(if highlight
(assert-true (member highlight highlights))
(dolist (h highlights)
(ensure-no-enclosing-style markup-stream h)))
highlight)
; Return the list of general-productions, in order, gathered into runs of consecutive productions with the same highlight value.
; The result is a list of runs:
; (<highlight> <p> ... <p>),
; where each <p> is:
; (<general-production> <first> <last>),
; where <first> is true if this is the first production and <last> is true if this is the last production.
(defun gather-productions-by-highlights (general-productions)
(when general-productions
(let* ((first-production (first general-productions))
(prior-runs-reverse nil)
(current-highlight (general-production-highlight first-production))
(current-run-productions-reverse (list (list first-production t nil))))
(dolist (general-production (rest general-productions))
(let ((highlight (general-production-highlight general-production))
(p (list general-production nil nil)))
(if (eq highlight current-highlight)
(push p current-run-productions-reverse)
(progn
(push (cons current-highlight (nreverse current-run-productions-reverse)) prior-runs-reverse)
(setq current-highlight highlight)
(setq current-run-productions-reverse (list p))))))
(setf (third (first current-run-productions-reverse)) t)
(nreconc prior-runs-reverse (list (cons current-highlight (nreverse current-run-productions-reverse)))))))
; Emit markup paragraphs for the grammar general rule.
; If the rule is short enough (only one production), emit the rule on one line.
; highlights is a list of keywords that may be used to highlight specific rules or productions. It should
; be the same as the list of highlights passed to make-grammar.
(defun depict-general-rule (markup-stream general-rule highlights)
(let ((general-productions (general-rule-productions general-rule)))
(assert-true general-productions)
(let* ((production-runs (gather-productions-by-highlights general-productions))
(rule-highlight (and (endp (rest production-runs))
(check-highlight (first (first production-runs)) highlights markup-stream))))
(depict-division-style (markup-stream rule-highlight t)
(depict-division-style (markup-stream :nowrap)
(depict-division-style (markup-stream :grammar-rule)
(if (rest general-productions)
(progn
(depict-general-production-lhs markup-stream (general-rule-lhs general-rule))
(dolist (production-run production-runs)
(depict-division-style (markup-stream (check-highlight (first production-run) highlights markup-stream) t)
(dolist (p (rest production-run))
(apply #'depict-general-production-rhs markup-stream p)))))
(depict-paragraph (markup-stream :grammar-lhs-last)
(depict-general-production markup-stream (first general-productions) :definition)))))))))
;;; ------------------------------------------------------------------------------------------------------
;;; RULES
;;; A rule is the set of all productions with the same lhs nonterminal.
;;; There is exactly one rule structure for a given nonterminal lhs, so eq can be
;;; used to test for rule equality.
;;;
;;; If the rule cannot somehow produce an empty expansion, then passthrough-terminals is empty.
;;; Otherwise, passthrough-terminals summarizes the constraints imposed on the next lookahead terminal
;;; imposed by all empty expansions of this rule. If these empty expansions do not impose any
;;; lookahead-constraints, then passthrough-terminals will be the full set.
(defstruct (rule (:include general-rule (productions nil :type list :read-only t))
(:constructor make-rule (productions))
(:copier nil)
(:predicate rule?))
;productions ;The list of all productions for this rule's nonterminal lhs
(number nil :type (or null integer)) ;This nonterminal's serial number
(passthrough-terminals *empty-terminalset* :type terminalset) ;See above
(initial-terminals *empty-terminalset* :type terminalset)) ;Set of all terminals that can begin some expansion of this nonterminal
; Return a list of nonterminals in this rule's rhs.
; The list may contain duplicates.
(defun rule-nonterminals (rule)
(mapcan #'(lambda (production) (copy-list (production-nonterminals production)))
(rule-productions rule)))
; Return a unique serial number for the given nonterminal.
(defun nonterminal-number (grammar nonterminal)
(rule-number (assert-non-null (gethash nonterminal (grammar-rules grammar))
"Can't find nonterminal ~S" nonterminal)))
;;; ------------------------------------------------------------------------------------------------------
;;; GENERIC RULES
;;; A generic rule is the set of all generic productions with the same lhs generic nonterminal.
(defstruct (generic-rule (:include general-rule)
(:constructor make-generic-rule (productions))
(:copier nil)
(:predicate generic-rule?)))
; productions ;The list of all generic-productions for this rule's generic nonterminal lhs
; Return a new generic-rule with the given nonterminal argument replaced by the given attribute.
; The resulting rule must still be generic -- it is an error to call this so that it would result
; in a rule with a plain or attributed lhs nonterminal.
(defun generic-rule-substitute (grammar-parametrization attribute argument generic-rule)
(make-generic-rule
(mapcar #'(lambda (generic-production)
(assert-type (generic-production-substitute grammar-parametrization attribute argument generic-production)
generic-production))
(generic-rule-productions generic-rule))))
;;; ------------------------------------------------------------------------------------------------------
;;; GRAMMAR ITEMS
;;; An item is a tuple <prod, position>, where prod is a production and
;;; position is an integer between 0 and length(rhs(production)), inclusive.
;;; The first position elements of production's rhs are called "seen"
;;; and the rest are called "unseen".
;;; There is exactly one item structure for a given <prod, position> combination,
;;; so eq can be used to test for item equality.
(defstruct (item (:constructor allocate-item (production dot unseen number next))
(:copier nil)
(:predicate item?))
(production nil :type production :read-only t) ;The production to which this item corresponds
(dot nil :type integer :read-only t) ;List of grammar symbols to which that nonterminal expands
(unseen nil :type list :read-only t) ;Portion of production's rhs to the right of the dot
(number nil :type integer :read-only t) ;Unique number (i.e. different from any other item's number)
(next nil :type (or null item) :read-only t)) ;The item with the same production but dot shifted one to the right; nil if unseen is nil
; Return the first grammar symbol to the right of the item's dot or nil if
; the dot is already at the rightmost position.
(declaim (inline item-next-symbol))
(defun item-next-symbol (item)
(first (item-unseen item)))
; Return the lhs of the item's production.
(declaim (inline item-lhs))
(defun item-lhs (item)
(production-lhs (item-production item)))
; Return the constraints of the item's production.
(declaim (inline item-constraints))
(defun item-constraints (item)
(production-constraints (item-production item)))
; Make an item with the given production and dot location (which must be an integer
; between 0 and length(rhs(production)), inclusive. Reuse an existing item in the
; grammar if possible.
(defun make-item (grammar production dot)
(let* ((items-hash (grammar-items-hash grammar))
(key (cons production dot))
(existing-item (gethash key items-hash)))
(or
existing-item
(progn
(assert-true (<= dot (length (production-rhs production))))
(let* ((unseen (nthcdr dot (production-rhs production)))
(next (and unseen (make-item grammar production (1+ dot))))
(number (+ (* (production-number production) (1+ (grammar-max-production-length grammar))) dot)))
(setf (gethash key items-hash)
(allocate-item production dot unseen number next)))))))
(defun print-item (item &optional (stream t) after-dot)
(let ((production (item-production item)))
(format stream "~W -> ~:_" (production-lhs production))
(pprint-logical-block (stream (production-rhs production))
(do ((pos 0 (1+ pos))
(constraints (production-constraints production))
(first t))
(nil)
(when (= pos (item-dot item))
(if first
(setq first nil)
(format stream " ~:_"))
(write-char #\. stream)
(when after-dot
(format stream " ~:_~W" after-dot)))
(do ()
((or (endp constraints) (/= (constraint-pos (first constraints)) pos)))
(if first
(setq first nil)
(format stream " ~:_"))
(write (pop constraints) :stream stream))
(pprint-exit-if-list-exhausted)
(if first
(setq first nil)
(format stream " ~:_"))
(write (pprint-pop) :stream stream)))))
(defmethod print-object ((item item) stream)
(print-unreadable-object (item stream)
(format stream "item ~@_")
(print-item item stream)))
;;; ------------------------------------------------------------------------------------------------------
;;; GRAMMAR LAITEMS
;;; A laitem is an item with associated lookahead information.
;;; Unlike items, laitem structures are not shared among the states.
(defstruct (laitem (:constructor allocate-laitem (grammar item forbidden lookaheads))
(:copier nil)
(:predicate laitem?))
(grammar nil :type grammar :read-only t) ;The grammar to which this laitem belongs
(item nil :type item :read-only t) ;The item to which this laitem corresponds
(forbidden nil :type terminalset) ;A set of terminals that must not occur after the dot because of lookahead-constraints
(lookaheads nil :type terminalset) ;Set of lookahead terminals
(propagates nil :type list)) ;List of (laitem . mask) to which lookaheads propagate from this laitem (see note below)
;When parsing a LALR(1) grammar, propagates contains all laitems (in this and other states)
;to which lookaheads propagate from this laitem. The mask in each entry of propagates
;is a terminalset that indicates which lookaheads can propagate; this is usually *full-terminalset*
;but can be smaller in the presence of constraints.
;When parsing a LR(1) grammar, propagates is the list of all laitems to which lookaheads propagate from this laitem
;without following a shift transition. Such laitems must necessarily be in the same state. In the LR(1) case each
;laitem listed in the propagates list must come after this laitem in this state's laitems list.
; Add or modify a propagation entry in src-laitem to point to dst-laitem with
; the given mask.
(defun laitem-add-propagation (src-laitem dst-laitem mask)
(let ((propagation-entry (assoc dst-laitem (laitem-propagates src-laitem))))
(if propagation-entry
(terminalset-union-f (cdr propagation-entry) mask)
(push (cons dst-laitem mask) (laitem-propagates src-laitem)))))
(defvar *lookahead-print-column* 70)
(defun print-laitem (laitem &optional (stream t))
(let* ((grammar (laitem-grammar laitem))
(item (laitem-item laitem))
(forbidden (laitem-forbidden laitem))
(forbidden-as-constraint
(and (not (terminalset-empty? forbidden))
(let ((forbidden-terminals (terminalset-list grammar forbidden)))
(make-lookahead-constraint (item-dot item) forbidden-terminals forbidden-terminals)))))
(print-item item stream forbidden-as-constraint)
(format stream " ~vT~_" *lookahead-print-column*)
(pprint-logical-block (stream nil :prefix "{" :suffix "}")
(print-terminalset grammar (laitem-lookaheads laitem) stream))))
(defmethod print-object ((laitem laitem) stream)
(print-unreadable-object (laitem stream)
(format stream "laitem ~@_")
(print-laitem laitem stream)))
;;; ------------------------------------------------------------------------------------------------------
;;; GRAMMAR TRANSITIONS
;;; A grammar transition is one of the following:
;;; (:shift state) ;Shift and go to the given state
;;; (:reduce production) ;Reduce by the given production
;;; (:accept) ;Accept the input
(declaim (inline make-shift-transition))
(defun make-shift-transition (state)
(assert-type state state)
(list :shift state))
(declaim (inline make-reduce-transition))
(defun make-reduce-transition (production)
(assert-type production production)
(list :reduce production))
(declaim (inline make-accept-transition))
(defun make-accept-transition ()
(list :accept))
(declaim (inline transition-kind))
(defun transition-kind (transition)
(first transition))
(declaim (inline transition-state))
(defun transition-state (transition)
(assert-true (eq (first transition) :shift))
(second transition))
(defun (setf transition-state) (state transition)
(assert-true (eq (first transition) :shift))
(setf (second transition) state))
(declaim (inline transition-production))
(defun transition-production (transition)
(assert-true (eq (first transition) :reduce))
(second transition))
(defun print-transition (transition stream)
(case (transition-kind transition)
(:shift (format stream "shift S~D" (state-number (transition-state transition))))
(:reduce (format stream "reduce ~W" (production-name (transition-production transition))))
(:accept (format stream "accept"))
(t (error "Bad transition: ~S" transition))))
;;; ------------------------------------------------------------------------------------------------------
;;; GRAMMAR STATES
(defstruct (state (:constructor allocate-state (number kernel laitems))
(:copier nil)
(:predicate state?))
(number nil :type integer :read-only t) ;Serial number of the state
(kernel nil :type list) ;List of kernel items [list of (item . lookahead) for canonical LR(1)] in order of increasing item-number values
(laitems nil :type list) ;List of laitems
(transitions nil :type list) ;List of (terminal . transition). A null terminal indicates "all terminals".
(gotos nil :type list)) ;List of (nonterminal . state)
; Return the transition for the given terminal or nil if there is none.
(defun state-transition (state terminal)
(let ((transitions (state-transitions state)))
(cdr
(or (assoc terminal transitions :test *grammar-symbol-=*)
(assoc nil transitions :test *grammar-symbol-=*)))))
; If the state has the same transition for every terminal, return that transition;
; otherwise return nil.
(defun state-only-transition (state)
(let ((transitions (state-transitions state)))
(and transitions
(null (cdr transitions))
(null (caar transitions))
(cdar transitions))))
; If all outgoing transitions from the state are the same reduction, return that
; reduction's production; otherwise return nil.
(defun forwarding-state-production (state)
(let ((transitions (state-transitions state)))
(and transitions
(let ((transition (cdar transitions)))
(and (eq (transition-kind transition) :reduce)
(null (rassoc transition (cdr transitions) :test (complement #'equal)))
(transition-production transition))))))
; Return the laitem corresponding to the given item in the given state.
(declaim (inline state-laitem))
(defun state-laitem (state item)
(assert-non-null (find item (state-laitems state) :key #'laitem-item)
"State ~S doesn't have item ~S" state item))
; Return true if this laitem is in the state's kernel either because the dot
; is not at the leftmost position or because the lhs is the start nonterminal.
(defun laitem-in-kernel? (laitem)
(let ((item (laitem-item laitem)))
(or (not (zerop (item-dot item)))
(grammar-symbol-= (item-lhs item) *start-nonterminal*))))
; Return the state's list of laitems sorted by the criteria below.
; Criterion 1 is the major sorting order, criterion 2 decides the sorting order of items
; equal by criterion 1, etc.
; 1. laitems whose lhs matches the lhs of any kernel item in this state come before
; laitems whose lhs does not match the lhs of any kernel item in this state.
; 2. laitems are sorted by the number of their lhs nonterminal.
; 3. laitems in this state's kernel come before laitems not in the kernel.
; 4. laitems earlier in (state-laitems state) come before laitems later in (state-laitems state).
(defun laitems-sorted-nicely (state)
(let ((laitems (copy-list (state-laitems state))))
(when laitems
(let ((grammar (laitem-grammar (first laitems))))
(labels
((lhs-matches-some-kernel-item (lhs-nonterminal)
(member lhs-nonterminal (state-kernel state)
:test *grammar-symbol-=*
:key #'(lambda (kernel-item)
(when (consp kernel-item)
(setq kernel-item (car kernel-item)))
(item-lhs kernel-item))))
(laitem-< (laitem1 laitem2)
(let* ((item1 (laitem-item laitem1))
(item2 (laitem-item laitem2))
(lhs1 (item-lhs item1))
(lhs2 (item-lhs item2))
(lhs-number-1 (nonterminal-number grammar lhs1))
(lhs-number-2 (nonterminal-number grammar lhs2))
(item1-lhs-matches-some-kernel-item (lhs-matches-some-kernel-item lhs1))
(item2-lhs-matches-some-kernel-item (lhs-matches-some-kernel-item lhs2)))
(cond
((and item1-lhs-matches-some-kernel-item (not item2-lhs-matches-some-kernel-item)) t)
((and (not item1-lhs-matches-some-kernel-item) item2-lhs-matches-some-kernel-item) nil)
((< lhs-number-1 lhs-number-2) t)
((> lhs-number-1 lhs-number-2) nil)
(t (let ((item1-in-kernel (laitem-in-kernel? laitem1))
(item2-in-kernel (laitem-in-kernel? laitem2)))
(cond
((and item1-in-kernel (not item2-in-kernel)) t)
((and (not item1-in-kernel) item2-in-kernel) nil)
(t (dolist (state-laitem (state-laitems state) nil)
(cond
((eq state-laitem laitem2) (return nil))
((eq state-laitem laitem1) (return t))))))))))))
(stable-sort laitems #'laitem-<))))))
(defun print-state (state &optional (stream t))
(pprint-logical-block (stream nil)
(format stream "S~D:" (state-number state))
(pprint-indent :block 2 stream)
(pprint-newline :mandatory stream)
(pprint-logical-block (stream (laitems-sorted-nicely state))
(do ((first t nil))
(nil)
(pprint-exit-if-list-exhausted)
(unless first
(pprint-newline :mandatory stream))
(let ((laitem (pprint-pop)))
(pprint-logical-block (stream nil)
(unless (laitem-in-kernel? laitem)
(write-string " " stream))
(pprint-indent :block 4 stream)
(print-laitem laitem stream)))))
(when (state-transitions state)
(pprint-newline :mandatory stream)
(pprint-logical-block (stream (collect-equivalences (state-transitions state) :test #'equal) :prefix "Transitions: ")
(loop
(pprint-exit-if-list-exhausted)
(let ((transition-cons (pprint-pop)))
(pprint-logical-block (stream nil)
(let ((terminals (car transition-cons)))
(if (equal terminals '(nil))
(write-string "any" stream)
(pprint-fill stream terminals nil)))
(format stream " ~2I~_=> ")
(print-transition (cdr transition-cons) stream))
(format stream " ~:_")))))
(when (state-gotos state)
(pprint-newline :mandatory stream)
(pprint-logical-block (stream (state-gotos state) :prefix "Gotos: ")
(loop
(pprint-exit-if-list-exhausted)
(let ((goto-cons (pprint-pop)))
(format stream "~@<~W ~:_=> ~:_S~D~:> ~:_" (car goto-cons) (state-number (cdr goto-cons)))))))))
(defmethod print-object ((state state) stream)
(print-unreadable-object (state stream)
(format stream "state S~D" (state-number state))))
;;; ------------------------------------------------------------------------------------------------------
;;; PARAMETER TREES
;;; A parameter tree describes which nonterminal parameters are generic and which are specific in all
;;; productions derived from the same nonterminal symbol. The tree has as many levels as there are
;;; parameters for that nonterminal symbol. A level is generic if it is generic in all applicable
;;; productions; otherwise it is specific.
;;;
;;; The parameter tree (and each of its subtrees) can have one of three forms:
;;; (:rule <general-rule>)
;;; if the generic nonterminal has no remaining parameters;
;;; (:argument <argument> <parameter-subtree>)
;;; if the first remaining nonterminal parameter is an argument in all productions seen so far;
;;; (:attributes <argument-or-nil> (<attribute> . <parameter-subtree>) (<attribute> . <parameter-subtree>) ...)
;;; if the first remaining nonterminal parameter can be one of several attributes in productions seen so far;
;;; if argument-or-nil is not nil, it is an argument that includes all of the provided attributes.
;;;
;;; The parameter tree (and each of its subtrees) is mutable and updated in place.
;;;
; Create and return an initial parameter tree for the given remaining parameters
; of the general-production.
(defun make-parameter-subtree (grammar parameters general-production)
(cond
(parameters
(let ((parameter (first parameters))
(subtree (make-parameter-subtree grammar (rest parameters) general-production)))
(if (nonterminal-argument? parameter)
(list :argument parameter subtree)
(list :attributes nil (cons parameter subtree)))))
((production? general-production)
(list :rule (grammar-rule grammar (production-lhs general-production))))
(t
(assert-true (generic-production? general-production))
(list :rule (make-generic-rule (list general-production))))))
; Create and return an initial parameter tree for the general-production.
(defun make-parameter-tree (grammar general-production)
(make-parameter-subtree grammar
(general-nonterminal-parameters (general-production-lhs general-production))
general-production))
; The parameter subtree has kind :argument at its top level. Convert it in place
; into kind :attributes.
(defun parameter-subtree-divide-argument (grammar parameter-subtree)
(let ((argument (second parameter-subtree))
(argument-subtree (third parameter-subtree)))
(labels
((substitute-argument-with (attribute subtree)
(ecase (first subtree)
(:rule
(let* ((general-rule (second subtree))
(lhs (general-rule-lhs general-rule))
(new-lhs (general-grammar-symbol-substitute attribute argument lhs)))
(assert-true (generic-rule? general-rule))
(list :rule
(if (generic-nonterminal? new-lhs)
(generic-rule-substitute grammar attribute argument general-rule)
(grammar-rule grammar new-lhs)))))
(:argument
(list :argument
(second subtree)
(substitute-argument-with attribute (third subtree))))
(:attributes
(list :attributes
(second subtree)
(mapcar #'(lambda (argument-subtree-binding)
(cons (car argument-subtree-binding)
(substitute-argument-with attribute (cdr argument-subtree-binding))))
(cddr subtree))))))
(create-attribute-subtree-binding (attribute)
(cons attribute (substitute-argument-with attribute argument-subtree))))
(setf (first parameter-subtree) :attributes)
(setf (cddr parameter-subtree)
(mapcar #'create-attribute-subtree-binding
(grammar-parametrization-lookup-argument grammar argument))))))
; Mutate the parameter subtree to add the general-production to its rules.
; parameters are the nonterminal parameters for the remaining subtree levels.
(defun parameter-subtree-add-production (grammar parameter-subtree parameters general-production)
(let ((lhs (general-production-lhs general-production))
(kind (first parameter-subtree)))
(cond
((eq kind :rule)
(let ((general-rule (second parameter-subtree)))
(cond
(parameters
(error "Extra nonterminal parameters ~S for ~S" parameters lhs))
((production? general-production)
(assert-true (member general-production (rule-productions general-rule) :test #'eq)))
(t
(assert-true (generic-production? general-production))
(assert-true (not (member general-production (generic-rule-productions general-rule) :test #'eq)))
(setf (generic-rule-productions general-rule)
(nconc (generic-rule-productions general-rule) (list general-production)))))))
((null parameters)
(error "Missing nonterminal parameters in ~S" lhs))
(t
(let ((parameter (first parameters))
(parameters-rest (rest parameters)))
(ecase kind
(:argument
(let ((argument (second parameter-subtree))
(argument-subtree (third parameter-subtree)))
(if (nonterminal-argument? parameter)
(if (eq parameter argument)
(parameter-subtree-add-production grammar argument-subtree parameters-rest general-production)
(error "Nonterminal argument conflict: ~S vs. ~S" parameter argument))
(progn
(parameter-subtree-divide-argument grammar parameter-subtree)
(parameter-subtree-add-production grammar parameter-subtree parameters general-production)))))
(:attributes
(let ((argument (second parameter-subtree))
(attribute-subtree-bindings (cddr parameter-subtree)))
(if (nonterminal-argument? parameter)
(let ((argument-attributes (grammar-parametrization-lookup-argument grammar parameter)))
(labels
((add-attribute-production (attribute-subtree-binding)
(let ((attribute (car attribute-subtree-binding)))
(unless (member attribute argument-attributes :test #'eq)
(error "Attribute ~S is not a member of argument ~S" attribute parameter))
(parameter-subtree-add-production
grammar
(cdr attribute-subtree-binding)
parameters-rest
(generic-production-substitute grammar attribute parameter general-production)))))
(cond
((null argument)
(mapc #'add-attribute-production attribute-subtree-bindings)
(setf (cddr parameter-subtree)
(nconc attribute-subtree-bindings
(mapcan #'(lambda (attribute)
(unless (assoc attribute attribute-subtree-bindings :test #'eq)
(list
(cons attribute
(make-parameter-subtree
grammar
parameters-rest
(generic-production-substitute grammar attribute parameter general-production))))))
argument-attributes)))
(setf (second parameter-subtree) parameter))
((eq parameter argument)
(assert-true (= (length attribute-subtree-bindings) (length argument-attributes)))
(mapc #'add-attribute-production attribute-subtree-bindings))
(t (error "Nonterminal argument conflict: ~S vs. ~S" parameter argument)))))
(let ((attribute-subtree-binding (assoc parameter attribute-subtree-bindings :test #'eq)))
(cond
(attribute-subtree-binding
(parameter-subtree-add-production grammar (cdr attribute-subtree-binding) parameters-rest general-production))
(argument
(error "Attribute ~S is not a member of argument ~S" parameter argument))
(t
(setf (cddr parameter-subtree)
(nconc attribute-subtree-bindings
(list (cons parameter
(make-parameter-subtree grammar parameters-rest general-production)))))))))))))))))
; Mutate the parameter tree to add the general-production to its rules.
(defun parameter-tree-add-production (grammar parameter-tree general-production)
(parameter-subtree-add-production grammar
parameter-tree
(general-nonterminal-parameters (general-production-lhs general-production))
general-production)
parameter-tree)
; Return a freshly consed list of all rules and generic-rules in the parameter tree.
(defun parameter-tree-general-rules (parameter-tree)
(ecase (first parameter-tree)
(:rule (list (second parameter-tree)))
(:argument (parameter-tree-general-rules (third parameter-tree)))
(:attributes
(mapcan
#'(lambda (argument-subtree-binding)
(parameter-tree-general-rules (cdr argument-subtree-binding)))
(cddr parameter-tree)))))
;;; ------------------------------------------------------------------------------------------------------
;;; GRAMMAR
(defstruct (grammar (:include grammar-parametrization)
(:constructor allocate-grammar)
(:copier nil)
(:predicate grammar?))
(terminals nil :type simple-vector :read-only t) ;Vector of all terminals (in order of terminal numbers)
(nonterminals nil :type simple-vector :read-only t) ;Vector of all nonterminals (in a depth-first order)
(nonterminals-list nil :type list :read-only t) ;List version of the nonterminals vector
(terminal-variants nil :type hash-table :read-only t) ;Hash table of terminal -> list of that terminal's variants, including the terminal itself
(terminal-terminalsets nil :type hash-table :read-only t) ;Hash table of terminal -> terminalset of that terminal's variants, including the terminal itself
(terminal-numbers nil :type hash-table :read-only t) ;Hash table of terminal -> terminal number
(terminal-actions nil :type hash-table :read-only t) ;Hash table of terminal -> list of (action-symbol . action-function-or-nil)
(rules nil :type hash-table :read-only t) ;Hash table of nonterminal -> rule
(parameter-trees nil :type hash-table :read-only t) ;Hash table of nonterminal-symbol -> parameter-tree
(max-production-length nil :type integer :read-only t) ;Maximum number of grammar symbols in the rhs of a production
(general-productions nil :type hash-table :read-only t);Hash table of production-name -> general-production
(n-productions nil :type integer :read-only t) ;Number of productions in the grammar
(highlights nil :type list :read-only t) ;List of style keywords for highlighting selected productions
;The following fields are used for the parser.
(items-hash nil :type (or null hash-table)) ;Hash table of (production . dot) -> item; nil for a cleaned grammar or a grammar without a parser
(states nil :type list) ;List of LR(0) states (in order of state numbers)
;The following fields are used for the action generator.
(action-signatures nil :type (or null hash-table))) ;Hash table of grammar-symbol -> list of (action-symbol type-or-type-expr writable)
; Return a list of the given terminal's variants, including the terminal itself.
(declaim (inline terminal-variants))
(defun terminal-variants (grammar terminal)
(or (gethash terminal (grammar-terminal-variants grammar))
(error "Can't find terminal ~S" terminal)))
; Return a terminalset of the given terminal's variants, including the terminal itself.
(declaim (inline terminal-terminalset))
(defun terminal-terminalset (grammar terminal)
(or (gethash terminal (grammar-terminal-terminalsets grammar))
(error "Can't find terminal ~S" terminal)))
; Return a rule for the given nonterminal lhs.
(defun grammar-rule (grammar lhs)
(or (gethash lhs (grammar-rules grammar))
(error "Can't find rule for ~S" lhs)))
; Return a list of general-rules that together form a partition of all productions whose lhs's
; are instances of the given lhs-general-nonterminal.
; The given lhs-general-nonterminal must have been given as the lhs for at least one general production
; source when constructing this grammar.
(defun grammar-general-rules (grammar lhs-general-nonterminal)
(if (generic-nonterminal? lhs-general-nonterminal)
(parameter-tree-general-rules (gethash (generic-nonterminal-symbol lhs-general-nonterminal) (grammar-parameter-trees grammar)))
(list (grammar-rule grammar lhs-general-nonterminal))))
; Return the start production for the grammar.
(defun grammar-start-production (grammar)
(assert-non-null (first (rule-productions (grammar-rule grammar *start-nonterminal*)))))
; Return the user (not internal) start-symbol of the grammar.
(defun gramar-user-start-symbol (grammar)
(assert-non-null (first (production-rhs (grammar-start-production grammar)))))
; Return the production with the given name in the grammar.
; The returned production may be a production or a generic-production.
; Signal an error if there is no such production.
(defun grammar-general-production (grammar production-name)
(or (gethash production-name (grammar-general-productions grammar))
(error "Production ~S not found" production-name)))
; Call f on each production in the grammar in an unspecified order.
(defun each-grammar-production (grammar f)
(maphash
#'(lambda (lhs rule)
(declare (ignore lhs))
(mapc f (rule-productions rule)))
(grammar-rules grammar)))
; Return the starting state for the grammar.
(defun grammar-start-state (grammar)
(assert-non-null (first (grammar-states grammar))))
; Return the state numbered n in the grammar.
(defun grammar-state (grammar n)
(assert-non-null (nth n (grammar-states grammar))))
; Return two values:
; a generate terminalset G;
; a passthrough terminalset P.
;
; G is the terminalset of all terminals x that satisfy
; symbol ==>* x rest,
; where rest is an arbitrary string of grammar symbols.
;
; P is the terminalset of all terminals x that satisfy
; symbol x ==> x
(defun symbol-initial-terminals (grammar symbol)
(assert-type symbol grammar-symbol)
(if (nonterminal? symbol)
(let ((rule (grammar-rule grammar symbol)))
(values (rule-initial-terminals rule) (rule-passthrough-terminals rule)))
(values (terminal-terminalset grammar symbol) *empty-terminalset*)))
; Given an arbitrary string of grammar symbols, a list of constraints, and an initial position,
; return two values:
; a generate terminalset G;
; a passthrough terminalset P.
;
; G is the terminalset of all terminals x that satisfy
; symbol-string ==>* x rest,
; where rest is an arbitrary string of grammar symbols.
;
; P is the terminalset of all terminals x that satisfy
; symbol-string x ==> x
;
; The constraints' positions are relative to the given initial position, which specifies the position
; of the first grammar-symbol in the symbol-string. The constraints must be listed in order of
; increasing positions. If ignore-initial-constraints is true, ignore the constraints located at pos
; but include the constraints at subsequent positions if applicable.
(defun string-initial-terminals (grammar symbol-string constraints pos ignore-initial-constraints)
(do ((symbol-string symbol-string (cdr symbol-string))
(pos pos (1+ pos))
(initial-terminals *empty-terminalset*)
(passthrough-terminals *full-terminalset*))
((terminalset-empty? passthrough-terminals) (values initial-terminals *empty-terminalset*))
(if ignore-initial-constraints
(setq ignore-initial-constraints nil)
(dolist (constraint constraints)
(when (= (constraint-pos constraint) pos)
(terminalset-intersection-f passthrough-terminals (constraint-terminalset constraint)))))
(if symbol-string
(multiple-value-bind (generate passthrough) (symbol-initial-terminals grammar (first symbol-string))
(terminalset-union-f initial-terminals (terminalset-intersection passthrough-terminals generate))
(terminalset-intersection-f passthrough-terminals passthrough))
(return (values initial-terminals passthrough-terminals)))))
; Intern attributed or generic nonterminals in the production's lhs and rhs. Replace
; (:- <terminal> ... <terminal>) or (:-- (<grammar-symbol> ... <grammar-symbol>) <terminal> ... <terminal>)
; sublists in the rhs with lookahead-constraints and put these, in order, after the fourth element of
; the returned list. Also replace variant constraint symbols with variant-constraints.
; The variant-constraint-names parameter should be a list of possible variant constraint symbols.
; Return the resulting production source.
(defun intern-production-source (grammar-parametrization variant-constraint-names highlights production-source)
(assert-type production-source (tuple (or user-nonterminal cons) (list (or user-grammar-symbol cons)) identifier t))
(let ((production-lhs-source (first production-source))
(production-rhs-source (second production-source))
(production-name (third production-source))
(production-highlight (fourth production-source)))
(unless (or (null production-highlight) (member production-highlight highlights :test #'eq))
(error "Bad highlight in rule: ~S; allowed highlights are ~S" production-source highlights))
(if (or (consp production-lhs-source) (some #'consp production-rhs-source) (intersection variant-constraint-names production-rhs-source))
(multiple-value-bind (lhs-nonterminal lhs-arguments) (grammar-parametrization-intern grammar-parametrization production-lhs-source)
(let ((rhs nil)
(constraints nil)
(pos 0))
(dolist (component-source production-rhs-source)
(cond
((and (consp component-source) (eq (first component-source) :-))
(let ((lookaheads (rest component-source)))
(push
(make-lookahead-constraint pos (assert-non-null lookaheads) lookaheads)
constraints)))
((and (consp component-source) (eq (first component-source) :--))
(let ((lookaheads (rest component-source)))
(push
(make-lookahead-constraint pos (assert-non-null (rest lookaheads)) (assert-non-null (first lookaheads)))
constraints)))
((member component-source variant-constraint-names)
(push (make-variant-constraint pos component-source) constraints))
(t
(push (grammar-parametrization-intern grammar-parametrization component-source lhs-arguments) rhs)
(incf pos))))
(list* lhs-nonterminal (nreverse rhs) production-name production-highlight (nreverse constraints))))
production-source)))
; Make a grammar structure out of a grammar in source form.
; A grammar-source is a list of productions; each production is a list of:
; a nonterminal A (the lhs);
; a list of grammar symbols forming A's expansion (the rhs);
; a production name;
; a highlight keyword or nil.
; Nonterminals in the lhs and rhs can be parametrized; in this case such a nonterminal
; is represented by a list whose first element is the name and the remaining elements are
; the arguments or attributes. Any nonterminal argument in the rhs must also be an argument
; of the lhs nonterminal. The lhs nonterminal must not have duplicate arguments. The lhs
; nonterminal can have attributes, thereby designating a specialization instead of a fully
; generic production.
;
; variant-constraint-names should be a list of keywords that are variant-constraints instead of nonterminals
;
; A variant-generator is either nil or a function that takes a terminal and outputs a list of its variants.
; Each variant is specified as a cons of:
; A variant terminal (may be eql to the original terminal; this lets one add constraints that exclude the original terminal)
; A list of names of variant constraints which exclude this variant terminal
;
; The rhs can also contain lookahead constraints of the form
; (:- <terminal> ... <terminal>)
; which indicate that the following terminal must not be one of the listed terminals. The form
; (:-- (<grammar-symbol> ... <grammar-symbol>) <terminal> ... <terminal>)
; does the same thing except that it prints the grammar-symbols instead of the terminals when
; the production is printed. The form
; <constraint>
; where <constraint> is a member of the variant-constraint-names list also represents a constraint on the following
; terminal; that constraint excludes all variants that were returned by variant-generator along with this constraint.
;
; excluded-nonterminals is a list of nonterminals not used in the grammar. Productions,
; including productions expanded from generic productions, that have one of these nonterminals
; on the lhs are ignored.
;
; highlights is a list of keywords that may be used to highlight specific rules or productions. Each production that includes
; a highlight as its fourth element will be rendered using the markup style specified by highlight.
(defun make-grammar (grammar-parametrization start-symbol grammar-source &key variant-constraint-names variant-generator excluded-nonterminals highlights)
(assert-type highlights (list keyword))
(let ((variant-constraint-forbid-lists (mapcar #'list variant-constraint-names))
(interned-grammar-source
(mapcar #'(lambda (production-source)
(intern-production-source grammar-parametrization variant-constraint-names highlights production-source))
grammar-source))
(rules (make-hash-table :test #'eq))
(terminals-hash (make-hash-table :test *grammar-symbol-=*))
(terminal-variants (make-hash-table :test *grammar-symbol-=*))
(general-productions (make-hash-table :test #'equal))
(production-number 0)
(max-production-length 1)
(excluded-nonterminals-hash (make-hash-table :test *grammar-symbol-=*))
(constraints nil))
;Set up excluded-nonterminals-hash. The values of the hash table are either :seen or :unseen
;depending on whether a production with the particular nonterminal has been seen yet.
(dolist (excluded-nonterminal excluded-nonterminals)
(setf (gethash (grammar-parametrization-intern grammar-parametrization excluded-nonterminal nil) excluded-nonterminals-hash)
:unseen))
;Create the starting production: *start-nonterminal* ==> start-symbol
(setf (gethash *start-nonterminal* rules)
(list (make-production *start-nonterminal* (list start-symbol) nil nil nil 1 0)))
;Create the rest of the productions.
(flet
((create-production (lhs rhs constraints name highlight)
(let ((production (make-production lhs rhs constraints name highlight (length rhs) (incf production-number))))
(push production (gethash lhs rules))
(dolist (rhs-terminal (production-terminals production))
(setf (gethash rhs-terminal terminals-hash) t))
production))
(nonterminal-excluded (nonterminal)
(and (gethash nonterminal excluded-nonterminals-hash)
(setf (gethash nonterminal excluded-nonterminals-hash) :seen))))
(dolist (production-source interned-grammar-source)
(let* ((production-lhs (first production-source))
(production-rhs (second production-source))
(production-name (third production-source))
(production-highlight (fourth production-source))
(production-constraints (cddddr production-source))
(lhs-arguments (general-grammar-symbol-arguments production-lhs)))
(setq max-production-length (max max-production-length (length production-rhs)))
(when (gethash production-name general-productions)
(error "Duplicate production name ~S" production-name))
(if lhs-arguments
(let ((productions nil))
(grammar-parametrization-each-permutation
grammar-parametrization
#'(lambda (bound-argument-alist)
(let ((instantiated-lhs (instantiate-general-grammar-symbol bound-argument-alist production-lhs)))
(unless (nonterminal-excluded instantiated-lhs)
(push (create-production
instantiated-lhs
(mapcar #'(lambda (general-grammar-symbol)
(instantiate-general-grammar-symbol bound-argument-alist general-grammar-symbol))
production-rhs)
production-constraints
production-name
production-highlight)
productions))))
lhs-arguments)
(when productions
(setf (gethash production-name general-productions)
(make-generic-production production-lhs production-rhs production-constraints production-name production-highlight (nreverse productions)))))
(unless (nonterminal-excluded production-lhs)
(setf (gethash production-name general-productions)
(create-production production-lhs production-rhs production-constraints production-name production-highlight)))))))
(when variant-generator
(dolist (terminal (hash-table-keys terminals-hash))
(dolist (variant-and-constraints (funcall variant-generator terminal))
(let ((variant (first variant-and-constraints)))
(unless (grammar-symbol-= terminal variant)
(push variant (gethash terminal terminal-variants))
(setf (gethash variant terminals-hash) t))
(dolist (constraint (rest variant-and-constraints))
(push variant (cdr (assoc constraint variant-constraint-forbid-lists))))))))
;Change all values of the rules hash table to contain rule structures
;instead of mere lists of rules. Also check that all referenced nonterminals
;have been defined.
(maphash
#'(lambda (rule-lhs rule-productions)
(dolist (rule-production rule-productions)
(dolist (grammar-symbol (production-rhs rule-production))
(when (nonterminal? grammar-symbol)
(unless (gethash grammar-symbol rules)
(error "Nonterminal ~S used but not defined" grammar-symbol))))
(dolist (constraint (production-constraints rule-production))
(push constraint constraints)
(when (lookahead-constraint? constraint)
(dolist (lookahead-terminal (lookahead-constraint-forbidden-terminals constraint))
(unless (gethash lookahead-terminal terminals-hash)
(warn "Lookahead terminal ~S not used in main grammar" lookahead-terminal)
(setf (gethash lookahead-terminal terminals-hash) t))))))
(setf (gethash rule-lhs rules)
(make-rule (nreverse rule-productions))))
rules)
;Check that all excluded nonterminals have been seen.
(maphash
#'(lambda (excluded-nonterminal seen)
(unless (eq seen :seen)
(warn "Nonterminal ~S declared excluded but not defined" excluded-nonterminal)))
excluded-nonterminals-hash)
(let ((nonterminals-list (depth-first-search
*grammar-symbol-=*
#'(lambda (nonterminal) (rule-nonterminals (gethash nonterminal rules)))
*start-nonterminal*)))
(when (/= (length nonterminals-list) (hash-table-count rules))
(let ((dead-nonterminals (set-difference (hash-table-keys rules) nonterminals-list :test *grammar-symbol-=*)))
(warn "The following nonterminals are not reachable from start: ~S" dead-nonterminals)
(setq nonterminals-list (nconc nonterminals-list dead-nonterminals))))
(let ((terminals (coerce (cons *end-marker* (sorted-hash-table-keys terminals-hash))
'simple-vector))
(terminal-terminalsets (make-hash-table :test *grammar-symbol-=*))
(nonterminals (coerce nonterminals-list 'simple-vector)))
(dotimes (n (length terminals))
(let ((terminal (svref terminals n)))
(setf (gethash terminal terminals-hash) n)
(pushnew terminal (gethash terminal terminal-variants))))
(dotimes (n (length nonterminals))
(setf (rule-number (gethash (svref nonterminals n) rules)) n))
(let ((grammar (allocate-grammar
:argument-attributes (grammar-parametrization-argument-attributes grammar-parametrization)
:terminals terminals
:nonterminals nonterminals
:nonterminals-list nonterminals-list
:terminal-variants terminal-variants
:terminal-terminalsets terminal-terminalsets
:terminal-numbers terminals-hash
:terminal-actions (make-hash-table :test *grammar-symbol-=*)
:rules rules
:parameter-trees (make-hash-table :test *grammar-symbol-=*)
:max-production-length max-production-length
:general-productions general-productions
:n-productions production-number
:highlights highlights)))
;Compute the terminalsets in the terminal-terminalsets.
(dotimes (n (length terminals))
(let ((terminal (svref terminals n))
(terminalset *empty-terminalset*))
(dolist (variant (terminal-variants grammar terminal))
(terminalset-union-f terminalset (make-terminalset grammar variant)))
(setf (gethash terminal terminal-terminalsets) terminalset)))
;Replace the cdr of each element of variant-constraint-forbid-lists with a terminalset of all
;terminals not forbidden by that constraint.
(dolist (constraint-and-forbidden-variants variant-constraint-forbid-lists)
(let ((terminalset *full-terminalset*))
(dolist (variant (rest constraint-and-forbidden-variants))
(terminalset-difference-f terminalset (ash 1 (gethash variant terminals-hash)))
(setf (rest constraint-and-forbidden-variants) terminalset))))
;Compute the terminalsets in the constraints.
(dolist (constraint constraints)
(cond
((lookahead-constraint? constraint)
(let ((terminalset *full-terminalset*))
(dolist (forbidden-terminal (lookahead-constraint-forbidden-terminals constraint))
(terminalset-difference-f terminalset (terminal-terminalset grammar forbidden-terminal)))
(setf (constraint-terminalset constraint) terminalset)))
((variant-constraint? constraint)
(setf (constraint-terminalset constraint) (assert-non-null (cdr (assoc (variant-constraint-name constraint)
variant-constraint-forbid-lists)))))
(t (error "Unknown constraint ~S" constraint))))
;Compute the values of passthrough-terminals and initial-terminals in each rule.
(do ((changed t))
((not changed))
(setq changed nil)
(dolist (nonterminal (grammar-nonterminals-list grammar))
(let ((rule (grammar-rule grammar nonterminal))
(new-initial-terminals *empty-terminalset*)
(new-passthrough-terminals *empty-terminalset*))
(dolist (production (rule-productions rule))
(multiple-value-bind (production-initial-terminals production-passthrough-terminals)
(string-initial-terminals grammar (production-rhs production) (production-constraints production) 0 nil)
(terminalset-union-f new-initial-terminals production-initial-terminals)
(terminalset-union-f new-passthrough-terminals production-passthrough-terminals)))
(unless (terminalset-= new-initial-terminals (rule-initial-terminals rule))
(assert-true (terminalset-<= (rule-initial-terminals rule) new-initial-terminals))
(setf (rule-initial-terminals rule) new-initial-terminals)
(setq changed t))
(unless (terminalset-= new-passthrough-terminals (rule-passthrough-terminals rule))
(assert-true (terminalset-<= (rule-passthrough-terminals rule) new-passthrough-terminals))
(setf (rule-passthrough-terminals rule) new-passthrough-terminals)
(setq changed t)))))
;Compute the parameter-trees entries.
(let ((parameter-trees (grammar-parameter-trees grammar)))
(dolist (production-source interned-grammar-source)
(let ((general-production (gethash (third production-source) general-productions)))
(let ((lhs-general-nonterminal (general-production-lhs general-production)))
(when (or (generic-nonterminal? lhs-general-nonterminal)
(attributed-nonterminal? lhs-general-nonterminal))
(let* ((lhs-symbol (general-grammar-symbol-symbol lhs-general-nonterminal))
(parameter-tree (gethash lhs-symbol parameter-trees)))
(if parameter-tree
(parameter-tree-add-production grammar parameter-tree general-production)
(setf (gethash lhs-symbol parameter-trees)
(make-parameter-tree grammar general-production)))))))))
grammar)))))
(defvar *name-print-column* 70)
; Print the grammar nicely.
(defun print-grammar (grammar &optional (stream t) &key (details t))
(labels
((print-production-number (n)
(format nil "P~D" n)))
(let ((production-number-width (length (print-production-number (grammar-n-productions grammar)))))
(pprint-logical-block (stream nil)
(format stream "Terminals: ~@_~<~@{~W ~:_~}~:>~:@_" (coerce (grammar-terminals grammar) 'list))
(when details
(format stream "Nonterminals: ~@_~<~@{~W ~:_~}~:>~:@_" (grammar-nonterminals-list grammar)))
;Print the rules.
(pprint-logical-block (stream (grammar-nonterminals-list grammar))
(pprint-exit-if-list-exhausted)
(format stream "Rules:")
(pprint-indent :block 2 stream)
(pprint-newline :mandatory stream)
(loop
(let* ((rule-lhs (pprint-pop))
(rule (grammar-rule grammar rule-lhs)))
(pprint-logical-block (stream nil)
(pprint-logical-block (stream (rule-productions rule) :prefix (format nil "~W " rule-lhs))
(pprint-exit-if-list-exhausted)
(format stream "-> ")
(loop
(let ((production (pprint-pop)))
(format stream "~@<~:[<epsilon> ~;~:*~{~W ~:_~}~] ~_~vT~vA [~W]~:>"
(general-production-rhs-components production) *name-print-column*
production-number-width (print-production-number (production-number production))
(production-name production)))
(pprint-exit-if-list-exhausted)
(format stream "~:@_ | ")))
(pprint-indent :block 2 stream)
(when details
(format stream "~:@_Initial terminals: ~@_")
(pprint-logical-block (stream nil)
(unless (terminalset-empty? (rule-passthrough-terminals rule))
(format stream "<epsilon> ~:_"))
(print-terminalset grammar (rule-initial-terminals rule) stream))))
(pprint-newline :mandatory stream))
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream)))
;Print the states.
(pprint-newline :mandatory stream)
(pprint-logical-block (stream (grammar-states grammar))
(pprint-exit-if-list-exhausted)
(unless (grammar-items-hash grammar)
(error "Can't print a cleaned grammar's states"))
(format stream "States:")
(pprint-indent :block 2 stream)
(pprint-newline :mandatory stream)
(loop
(print-state (pprint-pop) stream)
(pprint-newline :mandatory stream)
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream))))
(pprint-newline :mandatory stream))))
(defmethod print-object ((grammar grammar) stream)
(print-unreadable-object (grammar stream :identity t)
(write-string "grammar" stream)))
; Emit markup paragraphs for the grammar.
(defun depict-grammar (markup-stream grammar)
(depict-paragraph (markup-stream :body-text)
(depict markup-stream "Start nonterminal: ")
(depict-general-nonterminal markup-stream (gramar-user-start-symbol grammar) :reference))
(dolist (nonterminal (grammar-nonterminals-list grammar))
(unless (grammar-symbol-= nonterminal *start-nonterminal*)
(depict-general-rule markup-stream (grammar-rule grammar nonterminal) (grammar-highlights grammar)))))
; Return a list of nontrivial sets of states with the same kernels.
(defun grammar-kernel-sets (grammar)
(let ((states-hash (make-hash-table :test #'equal))
(equivalences nil))
(dolist (state (grammar-states grammar))
(push state (gethash (state-kernel state) states-hash)))
(maphash #'(lambda (kernel states)
(declare (ignore kernel))
(unless (= (length states) 1)
(push (nreverse states) equivalences)))
states-hash)
(sort equivalences #'< :key #'(lambda (equivalence)
(state-number (first equivalence))))))
; Call f on each state in the grammar, in order of state numbers.
; f should take two parameters:
; a state;
; a hash table of terminal -> transition
(defun all-state-transitions (f grammar)
(let ((transitions-hash (make-hash-table :test *grammar-symbol-=*)))
(dolist (state (grammar-states grammar))
(dolist (transition-pair (state-transitions state))
(setf (gethash (car transition-pair) transitions-hash) (cdr transition-pair)))
(funcall f state transitions-hash)
(clrhash transitions-hash))))
;;; ------------------------------------------------------------------------------------------------------
;;; YACC OUTPUT
; Print the nonterminal in a yacc-like form.
(defun yacc-print-nonterminal (nonterminal &optional (stream t))
(cond
((keywordp nonterminal)
(write-string (symbol-upper-mixed-case-name nonterminal) stream))
((attributed-nonterminal? nonterminal)
(write-string (symbol-upper-mixed-case-name (attributed-nonterminal-symbol nonterminal)) stream)
(dolist (attribute (attributed-nonterminal-attributes nonterminal))
(write-char #\_ stream)
(write-string (symbol-lower-mixed-case-name attribute) stream)))
(t (error "Bad nonterminal ~S" nonterminal))))
; Print the grammar-symbol in a yacc-like form.
(defun yacc-print-grammar-symbol (grammar-symbol &optional (stream t))
(cond
((nonterminal? grammar-symbol)
(yacc-print-nonterminal grammar-symbol stream))
((and grammar-symbol (symbolp grammar-symbol))
(let ((name (symbol-name grammar-symbol)))
(if (and (> (length name) 0) (char= (char name 0) #\$))
(write-string (string-upcase name :start 1) stream)
(format stream "\"~A\"" (string-downcase name)))))
(t (error "Don't know how to emit markup for terminal ~S" grammar-symbol))))
#|
; Print the grammar in a yacc-like form.
(defun yacc-print-grammar (grammar &optional (stream t))
|#