Commits

Ivan Boldyrev  committed 726c5a5

Syntax of grammar definitions is changed.
Keywords: grammar, syntax, doc, examples

* doc/MACRO:
Documentation of new syntax.

* examples/calculator.lisp (*calculator-parser*):
Example is changed according to new syntax.

* generator/fg-grammar.lisp (split-rule-form, etc):
Grammar parsing is changed very much.

* test/fg-grammar-test.lisp:
Test of some functions from fg-grammar.lisp.

  • Participants
  • Parent commits 1ffa723

Comments (0)

Files changed (4)

 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)
+RULE := (SYMBOL [DELIM VAR-DESIGNATOR*]+)
 
 VAL-DESIGNATOR := (:var SYMBOL RULE-EXP)
                |  (:initarg SYMBOL RULE-EXP)
                |  RULE-EXP
+               |  ACTION-DESCRIPTION
+
+ACTION-DESCRIPTION := (:call FUNCTION)
+                   |  (:class CLASS)
+                   |  (:do LIST-OF-FORMS)
+
 
 RULE-EXP       := (CL:* RULE-EXP)
                |  (CL:+ RULE-EXP)
                |  (:LIST RULE-EXP RULE-EXP)
                |  SYMBOL
 
-It describes action performed when the rule is reduced.
+DELIM in one RULE is same symbol:
+
+  (a -> b c
+     -> k l m n)
+
+but not
+
+  (a -> b c
+     => k l m n)
+
+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.
 
 FUNCTION here is a form that evaluates to function designator.  For
 example:
   #'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
+:DO 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.
 delimited by RULE-EXP2.  Semantic values aof RULE-EXP1 and RULE-EXP2
 are in same list.  For example:
 
-  (SEQ (...)
+  (SEQ ->
        (:LIST OPERATOR SEMICOLON))
 
 is equivalent to:
 
-  (SEQ (...)
+  (SEQ ->
        OPERATOR)
-  (SEQ (...)
+  (SEQ ->
        OPERATOR SEMICOLON OPERATOR)
-  (SEQ (...)
+  (SEQ ->
        OPERATOR SEMICOLON OPERATOR SEMICOLON OPERATOR)
   ... #| and so on |#
 
 Note that
-  (SEQ2 (...)
+  (SEQ2 ->
        (:LIST OPERATOR SEMICOLON) SEMICOLON)
 
 equals to
-  (SEQ2 (...)
+  (SEQ2 ->
        OPERATOR SEMICOLON)
-  (SEQ2 (...)
+  (SEQ2 ->
        OPERATOR SEMICOLON OPERATOR SEMICOLON)
-  (SEQ2 (...)
+  (SEQ2 ->
        OPERATOR SEMICOLON OPERATOR SEMICOLON OPERATOR SEMICOLON)
   ... #| and so on |#
 

File examples/calculator.lisp

   ;; List of terminal
   (+ - * / = :semicolon :id :const)
   ;; List of rules
-  ((s   (:form (format t "Value: ~S" (first (last exp-list))))
+  ((s ->
       (:var exp-list (:list exp :semicolon))
-      (:maybe :semicolon))
+      (:maybe :semicolon)
+      (:do (format t "Value: ~S" (first (last exp-list)))))
    ;; 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))
+   (exp -> (:var var :id) = (:var exp exp)
+           (:do (setf (gethash var *dictionary*)
+                      exp))
+        ;; Binary operations
+
+            -> exp
+           (:or ((:or + -)) ; Nested OR here is just for fun
+                * /)
+           exp
+           (:call (lambda (a op b)
+                    (funcall op a b)))
+        ;; Constants
+        -> :const
+        ;; and variables
+        ->  :id
+            (:call (lambda (var)
+                     (or (gethash var *dictionary*)
+                         (error "Undefined variable: ~S" var))))))
   :prec-info
   ((:right =) ;; Actually associativity doesn't matter here because
 	      ;; it is enforsed by rule structure anyway.

File generator/fg-grammar.lisp

                               :id (incf *grammar-next-id*)
                               :is-terminal is-terminal))))))
 
+(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
+    (let ((left-sides (list nil)))
+      (dolist (token data)
+        (if (eq delim token)
+            (push () left-sides)
+            (push token (first left-sides))))
+      (mapcar #'(lambda (rest) (cons left-nterminal (nreverse rest)))
+              (nreverse left-sides)))))
+
 (defun process-rule (s-rule)
   "Process given rule and return RULE object."
-  (destructuring-bind (left args &rest right) s-rule
+  (destructuring-bind (left args main-action &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
+                         :action main-action
                          args)))
         (push rule
               (nterm-rules left-nterm))
                 (setf (prec-assoc    rule) (prec-assoc    last-terminal)
                   (prec-priority rule) (prec-priority last-terminal)))))))
 
-(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 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)))))
 
-(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 expand-action--class (form rhs rest rev-var-list rev-initarg-list)
+  (unless (null (rest rest))
+    (error "~S form ~S must be last in the clause: ~S" :class form rhs))
+  `(:call (function (lambda ,(reverse rev-var-list)
+            (declare (ignorable ,@rev-var-list))
+            (make-instance (quote ,(second form))
+                           ,@(reverse rev-initarg-list))))))
 
-(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.")))))
+(defparameter +complex-attribute-form+
+  '(:do :class))
+
+(defparameter +attribute-form+
+  '(:do :class :call))
+
+(defun complex-attribute-form-p (form)
+  "True if form is non-primitive attribute form."
+  (and (consp form)
+       (member (first form) +complex-attribute-form+)))
+
+(defun attribute-form-p (form)
+  "True if form is any attribute form."
+  (and (consp form)
+       (member (first form) +attribute-form+)))
+
+(defun expand-action (rule)
+  (destructuring-bind (lhs &rest rhs) rule
+    (let ((exp-rhs (expand-rhs rhs)))
+      (let ((primary-action (second (first (last exp-rhs))))
+            (new-rhs (nbutlast exp-rhs)))
+        `(,lhs ,nil ,primary-action ,@new-rhs)))))
+      
+(defun expand-rhs (rhs)
+  (let ((var-list '())
+        (rev-initarg-list '()))
+    (nconc
+     (loop :for form :in rhs
+        :for rest :on rhs
+        :collect
+        (cond
+          ((complex-attribute-form-p form)
+           (ecase (first form)
+             ((:do)
+              (expand-action--do form var-list rest))
+             ((:class)
+              (expand-action--class form rhs rest var-list rev-initarg-list))))
+          ((consp form)
+           (case (first form)
+             ((:var)
+              ;; TODO: ASSERT is not proper form here
+              (assert (cddr form) nil
+                      "Var clause is too short: ~S" form)
+              (assert (not (cdddr form)) nil
+                      "Var clause is too long: ~S" form)
+              (push (second form) var-list)
+              (third form))
+             ((:initarg)
+              ;; TODO: ASSERT is not proper form here
+              (assert (cddr form) nil
+                      "Intarg clause is too short: ~S" form)
+              (assert (not (cdddr form)) nil
+                      "Init-Env clause is too long: ~S" form)
+              (let ((var (gensym)))
+                (push (second form)
+                      rev-initarg-list)
+                (push var
+                      rev-initarg-list)
+                (push var var-list)
+                (third form)))
+             (t
+              (let ((var (gensym)))
+                (push var var-list)
+                form))))
+          (t
+           (let ((var (gensym)))
+             (push var var-list)
+             form))))
+     ;; Primary action
+     (cond
+       ((null rhs)
+        '((:call (constantly nil))))
+       ((not (attribute-form-p (first (last rhs))))
+        (if (rest rhs)
+            '((:call (function list)))
+            '((:call (function identity)))))
+       (t
+        '())))))
 
 (defparameter +complex-forms+
-  '(:* * :+ + :maybe :list))
+  '(:* * :+ + :maybe :list :call))
 
 ;;;  Transform complex forms like "(:+ a)" into 3 values:
 ;;;
         (generated-sym1 (gensym)))
     (ecase (first form)
       ((:* *)
-       (push `(,generated-sym1 (:action #'(lambda (cdr &rest car) ; Twisted!
-                                            (append (reverse car) cdr)))
-               ,generated-sym1 ,@(rest form))
+       (push `(,generated-sym1 nil
+               ,generated-sym1 ,@(rest form)
+               #'(lambda (cdr &rest car) ; Twisted!
+                          (append (reverse car) cdr)))
              generated-rules)
-       (push `(,generated-sym1 (:action (constantly nil))
-               ) ; empty
+       (push `(,generated-sym1 nil 
+               (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)))
+       (push `(,generated-sym1 nil
+               #'(lambda (cdr &rest car) ; Twisted!
+                   (append (reverse car) cdr))
                ,generated-sym1 ,@(rest form))
              generated-rules)
-       (push `(,generated-sym1 (:action #'list)
+       (push `(,generated-sym1 nil
+               #'list
                ,@(rest form))
              generated-rules)
        (values generated-sym1 generated-rules 'common-lisp:reverse))
       ((:maybe)
-       (push (if (cddr form)
-                 `(,generated-sym1 (:action #'list)
-                   ,@(rest form))
-                 `(,generated-sym1 (:action #'identity)
+       (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 (:action (constantly nil)))
+       (push `(,generated-sym1 nil
+               (constantly nil)
+               ;; Empty
+               )
              generated-rules)
        (values generated-sym1 generated-rules nil))
       ((:list)
          ;; 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)))
+         (push `(,generated-sym1 nil
+                 #'(lambda (list cons car)
+                            (declare (ignore cons))
+                            (cons car list))
                  ,generated-sym1 ,delim ,item)
                generated-rules)
-         (push `(,generated-sym1 (:action #'list)
+         (push `(,generated-sym1 nil
+                 #'list
                  ,item)
                generated-rules)
-         (values generated-sym1 generated-rules 'common-lisp:reverse))))))
+         (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))
          ;; Rest of short subforms are inserted into new rules:
          ;; subform replaces inlinable form in original rule.
          (let* ((rule-left (first rule))
-                (rule-action (second rule))
-                (rule-right (cddr 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-action
+                       :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 (:action #'list)
+             (push `(,generated-sym1 nil
+                     #'list
                      ,@subform)
                    new-rules))
            ;; First short subform happens to be complex form, it is
              +inlineable-forms+)
      (expand-inlinable-form form rule pos))))
 
-(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 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
-                 (loop :for form :in (cddr 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)))
+                 ;; 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)
-                   ,(if (some #'identity transforms)
-                        (apply-argument-transforms transforms (second rule))
-                        (second rule))
-              ,@rhs-expand)
+               ,(second rule)
+               ,(if (some #'identity transforms)
+                    (apply-argument-transforms-to-action transforms (third rule))
+                    (third rule))
+               ,@rhs-expand)
             more-rules))))
    rules))
 
                                rules)))
 
 (defun parse-grammar (initial terminals rules &key prec-info)
+  ;; Add EOF mark
   (push +EOF+ terminals)
+  ;; Add artifical start rule
   (setf rules
         (append rules
-                (list (list +START+ '(:action (function identity))
-                            initial))))
+                (list `(,+START+ #:-> ,initial (:call (function identity))))))
   (with-new-grammar-environment
-    (multiple-value-bind (terminals first-nterminal-id)  (init-env terminals)
+    (multiple-value-bind (terminals first-nterminal-id)
+        (init-env terminals) ;; Terminals added here
       (let* ((proc-rules (mapcar #'process-rule
                                  (expand-rules
-                                  (mapcar #'generate-action rules))))
+                                  (mapcar #'expand-action
+                                          (mapcan #'split-rule-form rules)))))
              (nterminals (sort (loop :for nterm
                                  :being :each :hash-value :of *grammar-environment*
                                  :when (not (terminal-p nterm))

File test/fg-grammar-test.lisp

+;;;; ** Grammar parsing
+(rt:deftest (fucc-generator::split-rule-form :simple)
+    (fucc-generator::split-rule-form '(s -> a b c (:do (print 'abc))))
+  ;; Result
+  ((s a b c (:do (print 'abc)))))
+
+(rt:deftest (fucc-generator::split-rule-form :multiple)
+    (fucc-generator::split-rule-form '(s -> a b c (:do (print 'abc))
+                                       -> (:do (print 'car)) c a r))
+  ;; Result
+  ((s a b c (:do (print 'abc)))
+   (s (:do (print 'car)) c a r)))
+
+(rt:deftest (fucc-generator::split-rule-form :separator)
+    (fucc-generator::split-rule-form '(s :=> a b c (:do (print 'abc))
+                                       :=> (:do (print 'car)) c a r))
+  ;; Result
+  ((s a b c (:do (print 'abc)))
+   (s (:do (print 'car)) c a r)))
+
+(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))
+  ;; Result
+  (s () (function list) a b c))
+
+(defun replace-arguments (form arguments-extractor replace)
+  (let ((args (funcall arguments-extractor form)))
+    (sublis
+     (loop
+        :for arg :in args
+        :for new-arg :in replace
+        :collect (cons arg new-arg))
+     form)))
+
+(rt:deftest (fucc-generator::expand-action :class)
+    (replace-arguments
+     (fucc-generator::expand-action '(s
+                                      (:initarg :a a)
+                                      b
+                                      (:initarg :c c)
+                                      (:class test)))
+     (lambda (form) (cadar (cdaddr form)))
+     '(a0 b1 c2))
+  ;; Result
+  (s () (function (lambda (a0 b1 c2)
+          (declare (ignorable c2 b1 a0))
+          (make-instance 'test :a a0 :c c2)))
+     a b c))
+
+(rt:deftest (fucc-generator::expand-action :form)
+    (fucc-generator::expand-action '(s
+                                     (:do (print "Hello, world!"))
+                                     (:var a1 a)
+                                     (:var b (:or b c))
+                                     (:var a2 a)
+                                     (:do (list a1 a2 b))))
+  ;; Result
+  (s ()
+     (function
+      (lambda (a1 b a2)
+       (declare (ignorable a2 b a1))
+       (list a1 a2 b)))
+     (:call (function
+             (lambda ()
+              (declare (ignorable))
+              (print "Hello, world!"))))
+     a (:or b c) a))
+
+(rt:deftest (fucc-generator::apply-argument-transforms-to-action :simple)
+    (replace-arguments
+     (fucc-generator::apply-argument-transforms-to-action
+      '(nil nil reverse nil)
+      '(lambda (a b c d) (list a d b c)))
+     #'cadadr
+     '(k l m n))
+  ;; Result
+  (function
+    (lambda (k l m n)
+     (funcall (lambda (a b c d) (list a d b c)) k l (reverse m) n))))
+
+;;;; Local variables: ***
+;;;; mode: lisp ***
+;;;; outline-regexp: ";;;; \\*\\*+ " ***
+;;;; End: ***