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

Start of something big

Browse source 
This marks a deviation from the foof-loop inheritance, and a path
towards a more lexical scope. :for clauses are now bound to the top of
each loop, and the following :bind, :when, :unless, :break, :final and
:acc clauses now follow a the lexical order of when they were
introduced... At least, that's the plan. This commit makes :for, :bind,
:when, :unless and :break work. The rest is broken.

and :let+:let* are no more.
This commit is contained in:
Linus 2021-05-16 20:09:06 +02:00
parent cccc324ecd
commit 769553832b
2 changed files with 103 additions and 135 deletions
Download patch file Download diff file Expand all files Collapse all files

202
goof-impl.scm
View file

@ -29,7 +29,7 @@
(define-aux-syntaxes (define-aux-syntaxes
;; 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 :bind :subloop :for :acc
;; Auxiliary syntax for the iterators. ;; Auxiliary syntax for the iterators.
:gen :gen
;; auxiliary auxiliary syntax ;; auxiliary auxiliary syntax
@ -40,7 +40,9 @@
;; Internal syntax. %acc is turned into :acc by the forify macro ;; 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 ;; it is used make it possible to report an error if :acc is used in
;; one of the simple macros. ;; one of the simple macros.
%acc) %acc
;; nop. Used by CL
:nop)
@ -76,7 +78,7 @@
(syntax-rules (:for :acc :break :subloop :when :unless :final DONE) (syntax-rules (:for :acc :break :subloop :when :unless :final DONE)
((_ DONE clauses () orig name . body) ((_ DONE clauses () orig name . body)
(cl orig name (cl orig name
(()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) () (()) (()) (()) (()) (()) () ((() ())) (())
clauses . body)) clauses . body))
;; Ensure that a subloop gets run at least once ;; Ensure that a subloop gets run at least once
@ -103,7 +105,7 @@
(define-syntax push-new-subloop (define-syntax push-new-subloop
(syntax-rules () (syntax-rules ()
((_ orig name (lets ...) (accs ...) (vars ...) (checks ...) (refs ...) f (((ff-cur ...) (ff-above ...)) . ff-rest) ((_ orig name (lets ...) (accs ...) (vars ...) (checks ...) (refs ...) f (((ff-cur ...) (ff-above ...)) . ff-rest)
(ul ...) (uw ...) (ub ...) uf clauses . body) (user ...) clauses . body)
(cl orig name (cl orig name
(() lets ...) (() lets ...)
(() accs ...) (() accs ...)
@ -113,58 +115,55 @@
f f
;; propagate :for-finalizers to subloop to be run in case of :break ;; propagate :for-finalizers to subloop to be run in case of :break
((() (ff-cur ... ff-above ...)) ((ff-cur ...) (ff-above ...)) . ff-rest) ((() (ff-cur ... ff-above ...)) ((ff-cur ...) (ff-above ...)) . ff-rest)
(() ul ...) (() user ...)
(() uw ...)
(() ub ...)
uf
clauses . body)))) clauses . body))))
;; cl sorts all the clauses into subloops and positions everything where it should be. ;; cl sorts all the clauses into subloops and positions everything where it should be.
(define-syntax cl (define-syntax cl
(syntax-rules (=> :for :acc :when :unless :break :final :let :let* :subloop) (syntax-rules (=> :for :acc :when :unless :break :final :bind :subloop)
((_ orig name l a v c r f ff ul uw ub uf () => expr . body) ((_ orig name l a v c r f ff user () => expr . body)
(emit orig name l a v c r f ff ul uw ub uf expr . body)) (emit orig name l a v c r f ff user expr . body))
((_ orig name l a v c r f ff ul uw ub uf () . body) ((_ orig name l a v c r f ff user () . body)
(emit orig name l a v c r f ff ul uw ub uf (if #f #f) . body)) (emit orig name l a v c r f ff user (if #f #f) . body))
;; user bindings
((_ orig name l a v c r f ff ((cur-ul ...) . ul-rest) ((:bind (id id* ... expr) ...) clauses ...) . body)
(cl orig name l a v c r f ff ((cur-ul ... (:bind (id id* ... expr) ...)) . ul-rest) (clauses ...) . body))
;; USER LETS
((_ orig name l a v c r f ff ((cur-ul ...) . ul-rest) uw ub uf ((:let id id* ... expr) clauses ...) . body)
(cl orig name l a v c r f ff ((cur-ul ... (:let id id* ... expr)) . ul-rest) uw ub uf (clauses ...) . body))
((_ orig name l a v c r f ff ((cur-ul ...) . ul-rest) uw ub uf ((:let* id id* ... expr) clauses ...) . body)
(cl orig name l a v c r f ff ((cur-ul ... (:let* id id* ... expr)) . ul-rest) uw ub uf (clauses ...) . body))
;; user-whens ;; user-whens
((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf ((:when test) clauses ...) . body) ((_ orig name l a v c r f ff ((cur-uw ...) . uw-rest) ((:when test) clauses ...) . body)
(cl orig name l a v c r f ff ul ((cur-uw ... test) . uw-rest) ub uf (clauses ...) . body)) (cl orig name l a v c r f ff ((cur-uw ... (:when test)) . uw-rest) (clauses ...) . body))
((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf ((:unless test) clauses ...) . body) ((_ orig name l a v c r f ff ((cur-uw ...) . uw-rest) ((:unless test) clauses ...) . body)
(cl orig name l a v c r f ff ul ((cur-uw ... (not test)) . uw-rest) ub uf (clauses ...) . body)) (cl orig name l a v c r f ff ((cur-uw ... (:when (not test))) . uw-rest) (clauses ...) . body))
;; 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 ((cur-ub ...) . ub-rest) ((: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 ((cur-ub ... (:break expr)) . ub-rest) (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 ((cur-uw ...) . uw-rest)((: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 ((cur-uw ... (:final expr)) . uw-rest) (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 ((cur-uw ...) . uw-rest) (:subloop clauses ...) . body)
(cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ub uf (clauses ...) . body)) (cl orig name l a v c r f ff ((cur-uw ... :nop) . uw-rest) (clauses ...) . body))
;; :for-clauses ;; :for-clauses
;; found a for clause when we have a :when or :unless clause. Push new subloop ;; found a for clause when we have a :when or :unless clause. Push new subloop
((_ orig name l a v c r f ff ul ((uw uw* ...) . uw-rest) ub uf ((:for for-rest ...) clauses ...) . body) ((_ orig name l a v c r f ff ((uw uw* ...) . uw-rest) ((:for for-rest ...) clauses ...) . body)
(push-new-subloop orig name l a v c r f ff ul ((uw uw* ...) . uw-rest) ub uf ((:for for-rest ...) clauses ...) . body)) (push-new-subloop orig name l a v c r f ff ((uw uw* ...) . uw-rest) ((:for for-rest ...) clauses ...) . body))
;; For clause with a sequence creator. ;; For clause with a sequence creator.
((_ orig name l a v c r f ff ul uw ub uf ((:for id ids ... (iterator source ...)) clauses ...) . body) ((_ orig name l a v c r f ff user((:for id ids ... (iterator source ...)) clauses ...) . body)
(valid-clause? iterator :for ((id ids ...) (source ...)) cl-next/for orig name l a v c r f ff ul uw ub uf (clauses ...) . body)) (valid-clause? iterator :for ((id ids ...) (source ...)) cl-next/for orig name l a v c r f ff user (clauses ...) . body))
;; accumulator clause ;; accumulator clause
((_ 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 user ((:acc id ids ... (accumulator source ...)) clauses ...) . body)
(valid-clause? accumulator :acc ((id ids ...) (source ...)) cl-next/acc orig name l a v c r f ff ul uw ub uf (clauses ...) . body)) (valid-clause? accumulator :acc ((id ids ...) (source ...)) cl-next/acc orig name l a v c r f ff user (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 user (clause . rest) . body)
(syntax-error "Invalid clause in loop" clause orig)) (syntax-error "Invalid clause in loop" clause orig))
)) ))
@ -245,7 +244,7 @@
((refs ...) . refs-rest) ((refs ...) . refs-rest)
finals finals
(((ff-cur ...) (ff-above ...)) . ff-rest) (((ff-cur ...) (ff-above ...)) . ff-rest)
ul uw ub uf clauses . body) user clauses . body)
(cl orig name (cl orig name
((lets ... new-lets ...) . lets-rest) ((lets ... new-lets ...) . lets-rest)
accs accs
@ -254,33 +253,32 @@
((refs ... new-refs ...) . refs-rest) ((refs ... new-refs ...) . refs-rest)
finals finals
(((ff-cur ... new-for-finals ...) (ff-above ...)) . ff-rest) (((ff-cur ... new-for-finals ...) (ff-above ...)) . ff-rest)
ul uw ub uf clauses . body)) user clauses . body))
((cl err ...) ((cl err ...)
(cl err ...)))) (cl err ...))))
(define-syntax user-let
(syntax-rules (:let :let*) (define-syntax user
((_ () () () body ...) (syntax-rules (:when :bind :break :final :nop)
((_ final-expr next outer () body ...)
(begin body ...)) (begin body ...))
((_ (lets ...) () () . body)
(let (lets ...)
. body))
((_ () (stars ...) () . body)
(let* (stars ...) . body))
;; These twe clauses handle let type changes. ((_ f n o (:nop . rest) . body)
((_ () (stars ... last) ((:let id id* ... expr) clauses ...) . body) (user f n o rest . body))
(let* (stars ...)
(user-let (last (id id* ... expr)) () (clauses ...) . body)))
((_ (lets ...) () ((:let* id id* ... expr) clauses ...) . body)
(let (lets ...)
(user-let () ((id id* ... expr)) (clauses ...) . body)))
;; 2 clauses new of the same that already existed ((_ f n o ((:bind pairs ...) . rest) . body)
((_ (lets ...) () ((:let id id* ... expr) clauses ...) . body) (let (pairs ...)
(user-let (lets ... (id id* ... expr)) () (clauses ...) . body)) (user f n o rest . body)))
((_ () (stars ...) ((:let* id id* ... expr) clauses ...) . body) ((_ f n o ((:when test) . rest) . body)
(user-let () (stars ... (id id* ... expr)) (clauses ...) . body)))) (cond
(test (user f n o rest . body))
(else n)))
((_ (final-expr ...) n o ((:break expr) . rest) . body)
(cond
(expr final-expr ...)
(else (user (final-expr ...) n o rest . body))))
))
;; If there are no subloops, we emit to the simple case ;; If there are no subloops, we emit to the simple case
(define-syntax emit (define-syntax emit
@ -300,7 +298,7 @@
((refs ...)) ((refs ...))
((final-binding final-value) ...) ((final-binding final-value) ...)
(((ff-cur ...) (ff-above ...))) (((ff-cur ...) (ff-above ...)))
((user-lets ...)) ((user-whens ...)) ((user-breaks ...)) uf ((us ...))
final-expr . body) final-expr . body)
(let* ((final-fun (lambda (final-binding ...) final-expr)) (let* ((final-fun (lambda (final-binding ...) final-expr))
lets ...) lets ...)
@ -310,19 +308,15 @@
ff-cur ... ff-cur ...
(final-fun final-value ...)) (final-fun final-value ...))
(ref-let (refs ...) (ref-let (refs ...)
(user-let () () (user-lets ...) (user (ff-above ... ff-cur ... (final-fun final-value ...))
(if (and user-whens ...) (loop accvar ... step ...)
#f
(us ...)
(let-kw-form name (let-kw-form name
(final-fun final-value ...) (final-fun final-value ...)
uf ()
(loop (accvar accstep) ... (var step) ...) (loop (accvar accstep) ... (var step) ...)
(cond (let () (if #f #f) . body))))))))))
((or user-breaks ...)
ff-above ... ff-cur ...
(final-fun final-value ...))
(else
(let () (if #f #f) . body))))
(loop accvar ... step ...) )))))))))
;; Emit-many/first emits the outermost let loop and binds the final lambda. ;; Emit-many/first emits the outermost let loop and binds the final lambda.
(define-syntax emit-many/first (define-syntax emit-many/first
@ -335,10 +329,7 @@
(refs-next ... (refs ...)) (refs-next ... (refs ...))
((final-binding final-value) ...) ((final-binding final-value) ...)
(ff-next ... ((ff-cur ...) ())) (ff-next ... ((ff-cur ...) ()))
(ul-next ... (user-lets ...)) (us-next ... (us ...))
(uw-next ... (user-whens ...))
(ub-next ... (user-breaks ...))
uf
final-expr final-expr
. body) . body)
(let* ((final-fun (lambda (final-binding ...) final-expr)) (let* ((final-fun (lambda (final-binding ...) final-expr))
@ -350,13 +341,11 @@
ff-cur ... ff-cur ...
(final-fun final-value ...)) (final-fun final-value ...))
(ref-let (refs ...) (ref-let (refs ...)
(user-let () () (user-lets ...) (user (ff-cur ... (final-fun final-value ...))
(if (and user-whens ...) (outer-loop accvar ... step ...)
(cond #f
((or user-breaks ...) (us ...)
ff-cur ... (emit-many/rest orig
(final-fun final-value ...))
(else (emit-many/rest orig
name name
(outer-loop accstep ... step ...) (outer-loop accstep ... step ...)
(lets-next ...) (lets-next ...)
@ -367,12 +356,8 @@
;; THIS IS NOW A COMPLETE call to final ;; THIS IS NOW A COMPLETE call to final
(final-fun final-value ...) (final-fun final-value ...)
(ff-next ...) (ff-next ...)
(ul-next ...) (us-next ...)
(uw-next ...) . body)))))))))
(ub-next ...)
uf
. body)))
(outer-loop accvar ... step ...))))))))))
(define-syntax emit-many/rest (define-syntax emit-many/rest
(syntax-rules () (syntax-rules ()
@ -387,10 +372,7 @@
((refs ...)) ((refs ...))
final final
(((ff-cur ...) (ff-above ...))) (((ff-cur ...) (ff-above ...)))
((user-lets ...)) ((us ...))
((user-whens ...))
((user-breaks ...))
uf
. body) . body)
(let* (lets ...) (let* (lets ...)
(let innermost-loop ((accvar accinit) ... (let innermost-loop ((accvar accinit) ...
@ -400,16 +382,12 @@
ff-cur ... ff-cur ...
outer) outer)
(ref-let (refs ...) (ref-let (refs ...)
(user-let () () (user-lets ...) (user (ff-cur ... ff-above ... final)
(if (and user-whens ...) (innermost-loop accstep ... step ...)
(cond #f
((or user-breaks ...) (us ...)
ff-above ... ff-cur ... (let-kw-form name final () (innermost-loop (accvar accstep) ... (var step) ...)
final) . body)))))))
(else
(let-kw-form name final uf (innermost-loop (accvar accstep) ... (var step) ...)
. body)))
(innermost-loop accvar ... step ...))))))))
;; Any intermediate loops ;; Any intermediate loops
((_ orig ((_ orig
@ -422,10 +400,7 @@
(next-refs ... (refs ...)) (next-refs ... (refs ...))
final final
(next-ff ... ((ff-cur ...) (ff-above ...))) (next-ff ... ((ff-cur ...) (ff-above ...)))
(ul-next ... (user-lets ...)) (us-next ... (us ...))
(uw-next ... (user-whens ...))
(ub-next ... (user-breaks ...))
uf
. body) . body)
(let* (lets ...) (let* (lets ...)
(let intermediate-loop ((accvar accinit) ... (let intermediate-loop ((accvar accinit) ...
@ -435,13 +410,10 @@
ff-cur ... ff-cur ...
outer) outer)
(ref-let (refs ...) (ref-let (refs ...)
(user-let () () (user-lets ...) (user (ff-cur ... ff-above ... final)
(if (and user-whens ...) (intermediate-loop accstep ... step ...)
(cond #f
((or user-breaks ...) (emit-many/rest orig
ff-above ... ff-cur ...
final)
(else (emit-many/rest orig
name name
(intermediate-loop accstep ... step ...) (intermediate-loop accstep ... step ...)
(next-lets ...) (next-lets ...)
@ -451,15 +423,11 @@
(next-refs ...) (next-refs ...)
final final
(next-ff ...) (next-ff ...)
(ul-next ...) (us-next ...)
(uw-next ...) . body)))))))))
(ub-next ...)
uf
. body)))
(intermediate-loop accvar ... step ...))))))))))
(define-syntax forify (define-syntax forify
(syntax-rules (%acc) (syntax-rules (%acc)
((_ orig name () ((%acc . acc-rest) . argsrest) . body) ((_ orig name () ((%acc . acc-rest) . argsrest) . body)
(forify* orig name () ((:for ensure-once (up-from 0 1)) (%acc . acc-rest) . argsrest) . body)) (forify* orig name () ((:for ensure-once (up-from 0 1)) (%acc . acc-rest) . argsrest) . body))
((_ . rest) ((_ . rest)

2
goof.scm
View file

@ -47,7 +47,7 @@
loop/or loop/or
loop/list/parallel loop/list/parallel
:when :unless :break :final :let :let* :subloop :for :acc :when :unless :break :final :bind :subloop :for :acc
:length :fill :length :fill
:to :by :to :by