Start of something big
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
parent
cccc324ecd
commit
769553832b
2 changed files with 103 additions and 135 deletions
236
goof-impl.scm
236
goof-impl.scm
|
|
@ -29,7 +29,7 @@
|
|||
|
||||
(define-aux-syntaxes
|
||||
;; 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.
|
||||
:gen
|
||||
;; auxiliary auxiliary syntax
|
||||
|
|
@ -40,7 +40,9 @@
|
|||
;; 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)
|
||||
%acc
|
||||
;; nop. Used by CL
|
||||
:nop)
|
||||
|
||||
|
||||
|
||||
|
|
@ -76,7 +78,7 @@
|
|||
(syntax-rules (:for :acc :break :subloop :when :unless :final DONE)
|
||||
((_ DONE clauses () orig name . body)
|
||||
(cl orig name
|
||||
(()) (()) (()) (()) (()) () ((() ())) (()) (()) (()) ()
|
||||
(()) (()) (()) (()) (()) () ((() ())) (())
|
||||
clauses . body))
|
||||
|
||||
;; Ensure that a subloop gets run at least once
|
||||
|
|
@ -103,7 +105,7 @@
|
|||
(define-syntax push-new-subloop
|
||||
(syntax-rules ()
|
||||
((_ 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
|
||||
(() lets ...)
|
||||
(() accs ...)
|
||||
|
|
@ -113,58 +115,55 @@
|
|||
f
|
||||
;; propagate :for-finalizers to subloop to be run in case of :break
|
||||
((() (ff-cur ... ff-above ...)) ((ff-cur ...) (ff-above ...)) . ff-rest)
|
||||
(() ul ...)
|
||||
(() uw ...)
|
||||
(() ub ...)
|
||||
uf
|
||||
(() user ...)
|
||||
clauses . body))))
|
||||
|
||||
|
||||
;; cl sorts all the clauses into subloops and positions everything where it should be.
|
||||
(define-syntax cl
|
||||
(syntax-rules (=> :for :acc :when :unless :break :final :let :let* :subloop)
|
||||
((_ 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 ul uw ub uf expr . body))
|
||||
((_ orig name l a v c r f ff ul uw ub uf () . body)
|
||||
(emit orig name l a v c r f ff ul uw ub uf (if #f #f) . body))
|
||||
(syntax-rules (=> :for :acc :when :unless :break :final :bind :subloop)
|
||||
((_ orig name l a v c r f ff user () => expr . body)
|
||||
(emit orig name l a v c r f ff user expr . body))
|
||||
((_ orig name l a v c r f ff user () . 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
|
||||
((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf ((:when test) clauses ...) . body)
|
||||
(cl orig name l a v c r f ff ul ((cur-uw ... test) . uw-rest) ub uf (clauses ...) . body))
|
||||
((_ orig name l a v c r f ff ul ((cur-uw ...) . uw-rest) ub uf ((: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))
|
||||
((_ 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 ((cur-uw ... (:when test)) . uw-rest) (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 ((cur-uw ... (:when (not test))) . uw-rest) (clauses ...) . body))
|
||||
|
||||
;; 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))
|
||||
((_ 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 ((cur-ub ... (:break expr)) . ub-rest) (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))
|
||||
((_ 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 ((cur-uw ... (:final expr)) . uw-rest) (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)
|
||||
(cl orig name l a v c r f ff ul ((cur-uw ... #t) . uw-rest) ub uf (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 ((cur-uw ... :nop) . uw-rest) (clauses ...) . body))
|
||||
;; :for-clauses
|
||||
;; 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)
|
||||
(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 ((uw uw* ...) . uw-rest) ((:for for-rest ...) clauses ...) . body))
|
||||
|
||||
;; 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)
|
||||
(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))
|
||||
((_ 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 user (clauses ...) . body))
|
||||
|
||||
;; accumulator clause
|
||||
((_ orig name l a v c r f ff ul uw ub uf ((: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))
|
||||
((_ 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 user (clauses ...) . body))
|
||||
|
||||
;; 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))
|
||||
|
||||
))
|
||||
|
|
@ -245,7 +244,7 @@
|
|||
((refs ...) . refs-rest)
|
||||
finals
|
||||
(((ff-cur ...) (ff-above ...)) . ff-rest)
|
||||
ul uw ub uf clauses . body)
|
||||
user clauses . body)
|
||||
(cl orig name
|
||||
((lets ... new-lets ...) . lets-rest)
|
||||
accs
|
||||
|
|
@ -254,33 +253,32 @@
|
|||
((refs ... new-refs ...) . refs-rest)
|
||||
finals
|
||||
(((ff-cur ... new-for-finals ...) (ff-above ...)) . ff-rest)
|
||||
ul uw ub uf clauses . body))
|
||||
user clauses . body))
|
||||
((cl err ...)
|
||||
(cl err ...))))
|
||||
|
||||
(define-syntax user-let
|
||||
(syntax-rules (:let :let*)
|
||||
((_ () () () body ...)
|
||||
|
||||
(define-syntax user
|
||||
(syntax-rules (:when :bind :break :final :nop)
|
||||
((_ final-expr next outer () body ...)
|
||||
(begin body ...))
|
||||
((_ (lets ...) () () . body)
|
||||
(let (lets ...)
|
||||
. body))
|
||||
((_ () (stars ...) () . body)
|
||||
(let* (stars ...) . body))
|
||||
|
||||
;; These twe clauses handle let type changes.
|
||||
((_ () (stars ... last) ((:let id id* ... expr) clauses ...) . 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)))
|
||||
((_ f n o (:nop . rest) . body)
|
||||
(user f n o rest . body))
|
||||
|
||||
;; 2 clauses new of the same that already existed
|
||||
((_ (lets ...) () ((:let id id* ... expr) clauses ...) . body)
|
||||
(user-let (lets ... (id id* ... expr)) () (clauses ...) . body))
|
||||
((_ () (stars ...) ((:let* id id* ... expr) clauses ...) . body)
|
||||
(user-let () (stars ... (id id* ... expr)) (clauses ...) . body))))
|
||||
((_ f n o ((:bind pairs ...) . rest) . body)
|
||||
(let (pairs ...)
|
||||
(user f n o rest . body)))
|
||||
((_ f n o ((:when test) . rest) . 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
|
||||
(define-syntax emit
|
||||
|
|
@ -300,7 +298,7 @@
|
|||
((refs ...))
|
||||
((final-binding final-value) ...)
|
||||
(((ff-cur ...) (ff-above ...)))
|
||||
((user-lets ...)) ((user-whens ...)) ((user-breaks ...)) uf
|
||||
((us ...))
|
||||
final-expr . body)
|
||||
(let* ((final-fun (lambda (final-binding ...) final-expr))
|
||||
lets ...)
|
||||
|
|
@ -310,19 +308,15 @@
|
|||
ff-cur ...
|
||||
(final-fun final-value ...))
|
||||
(ref-let (refs ...)
|
||||
(user-let () () (user-lets ...)
|
||||
(if (and user-whens ...)
|
||||
(let-kw-form name
|
||||
(final-fun final-value ...)
|
||||
uf
|
||||
(loop (accvar accstep) ... (var step) ...)
|
||||
(cond
|
||||
((or user-breaks ...)
|
||||
ff-above ... ff-cur ...
|
||||
(final-fun final-value ...))
|
||||
(else
|
||||
(let () (if #f #f) . body))))
|
||||
(loop accvar ... step ...) )))))))))
|
||||
(user (ff-above ... ff-cur ... (final-fun final-value ...))
|
||||
(loop accvar ... step ...)
|
||||
#f
|
||||
(us ...)
|
||||
(let-kw-form name
|
||||
(final-fun final-value ...)
|
||||
()
|
||||
(loop (accvar accstep) ... (var step) ...)
|
||||
(let () (if #f #f) . body))))))))))
|
||||
|
||||
;; Emit-many/first emits the outermost let loop and binds the final lambda.
|
||||
(define-syntax emit-many/first
|
||||
|
|
@ -335,10 +329,7 @@
|
|||
(refs-next ... (refs ...))
|
||||
((final-binding final-value) ...)
|
||||
(ff-next ... ((ff-cur ...) ()))
|
||||
(ul-next ... (user-lets ...))
|
||||
(uw-next ... (user-whens ...))
|
||||
(ub-next ... (user-breaks ...))
|
||||
uf
|
||||
(us-next ... (us ...))
|
||||
final-expr
|
||||
. body)
|
||||
(let* ((final-fun (lambda (final-binding ...) final-expr))
|
||||
|
|
@ -350,29 +341,23 @@
|
|||
ff-cur ...
|
||||
(final-fun final-value ...))
|
||||
(ref-let (refs ...)
|
||||
(user-let () () (user-lets ...)
|
||||
(if (and user-whens ...)
|
||||
(cond
|
||||
((or user-breaks ...)
|
||||
ff-cur ...
|
||||
(final-fun final-value ...))
|
||||
(else (emit-many/rest orig
|
||||
name
|
||||
(outer-loop accstep ... step ...)
|
||||
(lets-next ...)
|
||||
(accs-next ...)
|
||||
(vars-next ...)
|
||||
(checks-next ...)
|
||||
(refs-next ...)
|
||||
;; THIS IS NOW A COMPLETE call to final
|
||||
(final-fun final-value ...)
|
||||
(ff-next ...)
|
||||
(ul-next ...)
|
||||
(uw-next ...)
|
||||
(ub-next ...)
|
||||
uf
|
||||
. body)))
|
||||
(outer-loop accvar ... step ...))))))))))
|
||||
(user (ff-cur ... (final-fun final-value ...))
|
||||
(outer-loop accvar ... step ...)
|
||||
#f
|
||||
(us ...)
|
||||
(emit-many/rest orig
|
||||
name
|
||||
(outer-loop accstep ... step ...)
|
||||
(lets-next ...)
|
||||
(accs-next ...)
|
||||
(vars-next ...)
|
||||
(checks-next ...)
|
||||
(refs-next ...)
|
||||
;; THIS IS NOW A COMPLETE call to final
|
||||
(final-fun final-value ...)
|
||||
(ff-next ...)
|
||||
(us-next ...)
|
||||
. body)))))))))
|
||||
|
||||
(define-syntax emit-many/rest
|
||||
(syntax-rules ()
|
||||
|
|
@ -387,10 +372,7 @@
|
|||
((refs ...))
|
||||
final
|
||||
(((ff-cur ...) (ff-above ...)))
|
||||
((user-lets ...))
|
||||
((user-whens ...))
|
||||
((user-breaks ...))
|
||||
uf
|
||||
((us ...))
|
||||
. body)
|
||||
(let* (lets ...)
|
||||
(let innermost-loop ((accvar accinit) ...
|
||||
|
|
@ -400,16 +382,12 @@
|
|||
ff-cur ...
|
||||
outer)
|
||||
(ref-let (refs ...)
|
||||
(user-let () () (user-lets ...)
|
||||
(if (and user-whens ...)
|
||||
(cond
|
||||
((or user-breaks ...)
|
||||
ff-above ... ff-cur ...
|
||||
final)
|
||||
(else
|
||||
(let-kw-form name final uf (innermost-loop (accvar accstep) ... (var step) ...)
|
||||
. body)))
|
||||
(innermost-loop accvar ... step ...))))))))
|
||||
(user (ff-cur ... ff-above ... final)
|
||||
(innermost-loop accstep ... step ...)
|
||||
#f
|
||||
(us ...)
|
||||
(let-kw-form name final () (innermost-loop (accvar accstep) ... (var step) ...)
|
||||
. body)))))))
|
||||
|
||||
;; Any intermediate loops
|
||||
((_ orig
|
||||
|
|
@ -422,10 +400,7 @@
|
|||
(next-refs ... (refs ...))
|
||||
final
|
||||
(next-ff ... ((ff-cur ...) (ff-above ...)))
|
||||
(ul-next ... (user-lets ...))
|
||||
(uw-next ... (user-whens ...))
|
||||
(ub-next ... (user-breaks ...))
|
||||
uf
|
||||
(us-next ... (us ...))
|
||||
. body)
|
||||
(let* (lets ...)
|
||||
(let intermediate-loop ((accvar accinit) ...
|
||||
|
|
@ -435,13 +410,10 @@
|
|||
ff-cur ...
|
||||
outer)
|
||||
(ref-let (refs ...)
|
||||
(user-let () () (user-lets ...)
|
||||
(if (and user-whens ...)
|
||||
(cond
|
||||
((or user-breaks ...)
|
||||
ff-above ... ff-cur ...
|
||||
final)
|
||||
(else (emit-many/rest orig
|
||||
(user (ff-cur ... ff-above ... final)
|
||||
(intermediate-loop accstep ... step ...)
|
||||
#f
|
||||
(emit-many/rest orig
|
||||
name
|
||||
(intermediate-loop accstep ... step ...)
|
||||
(next-lets ...)
|
||||
|
|
@ -451,19 +423,15 @@
|
|||
(next-refs ...)
|
||||
final
|
||||
(next-ff ...)
|
||||
(ul-next ...)
|
||||
(uw-next ...)
|
||||
(ub-next ...)
|
||||
uf
|
||||
. body)))
|
||||
(intermediate-loop accvar ... step ...))))))))))
|
||||
(us-next ...)
|
||||
. body)))))))))
|
||||
|
||||
(define-syntax forify
|
||||
(syntax-rules (%acc)
|
||||
((_ orig name () ((%acc . acc-rest) . argsrest) . body)
|
||||
(forify* orig name () ((:for ensure-once (up-from 0 1)) (%acc . acc-rest) . argsrest) . body))
|
||||
((_ . rest)
|
||||
(forify* . rest))))
|
||||
(syntax-rules (%acc)
|
||||
((_ orig name () ((%acc . acc-rest) . argsrest) . body)
|
||||
(forify* orig name () ((:for ensure-once (up-from 0 1)) (%acc . acc-rest) . argsrest) . body))
|
||||
((_ . rest)
|
||||
(forify* . rest))))
|
||||
|
||||
(define-syntax forify*
|
||||
(syntax-rules (:for :acc :when :unless :break :final :subloop :let :let* %acc)
|
||||
|
|
|
|||
2
goof.scm
2
goof.scm
|
|
@ -47,7 +47,7 @@
|
|||
loop/or
|
||||
loop/list/parallel
|
||||
|
||||
:when :unless :break :final :let :let* :subloop :for :acc
|
||||
:when :unless :break :final :bind :subloop :for :acc
|
||||
:length :fill
|
||||
:to :by
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue