From d17bbb8990764d8254c9ec0c6e24ce47844b52be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sun, 21 Nov 2010 04:07:40 +0100 Subject: [PATCH] =?UTF-8?q?Impl=C3=A9mentation=20de=20loop=20(ne=20g=C3=A8?= =?UTF-8?q?re=20que=20les=20for,=20with(cass=C3=A9)=20et=20do).?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- implementation/loop.lisp | 543 +++++++++++++++++++++++++++++++++ implementation/mini-meval.lisp | 1 + 2 files changed, 544 insertions(+) create mode 100644 implementation/loop.lisp diff --git a/implementation/loop.lisp b/implementation/loop.lisp new file mode 100644 index 0000000..12b6036 --- /dev/null +++ b/implementation/loop.lisp @@ -0,0 +1,543 @@ +(defmacro dbg (x) `(print ,x)) +(defmacro dbg (x) nil) + +(defun transform-loop (expr) + (let* ((name nil) + (acc (make-symbol "acc")) + (variables nil) + (all-variables nil) + (result nil) + (initialization nil) + (loopbody nil) + (finally nil) + (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) + ; (group-with 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-limit 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)))) + (macrolet ((advance (x) `(setq ,x (cdr ,x)))) + (tagbody + start + (dbg '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 + (dbg 'prologue) + (dbg expr) + (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 + (dbg 'main) + (when (endp expr) (go end-parse)) + (case (car expr) + (do (go do)) + (initially (push 'prologue stack) (go initially)) + (finally (push 'prologue stack) (go finally)) + (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))) + (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) + + for + (dbg 'for) + (advance expr) + ;; (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 for-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 for-initial-value (car expr)) + (advance expr) + for-select-clause-handler + (case for-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 for-getter-fun `(car ,storage-sym)) + (go in-on-for) + + on-for + (setq for-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 for-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-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) + (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 for-initial-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)) + (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))))) + (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)))) + (advance expr)) + (go for-make-let) + + vector-for + (error "bootstrap : loop : syntax (loop for var across vector) not implemented yet !") + (go end-for) + + hash-package-for + (error "bootstrap : loop : looping across hashes and packages is not implemented yet !") + (go end-for) + + for-make-let + (push `(,storage-sym ,for-initial-value) variables) + (setq left-destr vars-names) + (push 'for-make-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 + (unless (eq t for-end-predicate) + (push `(when ,for-end-predicate (go finally)) loopbody)) + (setq left-destr vars-names) + (setq right-destr for-getter-fun) + (push 'for-push-psetq stack) + (go destructuring-psetq) + for-push-psetq + (push destr-psetq loopbody) + (push `(setq ,storage-sym ,for-step-fun) loopbody) + ;; (go end-for) + end-for + (push variables all-variables) + (setq variables 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)) + (advance expr) + (go prologue) + + do + (dbg 'do) + (advance expr) + (when (endp expr) (error "bootstrap : loop : expected an expression for 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 + (dbg '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 main) + + + get-vars-and-types + ;; params : get-vars-and-types-end-keywords + ;; returns : vars-names, real-vars-names + (dbg 'get-vars-and-types) + ;; a [= 1] [and ...] + ;; a type [= 1] [and ...] + ;; a of-type type [= 1] [and ...] + ;; (a b c) [= ] [and ...] + ;; (a b c) (t1 t2 t3) [= ] [and ...] + ;; (a b c) of-type (t1 t2 t3) [= ] [and ...] + ;; (a b c) type [= ] [and ...] + ;; (a b c) of-type type [= ] [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 + (dbg 'destructuring-let) + + ;; Cas sans destructuring + (unless (consp left-destr) + (push `(,left-destr ,right-destr) variables) + (go destr-let-end)) + + (push `(,(car left-destr) (car (setq ,destr-whole-sym ,right-destr))) variables) + (advance left-destr) + destr-let-loop + (dbg 'destr-let-loop) + (when (endp left-destr) + (go destr-let-end)) + (when (atom left-destr) + (push `(,left-destr ,destr-whole-sym) variables) + (go destr-let-end)) + (push `(,(car left-destr) (car (setq ,destr-whole-sym (cdr ,destr-whole-sym)))) variables) + (advance left-destr) + (go destr-let-loop) + destr-let-end + (dbg 'destr-let-end) + (go return) + + destructuring-psetq + ;; params : left-destr right-destr + ;; return : nothing + ;; mutate : destr-psetq + ;; modify : left-destr + (dbg 'destructuring-psetq) + + ;; Cas sans destructuring + (unless (consp left-destr) + (setq destr-psetq `(setq ,left-destr ,right-destr)) + (go destr-psetq-end)) + + (setq destr-psetq `((car (setq ,destr-whole-sym ,right-destr)) ,(car left-destr) psetq)) ;; in reverse order + (advance left-destr) + destr-psetq-loop + (dbg 'destr-psetq-loop) + (when (endp left-destr) + (go destr-psetq-reverse-end)) + (when (atom left-destr) + (push left-destr destr-psetq) + (push destr-whole-sym destr-psetq) + (go destr-psetq-reverse-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) + + destructuring-empty-let + ;; params : left-destr + ;; return : nothing + ;; mutate : variables + ;; modify : left-destr + (dbg 'destructuring-empty-let) + + ;; Cas sans destructuring + (unless (consp left-destr) + (push `(,left-destr nil) variables) + (go destr-empty-let-end)) + + (push `(,(car left-destr) nil) 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) + (go destr-empty-let-end)) + (push `(,(car left-destr) nil) variables) + (advance left-destr) + (go destr-empty-let-loop) + destr-empty-let-end + (dbg 'destr-empty-let-end) + (go return) + + initially + (dbg 'initially) + (advance expr) + (when (endp expr) (error "bootstrap : loop : expected an expression for 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 + (dbg '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 + (dbg 'initially-end) + (go return) + + finally + (dbg 'finally) + (advance expr) + (when (eq 'return (car expr)) + (push `(return-from ,name ,(cadr expr)) finally) + (advance expr) + (advance expr) + (go finally-end)) + (when (member (car expr) '(do doing)) + (advance expr)) + (when (endp expr) (error "bootstrap : loop : expected an expression for 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 + (dbg '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 + (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)))) + + end-parse + (dbg 'end-parse) + make-body + (dbg 'make-body) + (setq result + `(tagbody + initialization + (progn ,@(reverse initialization)) + loopbody + (progn ,@(reverse loopbody)) + (go loopbody) + finally + (progn ,@(reverse finally)) + implicit-return + (return-from ,name ,acc))) + build-lets-loop + (dbg 'build-lets-loop) + (when (endp all-variables) + (go build-block-and-let)) + (setq result `(let ,(reverse (car all-variables)) ,result)) + (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))) + the-end + (dbg 'the-end) + )) + 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)))) + +#| +(loop (print 5)) +=> boucle infinie + +expansion : let, block et tagbody + +(loop …) +expands into : + + + + +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 + ()))) + +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 ] +=> itération + test + +"repeat " +=> 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 [into acc]" +(setf last-acc (setf (cdr last-acc) )) +si acc est absent, on accumule sur l'accumulateur par défaut. + +nconc, sum, count, minimize, maximize : voir la doc + +|# \ No newline at end of file diff --git a/implementation/mini-meval.lisp b/implementation/mini-meval.lisp index 3f90ab9..054e8bf 100644 --- a/implementation/mini-meval.lisp +++ b/implementation/mini-meval.lisp @@ -272,6 +272,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau (if definition (cdr definition) (mini-meval-error expr etat-global etat-local "mini-meval : undefined function : ~w." name)))) + ;; TODO : #'(lambda ...) ((funcall :name _ :params _*) (apply (mini-meval name etat-global etat-local) (mapcar (lambda (x) (mini-meval x etat-global etat-local)) params)))