Commits

Anonymous committed 8c8d518

tag of lispnik@gmail.com--2006-fucc/fucc--main--0.0--patch-10

(automatically generated log message)

Comments (0)

Files changed (27)

+FUCC Parser is licensed under the terms of following license agreement.
+
+Copyright (c) 2004 Ivan Boldyrev
+                                            
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+                                            
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+                                            
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;;; Local Variables: ***
+;;; mode: view ***
+;;; End: ***
+-*- mode: outline; -*-
+* What's FUCC
+
+FUCC is FU Compiler Compiler.  FUCC converts LALR(1) or LR(1)
+context-free grammar into Common Lisp program that parses input with
+actions.
+
+FUCC consists of two parts: generator and parser.  Generator is used
+for generating parsing tables.  Parser uses the tables for parsing an
+input.  If your grammar is fixed, you need generator for compilation only
+and don't need to distribute it.
+
+See files in doc directory, especially doc/FUCC-FAQ.

doc/ERROR-RECOVERY

+-*- mode: outline; -*-
+
+* Error recovery
+
+FUCC signals about different problems (input errors, shift/reduce or
+reduce/reduce conflicts).  You can continue parsing with different
+restarts.  See Common Lisp HyperSpec, 9.1 Conditions.
+
+** Condition
+
+*** FUCC:PARSE-ERROR-CONDITION
+Parsing error.
+
+**** Readers
+FUCC:ERROR-TOKEN-ID
+FUCC:ERROR-DATA
+FUCC:ERROR-CONFIG
+
+Token ID and data received from lexer, and parser configuration.
+
+**** Restarts
+FUCC:SKIP-TOKEN
+  Get next token from lexer.
+
+FUCC:USE-TOKEN token data
+  Use the TOKEN (symbol, including NIL as end of stream) and DATA
+  (semantics) instead of old one.
+
+FUCC:INSERT-TOKEN token data
+  Insert TOKEN and DATA into stream: process TOKEN and DATA, then
+  process old token.
+
+  Perhaps, this restart will be removed in favor of
+  FUCC:INSERT-TOKEN-LIST.
+
+FUCC:INSERT-TOKEN-LIST list
+  Insert list of tokens into stream, process them, then process old
+  token.
+
+  List consists of cons pairs (TOKEN . DATA).
+
+
+*** FUCC:PARSE-CONFLICT-CONDITION
+Shift/reduce or reduce/reduce conflict.  Reader FUCC:POSSIBLE-ACTIONS
+returns list of conflicting actions.
+
+This is subtype of FUCC:PARSE-ERROR-CONDITION.
+
+**** Readers
+FUCC:POSSIBLE-ACTIONS
+  List of conflicting actions.
+
+**** Restarts
+FUCC:USE-ACTION action
+  Use action for recovery.  Action can be selected from list of
+  conflicting action or something else.
+
+;;; LocalWords:  FUCC HyperSpec
+-*- mode: outline; -*-
+
+1. What is FUCC?
+2. What does the name mean?
+2a. What is FU?
+4. Do you plan implementing other parsing algorithms?
+
+
+1. What is FUCC?
+
+   FUCC is a parser generator and parser for Common Lisp.
+
+
+2. What does the name mean?
+
+   FUCC is a FU Compiler Compiler.
+
+
+2a. What is FU?
+
+   Deliberately nothing.
+
+
+3. Do you plan implementing other parsing algorithms?
+
+   Yes, I plan to add GLR and LL parsing.  Early, CYK and other
+   parsers too.
+
+   Then FUCC will be universal parser toolkit for Common Lisp.
+
+;;; LocalWords:  FUCC LLGPL
+-*- mode: outline; -*-
+
+* Lexer
+
+Lexer is a function with zero or one argument (if LEXER-OPTION of
+DEFPARSER contains :CONTEXT) that returns two values: token id as
+symbol and semantic information (any Lisp object).  NIL as token id is
+sign of end of input stream, its semantic value is ignored.
+
+;; LocalWords:  fixnum
+-*- mode: outline; -*-
+
+Macro FUCC:DEFPARSER variable initial (&rest terminals) (&rest rules)
+                     &key prec-info
+                          (type :lalr)
+                          lexer-options
+
+Defines parser who's data is stored in VARIABLE that is declared
+special with DEFPARAMETER.  INITIAL is symbol: initial nonterminal.
+TERMINALS is list of terminals that parser can accept.  Other symbols
+are treated as nonterminals.  RULES is list of rules in arbitrary order.
+
+Each rule in RULES list is list.  First element is non-terminal
+(symbol that is member of TERMINALS list), second is
+action-description list (see below) and other elements (if any)
+are right side of the rule.
+
+RULE := (SYMBOL ACTION-DESCRIPTION &rest VAR-DESIGNATOR*)
+
+ACTION-DESCRIPTION := (:action FUNCTION)
+                   |  (:class CLASS)
+                   |  (:form LIST-OF-FORMS)
+
+VAL-DESIGNATOR := (:var SYMBOL RULE-EXP)
+               |  (:initarg SYMBOL RULE-EXP)
+               |  RULE-EXP
+
+RULE-EXP       := (CL:* RULE-EXP)
+               |  (CL:+ RULE-EXP)
+               |  (:MAYBE RULE-EXP)
+               |  (:LIST RULE-EXP RULE-EXP)
+               |  SYMBOL
+
+It describes action performed when the rule is reduced.
+
+FUNCTION here is a form that evaluates to function designator.  For
+example:
+
+  #'(lambda (a b) (cons a b))
+  (lambda (x) (process x))
+  #'identity
+  (constantly "Mary had a little lamb")
+
+During reduction semantic values of right side are passed as arguments
+to the FUNCTION value.  Value of the expression is semantic value of
+reduced nonterminal.
+
+CLASS is symbol that denotes class name.  You must not quote it.
+
+LIST-OF-FORMS is list of forms.
+
+:ACTION-form is basic form.  :CLASS-form and :FORM-form are converted
+to it internally.
+
+:CLASS-form creates object of class CLASS, who's initargs are defined
+with :INITARG VAL-DESIGNATORs.  You can use :INITARG VAL-DESIGNATORs
+only with :CLASS-form.
+
+:FORM evaluates form with variables who's names are
+symbols in :VAR VAL-DESIGNATORs bound in lexical context with values
+of semantic values of corresponding RULE-EXP.  You can use :VAR
+VAL-DESIGNATORs only with :FORM-form.
+
+Rules can be more complex than list of terminals/nonterminals: it can
+contain repetition operators like +, *, :LIST and :MAYBE for optional
+items.
+
+Rule expression (CL:* RULE-EXP) returns list of RULE-EXP as semantic
+value.  It matches 0 or more repetitions of RULE-EXP.
+
+Rule expression (CL:+ RULE-EXP) is similar to CL:*, but minimal number
+of elements is 1.
+
+(:MAYBE RULE-EXP) defines optional elements.  If RULE-EXP doesn't
+match, NIL is returned as semantic value, otherwise semantic value of
+RULE-EXP is used.
+
+(:LIST RULE-EXP1 RULE-EXP2) finds non-empty list of RULE-EXP1
+delimited by RULE-EXP2.  Semantic values aof RULE-EXP1 and RULE-EXP2
+are in same list.  For example:
+
+  (SEQ (...)
+       (:LIST OPERATOR SEMICOLON))
+
+is equivalent to:
+
+  (SEQ (...)
+       OPERATOR)
+  (SEQ (...)
+       OPERATOR SEMICOLON OPERATOR)
+  (SEQ (...)
+       OPERATOR SEMICOLON OPERATOR SEMICOLON OPERATOR)
+  ... #| and so on |#
+
+Note that
+  (SEQ2 (...)
+       (:LIST OPERATOR SEMICOLON) SEMICOLON)
+
+equals to
+  (SEQ2 (...)
+       OPERATOR SEMICOLON)
+  (SEQ2 (...)
+       OPERATOR SEMICOLON OPERATOR SEMICOLON)
+  (SEQ2 (...)
+       OPERATOR SEMICOLON OPERATOR SEMICOLON OPERATOR SEMICOLON)
+  ... #| and so on |#
+
+Such expression must be used with caution: they can introduce
+conflicts.
+
+Keywords:
+
+* :PREC-INFO
+
+Precedence info.  Argument is list of prec-lists.  Each prec-list
+start with one of keywords: :LEFT, :RIGHT or :NONE for
+left-associative, right-associative or non-associative operator.
+Rest of elements are terminals and nonterminals.
+
+Order of prec-lists defines their priority: tokens with least priority
+first.
+
+* :TYPE
+
+Parser type: :LALR (default), :LR (aka :LR1), :LR0, :SLR.
+
+* :LEXER-OPTIONS
+
+List of options.  Currently only one option is available: :CONTEXT.
+So, value is either empty list (default) or '(:CONTEXT).
+
+;; LocalWords:  LALR

doc/impl/CONFLICTS

+-*- mode: outline; -*-
+
+* Conflict resolution
+
+Precedence rules define poset PREC (partially ordered set) on actions.
+With addition rules like "otherwise shift over reduction" and "reduce
+rule which is defined first" make it ordered set RPREC.
+
+** Conflict resolution in GLR
+
+This issue is not quite clear to me.  GNU Bison splits parser on
+unresolved conflicts; but it also "resolves all the outstanding
+actions either by precedences given to the grammar rules involved".
+
+Perhaps, using all maximal elements of the poset PREC would be enough.
+
+;;; LocalWords:  poset

doc/impl/GENERATOR

+-*- mode: outline; -*-
+
+* Generic implementation of CLOSURE and GOTO
+
+Different flavors (LR(0), LR(1)) of CLOSURE and GOTO has common
+structure.  Thus generic implementation of these function are
+provided.  Custom versions pass custom closures to create specific
+result.
+
+** CLOSURE set proceed expand ordering
+
+LRPOINT in this section may be type other than
+FUCC-GENERATOR::LRPOINT, though current implementation uses only
+latter.
+
+SET is a list of LRPOINTs.
+
+PROCEED is a function of one argument -- LRPOINT -- that creates list
+of possible new elements in compressed form (for example, LR(0)
+version returns list of nonterminals).  The object must be
+comparable with EQUAL.
+
+EXPAND is a function of one argument that expands (uncompresses)
+objects returned by PROCEED.  For example, LR(0) version for every
+nonterminal returns list of LRPOINTs with rules of the nonterminal.
+
+ORDERING is function to order LRPOINTs.
+
+;;; LocalWords:  FUCC LRPOINT LRPOINTs

doc/impl/LR-PARSER

+-*- mode: outline; -*-
+
+* Table-driven LR-parser
+
+Table driven LR-parser is implemented as FUCC:PARSER-LR.  Input
+arguments are lexer function, initial state of lexer and parser table.
+
+;;; LocalWords:  FUCC

examples/calculator.lisp

+#+asdf(eval-when (:compile-toplevel :execute :load-toplevel)
+        (asdf:oos 'asdf:load-op :fucc-parser))
+#+asdf(eval-when (:compile-toplevel :execute)
+        (asdf:oos 'asdf:load-op :fucc-generator))
+
+;;;  Calculators are "hello world" for parsers
+
+(defparameter *dictionary*
+  (make-hash-table)
+  "Table that associate variable with value")
+
+;;;  Adding parenthes ( exp ) is left as exercise
+(fucc:defparser *calculator-parser*
+    s ; Initial non-terminal
+  ;; List of terminal
+  (+ - * / = :semicolon :id :const)
+  ;; List of rules
+  ((s   (:form (format t "Value: ~S" (first (last exp-list))))
+      (:var exp-list (:list exp :semicolon))
+      (:maybe :semicolon))
+   ;; Assignment
+   (exp (:form (setf (gethash var *dictionary*)
+                       exp))
+      (:var var :id) = (:var exp exp))
+   ;; Binary operations
+   (exp (:action (lambda (a op b)
+                     (funcall op a b)))
+      exp
+      (:or (:or + -) ; Nested OR here is just for fun
+           * /)
+      exp)
+   ;; Constants and variables
+   (exp (:action #'identity)
+      :const)
+   (exp (:action (lambda (var)
+                   (or (gethash var *dictionary*)
+                       (error "Undefined variable: ~S" var))))
+      :id))
+  :prec-info
+  ((:right =) ;; Actually associativity doesn't matter here because
+	      ;; it is enforsed by rule structure anyway.
+   (:left + -) ;; But here it matters.
+   (:left * /)))
+
+(defun calc-lexer (list)
+  "Return lexical analizer for list of tokens"
+  (lambda ()
+    (let ((next-value (pop list)))
+      (cond
+        ((null next-value)
+         (values nil nil))
+        ((member next-value '(:semicolon #\;))
+         (values :semicolon :semicolon))
+        ((member next-value '(+ - * / =))
+         (values next-value (fdefinition next-value)))
+        ((symbolp next-value)
+         (values :id next-value))
+        ((numberp next-value)
+         (values :const next-value))
+        (t
+         (error "Unknown token: ~S" next-value))))))
+
+(defun test-calc (list)
+  (fucc:parser-lr
+   (calc-lexer list)
+   *calculator-parser*))
+
+
+(test-calc (copy-list '(a = c = 3 #\;
+                        b = 4 #\;
+                        a * a + b * 9 - a)))

generator/fg-common.lisp

+#|
+ Copyright (c) 2006 Ivan Boldyrev
+                                             
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+                                             
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+                                             
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+|#
+
+(cl:in-package #:fucc-generator)
+
+(let ((processed-lrpoints (make-hash-table :test 'eql))
+      (processed-nterms (make-hash-table :test 'equal))
+      (new-unprocessed (make-hash-table :test 'equal)))
+  (defun closure (set proceed expand ordering)
+    (declare (type function proceed expand ordering))
+    (let ((unprocessed 'nil))
+      ;; Initial set of non-kernel nterms
+      (dolist (elt set)
+        (dolist (new-elt (funcall proceed elt))
+          (unless (gethash new-elt processed-nterms)
+            (push new-elt unprocessed))))
+      (loop :while unprocessed :do
+            (clrhash new-unprocessed)
+            ;; Mark as processed _before_ processing
+            (dolist (unpr unprocessed)
+              (setf (gethash unpr processed-nterms) t))
+            ;; Process
+            (dolist (unpr unprocessed)
+              (dolist (pt (funcall expand unpr))
+                ;; Proceed: new possibilities
+                (when (eq pt (iget pt processed-lrpoints
+                                   #'lrpoint-hash
+                                   #'lrpoint=))
+                  (dolist (candidate (funcall proceed pt))
+                    (when (and candidate
+                               (not (gethash candidate processed-nterms)))
+                      (iget candidate new-unprocessed #'sxhash #'equal))))))
+            (setf unprocessed (itable-to-list new-unprocessed)))
+      (prog1
+          (sort (nconc
+                 (itable-to-list processed-lrpoints)
+                 set)
+                ordering)
+        (clrhash processed-lrpoints)
+        (clrhash processed-nterms)
+        (clrhash new-unprocessed)))))
+
+(let ((data (make-hash-table :test 'eql)))
+  (defun goto-nc (set nterm pred)
+    (loop :for lrp :in set
+          :for rule := (lrpoint-rule lrp)
+          :for pos := (lrpoint-pos lrp)
+          :when (and (< pos (rule-length rule))
+                     (funcall pred nterm rule pos))
+          :do  (iget (advance-lrpoint lrp) data #'lrpoint-hash #'lrpoint=))
+    (prog1
+        (sort (itable-to-list data) #'lrpoint<=)
+      (clrhash data))))
+
+(defun items (grammar closure-fun goto-fun initial-lrpoint)
+  "Calculate kernel items.  Returns list of items."
+  (let* ((root-item (make-item
+                     :set
+                     (funcall closure-fun (list initial-lrpoint))))
+         (items (make-hash-table :test 'eql))
+         (unprocessed (list root-item)))
+    (loop :while unprocessed :do
+          (let ((new-unprocessed nil))
+            (dolist (item unprocessed)
+              (iget item items #'item-hash #'item=))
+            (dolist (nterm (append (grammar-terms grammar)
+                                   (grammar-nterms grammar)))
+              (dolist (item unprocessed)
+                (let ((new-set (funcall goto-fun (item-set item) nterm)))
+                  (when new-set
+                    (let* ((new-item (make-item :set new-set))
+                           (member (iget new-item items
+                                         #'item-hash
+                                         #'item=)))
+                      (when (eq new-item member)
+                        ;; The item is new
+                        (push member new-unprocessed))
+                      (push (cons nterm member)
+                            (item-moves item)))))))
+            (setf unprocessed new-unprocessed)))
+    (cons root-item
+          (delete root-item 
+                  (loop :for list :being :each :hash-value :of items
+                        :nconc list)))))
+
+(defun reduction-lrpoint-p (lrp)
+  "Check if lrpoint is reduction lrpoint (i.e. point is at right side)"
+  (or (= (lrpoint-pos lrp)
+         (rule-length (lrpoint-rule lrp)))
+      ;; Special care for epsilon-rules
+      (and (epsilon-rule-p (lrpoint-rule lrp))
+           (zerop (lrpoint-pos lrp)))))
+
+(defun report-conflict-and-ret (type used-action discarded-action)
+  (warn "~S conflict: ~S is used over ~S." type used-action discarded-action)
+  used-action)
+
+(defun compare-actions (action1 action2)
+  (let ((priority1 (prec-priority (cadr action1)))
+           (priority2 (prec-priority (cadr action2))))
+    (assert (and priority1 (<= 0 priority1)))
+    (assert (and priority2 (<= 0 priority2)))
+    (cond
+      ((< priority1 priority2) :less)
+      ((> priority1 priority2) :more)
+      (t ; equal
+       (cond
+         (; Reduce/reduce
+          (and (eq :reduce (car action1))
+               (eq :reduce (car action2)))
+          :uncomparable)
+         (; Shift/reduce
+          (and (eq :shift (car action1))
+               (eq :reduce (car action2)))
+          (ecase (prec-assoc (cadr action1)) ; Same priority -> same
+					     ; associativity
+            (:left
+             :less)
+            (:right
+             :more)
+            ((:none :nonassoc)
+             :nonassoc)))
+         (; Reduce/shist
+          (and (eq :reduce (car action1))
+               (eq :shift (car action2)))
+          (ecase (prec-assoc (cadr action1)) ; Same priority -> same
+					     ; associativity
+            (:left
+             :more)
+            (:right
+             :left)
+            ((:none :nonassoc)
+             :nonassoc)))
+         (; priority error
+          t #|(or (eq :priority-error (car action1))
+                  (eq :priority-error (car action2)))|#
+          :nonassoc))))))
+
+(defun add-to-maximal-actions (max-actions action)
+  (cons action     ; Warning: non-local exit with RETURN-FROM may skip
+                                        ; this CONS.
+        (loop :for actions :on max-actions
+              :for cmp := (compare-actions action (first actions))
+              :if (eq :less cmp) :do
+              ;; New action is less than some old one.  Drop new action
+              (return-from add-to-maximal-actions
+                (nconc actions processed))
+              :else :if (eq :uncomparable cmp)
+              :collect (first actions) :into processed
+              :else :if (eq :nonassoc cmp)
+              :collect (list :priority-error (prec-priority (second action)))
+                 :into processed
+              :end
+              :finally (return processed))))
+
+(defun resolve-simple-conflicts (actions)
+  "Return set of actions that no other action supersedes."
+  (loop :with no-priority := nil
+        :with has-priority := nil
+        :for action :in actions
+        :for priority := (prec-priority (second action))
+        :if (or (null priority)
+                (minusp priority))
+        :do (push action no-priority)
+        :else
+        :do (setf has-priority
+                  (add-to-maximal-actions has-priority action))
+        :end
+        :finally (return (nconc
+                          ;; Deleter priority error states
+                          (delete :priority-error has-priority
+                                  :key #'car)
+                          no-priority))))
+
+(defun linearize-conflicts (actions)
+  (reduce #'(lambda (a1 a2)
+              (cond
+                ((eq :shift (first a1))
+                 (report-conflict-and-ret :shift/reduce a1 a2))
+                ((eq :shift (first a2))
+                 (report-conflict-and-ret :shift/reduce a2 a1))
+                (t ; Reduce/reduce
+                 (if (< (rule-index (cadr a1))
+                        (rule-index (cadr a2)))
+                     (report-conflict-and-ret :reduce/reduce a1 a2)
+                     (report-conflict-and-ret :reduce/reduce a2 a1)))))
+          (resolve-simple-conflicts actions)))
+
+(defun generate-tables (grammar items reduce-set-fun)
+  "Return two values: action table and goto table."
+  (loop :for item :in items
+        :for num :from 0 :do
+        (setf (item-index item) num))
+  (let ((state-num (length items))
+        (terms-num (length (grammar-terms grammar)))
+        (nterms-num (length (grammar-nterms grammar))))
+    (let ((action-table (make-array (list state-num terms-num)
+                                    :initial-element nil))
+          (goto-table (make-array (1- nterms-num) :initial-element nil)))
+      ;; Shifts
+      (dolist (item items)
+        (loop :for (nterm . new-item) :in (item-moves item) :do
+              (if (term-p nterm)
+                  (pushnew (list* :shift nterm (item-index new-item))
+                           (aref action-table
+                                 (item-index item)
+                                 (nterm-id nterm))
+                           :test #'equal)
+                  (pushnew (cons (item-index item)
+                                 (item-index new-item))
+                           (aref goto-table
+                                 (- (nterm-id nterm)
+                                    terms-num))
+                           :test #'equal))))
+      ;; Reduce or accept
+      (dolist (item items)
+        (dolist (redex (funcall reduce-set-fun item grammar))
+          (destructuring-bind (rule nterm) redex
+            (pushnew (if (eql +START+
+                              (nterm-name (rule-left rule)))
+                         (list :accept)
+                         (cons :reduce redex))
+                     (aref action-table
+                           (item-index item)
+                           (nterm-id nterm))
+                     :test #'equal))))
+      (values action-table goto-table))))
+
+(defun chain-rule-p (rule)
+  (let ((left-side (rule-left rule)))
+    (and (consp left-side)
+         (not (null (first left-side)))
+         (null (rest left-side)))))
+
+(defun one-step-chain-rule-p (rule state term-id action-table goto-table)
+  (assert (chain-rule-p rule))
+  (let* ((idx (nterm-id (first (rule-left rule))))
+         (new-state (aref goto-table idx state))
+         (new-actions (aref action-table new-state term-id)))
+    (find :action new-actions :key #'car)))
+
+(defun reduce-action (action state term action-table goto-table)
+  (declare (ignore action state term action-table goto-table))
+  (error "REDUCE-ACTION is unimplemented yet"))
+
+(defun remove-chain-rules (action-table goto-table)
+  (let ((unprocessed nil))
+    ;; Initialize list of unprocessed items
+    (dotimes (i (array-dimension action-table 0))
+      (dotimes (j (array-dimension action-table 1))
+        (loop :for action-tail :on (aref action-table i j)
+              :for action := (first action-tail) :do
+              (when (and action-tail
+                         (eq :reduce (first action))
+                         (chain-rule-p (cadr action)))
+                (push (list i j action action-tail) unprocessed)))))
+    ;; do processing
+    (loop :with repeat-flag := t :do
+          (let ((new-unprocessed nil))
+            (setf repeat-flag nil)
+            (loop :for unproc :in unprocessed :do
+                  (destructuring-bind (state term action action-tail) unproc
+                    (if (one-step-chain-rule-p (cadr action)
+                                               state
+                                               term
+                                               action-table
+                                               goto-table)
+                        (setf (first action-tail)
+                              (reduce-action action
+                                             state
+                                             term
+                                             action-table
+                                             goto-table)
+                              ;; Set repeat-flag
+                              repeat-flag
+                              t)
+                        (push unproc new-unprocessed))))
+            (setf unprocessed new-unprocessed))
+          :while repeat-flag)))

generator/fg-decl.lisp

+#|
+ Copyright (c) 2006 Ivan Boldyrev
+                                             
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+                                             
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+                                             
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+|#
+
+(cl:in-package #:fucc-generator)
+
+(defclass properties ()
+  ((%properties :initform (make-hash-table :test 'eq) :type hash-table)))
+
+(defmacro define-property (name)
+  `(progn
+    (defun ,name (obj)
+      (gethash ',name (slot-value obj '%properties)))
+    (defsetf ,name (obj) (value)
+        `(setf (gethash ',',name (slot-value ,obj '%properties)) ,value))))
+
+(defun prop-bound-p (obj name)
+  (nth-value 1 (gethash name (slot-value obj '%properites))))
+
+(defclass prec-mixin ()
+  ((priority :accessor prec-priority
+             :initarg :priority
+             :initform -1
+             :type number)
+   (assoc :accessor prec-assoc
+          :initarg :assoc
+          :initform nil)))
+
+(defmethod prec-priority ((number number))
+  number)
+
+(defclass rule (properties prec-mixin)
+  ((left :accessor rule-left :initarg  :left)
+   (right :accessor rule-right :initarg :right)
+   (length :reader rule-length)
+   (index :accessor rule-index :initarg :index)
+   (action :accessor rule-action
+           :initarg :action
+           :initform (error "Action is not provided"))))
+
+(defmethod initialize-instance :after ((rule rule) &rest arguments)
+  (declare (ignore arguments))
+  (when (slot-boundp rule 'right)
+      (setf (slot-value rule 'length) (length (rule-right rule)))))
+
+(defmethod (setf rule-right) :after (value (rule rule))
+  (setf (slot-value rule 'length) (length value)))
+
+(defun make-rule (&rest args)
+  ;; We allow other keys here because :CLASS or :FORMS can be passed
+  (apply #'make-instance 'rule :allow-other-keys t args))
+
+(defun epsilon-rule-p (rule)
+  "Check epsilon-rule."
+  (let ((rhs (rule-right rule)))
+    (or (null rhs)
+        (and (null rhs) (null rhs)))))
+
+(defclass nterm (properties prec-mixin)
+  ((name :accessor nterm-name :initarg :name)
+   (rules :accessor nterm-rules :initarg :rules :initform nil)
+   (id :accessor nterm-id :initarg :id)
+   (is-term :accessor term-p :initarg :is-term :initform nil)))
+
+(defmethod nterm-name ((name null))
+  nil)
+
+(defmethod term-p ((term null))
+  nil)
+
+(defun make-nterm (&rest args)
+  (apply #'make-instance 'nterm args))
+
+(defvar *grammar-environment*)
+(defvar *grammar-next-id*)
+
+(defclass grammar ()
+  ((nterms :accessor grammar-nterms :initarg :nterms)
+   (terms :accessor grammar-terms :initarg :terms)
+   (rules :accessor grammar-rules :initarg :rules)
+   (environment :accessor grammar-environment
+                :initarg :environment
+                :initform *grammar-environment*)
+   (first-nterm-id :accessor first-nterm-id
+                   :initarg :first-nterm-id
+                   :initform *grammar-next-id*)
+   (prec-info :accessor grammar-prec-info
+               :initarg :precedence
+               :initform nil
+               :type list)))
+
+(defun make-grammar (&rest args)
+  (apply #'make-instance 'grammar args))
+
+(defstruct lrpoint
+  rule
+  (pos 0 :type fixnum)
+  lahead)
+
+(defun advance-lrpoint (lrpoint)
+  (make-lrpoint :rule (lrpoint-rule lrpoint)
+                :pos (1+ (lrpoint-pos lrpoint))
+                :lahead (lrpoint-lahead lrpoint)))
+
+(defun nterm-at-pos (lrpoint)
+  "Return nterm at position or NIL."
+  (nth (lrpoint-pos lrpoint)
+       (rule-right (lrpoint-rule lrpoint))))
+
+(defun lrpoint<= (a b)
+  (or (< (rule-index (lrpoint-rule a))
+         (rule-index (lrpoint-rule b)))
+      (and (eq (lrpoint-rule a)
+               (lrpoint-rule b))
+           (or (< (lrpoint-pos a)
+                  (lrpoint-pos b))
+               (and
+                (= (lrpoint-pos a)
+                   (lrpoint-pos b))
+                (<= (nterm-id (first (lrpoint-lahead a)))
+                    (nterm-id (first (lrpoint-lahead b)))))))))
+
+(defun lrpoint= (a b)
+  (and (eq (lrpoint-rule a)
+           (lrpoint-rule b))
+       (= (lrpoint-pos a)
+          (lrpoint-pos b))
+       (equal (lrpoint-lahead a)
+              (lrpoint-lahead b))))
+
+(defun lrpoint-hash (lrp)
+  (logxor (rule-index (lrpoint-rule lrp))
+          (lrpoint-pos lrp)
+          (sxhash (lrpoint-lahead lrp))))
+
+(defclass item (properties)
+  ((set :reader item-set :initarg :set)
+   (index :accessor item-index)
+   (moves :accessor item-moves :initform nil)))
+
+(defun make-item (&rest args)
+  (apply #'make-instance 'item args))
+
+(defun item= (a b)
+  (funcall (list-cmp #'lrpoint=)
+           (item-set a)
+           (item-set b)))
+
+(defun item-hash (item)
+  (reduce #'logxor (item-set item) :key #'lrpoint-hash))
+
+(defconstant +EOF+ '%$*EOF
+  "Symbol used as end-of-file terminal.")
+
+(defconstant +START+ '%$*Start
+  "Symbol used as initial nonterminal.")
+
+(defmethod print-object ((nterm nterm) output)
+  (format output "#<~A :NAME ~S :ID ~S>"
+          (if (term-p nterm)
+              "TERM"
+              "NTERM")
+          (nterm-name nterm)
+          (nterm-id nterm)))
+
+(defmethod print-object ((rule rule) output)
+  (format output "#<RULE ~S -> ~{~S ~} :ACTION ~S>"
+          (nterm-name (rule-left rule))
+          (mapcar #'nterm-name (rule-right rule))
+          (rule-action rule)))
+
+(defmethod print-object ((item item) output)
+  (format output "<ITEM")
+  (when (slot-boundp item 'index)
+    (format output " :INDEX ~S" (item-index item)))
+  (when (slot-boundp item 'set)
+    (format output " :SET ~S" (item-set item)))
+  (format output ">"))
+

generator/fg-dump.lisp

+#|
+ Copyright (c) 2006 Ivan Boldyrev
+                                             
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+                                             
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+                                             
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+|#
+
+(cl:in-package #:fucc-generator)
+
+(defvar *counter*)
+(defvar *action-forms*)
+
+(defun get-uniq-id (form)
+  (multiple-value-bind (value present-p) (gethash form *action-forms*)
+    (if present-p
+        value
+        (setf (gethash form *action-forms*)
+              (incf *counter*)))))
+
+(defun dump-action-to-2d (action-table)
+  (let ((array (make-array (array-dimensions action-table)
+                           :initial-element nil))
+        (*counter* -1)
+        (*action-forms* (make-hash-table :test 'equal))
+        (actions-var (gensym))
+        (array-var (gensym))
+        (result-var (gensym))
+        (i-var (gensym))
+        (j-var (gensym))
+        (redux-var (gensym)))
+    (dotimes (state (array-dimension action-table 0))
+      (dotimes (term (array-dimension action-table 1))
+        (let ((actions (aref action-table state term)))
+          (assert (null (rest actions)) nil
+                  "Unresolved conflicts found at (~S ~S): ~S"
+                  term state actions)
+          (setf (aref array state term)
+           (ecase (car (first actions))
+             ((:shift)
+              (list :shift :new-state (cddr (first actions))))
+             ((:reduce)
+              (let ((rule (cadr (first actions))))
+                (list :reduce
+                 :term (nterm-id (rule-left rule))
+                 :len (if (null (first (rule-right rule)))
+                          0
+                          (rule-length rule))
+                 :function (get-uniq-id (rule-action rule)))))
+             ((:accept)
+              '(:accept))
+             ((nil)
+              '(:error)))))))
+    `(let* ((,actions-var
+            (make-array ,(1+ *counter*)
+                        :initial-contents
+                        (list
+                         ,@(loop
+                            :with tmp := (make-array (1+ *counter*)
+                                                     :initial-element nil)
+                            :for form :being :each :hash-key :of *action-forms*
+                                      :using (:hash-value id)
+                            :do (setf (aref tmp id)
+                                      form)
+                            :finally (return (coerce tmp 'list))))))
+           (,array-var ,array)
+           (,result-var (make-array ',(array-dimensions action-table)
+                                    :initial-element nil)))
+      (dotimes (,i-var ,(array-dimension action-table 0))
+        (dotimes (,j-var ,(array-dimension action-table 1))
+          (setf (aref ,result-var ,i-var ,j-var)
+                (ecase (first (aref ,array-var ,i-var ,j-var))
+                  ((:shift)
+                   (apply #'fucc::make-shift-action
+                          (rest (aref ,array-var ,i-var ,j-var))))
+                  ((:reduce)
+                   (let ((,redux-var (apply #'fucc::make-reduce-action
+                                            (rest (aref ,array-var
+                                                        ,i-var ,j-var)))))
+                     (setf #1=(fucc::reduce-action-function ,redux-var)
+                           (aref ,actions-var #1#))
+                     ,redux-var))
+                  ((:error)
+                   (fucc::make-error-action))
+                  ((:accept)
+                   (fucc::make-accept-action))))))
+      ,result-var)))
+
+(defun dump-goto-to-2d (goto-table)
+  (let ((goto-tbl (make-array (array-dimensions goto-table)
+                              :initial-element nil)))
+    (dotimes (nterm (array-dimension goto-table 0))
+      (loop :for (old-state . new-state) :in (aref goto-table nterm) :do
+            (setf (aref goto-tbl old-state nterm)
+                  new-state)))
+    goto-tbl))
+
+;;; Simple 2d tables
+(defun dump-to-2d-tables (action-table goto-table)
+  `(list ,(dump-action-to-2d action-table)
+    ,(dump-goto-to-2d goto-table)))
+
+;;; Action table is 2d (state, term) , goto table is list of
+;;; (old-state . new-state) for given nterm
+(defun dump-to-2d-and-1d (action-table goto-table)
+  `(list ,(dump-action-to-2d action-table)
+    ,goto-table))
+
+;;; For each state give list of terminals that do not lead to error state
+(defun dump-valid-terminals (action-table grammar)
+  (let* ((size (array-dimension action-table 0))
+         (result (make-array size :initial-element nil)))
+    (dotimes (state size)
+      (loop :for term-id :from 0 :below (array-dimension action-table 1)
+            :for term :in (grammar-terms grammar) :do
+            (let ((actions (aref action-table state term-id)))
+              (when actions
+                (push (nterm-name term) (aref result state)))))
+      ;; Just to preserve correct order of terminals for user
+      ;; convenience
+      (setf #1=(aref result state)
+            (subst nil +EOF+ (nreverse #1#))))
+    ;; Update table: equal lists should be same.  Perhaps, it may save
+    ;; some bytes :)
+    (let ((ht (make-hash-table :test 'equal :size size)))
+      (dotimes (state size)
+        (let* ((val1 #1#)
+               (val2 (gethash val1 ht)))
+          (if val2
+              (setf #1# val2)
+              (setf (gethash val1 ht)
+                    val1)))))
+    result))

generator/fg-grammar.lisp

+#|
+ Copyright (c) 2006 Ivan Boldyrev
+                                             
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+                                             
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+                                             
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+|#
+
+(cl:in-package #:fucc-generator)
+
+(defmacro with-new-grammar-environment (&body body)
+  `(let ((*grammar-environment* (make-hash-table :test 'eq))
+         (*grammar-next-id* -1))
+    ,@body))
+
+(defun init-env (terminals)
+  "Populate table with TERMINALS.  Returns list of term objects and
+first ID of non-terminals."
+  (let ((terms (mapcar #'(lambda (term) (get-nterm term :is-term t))
+                       terminals)))
+    (values terms *grammar-next-id*)))
+
+(defun get-nterm (name &key is-term)
+  "If NAME is NIL, return NIL.  Otherwise look for NAME in
+environment.  If found, return it; otherwise create new object."
+  (if (null name)
+      nil
+      (let ((from-hash (gethash name *grammar-environment*)))
+        (if from-hash
+            from-hash
+            (setf (gethash name *grammar-environment*)
+                  (make-nterm :name name
+                              :id (incf *grammar-next-id*)
+                              :is-term is-term))))))
+
+(defun process-rule (s-rule)
+  "Process given rule and return RULE object."
+  (destructuring-bind (left args &rest right) s-rule
+    (let ((left-nterm (get-nterm left))
+          (right-nterms (mapcar #'get-nterm right)))
+      (let ((rule (apply #'make-rule
+                         :left left-nterm
+                         :right right-nterms
+                         args)))
+        (push rule
+              (nterm-rules left-nterm))
+        rule))))
+
+(defun set-precedence-info (grammar)
+  ;; Set terminals' precedence info
+  (loop :for (prec . terms) :in (grammar-prec-info grammar)
+        :for idx :from 0
+        :do (dolist (term terms)
+              (let ((nt (nterm-by-name term grammar)))
+                (setf (prec-assoc nt) prec)
+                (setf (prec-priority nt) idx))))
+  ;; Set rules' precedence info
+  (loop :for rule :in (grammar-rules grammar) :do
+        (if (and (slot-boundp rule 'priority)
+                 (symbolp (prec-priority rule)))
+            (let ((term (nterm-by-name (prec-priority rule))))
+              (setf (prec-assoc rule)    (prec-assoc term)
+                    (prec-priority rule) (prec-priority term)))
+            (let ((last-term (find-if #'term-p (rule-right rule)
+                                   :from-end t)))
+              (when last-term
+                (setf (prec-assoc    rule) (prec-assoc    last-term)
+                  (prec-priority rule) (prec-priority last-term)))))))
+
+(defun generate-action--class (lhs class rule-info rhs)
+  (let ((rev-arglist '())
+        (ignored '())
+        (m-o-args '()))
+    
+    ;; Gather information and create left side
+    (let ((new-right
+           (mapcar
+            #'(lambda (item)
+                (let ((arg (gensym)))
+                  (push arg rev-arglist)
+                  (if (and (consp item)
+                           (eq :initarg (first item)))
+                      (progn
+                        (assert (cddr item) nil
+                                "Slot clause is too short: ~S" item)
+                        (assert (not (cdddr item)) nil
+                                "Slot clause is too long: ~S" item)
+                        (push arg m-o-args) ; argument
+                        (push (list (quote quote)
+                                    (second item)) ; initarg
+                              m-o-args)
+                        (third item))
+                      (progn
+                        (push arg ignored)
+                        item))))
+            rhs)))
+      `(,lhs (:action #'(lambda (,@(nreverse rev-arglist))
+                           (declare (ignore ,@ignored))
+                           (make-instance ',class
+                                          ,@m-o-args))
+               ,@rule-info)
+        ,@new-right))))
+
+(defun generate-action--form (lhs form rule-info rhs)
+  (let ((rev-arglist '()))
+    ;; Gather information and create left side
+    (let ((new-right
+           (mapcar
+            #'(lambda (item)
+                (if (and (consp item)
+                         (eq :var (first item)))
+                    (progn
+                      (assert (cddr item) nil
+                              "Var clause is too short: ~S" item)
+                      (assert (not (cdddr item)) nil
+                              "Var clause is too long: ~S" item)
+                      (push (second item) rev-arglist) ; var name
+                      (third item))
+                    (progn
+                      (push (gensym) rev-arglist)
+                      item)))
+            rhs)))
+      (let ((arglist (nreverse rev-arglist)))
+        `(,lhs (:action #'(lambda (,@arglist)
+                            (declare (ignorable ,@arglist))
+                            ,form)
+                ,@rule-info)
+          ,@new-right)))))
+
+(defun generate-action (rule)
+  (destructuring-bind (lhs (&rest rule-info
+                            &key (action nil action-p)
+                                 (form  nil form-p)
+                                 (class  nil class-p)
+                                 &allow-other-keys)
+                           &rest rhs)
+      rule
+    (declare (ignore action))
+    ;; Sanity check
+    (let ((count (count t (list action-p form-p class-p))))
+      (assert (>= 1 count) nil
+              "More than one action-related key is provided: ~S" rule-info)
+      (assert (= 1 count) nil
+              "Action-related keys are not provided: ~S~%One of ~{~S ~} is expected." rule-info '(:action :form :class)))
+    (cond
+      (class-p
+       (generate-action--class lhs class rule-info rhs))
+      (form-p
+       (generate-action--form lhs form rule-info rhs))
+      (action-p
+       `(,lhs ,rule-info ,@rhs))
+      (t
+       (error "Can't happen: checked earlier.")))))
+
+
+(defun parse-complex-form (form rule pos)
+  (let ((generated-rules ())
+        (generated-sym1 (gensym)))
+    (ecase (first form)
+      ((:* *)
+       (push `(,generated-sym1 (:action #'(lambda (cdr &rest car) ; Twisted!
+                                            (append (reverse car) cdr)))
+               ,generated-sym1 ,@(rest form))
+             generated-rules)
+       (push `(,generated-sym1 (:action (constantly nil))
+               ) ; empty
+             generated-rules)
+       (values generated-sym1 generated-rules 'common-lisp:reverse))
+      ((:+ +)
+       (push `(,generated-sym1 (:action #'(lambda (cdr &rest car) ; Twisted!
+                                            (append (reverse car) cdr)))
+               ,generated-sym1 ,@(rest form))
+             generated-rules)
+       (push `(,generated-sym1 (:action #'list)
+               ,@(rest form))
+             generated-rules)
+       (values generated-sym1 generated-rules 'common-lisp:reverse))
+      ((:or or)
+       (let* ((rule-left (first rule))
+              (rule-action (second rule))
+              (rule-right (cddr rule))
+              (new-form (second form))
+              (new-rules
+               (loop :for or-clause :in (cddr form)
+                     :collect `(,rule-left ,rule-action
+                                ,@(replace (copy-list rule-right)
+                                           (list or-clause)
+                                           :start1 pos :end1 (1+ pos))))))
+         (if (consp new-form)
+             (multiple-value-bind (new-form2 new-rules2 transform2)
+                 (parse-complex-form new-form rule pos)
+               (values new-form2
+                       (nconc new-rules2 new-rules)
+                       transform2))
+             (values new-form
+                     new-rules
+                     nil))))
+      ((:maybe)
+       (push (if (cddr form)
+                 `(,generated-sym1 (:action #'list)
+                   ,@(rest form))
+                 `(,generated-sym1 (:action #'identity)
+                   ,(second form)))
+             generated-rules)
+       (push `(,generated-sym1 (:action (constantly nil)))
+             generated-rules)
+       (values generated-sym1 generated-rules nil))
+      ((:list)
+       (destructuring-bind (item delim) (rest form)
+         ;; Variable names in lambda are meaningless, but from
+         ;; COMMON-LISP package.  This avoids "package FUCC-GENERATOR
+         ;; not found" when loading FASLs with debug info.
+         (push `(,generated-sym1 (:action #'(lambda (list cons car)
+                                              (declare (ignore cons))
+                                              (cons car list)))
+                 ,generated-sym1 ,delim ,item)
+               generated-rules)
+         (push `(,generated-sym1 (:action #'list)
+                 ,item)
+               generated-rules)
+         (values generated-sym1 generated-rules 'common-lisp:reverse))))))
+
+(defun apply-argument-transforms (transforms rule-params)
+  (destructuring-bind (&key action &allow-other-keys) rule-params
+    (assert action nil
+            "CAN'T HAPPEN: :ACTION is not found in ~S" rule-params)
+    ;; Analyze the action
+    (loop :for tr :in transforms
+          :for arg := (gensym)
+          :collect arg :into new-arglist
+          :collect (if tr
+                       `(,tr ,arg)
+                       arg)
+          :into arguments
+          :finally (return
+                     (list*
+                      :action
+                      (if (and (eq 'function (first action))
+                               (not
+                                (and
+                                 (consp (second action))
+                                 (eq 'setf (first (second action))))))
+                          ;; Function name or lambda expression
+                          `(function
+                            (lambda ,new-arglist
+                             (,@(rest action)
+                               ,@arguments)))
+                          `(function
+                            (lambda ,new-arglist
+                             (funcall ,action ,@arguments))))
+                      rule-params)))))
+
+(defun expand-rules (rules)
+  (mapcan
+   #'(lambda (rule)
+       (let ((more-rules ())
+             (rule2 (generate-action rule))
+             (transforms nil))
+         (let ((new-rhs
+                (loop :for form :in (cddr rule2)
+                      :for pos :from 0
+                      :if (consp form)
+                      :collect
+                      (multiple-value-bind (new-nterm new-rules transform)
+                          (parse-complex-form form rule2 pos)
+                        (push transform transforms)
+                        (setf more-rules
+                              (nconc more-rules
+                                     (expand-rules new-rules)))
+                        new-nterm)
+                      :else
+                      :do (push nil transforms)
+                      :and :collect form
+                      :end)))
+           (setf transforms (nreverse transforms))
+           (list*
+            `(,(first rule2)
+              ,(if (some #'identity transforms)
+                   (apply-argument-transforms transforms (second rule2))
+                   (second rule2))
+              ,@new-rhs)
+            more-rules))))
+   rules))
+
+(defun parse-grammar (initial terminals rules &key prec-info)
+  (push +EOF+ terminals)
+  (setf rules
+        (append rules
+                (list (list +START+ '(:action (function identity))
+                            initial))))
+  (with-new-grammar-environment
+    (multiple-value-bind (terms first-nterm-id)  (init-env terminals)
+      (let* ((proc-rules (mapcar #'process-rule (expand-rules rules)))
+             (nterms (sort (loop :for nterm
+                                 :being :each :hash-value :of *grammar-environment*
+                                 :when (not (term-p nterm))
+                                 :collect nterm)
+                          #'<
+                          :key #'nterm-id)))
+        (let ((grammar (make-grammar :first-nterm-id first-nterm-id
+                                     :rules proc-rules
+                                     :terms terms
+                                     :nterms nterms
+                                     :precedence prec-info)))
+          (set-precedence-info grammar)
+          grammar)))))
+
+(defun nterm<= (a b)
+  (cond
+    ((null a)
+     t)
+    ((null b)
+     nil)
+    (t
+     (<= (nterm-id a)
+         (nterm-id b)))))
+
+(defun nterm-by-name (name grammar)
+  "Return NTERM by NAME in given GRAMMAR"
+  (gethash name (grammar-environment grammar)))
+
+(defun renumber-rules (grammar)
+  (loop :for rule :in (grammar-rules grammar)
+        :for idx :from 0 :do
+        (setf (rule-index rule) idx)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;;  FIRST function
+;;;;
+
+(define-property nterm-first)
+
+(defun calculate-first (grammar)
+  "Calculate FIRST for every nterm of grammar."
+  ;; Assign FIRST of terms to themselves
+  (dolist (term (grammar-terms grammar))
+    (setf (nterm-first term) (list term)))
+  ;; Set FIRST of nterms to NIL initially
+  (dolist (nterm (grammar-nterms grammar))
+    (setf (nterm-first nterm) nil))
+  ;; Calculate FIRST of nterms
+  (let ((more-repeats t))
+    (loop
+     :while more-repeats :do
+     (setf more-repeats nil)
+     (dolist (nterm (grammar-nterms grammar))
+       (let ((nt-first-orig (nterm-first nterm))
+             (nt-first-more (reduce #'(lambda  (a b)
+                                        (ounion a b :ordering #'nterm<=))
+                                    (nterm-rules nterm)
+                                    :initial-value nil
+                                    :key #'(lambda (rule)
+                                             (seq-first (rule-right rule))))))
+         (let ((nt-first-new (ounion nt-first-orig nt-first-more
+                                     :ordering #'nterm<=)))
+           (when (not (equal nt-first-orig nt-first-new))
+             (setf (nterm-first nterm) nt-first-new)
+             (setf more-repeats t))))))))
+
+(defun item-first (something)
+  (if (null something)
+      '(nil)
+      (nterm-first something)))
+
+(defun seq-first (seq)
+  "FIRST of list of nterms"
+  (cond
+    ((null seq)
+     '(nil))
+    ((null (rest seq))
+     (item-first (first seq)))
+    (t
+     (let ((elt-first  (item-first (first seq))))
+       (if (null (first elt-first))
+           (ounion (rest elt-first) (seq-first (rest seq)) :ordering #'nterm<=)
+           elt-first)))))
+
+(defun combine-first (set1 set2)
+  "If (FIRST-SEQ A) is SET1, (FIRST-SEQ B) is SET2, this function returns
+ (FIRST-SEQ (APPEND A B))"
+  (if (null (first set1))
+      (ounion (rest set1) set2 :ordering #'nterm<=)
+      set1))
+
+(defmacro combine-first-sets (set &rest other-sets)
+  "This macro is similair to COMBINE-FIRST, but it accepts variable
+number of argument and doesn't evaluate unused expressions"
+  (if (null other-sets)
+      set
+      (let ((temp-var (gensym)))
+        `(let ((,temp-var ,set))
+          (if (and ,temp-var (null (first ,temp-var)))
+              (ounion (rest ,temp-var) (combine-first-sets ,@other-sets)
+                      :ordering #'nterm<=)
+              ,temp-var)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;;  Function FOLLOW
+;;;;
+
+(define-property nterm-follow)
+
+(defun calculate-follow (grammar)
+  (push (nterm-by-name +EOF+ grammar)
+        (nterm-follow (nterm-by-name '%$*Start grammar)))
+  (let ((more-repeats t))
+    (loop :while more-repeats :do
+          (setf more-repeats nil)
+          (dolist (rule (grammar-rules grammar))
+            (loop :for (nt . tail) :on (rule-right rule) :do
+                  (unless (null nt)
+                    (let* ((follow-orig (nterm-follow nt))
+                           (first (seq-first tail))
+                           (follow-add
+                            (ounion (if (member 'nil first)
+                                        (nterm-follow (rule-left rule))
+                                        nil)
+                                    (remove nil first)
+                                    :ordering #'nterm<=))
+                           (follow-new (ounion follow-orig follow-add
+                                               :ordering #'nterm<=)))
+                      (unless (equal follow-orig follow-new)
+                        (setf (nterm-follow nt) follow-new)
+                        (setf more-repeats t)))))))))
+

generator/fg-lalr.lisp

+#|
+ Copyright (c) 2006 Ivan Boldyrev
+                                             
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+                                             
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+                                             
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+|#
+
+(cl:in-package #:fucc-generator)
+
+(define-property item-kernel)
+
+(defun kernel-lrpoint-p (lrpoint)
+  (or (plusp (lrpoint-pos lrpoint))
+      (and (eq +START+ (nterm-name (rule-left (lrpoint-rule lrpoint))))
+           (zerop (lrpoint-pos lrpoint)))))
+
+(defun kernel (item)
+  (mapcan #'(lambda (lrpoint)
+              (if (kernel-lrpoint-p lrpoint)
+                  (list lrpoint)
+                  nil))
+          (if (listp item)
+              item
+              (item-set item))))
+
+(defparameter +wildcard+
+  (make-nterm :name 'no-such-symbol
+              :id -1
+              :is-term t)
+  "Special wildcard terminal for lookahead tracing.")
+
+(setf (nterm-first +wildcard+) (list +wildcard+))
+
+(define-property channels)
+
+(define-property spontaneous-laheads)
+
+(defun simple-lrpoint (lrpoint item)
+  (find-if #'(lambda (lrpt)
+               (and (eq (lrpoint-rule lrpt)
+                        (lrpoint-rule lrpoint))
+                    (equal (lrpoint-pos lrpt)
+                           (lrpoint-pos lrpoint))))
+           (item-set item)))
+
+(defun set-channel-info (from-item from-lrp to-item to-lrp)
+  (pushnew (list* (simple-lrpoint from-lrp from-item)
+                  to-item
+                  (simple-lrpoint to-lrp to-item))
+           (channels from-item)
+           :test #'equal))
+
+(defun set-spontaneous-lahead-info (lrpoint item)
+  (let ((lrp (simple-lrpoint lrpoint item)))
+    (assert (not (null lrp)))
+    (pushnew (cons lrp (lrpoint-lahead lrpoint))
+             (spontaneous-laheads item)
+             :test #'equal)))
+
+(defun generate-laheads (items eof)
+  (dolist (item items)
+    (dolist (lrpoint (item-kernel item))
+      (when (and (eq +START+ (nterm-name (rule-left (lrpoint-rule lrpoint))))
+                 (zerop (lrpoint-pos lrpoint)))
+        (pushnew (cons lrpoint (list eof))
+                 (spontaneous-laheads item)
+                 :test #'equal))
+      (let* ((test-lrpoint (make-lrpoint :rule   (lrpoint-rule lrpoint)
+                                         :pos    (lrpoint-pos  lrpoint)
+                                         :lahead (list +wildcard+)))
+             ;; TODO modify closure-lr1 so that it could use other slots
+             ;; for lookahead.  Or will it break lrpoint= ?
+             (closure (closure-lr1 (list test-lrpoint))))
+        (loop :for lrp :in closure :do
+              (let ((nt (nterm-at-pos lrp)))
+                (when nt
+                  (let ((next (cdr (assoc nt (item-moves item)))))
+                    (assert next)
+                    (if (equal `(,+wildcard+) (lrpoint-lahead lrp))
+                        (set-channel-info item lrpoint
+                                          next (advance-lrpoint lrp))
+                        (set-spontaneous-lahead-info
+                         (advance-lrpoint lrp) next))))))))))
+
+
+;; TODO: keep lookaheads as (lrpoint lahead1 lahead2 ...), not as
+;; (lrpoint . lahead1), (lrpoint . lahead2) ...  But it will affect
+;; calculation of new-unprocessed.
+;;
+;; Note that each lookahead is one-element list of terminals.
+(defun spread-laheads (items)
+  (let ((unprocessed items))
+    (loop
+     :for new-unprocessed := nil
+     :while unprocessed :do
+     ;; TODO: keep (CONS ITEM LRP) in new-unprocessed, not just ITEM 
+     (loop
+      :for item :in unprocessed
+      :for sp-laheads := (spontaneous-laheads item)
+      :when sp-laheads :do
+      (loop
+       :for (from-lrp to-item . to-lrp)
+       :in (channels item)
+       :for old-sp-laheads := (spontaneous-laheads to-item) :do
+       (loop
+        :for (lrp . lahead) :in sp-laheads
+        :when (eq lrp from-lrp) :do
+        (pushnew (cons to-lrp lahead)
+                 (spontaneous-laheads to-item)
+                 :test #'equal))
+       (unless (eq old-sp-laheads (spontaneous-laheads to-item))
+         (pushnew to-item new-unprocessed))))
+     (dolist (item unprocessed)
+       (let ((sp-laheads (spontaneous-laheads item)))
+         (when sp-laheads)))
+     (setf unprocessed new-unprocessed))))
+
+(define-property rm-info)
+
+(defun update-rm-info (target-nterm rule)
+  "Update RM-INFO for TARGET-NTERM with information from RULE."
+  (if (or (epsilon-rule-p rule) (term-p (first (rule-right rule))))
+      nil
+      (let ((source (first (rule-right rule)))
+            (tail (rest (rule-right rule)))
+            (updated-p nil))
+        (let ((source-rm-info (rm-info source))
+              (target-rm-info (rm-info target-nterm))
+              (first-set (seq-first tail)))
+          (dotimes (i (array-dimension source-rm-info 0))
+            ;; Try uniting info about i-th nterm
+            (when (aref source-rm-info i)
+              (let ((new-value (ounion (aref target-rm-info i)
+                                       (combine-first (aref source-rm-info i)
+                                                      first-set)
+                                       :ordering #'nterm<=)))
+                (unless (equal new-value (aref target-rm-info i))
+                  (setf (aref target-rm-info i) new-value
+                        updated-p t))))))
+        updated-p)))
+
+(defun calculate-rm-info (grammar)
+  "Info about rightmost derivations"
+  (let ((nterm-num (length (grammar-nterms grammar)))
+        (term-num (length (grammar-terms grammar))))
+    (dolist (nterm (grammar-nterms grammar))
+      (let ((array (make-array nterm-num :initial-element nil)))
+        (setf (aref array (- (nterm-id nterm) term-num))
+              '(nil)) ; Or nil?
+        (setf (rm-info nterm) array)))
+    (let ((set (grammar-nterms grammar)))
+      (loop :while set
+            :for updated-nterms := nil :do
+            (dolist (nterm set)
+              (let ((updated nil))
+                (dolist (rule (nterm-rules nterm))
+                  (when (update-rm-info nterm rule)
+                    (setf updated t)))
+                (when updated
+                  (pushnew nterm updated-nterms))))
+            (setf set updated-nterms)))))
+
+;;; TODO: try specialized version.  Necessary info can be generated
+;;; during calculation of FIRST.
+(defun items-lalr (grammar)
+  (calculate-rm-info grammar)
+  (let ((lr0-items (items-lr0 grammar)))
+    (dolist (item lr0-items)
+      (setf (item-kernel item)
+            (kernel (item-set item))))
+    (generate-laheads lr0-items (nterm-by-name +EOF+ grammar))
+    (spread-laheads lr0-items)
+    lr0-items))
+
+(defun nterm-epsilon-rules (nterm)
+  "List of epsilon rules of the nterm"
+  (mapcan #'(lambda (rule)
+              (if (epsilon-rule-p rule)
+                  (list rule)
+                  nil))
+          (nterm-rules nterm)))
+
+(defun get-epsilon-reductions (lrpoint lahead grammar)
+  "Epsilon reductions that can happen for the LRPOINT and LAHEAD"
+  (let ((nterm (nterm-at-pos lrpoint)))
+    (if (or (not nterm) (term-p nterm))
+        nil
+        (let ((accumulator ())
+              (rm-info (rm-info nterm)))
+          (loop :for i :from 0 :below (array-dimension rm-info 0)
+                :for nterm :in (grammar-nterms grammar) :do
+                (let ((first-set (combine-first-sets
+                                  (aref rm-info i)
+                                  (seq-first
+                                   (nthcdr (1+ (lrpoint-pos lrpoint))
+                                           (rule-right (lrpoint-rule lrpoint))))
+                                  lahead)))
+                  (loop :for rule :in (nterm-epsilon-rules nterm) :do
+                        (loop :for term :in first-set :do
+                              (push (cons rule (list term))
+                                    accumulator)))))
+          (nreverse accumulator)))))
+
+
+(defun reduce-set-lalr (item grammar)
+  (mapcan #'(lambda (pair)
+              (destructuring-bind (lrpoint . lahead) pair
+                  (if (reduction-lrpoint-p lrpoint)
+                      (list (cons (lrpoint-rule lrpoint)
+                                  lahead))
+                      (get-epsilon-reductions lrpoint lahead grammar))))
+          (spontaneous-laheads item)))

generator/fg-lr.lisp

+#|
+ Copyright (c) 2006 Ivan Boldyrev
+                                             
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+                                             
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+                                             
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+|#
+
+(cl:in-package #:fucc-generator)
+
+(defun closure-lr1 (set)
+  (closure
+   set
+   #'(lambda (lrp)
+       (let ((rule (lrpoint-rule lrp))
+             (pos (lrpoint-pos lrp))
+             (result nil))
+         (when (< pos (rule-length rule))
+           (let ((nterm (elt (rule-right rule) pos))
+                 (first-set (seq-first
+                             (append (nthcdr (1+ pos) (rule-right rule))
+                                     (lrpoint-lahead lrp)))))
+             (when (and nterm (not (term-p nterm)))
+               (dolist (term first-set)
+                 (when term
+                   (pushnew (list nterm term)
+                            result
+                            :test #'equal))))))
+         result))
+   #'(lambda (cons)
+       (destructuring-bind (nterm . lahead) cons
+         (mapcar #'(lambda (rule)
+                     (make-lrpoint :rule rule :pos 0 :lahead lahead))
+                 (nterm-rules nterm))))
+   #'lrpoint<=))
+
+(defun goto-lr1 (set nterm)
+  (closure-lr1
+   (goto-nc set
+            nterm
+            #'(lambda (nterm rule pos)
+                (eq nterm (elt (rule-right rule)
+                               pos))))))
+
+(defun items-lr1 (grammar)
+  "Calculate LR(1) items for GRAMMAR."
+  (items grammar
+         #'closure-lr1
+         #'goto-lr1
+         (make-lrpoint :rule (first (last (grammar-rules grammar)))
+                       :pos 0
+                       :lahead (list (nterm-by-name +EOF+ grammar)))))
+
+(defun reduce-set-lr1 (item grammar)
+  (declare (ignore grammar))
+  (mapcan #'(lambda (lrpoint)
+              (if (reduction-lrpoint-p lrpoint)
+                  (list (cons (lrpoint-rule lrpoint)
+                              (lrpoint-lahead lrpoint)))
+                  nil))
+          (item-set item)))
+

generator/fg-lr0.lisp

+#|
+ Copyright (c) 2006 Ivan Boldyrev
+                                             
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+                                             
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+                                             
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+|#
+
+(cl:in-package #:fucc-generator)
+
+(defun closure-lr0 (set)
+  (closure set
+           #'(lambda (lrp)
+               (let ((lr-rule (lrpoint-rule lrp))
+                     (lr-pos (lrpoint-pos lrp))
+                     (result nil))
+                 (when (< lr-pos (rule-length lr-rule))
+                   (let ((nterm (elt (rule-right lr-rule) lr-pos)))
+                     (when (and nterm (not (term-p nterm)))
+                       (pushnew nterm result))))
+                 result))
+           #'(lambda (nterm)
+               (mapcar #'(lambda (rule)
+                           (make-lrpoint :rule rule :pos 0))
+                       (nterm-rules nterm)))
+           #'lrpoint<=))
+
+(defun goto-lr0 (set nterm)
+  (closure-lr0
+   (goto-nc set
+            nterm
+            #'(lambda (nterm rule pos)
+                (eq nterm (elt (rule-right rule)
+                               pos))))))
+
+(defun items-lr0 (grammar)
+  "Calculate LR(0) items for the GRAMMAR."
+  (items grammar
+         #'closure-lr0
+         #'goto-lr0
+         (make-lrpoint :rule (first (last (grammar-rules grammar)))
+                       :pos 0)))
+
+(defun reduce-set-lr0 (item grammar)
+  "Set rules that can be reduced in given item with LR0 aglorithm."
+  (mapcan #'(lambda (lrpoint)
+              (if (reduction-lrpoint-p lrpoint)
+                  (mapcar #'(lambda (term)
+                              (list (lrpoint-rule lrpoint) term))
+                          (grammar-terms grammar))
+                  nil))
+          (item-set item)))
+
+(defun accept-set-slr-helper (lrpoint item grammar)
+  (declare (ignore item))
+  (if (eql +START+ (nterm-name (rule-left (lrpoint-rule lrpoint))))
+      (list (list (lrpoint-rule lrpoint)
+                  (nterm-by-name +EOF+ grammar)))
+      (mapcar #'(lambda (term)
+                  (list (lrpoint-rule lrpoint) term))
+              (nterm-follow (rule-left (lrpoint-rule lrpoint))))))
+
+(defun reduce-set-slr (item grammar)
+  "Set rules that can be reduced in given item with LR0 aglorithm."
+  (mapcan #'(lambda (lrpoint)
+              (if (reduction-lrpoint-p lrpoint)
+                  (accept-set-slr-helper lrpoint item grammar)
+                  nil))
+          (item-set item)))
+

generator/fg-macro.lisp

+#|
+ Copyright (c) 2006 Ivan Boldyrev
+                                             
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+                                             
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+                                             
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+|#
+
+(in-package #:fucc-generator)
+
+(defmacro fucc:defparser (variable initial (&rest terminals) (&rest rules)
+                          &key prec-info
+                               (type :lalr)
+                               lexer-options)
+  (let ((grammar (parse-grammar initial terminals rules :prec-info prec-info))
+        (%/value/-var (gensym))
+        (mapping-var (gensym))
+        (state-var (gensym))
+        (nterm-var (gensym))
+        (term-var (gensym))
+        (parser-var (gensym))
+        (goto-table-var (gensym))
+        (new-state-var (gensym))
+        (use-context-p (member :context lexer-options)))
+    ;; Check parameters
+    (dolist (option (set-difference lexer-options '(:context)))
+      (warn "Unknown lexer option: ~S" option))
+    ;; Calculate grammar element's properties
+    (renumber-rules grammar)
+    (calculate-first grammar)
+    (calculate-follow grammar)
+    ;; Warning about unproductive or unused nonterminals
+    (let* ((unproductive (delete-unproductive-nterm-rules grammar))
+           (unused (delete-unused-term-rules grammar)))
+      (when unproductive
+        (setf unproductive
+              (sort unproductive #'nterm<=))
+        (warn "Unproductive nonterminals:~%~{ ~S~}"
+              unproductive))
+      (when unused
+        (setf unused (sort unused #'nterm<=))
+        (warn "Unused (non)terminals:~%~{ ~S~}"
+              unused))
+      (when (or unproductive unused)
+        ;; Recalculate grammar properties
+        (loop :for idx :from 0
+              :for term :in (grammar-terms grammar) :do
+              (setf (nterm-id term) idx))
+        (loop :for idx :from (length (grammar-terms grammar))
+              :for nterm :in (grammar-nterms grammar) :do
+              (setf (nterm-id nterm) idx))
+        (renumber-rules grammar)
+        (calculate-first grammar)
+        (calculate-follow grammar)))
+    (let ((items (ecase type
+                   ((:lalr)
+                    (items-lalr grammar))
+                   ((:lr :lr1)
+                    (items-lr1 grammar))
+                   ((:lr0 :slr)
+                    (items-lr0 grammar)))))
+      (multiple-value-bind (action goto)
+          (generate-tables grammar
+                           items
+                           (ecase type
+                             ((:lalr)
+                              #'reduce-set-lalr)
+                             ((:lr :lr1)
+                              #'reduce-set-lr1)
+                             ((:lr0)
+                              #'reduce-set-lr0)
+                             ((:slr)
+                              #'reduce-set-slr)))
+        (dotimes (i (array-dimension action 0))
+          (dotimes (j (array-dimension action 1))
+            (when (and (aref action i j)
+                       (rest (aref action i j)))
+              (setf (aref action i j)
+                    (list
+                     (linearize-conflicts
+                      (aref action i j)))))))
+        `(defparameter ,variable
+          (load-time-value
+           (let ((,%/value/-var ,(dump-to-2d-and-1d action goto))
+                 (,mapping-var (fucc::alist-to-hash-table
+                           ',(list*
+                              (cons nil 0)
+                              (mapcar #'(lambda (term)
+                                          (cons (nterm-name term)
+                                                (nterm-id term)))
+                                      (rest (grammar-terms grammar)))))))
+             (list
+              0                      ; TODO: mechanism-dependent value
+              #'(lambda (,state-var ,term-var ,parser-var) ; TODO: ditto
+                  (setf ,term-var (or (gethash ,term-var ,mapping-var)
+                                      (and ,term-var
+                                           ;; TODO: specific condition type
+                                           (error "Unknown terminal ~S" ,term-var))
+                                      0))
+                  (aref (fourth ,parser-var)
+                        ,state-var ,term-var))
+              #'(lambda (,state-var ,nterm-var ,parser-var) ; TODO: ditto
+                  (let* ((,goto-table-var (fifth ,parser-var))
+                         (,new-state-var
+                          (cdr (assoc ,state-var
+                                      (aref ,goto-table-var
+                                            (- ,nterm-var ,(length (grammar-terms grammar))))))))
+                    (assert ,new-state-var)
+                    ,new-state-var))
+              (first ,%/value/-var)
+              (second ,%/value/-var)
+              ,(if use-context-p
+                   (dump-valid-terminals action grammar)
+                   nil)))))))))

generator/fg-package.lisp

+#|
+ Copyright (c) 2006 Ivan Boldyrev
+                                             
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+                                             
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+                                             
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+|#
+
+(cl:defpackage #:fucc-generator
+  (:use #:common-lisp)
+  (:export
+   #| Nothing yet |#))

generator/fg-transform.lisp

+#|
+ Copyright (c) 2006 Ivan Boldyrev
+                                             
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+                                             
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.