a47d6d992b
Fix foldig to be an :acc version of in. :continue will stop the subloop and start the next iteration of the outer loop
232 lines
9.5 KiB
Scheme
232 lines
9.5 KiB
Scheme
;; 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)))))
|