pjs/js/semantics/Parser.lisp

;;; The contents of this file are subject to the Netscape Public License
;;; Version 1.0 (the "NPL"); you may not use this file except in
;;; compliance with the NPL.  You may obtain a copy of the NPL at
;;; http://www.mozilla.org/NPL/
;;;
;;; Software distributed under the NPL is distributed on an "AS IS" basis,
;;; WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
;;; for the specific language governing rights and limitations under the
;;; NPL.
;;;
;;; The Initial Developer of this code under the NPL is Netscape
;;; Communications Corporation.  Portions created by Netscape are
;;; Copyright (C) 1998 Netscape Communications Corporation.  All Rights
;;; Reserved.

;;;
;;; LALR(1) and LR(1) grammar generator
;;;
;;; Waldemar Horwat (waldemar@netscape.com)
;;;


;;; ------------------------------------------------------------------------------------------------------

; kernel-item-alist is a list of pairs (item . prev), where item is a kernel item
; and prev is either nil or a laitem.  kernel is a list of the kernel items in a canonical order.
; Return a new state with the given list of kernel items and state number.
; If update-propagates is true, for each non-null prev in kernel-item-alist, update
; (laitem-propagates prev) to include the corresponding laitem in the new state.  Do this anyway
; for internal lookaheads, regardless of update-propagates.
(defun make-state (grammar kernel kernel-item-alist update-propagates number initial-lookaheads)
  (let ((laitems nil)
        (laitems-hash (make-hash-table :test #'eq)))
    (labels
      ;Create a laitem for this item and add the association item->laitem to the laitems-hash
      ;hash table if it's not there already.  Regardless of whether a new laitem was created,
      ;update the laitem's lookaheads to also include the given lookaheads.
      ;forbidden is a terminalset of terminals that must not occur immediately after the dot in this
      ;laitem.  The forbidden set is inherited from constraints in parent laitems in the same state.
      ;If prev is non-null, update (laitem-propagates prev) to include the laitem and the given
      ;passthrough terminalset if it's not already included there.
      ;If a new laitem was created and its first symbol after the dot exists and is a
      ;nonterminal A, recursively close items A->.rhs corresponding to all rhs's in the
      ;grammar's rule for A.
      ((close-item (item forbidden lookaheads prev passthroughs)
         (let ((production (item-production item))
               (laitem (gethash item laitems-hash)))
           (unless (terminalset-empty? forbidden)
             (multiple-value-bind (dot-lookaheads dot-passthroughs)
                                  (string-initial-terminals grammar (item-unseen item) (production-constraints production) (item-dot item))
               (let ((dot-initial (terminalset-union dot-lookaheads dot-passthroughs)))
                 ;Check whether any terminal can start this item.  If not, skip this item altogether.
                 (when (terminalset-empty? (terminalset-difference dot-initial forbidden))
                   ;Mark skipped items in the laitems-hash table.
                   (when (and laitem (not (eq laitem 'forbidden)))
                     (error "Two laitems in the same state differing only in forbidden initial terminal constraints: ~S" laitem))
                   (setf (gethash item laitems-hash) 'forbidden)
                   (return-from close-item))
                 ;Convert forbidden into a canonical format by removing terminals that cannot begin this item's expansion anyway.
                 (terminalset-intersection-f forbidden dot-initial))))
           (if laitem
             (progn
               (unless (terminalset-= forbidden (laitem-forbidden laitem))
                 (error "Two laitems in the same state differing only in forbidden initial terminal constraints: ~S" laitem))
               (terminalset-union-f (laitem-lookaheads laitem) lookaheads))
             (let ((item-next-symbol (item-next-symbol item)))
               (setq laitem (allocate-laitem grammar item forbidden lookaheads))
               (push laitem laitems)
               (setf (gethash item laitems-hash) laitem)
               (when (nonterminal? item-next-symbol)
                 (let* ((dot (item-dot item))
                        (next-forbidden (terminalset-union forbidden
                                                           (terminalset-complement (general-production-lookahead-constraint production dot)))))
                   (multiple-value-bind (next-lookaheads next-passthroughs)
                                        (string-initial-terminals grammar (rest (item-unseen item)) (production-constraints production) (1+ dot))
                     (let ((next-prev (and (not (terminalset-empty? next-passthroughs)) laitem)))
                       (dolist (production (rule-productions (grammar-rule grammar item-next-symbol)))
                         (close-item (make-item grammar production 0) next-forbidden next-lookaheads next-prev next-passthroughs))))))))
           (when prev
             (laitem-add-propagation prev laitem passthroughs)))))
      
      (dolist (acons kernel-item-alist)
        (close-item (car acons) 
                    *empty-terminalset*
                    initial-lookaheads
                    (and update-propagates (cdr acons))
                    *full-terminalset*))
      (allocate-state number kernel (nreverse laitems)))))


; f is a function that takes three arguments:
;   a grammar symbol;
;   a list of kernel items in order of increasing item number;
;   a list of pairs (item . prev), where item is a kernel item and prev is a laitem.
; For each possible symbol X that can be shifted while in the given state S, call
; f giving it S and the list of items that constitute the kernel of that shift's destination
; state.  The prev's are the sources of the corresponding shifted items.
(defun state-each-shift-item-alist (f state)
  (let ((shift-symbols-hash (make-hash-table :test *grammar-symbol-=*)))
    (dolist (source-laitem (state-laitems state))
      (let* ((source-item (laitem-item source-laitem))
             (shift-symbol (item-next-symbol source-item)))
        (when shift-symbol
          (push (cons (item-next source-item) source-laitem)
                (gethash shift-symbol shift-symbols-hash)))))
    ;Use dolist/gethash instead of maphash to make state assignments deterministic.
    (dolist (shift-symbol (sorted-hash-table-keys shift-symbols-hash))
      (let ((kernel-item-alist (gethash shift-symbol shift-symbols-hash)))
        (funcall f shift-symbol (sort (mapcar #'car kernel-item-alist) #'< :key #'item-number) kernel-item-alist)))))


;;; ------------------------------------------------------------------------------------------------------
;;; LR(1)


; kernel-item-alist should have the same kernel items as state.
; Return true if the prev lookaheads in kernel-item-alist are the same as or subsets of
; the corresponding lookaheads in the state's kernel laitems.
(defun state-subsumes-lookaheads (state kernel-item-alist)
  (every
   #'(lambda (acons)
       (terminalset-<= (laitem-lookaheads (cdr acons))
                       (laitem-lookaheads (state-laitem state (car acons)))))
   kernel-item-alist))


; kernel-item-alist should have the same kernel items as state.
; Return true if the prev lookaheads in kernel-item-alist are weakly compatible
; with the lookaheads in the state's kernel laitems.
(defun state-weakly-compatible (state kernel-item-alist)
  (labels
    ((lookahead-weakly-compatible (lookahead1a lookahead1b lookahead2a lookahead2b)
       (or (and (terminalsets-disjoint lookahead1a lookahead2b)
                (terminalsets-disjoint lookahead1b lookahead2a))
           (not (terminalsets-disjoint lookahead1a lookahead1b))
           (not (terminalsets-disjoint lookahead2a lookahead2b))))
     
     (lookahead-list-weakly-compatible (lookahead1a lookaheads1 lookahead2a lookaheads2)
       (or (endp lookaheads1)
           (and (lookahead-weakly-compatible lookahead1a (first lookaheads1) lookahead2a (first lookaheads2))
                (lookahead-list-weakly-compatible lookahead1a (rest lookaheads1) lookahead2a (rest lookaheads2)))))
     
     (lookahead-lists-weakly-compatible (lookaheads1 lookaheads2)
       (or (endp lookaheads1)
           (and (lookahead-list-weakly-compatible (first lookaheads1) (rest lookaheads1) (first lookaheads2) (rest lookaheads2))
                (lookahead-lists-weakly-compatible (rest lookaheads1) (rest lookaheads2))))))
    
    (or (= (length kernel-item-alist) 1)
        (lookahead-lists-weakly-compatible
         (mapcar #'(lambda (acons) (laitem-lookaheads (state-laitem state (car acons)))) kernel-item-alist)
         (mapcar #'(lambda (acons) (laitem-lookaheads (cdr acons))) kernel-item-alist)))))


; Propagate all lookaheads in the state.
(defun propagate-internal-lookaheads (state)
  (dolist (src-laitem (state-laitems state))
    (let ((src-lookaheads (laitem-lookaheads src-laitem)))
      (dolist (propagation (laitem-propagates src-laitem))
        (let ((dst-laitem (car propagation))
              (mask (cdr propagation)))
          (terminalset-union-f (laitem-lookaheads dst-laitem) (terminalset-intersection src-lookaheads mask)))))))


; Propagate all lookaheads in kernel-item-alist, which must target destination-state.
; Mark destination-state as dirty in the dirty-states hash table.
(defun propagate-external-lookaheads (kernel-item-alist destination-state dirty-states)
  (dolist (acons kernel-item-alist)
    (let ((dest-laitem (state-laitem destination-state (car acons)))
          (src-laitem (cdr acons)))
      (terminalset-union-f (laitem-lookaheads dest-laitem) (laitem-lookaheads src-laitem))))
  (setf (gethash destination-state dirty-states) t))


; Make all states in the grammar and return the initial state.
; Initialize the grammar's list of states.
; Set up the laitems' propagate lists but do not propagate lookaheads yet.
; Initialize the states' gotos lists.
; Initialize the states' shift (but not reduce or accept) transitions in the transitions lists.
(defun add-all-lr-states (grammar)
  (let* ((initial-item (make-item grammar (grammar-start-production grammar) 0))
         (lr-states-hash (make-hash-table :test #'equal))  ;kernel -> list of states with that kernel
         (initial-kernel (list initial-item))
         (initial-state (make-state grammar initial-kernel (list (cons initial-item nil)) nil 0 (make-terminalset grammar *end-marker*)))
         (states (list initial-state))
         (next-state-number 1))
    (setf (gethash initial-kernel lr-states-hash) (list initial-state))
    (do ((source-states (list initial-state))
         (dirty-states (make-hash-table :test #'eq)))      ;Set of states whose kernel lookaheads changed and haven't been propagated yet
        ((and (endp source-states) (zerop (hash-table-count dirty-states))))
      (labels
        ((make-destination-state (kernel kernel-item-alist)
           (let* ((possible-destination-states (gethash kernel lr-states-hash))
                  (destination-state (find-if #'(lambda (possible-destination-state)
                                                  (state-subsumes-lookaheads possible-destination-state kernel-item-alist))
                                              possible-destination-states)))
             (cond
              (destination-state)
              ((setq destination-state (find-if #'(lambda (possible-destination-state)
                                                    (state-weakly-compatible possible-destination-state kernel-item-alist))
                                                possible-destination-states))
               (propagate-external-lookaheads kernel-item-alist destination-state dirty-states))
              (t
               (setq destination-state (make-state grammar kernel kernel-item-alist nil next-state-number *empty-terminalset*))
               (propagate-external-lookaheads kernel-item-alist destination-state dirty-states)
               (push destination-state (gethash kernel lr-states-hash))
               (incf next-state-number)
               (push destination-state states)
               (push destination-state source-states)))
             destination-state))
         
         (update-destination-state (destination-state kernel-item-alist)
           (cond
            ((state-subsumes-lookaheads destination-state kernel-item-alist)
             destination-state)
            ((state-weakly-compatible destination-state kernel-item-alist)
             (propagate-external-lookaheads kernel-item-alist destination-state dirty-states)
             destination-state)
            (t (make-destination-state (state-kernel destination-state) kernel-item-alist)))))
        
        (if source-states
          (let ((source-state (pop source-states)))
            (remhash source-state dirty-states)
            (propagate-internal-lookaheads source-state)
            (state-each-shift-item-alist
             #'(lambda (shift-symbol kernel kernel-item-alist)
                 (let ((destination-state (make-destination-state kernel kernel-item-alist)))
                   (if (nonterminal? shift-symbol)
                     (push (cons shift-symbol destination-state)
                           (state-gotos source-state))
                     (push (cons shift-symbol (make-shift-transition destination-state))
                           (state-transitions source-state)))))
             source-state))
          (dolist (dirty-state (sort (hash-table-keys dirty-states) #'< :key #'state-number))
            (when (remhash dirty-state dirty-states)
              (propagate-internal-lookaheads dirty-state)
              (state-each-shift-item-alist
               #'(lambda (shift-symbol kernel kernel-item-alist)
                   (declare (ignore kernel))
                   (if (nonterminal? shift-symbol)
                     (let* ((destination-binding (assoc shift-symbol (state-gotos dirty-state) :test *grammar-symbol-=*))
                            (destination-state (assert-non-null (cdr destination-binding))))
                       (setf (cdr destination-binding) (update-destination-state destination-state kernel-item-alist)))
                     (let* ((destination-transition (cdr (assoc shift-symbol (state-transitions dirty-state) :test *grammar-symbol-=*)))
                            (destination-state (assert-non-null (transition-state destination-transition))))
                       (setf (transition-state destination-transition)
                             (update-destination-state destination-state kernel-item-alist)))))
               dirty-state))))))
    (setf (grammar-states grammar) (nreverse states))
    initial-state))


;;; ------------------------------------------------------------------------------------------------------
;;; LALR(1)


; Make all states in the grammar and return the initial state.
; Initialize the grammar's list of states.
; Set up the laitems' propagate lists but do not propagate lookaheads yet.
; Initialize the states' gotos lists.
; Initialize the states' shift (but not reduce or accept) transitions in the transitions lists.
(defun add-all-lalr-states (grammar)
  (let* ((initial-item (make-item grammar (grammar-start-production grammar) 0))
         (lalr-states-hash (make-hash-table :test #'equal))  ;kernel -> state
         (initial-kernel (list initial-item))
         (initial-state (make-state grammar initial-kernel (list (cons initial-item nil)) t 0 (make-terminalset grammar *end-marker*)))
         (states (list initial-state))
         (next-state-number 1))
    (setf (gethash initial-kernel lalr-states-hash) initial-state)
    (do ((source-states (list initial-state)))
        ((endp source-states))
      (let ((source-state (pop source-states)))
        (state-each-shift-item-alist
         #'(lambda (shift-symbol kernel kernel-item-alist)
             (let ((destination-state (gethash kernel lalr-states-hash)))
               (if destination-state
                 (dolist (acons kernel-item-alist)
                   (laitem-add-propagation (cdr acons) (state-laitem destination-state (car acons)) *full-terminalset*))
                 (progn
                   (setq destination-state (make-state grammar kernel kernel-item-alist t next-state-number *empty-terminalset*))
                   (setf (gethash kernel lalr-states-hash) destination-state)
                   (incf next-state-number)
                   (push destination-state states)
                   (push destination-state source-states)))
               (if (nonterminal? shift-symbol)
                 (push (cons shift-symbol destination-state)
                       (state-gotos source-state))
                 (push (cons shift-symbol (make-shift-transition destination-state))
                       (state-transitions source-state)))))
         source-state)))
    (setf (grammar-states grammar) (nreverse states))
    initial-state))


; Propagate the lookaheads in the LALR(1) grammar.
(defun propagate-lalr-lookaheads (grammar)
  (let ((dirty-laitems (make-hash-table :test #'eq)))
    (dolist (state (grammar-states grammar))
      (dolist (laitem (state-laitems state))
        (when (and (laitem-propagates laitem) (not (terminalset-empty? (laitem-lookaheads laitem))))
          (setf (gethash laitem dirty-laitems) t))))
    (do ()
        ((zerop (hash-table-count dirty-laitems)))
      (dolist (dirty-laitem (hash-table-keys dirty-laitems))
        (remhash dirty-laitem dirty-laitems)
        (let ((src-lookaheads (laitem-lookaheads dirty-laitem)))
          (dolist (propagation (laitem-propagates dirty-laitem))
            (let ((dst-laitem (car propagation))
                  (mask (cdr propagation)))
              (let* ((old-dst-lookaheads (laitem-lookaheads dst-laitem))
                     (new-dst-lookaheads (terminalset-union old-dst-lookaheads (terminalset-intersection src-lookaheads mask))))
                (unless (terminalset-= old-dst-lookaheads new-dst-lookaheads)
                  (setf (laitem-lookaheads dst-laitem) new-dst-lookaheads)
                  (setf (gethash dst-laitem dirty-laitems) t))))))))
    
    ;Erase the propagates chains in all laitems.
    (dolist (state (grammar-states grammar))
      (dolist (laitem (state-laitems state))
        (setf (laitem-propagates laitem) nil)))))


;;; ------------------------------------------------------------------------------------------------------


; Calculate the reduce and accept transitions in the grammar.
; Also sort all transitions by their terminal numbers and gotos by their nonterminal numbers.
; Conflicting transitions are sorted as follows:
;    shifts come before reduces and accepts
;    accepts come before reduces
;    reduces with lower production numbers come before reduces with higher production numbers
; Disambiguation will choose the first member of a sorted list of conflicting transitions.
(defun finish-transitions (grammar)
  (dolist (state (grammar-states grammar))
    (dolist (laitem (state-laitems state))
      (let ((item (laitem-item laitem)))
        (unless (item-next-symbol item)
          (let ((lookaheads (terminalset-difference
                             (terminalset-intersection
                              (laitem-lookaheads laitem)
                              (general-production-lookahead-constraint (item-production item) (item-dot item)))
                             (laitem-forbidden laitem))))
            (if (grammar-symbol-= (item-lhs item) *start-nonterminal*)
              (when (terminal-in-terminalset grammar *end-marker* lookaheads)
                (push (cons *end-marker* (make-accept-transition))
                      (state-transitions state)))
              (map-terminalset-reverse
               #'(lambda (lookahead)
                   (push (cons lookahead (make-reduce-transition (item-production item)))
                         (state-transitions state)))
               grammar
               lookaheads))))))
    (setf (state-gotos state)
          (sort (state-gotos state) #'< :key #'(lambda (goto-cons) (state-number (cdr goto-cons)))))
    (setf (state-transitions state)
          (sort (state-transitions state)
                #'(lambda (transition-cons-1 transition-cons-2)
                    (let ((terminal-number-1 (terminal-number grammar (car transition-cons-1)))
                          (terminal-number-2 (terminal-number grammar (car transition-cons-2))))
                      (cond
                       ((< terminal-number-1 terminal-number-2) t)
                       ((> terminal-number-1 terminal-number-2) nil)
                       (t (let* ((transition1 (cdr transition-cons-1))
                                 (transition2 (cdr transition-cons-2))
                                 (transition-kind-1 (transition-kind transition1))
                                 (transition-kind-2 (transition-kind transition2)))
                            (cond
                             ((eq transition-kind-2 :shift) nil)
                             ((eq transition-kind-1 :shift) t)
                             ((eq transition-kind-2 :accept) nil)
                             ((eq transition-kind-1 :accept) t)
                             (t (let ((production-number-1 (production-number (transition-production transition1)))
                                      (production-number-2 (production-number (transition-production transition2))))
                                  (< production-number-1 production-number-2)))))))))))))


; Find ambiguities, if any, in the grammar.  Report them on the given stream.
; Fix all ambiguities in favor of the first transition listed
; (the transitions were ordered by finish-transitions).
(defun report-and-fix-ambiguities (grammar stream)
  (let ((found-ambiguities nil))
    (pprint-logical-block (stream nil)
      (dolist (state (grammar-states grammar))
        (labels
          
          ((report-ambiguity (transition-cons other-transition-conses)
             (unless found-ambiguities
               (setq found-ambiguities t)
               (format stream "~&Ambiguities:")
               (pprint-indent :block 2 stream))
             (pprint-newline :mandatory stream)
             (pprint-logical-block (stream nil)
               (format stream "S~D: ~W ~:_=> ~:_" (state-number state) (car transition-cons))
               (pprint-logical-block (stream nil)
                 (dolist (a (cons transition-cons other-transition-conses))
                   (print-transition (cdr a) stream)
                   (format stream "   ~:_")))))
           
           ; Check the list of transition-conses and report ambiguities.
           ; start is the start of a possibly larger list of transition-conses whose tail
           ; is the given list.  If ambiguities exist, return a copy of start up to the
           ; position of list in it followed by list with ambiguities removed.  If not,
           ; return start unchanged.
           (check (transition-conses start)
             (if transition-conses
               (let* ((transition-cons (first transition-conses))
                      (transition-terminal (car transition-cons))
                      (transition-conses-rest (rest transition-conses)))
                 (if transition-conses-rest
                   (if (grammar-symbol-= transition-terminal (car (first transition-conses-rest)))
                     (let ((unrelated-transitions
                            (member-if #'(lambda (a) (not (grammar-symbol-= transition-terminal (car a))))
                                       transition-conses-rest)))
                       (report-ambiguity transition-cons (ldiff transition-conses-rest unrelated-transitions))
                       (check unrelated-transitions (append (ldiff start transition-conses-rest) unrelated-transitions)))
                     (check transition-conses-rest start))
                   start))
               start)))
          
          (let ((transition-conses (state-transitions state)))
            (setf (state-transitions state) (check transition-conses transition-conses))))))
    (when found-ambiguities
      (pprint-newline :mandatory stream))))


; Erase the existing parser, if any, for the given grammar.
(defun clear-parser (grammar)
  (clrhash (grammar-items-hash grammar))
  (setf (grammar-states grammar) nil))


; Construct a LR or LALR parser in the given grammar.  kind should be either :lalr-1 or :lr-1.
; Return the grammar.
(defun compile-parser (grammar kind)
  (clear-parser grammar)
  (ecase kind
    (:lalr-1
     (add-all-lalr-states grammar)
     (propagate-lalr-lookaheads grammar))
    (:lr-1
     (add-all-lr-states grammar)))
  (finish-transitions grammar)
  (report-and-fix-ambiguities grammar *error-output*)
  grammar)


; Make the grammar and compile its parser.  kind should be either :lalr-1 or :lr-1.
(defun make-and-compile-grammar (kind parametrization start-symbol grammar-source &optional excluded-nonterminals-source)
  (compile-parser (make-grammar parametrization start-symbol grammar-source excluded-nonterminals-source)
                  kind))


;;; ------------------------------------------------------------------------------------------------------

; Parse the input list of tokens to produce a parse tree.
; token-terminal is a function that returns a terminal symbol when given an input token.
(defun parse (grammar token-terminal input)
  (labels
    (;Continue the parse with the given parser stack and remainder of input.
     (parse-step (stack input)
       (if (endp input)
         (parse-step-1 stack *end-marker* nil nil)
         (let ((token (first input)))
           (parse-step-1 stack (funcall token-terminal token) token (rest input)))))
     
     ;Same as parse-step except that the next input terminal has been determined already.
     ;input-rest contains the input tokens after the next token.
     (parse-step-1 (stack terminal token input-rest)
       (let* ((state (caar stack))
              (transition (cdr (assoc terminal (state-transitions state) :test *grammar-symbol-=*))))
         (if transition
           (case (transition-kind transition)
             (:shift (parse-step (acons (transition-state transition) token stack) input-rest))
             (:reduce (let ((production (transition-production transition))
                            (expansion nil))
                        (dotimes (i (production-rhs-length production))
                          (push (cdr (pop stack)) expansion))
                        (let* ((state (caar stack))
                               (dst-state (assert-non-null
                                           (cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
                               (named-expansion (cons (production-name production) expansion)))
                          (parse-step-1 (acons dst-state named-expansion stack) terminal token input-rest))))
             (:accept (cdar stack))
             (t (error "Bad transition: ~S" transition)))
           (error "Parse error on ~S followed by ~S ..." token (ldiff input-rest (nthcdr 10 input-rest)))))))
    
    (parse-step (list (cons (grammar-start-state grammar) nil)) input)))


;;; ------------------------------------------------------------------------------------------------------
;;; ACTIONS

; Initialize the action-signatures hash table, setting each grammar symbol's signature
; to null for now.  Also clear all production actions in the grammar.
(defun clear-actions (grammar)
  (let ((action-signatures (make-hash-table :test *grammar-symbol-=*))
        (terminals (grammar-terminals grammar))
        (nonterminals (grammar-nonterminals grammar)))
    (dotimes (i (length terminals))
      (setf (gethash (svref terminals i) action-signatures) nil))
    (dotimes (i (length nonterminals))
      (setf (gethash (svref nonterminals i) action-signatures) nil))
    (setf (grammar-action-signatures grammar) action-signatures)
    (each-grammar-production
     grammar
     #'(lambda (production)
         (setf (production-actions production) nil)
         (setf (production-n-action-args production) nil)
         (setf (production-evaluator-code production) nil)
         (setf (production-evaluator production) nil)))
    (clrhash (grammar-terminal-actions grammar))))


; Declare the type of action action-symbol, when called on general-grammar-symbol, to be type-expr.
; Signal an error on duplicate actions.
; It's OK if some of the symbol instances don't exist, as long as at least one does.
(defun declare-action (grammar general-grammar-symbol action-symbol type-expr)
  (unless (and action-symbol (symbolp action-symbol))
    (error "Bad action name ~S" action-symbol))
  (let ((action-signatures (grammar-action-signatures grammar))
        (grammar-symbols (general-grammar-symbol-instances grammar general-grammar-symbol))
        (symbol-exists nil))
    (dolist (grammar-symbol grammar-symbols)
      (let ((signature (gethash grammar-symbol action-signatures :undefined)))
        (unless (eq signature :undefined)
          (setq symbol-exists t)
          (when (assoc action-symbol signature :test #'eq)
            (error "Attempt to redefine the type of action ~S on ~S" action-symbol grammar-symbol))
          (setf (gethash grammar-symbol action-signatures)
                (nconc signature (list (cons action-symbol type-expr))))
          (if (nonterminal? grammar-symbol)
            (dolist (production (rule-productions (grammar-rule grammar grammar-symbol)))
              (setf (production-actions production)
                    (nconc (production-actions production) (list (cons action-symbol nil)))))
            (let ((terminal-actions (grammar-terminal-actions grammar)))
              (assert-type grammar-symbol terminal)
              (setf (gethash grammar-symbol terminal-actions)
                    (nconc (gethash grammar-symbol terminal-actions) (list (cons action-symbol nil)))))))))
    (unless symbol-exists
      (error "Bad action grammar symbol ~S" grammar-symbols))))


; Return the list of pairs (action-symbol . type-or-type-expr) for this grammar-symbol.
; The pairs are in order from oldest to newest action-symbols added to this grammar-symbol.
(declaim (inline grammar-symbol-signature))
(defun grammar-symbol-signature (grammar grammar-symbol)
  (gethash grammar-symbol (grammar-action-signatures grammar)))


; Return the list of action types of the grammar's user start-symbol.
(defun grammar-user-start-action-types (grammar)
  (mapcar #'cdr (grammar-symbol-signature grammar (gramar-user-start-symbol grammar))))


; If action action-symbol is declared on grammar-symbol, return two values:
;   t, and
;   the action's type-expr;
; If not, return nil.
(defun action-declaration (grammar grammar-symbol action-symbol)
  (let ((declaration (assoc action-symbol (grammar-symbol-signature grammar grammar-symbol) :test #'eq)))
    (and declaration
         (values t (cdr declaration)))))


; Call f on every action declaration, passing it two arguments:
;   the grammar-symbol;
;   a pair (action-symbol . type-expr).
; f may modify the action's type-expr.
(defun each-action-declaration (grammar f)
  (maphash #'(lambda (grammar-symbol signature)
               (dolist (action-declaration signature)
                 (funcall f grammar-symbol action-declaration)))
           (grammar-action-signatures grammar)))


; Define action action-symbol, when called on the production with the given name,
; to be action-expr.  The action should have been declared already.
(defun define-action (grammar production-name action-symbol action-expr)
  (dolist (production (general-production-productions (grammar-general-production grammar production-name)))
    (let ((definition (assoc action-symbol (production-actions production) :test #'eq)))
      (cond
       ((null definition)
        (error "Attempt to define action ~S on ~S, which hasn't been declared yet" action-symbol production-name))
       ((cdr definition)
        (error "Duplicate definition of action ~S on ~S" action-symbol production-name))
       (t (setf (cdr definition) (make-action action-expr)))))))


; Define action action-symbol, when called on the given terminal,
; to execute the given function, which should take a token as an input and
; produce a value of the proper type as output.
; The action should have been declared already.
(defun define-terminal-action (grammar terminal action-symbol action-function)
  (assert-type action-function function)
  (let ((definition (assoc action-symbol (gethash terminal (grammar-terminal-actions grammar)) :test #'eq)))
    (cond
     ((null definition)
      (error "Attempt to define action ~S on ~S, which hasn't been declared yet" action-symbol terminal))
     ((cdr definition)
      (error "Duplicate definition of action ~S on ~S" action-symbol terminal))
     (t (setf (cdr definition) action-function)))))



; Parse the input list of tokens to produce a list of action results.
; token-terminal is a function that returns a terminal symbol when given an input token.
; If trace is:
;   nil,     don't print trace information
;   :code,   print trace information, including action code
;   other    print trace information
; Return two values:
;   the list of action results;
;   the list of action results' types.
(defun action-parse (grammar token-terminal input &key trace)
  (labels
    (;Continue the parse with the given stacks and remainder of input.
     (parse-step (state-stack value-stack input)
       (if (endp input)
         (parse-step-1 state-stack value-stack *end-marker* nil nil)
         (let ((token (first input)))
           (parse-step-1 state-stack value-stack (funcall token-terminal token) token (rest input)))))
     
     ;Same as parse-step except that the next input terminal has been determined already.
     ;input-rest contains the input tokens after the next token.
     (parse-step-1 (state-stack value-stack terminal token input-rest)
       (let* ((state (car state-stack))
              (transition (cdr (assoc terminal (state-transitions state) :test *grammar-symbol-=*))))
         (if transition
           (case (transition-kind transition)
             (:shift
              (dolist (action-function-binding (gethash terminal (grammar-terminal-actions grammar)))
                (push (funcall (cdr action-function-binding) token) value-stack))
              (parse-step (cons (transition-state transition) state-stack) value-stack input-rest))
             (:reduce
              (let* ((production (transition-production transition))
                     (state-stack (nthcdr (production-rhs-length production) state-stack))
                     (state (car state-stack))
                     (dst-state (assert-non-null
                                 (cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
                     (value-stack (funcall (production-evaluator production) value-stack)))
                (parse-step-1 (cons dst-state state-stack) value-stack terminal token input-rest)))
             (:accept (values (nreverse value-stack) (grammar-user-start-action-types grammar)))
             (t (error "Bad transition: ~S" transition)))
           (error "Parse error on ~S followed by ~S ..." token (ldiff input-rest (nthcdr 10 input-rest)))))))
    
    (if trace
      (trace-action-parse grammar token-terminal input trace)
      (parse-step (list (grammar-start-state grammar)) nil input))))


; Same as action-parse, but with tracing information
; If trace is:
;   :code,   print trace information, including action code
;   other    print trace information
; Return two values:
;   the list of action results;
;   the list of action results' types.
(defun trace-action-parse (grammar token-terminal input trace)
  (labels
    (;Continue the parse with the given stacks and remainder of input.
     ;type-stack contains the types of corresponding value-stack entries.
     (parse-step (state-stack value-stack type-stack input)
       (if (endp input)
         (parse-step-1 state-stack value-stack type-stack *end-marker* nil nil)
         (let ((token (first input)))
           (parse-step-1 state-stack value-stack type-stack (funcall token-terminal token) token (rest input)))))
     
     ;Same as parse-step except that the next input terminal has been determined already.
     ;input-rest contains the input tokens after the next token.
     (parse-step-1 (state-stack value-stack type-stack terminal token input-rest)
       (let* ((state (car state-stack))
              (transition (cdr (assoc terminal (state-transitions state) :test *grammar-symbol-=*))))
         (format *trace-output* "S~D: ~@_" (state-number state))
         (print-values (reverse value-stack) (reverse type-stack) *trace-output*)
         (pprint-newline :mandatory *trace-output*)
         (if transition
           (case (transition-kind transition)
             (:shift
              (format *trace-output* "  shift ~W~:@_" terminal)
              (dolist (action-function-binding (gethash terminal (grammar-terminal-actions grammar)))
                (push (funcall (cdr action-function-binding) token) value-stack))
              (dolist (action-signature (grammar-symbol-signature grammar terminal))
                (push (cdr action-signature) type-stack))
              (parse-step (cons (transition-state transition) state-stack) value-stack type-stack input-rest))
             (:reduce
              (let ((production (transition-production transition)))
                (write-string "  reduce " *trace-output*)
                (if (eq trace :code)
                  (write production :stream *trace-output* :pretty t)
                  (print-production production *trace-output*))
                (pprint-newline :mandatory *trace-output*)
                (let* ((state-stack (nthcdr (production-rhs-length production) state-stack))
                       (state (car state-stack))
                       (dst-state (assert-non-null
                                   (cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
                       (value-stack (funcall (production-evaluator production) value-stack))
                       (type-stack (nthcdr (production-n-action-args production) type-stack)))
                  (dolist (action-signature (grammar-symbol-signature grammar (production-lhs production)))
                    (push (cdr action-signature) type-stack))
                  (parse-step-1 (cons dst-state state-stack) value-stack type-stack terminal token input-rest))))
             (:accept
              (format *trace-output* "  accept~:@_")
              (values (nreverse value-stack) (nreverse type-stack)))
             (t (error "Bad transition: ~S" transition)))
           (error "Parse error on ~S followed by ~S ..." token (ldiff input-rest (nthcdr 10 input-rest)))))))
    
    (parse-step (list (grammar-start-state grammar)) nil nil input)))