2c182da570
I have racketified goof loops. No :for or :acc needed, and :when, :unless, and :break are no longer parethesised. :acc blah (in ...) and :for blah (in ...) has been changed to (blah (folding ...)) and (blah (in ...))
401 lines
16 KiB
Scheme
401 lines
16 KiB
Scheme
;; goof loop - a bastardisation of chibi loop.
|
|
;;
|
|
;; Copyright 2020 Linus Björnstam
|
|
;; Copyright 2000-2015 Alex Shinn (original author of chibi-loop)
|
|
;; All rights reserved.
|
|
;;
|
|
;; Redistribution and use in source and binary forms, with or without
|
|
;; modification, are permitted provided that the following conditions
|
|
;; are met:
|
|
;; 1. Redistributions of source code must retain the above copyright
|
|
;; notice, this list of conditions and the following disclaimer.
|
|
;; 2. Redistributions in binary form must reproduce the above copyright
|
|
;; notice, this list of conditions and the following disclaimer in the
|
|
;; documentation and/or other materials provided with the distribution.
|
|
;; 3. The name of the author(s) may not be used to endorse or promote products
|
|
;; derived from this software without specific prior written permission.
|
|
;;
|
|
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
|
|
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
|
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
|
;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
|
|
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
|
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
|
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
|
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
|
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
|
|
|
|
;; This is a looping construct obviously based on (chibi loop) (aka:
|
|
;; foof-loop) by Alex Shinn. The name goof-loop is a play on that
|
|
;; name, and the fact that I goofed in the chibi issue tracker when
|
|
;; trying to understand the iterator protocol.
|
|
|
|
|
|
|
|
(use-modules (helpers)
|
|
(srfi srfi-71))
|
|
|
|
(define-aux-syntaxes
|
|
;; Auxiliary syntax for the loop clauses
|
|
:when :unless :break :final :let :let* :subloop
|
|
;; Auxiliary syntax for the iterators.
|
|
:gen)
|
|
|
|
|
|
(include "iterators.scm")
|
|
|
|
|
|
|
|
(define-syntax loop
|
|
(syntax-rules ()
|
|
((loop (clauses ...) body ...)
|
|
(cl (loop (clauses ...) body ...)
|
|
loop-name
|
|
(()) (()) (()) (()) (()) () (()) (()) (())
|
|
(clauses ...)
|
|
body ... (loop-name)))
|
|
((loop name (clauses ...) . body)
|
|
(cl (loop name (clauses ...) . body)
|
|
name
|
|
(()) (()) (()) (()) (()) () (()) (()) (())
|
|
(clauses ...)
|
|
. body))))
|
|
|
|
(define-syntax push-new-subloop
|
|
(syntax-rules ()
|
|
((_ orig name (lets ...) (accs ...) (vars ...) (checks ...) (refs ...) f (ul ...) (uw ...) (ub ...) clauses . body)
|
|
(cl orig name
|
|
(() lets ...)
|
|
(() accs ...)
|
|
(() vars ...)
|
|
(() checks ...)
|
|
(() refs ...)
|
|
f
|
|
(() ul ...)
|
|
(() uw ...)
|
|
(() ub ...)
|
|
clauses . body))))
|
|
|
|
|
|
;; Clauses sorts all the clauses into subloops and positions everything where it should be.
|
|
(define-syntax cl
|
|
(syntax-rules (=> in :when :unless :break :final :let :let* :subloop)
|
|
((_ 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 expr . body))
|
|
((_ orig name l a v c r f ul uw ub () . body)
|
|
(emit orig name l a v c r f ul uw ub (if #f #f) . body))
|
|
|
|
;; user-whens
|
|
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub (:when test clauses ...) . body)
|
|
(cl orig name l a v c r f ul ((cur-uw ... test) . uw-rest) ub (clauses ...) . body))
|
|
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub (:unless test clauses ...) . body)
|
|
(cl orig name l a v c r f ul ((cur-uw ... (not test)) . uw-rest) ub (clauses ...) . body))
|
|
;; USER BREAKS
|
|
;; 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)
|
|
(cl orig name l a v c r f ul ((cur-uw ... #t) . uw-rest) ((cur-ub ... expr) . ub-rest) (clauses ...) . body))
|
|
;; USER LETS
|
|
((_ 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 ((cur-ul ... (:let id id* ... expr)) . ul-rest) uw ub (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 ((cur-ul ... (:let* id id* ... expr)) . ul-rest) (clauses ...) . body))
|
|
|
|
;; Explicit subloop. Shorthand for (:when #t)
|
|
((_ orig name l a v c r f ul ((cur-uw ...) . uw-rest) ub (:subloop clauses ...) . body)
|
|
(cl orig name l a v c r f ul ((cur-uw ... #t) . uw-rest) ub (clauses ...) . body))
|
|
|
|
|
|
|
|
;; :for-clauses
|
|
;; 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)
|
|
(push-new-subloop orig name l a v c r f ul ((uw uw* ...) . uw-rest) ub ((for-rest ...) clauses ...) . body))
|
|
|
|
;; For clause with a sequence creator.
|
|
((_ orig name l a v c r f ul uw ub ((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))
|
|
|
|
|
|
|
|
;; ERROR HANDLING?
|
|
((_ orig name l a v c r f ul uw ub (clause . rest) . body)
|
|
(syntax-error "Invalid clause in loop" clause orig))
|
|
|
|
))
|
|
|
|
|
|
;; HOLY CODE-DUPLICATION-BATMAN!
|
|
;; cl-next integrates any bindings introduced by a :for or :acc clause. The complexity comes from pushing :acc-clauses
|
|
;; 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.
|
|
(define-syntax cl-next
|
|
(syntax-rules ()
|
|
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
|
|
orig name
|
|
((lets ...))
|
|
((accs ...))
|
|
((vars ...))
|
|
((checks ...))
|
|
((refs ...))
|
|
(finals ...) ul uw ub clauses . body)
|
|
(cl orig name
|
|
((lets ... new-lets ...))
|
|
((accs ... (accvar accinit accupdate) ...))
|
|
((vars ... new-vars ...))
|
|
((checks ... new-checks ...))
|
|
((refs ... new-refs ...))
|
|
(finals ... new-finals ...)
|
|
ul uw ub clauses . body))
|
|
;; We have ONE subloop!
|
|
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
|
|
orig name
|
|
((lets ...) . lets-rest)
|
|
((accs ...) ((oldacc oldinit oldupdate) ...))
|
|
((vars ...) . vars-rest)
|
|
((checks ...) . checks-rest)
|
|
((refs ...) . refs-rest)
|
|
(finals ...) ul uw ub clauses . body)
|
|
(cl orig name
|
|
((lets ... new-lets ...) . lets-rest)
|
|
((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accinit accvar) ...))
|
|
((vars ... new-vars ...) . vars-rest)
|
|
((checks ... new-checks ...) . checks-rest)
|
|
((refs ... new-refs ...) . refs-rest)
|
|
(finals ... new-finals ...)
|
|
ul uw ub clauses . body))
|
|
;; We have several subloops!
|
|
((_ (new-lets ...) ((accvar accinit accupdate) ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
|
|
orig name
|
|
((lets ...) . lets-rest)
|
|
((accs ...) ((oldacc oldinit oldupdate) ...) ... ((oldestacc oldestinit oldestupdate) ...))
|
|
((vars ...) . vars-rest)
|
|
((checks ...) . checks-rest)
|
|
((refs ...) . refs-rest)
|
|
(finals ...) ul uw ub clauses . body)
|
|
(cl orig name
|
|
((lets ... new-lets ...) . lets-rest)
|
|
((accs ... (accvar accvar accupdate) ...) ((oldacc oldinit oldupdate) ... (accvar accvar accvar) ...) ...
|
|
((oldestacc oldestinit oldestupdate) ... (accvar accinit accvar) ...))
|
|
((vars ... new-vars ...) . vars-rest)
|
|
((checks ... new-checks ...) . checks-rest)
|
|
((refs ... new-refs ...) . refs-rest)
|
|
(finals ... new-finals ...)
|
|
ul uw ub clauses . body))
|
|
))
|
|
|
|
(define-syntax user-let
|
|
(syntax-rules (:let :let*)
|
|
((_ () () () body ...)
|
|
(begin body ...))
|
|
((_ (lets ...) () () . body)
|
|
(let (lets ...)
|
|
. body))
|
|
((_ () (stars ...) () . body)
|
|
(let* (stars ...) . body))
|
|
|
|
;; These twe clauses handle let type changes.
|
|
((_ () (stars ... last) ((:let id id* ... expr) clauses ...) . body)
|
|
(let* (stars ...)
|
|
(user-let (last (id id* ... expr)) () (clauses ...) . body)))
|
|
((_ (lets ...) () ((:let* id id* ... expr) clauses ...) . body)
|
|
(let (lets ...)
|
|
(user-let () ((id id* ... expr)) (clauses ...) . body)))
|
|
|
|
;; 2 clauses new of the same that already existed
|
|
((_ (lets ...) () ((:let id id* ... expr) clauses ...) . body)
|
|
(user-let (lets ... (id id* ... expr)) () (clauses ...) . body))
|
|
((_ () (stars ...) ((:let* id id* ... expr) clauses ...) . body)
|
|
(user-let () (stars ... (id id* ... expr)) (clauses ...) . body))))
|
|
|
|
;; If there is no subloops, we emit to the simple case
|
|
(define-syntax emit
|
|
(syntax-rules ()
|
|
((_ orig name (one) . rest)
|
|
(emit-one orig name (one) . rest))
|
|
((_ orig name . rest)
|
|
(emit-many/first #f name . rest))))
|
|
|
|
(define-syntax emit-one
|
|
(syntax-rules ()
|
|
((_ orig name
|
|
((lets ...))
|
|
(((accvar accinit accstep) ...))
|
|
(((var init step) ...))
|
|
((checks ...))
|
|
((refs ...))
|
|
((final-binding final-value) ...)
|
|
((user-lets ...)) ((user-whens ...)) ((user-breaks ...)) final-expr . body)
|
|
(let* (lets ...)
|
|
(define (final-fun final-binding ...)
|
|
final-expr)
|
|
(define (loopy-loop accvar ... var ...)
|
|
(if (or checks ...)
|
|
(final-fun final-value ...)
|
|
(let (refs ...)
|
|
(user-let () () (user-lets ...)
|
|
(if (and user-whens ...)
|
|
(let-kw-form name (loopy-loop (accvar accstep) ... (var step) ...)
|
|
(if (or user-breaks ...)
|
|
(final-fun final-value ...)
|
|
(let () (if #f #f) . body)))
|
|
(loopy-loop accvar ... step ...))))))
|
|
(loopy-loop accinit ... init ...)))))
|
|
|
|
;; Emit-many/first emits the outermost let loop and binds the final lambda.
|
|
(define-syntax emit-many/first
|
|
(syntax-rules ()
|
|
((_ orig name
|
|
(lets-next ... (lets ...))
|
|
(accs-next ... ((accvar accinit accstep) ...))
|
|
(vars-next ... ((var init step) ...))
|
|
(checks-next ... (checks ...))
|
|
(refs-next ... (refs ...))
|
|
((final-binding final-value) ...)
|
|
(ul-next ... (user-lets ...))
|
|
(uw-next ... (user-whens ...))
|
|
(ub-next ... (user-breaks ...))
|
|
final-expr
|
|
. body)
|
|
(let* ((final-fun (lambda (final-binding ...) final-expr))
|
|
lets ...)
|
|
(let outer-loop ((accvar accinit) ...
|
|
(var init) ...)
|
|
(if (or checks ...)
|
|
(final-fun final-value ...)
|
|
(let (refs ...)
|
|
(user-let () () (user-lets ...)
|
|
(if (and user-whens ...)
|
|
(cond
|
|
((or user-breaks ...) (final-fun final-value ...))
|
|
(else (emit-many/rest orig
|
|
name
|
|
(outer-loop accstep ... step ...)
|
|
(lets-next ...)
|
|
(accs-next ...)
|
|
(vars-next ...)
|
|
(checks-next ...)
|
|
(refs-next ...)
|
|
;; THIS IS NOW A COMPLETE call to final
|
|
(final-fun final-value ...)
|
|
(ul-next ...)
|
|
(uw-next ...)
|
|
(ub-next ...)
|
|
. body)))
|
|
(outer-loop accvar ... step ...))))))))))
|
|
|
|
(define-syntax emit-many/rest
|
|
(syntax-rules ()
|
|
;; match innermost loop
|
|
((_ orig
|
|
name
|
|
outer
|
|
((lets ...))
|
|
(((accvar accinit accstep) ...))
|
|
(((var init step) ...))
|
|
((checks ...))
|
|
((refs ...))
|
|
final
|
|
((user-lets ...))
|
|
((user-whens ...))
|
|
((user-breaks ...))
|
|
. body)
|
|
(let* (lets ...)
|
|
(let innermost-loop ((accvar accinit) ...
|
|
(var init) ...)
|
|
(if (or checks ...)
|
|
outer
|
|
(let (refs ...)
|
|
(user-let () () (user-lets ...)
|
|
(if (and user-whens ...)
|
|
(cond
|
|
((or user-breaks ...) final)
|
|
(else
|
|
(let-kw-form name (innermost-loop (accvar accstep) ... (var step) ...)
|
|
. body)))
|
|
(innermost-loop accvar ... step ...))))))))
|
|
|
|
;; Any intermediate loops
|
|
((_ orig
|
|
name
|
|
outer
|
|
(next-lets ... (lets ...))
|
|
(next-accs ... ((accvar accinit accstep) ...))
|
|
(next-vars ... ((var init step) ...))
|
|
(next-checks ... (checks ...))
|
|
(next-refs ... (refs ...))
|
|
final
|
|
(ul-next ... (user-lets ...))
|
|
(uw-next ... (user-whens ...))
|
|
(ub-next ... (user-breaks ...))
|
|
. body)
|
|
(let* (lets ...)
|
|
(let intermediate-loop ((accvar accinit) ...
|
|
(var init) ...)
|
|
(if (or checks ...)
|
|
outer
|
|
(let (refs ...)
|
|
(user-let () () (user-lets ...)
|
|
(if (and user-whens ...)
|
|
(if (or user-breaks ...)
|
|
final
|
|
(emit-many/rest
|
|
orig
|
|
name
|
|
(intermediate-loop accstep ... step ...)
|
|
(next-lets ...)
|
|
(next-accs ...)
|
|
(next-vars ...)
|
|
(next-checks ...)
|
|
(next-refs ...)
|
|
final
|
|
(ul-next ...)
|
|
(uw-next ...)
|
|
(ub-next ...)
|
|
. body))
|
|
(intermediate-loop accvar ... step ...))))))))))
|
|
|
|
|
|
|
|
;; Helper procedures for let-kw-form
|
|
(define (syntax= s1 s2)
|
|
(equal? (syntax->datum s1) (syntax->datum s2)))
|
|
|
|
(define (update-name params name val)
|
|
(cond
|
|
((null? params) (error "unknown loop parameter name " name (list '=> name val)))
|
|
((syntax= name (caar params))
|
|
(cons (list (caar params) val) (cdr params)))
|
|
(else
|
|
(cons (car params) (update-name (cdr params) name val)))))
|
|
|
|
(define (syntax->list stx)
|
|
(syntax-case stx ()
|
|
((a ...) #'(a ...))))
|
|
|
|
(define-syntax let-kw-form
|
|
(syntax-rules ()
|
|
((_ macro-name (loop-name (var step) ...) . body)
|
|
(let-syntax ((macro-name
|
|
(lambda (stx)
|
|
(with-ellipsis :::
|
|
(let loop ((lst (cdr (syntax->list stx)))
|
|
(params (list #'(var step) ...)))
|
|
(if (null? lst)
|
|
(with-syntax ((((v s) :::) params))
|
|
#'(loop-name s :::))
|
|
(syntax-case (car lst) (=>)
|
|
((=> name val)
|
|
(loop (cdr lst) (update-name params #'name #'val)))
|
|
(_ (error "Malformed looping clause in macro")))))))))
|
|
. body))))
|
|
|
|
|
|
|
|
(define-syntax loop/list
|
|
(syntax-rules ()
|
|
((_ (clauses ...) body ...)
|
|
(loop loop-name (clauses ...)
|
|
=> '()
|
|
(cons (let () body ...) (loop-name))))))
|