From 2fca0d0511dcc5514d97b5cf559df1f38afad56c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 24 Apr 2019 19:44:50 +0200 Subject: Add let-lazy. --- module/util.scm | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/module/util.scm b/module/util.scm index 9a816cee..9673288d 100644 --- a/module/util.scm +++ b/module/util.scm @@ -8,7 +8,9 @@ mod! sort* sort*! mod/r! set/r! find-min - catch-multiple) + catch-multiple + quote? + tree-map let-lazy) #:replace (let* set! define-syntax) ) @@ -335,4 +337,25 @@ (else (values (reverse done) rem))))) +(define* (tree-map proc tree #:key (descend (const #t))) + (cond ((not (list? tree)) (proc tree)) + ((null? tree) '()) + ((list? (car tree)) + (cons (if (descend (car tree)) + (tree-map proc (car tree) #:descend descend) + (car tree)) + (tree-map proc (cdr tree) #:descend descend))) + (else (cons (proc (car tree)) + (tree-map proc (cdr tree) #:descend descend))))) + +(define (quote? form) + (and (not (null? form)) + (eq? 'quote (car form)))) + +(define-macro (let-lazy bindings . body) + (let ((keys (map car bindings))) + `(let ,(map (lambda (b) `(,(car b) (delay ,@(cdr b)))) + bindings) + ,@(tree-map (lambda (t) (if (memv t keys) `(force ,t) t)) + body #:descend (negate quote?))))) -- cgit v1.2.3