suzanne.soy/2010-m1s1-compilation
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Encore quelques tests sur mini-meval : il passe avec succès les let, let*, defun, defvar, defmacro, macrolet !

Browse Source
This commit is contained in:
Georges Dupéron 2010-11-15 04:29:45 +01:00
parent 44f3bf6fc1
commit 3bb7a28fb6
2 changed files with 131 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

172
implementation/mini-meval.lisp
View File

@ -51,20 +51,20 @@
(if fixed (if fixed
(if (endp params) (if (endp params)
(error "mini-meval-params : not enough parameters !") (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 (if optional
(let* ((var (caar optional)) (let* ((var (caar optional))
(value (if (endp params) (value (if (endp params)
(mini-meval (cadar optional) global local) (mini-meval (cadar optional) global local)
(car params))) (car params)))
(svar (caddar optional)) (svar (caddar optional))
(new-local (acons var value local)) (new-local (acons `(,var . variable) value local))
(new-local-2 (if svar (new-local-2 (if svar
(acons svar (endp params) new-local) (acons `(,svar . variable) (endp params) new-local)
new-local))) new-local)))
(mini-meval-params (cdr params) global new-local-2 nil (cdr optional) rest key other aux)) (mini-meval-params (cdr params) global new-local-2 nil (cdr optional) rest key other aux))
(if rest (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). ;; TODO : finir d'implémenter &key &allow-other-keys &aux (et relire CLTL).
local)))) local))))
; (if key ; (if key
@ -76,24 +76,24 @@
; maybe-val ; maybe-val
; (error "mini-meval-params : Nombre de paramètres impair alors qu'il y a &key.")))) ; (error "mini-meval-params : Nombre de paramètres impair alors qu'il y a &key."))))
; (svar (fourth (car 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) ; (cadr maybe-val-2)
; (mini-meval (third (car key)) global local)) ; (mini-meval (third (car key)) global local))
; local)) ; local))
; (new-local-2 (if svar ; (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))) ; 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) (defun mini-meval-get-params-from-real (etat-global etat-local lambda-list effective-parameters)
"Lambda-list doit être déjà sliced." "Lambda-list doit être déjà sliced."
(apply #'mini-meval-params effective-parameters etat-global etat-local (funcall #'mini-meval-params effective-parameters etat-global etat-local
(cdr (assoc 'fixed lambda-list)) (cdr (assoc 'fixed lambda-list))
(cdr (assoc 'optional lambda-list)) (cdr (assoc 'optional lambda-list))
(cdr (assoc 'rest lambda-list)) (cdr (assoc 'rest lambda-list))
(cdr (assoc 'key lambda-list)) (cdr (assoc 'key lambda-list))
(cdr (assoc 'other lambda-list)) (cdr (assoc 'other lambda-list))
(cdr (assoc 'aux 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. 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 ;; 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. 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 : 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 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 (cond-match
expr expr
((debug :id _?)
(format t "~&debug :~& id = ~w~& global = ~w~& local = ~w" id etat-global etat-local))
#| 2) Cas des macros |# #| 2) Cas des macros |#
((:name $ :params _*) ((:name $$ :params _*)
(let ((definition (assoc* `(,name macro) #'equal etat-local etat-global))) (let ((definition (assoc* `(,name . macro) #'equal etat-local (cdr etat-global))))
(if definition (if definition
#| - Si on a une fonction de ce nom dans l'état-local ou dans l'etat-global, on l'exécute. |# #| - 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)))) (else))))
#| 1) Cas des formes spéciales |# #| 1) Cas des formes spéciales |#
((eval-when :situations ($*) :body _*) ((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) (mini-meval `(progn ,body)
etat-global etat-global
(reduce* etat-local (lambda (new-etat-local name lambda-list fbody) (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) (mini-meval `(lamdba ,lambda-list ,@fbody) etat-global etat-local)
new-etat-local)) new-etat-local))
name lambda-list fbody))) name lambda-list fbody)))
((labels ((:name $ :lambda-list @ :fbody _*)*) :body _*) ((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)) name))
(new-etat-local (append new-bindings etat-local))) (new-etat-local (append new-bindings etat-local)))
(mapcar (lambda (name lambda-list fbody) (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 ;; 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. ;; le risque inexistant de faire une mutation dans etat-local.
;; TODO : vérifier que ça marche. ;; TODO : vérifier que ça marche.
(assoc-set `(,name 'function) (assoc-set `(,name . function)
(mini-meval `(lambda ,lambda-list ,@fbody) new-etat-local) (mini-meval `(lambda ,lambda-list ,@fbody) new-etat-local)
new-bindings new-bindings
#'equal)) #'equal))
name lambda-list fbody) 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 _*) ((let ((:name $ :value _)*) :body _*)
(mini-meval `(progn ,body) (mini-meval `(progn ,@body)
etat-global etat-global
(reduce* etat-local (lambda (new-etat-local name value) (reduce* etat-local (lambda (new-etat-local name value)
(acons (cons name 'variable) (acons `(,name . variable)
(mini-meval value etat-global etat-local) (mini-meval value etat-global etat-local)
new-etat-local)) new-etat-local))
name value))) name value)))
((let* ((:name $ :value _)*) :body _*) (((? (eq x 'let*)) ((:name $ :value _)*) :body _*)
(mini-meval `(progn ,body) (mini-meval `(progn ,@body)
etat-global etat-global
(reduce* etat-local (lambda (new-etat-local name value) (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. ;; Comme let sauf new-etat-local au lieu de etat-local ici.
(mini-meval value etat-global new-etat-local) (mini-meval value etat-global new-etat-local)
new-etat-local)) new-etat-local))
name value))) name value)))
((macrolet ((:name $ :lambda-list @ :mbody _*)*) :body _*) ((macrolet ((:name $ :lambda-list @ :mbody _*)*) :body _*)
(mini-meval `(progn ,body) (mini-meval `(progn ,@body)
etat-global etat-global
(reduce* etat-local (lambda (new-etat-local name lambda-list mbody) (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 ;; comme le flet sauf nil au lieu de new-etat-local
;; CLTL 7.5 : ;; CLTL 7.5 :
;; The precise rule is that the macro-expansion functions defined ;; 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)) new-etat-local))
name lambda-list mbody))) name lambda-list mbody)))
((progn :body _*) ((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)))) body))))
((if :condition _ :si-vrai _ :si-faux _?) ((if :condition _ :si-vrai _ :si-faux _?)
(if (mini-meval condition etat-global etat-local) (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 _*) ((lambda :lambda-list @ :body _*)
(let ((sliced-lambda-list (slice-up-lambda-list lambda-list))) (let ((sliced-lambda-list (slice-up-lambda-list lambda-list)))
(lambda (&rest effective-parameters) (lambda (&rest effective-parameters)
(mini-meval body (mini-meval `(progn ,@body)
etat-global etat-global
(mini-meval-get-params-from-real etat-global etat-local sliced-lambda-list effective-parameters))))) (mini-meval-get-params-from-real etat-global etat-local sliced-lambda-list effective-parameters)))))
((defun :name $ :lambda-list @ :body _*) ((defun :name $ :lambda-list @ :body _*)
(assoc-set `(,name 'function) (assoc-set `(,name . function)
(mini-meval `(lambda ,lambda-list ,@body) etat-global etat-local) (mini-meval `(lambda ,lambda-list ,@body) etat-global etat-local)
etat-global (cdr etat-global)
#'equal) #'equal)
name) name)
((defmacro :name $ :lambda-list @ :body _*) ((defmacro :name $ :lambda-list @ :body _*)
(assoc-set `(,name 'macro) (assoc-set `(,name . macro)
(mini-meval `(lambda ,lambda-list ,@body) etat-global etat-local) (mini-meval `(lambda ,lambda-list ,@body) etat-global etat-local)
etat-global (cdr etat-global)
#'equal) #'equal)
name) name)
((defvar :name $ :value _) ((defvar :name $ :value _)
(assoc-set `(,name 'variable) (assoc-set `(,name . variable)
(mini-meval value etat-global etat-local) (mini-meval value etat-global etat-local)
etat-global (cdr etat-global)
#'equal) #'equal)
name) name)
((setf/setq) ((setf/setq)
) )
((quote :val _)
val)
#| Traitement des appels de fonction |# #| Traitement des appels de fonction |#
((:lambda (lambda @ _*) :params _*) ((:lambda (lambda @ _*) :params _*)
#| - Si c'est une fonction anonyme, on l'exécute. |# #| - Si c'est une fonction anonyme, on l'exécute. |#
(apply (mini-meval lambda etat-global etat-local) params)) (apply (mini-meval lambda etat-global etat-local) params))
((:name $ :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 (if definition
#| - Si on a une fonction de ce nom dans l'état-local ou dans l'etat-global, on l'exécute. |# #| - 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)) (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 . $$) ((:name . $$)
(let ((definition (assoc* `(,name variable) #'equal etat-local etat-global))) (let ((definition (assoc* `(,name . variable) #'equal etat-local (cdr etat-global))))
(if definition (if definition
(cdr 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 . (? numberp))
num) num)
((:str . (? stringp)) ((:str . (? stringp))
str) str)
((quote :val _)
val)
(() (()
nil))) 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)))

10
util.lisp
View File

@ -13,7 +13,7 @@
(defmacro assoc-set (k v alist &optional (compare #'eq)) (defmacro assoc-set (k v alist &optional (compare #'eq))
`(let ((my-k ,k) `(let ((my-k ,k)
(my-v ,v)) (my-v ,v))
(let ((association (assoc my-k ,alist :key ,compare))) (let ((association (assoc my-k ,alist :test ,compare)))
(if association (if association
(setf (cdr association) my-v) (setf (cdr association) my-v)
(push (cons my-k my-v) ,alist))))) (push (cons my-k my-v) ,alist)))))
@ -109,13 +109,7 @@
res)) res))
((stringp data) ((stringp data)
(copy-seq data)) (copy-seq data))
((null data) ((or (null data) (symbolp data) (numberp data) (characterp data) (functionp data))
nil)
((symbolp data)
data)
((numberp data)
data)
((characterp data)
data) data)
(t (t
(warn "copy-all : Je ne sais pas copier ~w" data) (warn "copy-all : Je ne sais pas copier ~w" data)