;; 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) #:use-module ((srfi srfi-1) #:select (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 :final :let :let* :subloop :for :acc :length :fill in in-list in-lists in-vector in-reverse-vector in-string in-reverse-string 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 ;; Syntax for adding clauses register-loop-clause )) ;; This contains the portable parts of goof-loop. (include "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 ;; boxer are not. (define valid-for-clauses (make-parameter (list #'in #'in-list #'in-lists #'in-vector #'in-reverse-vector #'in-string #'in-reverse-string #'in-hash #'in-port #'in-file #'in-generator #'up-from #'down-from ;; generator clauses #'in-cycle #'in-indexed ))) (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) ((_ 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 one two original-syntax . rest) (if (clause-defined? 'for #'iterator) #'(iterator 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 () ((_ loop-name final-fun () ((v s) ...)) (loop-name s ...)) ((_ loop-name final-fun (user-finals ...) ((v s) ...)) (let ((v s) ...) (if (or user-finals ...) final-fun (loop-name v ...)))))) (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) (with-ellipsis ::: (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)))))