Commits

Anonymous committed 5e9a12f

Changes from fucc--ll--0.2 are merged
Keywords: merge

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-2
Split LL generator and LL parser.

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-3
Bugfix: remove stale debug print

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-4
Error checking: check if rule present in a cell

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-5
Bugfix: handle epsilon-rules

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-6
Merge from upstream

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-7
Execute rule's final actions.

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-8
Execute middle actions in LL

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-9
Bugfix in LR code

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-10
Initial action in LL.

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-11
Do not externalize hashtable

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-12
Ignore values of middle actions in LR.

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-13
Middle actions are ingnored when choosing default action.

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-14
defparser accepts LL grammars.

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-15
Bugfix: insert proper default action if middle :call is present

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-16
Bugfix: generate reductions for some epsilon rules

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-17
Improve code of get-epsilon-reductions

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-18
LR-related expansion code is segregated

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-19
LL grammar expansion

* lispnik@gmail.com--2006-fucc/fucc--ll--0.2--patch-20
Warn if delimeter has alphanumeric character inside.

  • Participants
  • Parent commits 68e567b

Comments (0)

Files changed (15)

 ACTION-DESCRIPTION describes action performed when the rule is reduced
 and intermediate actions.  If last VAL-DESIGNATOR is not an
 ACTION-DESCRIPTION, then default action description is inserted: it is
-(CONSTANTLY NIL) for epsilon-rules, #'IDENTITY for one-element rule
-and #'LIST for other rules.
+(CONSTANTLY NIL) for epsilon-rules, #'IDENTITY for one-element (middle
+actions are ingored) rule and #'LIST for other rules.
 
 FUNCTION here is a form that evaluates to function designator.  For
 example:
 
 * :TYPE
 
-Parser type: :LALR (default), :LR (aka :LR1), :LR0, :SLR.
+Parser type: :LALR (default), :LR (aka :LR1), :LR0, :SLR and :LL .
 
 * :LEXER-OPTIONS
 

File doc/impl/LL-PARSER

+-*- mode: outline; -*-
+* Table-driver LL-parser
+Static parser input is tables and other parameters generated from
+grammar.  Dynamic parser input is stream of tokens generated by lexer.
+
+** Static parser input
+Static parser input is a 4-element list.
+
+First element is a 2d array (table).  First axis is a nonterminal ID
+from the rule, second -- terminal ID from the lexer.  Value of a cell
+is a rule to be expanded (LL-RULE structure).
+
+Second element is an ID of starting non-terminal.
+
+Third element is an ID of EOF terminal.
+
+Fourth element is a hash table that maps parser's token ID as symbol
+to terminal ID.
+
+** Terminal vs. non-terminal
+Non-terminals are kept negative: (- (1+ nonterminal-id )).
+This reduces size of largest possible table, but such what is grammar
+that creates such a table???

File fucc-generator.asd

 #| -*- mode: lisp; -*-
- Copyright (c) 2006 Ivan Boldyrev
+ Copyright (c) 2006-2007 Ivan Boldyrev
                                              
  Permission is hereby granted, free of charge, to any person obtaining
  a copy of this software and associated documentation files (the
                    (:file "fg-decl"
                           :depends-on ("fg-package"
                                        "fg-util"))
+                   (:file "fg-grammar-lr"
+                          :depends-on ("fg-package"
+                                       "fg-decl"
+                                       "fg-util"))
+                   (:file "fg-grammar-ll"
+                          :depends-on ("fg-package"
+                                       "fg-decl"
+                                       "fg-util"
+                                       "fg-grammar-lr"))
                    (:file "fg-grammar"
                           :depends-on ("fg-package"
                                        "fg-decl"
-                                               "fg-util"))
+                                       "fg-util"
+                                       "fg-grammar-lr"
+                                       "fg-grammar-ll"))
                    (:file "fg-transform"
                           :depends-on ("fg-package"
                                        "fg-decl"
                           :depends-on ("fg-package"
                                        "fg-decl"
                                        "fg-grammar"
+                                       "fg-grammar-lr"
                                        "fg-common"
                                        "fg-transform"
                                        "fg-lr0"

File fucc-parser.asd

                 (:file "fucc-util"
                        :depends-on ("fucc-package" "fucc-decl"))
                 (:file "fucc-parser"
-                       :depends-on ("fucc-package" "fucc-decl" "fucc-util"))))))
+                       :depends-on ("fucc-package" "fucc-decl" "fucc-util"))
+                (:file "fucc-ll"
+                       :depends-on ("fucc-package"))))))
 
 ; (asdf:operate 'asdf:load-op :fucc-parser)

File generator/fg-decl.lisp

           :accessor rule-production
           :initarg :right
           :documentation "Right-hand side: list of terms")
+   (init-action :accessor rule-init-action
+                :initarg :init-action
+                :documentation "Action executed when rule is expanded.")
+   (middle-actions :accessor rule-middle-actions
+                   :initarg :middle-actions
+                   :documentation "List of middle actions")
    (length :reader rule-length
            :documentation "Cached length of right-hand side")
    (index :accessor rule-index :initarg :index)

File generator/fg-grammar-ll.lisp

+#|
+ Copyright (c) 2007 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)
+
+
+(defparameter +complex-forms-ll+
+  '(:* * :+ + :maybe :list :or or))
+
+;;;  Transform complex forms like "(:+ a)" into 3 values:
+;;;
+;;; 1. symbol that is used in original rule as substitution of the
+;;; form ("substitution nterm").  It may be fresh symbol or some old one.
+;;;
+;;; 2. Set of new rules.  May be empty.
+;;;
+;;; 3. Value transformer.  This is a symbol naming a function or
+;;; lambda-expression (but not result of its evaluation).  Transformer
+;;; is applied to value generated by substitution nterm.  It is handy
+;;; for efficient implementation of list forms.
+(defun expand-form-ll (form rule pos)
+  (declare (ignore rule pos))
+  (let ((generated-rules '())
+        (generated-sym (gensym)))
+    (ecase (first form)
+      ((:or or)
+       (dolist (subform (rest form))
+         (push
+          (if (atom subform)
+              ;; Atomic
+              `(,generated-sym nil ,subform)
+              ;; General
+              `(,generated-sym nil ,@subform))
+          generated-rules))
+       (values generated-sym (nreverse generated-rules) nil))
+      ((:* *)
+       (values generated-sym
+               (list
+                `(,generated-sym nil (constantly nil))
+                `(,generated-sym nil #'list* ,@(rest form) ,generated-sym))
+               nil))
+      ((:+ +)
+       (let ((generated-sym2 (gensym)))
+        (values generated-sym2
+                (list
+                 `(,generated-sym2 nil
+                       #'list* ,@(rest form) ,generated-sym)
+                 `(,generated-sym nil (constantly nil))
+                 `(,generated-sym nil #'list* ,@(rest form) ,generated-sym))
+                nil)))
+      ((:maybe)
+       (values generated-sym
+                (list
+                 `(,generated-sym nil (constantly nil))
+                 (if (cddr form)
+                     `(,generated-sym nil #'list ,@(rest form))
+                     `(,generated-sym nil #'identity ,(second form))))
+                 nil))
+      ((:list list)
+       (let ((generated-sym2 (gensym)))
+        (destructuring-bind (item delim) (rest form)
+          (values generated-sym2
+                  (list
+                   `(,generated-sym2 nil 
+                                     #'cons
+                                     ,item ,generated-sym)
+                   `(,generated-sym nil (constantly nil))
+                   `(,generated-sym nil 
+                                    (lambda (second first rest)
+                                      (cons first rest))
+                                    ,delim ,item ,generated-sym))
+                  nil)))))))
+
+(defun expand-rules-ll (rules)
+  (declare (type list rules))
+  (expand-rules* #'expand-form-ll #'expand-rules-ll +complex-forms-ll+ rules))

File generator/fg-grammar-lr.lisp

+#|
+ Copyright (c) 2006-2007 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)
+
+;;; TODO: Rename variables and functions, appeding "-lr" to names.
+
+(defparameter +complex-forms-lr+
+  '(:* * :+ + :maybe :list :call))
+
+;;;  Transform complex forms like "(:+ a)" into 3 values:
+;;;
+;;; 1. symbol that is used in original rule as substitution of the
+;;; form ("substitution nterm").  It may be fresh symbol or some old one.
+;;;
+;;; 2. Set of new rules.  May be empty.
+;;;
+;;; 3. Value transformer.  This is a symbol naming a function or
+;;; lambda-expression (but not result of its evaluation).  Transformer
+;;; is applied to value generated by substitution nterm.  It is handy
+;;; for efficient implementation of list forms.
+(defun expand-complex-form-lr (form rule pos)
+  (declare (ignore rule pos))
+  (let ((generated-rules ())
+        (generated-sym1 (gensym)))
+    (ecase (first form)
+      ((:* *)
+       (push `(,generated-sym1 nil
+               ,generated-sym1 ,@(rest form)
+               #'(lambda (cdr &rest car) ; Twisted!
+                          (append (reverse car) cdr)))
+             generated-rules)
+       (push `(,generated-sym1 nil 
+               (constantly nil)
+               ;; empty
+               )
+             generated-rules)
+       (values generated-sym1 generated-rules 'common-lisp:reverse))
+      ((:+ +)
+       (push `(,generated-sym1 nil
+               #'(lambda (cdr &rest car) ; Twisted!
+                   (append (reverse car) cdr))
+               ,generated-sym1 ,@(rest form))
+             generated-rules)
+       (push `(,generated-sym1 nil
+               #'list
+               ,@(rest form))
+             generated-rules)
+       (values generated-sym1 generated-rules 'common-lisp:reverse))
+      ((:maybe)
+       (push (if (cddr form) ; Nested form is a list
+                 `(,generated-sym1 nil
+                   #'list
+                  ,@(rest form) )
+                 `(,generated-sym1 nil
+                   #'identity
+                   ,(second form)))
+             generated-rules)
+       (push `(,generated-sym1 nil
+               (constantly nil)
+               ;; Empty
+               )
+             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 nil
+                 #'(lambda (list cons car)
+                            (declare (ignore cons))
+                            (cons car list))
+                 ,generated-sym1 ,delim ,item)
+               generated-rules)
+         (push `(,generated-sym1 nil
+                 #'list
+                 ,item)
+               generated-rules)
+         (values generated-sym1 generated-rules 'common-lisp:reverse))))))
+
+(defparameter +inlineable-forms-lr+
+  '(:or or))
+
+;;; Inline complex form (like :or).  Returned values are same as of
+;;; expand-complex-form-lr.
+(defun expand-inlinable-form-lr (form rule pos)
+  (let ((generated-sym1 (gensym)))
+    (ecase (first form)
+      ((:or or)
+       (let ((short-subforms ()) ; One-element forms are just inlined.
+             (long-subforms ())) ; Forms with two or more elements
+                                 ; are implemented with fresh nterm.
+         (dolist (subform (rest form))
+           (cond
+             ((atom subform)        ; Atomic form is short
+              (push subform short-subforms))
+             ((null (rest subform)) ; One-element list is short
+              (push (first subform) short-subforms))
+             (t                     ; Everything else is long subform
+              (push subform long-subforms))))
+         ;; Bind long subforms to one artificial nterm
+         (when long-subforms
+           (push generated-sym1 short-subforms))
+
+         ;; First short subform is returned as substitution nterm.
+         ;; Rest of short subforms are inserted into new rules:
+         ;; subform replaces inlinable form in original rule.
+         (let* ((rule-left (first rule))
+                (rule-meta (second rule))
+                (rule-action (third rule))
+                (rule-right (cdddr rule))
+                (new-form (first short-subforms))
+                (new-rules
+                 (loop :for or-clause :in (rest short-subforms)
+                       :collect `(,rule-left ,rule-meta
+                                   ,rule-action
+                                   ;; Short subform replaces inlinable
+                                   ;; form
+                                  ,@(replace (copy-list rule-right)
+                                             (list or-clause)
+                                             :start1 pos :end1 (1+ pos))))))
+           (dolist (subform long-subforms)
+             (push `(,generated-sym1 nil
+                     #'list
+                     ,@subform)
+                   new-rules))
+           ;; First short subform happens to be complex form, it is
+           ;; processed recursively.
+           (if (consp new-form)
+               (multiple-value-bind (new-form2 new-rules2 transform2)
+                   (parse-complex-form-lr new-form rule pos)
+                 (values new-form2
+                         (nconc new-rules2 new-rules)
+                         transform2))
+               (values new-form
+                       new-rules
+                       nil))))))))
+
+(defun parse-complex-form-lr (form rule pos)
+  (cond
+    ((member (first form)
+             +complex-forms-lr+)
+     (expand-complex-form-lr form rule pos))
+    ((member (first form)
+             +inlineable-forms-lr+)
+     (expand-inlinable-form-lr form rule pos))))
+
+(defun expand-middle-actions-in-rule-lr (rule)
+  "Expand middle actions for LR.  Values of middle actions are ignored."
+  (let ((new-vars '())
+        (ignore-vars '())
+        (passed-vars '())
+        (generated-rules)
+        (new-rhs '()))
+    (loop :for form :in (cdddr rule)
+       :for var := (gensym) :do ; Var is used as lambda arg and as new
+                                ; nterminal
+       (push var new-vars)
+       :if (attribute-form-p form) :do
+       (push var ignore-vars)
+       (push `(,var nil
+               ,(second form)
+               ;; Empty
+               )
+             generated-rules)
+       (push var new-rhs)
+       :else :do
+       (push var passed-vars)
+       (push form new-rhs))
+    (if generated-rules
+        (values `(,(first rule) ,(second rule)
+                   (lambda ,(nreverse new-vars)
+                     (declare (ignore ,@ignore-vars))
+                     (funcall ,(third rule) ,@(nreverse passed-vars)))
+                   ,@(nreverse new-rhs))
+                generated-rules)
+        (values rule nil))))
+
+(defun expand-middle-actions-lr (rules)
+  "Expand middle actions for LR in rules."
+  (loop :for rule :in rules
+     :for (rewritten-rule new-rules)
+     := (multiple-value-list
+         (expand-middle-actions-in-rule-lr rule))
+     :nconc (list* rewritten-rule new-rules)))
+
+(defun apply-argument-transforms-to-action (transforms action)
+  "Apply TRANSFORMS to ACTION"
+  ;; Create new action
+  (loop :for tr :in transforms
+     :for arg := (gensym)
+     :collect arg :into new-arglist
+     :collect (if tr
+                  `(,tr ,arg)
+                  arg)
+     :into arguments
+     :finally (return
+                (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)))))))
+
+(defun expand-rules* (expander recursive prefix-set rules)
+  "Apply EXPANDER to forms starting with atoms in PREFIX-SET to all RULES."
+  (mapcan
+   #'(lambda (rule)
+       (let ((more-rules ())
+             (transforms nil))
+         (let* ((rhs-expand
+                 ;; Calculate new rhs and collect transforms into TRANSFORMS
+                 (loop :for form :in (cdddr rule)
+                    :for pos :from 0
+                    :if (and (consp form)
+                             (member (first form)
+                                     prefix-set
+                                     :test #'eq))
+                    :collect
+                    (multiple-value-bind (new-nterm new-rules transform)
+                        (funcall expander form rule pos)
+                      (push transform transforms)
+                      (setf more-rules
+                            (nconc more-rules
+                                   ;; Expand generated rules recursively
+                                   (funcall recursive new-rules)))
+                      new-nterm)
+                    :else
+                    :do (push nil transforms)
+                    :and :collect form
+                    :end)))
+           (setf transforms (nreverse transforms))
+           (list*
+            `(,(first rule)
+               ,(second rule)
+               ,(if (some #'identity transforms)
+                    (apply-argument-transforms-to-action transforms (third rule))
+                    (third rule))
+               ,@rhs-expand)
+            more-rules))))
+   rules))
+
+(defun expand-rules-lr (rules)
+  (expand-rules* #'expand-inlinable-form-lr
+                 #'expand-rules-lr
+                +inlineable-forms-lr+
+                (expand-rules* #'expand-complex-form-lr
+                               #'expand-rules-lr
+                               +complex-forms-lr+
+                               (expand-middle-actions-lr rules))))

File generator/fg-grammar.lisp

 #|
- Copyright (c) 2006 Ivan Boldyrev
+ Copyright (c) 2006-2007 Ivan Boldyrev
                                              
  Permission is hereby granted, free of charge, to any person obtaining
  a copy of this software and associated documentation files (the
 (defun split-rule-form (rule-form)
   "Convert rule form (A -> x -> y) into list ((A x) (A y))"
   (destructuring-bind (left-nterminal delim &rest data) rule-form
-    (when (find-if #'alpha-char-p (symbol-name delim))
-      (warn "Delimiter ~S with alphabetic character in rule group ~S" delim rule-form))
+    (let ((bad-char (find-if #'alphanumericp (string delim))))
+      (when (find-if #'alpha-char-p (symbol-name delim))
+        (warn "Delimiter ~S with alphabetic character ~A in rule group~% ~S"
+              delim bad-char rule-form)))
     (let ((left-sides (list nil)))
       (dolist (token data)
         (if (eq delim token)
   "Process given rule and return RULE object."
   (destructuring-bind (left args main-action &rest right) s-rule
     (let ((left-nterm (get-nterm left))
-          (right-nterms (mapcar #'get-nterm right)))
+          (right-nterms '())
+          (actions '())
+          (init-action nil))
+      (when (and (rest right)
+                 (attribute-form-p (first right)))
+        (setf init-action (second (pop right))))
+      (loop :while right :do
+         (if (attribute-form-p (second right))
+             ;; Nterm with action
+             (let ((nt (get-nterm (pop right)))
+                   (action (second (pop right))))
+               (push action actions)
+               (push nt right-nterms))
+             ;; Normal nterm
+             (let ((nt (get-nterm (pop right))))
+               (push nil actions)
+               (push nt right-nterms))))
+      (setf actions (nreverse actions))
+      (setf right-nterms (nreverse right-nterms))
       (let ((rule (apply #'make-rule
                          :left left-nterm
                          :right right-nterms
+                         :init-action init-action
+                         :middle-actions actions
                          :action main-action
                          args)))
         (push rule
                   (prec-priority rule) (prec-priority last-terminal)))))))
 
 (defun expand-action--do (form rev-var-list rest)
-  `(:call (function (lambda ,(if (rest rest)
-                                 '() ; Arglist of non-primary actions in LR.
-                                 (reverse rev-var-list))
-            (declare (ignorable ,@rev-var-list))
-            ,@(rest form)))))
+  (let ((rev-arglist (if (rest rest)
+                         '()          ; Arglist of non-primary actions
+                         rev-var-list)))
+    `(:call (function (lambda ,(reverse rev-arglist)
+                          (declare (ignorable ,@rev-arglist))
+              ,@(rest form))))))
 
 (defun expand-action--class (form rhs rest rev-var-list rev-initarg-list)
   (unless (null (rest rest))
        ((null rhs)
         '((:call (constantly nil))))
        ((not (attribute-form-p (first (last rhs))))
-        (if (rest rhs)
+        ;; Using COUNT is not fastest way, but rules are rarely really
+        ;; long.  Faster:
+        ;; (member-if-not #'attribute-form-p
+        ;;        (rest (member-if-not #'attribute-form-p rhs)))
+        (if (<= 2 (count-if (complement #'attribute-form-p) rhs))
             '((:call (function list)))
             '((:call (function identity)))))
        (t
         '())))))
 
-(defparameter +complex-forms+
-  '(:* * :+ + :maybe :list :call))
-
-;;;  Transform complex forms like "(:+ a)" into 3 values:
-;;;
-;;; 1. symbol that is used in original rule as substitution of the
-;;; form ("substitution nterm").  It may be fresh symbol or some old one.
-;;;
-;;; 2. Set of new rules.  May be empty.
-;;;
-;;; 3. Value transformer.  This is a symbol naming a function or
-;;; lambda-expression (but not result of its evaluation).  Transformer
-;;; is applied to value generated by substitution nterm.  It is handy
-;;; for efficient implementation of list forms.
-(defun expand-complex-form (form rule pos)
-  (declare (ignore rule pos))
-  (let ((generated-rules ())
-        (generated-sym1 (gensym)))
-    (ecase (first form)
-      ((:* *)
-       (push `(,generated-sym1 nil
-               ,generated-sym1 ,@(rest form)
-               #'(lambda (cdr &rest car) ; Twisted!
-                          (append (reverse car) cdr)))
-             generated-rules)
-       (push `(,generated-sym1 nil 
-               (constantly nil)
-               ;; empty
-               )
-             generated-rules)
-       (values generated-sym1 generated-rules 'common-lisp:reverse))
-      ((:+ +)
-       (push `(,generated-sym1 nil
-               #'(lambda (cdr &rest car) ; Twisted!
-                   (append (reverse car) cdr))
-               ,generated-sym1 ,@(rest form))
-             generated-rules)
-       (push `(,generated-sym1 nil
-               #'list
-               ,@(rest form))
-             generated-rules)
-       (values generated-sym1 generated-rules 'common-lisp:reverse))
-      ((:maybe)
-       (push (if (cddr form) ; Nested form is a list
-                 `(,generated-sym1 nil
-                   #'list
-                  ,@(rest form) )
-                 `(,generated-sym1 nil
-                   #'identity
-                   ,(second form)))
-             generated-rules)
-       (push `(,generated-sym1 nil
-               (constantly nil)
-               ;; Empty
-               )
-             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 nil
-                 #'(lambda (list cons car)
-                            (declare (ignore cons))
-                            (cons car list))
-                 ,generated-sym1 ,delim ,item)
-               generated-rules)
-         (push `(,generated-sym1 nil
-                 #'list
-                 ,item)
-               generated-rules)
-         (values generated-sym1 generated-rules 'common-lisp:reverse)))
-      ((:call)
-       (push `(,generated-sym1 nil
-               (:call ,(second form))
-               ;; Empty
-               )
-             generated-rules)
-       (values generated-sym1 generated-rules nil)))))
-
-(defparameter +inlineable-forms+
-  '(:or or))
-
-;;; Inline complex form (like :or).  Returned values are same as of
-;;; expand-complex-form.
-(defun expand-inlinable-form (form rule pos)
-  (let ((generated-sym1 (gensym)))
-    (ecase (first form)
-      ((:or or)
-       (let ((short-subforms ()) ; One-element forms are just inlined.
-             (long-subforms ())) ; Forms with two or more elements
-                                 ; are implemented with fresh nterm.
-         (dolist (subform (rest form))
-           (cond
-             ((atom subform)        ; Atomic form is short
-              (push subform short-subforms))
-             ((null (rest subform)) ; One-element list is short
-              (push (first subform) short-subforms))
-             (t                     ; Everything else is long subform
-              (push subform long-subforms))))
-         ;; Bind long subforms to one artificial nterm
-         (when long-subforms
-           (push generated-sym1 short-subforms))
-
-         ;; First short subform is returned as substitution nterm.
-         ;; Rest of short subforms are inserted into new rules:
-         ;; subform replaces inlinable form in original rule.
-         (let* ((rule-left (first rule))
-                (rule-meta (second rule))
-                (rule-action (third rule))
-                (rule-right (cdddr rule))
-                (new-form (first short-subforms))
-                (new-rules
-                 (loop :for or-clause :in (rest short-subforms)
-                       :collect `(,rule-left ,rule-meta
-                                   ,rule-action
-                                   ;; Short subform replaces inlinable
-                                   ;; form
-                                  ,@(replace (copy-list rule-right)
-                                             (list or-clause)
-                                             :start1 pos :end1 (1+ pos))))))
-           (dolist (subform long-subforms)
-             (push `(,generated-sym1 nil
-                     #'list
-                     ,@subform)
-                   new-rules))
-           ;; First short subform happens to be complex form, it is
-           ;; processed recursively.
-           (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))))))))
-
-(defun parse-complex-form (form rule pos)
-  (cond
-    ((member (first form)
-             +complex-forms+)
-     (expand-complex-form form rule pos))
-    ((member (first form)
-             +inlineable-forms+)
-     (expand-inlinable-form form rule pos))))
-
-(defun apply-argument-transforms-to-action (transforms action)
-  "Apply TRANSFORMS to ACTION"
-  ;; Create new action
-  (loop :for tr :in transforms
-     :for arg := (gensym)
-     :collect arg :into new-arglist
-     :collect (if tr
-                  `(,tr ,arg)
-                  arg)
-     :into arguments
-     :finally (return
-                (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)))))))
-
-(defun expand-rules* (expander prefix-set rules)
-  "Apply EXPANDER to forms starting with atoms in PREFIX-SET to all RULES."
-  (mapcan
-   #'(lambda (rule)
-       (let ((more-rules ())
-             (transforms nil))
-         (let* ((rhs-expand
-                 ;; Calculate new rhs and collect transforms into TRANSFORMS
-                 (loop :for form :in (cdddr rule)
-                    :for pos :from 0
-                    :if (and (consp form)
-                             (member (first form)
-                                     prefix-set
-                                     :test #'eq))
-                    :collect
-                    (multiple-value-bind (new-nterm new-rules transform)
-                        (funcall expander form rule 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 rule)
-               ,(second rule)
-               ,(if (some #'identity transforms)
-                    (apply-argument-transforms-to-action transforms (third rule))
-                    (third rule))
-               ,@rhs-expand)
-            more-rules))))
-   rules))
-
-(defun expand-rules (rules)
-  (expand-rules* #'expand-inlinable-form
-                +inlineable-forms+
-                (expand-rules* #'expand-complex-form
-                               +complex-forms+
-                               rules)))
-
-(defun parse-grammar (initial terminals rules &key prec-info)
+(defun parse-grammar (initial terminals rules &key prec-info (type :lr))
   ;; Add EOF mark
   (push +EOF+ terminals)
   ;; Add artifical start rule
   (with-new-grammar-environment
     (multiple-value-bind (terminals first-nterminal-id)
         (init-env terminals) ;; Terminals added here
-      (let* ((proc-rules (mapcar #'process-rule
-                                 (expand-rules
-                                  (mapcar #'expand-action
-                                          (mapcan #'split-rule-form rules)))))
+      ;; Expand rules.
+      (let* ((action-rules (mapcar #'expand-action
+                                  (mapcan #'split-rule-form rules)))
+             (proc-rules (mapcar #'process-rule
+                                 (funcall
+                                  (if (eq :ll type)
+                                      #'expand-rules-ll
+                                      #'expand-rules-lr)
+                                   action-rules)))
              (nterminals (sort (loop :for nterm
                                  :being :each :hash-value :of *grammar-environment*
                                  :when (not (terminal-p nterm))

File generator/fg-lalr.lisp

 (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) (terminal-p nterm))
+    (if (or (null nterm) (terminal-p nterm))
         nil
         (let ((accumulator ())
               (rm-info (rm-info nterm)))
-          (loop :for i :from 0 :below (array-dimension rm-info 0)
+          (loop :for rm :across rm-info
                 :for nterminal :in (grammar-nterminals grammar) :do
                 (let ((first-set (combine-first-sets
-                                  (aref rm-info i)
+                                  rm
                                   (seq-first
                                    (nthcdr (1+ (lrpoint-pos lrpoint))
                                            (rule-right (lrpoint-rule lrpoint))))
                                   lahead)))
-                  (loop :for rule :in (nterminal-epsilon-rules nterm) :do
+                  (loop :for rule :in (nterminal-epsilon-rules nterminal) :do
                         (loop :for terminal :in first-set :do
                               (push (cons rule (list terminal))
                                     accumulator)))))

File generator/fg-ll.lisp

 
 (cl:in-package #:fucc-generator)
 
-(defstruct ll-rule
-  (actions)
-  (nterms))
+(defun filter-rule (rule-right grammar)
+  "Transform nterm objects into their codes (negative for non-terminals)."
+  (mapcar #'(lambda (nterm)
+              (if (terminal-p nterm)
+                  (nterm-id nterm)
+                  (fucc::nt->negative (nterminal-id nterm grammar))))
+          rule-right))
 
-
-(defun stack-popper (n)
-  (lambda (data-stack action-stack)
-    (pop-n-stack data-stack action-stack n)))
-
-;;; TODO: There is similar function in LR parsing: nsplit-list
-(defun pop-n-stack (data-stack action-stack n)
-  (let ((result '()))
-    (loop :repeat n :do
-       (push (pop data-stack) result))
-    (push result data-stack)
-    ;; Recursive call to parent rule action
-    (funcall (first action-stack) data-stack (rest action-stack))))
-
-(defun identity-stack (data-stack action-stack)
-  (values data-stack action-stack))
-
-(defun rule->ll-rule (rule)
-  (make-ll-rule :nterms (reverse (rule-right rule))
-                :actions (nreverse
-                          (loop
-                             :for rest :on (rule-right rule)
-                             :for len  :from 1
-                             :collect (if (null (rest rest))
-                                          (stack-popper len)
-                                          #'identity-stack)))))
+(defun rule->ll-rule (rule grammar)
+  (cons
+   (reverse
+    (filter-rule (rule-right rule) grammar))
+   (if (null (rule-right rule))
+       `(fucc::ll-final-action 0 ,(rule-action rule))
+       (list*
+        'list
+        ;; Initial action
+        `(fucc::ll-middle-action 0 ,(rule-init-action rule))
+        ;; Middle actions
+        (nreverse
+         (loop
+            :for rest :on (rule-right rule)
+            :for action :in (rule-middle-actions rule)
+            :for len  :from 1
+            :collect (if (null (rest rest))
+                         `(fucc::ll-final-action ,len ,(rule-action rule))
+                         `(fucc::ll-middle-action ,len ,action))))))))
 
 (defun make-ll-table (grammar)
   "Generate LL table where each cell may contain list of possible
           (dolist (termnl first-set)
             (if (null termnl)
                 ;; Epsilon derivation is possible.  Use FOLLOW set
-                (dolist (termnl-follow (rule-left rule))
-                  ;; We use PUSHNEW here becase rule may be addet two
+                (dolist (termnl-follow (nterm-follow (rule-left rule)))
+                  ;; We use PUSHNEW here becase rule may be added two
                   ;; times: as epsilon rule and as ordinary rule.  It
                   ;; is conflict, but it implicit one.  It is always
                   ;; demonstrated somewhere else explicitly.
                                (nterm-id termnl)))))))
       table)))
 
-(defun convert-to-deterministic-ll-table (table)
+(defun convert-to-deterministic-ll-table (table grammar)
   (dotimes (nterminal (array-dimension table 0))
     (dotimes (terminal (array-dimension table 1))
       (let ((value (aref table nterminal terminal)))
            (error "Cannot resolve LL conflict: ~S" value))
           (t
            (setf #1=(aref table nterminal terminal)
-                 (rule->ll-rule (first #1#))))))))
+                 (rule->ll-rule (first #1#) grammar)))))))
   table)
 
-;;; TODO: Consider redesign.  Instead of stacks use stack of stacks,
-;;; where each stack on stack corresponds to rule in process.
-;;; Now this structure is kept in actions, perhaps, keeping it in CONS
-;;; structure may be more optimal.
-(defun parse-ll (lexer ll-table grammar)
-  (let ((nterm-stack (list (first (grammar-nterminals grammar))
-                           (first (grammar-terminals grammar))))
-        (data-stack '())
-        (action-stack (list (lambda (data-stack action-stack)
-                              (declare (ignore action-stack))
-                              (return-from parse-ll (first data-stack))))))
-    (loop
-       (multiple-value-bind (tid data) (funcall lexer)
-         ;; Do all possible rule expansions.
-         (loop :until (terminal-p (first nterm-stack)) :do
-            (let* ((nonterm (pop nterm-stack))
-                   (ll-rule (aref ll-table (nterminal-id nonterm grammar) tid)))
-              (loop
-                 :for nterm :in (ll-rule-nterms ll-rule) :do
-                 (push nterm nterm-stack))
-              (loop
-                 :for action :in (ll-rule-actions ll-rule) :do
-                 (push action action-stack))))
-         
-         ;; Now there is either terminal or EOF on stack
-         (if (equal tid
-                    ;; TODO: NTERM-ID is wrong here (EOF is NIL!)
-                    (nterm-id (first nterm-stack)))
-             (progn
-               (pop nterm-stack)
-               (push data data-stack)
-               ;; If we have complete, non-local exit is performed from action
-               (multiple-value-setq (data-stack action-stack)
-                 (funcall (first action-stack) data-stack (rest action-stack))))
-             (error "LL parse error: ~S expected, ~S found"
-                    (first nterm-stack)
-                    tid))))))
+(defun det-ll-table->list-ll-parser-data (table)
+  `(make-array
+    ',(array-dimensions table)
+    :initial-contents
+    (list
+     ,@(loop
+          :for nterminal :from 0 :below (array-dimension table 0)
+          :collect 
+          (cons 'list
+                (loop
+                   :for terminal :from 0 :below (array-dimension table 1)
+                   :for (rule . action) := (aref table nterminal terminal)
+                   :if (aref table nterminal terminal)
+                   :collect `(cons ',rule ,action)
+                   :else
+                   :collect nil))))))
+
+(defun make-deterministic-ll-parser-data (table grammar)
+  `(list
+    ,(det-ll-table->list-ll-parser-data
+       (convert-to-deterministic-ll-table table grammar))
+    ,(fucc::nt->negative (nterminal-id (first (grammar-nterminals grammar))
+                                       grammar))
+    ,(nterm-id (first (grammar-terminals grammar)))
+    (fucc::alist-to-hash-table
+     ',(loop
+          :for term :in (grammar-terminals grammar)
+          :if (eq +EOF+ (nterm-name term))
+          :collect (cons nil (nterm-id term))
+          :else
+          :collect (cons (nterm-name term) (nterm-id term))))))

File generator/fg-macro.lisp

 #|
- Copyright (c) 2006 Ivan Boldyrev
+ Copyright (c) 2006-2007 Ivan Boldyrev
                                              
  Permission is hereby granted, free of charge, to any person obtaining
  a copy of this software and associated documentation files (the
                                prec-info
                                (type :lalr)
                                lexer-options)
-  (let ((grammar (parse-grammar initial terminals rules :prec-info prec-info))
+  (let ((grammar (parse-grammar initial terminals rules
+                                :prec-info prec-info
+                                :type type))
         (%/value/-var (gensym))
         (mapping-var (gensym))
         (state-var (gensym))
           (when used-by-mistake
             (warn "Used reserved terminals:~%~{ ~S~}" used-by-mistake))))
       (when (or unproductive unused)
-        ;; Recalculate grammar properties
+        ;; Renumber grammar elements
         (loop :for idx :from 0
               :for terminal :in (grammar-terminals grammar) :do
               (setf (nterm-id terminal) idx))
         (loop :for idx :from (first-nterminal-id grammar)
               :for nterminal :in (grammar-nterminals grammar) :do
               (setf (nterm-id nterminal) idx))
+        ;; Recalculate grammar properties
         (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 (terminal)
-                                          (cons (nterm-name terminal)
-                                                (nterm-id terminal)))
-                                      (rest (grammar-terminals grammar)))))))
-             (list
-              0                      ; TODO: mechanism-dependent value
-              #'(lambda (,state-var ,terminal-var ,parser-var) ; TODO: ditto
-                  (setf ,terminal-var (or (gethash ,terminal-var ,mapping-var)
-                                      (and ,terminal-var
-                                           ;; TODO: specific condition type
-                                           (error "Unknown terminal ~S" ,terminal-var))
-                                      0))
-                  (aref (fourth ,parser-var)
-                        ,state-var ,terminal-var))
-              #'(lambda (,state-var ,nterminal-var ,parser-var) ; TODO: ditto
-                  (let* ((,goto-table-var (fifth ,parser-var))
-                         (,new-state-var
-                          (cdr (assoc ,state-var
-                                      (aref ,goto-table-var
-                                            (- ,nterminal-var ,(first-nterminal-id grammar)))))))
-                    (assert ,new-state-var)
-                    ,new-state-var))
-              (first ,%/value/-var)
-              (second ,%/value/-var)
-              ,(if use-context-p
-                   (dump-valid-terminals action grammar)
-                   nil)))))))))
+    (if (eq type :ll)
+        `(defparameter
+             ,variable
+           (load-time-value
+            ,(make-deterministic-ll-parser-data
+              (make-ll-table grammar)
+              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 (terminal)
+                                                    (cons (nterm-name terminal)
+                                                          (nterm-id terminal)))
+                                                (rest (grammar-terminals grammar)))))))
+                  (list
+                   0                 ; TODO: mechanism-dependent value
+                   #'(lambda (,state-var ,terminal-var ,parser-var) ; TODO: ditto
+                       (setf ,terminal-var (or (gethash ,terminal-var ,mapping-var)
+                                               (and ,terminal-var
+                                                    ;; TODO: specific condition type
+                                                    (error "Unknown terminal ~S" ,terminal-var))
+                                               0))
+                       (aref (fourth ,parser-var)
+                             ,state-var ,terminal-var))
+                   #'(lambda (,state-var ,nterminal-var ,parser-var) ; TODO: ditto
+                       (let* ((,goto-table-var (fifth ,parser-var))
+                              (,new-state-var
+                               (cdr (assoc ,state-var
+                                           (aref ,goto-table-var
+                                                 (- ,nterminal-var ,(first-nterminal-id grammar)))))))
+                         (assert ,new-state-var)
+                         ,new-state-var))
+                   (first ,%/value/-var)
+                   (second ,%/value/-var)
+                   ,(if use-context-p
+                        (dump-valid-terminals action grammar)
+                        nil))))))))))

File parser/fucc-ll.lisp

+#|
+ Copyright (c) 2007 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)
+
+(defun ll-rule-actions (ll-rule)
+  (cdr ll-rule))
+
+(defun ll-rule-nterms (ll-rule)
+  (car ll-rule))
+
+(defun nt->negative (id)
+  (- (1+ id)))
+
+(defun negative->nt (ng)
+  (1- (- ng)))
+
+(defun ll-terminal-p (id)
+  (not (minusp id)))
+
+(defmacro rev-apply (n func list-exp)
+  (let ((args (loop :repeat n :collect (gensym)))
+        (rest-var (gensym)))
+    `(destructuring-bind (,@args &rest ,rest-var) ,list-exp
+       (values (funcall ,func ,@(reverse args))
+               ,rest-var))))
+
+(defmacro stack-popper (n)
+  `(lambda (data-stack action-stack)
+    (pop-n-stack data-stack action-stack ,n)))
+
+(defmacro ll-final-action (len action)
+  "Final ACTION (form that returns function) where rule length
+is LEN (unsigned byte)"
+  `(function
+    (lambda (data-stack action-stack)
+     (multiple-value-bind (val new-data-stack)
+         (rev-apply ,len ,action data-stack)
+       (push val new-data-stack)
+       (funcall (first action-stack) new-data-stack (rest action-stack))))))
+
+(defmacro ll-middle-action (len action)
+  "Non-final ACTION (form that return function).  LEN is unsigned
+byte that defines number of preceeding tokens."
+  (declare (ignore len))
+  `(function
+    (lambda (data-stack action-stack)
+     ,@(if action
+           `((funcall ,action))
+           ())
+     (values data-stack action-stack))))
+
+;;; TODO: There is similar function in LR parsing: nsplit-list
+(defun pop-n-stack (data-stack action-stack n)
+  (let ((result '()))
+    ;; Reduce data into list
+    (loop :repeat n :do
+       (push (pop data-stack) result))
+    ;; Put list on a stack
+    (push result data-stack)
+    ;; Recursive call to parent rule action
+    (funcall (first action-stack) data-stack (rest action-stack))))
+
+(defun parser-ll (lexer ll-data)
+  (destructuring-bind (ll-table init eof token-map) ll-data
+    (let ((nterm-stack (list init eof))
+          (data-stack '())
+          (action-stack (list (lambda (data-stack action-stack)
+                                (declare (ignore action-stack))
+                                (return-from parser-ll (first data-stack)))))
+          (lexer-proc (lambda () (multiple-value-bind (token attr)
+                                     (funcall lexer)
+                                   (multiple-value-bind (id found-p)
+                                       (gethash token token-map)
+                                     (if found-p
+                                         (values id attr)
+                                         (error "Unknown token: ~S" token)))))))
+      (loop
+         (multiple-value-bind (tid data) (funcall lexer-proc)
+           ;; Do all possible rule expansions.
+           (loop :until (ll-terminal-p (first nterm-stack)) :do
+              (let* ((nonterm (pop nterm-stack))
+                     (ll-rule (aref ll-table (negative->nt nonterm) tid)))
+                (when (null ll-rule)
+                  (error "No rule for ~S at ~S found"
+                         (negative->nt nonterm)
+                         tid))
+                (if (null (ll-rule-nterms ll-rule))
+                    ;; Epsilon rule
+                    ;; Do action without pushing it on action-stack
+                    (multiple-value-setq (data-stack action-stack)
+                      (funcall (ll-rule-actions ll-rule) data-stack
+                               action-stack))
+                    ;; Do ordinary expansion
+                    (progn
+                      (loop
+                         :for nterm :in (ll-rule-nterms ll-rule) :do
+                         (push nterm nterm-stack))
+                      (loop
+                         :for action :in (rest (ll-rule-actions ll-rule)) :do
+                         (push action action-stack))
+                      ;; Execute initial action
+                      ;; TODO: are NILs are really OK here?  Initial
+                      ;; rule does not modify stack.
+                      (funcall (first (ll-rule-actions ll-rule)) nil nil)))))
+           ;; Now there is either terminal or EOF on stack
+           (if (equal tid
+                      (first nterm-stack))
+               (progn
+                 (pop nterm-stack)
+                 (push data data-stack)
+                 ;; Do action
+                 ;; If we have complete, non-local exit is performed from action
+                 (multiple-value-setq (data-stack action-stack)
+                   (funcall (first action-stack) data-stack (rest action-stack))))
+               (error "LL parse error: ~S expected, ~S found"
+                      (first nterm-stack)
+                      tid)))))))

File parser/fucc-package.lisp

   (:export
    #:defparser
    #:parser-lr
+   #:parser-ll
    #:use-value
    #:use-action
    #:skip-token

File test/fg-grammar-ll-test.lisp

+;;; ** General LL expansion
+(rt:deftest (fucc-generator::expand-rules-ll :simple)
+    ;; There is nothing to expand
+    (fucc-generator::expand-rules-ll '((s nil #'list a b c)))
+  ;; Result
+  ((s nil #'list a b c)))
+
+;;; ** Expanding forms
+(rt:deftest (fucc-generator::expand-form-ll :or)
+    (multiple-value-bind (nterm rules trans)
+        (fucc-generator::expand-form-ll
+         '(:or a ((:list a b)) (b) (b c))
+         nil
+         0)
+      (list
+       (every (lambda (rule)
+                (eq nterm (first rule)))
+              rules)
+       (mapcar #'rest rules)
+       trans))
+  (t ((nil a) (nil (:list a b)) (nil b) (nil b c)) nil))
+
+(rt:deftest (fucc-generator::expand-form-ll :*)
+    (multiple-value-bind (nterm rules trans)
+        (fucc-generator::expand-form-ll
+         '(:* a (:list a b) b c)
+         nil
+         0)
+      (sublis (list (cons nterm 'no-such-symbol1)) rules))
+  ((no-such-symbol1 nil (constantly nil))
+   (no-such-symbol1 nil #'list* a (:list a b) b c no-such-symbol1)))
+
+(rt:deftest (fucc-generator::expand-form-ll :+)
+    (multiple-value-bind (nterm rules trans)
+        (fucc-generator::expand-form-ll
+         '(:+ a (:list a b) b c)
+         nil
+         0)
+      (sublis (list (cons nterm 'no-such-symbol2)
+                    (cons (caadr rules) 'no-such-symbol1)) rules))
+  ((no-such-symbol2 nil #'list* a (:list a b) b c no-such-symbol1)
+   (no-such-symbol1 nil (constantly nil))
+   (no-such-symbol1 nil #'list* a (:list a b) b c no-such-symbol1)))
+
+(rt:deftest (fucc-generator::expand-form-ll :maybe 1)
+    (multiple-value-bind (nterm rules trans)
+        (fucc-generator::expand-form-ll
+         '(:maybe a)
+         nil
+         0)
+      (sublis (list (cons nterm 'no-such-symbol1)) rules))
+  ((no-such-symbol1 nil (constantly nil))
+   (no-such-symbol1 nil #'identity a)))
+
+(rt:deftest (fucc-generator::expand-form-ll :maybe 2)
+    (multiple-value-bind (nterm rules trans)
+        (fucc-generator::expand-form-ll
+         '(:maybe a (:list a b) b c)
+         nil
+         0)
+      (sublis (list (cons nterm 'no-such-symbol1)) rules))
+  ((no-such-symbol1 nil (constantly nil))
+   (no-such-symbol1 nil #'list a (:list a b) b c)))
+
+(rt:deftest (fucc-generator::expand-form-ll :list)
+    (multiple-value-bind (nterm rules trans)
+        (fucc-generator::expand-form-ll
+         '(:list a b)
+         nil
+         0)
+      (sublis (list (cons nterm 'no-such-symbol2)
+                    (cons (caadr rules) 'no-such-symbol1)) rules))
+  ((no-such-symbol2 nil #'cons a no-such-symbol1)
+   (no-such-symbol1 nil (constantly nil))
+   (no-such-symbol1 nil  (lambda (second first rest)
+                                              (cons first rest))
+                    b a no-such-symbol1)))
+
+;;;; Local variables: ***
+;;;; mode: lisp ***
+;;;; outline-regexp: ";;;; \\*\\*+ " ***
+;;;; End: ***

File test/fg-grammar-test.lisp

   ((s a b c (:do (print 'abc)))
    (s (:do (print 'car)) c a r)))
 
+(rt:deftest (fucc-generator::split-rule-form :warn)
+    (block nil
+      (handler-bind ((warning #'(lambda (&rest ingore)
+                                  (declare (ignore ingore))
+                                  (return :warn))))
+        (fucc-generator::split-rule-form '(s a b c))))
+  :warn)
+
+(rt:deftest (fucc-generator::split-rule-form :nowarn)
+    (block nil
+      (handler-bind ((warning #'(lambda (&rest ingore)
+                                  (declare (ignore ingore))
+                                  (return :warn))))
+        (fucc-generator::split-rule-form '(s -> a b c))))
+  ((s a b c)))
+
 (rt:deftest (fucc-generator::expand-action :simple)
     (fucc-generator::expand-action '(s  a b c (:call (function +))))
   ;; Result
   (s () (function +) a b c))
 
-(rt:deftest (fucc-generator::expand-action :insert-action)
-    (fucc-generator::expand-action '(s  a b c))
+(rt:deftest (fucc-generator::expand-action :insert-action-0)
+    (fucc-generator::expand-action '(s))
+  ;; Result
+  (s () (constantly nil)))
+
+(rt:deftest (fucc-generator::expand-action :insert-action-1)
+    (fucc-generator::expand-action '(s a))
+  ;; Result
+  (s () (function identity) a))
+
+(rt:deftest (fucc-generator::expand-action :insert-action-1-with-do)
+    (fucc-generator::expand-action '(s (:do nil) a))
+  ;; Result
+  (s () (function identity)
+     (:call (function (lambda () (declare (ignorable)) nil)))
+     a))
+
+(rt:deftest (fucc-generator::expand-action :insert-action-1-with-call)
+    (fucc-generator::expand-action '(s (:call (constantly 0)) a))
+  ;; Result
+  (s () (function identity)
+     (:call (constantly 0))
+     a))
+
+(rt:deftest (fucc-generator::expand-action :insert-action-2)
+    (fucc-generator::expand-action '(s a b))
+  ;; Result
+  (s () (function list) a b))
+
+(rt:deftest (fucc-generator::expand-action :insert-action-3)
+    (fucc-generator::expand-action '(s a b c))
   ;; Result
   (s () (function list) a b c))