;; goof loop - a bastardisation of chibi loop. ;; ;; Copyright 2020, 2021 Linus Björnstam ;; ;; 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. (define-module (goof) #:use-module (goof helpers) #:use-module (goof ref-let) #:use-module ((rnrs io simple) #:select (eof-object)) #:use-module ((srfi srfi-1) #:select (any circular-list find)) #:use-module ((srfi srfi-43) #:select (vector-copy vector-copy!)) #:use-module (srfi srfi-71) #:use-module (ice-9 futures) #:export (loop loop/list loop/sum loop/product loop/first loop/last loop/and loop/or loop/list/parallel :when :unless :break :continue :final :bind :subloop :do :for :acc :initial :length :fill :to :by :default in in-list in-lists in-vector in-vector-reverse in-string in-string-reverse in-hash in-port in-file in-generator up-from down-from accumulating folding listing listing-reverse appending appending-reverse summing multiplying hashing vectoring ;; generator clauses in-cycle in-indexed stop-before stop-after ;; Syntax for adding clauses register-loop-clause)) ;; This contains the portable parts of goof-loop. (include "goof/goof-impl.scm") ;; This part is only for an auxilary macro that checks whether the :for or :acc clause is ;; actually defined. The reason I use parameters here is because guile modules are immutable by ;; default and I had to wrap it in something. Paremeters are available in the default environment ;; boxes are not. (define valid-for-clauses (make-parameter (list #'in #'in-list #'in-lists #'in-vector #'in-vector-reverse #'in-string #'in-string-reverse #'in-hash #'in-port #'in-file #'in-generator #'up-from #'down-from ;; generator clauses #'in-cycle #'in-indexed #'stop-before #'stop-after))) (define valid-acc-clauses (make-parameter (list #'folding #'listing #'listing-reverse #'appending #'appending-reverse #'summing #'multiplying #'hashing #'hashving #'hashqing #'vectoring))) (define (add-clause type form) (cond ((eq? type 'for) (valid-for-clauses (cons form (valid-for-clauses)))) ((eq? type 'acc) (valid-acc-clauses (cons form (valid-acc-clauses)))) (else (error "The argument type should be either 'acc or 'for")))) (define-syntax register-loop-clause (syntax-rules () ((_ type form) (eval-when (expand load eval) (add-clause type form))))) ;; Syntax (valid-clause? form rest ...) validates that it's first form is an already registered iterator ;; or accumulator. In guile we can do this by offloading all hard book-keeping to the hygienic ;; macro system. We simple store the syntax object of the iterator/accumulator and use ;; free-identifier=? to see if whatever iterator/accumulator used is actually defined. (define-syntax valid-clause? (lambda (stx) (define (clause-defined? type binding) (define searchee (cond ((eq? 'for type) (valid-for-clauses)) ((eq? 'acc type) (valid-acc-clauses)))) (define (pred x) (free-identifier=? x binding)) (find pred searchee)) (syntax-case stx (:acc :for) ((_ accumulator :acc one two original-syntax . rest) (if (clause-defined? 'acc #'accumulator) #'(accumulator :acc one two original-syntax . rest) (syntax-violation (syntax->datum #'accumulator) "Unknown accumulator in loop: " #'original-syntax #'accumulator))) ((_ iterator :for one two original-syntax . rest) (if (clause-defined? 'for #'iterator) #'(iterator :for one two original-syntax . rest) (syntax-violation (syntax->datum #'iterator) "Unknown iterator in loop: " #'original-syntax #'iterator)))))) ;; 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 variable 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 inner-recur (syntax-rules () ;; If we have no final tests, don't bother producing the code. The guile ;; inliner/DCE stops trying to do more work if the loop is very deep ;; meaning in deeply nested loops, we could end up producing slow code. ((_ loop-name final-fun () ((v s) ...)) (loop-name s ...)) ;; This is somewhat of an ugly thing. We want to test (or user-finals ...) ;; before updating the loop variables, but we want to update the loop variables ;; before running the final-fun. ((_ loop-name final-fun (user-finals ...) ((v s) ...)) (if (or user-finals ...) (let ((v s) ...) final-fun) (loop-name s ...))))) (define (syntax->list stx) (syntax-case stx () ((a ...) #'(a ...)))) (define-syntax let-kw-form (syntax-rules () ((_ macro-name final-fun (user-finals ...) (loop-name (var step) ...) . body) (let-syntax ((macro-name (lambda (stx) (let loop ((lst (cdr (syntax->list stx))) (params (list #'(var step) ...))) (if (null? lst) (with-syntax ((((v s) (... ...)) params)) #'(inner-recur loop-name final-fun (user-finals ...) ((v 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/parallel (syntax-rules () ((n (clauses ...) body ...) (forify (n (clauses ...) body ...) parallel-list-loop () (clauses ... (%acc futures (listing-reverse (future (let () body ...))))) => (loop ((:for future (in-list futures)) (:acc futures2 (listing-reverse (touch future)))) => futures2) (parallel-list-loop)))))