compiler: use new parser for macro params.

* share/txr/stdlib/compiler.tl (expand-bind-mac-parse-params):
Function removed.
(expand-bind-mac-params): Use mac-param-parser struct.

1 files changed, 80 insertions, 100 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index c4a1a849..d4609e01 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -1164,23 +1164,6 @@
                               (sys:setq ,accum (last ,accum))))
                (t body)))))))
 
-(defun expand-bind-mac-parse-params (params form)
-  (let* ((rest-par (nthlast 0 params))
-         (proper-pars (ldiff params rest-par))
-         nonkey-pars key-pars)
-    (while proper-pars
-      (let ((pp (pop proper-pars)))
-        (caseq pp
-          ((:env :whole :form)
-           (unless proper-pars
-             (compile-error form "~s requires argument" pp))
-           (push (cons pp (pop proper-pars)) key-pars))
-          (t (push pp nonkey-pars)))))
-    (tree-bind (: req-pars raw-opt-pars) (split* (nreverse nonkey-pars)
-                                                 (op where (op eq :)))
-      (let ((opt-pars (mapcar [iffi atom list] raw-opt-pars)))
-        (list (nreverse key-pars) req-pars opt-pars rest-par)))))
-
 (defun expand-bind-mac-params (ctx-form err-form params menv-var
                                obj-var strict err-block body)
   (let (vars gen-stk (plen (gensym)))
@@ -1191,92 +1174,89 @@
                  (or (pop gen-stk) (gensym)))
                (put-gen (g)
                  (push g gen-stk))
-               (expand-rec (params obj-var)
-                 (tree-bind (key-pars req-pars opt-pars rest-par)
-                            (expand-bind-mac-parse-params params ctx-form)
-                   (let* ((nreq (len req-pars))
-                          (nfix (+ nreq (len opt-pars)))
-                          (curs (get-gen)))
-                     (unwind-protect
-                       ^(,*(when strict
-                             ^((set ,plen (if (consp ,obj-var)
-                                            (len ,obj-var) 0))))
-                         ,*(cond
-                             ((eq strict t)
-                              ^((if (< ,plen ,nreq)
-                                  ,(berr t))
-                                ,*(unless rest-par
-                                    ^((if (> ,plen ,nfix)
-                                        ,(berr nil))))))
-                             ((null strict) nil)
-                             ((symbolp strict)
-                              ^((if (< ,plen ,nreq)
-                                  (return-from ,err-block ',strict))
-                                ,*(unless rest-par
-                                    ^((if (> ,plen ,nfix)
-                                        (return-from ,err-block ',strict)))))))
-                         ,*(append-each ((k key-pars))
-                             (tree-bind (key . sym) k
-                               (push sym vars)
-                               (caseq key
-                                 (:whole ^((set ,sym ,obj-var)))
-                                 (:form ^((set ,sym ,ctx-form)))
-                                 (:env ^((set ,sym ,menv-var))))))
-                         ,*(append-each ((p req-pars))
+               (expand-rec (par-syntax obj-var)
+                 (let* ((pars (new (mac-param-parser par-syntax ctx-form)))
+                        (curs (get-gen)))
+                   (unwind-protect
+                     ^(,*(when strict
+                           ^((set ,plen (if (consp ,obj-var)
+                                          (len ,obj-var) 0))))
+                       ,*(cond
+                           ((eq strict t)
+                            ^((if (< ,plen ,pars.nreq)
+                                ,(berr t))
+                              ,*(unless pars.rest
+                                  ^((if (> ,plen ,pars.nfix)
+                                      ,(berr nil))))))
+                           ((null strict) nil)
+                           ((symbolp strict)
+                            ^((if (< ,plen ,pars.nreq)
+                                (return-from ,err-block ',strict))
+                              ,*(unless pars.rest
+                                  ^((if (> ,plen ,pars.nfix)
+                                      (return-from ,err-block ',strict)))))))
+                       ,*(append-each ((k pars.key))
+                           (tree-bind (key . sym) k
+                             (push sym vars)
+                             (caseq key
+                               (:whole ^((set ,sym ,obj-var)))
+                               (:form ^((set ,sym ,ctx-form)))
+                               (:env ^((set ,sym ,menv-var))))))
+                       ,*(append-each ((p pars.req))
+                           (cond
+                             ((listp p)
+                              ^((set ,curs (car ,obj-var))
+                                (set ,obj-var (cdr ,obj-var))
+                                ,*(expand-rec p curs)))
+                             (t
+                              (push p vars)
+                              ^((set ,p (car ,obj-var))
+                                (set ,obj-var (cdr ,obj-var))))))
+                       ,*(append-each ((o pars.opt))
+                           (tree-bind (p : init-form pres-p) o
                              (cond
                                ((listp p)
-                                ^((set ,curs (car ,obj-var))
-                                  (set ,obj-var (cdr ,obj-var))
-                                  ,*(expand-rec p curs)))
+                                (when pres-p
+                                  (push pres-p vars))
+                                ^((set ,curs (or (car ,obj-var)
+                                               (sys:upenv ,init-form)))
+                                  (cond
+                                    ((and ,obj-var
+                                          (prog1
+                                            (neq (set ,curs (car ,obj-var)) :)
+                                            (set ,obj-var (cdr ,obj-var))))
+                                      ,*(if pres-p
+                                          ^((set ,pres-p t))))
+                                    (t
+                                      (set ,curs (sys:upenv ,init-form))))
+                                  (when ,curs
+                                    ,*(expand-rec p curs))))
                                (t
-                                (push p vars)
-                                ^((set ,p (car ,obj-var))
-                                  (set ,obj-var (cdr ,obj-var))))))
-                         ,*(append-each ((o opt-pars))
-                             (tree-bind (p : init-form pres-p) o
-                               (cond
-                                 ((listp p)
-                                  (when pres-p
-                                    (push pres-p vars))
-                                  ^((set ,curs (or (car ,obj-var)
-                                                 (sys:upenv ,init-form)))
-                                    (cond
-                                      ((and ,obj-var
-                                            (prog1
-                                              (neq (set ,curs (car ,obj-var)) :)
-                                              (set ,obj-var (cdr ,obj-var))))
-                                        ,*(if pres-p
-                                            ^((set ,pres-p t))))
-                                      (t
-                                        (set ,curs (sys:upenv ,init-form))))
-                                    (when ,curs
-                                      ,*(expand-rec p curs))))
-                                 (t
-                                   (push p vars)
-                                   (when pres-p
-                                     (push pres-p vars))
-                                   ^((cond
-                                       ((and ,obj-var
-                                             (prog1
-                                               (neq (set ,p (car ,obj-var)) :)
-                                               (set ,obj-var (cdr ,obj-var))))
-                                        ,*(if pres-p
-                                            ^((set ,pres-p t))))
-                                       (t
-                                         ,*(if init-form
-                                             ^((set ,p (sys:upenv ,init-form)))))))))))
-                         ,*(when rest-par
-                             (push rest-par vars)
-                             ^((set ,rest-par ,obj-var)))
-                         ,*(unless rest-par
-                             (cond
-                               ((eq strict t)
-                                ^((if ,obj-var ,(berr nil))))
-                               ((null strict) nil)
-                               ((symbolp strict)
-                                ^((if ,obj-var
-                                    (return-from ,err-block ',strict)))))))
-                       (put-gen curs))))))
+                                 (push p vars)
+                                 (when pres-p
+                                   (push pres-p vars))
+                                 ^((cond
+                                     ((and ,obj-var
+                                           (prog1
+                                             (neq (set ,p (car ,obj-var)) :)
+                                             (set ,obj-var (cdr ,obj-var))))
+                                      ,*(if pres-p
+                                          ^((set ,pres-p t))))
+                                     (t
+                                       ,*(if init-form
+                                           ^((set ,p (sys:upenv ,init-form)))))))))))
+                       ,*(when pars.rest
+                           (push pars.rest vars)
+                           ^((set ,pars.rest ,obj-var)))
+                       ,*(unless pars.rest
+                           (cond
+                             ((eq strict t)
+                              ^((if ,obj-var ,(berr nil))))
+                             ((null strict) nil)
+                             ((symbolp strict)
+                              ^((if ,obj-var
+                                  (return-from ,err-block ',strict)))))))
+                     (put-gen curs)))))
         (let ((bind-code (expand-rec params obj-var)))
           ^(let (,*(nreverse vars) ,plen ,*gen-stk)
              ,*bind-code