From 6eb147ff66fb54800e1b37730dc3de51868d8ea5 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Thu, 3 Aug 2023 06:36:48 -0700 Subject: opip: new special handling of (let ...). * stdlib/op.tl (sys:opip-single-let-p, sys:opip-let-p): New functions. (sys:opip-expand): Restructure from collect loop to car/cdr recursive form, because the new let operators in opip need access to the rest of the pipeline. Implement let operators. * tests/012/op.tl: New tests. * txr.1: Documented. --- stdlib/op.tl | 43 ++++++++++++++++++++++++++++++++++--------- 1 file changed, 34 insertions(+), 9 deletions(-) (limited to 'stdlib') diff --git a/stdlib/op.tl b/stdlib/op.tl index 31d0dc37..2a41fc5a 100644 --- a/stdlib/op.tl +++ b/stdlib/op.tl @@ -216,16 +216,41 @@ (defmacro aret (arg) ^(ap identity* ,arg)) +(defun sys:opip-single-let-p (c) + (tree-case c + ((op sym) + (and (eq op 'let) + (atom sym))) + (t nil))) + +(defun sys:opip-let-p (c) + (tree-case c + ((op (sym t) . rest) + (and (eq op 'let) + (atom sym) + (listp rest))) + (t nil))) + (defun sys:opip-expand (e clauses) - (collect-each ((c clauses)) - (if (atom c) - c - (let ((sym (car c))) - (if (member sym '(dwim uref qref op do lop ldo ap ip ado ido ret aret)) - c - (let ((opdo (if (or (special-operator-p (car c)) - (macro-form-p c e)) 'do 'op))) - ^(,opdo ,*c))))))) + (tree-case clauses + (nil nil) + ((c . rest) + (if (atom c) + (cons c (sys:opip-expand e rest)) + (let ((sym (car c))) + (cond + ((memq sym '(dwim uref qref op do lop ldo ap ip ado ido ret aret)) + (cons c (sys:opip-expand e rest))) + ((sys:opip-single-let-p c) + (tree-bind (t sym) c + (sys:opip-expand e ^((let (,sym @1)) ,*rest)))) + ((sys:opip-let-p c) + (tree-bind (t . vars) c + ^((do let* ,vars + [(opip ,*(sys:opip-expand e rest)) @1])))) + (t (let ((opdo (if (or (special-operator-p (car c)) + (macro-form-p c e)) 'do 'op))) + (cons ^(,opdo ,*c) (sys:opip-expand e rest)))))))))) (defmacro opip (:env e . clauses) ^[chain ,*(sys:opip-expand e clauses)]) -- cgit v1.2.3