Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
778 lines (717 sloc) 30.6 KB
;; TODO : remplacer les deux my-loop-finish par loop-finish à la fin.
(defun transform-loop (expr)
(let* ((name nil)
(acc (make-symbol "ACC"))
(first-sym (make-symbol "FIRST"))
(variables nil)
(all-variables nil)
(declared-variables nil)
(acc-tail nil)
(acc-tails 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
collect append nconc sum count minimize maximize
while until
always never thereis
do return
doing
if when unless else end
and))
(stack nil)
(conditionnal-stack nil)
(repeat-sym nil)
(destination nil)
(main-value nil)
(clause-type nil)
(thereis-temp (make-symbol "THERIS-TEMP"))
(element-getter-fun 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")))
(macrolet ((advance (x) `(setq ,x (cdr ,x))))
(tagbody
start
(when (eq 'named (car expr))
(if (and (consp (cdr expr)) (symbolp (cadr expr)))
(setq name (cadr expr))
(error "bootstrap : loop : expected a loop name but got ~w" (cadr expr))))
;;(go prologue)
prologue
(when (endp expr) (go end-parse))
(case (car expr)
(with (go with))
(for (go for))
(as (go for))
(repeat (go repeat))
(initially (push 'prologue stack) (go initially))
(finally (push 'prologue stack) (go finally))
(otherwise (go main)))
(go prologue)
main
(when (endp expr) (go end-parse))
(case (car expr)
(initially (push 'main stack) (go initially))
(finally (push 'main stack) (go finally)))
(push 'main stack)
;; (go main-core)
main-core
(case (car expr)
(do (go do))
(return (go loop-return))
((collect collecting append appending nconc nconcing count counting sum summing minimize minimizing maximize maximizing)
(go accumulation))
((while until always never thereis) (go end-test-control))
((if when unless) (go conditionnal))
(otherwise
(when (member (car expr) loop-keywords) (error "bootstrap : loop : loop keyword ~w can't appear here." (car expr)))
(error "bootstrap : invalid syntax in loop form : ~w." expr)))
accumulation
(setq clause-type (car expr))
(advance expr)
(if (endp expr) (error "bootstrap : loop : expected expression after ~w but found the end of the loop form." clause-type))
(setq main-value (car expr))
(advance expr)
(setq vars-names acc)
(unless (eq 'into (car expr)) (go accumulation-got-vars-2))
(advance expr)
(setq get-vars-and-types-end-keywords nil)
(push 'accumulation-got-vars stack)
(go get-vars-and-types)
;; TODO : on ne gère pas le cas "acc-clause expr type-spec" ("type-spec" sans le "into var"). Mais bon c'est tordu.
accumulation-got-vars
(when (listp vars-names) (error "bootstrap : loop : Invalid variable name for accumulation : ~w" vars-names))
accumulation-got-vars-2
(unless (member vars-names declared-variables)
(push `(,vars-names ,(if (member clause-type '(count counting sum summing)) 0 nil)) variables) ;; TODO : push variables all-variables à la fin si non null
(push vars-names declared-variables))
(when (member clause-type '(collect collecting append appending nconc nconcing))
(setq acc-tail (cdr (assoc vars-names acc-tails)))
(unless acc-tail
(setq acc-tail (make-symbol "ACC-TAIL"))
(push `(,acc-tail nil) variables) ;; TODO : push variables all-variables à la fin si non null
(push `(,vars-names . ,acc-tail) acc-tails)))
(case clause-type
((collect collecting) (go collect))
((append appending) (go append))
((nconc nconcing) (go nconc))
((count counting) (go count))
((sum summing) (go sum))
((minimize minimizing) (go minimize))
((maximize maximizing) (go maximize)))
collect
(setq element-getter-fun `(cons ,main-value nil))
(go accumulate-list)
append
(setq element-getter-fun `(copy-list ,main-value))
(go accumulate-list)
nconc
(setq element-getter-fun main-value)
;; (go accumulate-list)
accumulate-list
(push `(if ,vars-names
(setq ,acc-tail (rplacd (last ,acc-tail) ,element-getter-fun))
(setq ,acc-tail (setq ,vars-names ,element-getter-fun)))
loopbody)
(go return)
sum
(push `(setq ,vars-names (+ ,vars-names 1)) loopbody)
(go return)
count
(push `(when ,main-value (setq ,vars-names (+ ,vars-names 1))) loopbody)
(go return)
minimize
(setq element-getter-fun 'min) ;; Not an element-getter-fun really but I'm reclutant to add Yet Another Variable.
(go min-max)
maximize
(setq element-getter-fun 'min)
;; (go min-max)
min-max
(push `(if ,vars-names
(setq ,vars-names (,element-getter-fun ,vars-names ,main-value))
(setq ,vars-names ,main-value))
loopbody)
(go return)
end-test-control
(setq clause-type (car expr))
(advance expr)
(if (endp expr) (error "bootstrap : loop : expected expression after ~w but found the end of the loop form." clause-type))
(setq main-value (car expr))
(advance expr)
(case clause-type
(while (push `(unless ,main-value (go ,finally-sym)) loopbody))
(until (push `(when ,main-value (go ,finally-sym)) loopbody))
(always (push `(unless ,main-value (return-from ,name nil)) loopbody)
(unless (member acc declared-variables)
(push `(,acc t) variables)
(push acc declared-variables)))
(never (push `(when ,main-value (return-from ,name nil)) loopbody)
(unless (member acc declared-variables)
(push `(,acc t) variables)
(push acc declared-variables)))
(thereis (push `(let ((,thereis-temp ,main-value)) (when ,thereis-temp (return-from ,name ,thereis-temp))) loopbody)))
(go return)
with
(advance expr)
(setq get-vars-and-types-end-keywords '(=))
(push 'with-got-vars stack)
(go get-vars-and-types)
with-got-vars
(setq main-value nil)
(when (eq '= (car expr))
(advance expr)
(setq main-value (car expr))
(advance expr))
with-make-let
(setq left-destr vars-names)
(setq right-destr main-value)
(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
(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 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)
for-got-vars
(unless (member (car expr) '(in on = across being)) (go numeric-for))
(setq clause-type (car expr))
for-get-initial
(advance expr)
(when (endp expr) (error "bootstrap : loop : expected expression but found the end of the loop form."))
(setq main-value (car expr))
(advance expr)
for-select-clause-handler
(case clause-type
(in (go in-for))
(on (go on-for))
(= (go affect-then-for))
(across (go vector-for))
(being (go hash-package-for)))
(error "bootstrap : loop : serious failure while parsing the for clause handler.")
in-for
(setq element-getter-fun `(car ,storage-sym))
(go in-on-for)
on-for
(setq element-getter-fun storage-sym)
(go in-on-for)
in-on-for
(setq for-step-fun `(cdr ,storage-sym))
(setq for-end-predicate `(endp ,storage-sym))
(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 `(funcall ,(car expr) ,storage-sym))
(advance expr))
(go for-make-let)
affect-then-for
(setq element-getter-fun storage-sym)
(setq for-step-fun storage-sym)
(setq for-end-predicate t)
(when (eq 'then (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 (car expr))
(advance expr))
(go for-make-let)
numeric-for
(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))
(advance expr)
(when (endp expr) (error "bootstrap : loop : expected expression after from but found the end of the loop form."))
(setq main-value (car expr))
(advance expr))
(when (member (car expr) '(to downto upto below above))
(setq for-numeric-limit (car expr))
(when (member (car expr) '(downto above))
(unless (= for-numeric-direction 0)
(error "bootstrap : loop : do you want to go up or down ? This is not a caroussel."))
(setq for-numeric-direction -1))
(when (member (car expr) '(upto below))
(unless (= for-numeric-direction 0)
(error "bootstrap : loop : do you want to go up or down ? This is not a caroussel."))
(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 `(< (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-numeric-step (car expr))
(advance expr))
(setq main-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 element-getter-fun `(car ,storage-sym))
(go for-make-let)
vector-for
(error "bootstrap : loop : syntax (loop for var across vector) not implemented yet !")
(go for-end)
hash-package-for
(error "bootstrap : loop : looping across hashes and packages is not implemented yet !")
(go for-end)
for-make-let
(push `(,storage-sym nil) variables)
(setq left-destr vars-names)
(push 'for-make-initially-psetq stack)
(go destructuring-empty-let)
;; (setq left-destr vars-names)
;; (setq right-destr `(funcall ,element-getter-fun (setq ,storage-sym ,main-value)))
;; (push 'for-make-psetq stack)
;; (go destructuring-let)
for-make-initially-psetq
(push storage-sym for-initially-psetq)
(push main-value for-initially-psetq)
(setq left-destr vars-names)
(setq right-destr element-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-sym)) loopbody))
(setq left-destr vars-names)
(setq right-destr element-getter-fun)
(push 'for-end stack)
(go destructuring-psetq)
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
(advance expr)
(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
(advance expr)
(when (endp expr) (error "bootstrap : loop : expected an expression after DO, but encountered the end of the loop form."))
(when (member (car expr) loop-keywords) (error "bootstrap : loop : keyword ~w can't appear here, expected expression for DO." (car expr)))
(push (car expr) loopbody)
(advance expr)
do-loop
(when (endp expr) (go do-end))
(when (member (car expr) loop-keywords) (go do-end))
(push (car expr) loopbody)
(advance expr)
(go do-loop)
do-end
(go return)
loop-return
(advance expr)
(when (endp expr) (error "bootstrap : loop : expected an expression after RETURN, but encountered the end of the loop form."))
(push `(return-from ,name ,(car expr)) loopbody)
(advance expr)
(go return)
conditionnal
;; backup loopbody
(push loopbody conditionnal-stack)
(setq loopbody nil)
(setq clause-type (car expr))
(advance expr)
(when (endp expr) (error "bootstrap : loop : expected an expression after ~w, but encountered the end of the loop form." clause-type))
(if (eq 'unless clause-type)
(push `(not ,(car expr)) conditionnal-stack)
(push (car expr) conditionnal-stack))
(advance expr)
;; get conditionnal clause
(push 'conditionnal-after-if-clause stack)
(go get-conditionnal-clause)
conditionnal-after-if-clause
;; backup if-clause
(push loopbody conditionnal-stack)
(setq loopbody nil)
(when (eq 'end (car expr))
(go conditionnal-after-else-clause))
(unless (eq 'else (car expr))
(go conditionnal-after-else-clause))
(advance expr)
;; get conditionnal clause
(push 'conditionnal-after-else-clause stack)
(go get-conditionnal-clause)
conditionnal-after-else-clause
(if (eq 'end (car expr)) (advance expr))
(push loopbody conditionnal-stack)
(setq loopbody (cadddr conditionnal-stack))
;; conditionnal-stack contains (else-clause if-clause condition old-body ...)
(push `(if ,(caddr conditionnal-stack) (progn ,@(reverse (cadr conditionnal-stack))) (progn ,@(reverse (car conditionnal-stack)))) loopbody)
(setq conditionnal-stack (cddddr conditionnal-stack)) ;; pop !
(go return)
get-conditionnal-clause
(when (endp expr) (error "Expected conditionnal if-clause or else-clause, but found the end of the loop form."))
(push 'get-conditionnal-clause-loop stack)
(go main-core)
get-conditionnal-clause-loop
(unless (eq 'and (car expr)) (go return))
(advance expr)
(push 'get-conditionnal-clause-loop stack)
(go main-core)
get-vars-and-types
;; params : get-vars-and-types-end-keywords
;; returns : vars-names, real-vars-names
;; a [= 1] [and ...]
;; a type [= 1] [and ...]
;; a of-type type [= 1] [and ...]
;; (a b c) [= <list>] [and ...]
;; (a b c) (t1 t2 t3) [= <list>] [and ...]
;; (a b c) of-type (t1 t2 t3) [= <list>] [and ...]
;; (a b c) type [= <list>] [and ...]
;; (a b c) of-type type [= <list>] [and ...]
(setq vars-names (car expr))
(advance expr)
(when (eq 'of-type (car expr))
(advance expr)
(when (endp expr) (error "Expected type after OF-TYPE, but found the end of the loop form."))
(advance expr)
(go get-vars-and-types-end))
(unless (or (member (car expr) get-vars-and-types-end-keywords)
(member (car expr) loop-keywords))
(advance expr))
get-vars-and-types-end
(go return)
destructuring-let
;; params : left-destr right-destr
;; return : nothing
;; mutate : variables
;; modify : left-destr
;; Cas sans destructuring
(unless (consp left-destr)
(push `(,left-destr ,right-destr) variables)
(push left-destr declared-variables)
(go destr-let-end))
(push `(,(car left-destr) (car (setq ,destr-whole-sym ,right-destr))) variables)
(push (car left-destr) declared-variables)
(advance left-destr)
destr-let-loop
(when (endp left-destr)
(go destr-let-end))
(when (atom left-destr)
(push `(,left-destr ,destr-whole-sym) variables)
(push left-destr declared-variables)
(go destr-let-end))
(push `(,(car left-destr) (car (setq ,destr-whole-sym (cdr ,destr-whole-sym)))) variables)
(push (car left-destr) declared-variables)
(advance left-destr)
(go destr-let-loop)
destr-let-end
(go return)
destructuring-psetq
;; params : left-destr right-destr
;; return : nothing
;; mutate : destr-psetq
;; modify : left-destr
;; Cas sans destructuring
(unless (consp left-destr)
(push left-destr destr-psetq)
(push right-destr destr-psetq)
(go destr-psetq-end))
(push (car left-destr) destr-psetq)
(push `(car (setq ,destr-whole-sym ,right-destr)) destr-psetq)
(advance left-destr)
destr-psetq-loop
(when (endp left-destr)
(go destr-psetq-end))
(when (atom left-destr)
(push left-destr destr-psetq)
(push destr-whole-sym destr-psetq)
(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-end
(go return)
destructuring-empty-let
;; params : left-destr
;; return : nothing
;; mutate : variables
;; modify : left-destr
;; Cas sans destructuring
(unless (consp left-destr)
(push `(,left-destr nil) variables)
(push left-destr declared-variables)
(go destr-empty-let-end))
(push `(,(car left-destr) nil) variables)
(push (car left-destr) declared-variables)
(advance left-destr)
destr-empty-let-loop
(when (endp left-destr)
(go destr-empty-let-end))
(when (atom left-destr)
(push `(,left-destr nil) variables)
(push left-destr declared-variables)
(go destr-empty-let-end))
(push `(,(car left-destr) nil) variables)
(push (car left-destr) declared-variables)
(advance left-destr)
(go destr-empty-let-loop)
destr-empty-let-end
(go return)
initially
(advance expr)
(when (endp expr) (error "bootstrap : loop : expected an expression after INITIALLY, but encountered the end of the loop form."))
(when (member (car expr) loop-keywords) (error "bootstrap : loop : keyword ~w can't appear here, expected expression for INITIALLY." (car expr)))
(push (car expr) initialization)
(advance expr)
initially-step
(when (endp expr) (go initially-end))
(when (member (car expr) loop-keywords) (go initially-end))
(push (car expr) initialization)
(advance expr)
(go initially-step)
initially-end
(go return)
finally
(advance expr)
(when (eq 'return (car expr))
(advance expr)
(when (endp expr) (error "bootstrap : loop : expected an expression after FINALLY RETURN, but encountered the end of the loop form."))
(push `(return-from ,name ,(car expr)) finally)
(advance expr)
(go finally-end))
(when (member (car expr) '(do doing))
(advance expr))
(when (endp expr) (error "bootstrap : loop : expected an expression after FINALLY, but encountered the end of the loop form."))
(when (member (car expr) loop-keywords) (error "bootstrap : loop : keyword ~w can't appear here, expected expression for FINALLY." (car expr)))
(push (car expr) finally)
(advance expr)
;; (go finally-step)
finally-step
(when (endp expr) (go finally-end))
(when (member (car expr) loop-keywords) (go finally-end))
(push (car expr) finally)
(advance expr)
(go finally-step)
finally-end
(go return)
return
(when (endp stack) (error "bootstrap : loop : internal error : call stack is empty !"))
(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))
(accumulation-got-vars (go accumulation-got-vars))
(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))
(conditionnal-after-if-clause (go conditionnal-after-if-clause))
(conditionnal-after-else-clause (go conditionnal-after-else-clause))
(get-conditionnal-clause-loop (go get-conditionnal-clause-loop))
(otherwise (error "bootstrap : loop : internal error : invalid return point on call stack : ~w" destination)))
end-parse
(when variables
(push variables all-variables)
(push nil all-variables))
make-body
(setq finally `(progn
,@(reverse (cons `(return-from ,name
,(if (member acc declared-variables) acc nil))
finally))))
(setq initialization (reverse initialization))
(setq loopbody (reverse loopbody))
(setq result
`(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
(when (endp all-variables)
(go build-block-and-let))
(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
(setq result
`(block ,name
(let ((,destr-whole-sym nil)
(,first-sym t))
,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
;; music
rideau))
result))
#|
(eval (transform-loop '(for (i j) in '((1 1) (2 4) (3 9)) do (print i))))
=> 1
=> 2
=> 3
=> nil
(eval (transform-loop '(for (i j) in '((1 1) (2 4) (3 9)) do (print i) collect i into k append '(a a) into k finally return k)))
=> 1
=> 2
=> 3
=> '(1 a a 2 a a 3 a a)
(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 'init) (print i) finally (print 'fin) (print i))))
=> INIT
=> 1
=> 1 1 0
=> 2 4 1
=> 3 9 2
=> FIN
=> 3
=> NIL
(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))))
=> ((42 1 42) (42 NIL (42)) (42 3 (42 . 3)))
(eval (transform-loop '(for i from 1 to 10 if (evenp i) collect i else collect 'odd)))
=> (0 ODD 2 ODD 4 ODD 6 ODD 8 ODD 10)
(eval (transform-loop '(for i from 1 to 10 if (evenp i) collect i and if (evenp (/ i 2)) collect 'four and append '(four) end else collect 'odd)))
=> (0 FOUR FOUR ODD 2 ODD 4 FOUR FOUR ODD 6 ODD 8 FOUR FOUR ODD 10)
(eval (transform-loop '(for i from 1 to 10 unless (evenp i) collect i and if (> i 5) collect 'big and append '(something big) end else collect 'even)))
=> (EVEN 1 EVEN 3 EVEN 5 EVEN 7 BIG SOMETHING BIG EVEN 9 BIG SOMETHING BIG EVEN)
(eval (transform-loop '(for i from 1 to 10 thereis (and (> i 5) i))))
=> 6
(eval (transform-loop '(for i from 1 to 10 always (< i 11))))
=> T
(eval (transform-loop '(for i from 1 to 10 always (< i 3))))
=> nil
(eval (transform-loop '(for i from 1 to 10 never (< i 0))))
=> T
(eval (transform-loop '(for i from 1 to 10 never (> i 5))))
=> nil
|#
#|
(loop (print 5))
=> boucle infinie
expansion : let, block et tagbody
(loop …)
expands into :
<prologue>
<body>
<epilogue>
expands into :
(block nil …)
pour qu'on puisse faire (return …) et (return-from nil …)
(loop named X …)
=> (block X …)
do _*
initially _*
finally _*
Les autres ont une taille "fixe".
Attention, do peut être suivi de plusieurs tags et expressions. les tags sont comme ceux d'un tagbody, mais ne peuvent pas être des mots-clés de loop.
toutes les variables sont initialisées au début, même si elles sont déclarées au milieu
=> (block nil (let (vars) ...))
tous les initially sont rassemblés au début dans un progn, et tous les finally à la fin, avant le return implicite
=> (block nil
(let (vars)
(tagbody
initialisation
(progn initially1 i2 i3 ...)
loopbody
(...)
(go loopbody)
finally
(progn finally1 f2 f3 ...)
implicit-return
(<implicit-return>))))
les "with …" créent des bindings chacun dans un let, leurs valeurs sont calculées dans l'ordre d'aparition des with.
(loop with a = b and c = d with e = f ...)
=> (let ((a b)
(c d))
(let ((e f))
...))
ou
=> (let* ((#:|a| b)
(#:|c| d)
(a #:|a|)
(c #:|c|)
(#:|e| f)
(e #:|e|))
...)
"for …" ou "as …"
=> initialisation : set des valeurs initiales
=> loopbody : si on est à la fin de ce for, si oui, (go finally)
=> si non, on exécute l'itération de ce for, et on stocke la valeur.
for x
=> for x = 0 then (+ x 1)
for x [up|down]from 5
=> for x = 0 then (+- x 1)
for x [up|down]from 5 [up|down]to/below/above 15 [by <step>]
=> itération + test
"repeat <n>"
=> initialisation d'une variable interne
=> test si on est à la fin de ce repeat, si oui, (go finally)
=> sinon, on incrémente cette variable interne.
"collect <expr> [into acc]"
(setf last-acc (setf (cdr last-acc) <expr>))
si acc est absent, on accumule sur l'accumulateur par défaut.
nconc, sum, count, minimize, maximize : voir la doc
|#
Jump to Line
Something went wrong with that request. Please try again.