commit bea5dc47652ad684c422b0ebd3d9ade3a6d5e9c7
parent d17bbb8990764d8254c9ec0c6e24ce47844b52be
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Sun, 21 Nov 2010 08:11:35 +0100
Correction de bugs sur l'initialisation parallèle du for, remise en route du with, ajour du collect et du append.
Diffstat:
1 file changed, 184 insertions(+), 87 deletions(-)
diff --git a/implementation/loop.lisp b/implementation/loop.lisp
@@ -1,15 +1,18 @@
-(defmacro dbg (x) `(print ,x))
-(defmacro dbg (x) nil)
+;; TODO : remplacer les deux my-loop-finish par loop-finish à la fin.
(defun transform-loop (expr)
(let* ((name nil)
- (acc (make-symbol "acc"))
+ (acc (make-symbol "ACC"))
+ (acc-tail (make-symbol "ACC-TAIL"))
+ (first-sym (make-symbol "FIRST"))
(variables nil)
(all-variables nil)
(result nil)
(initialization nil)
(loopbody nil)
+ (loopbody-sym (make-symbol "LOOPBODY"))
(finally nil)
+ (finally-sym (make-symbol "FINALLY"))
(loop-keywords '(named
with for as repeat
initially finally
@@ -21,23 +24,28 @@
if when unless else end
and))
(stack nil)
- ; (group-with nil)
+ (repeat-sym nil)
+ (destination nil)
+ (with-initial-values nil)
(for-clause-type nil)
(for-getter-fun nil)
(for-initial-value nil)
(for-step-fun nil)
(for-end-predicate nil)
(for-numeric-direction nil)
+ (for-numeric-start nil)
+ (for-numeric-end nil)
+ (for-numeric-step nil)
(for-numeric-limit nil)
+ (for-initially-psetq nil)
+ (for-initially-affect nil)
(storage-sym nil)
(vars-names nil)
(get-vars-and-types-end-keywords nil)
(destr-psetq nil)
(left-destr nil)
(right-destr nil)
- (destr-whole-sym (make-symbol "whole"))
- (top-variables `((,acc nil)
- (,destr-whole-sym nil))))
+ (destr-whole-sym (make-symbol "WHOLE")))
(macrolet ((advance (x) `(setq ,x (cdr ,x))))
(tagbody
start
@@ -65,6 +73,13 @@
(when (endp expr) (go end-parse))
(case (car expr)
(do (go do))
+ (collect (go collect))
+ (append (go append))
+ (nconc (go nconc))
+ (sum (go sum))
+ (count (go count))
+ (minimize (go minimize))
+ (maximize (go maximize))
(initially (push 'prologue stack) (go initially))
(finally (push 'prologue stack) (go finally))
(otherwise
@@ -72,32 +87,78 @@
(error "bootstrap : invalid syntax in loop form : ~w." expr)))
(go main)
+ collect
+ (advance expr)
+ (if (endp expr) (error "bootstrap : loop : expected expression after collect but found the end of the loop form."))
+ (if (member expr loop-keywords) (error "bootstrap : loop : loop keyword ~w can't appear here." (car expr)))
+ (push `(if ,acc
+ (setq ,acc-tail (cdr (rplacd ,acc-tail (cons ,(car expr) nil))))
+ (setq ,acc-tail (setq ,acc (cons ,(car expr) nil))))
+ loopbody)
+ (advance expr)
+ (go main)
+ append
+ (advance expr)
+ (if (endp expr) (error "bootstrap : loop : expected expression after append but found the end of the loop form."))
+ (if (member expr loop-keywords) (error "bootstrap : loop : loop keyword ~w can't appear here." (car expr)))
+ (push `(if ,acc
+ (setq ,acc-tail (last (rplacd ,acc-tail (copy-list ,(car expr)))))
+ (setq ,acc-tail (last (setq ,acc (copy-list ,(car expr))))))
+ loopbody)
+ (advance expr)
+ (go main)
+ nconc
+ (error "niy")
+ (go main)
+ sum
+ (error "niy")
+ (go main)
+ count
+ (error "niy")
+ (go main)
+ minimize
+ (error "niy")
+ (go main)
+ maximize
+ (error "niy")
+ (go main)
+
with
(dbg 'with)
- (error "broken for now")
- ;; (advance expr)
- ;; with-loop
- ;; (dbg 'with-loop)
- ;; (setq group-with nil)
- ;; (push 'with stack)
- ;; (setq affect-destr-keywords '(=)) ;; '(= in) pour le for.
- ;; (go destructuring)
- ;; (when (eq 'and (car expr))
- ;; (go with-loop))
- ;; (push variables all-variables)
- ;; (setq variables nil)
- ;; (go prologue)
+ (advance expr)
+ (setq get-vars-and-types-end-keywords '(=))
+ (push 'with-got-vars stack)
+ (go get-vars-and-types)
+ with-got-vars
+ (setq with-initial-values nil)
+ (when (eq '= (car expr))
+ (advance expr)
+ (setq with-initial-values (car expr))
+ (advance expr))
+ with-make-let
+ (dbg 'with-make-let)
+ (setq left-destr vars-names)
+ (setq right-destr with-initial-values)
+ (push 'end-with stack)
+ (go destructuring-let)
+ end-with
+ (push variables all-variables)
+ (push nil all-variables)
+ (setq variables nil)
+ (when (eq 'and (car expr))
+ (go with))
+ (go prologue)
for
(dbg 'for)
- (advance expr)
+ (advance expr) ;; gobble for / and
;; (for vars in values)
;; (for vars on values)
;; (for vars = values [then expr])
;; (for vars across vector) ;; non implémenté
;; being : hash et package non supportés.
;; (for var [from/downfrom/upfrom expr1] [to/downto/upto/below/above expr2] [by expr3])
- (setq storage-sym (make-symbol "storage-for"))
+ (setq storage-sym (make-symbol "STORAGE-FOR"))
(setq get-vars-and-types-end-keywords '(in on = across being from downfrom upfrom to downto upto below above by))
(push 'for-got-vars stack)
(go get-vars-and-types)
@@ -148,11 +209,11 @@
(go for-make-let)
numeric-for
- (setq for-initial-value 0)
- (setq for-getter-fun storage-sym)
- (setq for-step-fun `(+ ,storage-sym 1))
- (setq for-numeric-direction 0)
(setq for-end-predicate t)
+ (setq for-numeric-start 0)
+ (setq for-numeric-step 1)
+ (setq for-numeric-direction 0)
+ (setq for-numeric-end 0)
(when (member (car expr) '(from upfrom downfrom))
(when (eq 'downfrom (car expr)) (setq for-numeric-direction -1))
(when (eq 'upfrom (car expr)) (setq for-numeric-direction 1))
@@ -172,66 +233,87 @@
(setq for-numeric-direction 1))
(advance expr)
(when (endp expr) (error "bootstrap : loop : expected expression after ~w but found the end of the loop form." for-numeric-limit))
+ (setq for-numeric-end (car expr))
(case for-numeric-limit
(to (if (= for-numeric-direction -1)
- (setq for-end-predicate `(< ,storage-sym ,(car expr)))
- (setq for-end-predicate `(> ,storage-sym ,(car expr)))))
- (downto (setq for-end-predicate `(< ,storage-sym ,(car expr))))
- (upto (setq for-end-predicate `(> ,storage-sym ,(car expr))))
- (below (setq for-end-predicate `(>= ,storage-sym ,(car expr))))
- (above (setq for-end-predicate `(<= ,storage-sym ,(car expr)))))
+ (setq for-end-predicate `(< (car ,storage-sym) (third ,storage-sym)))
+ (setq for-end-predicate `(> (car ,storage-sym) (third ,storage-sym)))))
+ (downto (setq for-end-predicate `(< (car ,storage-sym) (third ,storage-sym))))
+ (upto (setq for-end-predicate `(> (car ,storage-sym) (third ,storage-sym))))
+ (below (setq for-end-predicate `(>= (car ,storage-sym) (third ,storage-sym))))
+ (above (setq for-end-predicate `(<= (car ,storage-sym) (third ,storage-sym)))))
(advance expr))
(when (eq 'by (car expr))
(advance expr)
(when (endp expr) (error "bootstrap : loop : expected expression after by but found the end of the loop form."))
- (setq for-step-fun `(+ ,storage-sym ,(* (if (= for-numeric-direction -1) -1 1)
- (car expr))))
+ (setq for-numeric-step (car expr))
(advance expr))
+ (setq for-initial-value `(list ,for-numeric-start ,for-numeric-step ,for-numeric-end))
+ (if (= -1 for-numeric-direction)
+ (setq for-step-fun `(cons (- (car ,storage-sym) (second ,storage-sym)) (cdr ,storage-sym)))
+ (setq for-step-fun `(cons (+ (car ,storage-sym) (second ,storage-sym)) (cdr ,storage-sym))))
+ (setq for-getter-fun `(car ,storage-sym))
(go for-make-let)
vector-for
(error "bootstrap : loop : syntax (loop for var across vector) not implemented yet !")
- (go end-for)
+ (go for-end)
hash-package-for
(error "bootstrap : loop : looping across hashes and packages is not implemented yet !")
- (go end-for)
+ (go for-end)
for-make-let
- (push `(,storage-sym ,for-initial-value) variables)
+ (push `(,storage-sym nil) variables)
(setq left-destr vars-names)
- (push 'for-make-psetq stack)
+ (push 'for-make-initially-psetq stack)
(go destructuring-empty-let)
;; (setq left-destr vars-names)
;; (setq right-destr `(funcall ,for-getter-fun (setq ,storage-sym ,for-initial-value)))
;; (push 'for-make-psetq stack)
;; (go destructuring-let)
- for-make-psetq
+ for-make-initially-psetq
+ (push storage-sym for-initially-psetq)
+ (push for-initial-value for-initially-psetq)
+ (setq left-destr vars-names)
+ (setq right-destr for-getter-fun)
+ (psetq for-initially-affect destr-psetq destr-psetq for-initially-affect) ;; exchange
+ (push 'for-make-body-psetq stack)
+ (go destructuring-psetq)
+ for-make-body-psetq
+ (psetq destr-psetq for-initially-affect for-initially-affect destr-psetq) ;; re-exchange
+ (unless (eq storage-sym for-step-fun)
+ (push `(unless ,first-sym (setq ,storage-sym ,for-step-fun)) loopbody))
(unless (eq t for-end-predicate)
- (push `(when ,for-end-predicate (go finally)) loopbody))
+ (push `(when ,for-end-predicate (go ,finally-sym)) loopbody))
(setq left-destr vars-names)
(setq right-destr for-getter-fun)
- (push 'for-push-psetq stack)
+ (push 'for-end stack)
(go destructuring-psetq)
- for-push-psetq
- (push destr-psetq loopbody)
- (push `(setq ,storage-sym ,for-step-fun) loopbody)
- ;; (go end-for)
- end-for
+ for-end
+ (when (eq 'and (car expr)) (go for))
(push variables all-variables)
+ (push `((setq ,@(reverse for-initially-psetq))
+ (setq ,@(reverse for-initially-affect)))
+ all-variables)
(setq variables nil)
+ (setq for-initially-psetq nil)
+ (setq for-initially-affect nil)
+ (push `(setq ,@(reverse destr-psetq)) loopbody)
+ (setq destr-psetq nil)
(go prologue)
-
+
repeat
(dbg 'repeat)
(advance expr)
- (let ((repeat-sym (make-symbol "repeat-counter")))
- (push `((,repeat-sym ,(car expr))) all-variables)
- (push `(setq ,repeat-sym (- ,repeat-sym 1)) loopbody)
- (push `(when (< ,repeat-sym 0) (go finally)) loopbody))
+ (setq repeat-sym (make-symbol "REPEAT-COUNTER"))
+ (push `((,repeat-sym ,(car expr))) all-variables)
+ (push nil all-variables)
+ (push `(setq ,repeat-sym (- ,repeat-sym 1)) loopbody)
+ (push `(when (< ,repeat-sym 0) (go ,finally-sym)) loopbody)
(advance expr)
(go prologue)
-
+
do
(dbg 'do)
(advance expr)
@@ -312,26 +394,25 @@
;; Cas sans destructuring
(unless (consp left-destr)
- (setq destr-psetq `(setq ,left-destr ,right-destr))
+ (push left-destr destr-psetq)
+ (push right-destr destr-psetq)
(go destr-psetq-end))
- (setq destr-psetq `((car (setq ,destr-whole-sym ,right-destr)) ,(car left-destr) psetq)) ;; in reverse order
+ (push (car left-destr) destr-psetq)
+ (push `(car (setq ,destr-whole-sym ,right-destr)) destr-psetq)
(advance left-destr)
destr-psetq-loop
(dbg 'destr-psetq-loop)
(when (endp left-destr)
- (go destr-psetq-reverse-end))
+ (go destr-psetq-end))
(when (atom left-destr)
(push left-destr destr-psetq)
(push destr-whole-sym destr-psetq)
- (go destr-psetq-reverse-end))
+ (go destr-psetq-end))
(push (car left-destr) destr-psetq)
(push `(car (setq ,destr-whole-sym (cdr ,destr-whole-sym))) destr-psetq)
(advance left-destr)
(go destr-psetq-loop)
- destr-psetq-reverse-end
- (dbg 'destr-psetq-reverse-end)
- (setq destr-psetq (reverse destr-psetq))
destr-psetq-end
(dbg 'destr-psetq-end)
(go return)
@@ -406,57 +487,73 @@
finally-end
(dbg 'finally-end)
(go return)
-
+
return
(dbg 'return)
(when (endp stack) (error "bootstrap : loop : internal error : call stack is empty !"))
- (let ((destination (car stack)))
- (setq stack (cdr stack))
- (case destination
- (prologue (go prologue))
- (with (go with))
- (main (go main))
- (for-got-vars (go for-got-vars))
- (for-make-psetq (go for-make-psetq))
- (for-push-psetq (go for-push-psetq))
- (otherwise (error "bootstrap : loop : internal error : invalid return point on call stack : ~w" destination))))
+ (setq destination (car stack))
+ (setq stack (cdr stack))
+ (case destination
+ (prologue (go prologue))
+ (main (go main))
+ (with-got-vars (go with-got-vars))
+ (end-with (go end-with))
+ (for-got-vars (go for-got-vars))
+ (for-make-initially-psetq (go for-make-initially-psetq))
+ (for-make-body-psetq (go for-make-body-psetq))
+ (for-end (go for-end))
+ (otherwise (error "bootstrap : loop : internal error : invalid return point on call stack : ~w" destination)))
end-parse
(dbg 'end-parse)
make-body
(dbg 'make-body)
+ (setq finally `(progn ,@(reverse (cons `(return-from ,name ,acc) finally))))
+ (setq initialization (reverse initialization))
+ (setq loopbody (reverse loopbody))
(setq result
- `(tagbody
- initialization
- (progn ,@(reverse initialization))
- loopbody
- (progn ,@(reverse loopbody))
- (go loopbody)
- finally
- (progn ,@(reverse finally))
- implicit-return
- (return-from ,name ,acc)))
+ `(macrolet ((my-loop-finish () '(go ,finally-sym)))
+ (tagbody
+ (progn ,@initialization)
+ ,loopbody-sym
+ (progn ,@loopbody)
+ (setq ,first-sym nil)
+ (go ,loopbody-sym)
+ ,finally-sym
+ ,finally)))
build-lets-loop
(dbg 'build-lets-loop)
(when (endp all-variables)
(go build-block-and-let))
- (setq result `(let ,(reverse (car all-variables)) ,result))
+ (setq result `(let ,(reverse (cadr all-variables)) ,@(car all-variables) ,result))
+ (advance all-variables)
(advance all-variables)
(go build-lets-loop)
build-block-and-let
(dbg 'build-block-and-lets)
(setq result
- `(block ,name (let ,top-variables
- ,acc
- ,destr-whole-sym
- ,result)))
+ `(block ,name
+ (let ((,acc nil)
+ (,acc-tail nil)
+ (,destr-whole-sym nil)
+ (,first-sym t))
+ ,acc
+ ,acc-tail
+ ,destr-whole-sym
+ ,first-sym
+ ;; If you call loop-finish during variable declarations, and you use variables that haven't been initialized,
+ ;; then it will fail / use variables from the surrounding environment. But it's you freakin' problem if you do
+ ;; such bizarre things.
+ (macrolet ((my-loop-finish () ',finally))
+ ,result))))
the-end
- (dbg 'the-end)
- ))
+ ;; music
+ rideau))
result))
;; (eval (transform-loop '(for (i j) in '((1 1) (2 4) (3 9)) do (print i))))
;; (eval (transform-loop '(for (i j) in '((1 1) (2 4) (3 9)) for k from 0 to 5 do (format t "~&~a ~a ~a" i j k) initially (print 'i) finally (print 'f) (print i))))
+;; (eval (transform-loop '(for i = 42 and j in (list 1 i 3) for k = i then (cons i j) collect (list i j k))))
#|
(loop (print 5))
