bjoli/goof-loop
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Made simple loops better. Now with correct syntax proliferation.w

Browse source
This commit is contained in:
Linus 2020-12-01 20:53:25 +01:00
parent 0c110dd080
commit c53a08c769
1 changed files with 101 additions and 48 deletions
Download patch file Download diff file Expand all files Collapse all files

125
goof.scm
View file

@ -32,6 +32,7 @@
;; name, and the fact that I goofed in the chibi issue tracker when
;; trying to understand the iterator protocol.
;; TODO add :let and :let* to forify
(use-modules (helpers)
((srfi srfi-1) #:select (circular-list))
@ -43,7 +44,12 @@
;; Auxiliary syntax for the loop clauses
:when :unless :break :final :let :let* :subloop :for :acc
;; Auxiliary syntax for the iterators.
:gen)
:gen
;; Internal syntax. %acc is turned into :acc by the forify macro
;; it is used make it possible to report an error if :acc is used in
;; one of the simple macros.
%acc
)
(include "iterators.scm")
@ -61,18 +67,26 @@
((loop name () body ...)
(if #f #f))
((loop (clauses ...) body ...)
(cl (loop (clauses ...) body ...)
loop-name
(()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) ()
(clauses ...)
(ensure-for-clause (loop (clauses ...) body ...)
loop-name (clauses ...)
body ... (loop-name)))
((loop name (clauses ...) . body)
(cl (loop name (clauses ...) . body)
(ensure-for-clause (loop name (clauses ...) . body)
name
(()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) ()
(clauses ...)
. body))))
;; Should this check for more?
(define-syntax ensure-for-clause
(syntax-rules (:for :acc :break :subloop :when :unless :final :let :let*)
((_ orig name ((:for for-rest ...) clauses ...) . body)
(cl orig name
(()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) ()
((:for for-rest ...) clauses ...) . body))
((_ orig rest ...)
(syntax-error "First clause must be a :for clause" orig))))
(define-syntax push-new-subloop
(syntax-rules ()
((_ orig name (lets ...) (accs ...) (vars ...) (checks ...) (refs ...) f (((ff-cur ...) (ff-above ...)) . ff-rest)
@ -114,11 +128,11 @@
;; 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 ff ul ((cur-uw ...) . uw-rest) ((cur-ub ...) . ub-rest) uf (:break expr clauses ...) . body)
'(cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ((cur-ub ... expr) . ub-rest) uf (clauses ...) . body))
(cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ((cur-ub ... expr) . ub-rest) uf (clauses ...) . body))
;; user final
;; 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 ff ul ((cur-uw ...) . uw-rest) ub (cur-uf ...) (:final expr clauses ...) . body)
'(cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ub (cur-uf ... expr) (clauses ...) . body))
(cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ub (cur-uf ... expr) (clauses ...) . body))
;; Explicit subloop. Shorthand for (:when #t)
((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf (:subloop clauses ...) . body)
@ -136,13 +150,9 @@
((_ orig name l a v c r f ff ul uw ub uf ((:acc id ids ... (accumulator source ...)) clauses ...) . body)
(accumulator :acc ((id ids ...) (source ...)) cl-next/acc orig name l a v c r f ff ul uw ub uf (clauses ...) . body))
;; no :acc or :for: imlplicit for!
((_ orig name l a v c r f ff ul uw ub uf ((id ids ... (iterator source ...)) clauses ...) . body)
(cl orig name l a v c r f ff ul uw ub uf ((:for id ids ... (iterator source ...)) clauses ...) . body))
;; ERROR HANDLING?
((_ orig name l a v c r f ff ul uw ub uf (clause . rest) . body)
'(syntax-error "Invalid clause in loop" clause orig))
(syntax-error "Invalid clause in loop" clause orig))
))
@ -477,64 +487,107 @@
(define-syntax forify
(syntax-rules (:for :acc :when :unless :break :final :subloop %acc)
((forify o n done-clauses () . body)
(cl 1 n
(()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) ()
done-clauses . body))
((_ o n (s ...) ((:for c-rest ...) clauses ...) . body)
(forify o n (s ... (:for c-rest ...)) (clauses ...) . body))
((_ o n (s ...) (:when expr clauses ...) . body)
(forify o n (s ... :when expr) (clauses ...) . body))
((_ o n (s ...) (:unless expr clauses ...) . body)
(forify o n (s ... :when expr) (clauses ...) . body))
((_ o n (s ...) (:break expr clauses ...) . body)
(forify o n (s ... :break expr) (clauses ...) . body))
((_ o n (s ...) (:final expr clauses ...) . body)
(forify o n (s ... :final expr) (clauses ...) . body))
((_ o n (s ...) (:subloop clauses ...) . body)
(forify o n (s ... :subloop) (clauses ...) . body))
((_ o n (s ...) ((%acc c-rest ...) clauses ...) . body)
(forify o n (s ... (:acc c-rest ...)) (clauses ...) . body))
((_ o n (s ...) ((:acc c-rest ...) clauses ...) . body)
(syntax-error "Accumulating clauses are not allowed in simplified loop forms." o))
((_ o n (s ...) ((id id* ... (iterator source ...)) clauses ...) . body)
(forify o n (s ... (:for id id* ... (iterator source ...))) (clauses ...) . body))))
(define-syntax loop/list
(syntax-rules ()
((_ (clauses ...) body ...)
(loop loop-name (clauses ...)
(forify (loop/list (clauses ...) body ...)
loop-name () (clauses ...)
=> '()
(cons (let () body ...) (loop-name))))))
(define-syntax loop/sum
(syntax-rules ()
((_ (clauses ...) body ...)
(loop (clauses ... (:acc acc (summing (let () body ...)))) => acc))))
(forify (loop-sum (clauses ...) body ...)
loop-name
() (clauses ... (%acc acc (summing (let () body ...))))
=> acc
(loop-name)))))
(define-syntax loop/product
(syntax-rules ()
((_ (clauses ...) body ...)
(loop (clauses ... (:acc acc (multiplying (let () body ...)))) => acc))))
((n (clauses ...) body ...)
(forify (n (clauses ...) body ...)
product-loop () (clauses ... (%acc acc (multiplying (let () body ...))))
=> acc
(product-loop)))))
(define sentinel (list 'unique))
;; TODO: maybe have a look at the expansion of this. It seems weird.
(define-syntax loop/first
(syntax-rules ()
((_ (clauses ...) body ...)
(loop loop-name (clauses ... (:acc acc (folding sentinel)) :break (not (eq? sentinel acc)))
=> (if (eq? sentinel acc) #f acc)
(let ((result (let () body ...)))
(loop-name (=> acc result)))))))
((n (clauses ...) body ...)
(forify (n (clauses ...) body ...)
loop/first
() (clauses ... :final #t)
=> #f
body ...))))
(define-syntax loop/last
(syntax-rules ()
((_ (clauses ...) body ...)
(loop loop-name (clauses ... (:acc acc (folding sentinel))) => (if (eq? sentinel acc) #f acc)
((n (clauses ...) body ...)
(forify (n (clauses ...) body ...)
loop-name (clauses ... (%acc acc (folding sentinel)))
=> (if (eq? sentinel acc) #f acc)
(let ((result (let () body ...)))
(loop-name (=> acc result)))))))
(define-syntax loop/and
(syntax-rules ()
((_ (clauses ...) body ...)
(loop loop-name (clauses ... (:acc acc (folding #t)))
((n (clauses ...) body ...)
(forify (n (clauses ...) body ...)
and-loop
() (clauses ... (%acc acc (folding #t)))
=> acc
(let ((res (let () body ...)))
(if res
(loop-name (=> acc res))
#f))))))
(and res (and-loop (=> acc res))))))))
(define-syntax loop/or
(syntax-rules ()
((_ (clauses ...) body ...)
(loop loop-name (clauses ...)
((n (clauses ...) body ...)
(forify (n (clauses ...) body ...)
or-loop
() (clauses ...)
=> #f
(or (let () body ...) (loop-name))))))
(or (let () body ...) (or-loop))))))
(define-syntax loop/list/parallel
(syntax-rules ()
((_ (clauses ...) body ...)
(loop (clauses ... (:acc futures (listing-reverse (future (let () body ...)))))
((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)))))
=> futures2)
(parallel-list-loop)))))