Ajout de la fonction meval-lambda qui applique une lambda fonction quelconque a des valeurs d'arguments dans un certain environnement

This commit is contained in:
Bertrand BRUN 2010-11-07 03:11:34 +01:00
parent 534d55ada7
commit f05c73b033

View File

@ -1,7 +1,7 @@
(setq *debug* nil)
(load "match")
(defun get-env-num (num env)
"Récupère lenvironnement correspondant à celui souhaité."
(defun get-env-num-t (num env counter)
(cond ((= counter num) env)
((eq (aref env 0) nil) nil)
@ -11,6 +11,7 @@
(get-env-num-t num env 0))
(defun get-lower-env (env)
"Récupère lenvironnement le plus bas"
(if (or (= (array-total-size env) 0)
(eq (aref env 0) nil))
env
@ -32,9 +33,10 @@ du &rest dans une cellule de l'env sous forme d'une liste"
env)
(defun make-env (size list-values env &optional pos-rest)
"Construit un nouvel environnement de taille <size> dans <env>
et remplie ce nouvelle environnement avec les valeurs contenu dans
<list-values>"
"Construis lenvironnement en appariant les paramètres aux valeurs
correspondantes et signale une exception si paramètres et arguments
ne concordent pas. Si lenvironnement passe en paramètre nest pas vide,
le nouvel environnement y est inclus."
(cond ((and (not pos-rest)
(< size (length list-values)))
(error "Too arguments"))
@ -57,13 +59,11 @@ et remplie ce nouvelle environnement avec les valeurs contenu dans
env)))
(defun map-meval (list env)
(format *debug* "~&map-meval ~&~T=> list = ~a ~&~T=> env = ~a" list env)
(mapcar (lambda (x) (meval x env)) list))
(defun meval-progn (list env)
"Mevalue toutes les sous expressions et renvoie
la valeur de la dernier"
(format *debug* "~&meval-progn ~&~T=> list = ~a ~&~T env = ~a" list env)
(if (endp list)
nil
(if (endp (cdr list))
@ -73,6 +73,8 @@ la valeur de la dernier"
(meval-progn (cdr list) env)))))
(defun meval-body (list-expr env)
"Évalue en séquence la liste des expressions et
retourne la valeur retournée par la dernière"
(if (endp list-expr)
nil
(if (endp (cdr list-expr))
@ -82,13 +84,20 @@ la valeur de la dernier"
(meval-body (cdr list-expr) env)))))
(defun meval-args (list-expr env)
"Évalue en séquence la liste des expressions et
retourne la liste de leurs valeurs"
(if (endp list-expr)
nil
(if (endp (cdr list-expr))
`(,(meval (car list-expr) env))
`(,(meval (car list-expr) env)
,@(meval-args (cdr list-expr) env)))))
(defun meval-lambda (lclosure args env)
(match (:nil :lclosure :size (? integerp) :rest (? integerp)? :body _*) lclosure
(meval lclosure
(make-env size args env rest))))
(defun meval (expr &optional (env #()))
"Interprète le langage intermédiaire passé en paramètre."
(cond ((eq ':const (first expr))
@ -108,12 +117,17 @@ la valeur de la dernier"
(match (:nil :call :func-name _ :body _*) expr
(apply (symbol-function func-name) (map-meval body env))))
((eq ':mcall (first expr))
(match (:nil :mcall (:nil :lclosure :size (? integerp) :rest (? integerp)? :body _*) :args _*) expr
(meval-body `(,body)
(make-env size
(meval-args args env)
env
rest))))
(match (:nil :mcall :lambda (:nil :lclosure (? integerp) (? integerp)? _*) :args _*) expr
(meval-lambda lambda (meval-args args env) env)))
;; (meval-body `(,body)
;; (make-env size
;; (meval-args args env)
;; env
;; rest))))
;; ((match :mcall (first expr))
;; (format *debug* "~&(meval :mcall) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
@ -142,12 +156,11 @@ la valeur de la dernier"
((match (:progn) (first expr))
(format *debug* "~&(meval :progn) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
(meval-progn (cdr expr) env))
((match (:lclosure) (first expr))
(format *debug* "~&(meval :lclosure) ~&~T=> expr = ~a~&~T=> env = ~a" expr env)
((eq ':lclosure (first expr))
(if (and (atom (caddr expr))
(constantp (caddr expr))
(integerp (caddr expr)))
(meval-progn (cdddr expr) env)
(meval-progn `(,(cdddr expr)) env)
(meval-progn `(,(cddr expr)) env)))
(T
(error "form special ~S not yet implemented" (car expr)))))
@ -251,6 +264,13 @@ la valeur de la dernier"
(:cvar 0 2))) #(() 1 2 3))
'(1 (3 . 2)))
(deftest (meval meval-lambda)
(meval-lambda '(:lclosure 2 :call cons
(:cvar 0 1)
(:cvar 0 2))
'(1 2) #())
'(1 . 2))
(deftest (meval :mcall :lclosure)
(meval (lisp2li '((lambda (x y) (cons x y)) 1 2) ()))
'(1 . 2))