Made it a module.
Put it in any directory, run guile -L . and then import (goof) in that directory.
This commit is contained in:
Linus
parent
317b3e732b
commit
7ddb707bb7
5 changed files with 59 additions and 14 deletions
13
goof/helpers.scm
Normal file
13
goof/helpers.scm
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
(define-module (goof helpers)
|
||||
#:export (define-aux-syntax define-aux-syntaxes))
|
||||
|
||||
(define-syntax define-aux-syntax
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
((_ name)
|
||||
#'(define-syntax name
|
||||
(lambda (stx)
|
||||
(syntax-violation 'name "Loop clause used outside of loop macro" stx)))))))
|
||||
(define-syntax-rule (define-aux-syntaxes name ...)
|
||||
(begin
|
||||
(define-aux-syntax name) ...))
|
||||
368
goof/iterators.scm
Normal file
368
goof/iterators.scm
Normal file
|
|
@ -0,0 +1,368 @@
|
|||
;; iterators.scm - iterators for goof-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.
|
||||
|
||||
;; TODO iterators
|
||||
;; in-stream
|
||||
;; in-naturals
|
||||
;; in-hash with variations
|
||||
|
||||
;; TODO: accumulators
|
||||
;; vectoring
|
||||
;; hashing
|
||||
;; hashqing
|
||||
;; hashving
|
||||
|
||||
(define-syntax in
|
||||
(syntax-rules ()
|
||||
((_ ((var) (init)) n . rest)
|
||||
(n () () ((var init var)) () () () . rest))
|
||||
((_ ((var) (init step)) n . rest)
|
||||
(n () () ((var init step)) () () () . rest))
|
||||
((_ ((var) (init step stop)) n . rest)
|
||||
(n () () ((var init step)) (stop) () () . rest))))
|
||||
|
||||
(define-syntax in-list
|
||||
(syntax-rules (:gen)
|
||||
((_ ((var) source) next . rest)
|
||||
(in-list ((var cursor) source) next . rest))
|
||||
((_ ((var cursor) source) next . rest)
|
||||
(in-list ((var cursor succ) source) next . rest))
|
||||
((_ ((var cursor succ) (source)) next . rest)
|
||||
(in-list ((var cursor succ) (source cdr)) next . rest))
|
||||
((_ ((var cursor succ) (source step)) next . rest)
|
||||
(next
|
||||
;; outer let bindings, bound outside the loop, unchanged during the loop
|
||||
()
|
||||
;; accumulators. These are the same as the bindings below, but values are
|
||||
;; kept through subloops.
|
||||
()
|
||||
;; iterator, init, step
|
||||
((cursor source succ))
|
||||
;; tests to check whether the iterator is exhausted.
|
||||
((not (pair? cursor)))
|
||||
;; loop variables (called refs) and updates.
|
||||
((var (car cursor))
|
||||
(succ (step cursor)))
|
||||
;; final bindings: things bound in the final function.
|
||||
()
|
||||
;; the continuation.
|
||||
. rest))
|
||||
|
||||
;; Generator-clauses
|
||||
((_ lst)
|
||||
(gen-list lst))
|
||||
((_ :gen (var) (expr step))
|
||||
(gen-list lst step))))
|
||||
|
||||
(define gen-list
|
||||
(case-lambda
|
||||
((lst)
|
||||
(gen-list lst cdr))
|
||||
((lst by)
|
||||
(lambda ()
|
||||
(if (null? lst)
|
||||
(eof-object)
|
||||
(let ((res (car lst)))
|
||||
(set! lst (by lst))
|
||||
res))))))
|
||||
|
||||
|
||||
(define-syntax in-lists
|
||||
(syntax-rules ()
|
||||
((in-lists ((elts) lol) next . rest)
|
||||
(in-lists ((elts pairs) lol) next . rest))
|
||||
((in-lists ((elts pairs) lol) next . rest)
|
||||
(in-lists ((elts pairs succ) lol) next . rest))
|
||||
((in-lists ((elts pairs succ) (lol)) next . rest)
|
||||
(in-lists ((elts pairs succ) (lol cdr)) next . rest))
|
||||
((in-lists ((elts pairs succ) (lol)) next . rest)
|
||||
(in-lists ((elts pairs succ) (lol cdr)) next . rest))
|
||||
((in-lists ((elts pairs succ) (lol step)) next . rest)
|
||||
(in-lists ((elts pairs succ) (lol step null?)) next . rest))
|
||||
((in-lists ((elts pairs succ) (lol step done?)) next . rest)
|
||||
(next ()
|
||||
()
|
||||
((pairs lol succ))
|
||||
((let lp ((ls pairs)) ; an in-lined ANY
|
||||
(and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls))))))
|
||||
((elts (map car pairs))
|
||||
(succ (map step pairs)))
|
||||
()
|
||||
. rest))))
|
||||
|
||||
(define-syntax define-in-indexed
|
||||
(syntax-rules ()
|
||||
((define-in-indexed in-type in-type-reverse length ref)
|
||||
(begin
|
||||
(define-syntax in-type
|
||||
(syntax-rules ()
|
||||
((in-type seq next . rest)
|
||||
(%in-idx >= (lambda (x i) (+ i 1)) (lambda (x) 0) length ref tmp seq next . rest))))
|
||||
(define-syntax in-type-reverse
|
||||
(syntax-rules ()
|
||||
((in-type-reverse seq next . rest)
|
||||
(%in-idx < (lambda (x i) (- i 1)) (lambda (x) (- (length x) 1)) (lambda (x) 0) ref tmp seq next . rest))))
|
||||
))))
|
||||
|
||||
(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)
|
||||
|
||||
(define-in-indexed in-string in-string-reverse string-length string-ref)
|
||||
|
||||
;; helper for the above string and vector iterators
|
||||
(define-syntax %in-idx
|
||||
(syntax-rules ()
|
||||
;; cmp inc start end ref
|
||||
((%in-idx ge + s e r tmp ((var) (seq ...)) next . rest)
|
||||
(%in-idx ge + s e r tmp ((var seq-index) (seq ...)) next . rest))
|
||||
((%in-idx ge + s e r tmp ((var index) (seq)) next . rest)
|
||||
(%in-idx ge + s e r tmp ((var index) (seq (s tmp) (e tmp))) next . rest))
|
||||
((%in-idx ge + s e r tmp ((var index) (seq from)) next . rest)
|
||||
(%in-idx ge + s e r tmp ((var index) (seq from (e tmp))) next . rest))
|
||||
((%in-idx ge + s e r tmp ((var index) (seq from to)) next . rest)
|
||||
(next ((tmp seq) (end to))
|
||||
()
|
||||
((index from (+ tmp index)))
|
||||
((ge index end))
|
||||
((var (r tmp index)))
|
||||
()
|
||||
. rest))
|
||||
))
|
||||
|
||||
(define-syntax in-port
|
||||
(syntax-rules ()
|
||||
((in-port ((var) source) next . rest)
|
||||
(in-port ((var p) source) next . rest))
|
||||
((in-port ((var p) ()) next . rest)
|
||||
(in-port ((var p) ((current-input-port))) next . rest))
|
||||
((in-port ((var p) (port)) next . rest)
|
||||
(in-port ((var p) (port read-char)) next . rest))
|
||||
((in-port ((var p) (port read-char)) next . rest)
|
||||
(in-port ((var p) (port read-char eof-object?)) next . rest))
|
||||
((in-port ((var p) (port reader eof?)) next . rest)
|
||||
(next ((p port))
|
||||
()
|
||||
((var (reader p) (reader p)))
|
||||
((eof? var))
|
||||
()
|
||||
()
|
||||
. rest))))
|
||||
|
||||
(define-syntax in-file
|
||||
(syntax-rules ()
|
||||
((in-file ((var) source) next . rest)
|
||||
(in-file ((var p) source) next . rest))
|
||||
((in-file ((var p) (file)) next . rest)
|
||||
(in-file ((var p) (file read-char)) next . rest))
|
||||
((in-file ((var p) (file reader)) next . rest)
|
||||
(in-file ((var p) (file reader eof-object?)) next . rest))
|
||||
((in-file ((var p) (file reader eof?)) next . rest)
|
||||
(next ((p (open-input-file file)) (r reader) (e? eof?))
|
||||
()
|
||||
((var (r p) (r p)))
|
||||
((e? var))
|
||||
()
|
||||
((close-input-port p)) . rest))))
|
||||
|
||||
(define-syntax in-generator
|
||||
(syntax-rules ()
|
||||
((_ ((var) (source)) next . rest)
|
||||
(next ((gen source))
|
||||
()
|
||||
((var (gen) (gen)))
|
||||
((eof-object? var))
|
||||
()
|
||||
()
|
||||
. rest))))
|
||||
|
||||
(define-syntax up-from
|
||||
(syntax-rules (to by)
|
||||
((up-from (() . args) next . rest)
|
||||
(up-from ((var) . args) next . rest))
|
||||
((up-from ((var) (start (to limit) (by step))) next . rest)
|
||||
(next ((s start) (l limit) (e step))
|
||||
()
|
||||
((var s (+ var e)))
|
||||
((>= var l))
|
||||
() () . rest))
|
||||
((up-from ((var) (start (to limit))) next . rest)
|
||||
(next ((s start) (l limit)) () ((var s (+ var 1)))
|
||||
((>= var l)) () () . rest))
|
||||
((up-from ((var) (start (by step))) next . rest)
|
||||
(next ((s start) (e step))()
|
||||
((var s (+ var e))) () () () . rest))
|
||||
((up-from ((var) (start)) next . rest)
|
||||
(next ((s start)) () ((var s (+ var 1)))
|
||||
() () () . rest))
|
||||
;; Extra convenience, make it act like (in-range ...) from racket, but only for positive numbers.
|
||||
((up-from ((var) (start limit step)) next . rest)
|
||||
(next ((s start) (l limit) (e step)) () ((var s (+ var e))) ((>= var l)) () () . rest))
|
||||
((up-from ((var) (start limit)) next . rest)
|
||||
(up-from ((var) (start limit 1)) next . rest))))
|
||||
|
||||
(define-syntax down-from
|
||||
(syntax-rules (to by)
|
||||
((down-from (() . args) next . rest)
|
||||
(down-from ((var) . args) next . rest))
|
||||
((down-from ((var) (start (to limit) (by step))) next . rest)
|
||||
(next ((s start) (l limit) (e step))
|
||||
()
|
||||
((var (- s e) (- var e)))
|
||||
((< var l))
|
||||
() () . rest))
|
||||
((down-from ((var) (start (to limit))) next . rest)
|
||||
(next ((s start) (l limit)) () ((var (- s 1) (- var 1)))
|
||||
((< var l)) () () . rest))
|
||||
((down-from ((var) (start (by step))) next . rest)
|
||||
(next ((s start) (e step)) () ((var (- s e) (- var e)))
|
||||
() () () . rest))
|
||||
((down-from ((var) (start)) next . rest)
|
||||
(next ((s start)) () ((var (- s 1) (- var 1)))
|
||||
() () () . rest))
|
||||
((down-from ((var) (start limit step)) next . rest)
|
||||
(next ((s start) (l limit) (e step)) () ((var (- s e) (- var e))) ((< var l)) () () . rest))
|
||||
((down-from ((var) (start limit)) next . rest)
|
||||
(down-from ((var) (start limit 1)) next . rest))))
|
||||
|
||||
(define-syntax accumulating
|
||||
(syntax-rules (initial if :acc)
|
||||
((accumulating :acc (kons final init) ((var) . x) next . rest)
|
||||
(accumulating :acc (kons final init) ((var cursor) . x) next . rest))
|
||||
((accumulating :acc (kons final init) ((var cursor) ((initial i) . x)) n . rest)
|
||||
(accumulating :acc (kons final i) ((var cursor) x) n . rest))
|
||||
((accumulating :acc (kons final init) ((var cursor) (expr (if check))) n . rest)
|
||||
(n ((tmp-kons kons))
|
||||
((cursor init (if check (tmp-kons expr cursor) cursor)))
|
||||
()
|
||||
()
|
||||
()
|
||||
((var (final cursor)))
|
||||
. rest))
|
||||
((accumulating :acc (kons final init) ((var cursor) (expr)) n . rest)
|
||||
(n ((tmp-kons kons))
|
||||
((cursor init (tmp-kons expr cursor)))
|
||||
()
|
||||
()
|
||||
()
|
||||
((var (final cursor)))
|
||||
. rest))))
|
||||
|
||||
(define-syntax folding
|
||||
(syntax-rules (if :acc)
|
||||
((_ :acc ((var) (init update (if guard))) n . rest)
|
||||
(n ()
|
||||
((var init (if guard update var)))
|
||||
() () ()
|
||||
((var var))
|
||||
. rest))
|
||||
((_ :acc ((var) (init update)) n . rest)
|
||||
(folding :acc ((var) (init update (if #t))) n . rest))
|
||||
((_ :acc ((var) (init)) n . rest)
|
||||
(folding :acc ((var) (init var (if #t))) n . rest))))
|
||||
|
||||
(define-syntax listing
|
||||
(syntax-rules (:acc)
|
||||
((listing :acc args next . rest)
|
||||
(accumulating :acc (cons reverse '()) args next . rest))))
|
||||
|
||||
(define-syntax listing-reverse
|
||||
(syntax-rules (:acc)
|
||||
((listing-reverse :acc args next . rest)
|
||||
(accumulating :acc (cons (lambda (x) x) '()) args next . rest))))
|
||||
|
||||
(define (append-reverse rev tail)
|
||||
(if (null? rev) tail (append-reverse (cdr rev) (cons (car rev) tail))))
|
||||
|
||||
(define-syntax appending
|
||||
(syntax-rules (:acc)
|
||||
((appending :acc args next . rest)
|
||||
(accumulating :acc (append-reverse reverse '()) args next . rest))))
|
||||
|
||||
(define-syntax appending-reverse
|
||||
(syntax-rules (:acc)
|
||||
((appending-reverse :acc args next . rest)
|
||||
(accumulating :acc (append-reverse (lambda (x) x) '()) args next . rest))))
|
||||
|
||||
(define-syntax summing
|
||||
(syntax-rules (:acc)
|
||||
((summing :acc args next . rest)
|
||||
(accumulating :acc (+ (lambda (x) x) 0) args next . rest))))
|
||||
|
||||
(define-syntax multiplying
|
||||
(syntax-rules (:acc)
|
||||
((multiplying :acc args next . rest)
|
||||
(accumulating :acc (* (lambda (x) x) 1) args next . rest))))
|
||||
|
||||
|
||||
;;; Here starts generator clauses.
|
||||
|
||||
(define (generator->list gen)
|
||||
(let ((res (gen)))
|
||||
(if (eof-object? res)
|
||||
'()
|
||||
(cons res (generator->list gen)))))
|
||||
|
||||
(define (generator-cycle gen)
|
||||
(let ((circle (apply circular-list (generator->list gen))))
|
||||
(lambda ()
|
||||
(let ((res (car circle)))
|
||||
(set! circle (cdr circle))
|
||||
res))))
|
||||
|
||||
(define-syntax in-cycle
|
||||
(syntax-rules ()
|
||||
((_ ((id) (source)) n . rest)
|
||||
(n ((gen (generator-cycle source)))
|
||||
()
|
||||
()
|
||||
()
|
||||
((id (gen)))
|
||||
()
|
||||
. rest))))
|
||||
|
||||
|
||||
(define (generator-indexed gen)
|
||||
(let ((i 0))
|
||||
(lambda ()
|
||||
(let ((res (gen)) (index i))
|
||||
(if (eof-object? res)
|
||||
(values res res)
|
||||
(begin
|
||||
(set! i (+ i 1))
|
||||
(values index res)))))))
|
||||
|
||||
;; Somewhat of a hack :)
|
||||
(define-syntax in-indexed
|
||||
(syntax-rules ()
|
||||
((_ ((i val) (source)) n . rest)
|
||||
(n ((gen (generator-indexed source)))
|
||||
()
|
||||
((i 0 i))
|
||||
((eof-object? i))
|
||||
((i val (gen)))
|
||||
()
|
||||
. rest))))
|
||||
51
goof/ref-let.scm
Normal file
51
goof/ref-let.scm
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
(define-module (goof ref-let)
|
||||
#:export (ref-let)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-71))
|
||||
|
||||
(define-syntax ref-let
|
||||
(syntax-rules ()
|
||||
((ref-let ids body ...)
|
||||
(rl () () ids body ...))))
|
||||
|
||||
(define-syntax rl
|
||||
(syntax-rules (values)
|
||||
;; emit simple case, no match
|
||||
((_ (lets ...) () () body ...)
|
||||
(let (lets ...)
|
||||
body ...))
|
||||
;; emit, hard case.
|
||||
((rl (lets ...) (matches ...) () body ...)
|
||||
(let (lets ...)
|
||||
(match-let (matches ...)
|
||||
body ...)))
|
||||
|
||||
|
||||
;; a (values ...) clause:
|
||||
((rl (l ...) m (((values . v) expr) . clause-rest) . body)
|
||||
(rl (l ... ((values . v) expr)) m clause-rest . body))
|
||||
|
||||
;; Simple cases
|
||||
;; (rl ((a 5)) () (((b . _) (cons 1 2))) (+ a b))
|
||||
((_ (l ...) (m ...) (((p . p-rest) expr) . clause-rest) body ...)
|
||||
(rl (l ... (dummy expr)) (m ... ((p . p-rest) dummy)) clause-rest body ...))
|
||||
|
||||
|
||||
((rl (l ...) (m ...) ((binding expr) . clause-rest) body ...)
|
||||
(rl (l ... (binding expr)) (m ...) clause-rest body ...))
|
||||
|
||||
;; More than one id
|
||||
((rl l m ((id id* ... expr) . clause-rest) . body)
|
||||
(extract () () (id id* ... expr) l m clause-rest . body))))
|
||||
|
||||
(define-syntax extract
|
||||
(syntax-rules ()
|
||||
((_ let-binding (match-bindings ...) () (l ...) (m ...) clauses . body)
|
||||
(rl (l ... let-binding) (m ... match-bindings ...) clauses . body))
|
||||
((_ (lb ...) mb (expr) . rest)
|
||||
(extract (lb ... expr) mb () . rest))
|
||||
;; Pattern
|
||||
((_ (lb ...) (mb ...) ((p . p-rest) ids ...) . rest)
|
||||
(extract (lb ... dummy) (mb ... ((p . p-rest) dummy)) (ids ...) . rest))
|
||||
((_ (lb ...) mb (id ids ...) . rest)
|
||||
(extract (lb ... id) mb (ids ...) . rest))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue