op: new features for anonymous recursion.

Within the op syntax, the new implicit variable @rec
now refers to the function itself. There is also @(rec ...)
for calling the function through a function binding.
For instance, here is Fibonacci:

(do if (> @1 1) (+ @(rec (pred @1)) @(rec (ppred @1))) 1)

* share/txr/stdlib/op.tl (sys:op-ctx): New slots rec and
recvar.
(sys:op-rec-p, sys:op-ensure-rec): New functions.
(sys:op-alpha-rename): Check for the new syntaxes and
translate to appropriate gensymed expressions, while updating
the context structure, so the expander is informed about
the @rec or @(rec ...) activity in the expression.
(sys:op-expand): Check whether @rec or @(rec ...) has
been used in the expression, and generate the necessary
variants to support it. We need to bind the lambda to a
recursive binding using the same mechanism that labels
uses, and possibly to bind the gensym underneat @rec
to the value of that function binding.

* txr.1: op documentation extended to cover the new
feature, plus some wording improvements.

2 files changed, 88 insertions, 40 deletions

diff --git a/share/txr/stdlib/op.tl b/share/txr/stdlib/op.tl
index 03828d22..e9b19b45 100644
--- a/share/txr/stdlib/op.tl
+++ b/share/txr/stdlib/op.tl
@@ -27,7 +27,7 @@
 (defvar sys:*op-ctx*)
 
 (sys:make-struct-type
-  'sys:op-ctx nil nil '(form gens up meta) nil
+  'sys:op-ctx nil nil '(form gens up meta rec recvar) nil
   (lambda (me)
     (slotset me 'up sys:*op-ctx*)
     (slotset me 'meta (gensym "meta-")))
@@ -54,19 +54,36 @@
                       ((eq x 'sys:var) (or (integerp y)
                                            (eq y 'rest))))))))
 
+(defun sys:op-rec-p (expr)
+  (tree-case expr
+    ((x (y . r)) (and (eq x 'sys:expr) (eq y 'usr:rec)))))
+
+(defun sys:op-ensure-rec (ctx : recvar)
+  (when recvar
+    (slotset ctx 'recvar t))
+  (or (slot ctx 'rec) (slotset ctx 'rec (gensym "rec-"))))
+
 (defun sys:op-alpha-rename (f e op-args do-nested-metas)
   (let* ((ctx sys:*op-ctx*)
          (code ^(macrolet ((sys:expr (:form f arg)
                              (let ((ctx ,ctx))
-                               (if (and (slot ctx 'up) (sys:op-meta-p arg))
-                                 ^(,(slot (slot ctx 'up) 'meta) (quote ,arg))
-                               f)))
+                               (cond
+                                 ((and (slot ctx 'up)
+                                       (or (sys:op-meta-p arg)
+                                           (sys:op-rec-p arg)
+                                           (equal arg '(sys:var usr:rec))))
+                                  ^(,(slot (slot ctx 'up) 'meta) (quote ,arg)))
+                                 ((sys:op-rec-p f)
+                                  ^(,(sys:op-ensure-rec ctx) ,*(rest arg)))
+                                 (t f))))
                            (sys:var (:form f arg . mods)
                              (cond
-                               ((and (not mods) (sys:op-meta-p f))
+                               ((sys:op-meta-p f)
                                 (unless (integerp arg)
                                   (sys:setq arg 0))
                                 (sys:ensure-op-arg ,ctx arg))
+                               ((equal f '(sys:var usr:rec))
+                                (sys:op-ensure-rec ,ctx t))
                                (t f)))
                            ,*(if do-nested-metas
                                ^((,(slot ctx 'meta) ((quote arg)) arg))))
@@ -74,6 +91,8 @@
     (expand code e)))
 
 (defun sys:op-expand (f e args)
+  (unless args
+    ['compile-error f "arguments required"])
   (let* ((ctx (make-struct 'sys:op-ctx ^(form ,f)))
          (sys:*op-ctx* ctx)
          (sym (car f))
@@ -81,21 +100,30 @@
          (syntax-1 (sys:op-alpha-rename f e syntax-0 nil))
          (syntax-2 (sys:op-alpha-rename f e syntax-1 t))
          (metas (slot ctx 'gens))
-         (rest-sym (sys:ensure-op-arg ctx 0)))
-     (unless args
-       ['compile-error f "arguments required"])
-    ^(lambda (,*(cdr metas) . ,rest-sym)
-       ,(let ((fargs (cdr (cdr syntax-2))))
-          (cond
-            ((and (eq sym 'lop) fargs)
-             (let ((fargs-l1 (mapcar (lambda (farg)
-                                       ^(sys:l1-val ,farg))
-                                     fargs)))
-               ^[sys:apply ,(car (cdr syntax-2))
-                           (append ,rest-sym (list ,*fargs-l1))]))
-            ((or metas (eq sym 'do))
-             syntax-2)
-            (t (append syntax-2 rest-sym)))))))
+         (rec (slot ctx 'rec))
+         (recvar (slot ctx 'recvar))
+         (rest-sym (sys:ensure-op-arg ctx 0))
+         (lambda-interior (let ((fargs (cdr (cdr syntax-2))))
+                            (cond
+                              ((and (eq sym 'lop) fargs)
+                               (let ((fargs-l1 (mapcar (lambda (farg)
+                                                         ^(sys:l1-val ,farg))
+                                                       fargs)))
+                                 ^[sys:apply ,(car (cdr syntax-2))
+                                             (append ,rest-sym (list ,*fargs-l1))]))
+                              ((or metas (eq sym 'do))
+                               syntax-2)
+                              (t (append syntax-2 rest-sym))))))
+    (cond
+      (recvar ^(sys:lbind ((,rec (lambda (,*(cdr metas) . ,rest-sym)
+                                   (let ((,rec (fun ,rec)))
+                                     ,lambda-interior))))
+                 (fun ,rec)))
+      (rec ^(sys:lbind ((,rec (lambda (,*(cdr metas) . ,rest-sym)
+                                ,lambda-interior)))
+              (fun ,rec)))
+      (t ^(lambda (,*(cdr metas) . ,rest-sym)
+            ,lambda-interior)))))
 
 (defmacro op (:form f :env e . args)
   (sys:op-expand f e args))
diff --git a/txr.1 b/txr.1
index 6586d9fe..4c7148f3 100644
--- a/txr.1
+++ b/txr.1
@@ -45099,17 +45099,19 @@ an anonymous function which, if called with one argument, stores that argument
 into
 .codn x .
 
-The argument forms are arbitrary expressions, within which a special
-convention is permitted:
+The argument forms are arbitrary expressions, within which special
+conventions is permitted regarding the use of certain implicit variables:
 .RS
 .meIP >> @ num
 A number preceded by a
 .code @
-is a metanumber. This is a special syntax
-which denotes an argument. For instance
+is, syntactically, a metanumber. If it appears inside
+.code op
+as an expression, it behaves as a positional argument, whose
+existence it implies. For instance
 .code @2
-means that the second argument of
-the anonymous function is to be substituted in place of the
+means that the function shall have at least two arguments,
+the second argument of which is be substituted in place of the
 .codn @2 .
 .code op
 generates a function which has a number of required arguments equal to the
@@ -45127,14 +45129,29 @@ argument to
 returning the result, and ignores its first two arguments).
 There is no way to use
 .code op
-to generate functions which have optional arguments.
+to generate functions which have optional arguments.  The positional
+arguments are mutable; they may be assigned.
 .meIP < @rest
 If the meta-symbol
 .meta @rest
 appears in the
 .code op
-syntax, it explicitly denotes the list of trailing arguments,
-allowing them to be placed anywhere in the expression.
+syntax as an expression, it explicitly denotes and evaluates to the list of
+trailing arguments. Like the metanumber positional arguments, it
+may be assigned.
+.meIP < @rec
+If the meta-symbol
+.meta @rec
+appears in the
+.code op
+syntax as an expression, it denotes a mutable variable which is bound to the
+function itself which is generated by that
+.code op
+expression.
+.meIP >> @( rec ...)
+If this syntax appears inside
+.codn op ,
+it specifies a recursive call the function.
 .RE
 
 .IP
@@ -45155,7 +45172,7 @@ syntax, then
 is implicitly inserted.  What this means is that, for example, since
 the form
 .code "(op foo)"
-does not contain any numeric positional arguments like
+does not contain any implicit positional arguments like
 .codn @1 ,
 and does not contain
 .codn @rest ,
@@ -45231,10 +45248,11 @@ The
 and
 .code do
 operators can be nested, in any combination. This raises the
-question: if a metanumber like
-.code @1
-or
+question: if an expression like
+.codn @1 ,
 .code @rest
+or
+.code @rec
 occurs in an
 .code op
 that is nested
@@ -45242,22 +45260,24 @@ within an
 .codn op ,
 what is the meaning?
 
-A metanumber always belongs with the inner-most op or do operator. So for
-instance
+An expression with a single
+.code @
+always belongs with the inner-most op or do
+operator. So for instance
 .code "(op (op @1))"
 means that an
 .code "(op @1)"
 expression is nested
-within an
+within an outer
 .code op
-expression which itself contains no meta-syntax.
+expression that contains no references to its implicit variables.
 The
 .code @1
-belongs with the inner op.
+belongs to the inner op.
 
 There is a way for an inner
 .code op
-to refer to an outer op metanumber argument. This is
+to refer to the implicit variables of an outer one. This is
 expressed by adding an extra
 .code @
 prefix for every level of escape. For example in
@@ -45296,7 +45316,7 @@ a parameter from the outermost
 into the innermost
 .codn op .
 
-Note that meta-numbers and meta-symbols belonging to an
+Note that the implicit variables belonging to an
 .code op
 can be used in the dot position of a function call, such as: