Source

fucc / generator / fg-grammar-lr.lisp

#|
 Copyright (c) 2006-2008 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 "SYM1")))
    (ecase (first form)
      ((:* *)
       (push `(,generated-sym1 nil
               #'(lambda (cdr &rest car) ; Twisted!
                          (append (reverse car) cdr))
               ,generated-sym1 ,@(rest form))
             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 "SYM1")))
    (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 "NTERM") :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 "ARG")
     :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))))