418 lines
17 KiB
Scheme
418 lines
17 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.
|
|
;;
|
|
;; It extends chibi loop in the following way:
|
|
;; * adds support for binding variables in the loop clauses.
|
|
;; * Adds :when, :unless, and :break clauses that controls when the loop
|
|
;; body executes and when values are collected by accumulating for clauses.
|
|
;; similar to how #:when, #:unless and #:break works in racket.
|
|
;; * Planned: add support for subloops, akin to what the starified loops of
|
|
;; racket do.
|
|
;;
|
|
;; It restricts chibi loops in the following ways:
|
|
;; * with- and for-clauses are no longer visible in the final expression, for that you
|
|
;; must use a clause for which I don't have a name yet.
|
|
|
|
|
|
(use-modules (helpers)
|
|
(srfi srfi-71))
|
|
|
|
(include "iterators.scm")
|
|
|
|
;; TODO: Add intermediate subloops. Make sure that accumulators are properly propagated.
|
|
;; TODO. fix let-kw-form. Don't use mutation. This should work:(define (partition predicate list)
|
|
;; (loop continue ((:for element (in-list list))
|
|
;; (:acc satisfied (in '()))
|
|
;; (:acc unsatisfied (in '())))
|
|
;; => (values (reverse satisfied)
|
|
;; (reverse unsatisfied))
|
|
;; (if (predicate element)
|
|
;; (continue (=> satisfied (cons element satisfied)))
|
|
;; (continue (=> unsatisfied (cons element unsatisfied))))))
|
|
|
|
|
|
|
|
(define-aux-syntaxes :for :when :unless :break :final :let :let* :acc :subloop)
|
|
|
|
(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 :for :with :when :unless :break :final :let :acc)
|
|
((_ 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))
|
|
;; :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 for-rest ...) clauses ...) . body)
|
|
(push-new-subloop orig name l a v c r f ul ((uw uw* ...) . uw-rest) ub ((:for for-rest ...) clauses ...) . body))
|
|
|
|
;; The four special :for var (in ...)-clauses where user specifies their own iteration
|
|
((_ orig name l a v c r f ul ((uw uw* ...) uw-rest ...) ub ((:with args ...) clauses ...) . body)
|
|
(push-new-subloop name l a v c r f ul ((uw uw* ...) uw-rest ...) ub ((:with args ...) clauses ...) . body))
|
|
|
|
((_ orig name l a ((v-cur ...) . v-rest) ((c-cur ...) . c-rest)
|
|
r f ul uw ub ((:for var (in init step guard-expr)) clauses ...) . body)
|
|
(cl orig name l a ((v-cur ... (var init step)) . v-rest) ((c-cur ... guard-expr) . c-rest)
|
|
r f ul uw ub (clauses ...) . body))
|
|
((_ orig name l a ((v-cur ...) . v-rest) c r f ul uw ub ((:for var (in init step)) clauses ...) . body)
|
|
(cl orig name l a ((v-cur ... (var init step)) . v-rest) c r f ul uw ub (clauses ...) . body))
|
|
((_ orig name l a ((v-cur ...) . v-rest) c r f ul uw ub ((:for var (in init)) clauses ...) . body)
|
|
(cl orig name l a ((v-cur ... (var init var)) . v-rest) c r f ul uw ub (clauses ...) . body))
|
|
;; For clause with a sequence creator.
|
|
((_ orig name l a v c r f ul uw ub ((: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))
|
|
|
|
;; Accumulating clauses
|
|
;; should I push a subloop on a when clause?
|
|
;; Currently these have no stop or if-clauses. Maybe add?
|
|
((_ orig name l a v c r f ul uw ub ((:acc var (in init update)) clauses ...) . body)
|
|
(cl-next () ((var init update)) () () () ((var var)) orig name l a v c r f ul uw ub (clauses ...) . body))
|
|
((_ orig name l a v c r f ul uw ub ((:acc var (in init)) clauses ...) . body)
|
|
(cl-next () ((var init var)) () () () ((var var)) orig name l a v c r f ul uw ub (clauses ...) . 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))
|
|
|
|
;; ERROR HANDLING?
|
|
((_ orig name l a v c r f ul uw ub (clause . rest) . body)
|
|
(syntax-error "Invalid clause in loop" clause orig))
|
|
|
|
))
|
|
|
|
|
|
;; cl-next integrates the results
|
|
;; THIS WILL NEED TO BE UPDATED TO PROPERLY PUSH (accvar accinit accvar) ... down to the first accumulator. currently it
|
|
;; will be re-initialized for every previous loop except the innermost one.
|
|
;; THIS needs to work:
|
|
;; (loop ((:for a (in-list '((1 2) (3 4) (5 6))))
|
|
;; (:when #t)
|
|
;; (:for b (in-list a))
|
|
;; (:for acc (listing b)))
|
|
;; => acc)
|
|
;; as well as this:
|
|
;; (loop ((:for a (in-list '(((1) (2)) ((3) (4)) ((5) (6 7)))))
|
|
;; (:when #t)
|
|
;; (:for b (in-list a))
|
|
;; (:when :t)
|
|
;; (:for c (in-list b))
|
|
;; (:for acc (listing c)))
|
|
;; => acc)
|
|
|
|
(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 a 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))))
|
|
|
|
|
|
|
|
(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
|
|
next
|
|
((lets ...))
|
|
(((accvar accinit accstep) ...))
|
|
(((var init step) ...))
|
|
((checks ...))
|
|
((refs ...))
|
|
final
|
|
((user-lets ...))
|
|
((user-whens ...))
|
|
((user-breaks ...))
|
|
. body)
|
|
(let innermost-loop ((accvar accinit) ...
|
|
(var init) ...)
|
|
(let* (lets ...)
|
|
(if (or checks ...)
|
|
next
|
|
(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
|
|
next
|
|
(next-lets ... (lets ...))
|
|
(next-accs ... ((accvar accinit accupdate) ...))
|
|
(next-vars ... ((var init update) ...))
|
|
(next-checks ... (checks ...))
|
|
(next-refs ... (refs ...))
|
|
final
|
|
(ul-next ... (user-lets ...))
|
|
(uw-next ... (user-whens ...))
|
|
(ub-next ... (user-breaks ...))
|
|
. body)
|
|
(display "not implemented"))))
|
|
|
|
|
|
;; Helper procedures for let-kw-form
|
|
(define (syntax= s1 s2)
|
|
(equal? (syntax->datum s1) (syntax->datum s2)))
|
|
|
|
(define (named-update? syn)
|
|
(syntax-case syn (=>)
|
|
((=> var update) #t)
|
|
(_ #f)))
|
|
|
|
|
|
(define (update-psn! params psn val)
|
|
(list-set! params psn
|
|
(list (car (list-ref params psn)) val)))
|
|
|
|
(define (update-name! params name val)
|
|
(let loop ((params params))
|
|
(cond
|
|
((null? params) (error "unknown loop parameter name " name (list '=> name val)))
|
|
((syntax= name (caar params))
|
|
(set-cdr! (car params) (list val))
|
|
(display (syntax->datum val))
|
|
)
|
|
(else
|
|
(loop (cdr params))))))
|
|
|
|
(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)
|
|
;; this way of formulating params means it is an alist with syntax objects
|
|
;; as keys instead of a list of syntax objects
|
|
(define params (list #'(var step) ...))
|
|
(with-ellipsis :::
|
|
(let loop ((lst (cdr (syntax->list stx))) (pos 0))
|
|
(if (null? lst)
|
|
(with-syntax ((((v s) :::) params))
|
|
#'(loop-name s :::))
|
|
(syntax-case (car lst) (=>)
|
|
((=> name val)
|
|
(update-name! params #'name #'val)
|
|
(loop (cdr lst) #f))
|
|
(val pos
|
|
(begin
|
|
(update-psn! params psn #'val)
|
|
(loop (cdr lst) (+ pos 1))))
|
|
(_ (error "Positional arguments cannot be updated after a named argument")))))))))
|
|
. body))))
|
|
|
|
|