Undid racketification, because not diffrentiating between :for and :acc means that errors become very strange and unhelpful.
Added simple forms, like loop/list that accumulates bodies into a list. Add :final that works like in racket: (loop/list ((:for a (in-list '(1 2 3))) :final (= a 2)) (display a)) => (1 2)
This commit is contained in:
Linus
parent
80464ebe48
commit
1a826f86e2
2 changed files with 154 additions and 115 deletions
150
goof.scm
150
goof.scm
|
|
@ -33,15 +33,15 @@
|
||||||
;; trying to understand the iterator protocol.
|
;; trying to understand the iterator protocol.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(use-modules (helpers)
|
(use-modules (helpers)
|
||||||
((srfi srfi-1) #:select (circular-list))
|
((srfi srfi-1) #:select (circular-list))
|
||||||
(srfi srfi-71)
|
(srfi srfi-71)
|
||||||
(rnrs io simple))
|
(rnrs io simple)
|
||||||
|
(ice-9 futures))
|
||||||
|
|
||||||
(define-aux-syntaxes
|
(define-aux-syntaxes
|
||||||
;; Auxiliary syntax for the loop clauses
|
;; Auxiliary syntax for the loop clauses
|
||||||
:when :unless :break :final :let :let* :subloop
|
:when :unless :break :final :let :let* :subloop :for :acc
|
||||||
;; Auxiliary syntax for the iterators.
|
;; Auxiliary syntax for the iterators.
|
||||||
:gen)
|
:gen)
|
||||||
|
|
||||||
|
|
@ -51,23 +51,31 @@
|
||||||
|
|
||||||
|
|
||||||
(define-syntax loop
|
(define-syntax loop
|
||||||
(syntax-rules ()
|
(syntax-rules (=>)
|
||||||
|
((loop () => expr body ...)
|
||||||
|
(let () expr))
|
||||||
|
((loop () body ...)
|
||||||
|
(let () body ...))
|
||||||
|
((loop name () => expr body ...)
|
||||||
|
expr)
|
||||||
|
((loop name () body ...)
|
||||||
|
(if #f #f))
|
||||||
((loop (clauses ...) body ...)
|
((loop (clauses ...) body ...)
|
||||||
(cl (loop (clauses ...) body ...)
|
(cl (loop (clauses ...) body ...)
|
||||||
loop-name
|
loop-name
|
||||||
(()) (()) (()) (()) (()) () (()) (()) (())
|
(()) (()) (()) (()) (()) () (()) (()) (()) ()
|
||||||
(clauses ...)
|
(clauses ...)
|
||||||
body ... (loop-name)))
|
body ... (loop-name)))
|
||||||
((loop name (clauses ...) . body)
|
((loop name (clauses ...) . body)
|
||||||
(cl (loop name (clauses ...) . body)
|
(cl (loop name (clauses ...) . body)
|
||||||
name
|
name
|
||||||
(()) (()) (()) (()) (()) () (()) (()) (())
|
(()) (()) (()) (()) (()) () (()) (()) (()) ()
|
||||||
(clauses ...)
|
(clauses ...)
|
||||||
. body))))
|
. body))))
|
||||||
|
|
||||||
(define-syntax push-new-subloop
|
(define-syntax push-new-subloop
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ orig name (lets ...) (accs ...) (vars ...) (checks ...) (refs ...) f (ul ...) (uw ...) (ub ...) clauses . body)
|
((_ orig name (lets ...) (accs ...) (vars ...) (checks ...) (refs ...) f (ul ...) (uw ...) (ub ...) uf clauses . body)
|
||||||
(cl orig name
|
(cl orig name
|
||||||
(() lets ...)
|
(() lets ...)
|
||||||
(() accs ...)
|
(() accs ...)
|
||||||
|
|
@ -78,47 +86,58 @@
|
||||||
(() ul ...)
|
(() ul ...)
|
||||||
(() uw ...)
|
(() uw ...)
|
||||||
(() ub ...)
|
(() ub ...)
|
||||||
|
uf
|
||||||
clauses . body))))
|
clauses . body))))
|
||||||
|
|
||||||
|
|
||||||
;; Clauses sorts all the clauses into subloops and positions everything where it should be.
|
;; Clauses sorts all the clauses into subloops and positions everything where it should be.
|
||||||
(define-syntax cl
|
(define-syntax cl
|
||||||
(syntax-rules (=> in :when :unless :break :final :let :let* :subloop)
|
(syntax-rules (=> :for :acc :when :unless :break :final :let :let* :subloop)
|
||||||
((_ orig name l a v c r f ul uw ub () => expr . body)
|
((_ orig name l a v c r f ul uw ub uf () => expr . body)
|
||||||
(emit orig name l a v c r f ul uw ub expr . body))
|
(emit orig name l a v c r f ul uw ub uf expr . body))
|
||||||
((_ orig name l a v c r f ul uw ub () . body)
|
((_ orig name l a v c r f ul uw ub uf () . body)
|
||||||
(emit orig name l a v c r f ul uw ub (if #f #f) . body))
|
(emit orig name l a v c r f ul uw ub uf (if #f #f) . body))
|
||||||
|
|
||||||
|
;; USER LETS
|
||||||
|
((_ orig name l a v c r f ((cur-ul ...) . ul-rest) uw ub uf (:let (id id* ... expr) clauses ...) . body)
|
||||||
|
(cl orig name l a v c r f ((cur-ul ... (:let id id* ... expr)) . ul-rest) uw ub uf (clauses ...) . body))
|
||||||
|
((_ orig name l a v c r f ((cur-ul ...) . ul-rest) uw ub uf (:let* (id id* ... expr) clauses ...) . body)
|
||||||
|
(cl orig name l a v c r f ((cur-ul ... (:let* id id* ... expr)) . ul-rest) uw ub uf (clauses ...) . body))
|
||||||
;; user-whens
|
;; user-whens
|
||||||
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub (:when test clauses ...) . body)
|
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub uf (:when test clauses ...) . body)
|
||||||
(cl orig name l a v c r f ul ((cur-uw ... test) . uw-rest) ub (clauses ...) . body))
|
(cl orig name l a v c r f ul ((cur-uw ... test) . uw-rest) ub uf (clauses ...) . body))
|
||||||
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub (:unless test clauses ...) . body)
|
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub uf (:unless test clauses ...) . body)
|
||||||
(cl orig name l a v c r f ul ((cur-uw ... (not test)) . uw-rest) ub (clauses ...) . body))
|
(cl orig name l a v c r f ul ((cur-uw ... (not test)) . uw-rest) ub uf (clauses ...) . body))
|
||||||
;; USER BREAKS
|
;; USER BREAKS
|
||||||
;; This pushes a #t to the user when expression, thus forcing a subloop if a for-clause is found afterwards.
|
;; This pushes a #t to the user when expression, thus forcing a subloop if a for-clause is found afterwards.
|
||||||
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ((cur-ub ...) . ub-rest) (:break expr clauses ...) . body)
|
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ((cur-ub ...) . ub-rest) uf (:break expr clauses ...) . body)
|
||||||
(cl orig name l a v c r f ul ((cur-uw ... #t) . uw-rest) ((cur-ub ... expr) . ub-rest) (clauses ...) . body))
|
(cl orig name l a v c r f ul ((cur-uw ... #t) . uw-rest) ((cur-ub ... expr) . ub-rest) uf (clauses ...) . body))
|
||||||
;; USER LETS
|
;; user final
|
||||||
((_ orig name l a v c r f ((cur-ul ...) . ul-rest) uw ub (:let (id id* ... expr) clauses ...) . body)
|
;; This pushes a #t to the user when expression, thus forcing a subloop if a for-clause is found afterwards.
|
||||||
(cl orig name l a v c r f ((cur-ul ... (:let id id* ... expr)) . ul-rest) uw ub (clauses ...) . body))
|
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub (cur-uf ...) (:final expr clauses ...) . body)
|
||||||
((_ orig name l a v c r f ((cur-ul ...) . ul-rest) uw ub (:let* (id id* ... expr) clauses ...) . body)
|
(cl orig name l a v c r f ul ((cur-uw ... #t) . uw-rest) ub (cur-uf ... expr) (clauses ...) . body))
|
||||||
(cl orig name l a v c r f ((cur-ul ... (:let* id id* ... expr)) . ul-rest) (clauses ...) . body))
|
|
||||||
;; Explicit subloop. Shorthand for (:when #t)
|
;; Explicit subloop. Shorthand for (:when #t)
|
||||||
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub (:subloop clauses ...) . body)
|
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub uf (:subloop clauses ...) . body)
|
||||||
(cl orig name l a v c r f ul ((cur-uw ... #t) . uw-rest) ub (clauses ...) . body))
|
(cl orig name l a v c r f ul ((cur-uw ... #t) . uw-rest) ub uf (clauses ...) . body))
|
||||||
;; :for-clauses
|
;; :for-clauses
|
||||||
;; found a for clause when we have a :when or :unless clause. Push new subloop
|
;; found a for clause when we have a :when or :unless clause. Push new subloop
|
||||||
((_ orig name l a v c r f ul ((uw uw* ...) . uw-rest) ub ((for-rest ...) clauses ...) . body)
|
((_ orig name l a v c r f ul ((uw uw* ...) . uw-rest) ub uf ((:for for-rest ...) clauses ...) . body)
|
||||||
(push-new-subloop orig name l a v c r f ul ((uw uw* ...) . uw-rest) ub ((for-rest ...) clauses ...) . body))
|
(push-new-subloop orig name l a v c r f ul ((uw uw* ...) . uw-rest) ub uf ((:for for-rest ...) clauses ...) . body))
|
||||||
|
|
||||||
;; For clause with a sequence creator.
|
;; For clause with a sequence creator.
|
||||||
((_ orig name l a v c r f ul uw ub ((id ids ... (iterator source ...)) clauses ...) . body)
|
((_ orig name l a v c r f ul uw ub uf ((:for id ids ... (iterator source ...)) clauses ...) . body)
|
||||||
(iterator ((id ids ...) (source ...)) cl-next orig name l a v c r f ul uw ub (clauses ...) . body))
|
(iterator ((id ids ...) (source ...)) cl-next orig name l a v c r f ul uw ub uf (clauses ...) . body))
|
||||||
|
|
||||||
|
((_ orig name l a v c r f ul uw ub uf ((:acc id ids ... (accumulator source ...)) clauses ...) . body)
|
||||||
|
(accumulator :acc ((id ids ...) (source ...)) cl-next orig name l a v c r f ul uw ub uf (clauses ...) . body))
|
||||||
|
|
||||||
|
;; no :acc or :for: imlplicit for!
|
||||||
|
((_ orig name l a v c r f ul uw ub uf ((id ids ... (iterator source ...)) clauses ...) . body)
|
||||||
|
(cl orig name l a v c r f ul uw ub uf ((:for id ids ... (iterator source ...)) clauses ...) . body))
|
||||||
|
|
||||||
;; ERROR HANDLING?
|
;; ERROR HANDLING?
|
||||||
((_ orig name l a v c r f ul uw ub (clause . rest) . body)
|
((_ orig name l a v c r f ul uw ub uf (clause . rest) . body)
|
||||||
(syntax-error "Invalid clause in loop" clause orig))
|
(syntax-error "Invalid clause in loop" clause orig))
|
||||||
|
|
||||||
))
|
))
|
||||||
|
|
@ -129,7 +148,7 @@
|
||||||
;; into the outer loops. Since accumulators need to be available in the (final-fun ...), they need to be visible also
|
;; into the outer loops. Since accumulators need to be available in the (final-fun ...), they need to be visible also
|
||||||
;; in the outer loops if the loop exits there.
|
;; in the outer loops if the loop exits there.
|
||||||
(define-syntax cl-next
|
(define-syntax cl-next
|
||||||
(syntax-rules ()
|
(syntax-rules (:for :acc)
|
||||||
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
|
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
|
||||||
orig name
|
orig name
|
||||||
((lets ...))
|
((lets ...))
|
||||||
|
|
@ -137,7 +156,7 @@
|
||||||
((vars ...))
|
((vars ...))
|
||||||
((checks ...))
|
((checks ...))
|
||||||
((refs ...))
|
((refs ...))
|
||||||
(finals ...) ul uw ub clauses . body)
|
(finals ...) ul uw ub uf clauses . body)
|
||||||
(cl orig name
|
(cl orig name
|
||||||
((lets ... new-lets ...))
|
((lets ... new-lets ...))
|
||||||
((accs ... (accvar accinit accupdate) ...))
|
((accs ... (accvar accinit accupdate) ...))
|
||||||
|
|
@ -145,7 +164,7 @@
|
||||||
((checks ... new-checks ...))
|
((checks ... new-checks ...))
|
||||||
((refs ... new-refs ...))
|
((refs ... new-refs ...))
|
||||||
(finals ... new-finals ...)
|
(finals ... new-finals ...)
|
||||||
ul uw ub clauses . body))
|
ul uw ub uf clauses . body))
|
||||||
;; We have ONE subloop!
|
;; We have ONE subloop!
|
||||||
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
|
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
|
||||||
orig name
|
orig name
|
||||||
|
|
@ -154,7 +173,7 @@
|
||||||
((vars ...) . vars-rest)
|
((vars ...) . vars-rest)
|
||||||
((checks ...) . checks-rest)
|
((checks ...) . checks-rest)
|
||||||
((refs ...) . refs-rest)
|
((refs ...) . refs-rest)
|
||||||
(finals ...) ul uw ub clauses . body)
|
(finals ...) ul uw ub uf clauses . body)
|
||||||
(cl orig name
|
(cl orig name
|
||||||
((lets ... new-lets ...) . lets-rest)
|
((lets ... new-lets ...) . lets-rest)
|
||||||
((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accinit accvar) ...))
|
((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accinit accvar) ...))
|
||||||
|
|
@ -162,7 +181,7 @@
|
||||||
((checks ... new-checks ...) . checks-rest)
|
((checks ... new-checks ...) . checks-rest)
|
||||||
((refs ... new-refs ...) . refs-rest)
|
((refs ... new-refs ...) . refs-rest)
|
||||||
(finals ... new-finals ...)
|
(finals ... new-finals ...)
|
||||||
ul uw ub clauses . body))
|
ul uw ub uf clauses . body))
|
||||||
;; We have several subloops!
|
;; We have several subloops!
|
||||||
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
|
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
|
||||||
orig name
|
orig name
|
||||||
|
|
@ -171,7 +190,7 @@
|
||||||
((vars ...) . vars-rest)
|
((vars ...) . vars-rest)
|
||||||
((checks ...) . checks-rest)
|
((checks ...) . checks-rest)
|
||||||
((refs ...) . refs-rest)
|
((refs ...) . refs-rest)
|
||||||
(finals ...) ul uw ub clauses . body)
|
(finals ...) ul uw ub uf clauses . body)
|
||||||
(cl orig name
|
(cl orig name
|
||||||
((lets ... new-lets ...) . lets-rest)
|
((lets ... new-lets ...) . lets-rest)
|
||||||
((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accvar accvar) ...) ...
|
((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accvar accvar) ...) ...
|
||||||
|
|
@ -180,7 +199,7 @@
|
||||||
((checks ... new-checks ...) . checks-rest)
|
((checks ... new-checks ...) . checks-rest)
|
||||||
((refs ... new-refs ...) . refs-rest)
|
((refs ... new-refs ...) . refs-rest)
|
||||||
(finals ... new-finals ...)
|
(finals ... new-finals ...)
|
||||||
ul uw ub clauses . body))
|
ul uw ub uf clauses . body))
|
||||||
))
|
))
|
||||||
|
|
||||||
(define-syntax user-let
|
(define-syntax user-let
|
||||||
|
|
@ -224,7 +243,8 @@
|
||||||
((checks ...))
|
((checks ...))
|
||||||
((refs ...))
|
((refs ...))
|
||||||
((final-binding final-value) ...)
|
((final-binding final-value) ...)
|
||||||
((user-lets ...)) ((user-whens ...)) ((user-breaks ...)) final-expr . body)
|
((user-lets ...)) ((user-whens ...)) ((user-breaks ...)) uf
|
||||||
|
final-expr . body)
|
||||||
(let* (lets ...)
|
(let* (lets ...)
|
||||||
(define (final-fun final-binding ...)
|
(define (final-fun final-binding ...)
|
||||||
final-expr)
|
final-expr)
|
||||||
|
|
@ -234,7 +254,10 @@
|
||||||
(let (refs ...)
|
(let (refs ...)
|
||||||
(user-let () () (user-lets ...)
|
(user-let () () (user-lets ...)
|
||||||
(if (and user-whens ...)
|
(if (and user-whens ...)
|
||||||
(let-kw-form name (loopy-loop (accvar accstep) ... (var step) ...)
|
(let-kw-form name
|
||||||
|
(final-fun final-value ...)
|
||||||
|
uf
|
||||||
|
(loopy-loop (accvar accstep) ... (var step) ...)
|
||||||
(if (or user-breaks ...)
|
(if (or user-breaks ...)
|
||||||
(final-fun final-value ...)
|
(final-fun final-value ...)
|
||||||
(let () (if #f #f) . body)))
|
(let () (if #f #f) . body)))
|
||||||
|
|
@ -254,6 +277,7 @@
|
||||||
(ul-next ... (user-lets ...))
|
(ul-next ... (user-lets ...))
|
||||||
(uw-next ... (user-whens ...))
|
(uw-next ... (user-whens ...))
|
||||||
(ub-next ... (user-breaks ...))
|
(ub-next ... (user-breaks ...))
|
||||||
|
uf
|
||||||
final-expr
|
final-expr
|
||||||
. body)
|
. body)
|
||||||
(let* ((final-fun (lambda (final-binding ...) final-expr))
|
(let* ((final-fun (lambda (final-binding ...) final-expr))
|
||||||
|
|
@ -280,6 +304,7 @@
|
||||||
(ul-next ...)
|
(ul-next ...)
|
||||||
(uw-next ...)
|
(uw-next ...)
|
||||||
(ub-next ...)
|
(ub-next ...)
|
||||||
|
uf
|
||||||
. body)))
|
. body)))
|
||||||
(outer-loop accvar ... step ...))))))))))
|
(outer-loop accvar ... step ...))))))))))
|
||||||
|
|
||||||
|
|
@ -298,6 +323,7 @@
|
||||||
((user-lets ...))
|
((user-lets ...))
|
||||||
((user-whens ...))
|
((user-whens ...))
|
||||||
((user-breaks ...))
|
((user-breaks ...))
|
||||||
|
uf
|
||||||
. body)
|
. body)
|
||||||
(let* (lets ...)
|
(let* (lets ...)
|
||||||
(let innermost-loop ((accvar accinit) ...
|
(let innermost-loop ((accvar accinit) ...
|
||||||
|
|
@ -310,7 +336,7 @@
|
||||||
(cond
|
(cond
|
||||||
((or user-breaks ...) final)
|
((or user-breaks ...) final)
|
||||||
(else
|
(else
|
||||||
(let-kw-form name (innermost-loop (accvar accstep) ... (var step) ...)
|
(let-kw-form name final uf (innermost-loop (accvar accstep) ... (var step) ...)
|
||||||
. body)))
|
. body)))
|
||||||
(innermost-loop accvar ... step ...))))))))
|
(innermost-loop accvar ... step ...))))))))
|
||||||
|
|
||||||
|
|
@ -327,6 +353,7 @@
|
||||||
(ul-next ... (user-lets ...))
|
(ul-next ... (user-lets ...))
|
||||||
(uw-next ... (user-whens ...))
|
(uw-next ... (user-whens ...))
|
||||||
(ub-next ... (user-breaks ...))
|
(ub-next ... (user-breaks ...))
|
||||||
|
uf
|
||||||
. body)
|
. body)
|
||||||
(let* (lets ...)
|
(let* (lets ...)
|
||||||
(let intermediate-loop ((accvar accinit) ...
|
(let intermediate-loop ((accvar accinit) ...
|
||||||
|
|
@ -351,6 +378,7 @@
|
||||||
(ul-next ...)
|
(ul-next ...)
|
||||||
(uw-next ...)
|
(uw-next ...)
|
||||||
(ub-next ...)
|
(ub-next ...)
|
||||||
|
uf
|
||||||
. body))
|
. body))
|
||||||
(intermediate-loop accvar ... step ...))))))))))
|
(intermediate-loop accvar ... step ...))))))))))
|
||||||
|
|
||||||
|
|
@ -362,7 +390,7 @@
|
||||||
|
|
||||||
(define (update-name params name val)
|
(define (update-name params name val)
|
||||||
(cond
|
(cond
|
||||||
((null? params) (error "unknown loop parameter name " name (list '=> name val)))
|
((null? params) (error "unknown loop variable name " name (list '=> name val)))
|
||||||
((syntax= name (caar params))
|
((syntax= name (caar params))
|
||||||
(cons (list (caar params) val) (cdr params)))
|
(cons (list (caar params) val) (cdr params)))
|
||||||
(else
|
(else
|
||||||
|
|
@ -374,7 +402,7 @@
|
||||||
|
|
||||||
(define-syntax let-kw-form
|
(define-syntax let-kw-form
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ macro-name (loop-name (var step) ...) . body)
|
((_ macro-name final-fun (user-finals ...) (loop-name (var step) ...) . body)
|
||||||
(let-syntax ((macro-name
|
(let-syntax ((macro-name
|
||||||
(lambda (stx)
|
(lambda (stx)
|
||||||
(with-ellipsis :::
|
(with-ellipsis :::
|
||||||
|
|
@ -382,7 +410,10 @@
|
||||||
(params (list #'(var step) ...)))
|
(params (list #'(var step) ...)))
|
||||||
(if (null? lst)
|
(if (null? lst)
|
||||||
(with-syntax ((((v s) :::) params))
|
(with-syntax ((((v s) :::) params))
|
||||||
#'(loop-name s :::))
|
#'(let ((v s) :::)
|
||||||
|
(if (or user-finals ...)
|
||||||
|
final-fun
|
||||||
|
(loop-name v :::))))
|
||||||
(syntax-case (car lst) (=>)
|
(syntax-case (car lst) (=>)
|
||||||
((=> name val)
|
((=> name val)
|
||||||
(loop (cdr lst) (update-name params #'name #'val)))
|
(loop (cdr lst) (update-name params #'name #'val)))
|
||||||
|
|
@ -401,19 +432,19 @@
|
||||||
(define-syntax loop/sum
|
(define-syntax loop/sum
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ (clauses ...) body ...)
|
((_ (clauses ...) body ...)
|
||||||
(loop (clauses ... (acc (summing (let () body ...)))) => acc))))
|
(loop (clauses ... (:acc acc (summing (let () body ...)))) => acc))))
|
||||||
|
|
||||||
(define-syntax loop/product
|
(define-syntax loop/product
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ (clauses ...) body ...)
|
((_ (clauses ...) body ...)
|
||||||
(loop (clauses ... (acc (multiplying (let () body ...)))) => acc))))
|
(loop (clauses ... (:acc acc (multiplying (let () body ...)))) => acc))))
|
||||||
|
|
||||||
(define sentinel (list 'unique))
|
(define sentinel (list 'unique))
|
||||||
|
|
||||||
(define-syntax loop/first
|
(define-syntax loop/first
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ (clauses ...) body ...)
|
((_ (clauses ...) body ...)
|
||||||
(loop loop-name ((acc (folding sentinel)) clauses ... :break (not (eq? sentinel acc)))
|
(loop loop-name (clauses ... (:acc acc (folding sentinel)) :break (not (eq? sentinel acc)))
|
||||||
=> (if (eq? sentinel acc) #f acc)
|
=> (if (eq? sentinel acc) #f acc)
|
||||||
(let ((result (let () body ...)))
|
(let ((result (let () body ...)))
|
||||||
(loop-name (=> acc result)))))))
|
(loop-name (=> acc result)))))))
|
||||||
|
|
@ -421,9 +452,34 @@
|
||||||
(define-syntax loop/last
|
(define-syntax loop/last
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((_ (clauses ...) body ...)
|
((_ (clauses ...) body ...)
|
||||||
(loop loop-name ((acc (folding sentinel)) clauses ...) => (if (eq? sentinel acc) #f acc)
|
(loop loop-name (clauses ... (:acc acc (folding sentinel))) => (if (eq? sentinel acc) #f acc)
|
||||||
(let ((result (let () body ...)))
|
(let ((result (let () body ...)))
|
||||||
(loop-name (=> acc result)))))))
|
(loop-name (=> acc result)))))))
|
||||||
|
|
||||||
|
(define-syntax loop/and
|
||||||
|
(syntax-rules ()
|
||||||
|
((_ (clauses ...) body ...)
|
||||||
|
(loop loop-name (clauses ... (:acc acc (folding #t)))
|
||||||
|
=> acc
|
||||||
|
(let ((res (let () body ...)))
|
||||||
|
(if res
|
||||||
|
(loop-name (=> acc res))
|
||||||
|
#f))))))
|
||||||
|
|
||||||
|
(define-syntax loop/or
|
||||||
|
(syntax-rules ()
|
||||||
|
((_ (clauses ...) body ...)
|
||||||
|
(loop loop-name (clauses ...)
|
||||||
|
=> #f
|
||||||
|
(or (let () body ...) (loop-name))))))
|
||||||
|
|
||||||
|
(define-syntax loop/list/parallel
|
||||||
|
(syntax-rules ()
|
||||||
|
((_ (clauses ...) body ...)
|
||||||
|
(loop (clauses ... (:acc futures (listing-reverse (future (let () body ...)))))
|
||||||
|
=> (loop ((:for future (in-list futures))
|
||||||
|
(:acc futures2 (listing-reverse (touch future))))
|
||||||
|
=> futures2)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
115
iterators.scm
115
iterators.scm
|
|
@ -214,23 +214,20 @@
|
||||||
((up-from (() . args) next . rest)
|
((up-from (() . args) next . rest)
|
||||||
(up-from ((var) . args) next . rest))
|
(up-from ((var) . args) next . rest))
|
||||||
((up-from ((var) (start (to limit) (by step))) next . rest)
|
((up-from ((var) (start (to limit) (by step))) next . rest)
|
||||||
(next ((s start) (l limit) (e step)) ()
|
(next ((s start) (l limit) (e step))
|
||||||
((var s (+ var e))) ((>= var l)) () () . rest))
|
()
|
||||||
|
((var s (+ var e)))
|
||||||
|
((>= var l))
|
||||||
|
() () . rest))
|
||||||
((up-from ((var) (start (to limit))) next . rest)
|
((up-from ((var) (start (to limit))) next . rest)
|
||||||
(next ((s start) (l limit))()
|
(next ((s start) (l limit)) () ((var s (+ var 1)))
|
||||||
((var s (+ var 1)))
|
|
||||||
((>= var l)) () () . rest))
|
((>= var l)) () () . rest))
|
||||||
((up-from ((var) (start (by step))) next . rest)
|
((up-from ((var) (start (by step))) next . rest)
|
||||||
(next ((s start) (e step))()
|
(next ((s start) (e step))()
|
||||||
((var s (+ var e))) () () () . rest))
|
((var s (+ var e))) () () () . rest))
|
||||||
((up-from ((var) (start)) next . rest)
|
((up-from ((var) (start)) next . rest)
|
||||||
(next ((s start))
|
(next ((s start)) () ((var s (+ var 1)))
|
||||||
()
|
() () () . rest))
|
||||||
((var s (+ var 1)))
|
|
||||||
()
|
|
||||||
()
|
|
||||||
()
|
|
||||||
. rest))
|
|
||||||
;; Extra convenience, make it act like (in-range ...) from racket, but only for positive numbers.
|
;; Extra convenience, make it act like (in-range ...) from racket, but only for positive numbers.
|
||||||
((up-from ((var) (start limit step)) next . rest)
|
((up-from ((var) (start limit step)) next . rest)
|
||||||
(next ((s start) (l limit) (e step)) () ((var s (+ var e))) ((>= var l)) () () . rest))
|
(next ((s start) (l limit) (e step)) () ((var s (+ var e))) ((>= var l)) () () . rest))
|
||||||
|
|
@ -248,42 +245,28 @@
|
||||||
()
|
()
|
||||||
((var (- s e) (- var e)))
|
((var (- s e) (- var e)))
|
||||||
((< var l))
|
((< var l))
|
||||||
()
|
() () . rest))
|
||||||
()
|
|
||||||
. rest))
|
|
||||||
((down-from ((var) (start (to limit))) next . rest)
|
((down-from ((var) (start (to limit))) next . rest)
|
||||||
(next ((s start) (l limit))
|
(next ((s start) (l limit)) () ((var (- s 1) (- var 1)))
|
||||||
()
|
((< var l)) () () . rest))
|
||||||
((var (- s 1) (- var 1)))
|
|
||||||
((< var l))
|
|
||||||
()
|
|
||||||
()
|
|
||||||
. rest))
|
|
||||||
((down-from ((var) (start (by step))) next . rest)
|
((down-from ((var) (start (by step))) next . rest)
|
||||||
(next ((s start) (e step))
|
(next ((s start) (e step)) () ((var (- s e) (- var e)))
|
||||||
()
|
() () () . rest))
|
||||||
((var (- s e) (- var e)))
|
|
||||||
()
|
|
||||||
()
|
|
||||||
()
|
|
||||||
. rest))
|
|
||||||
((down-from ((var) (start)) next . rest)
|
((down-from ((var) (start)) next . rest)
|
||||||
(next ((s start))
|
(next ((s start)) () ((var (- s 1) (- var 1)))
|
||||||
()
|
() () () . rest))
|
||||||
((var (- s 1) (- var 1)))
|
((down-from ((var) (start limit step)) next . rest)
|
||||||
()
|
(next ((s start) (l limit) (e step)) () ((var (- s e) (- var e))) ((< var l)) () () . rest))
|
||||||
()
|
((down-from ((var) (start limit)) next . rest)
|
||||||
()
|
(down-from ((var) (start limit 1)) next . rest))))
|
||||||
. rest))
|
|
||||||
))
|
|
||||||
|
|
||||||
(define-syntax accumulating
|
(define-syntax accumulating
|
||||||
(syntax-rules (initial if)
|
(syntax-rules (initial if :acc)
|
||||||
((accumulating (kons final init) ((var) . x) next . rest)
|
((accumulating :acc (kons final init) ((var) . x) next . rest)
|
||||||
(accumulating (kons final init) ((var cursor) . x) next . rest))
|
(accumulating :acc (kons final init) ((var cursor) . x) next . rest))
|
||||||
((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest)
|
((accumulating :acc (kons final init) ((var cursor) ((initial i) . x)) n . rest)
|
||||||
(accumulating (kons final i) ((var cursor) x) n . rest))
|
(accumulating :acc (kons final i) ((var cursor) x) n . rest))
|
||||||
((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest)
|
((accumulating :acc (kons final init) ((var cursor) (expr (if check))) n . rest)
|
||||||
(n ((tmp-kons kons))
|
(n ((tmp-kons kons))
|
||||||
((cursor init (if check (tmp-kons expr cursor) cursor)))
|
((cursor init (if check (tmp-kons expr cursor) cursor)))
|
||||||
()
|
()
|
||||||
|
|
@ -291,7 +274,7 @@
|
||||||
()
|
()
|
||||||
((var (final cursor)))
|
((var (final cursor)))
|
||||||
. rest))
|
. rest))
|
||||||
((accumulating (kons final init) ((var cursor) (expr)) n . rest)
|
((accumulating :acc (kons final init) ((var cursor) (expr)) n . rest)
|
||||||
(n ((tmp-kons kons))
|
(n ((tmp-kons kons))
|
||||||
((cursor init (tmp-kons expr cursor)))
|
((cursor init (tmp-kons expr cursor)))
|
||||||
()
|
()
|
||||||
|
|
@ -301,32 +284,32 @@
|
||||||
. rest))))
|
. rest))))
|
||||||
|
|
||||||
(define-syntax folding
|
(define-syntax folding
|
||||||
(syntax-rules (if)
|
(syntax-rules (if :acc)
|
||||||
((_ ((var) (init update (if guard))) n . rest)
|
((_ :acc ((var) (init update (if guard))) n . rest)
|
||||||
(n ()
|
(n ()
|
||||||
((var init (if guard update var)))
|
((var init (if guard update var)))
|
||||||
() () ()
|
() () ()
|
||||||
((var var))
|
((var var))
|
||||||
. rest))
|
. rest))
|
||||||
((_ ((var) (init update)) n . rest)
|
((_ :acc ((var) (init update)) n . rest)
|
||||||
(folding ((var) (init update (if #t))) n . rest))
|
(folding ((var) (init update (if #t))) n . rest))
|
||||||
((_ ((var) (init)) n . rest)
|
((_ :acc ((var) (init)) n . rest)
|
||||||
(folding ((var) (init var (if #t))) n . rest))))
|
(folding ((var) (init var (if #t))) n . rest))))
|
||||||
|
|
||||||
|
|
||||||
;;> \macro{(for x [pair] (listing expr))}
|
;;> \macro{(for x [pair] (listing expr))}
|
||||||
|
|
||||||
(define-syntax listing
|
(define-syntax listing
|
||||||
(syntax-rules ()
|
(syntax-rules (:acc)
|
||||||
((listing args next . rest)
|
((listing :acc args next . rest)
|
||||||
(accumulating (cons reverse '()) args next . rest))))
|
(accumulating :acc (cons reverse '()) args next . rest))))
|
||||||
|
|
||||||
;;> \macro{(for x [pair] (listing-reverse expr))}
|
;;> \macro{(for x [pair] (listing-reverse expr))}
|
||||||
|
|
||||||
(define-syntax listing-reverse
|
(define-syntax listing-reverse
|
||||||
(syntax-rules ()
|
(syntax-rules (:acc)
|
||||||
((listing-reverse args next . rest)
|
((listing-reverse :acc args next . rest)
|
||||||
(accumulating (cons (lambda (x) x) '()) args next . rest))))
|
(accumulating :acc (cons (lambda (x) x) '()) args next . rest))))
|
||||||
|
|
||||||
(define (append-reverse rev tail)
|
(define (append-reverse rev tail)
|
||||||
(if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
|
(if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
|
||||||
|
|
@ -334,29 +317,29 @@
|
||||||
;;> \macro{(for x [pair] (appending expr))}
|
;;> \macro{(for x [pair] (appending expr))}
|
||||||
|
|
||||||
(define-syntax appending
|
(define-syntax appending
|
||||||
(syntax-rules ()
|
(syntax-rules (:acc)
|
||||||
((appending args next . rest)
|
((appending :acc args next . rest)
|
||||||
(accumulating (append-reverse reverse '()) args next . rest))))
|
(accumulating :acc (append-reverse reverse '()) args next . rest))))
|
||||||
|
|
||||||
;;> \macro{(for x [pair] (appending-reverse expr))}
|
;;> \macro{(for x [pair] (appending-reverse expr))}
|
||||||
|
|
||||||
(define-syntax appending-reverse
|
(define-syntax appending-reverse
|
||||||
(syntax-rules ()
|
(syntax-rules (:acc)
|
||||||
((appending-reverse args next . rest)
|
((appending-reverse :acc args next . rest)
|
||||||
(accumulating (append-reverse (lambda (x) x) '()) args next . rest))))
|
(accumulating :acc (append-reverse (lambda (x) x) '()) args next . rest))))
|
||||||
|
|
||||||
;;> \macro{(for x (summing expr))}
|
;;> \macro{(for x (summing expr))}
|
||||||
|
|
||||||
(define-syntax summing
|
(define-syntax summing
|
||||||
(syntax-rules ()
|
(syntax-rules (:acc)
|
||||||
((summing args next . rest)
|
((summing :acc args next . rest)
|
||||||
(accumulating (+ (lambda (x) x) 0) args next . rest))))
|
(accumulating :acc (+ (lambda (x) x) 0) args next . rest))))
|
||||||
|
|
||||||
;;> \macro{(for x (multiplying expr))}
|
;;> \macro{(for x (multiplying expr))}
|
||||||
|
|
||||||
(define-syntax multiplying
|
(define-syntax multiplying
|
||||||
(syntax-rules ()
|
(syntax-rules (:acc)
|
||||||
((multiplying args next . rest)
|
((multiplying :acc args next . rest)
|
||||||
(accumulating (* (lambda (x) x) 1) args next . rest))))
|
(accumulating (* (lambda (x) x) 1) args next . rest))))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -380,10 +363,10 @@
|
||||||
((_ ((id) (source)) n . rest)
|
((_ ((id) (source)) n . rest)
|
||||||
(n ((gen (generator-cycle source)))
|
(n ((gen (generator-cycle source)))
|
||||||
()
|
()
|
||||||
((id (gen) (gen)))
|
|
||||||
((eof-object? id))
|
|
||||||
()
|
()
|
||||||
()
|
()
|
||||||
|
((id (gen)))
|
||||||
|
()
|
||||||
. rest))))
|
. rest))))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue