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

149
goof.scm
View file

@ -32,6 +32,7 @@
;; name, and the fact that I goofed in the chibi issue tracker when ;; name, and the fact that I goofed in the chibi issue tracker when
;; trying to understand the iterator protocol. ;; trying to understand the iterator protocol.
;; TODO add :let and :let* to forify
(use-modules (helpers) (use-modules (helpers)
((srfi srfi-1) #:select (circular-list)) ((srfi srfi-1) #:select (circular-list))
@ -43,7 +44,12 @@
;; Auxiliary syntax for the loop clauses ;; Auxiliary syntax for the loop clauses
:when :unless :break :final :let :let* :subloop :for :acc :when :unless :break :final :let :let* :subloop :for :acc
;; Auxiliary syntax for the iterators. ;; 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") (include "iterators.scm")
@ -61,17 +67,25 @@
((loop name () body ...) ((loop name () body ...)
(if #f #f)) (if #f #f))
((loop (clauses ...) body ...) ((loop (clauses ...) body ...)
(cl (loop (clauses ...) body ...) (ensure-for-clause (loop (clauses ...) body ...)
loop-name loop-name (clauses ...)
(()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) () body ... (loop-name)))
(clauses ...)
body ... (loop-name)))
((loop name (clauses ...) . body) ((loop name (clauses ...) . body)
(cl (loop name (clauses ...) . body) (ensure-for-clause (loop name (clauses ...) . body)
name 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
(()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) () (()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) ()
(clauses ...) ((:for for-rest ...) clauses ...) . body))
. body)))) ((_ orig rest ...)
(syntax-error "First clause must be a :for clause" orig))))
(define-syntax push-new-subloop (define-syntax push-new-subloop
(syntax-rules () (syntax-rules ()
@ -114,11 +128,11 @@
;; USER BREAKS ;; USER BREAKS
;; This pushes a #t to the user when expression, thus forcing a subloop if a for-clause is found afterwards. ;; 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) ((_ 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 ;; user final
;; This pushes a #t to the user when expression, thus forcing a subloop if a for-clause is found afterwards. ;; 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) ((_ 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) ;; 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) ((_ 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) ((_ 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)) (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? ;; ERROR HANDLING?
((_ orig name l a v c r f ff ul uw ub uf (clause . rest) . body) ((_ 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))
)) ))
@ -474,67 +484,110 @@
(loop (cdr lst) (update-name params #'name #'val))) (loop (cdr lst) (update-name params #'name #'val)))
(_ (error "Malformed looping clause in macro"))))))))) (_ (error "Malformed looping clause in macro")))))))))
. body)))) . body))))
(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 (define-syntax loop/list
(syntax-rules () (syntax-rules ()
((_ (clauses ...) body ...) ((_ (clauses ...) body ...)
(loop loop-name (clauses ...) (forify (loop/list (clauses ...) body ...)
loop-name () (clauses ...)
=> '() => '()
(cons (let () body ...) (loop-name)))))) (cons (let () body ...) (loop-name))))))
(define-syntax loop/sum (define-syntax loop/sum
(syntax-rules () (syntax-rules ()
((_ (clauses ...) body ...) ((_ (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 (define-syntax loop/product
(syntax-rules () (syntax-rules ()
((_ (clauses ...) body ...) ((n (clauses ...) body ...)
(loop (clauses ... (:acc acc (multiplying (let () body ...)))) => acc)))) (forify (n (clauses ...) body ...)
product-loop () (clauses ... (%acc acc (multiplying (let () body ...))))
=> acc
(product-loop)))))
(define sentinel (list 'unique)) (define sentinel (list 'unique))
;; TODO: maybe have a look at the expansion of this. It seems weird.
(define-syntax loop/first (define-syntax loop/first
(syntax-rules () (syntax-rules ()
((_ (clauses ...) body ...) ((n (clauses ...) body ...)
(loop loop-name (clauses ... (:acc acc (folding sentinel)) :break (not (eq? sentinel acc))) (forify (n (clauses ...) body ...)
=> (if (eq? sentinel acc) #f acc) loop/first
(let ((result (let () body ...))) () (clauses ... :final #t)
(loop-name (=> acc result))))))) => #f
body ...))))
(define-syntax loop/last (define-syntax loop/last
(syntax-rules () (syntax-rules ()
((_ (clauses ...) body ...) ((n (clauses ...) body ...)
(loop loop-name (clauses ... (:acc acc (folding sentinel))) => (if (eq? sentinel acc) #f acc) (forify (n (clauses ...) body ...)
(let ((result (let () body ...))) loop-name (clauses ... (%acc acc (folding sentinel)))
(loop-name (=> acc result))))))) => (if (eq? sentinel acc) #f acc)
(let ((result (let () body ...)))
(loop-name (=> acc result)))))))
(define-syntax loop/and (define-syntax loop/and
(syntax-rules () (syntax-rules ()
((_ (clauses ...) body ...) ((n (clauses ...) body ...)
(loop loop-name (clauses ... (:acc acc (folding #t))) (forify (n (clauses ...) body ...)
=> acc and-loop
(let ((res (let () body ...))) () (clauses ... (%acc acc (folding #t)))
(if res => acc
(loop-name (=> acc res)) (let ((res (let () body ...)))
#f)))))) (and res (and-loop (=> acc res))))))))
(define-syntax loop/or (define-syntax loop/or
(syntax-rules () (syntax-rules ()
((_ (clauses ...) body ...) ((n (clauses ...) body ...)
(loop loop-name (clauses ...) (forify (n (clauses ...) body ...)
=> #f or-loop
(or (let () body ...) (loop-name)))))) () (clauses ...)
=> #f
(or (let () body ...) (or-loop))))))
(define-syntax loop/list/parallel (define-syntax loop/list/parallel
(syntax-rules () (syntax-rules ()
((_ (clauses ...) body ...) ((n (clauses ...) body ...)
(loop (clauses ... (:acc futures (listing-reverse (future (let () body ...))))) (forify (n (clauses ...) body ...)
=> (loop ((:for future (in-list futures)) parallel-list-loop
(:acc futures2 (listing-reverse (touch future)))) () (clauses ... (%acc futures (listing-reverse (future (let () body ...)))))
=> futures2))))) => (loop ((:for future (in-list futures))
(:acc futures2 (listing-reverse (touch future))))
=> futures2)
(parallel-list-loop)))))