New special operator: progv

Adding a progv operator, similar to the Common Lisp one.

* eval.c (progv_s): New symbol variable.
(op_progv): New static function.
(do_expand): Recognize and traverse the progv form.
(rt_progv): New static function: run-time support
for compiled progv.
(eval_init): Initialize progv_s, and register the the
op_progv operator interpreting function.

* stdlib/compilert (compiler compile): Handle progv
operator ...
(compiler comp-progv): ... via this new method.

* tests/019/progv.tl: New file.

* txr.1: Documented.

* stdlib/doc-syms.tl: Updated.

1 files changed, 27 insertions, 0 deletions

diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index cdbd3a3f..cc4eef7b 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -531,6 +531,7 @@
               (and me.(compile oreg env (expand-and form)))
               (or me.(comp-or oreg env form))
               (prog1 me.(comp-prog1 oreg env form))
+              (progv me.(comp-progv oreg env form))
               (sys:quasi me.(comp-quasi oreg env form))
               (dohash me.(compile oreg env (expand-dohash form)))
               (tree-bind me.(comp-tree-bind oreg env form))
@@ -1324,6 +1325,32 @@
     ((t fi) me.(compile oreg env fi))
     ((t) me.(compile oreg env nil))))
 
+(defmeth compiler comp-progv (me oreg env form)
+  (tree-case form
+    ((t syms vals)
+     me.(comp-progn oreg env ^(progn ,syms ,vals nil)))
+    ((t syms vals . body)
+     (let* ((denv (new env up env co me))
+            (sreg me.(alloc-treg))
+            (vreg me.(alloc-treg))
+            (sfrag me.(compile sreg env syms))
+            (vfrag me.(compile vreg env vals))
+            (bfrag me.(comp-progn oreg denv body)))
+       me.(free-treg sreg)
+       me.(free-treg vreg)
+       (new (frag bfrag.oreg
+                  (append sfrag.code
+                          vfrag.code
+                          ^((dframe ,denv.lev 0)
+                            (gcall ,oreg
+                                   ,me.(get-sidx 'sys:rt-progv)
+                                   ,sfrag.oreg
+                                   ,vfrag.oreg))
+                          bfrag.code
+                          '((end nil)))
+                  (uni sfrag.fvars (uni vfrag.fvars bfrag.fvars))
+                  (uni sfrag.ffuns (uni vfrag.ffuns bfrag.ffuns))))))))
+
 (defmeth compiler comp-quasi (me oreg env form)
   (let ((qexp (expand-quasi form)))
     me.(compile oreg env (expand qexp))))