;;; 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 Netscape Communications Corporation are
;;; Copyright (C) 1999-2002 Netscape Communications Corporation.  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.

;;;
;;; 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))
|#