From a7f158174e41155a119f8762f2bb36def24cb828 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Thu, 3 Oct 2019 20:06:49 -0700 Subject: 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. --- share/txr/stdlib/op.tl | 68 +++++++++++++++++++++++++++++++++++--------------- 1 file changed, 48 insertions(+), 20 deletions(-) (limited to 'share') 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)) -- cgit v1.2.3