From 3bb7a28fb62f15cd3ea4e1e20fb38f9cd96f0255 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Mon, 15 Nov 2010 04:29:45 +0100 Subject: [PATCH] =?UTF-8?q?Encore=20quelques=20tests=20sur=20mini-meval=20?= =?UTF-8?q?:=20il=20passe=20avec=20succ=C3=A8s=20les=20let,=20let*,=20defu?= =?UTF-8?q?n,=20defvar,=20defmacro,=20macrolet=20!?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- implementation/mini-meval.lisp | 172 ++++++++++++++++++++++++--------- util.lisp | 10 +- 2 files changed, 131 insertions(+), 51 deletions(-) diff --git a/implementation/mini-meval.lisp b/implementation/mini-meval.lisp index d2ef194..29dbe10 100644 --- a/implementation/mini-meval.lisp +++ b/implementation/mini-meval.lisp @@ -51,20 +51,20 @@ (if fixed (if (endp params) (error "mini-meval-params : not enough parameters !") - (mini-meval-params (cdr params) global (acons (car fixed) (car params) local) (cdr fixed) optional rest key other aux)) + (mini-meval-params (cdr params) global (acons `(,(car fixed) . variable) (car params) local) (cdr fixed) optional rest key other aux)) (if optional (let* ((var (caar optional)) (value (if (endp params) (mini-meval (cadar optional) global local) (car params))) (svar (caddar optional)) - (new-local (acons var value local)) + (new-local (acons `(,var . variable) value local)) (new-local-2 (if svar - (acons svar (endp params) new-local) + (acons `(,svar . variable) (endp params) new-local) new-local))) (mini-meval-params (cdr params) global new-local-2 nil (cdr optional) rest key other aux)) (if rest - (mini-meval-params params global (acons (car rest) params local) nil nil nil key other aux) + (mini-meval-params params global (acons `(,(car rest) . variable) params local) nil nil nil key other aux) ;; TODO : finir d'implémenter &key &allow-other-keys &aux (et relire CLTL). local)))) ; (if key @@ -76,24 +76,24 @@ ; maybe-val ; (error "mini-meval-params : Nombre de paramètres impair alors qu'il y a &key.")))) ; (svar (fourth (car key))) -; (new-local (acons var (if maybe-val-2 +; (new-local (acons `(,var . variable) (if maybe-val-2 ; (cadr maybe-val-2) ; (mini-meval (third (car key)) global local)) ; local)) ; (new-local-2 (if svar -; (acons svar (not (not (maybe-val-2))) new-local) +; (acons `(,svar . variable) (not (not (maybe-val-2))) new-local) ; new-local))) -; (mini-meval-params params global new-local-2 nil nil nil (cdr key) aux) +; (mini-meval-params params global new-local-2 nil nil nil (cdr key) other aux) (defun mini-meval-get-params-from-real (etat-global etat-local lambda-list effective-parameters) "Lambda-list doit être déjà sliced." - (apply #'mini-meval-params effective-parameters etat-global etat-local - (cdr (assoc 'fixed lambda-list)) - (cdr (assoc 'optional lambda-list)) - (cdr (assoc 'rest lambda-list)) - (cdr (assoc 'key lambda-list)) - (cdr (assoc 'other lambda-list)) - (cdr (assoc 'aux lambda-list)))) + (funcall #'mini-meval-params effective-parameters etat-global etat-local + (cdr (assoc 'fixed lambda-list)) + (cdr (assoc 'optional lambda-list)) + (cdr (assoc 'rest lambda-list)) + (cdr (assoc 'key lambda-list)) + (cdr (assoc 'other lambda-list)) + (cdr (assoc 'aux lambda-list)))) #| Mini-meval est un meval très simple destiné à évaluer les macros et les autres directives avec eval-when :compile-toplevel. @@ -101,7 +101,7 @@ Mini-meval est un meval très simple destiné à évaluer les macros et les autr ;; Fonctionnement de mini-meval Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il faut donc qu'il puisse maintenir son état entre les appels. |# -(defun mini-meval (expr &optional etat-global etat-local) +(defun mini-meval (expr &optional (etat-global (cons nil nil)) etat-local) #| L'algorithme d'évaluation est très simple et suit le schéma donné dans CLTL 5.1.3 : 1) Si l'expression est une forme spéciale, on la traite de manière particulière @@ -113,12 +113,14 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau (cond-match expr + ((debug :id _?) + (format t "~&debug :~& id = ~w~& global = ~w~& local = ~w" id etat-global etat-local)) #| 2) Cas des macros |# - ((:name $ :params _*) - (let ((definition (assoc* `(,name macro) #'equal etat-local etat-global))) + ((:name $$ :params _*) + (let ((definition (assoc* `(,name . macro) #'equal etat-local (cdr etat-global)))) (if definition #| - Si on a une fonction de ce nom dans l'état-local ou dans l'etat-global, on l'exécute. |# - (apply (cdr definition) (mapcar (lambda (x) (mini-meval x etat-global etat-local)) params)) + (mini-meval (apply (cdr definition) params) etat-global etat-local) (else)))) #| 1) Cas des formes spéciales |# ((eval-when :situations ($*) :body _*) @@ -129,46 +131,46 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau (mini-meval `(progn ,body) etat-global (reduce* etat-local (lambda (new-etat-local name lambda-list fbody) - (acons (cons name 'function) + (acons `(,name . function) (mini-meval `(lamdba ,lambda-list ,@fbody) etat-global etat-local) new-etat-local)) name lambda-list fbody))) ((labels ((:name $ :lambda-list @ :fbody _*)*) :body _*) - (let* ((new-bindings (reduce* nil (lambda (new-bindings name) `(((,name . 'function) . nil) . ,new-bindings)) + (let* ((new-bindings (reduce* nil (lambda (new-bindings name) `(((,name . function) . nil) . ,new-bindings)) name)) (new-etat-local (append new-bindings etat-local))) (mapcar (lambda (name lambda-list fbody) ;; On fait un assoc / setf dans new-bindings, qui ne contient que les fonctions qu'on vient juste d'ajouter, pour éviter ;; le risque inexistant de faire une mutation dans etat-local. ;; TODO : vérifier que ça marche. - (assoc-set `(,name 'function) + (assoc-set `(,name . function) (mini-meval `(lambda ,lambda-list ,@fbody) new-etat-local) new-bindings #'equal)) name lambda-list fbody) - (mini-meval `(progn ,body) etat-global new-etat-local))) + (mini-meval `(progn ,@body) etat-global new-etat-local))) ((let ((:name $ :value _)*) :body _*) - (mini-meval `(progn ,body) + (mini-meval `(progn ,@body) etat-global (reduce* etat-local (lambda (new-etat-local name value) - (acons (cons name 'variable) + (acons `(,name . variable) (mini-meval value etat-global etat-local) new-etat-local)) name value))) - ((let* ((:name $ :value _)*) :body _*) - (mini-meval `(progn ,body) + (((? (eq x 'let*)) ((:name $ :value _)*) :body _*) + (mini-meval `(progn ,@body) etat-global (reduce* etat-local (lambda (new-etat-local name value) - (acons (cons name 'variable) + (acons `(,name . variable) ;; Comme let sauf new-etat-local au lieu de etat-local ici. (mini-meval value etat-global new-etat-local) new-etat-local)) name value))) ((macrolet ((:name $ :lambda-list @ :mbody _*)*) :body _*) - (mini-meval `(progn ,body) + (mini-meval `(progn ,@body) etat-global (reduce* etat-local (lambda (new-etat-local name lambda-list mbody) - (acons (cons name 'macro) + (acons `(,name . macro) ;; comme le flet sauf nil au lieu de new-etat-local ;; CLTL 7.5 : ;; The precise rule is that the macro-expansion functions defined @@ -179,7 +181,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau new-etat-local)) name lambda-list mbody))) ((progn :body _*) - (cdr (last (mapcar (lambda (expr) (mini-meval expr etat-global etat-local)) + (car (last (mapcar (lambda (expr) (mini-meval expr etat-global etat-local)) body)))) ((if :condition _ :si-vrai _ :si-faux _?) (if (mini-meval condition etat-global etat-local) @@ -190,49 +192,133 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau ((lambda :lambda-list @ :body _*) (let ((sliced-lambda-list (slice-up-lambda-list lambda-list))) (lambda (&rest effective-parameters) - (mini-meval body + (mini-meval `(progn ,@body) etat-global (mini-meval-get-params-from-real etat-global etat-local sliced-lambda-list effective-parameters))))) ((defun :name $ :lambda-list @ :body _*) - (assoc-set `(,name 'function) + (assoc-set `(,name . function) (mini-meval `(lambda ,lambda-list ,@body) etat-global etat-local) - etat-global + (cdr etat-global) #'equal) name) ((defmacro :name $ :lambda-list @ :body _*) - (assoc-set `(,name 'macro) + (assoc-set `(,name . macro) (mini-meval `(lambda ,lambda-list ,@body) etat-global etat-local) - etat-global + (cdr etat-global) #'equal) name) ((defvar :name $ :value _) - (assoc-set `(,name 'variable) + (assoc-set `(,name . variable) (mini-meval value etat-global etat-local) - etat-global + (cdr etat-global) #'equal) name) ((setf/setq) ) + ((quote :val _) + val) #| Traitement des appels de fonction |# ((:lambda (lambda @ _*) :params _*) #| - Si c'est une fonction anonyme, on l'exécute. |# (apply (mini-meval lambda etat-global etat-local) params)) ((:name $ :params _*) - (let ((definition (assoc* `(,name function) #'equal etat-local etat-global))) + (let ((definition (assoc* `(,name . function) #'equal etat-local (cdr etat-global)))) (if definition #| - Si on a une fonction de ce nom dans l'état-local ou dans l'etat-global, on l'exécute. |# (apply (cdr definition) (mapcar (lambda (x) (mini-meval x etat-global etat-local)) params)) - (error "mini-meval : undefined function : ~w" name)))) + (error "mini-meval : undefined function : ~w.~&etat-global = ~w~&etat-local = ~w" name etat-global etat-local)))) ((:name . $$) - (let ((definition (assoc* `(,name variable) #'equal etat-local etat-global))) + (let ((definition (assoc* `(,name . variable) #'equal etat-local (cdr etat-global)))) (if definition (cdr definition) - (error "mini-meval : undefined variable : ~w" name)))) + (error "mini-meval : undefined variable : ~w.~&etat-global = ~w~&etat-local = ~w" name etat-global etat-local)))) ((:num . (? numberp)) num) ((:str . (? stringp)) str) - ((quote :val _) - val) (() nil))) + +(load "test-unitaire") +(erase-tests mini-meval) + +(deftestvar mini-meval e-global `(nil ((list . function) . ,#'list) ((+ . function) . ,#'+))) + +(deftest (mini-meval constante) + (mini-meval 42 e-global nil) + 42) + +(deftest (mini-meval appel-fonction) + (mini-meval '(+ 2 3) e-global nil) + 5) + +(deftest (mini-meval appel-fonction) + (mini-meval '(+ 2 (+ 3 4)) e-global nil) + 9) + +(deftest (mini-meval variable) + (mini-meval 'x e-global (acons '(x . variable) 42 nil)) + 42) + +(deftest (mini-meval appel-fonction-et-variable) + (mini-meval '(+ x x 3) e-global (acons '(x . variable) 42 nil)) + 87) + +(deftest (mini-meval appel-fonction-et-variable) + (mini-meval '(+ x (+ 3 x)) e-global (acons '(x . variable) 42 nil)) + 87) + +(deftest (mini-meval lambda extérieur) + (funcall (mini-meval '(lambda (x) x) e-global nil) 3) + 3) + +(deftest (mini-meval lambda extérieur) + (funcall (mini-meval '(lambda (x) (+ x 3)) e-global nil) 4) + 7) + +(deftest (mini-meval lambda immédiat) + (mini-meval '((lambda (x) (+ x 3)) 4) e-global nil) + 7) + +(deftest (mini-meval let) + (mini-meval '(let ((x 3) (y 4)) (+ x y)) e-global nil) + 7) + +(deftest (mini-meval let) + (mini-meval '(let ((x 3) (y 4) (z 5)) (let ((z (+ x y)) (w z)) (list x y z w))) e-global nil) + '(3 4 7 5)) + +(deftest (mini-meval let*) + (mini-meval '(let ((x 3) (y 4) (z 5)) (let* ((z (+ x y)) (w z)) (list x y z w))) e-global nil) + '(3 4 7 7)) + +(deftest (mini-meval progn) + (mini-meval '(progn 1 2 3 4) e-global nil) + 4) + +(deftest (mini-meval defvar) + (mini-meval '(progn (defvar x 42) x) e-global nil) + 42) + +(deftest (mini-meval defun) + (mini-meval '(progn (defun double (x) (+ x x)) (double 3)) e-global nil) + 6) + +(deftest (mini-meval quote) + (mini-meval ''x e-global nil) + 'x) + +(deftest (mini-meval defmacro) + (mini-meval '(progn (defmacro qlist (x y) (list 'list (list 'quote x) (list 'quote y))) (qlist a b)) e-global nil) + '(a b)) + +(deftest (mini-meval macrolet) + (mini-meval '(progn + (defun qlist (a b) (list a b)) + (list + (qlist 'a 'b) + (macrolet ((qlist (x y) (list 'list (list 'quote x) (list 'quote y)))) + (qlist 'a 'b)) + (qlist 'a 'b))) + e-global nil) + '((a b) ('a 'b) (a b))) diff --git a/util.lisp b/util.lisp index 6348471..66c2a9c 100644 --- a/util.lisp +++ b/util.lisp @@ -13,7 +13,7 @@ (defmacro assoc-set (k v alist &optional (compare #'eq)) `(let ((my-k ,k) (my-v ,v)) - (let ((association (assoc my-k ,alist :key ,compare))) + (let ((association (assoc my-k ,alist :test ,compare))) (if association (setf (cdr association) my-v) (push (cons my-k my-v) ,alist))))) @@ -109,13 +109,7 @@ res)) ((stringp data) (copy-seq data)) - ((null data) - nil) - ((symbolp data) - data) - ((numberp data) - data) - ((characterp data) + ((or (null data) (symbolp data) (numberp data) (characterp data) (functionp data)) data) (t (warn "copy-all : Je ne sais pas copier ~w" data)