Utilisation du match pour le meval + amelioration du cas du lambda dans meval + amelioration de la gestion de l'environnement dans meval
This commit is contained in:
Bertrand BRUN
parent
10c613da3b
commit
22132df065
|
|
@ -95,7 +95,7 @@ par le compilateur et par l’interpréteur"
|
|||
(if (member '&rest (second expr))
|
||||
`(:lclosure . (,(get-nb-params (second expr))
|
||||
,(+ 1 (mposition '&rest (second expr)))
|
||||
,(lisp2li (implicit-progn (cddr expr))
|
||||
,@(lisp2li (implicit-progn (cddr expr))
|
||||
(make-stat-env (second expr) env))))
|
||||
`(:lclosure . ,(cons (get-nb-params (second expr))
|
||||
(lisp2li (implicit-progn (cddr expr))
|
||||
|
|
@ -266,9 +266,9 @@ par le compilateur et par l’interpréteur"
|
|||
|
||||
(deftest (lisp2li rest)
|
||||
(lisp2li `(lambda (x &rest y) (cons x y)) ())
|
||||
'(:lclosure 2 2 (:call cons
|
||||
'(:lclosure 2 2 :call cons
|
||||
(:cvar 0 1)
|
||||
(:cvar 0 2))))
|
||||
(:cvar 0 2)))
|
||||
|
||||
(deftest (lisp2li unknown)
|
||||
(lisp2li '(bar 3) ())
|
||||
|
|
|
|||
256
meval.lisp
256
meval.lisp
|
|
@ -2,9 +2,7 @@
|
|||
(load "match")
|
||||
|
||||
(defun get-env-num (num env)
|
||||
(format *debug* "~&get-env-num ~&~T=> num = ~a ~&~T=> env = ~a" num env)
|
||||
(defun get-env-num-t (num env counter)
|
||||
(format *debug* "~&get-env-num-t ~&~T=> num = ~a ~&~T=> env = ~a ~&~T=> counter = ~a" num env counter)
|
||||
(cond ((= counter num) env)
|
||||
((eq (aref env 0) nil) nil)
|
||||
(T
|
||||
|
|
@ -13,28 +11,50 @@
|
|||
(get-env-num-t num env 0))
|
||||
|
||||
(defun get-lower-env (env)
|
||||
(format *debug* "~&get-lower-env ~&~T=> env = ~a" env)
|
||||
(if (or (= (array-total-size env) 0)
|
||||
(eq (aref env 0) nil))
|
||||
env
|
||||
(get-lower-env (aref env 0))))
|
||||
|
||||
(defun make-env (size list-values env)
|
||||
(defun make-rest (env values &optional (pos-rest 1))
|
||||
"Construit l'environnement en rajoutant tous les valeurs
|
||||
du &rest dans une cellule de l'env sous forme d'une liste"
|
||||
(let ((size (- (array-total-size env) 1)))
|
||||
(defun make-rest-lower-env (lower-env pos values)
|
||||
(cond ((= pos pos-rest)
|
||||
(setf (aref lower-env pos) values))
|
||||
(T
|
||||
(setf (aref lower-env pos) (car values))
|
||||
(make-rest-lower-env lower-env
|
||||
(+ pos 1)
|
||||
(cdr values)))))
|
||||
(make-rest-lower-env env 1 values))
|
||||
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>"
|
||||
(format *debug* "~&make-env ~&~T=> size = ~a ~&~T=> list-value = ~a ~&~T=> env = ~a" size list-values env)
|
||||
(if (= (array-total-size env) 0)
|
||||
(setf env (make-array (+ 1 size)))
|
||||
(setf (aref (get-lower-env env) 0) (make-array (+ 1 size))))
|
||||
(let ((lower-env (get-lower-env env)))
|
||||
(format *debug* "~&(make-env let) ~&~T=> lower-env = ~a" lower-env)
|
||||
(loop
|
||||
for value in list-values
|
||||
for rank = 1 then (+ rank 1)
|
||||
do (setf (aref lower-env rank) value)
|
||||
))
|
||||
env)
|
||||
(cond ((and (not pos-rest)
|
||||
(< size (length list-values)))
|
||||
(error "Too arguments"))
|
||||
((> size (length list-values))
|
||||
(error "Too few arguments"))
|
||||
(T
|
||||
(if (= (array-total-size env) 0)
|
||||
(setf env (make-array (+ 1 size)))
|
||||
(setf (aref (get-lower-env env) 0) (make-array (+ 1 size))))
|
||||
(let ((lower-env (get-lower-env env)))
|
||||
(if pos-rest
|
||||
(make-rest lower-env
|
||||
list-values
|
||||
pos-rest)
|
||||
(loop
|
||||
for value in list-values
|
||||
for rank = 1 then (+ rank 1)
|
||||
do (setf (aref lower-env rank) value)
|
||||
)))
|
||||
env)))
|
||||
|
||||
(defun map-meval (list env)
|
||||
(format *debug* "~&map-meval ~&~T=> list = ~a ~&~T=> env = ~a" list env)
|
||||
|
|
@ -52,90 +72,77 @@ la valeur de la dernier"
|
|||
(meval (car list) env)
|
||||
(meval-progn (cdr list) env)))))
|
||||
|
||||
(defun modify-lower-env (lower-env value pos)
|
||||
(format *debug* "~&modify-lower-env ~&~T=> lower-env = ~a ~&~T=> value = ~a ~&~T=> pos = ~a" lower-env value pos)
|
||||
(let ((env-bis (make-array (+ pos 1))))
|
||||
(defun construct-new-lower-env (new-env old-env)
|
||||
(format *debug* "~&construct-new-lower-env ~&~T=> new-env = ~a ~&~T=> old-env = ~a" new-env old-env)
|
||||
(loop
|
||||
for i = 0 then (+ i 1)
|
||||
do (setf (aref new-env i) (aref old-env i))
|
||||
while (<= i (- pos 1))
|
||||
))
|
||||
(setf (aref lower-env pos) value)
|
||||
(construct-new-lower-env env-bis lower-env)
|
||||
(format *debug* "~&modify-lower-env ~&~T env-bis = ~a" env-bis)
|
||||
(setf lower-env env-bis)
|
||||
))
|
||||
|
||||
(defun make-rest (env &optional (pos-rest 1))
|
||||
(format *debug* "~&make-rest ~&~T=> env = ~a ~&~T=> pos-rest = ~a" env pos-rest)
|
||||
(let* ((lower-env (get-lower-env env))
|
||||
(size (- (if (= 0 (array-total-size lower-env))
|
||||
1
|
||||
(array-total-size lower-env))
|
||||
1)))
|
||||
(defun make-rest-lower-env (lower-env pos)
|
||||
(format *debug* "~&make-rest-lower-env ~&~T=> lower-env = ~a ~&~T=> pos = ~a ~&~T=> size = ~a" lower-env pos size)
|
||||
(cond ((>= pos size)
|
||||
(cons (aref lower-env pos) nil))
|
||||
((< pos pos-rest)
|
||||
(make-rest-lower-env lower-env (+ pos 1)))
|
||||
(T
|
||||
(cons (aref lower-env pos)
|
||||
(make-rest-lower-env lower-env (+ pos 1))))))
|
||||
(modify-lower-env (get-lower-env env) (make-rest-lower-env (get-lower-env env) pos-rest) pos-rest)
|
||||
(format *debug* "~&make-rest ~&~T=> lower-env = ~a" (get-lower-env env)))
|
||||
env)
|
||||
(defun meval-body (list-expr env)
|
||||
(if (endp list-expr)
|
||||
nil
|
||||
(if (endp (cdr list-expr))
|
||||
(meval (car list-expr) env)
|
||||
(progn
|
||||
(meval (car list-expr) env)
|
||||
(meval-body (cdr list-expr) env)))))
|
||||
|
||||
(defun meval-args (list-expr env)
|
||||
(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 (expr &optional (env #()))
|
||||
"Interprète le langage intermédiaire passé en paramètre."
|
||||
(format *debug* "~&meval ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
|
||||
(cond ((match :const (first expr))
|
||||
(format *debug* "~&(meval :const) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
|
||||
(cdr expr))
|
||||
((match :cvar (first expr))
|
||||
(format *debug* "~&(meval :cvar) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
|
||||
(let ((sub-env (get-env-num (second expr) env)))
|
||||
(if sub-env
|
||||
(aref sub-env (third expr))
|
||||
(error "The variable ~S is unbound" expr))))
|
||||
((match :if (first expr))
|
||||
(format *debug* "~&(meval :if) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
|
||||
(if (meval (second expr) env)
|
||||
(meval (third expr) env)
|
||||
(meval (fourth expr) env)))
|
||||
((match :call (first expr))
|
||||
(format *debug* "~&(meval :call) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
|
||||
(apply (symbol-function (cadr expr)) (map-meval (cddr expr) env)))
|
||||
((match :mcall (first expr))
|
||||
(format *debug* "~&(meval :mcall) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
|
||||
(if (consp (second expr))
|
||||
(let ((closure (second expr)))
|
||||
(format *debug* "~&~T=> closure = ~a" closure)
|
||||
(cond ((and (atom (third closure))
|
||||
(constantp (third closure))
|
||||
(integerp (third closure)))
|
||||
(meval closure
|
||||
(make-rest (make-env (length (cddr expr))
|
||||
(map-meval (cddr expr) env)
|
||||
env)
|
||||
(caddr closure))))
|
||||
(T
|
||||
(cond ((< (second closure) (length (cddr expr)))
|
||||
(error "Too arguments"))
|
||||
((> (second closure) (length (cddr expr)))
|
||||
(error "Too few arguments"))
|
||||
(T
|
||||
(meval closure
|
||||
(make-env (second closure)
|
||||
(map-meval (cddr expr)env)
|
||||
env)))))))
|
||||
(error "form not yet implemented")))
|
||||
((match :progn (first expr))
|
||||
(cond ((eq ':const (first expr))
|
||||
(match (:nil :const :val . _) expr val))
|
||||
((eq ':cvar (first expr))
|
||||
(match (:nil :cvar :num-env (? integerp) :index (? integerp)) expr
|
||||
(let ((sub-env (get-env-num num-env env)))
|
||||
(if sub-env
|
||||
(aref sub-env index)
|
||||
(error "The variable unbound" expr)))))
|
||||
((eq ':if (first expr))
|
||||
(match (:nil :if :predicat @. :expr1 @. :expr2 @.) expr
|
||||
(if (meval predicat env)
|
||||
(meval expr1 env)
|
||||
(meval expr2 env))))
|
||||
((eq ':call (first expr))
|
||||
(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 :mcall (first expr))
|
||||
;; (format *debug* "~&(meval :mcall) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
|
||||
;; (if (consp (second expr))
|
||||
;; (let ((closure (second expr)))
|
||||
;; (format *debug* "~&~T=> closure = ~a" closure)
|
||||
;; (cond ((and (atom (third closure))
|
||||
;; (constantp (third closure))
|
||||
;; (integerp (third closure)))
|
||||
;; (meval-body closure
|
||||
;; (make-rest (make-env (length (cddr expr))
|
||||
;; (map-meval (cddr expr) env)
|
||||
;; env)
|
||||
;; (caddr closure))))
|
||||
;; (T
|
||||
;; (cond ((< (second closure) (length (cddr expr)))
|
||||
;; (error "Too arguments"))
|
||||
;; ((> (second closure) (length (cddr expr)))
|
||||
;; (error "Too few arguments"))
|
||||
;; (T
|
||||
;; (meval closure
|
||||
;; (make-env (second closure)
|
||||
;; (map-meval (cddr expr)env)
|
||||
;; env)))))))
|
||||
;; (error "form not yet implemented")))
|
||||
((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))
|
||||
((match (:lclosure) (first expr))
|
||||
(format *debug* "~&(meval :lclosure) ~&~T=> expr = ~a~&~T=> env = ~a" expr env)
|
||||
(if (and (atom (caddr expr))
|
||||
(constantp (caddr expr))
|
||||
|
|
@ -194,6 +201,56 @@ la valeur de la dernier"
|
|||
(:const . nil)) #(() 1 2 3))
|
||||
T)
|
||||
|
||||
(deftestvar (meval make-env) empty-env #())
|
||||
(deftest (meval make-env)
|
||||
(make-env 2 '(1 2) empty-env)
|
||||
#(() 1 2)
|
||||
#'equalp)
|
||||
|
||||
(deftestvar (meval make-env) env #(() 1 2))
|
||||
(deftest (meval make-env)
|
||||
(make-env 2 '(7 8) env)
|
||||
#(#(() 7 8) 1 2)
|
||||
#'equalp)
|
||||
|
||||
(deftestvar (meval make-env make-rest) env #(() nil nil))
|
||||
(deftest (meval make-env make-rest)
|
||||
(make-rest env '(1 2 3 4) 2)
|
||||
#(() 1 (2 3 4))
|
||||
#'equalp)
|
||||
|
||||
(deftestvar (meval make-env &rest) env #(() 1 2))
|
||||
(deftest (meval make-env &rest)
|
||||
(make-env 2 '(7 8 9) env 2)
|
||||
#(#(() 7 (8 9)) 1 2)
|
||||
#'equalp)
|
||||
|
||||
(deftest (meval make-env &rest)
|
||||
(make-env 1 '(nil) env 1)
|
||||
#(#(() (nil)) 1 2)
|
||||
#'equalp)
|
||||
|
||||
(deftest (meval meval-body)
|
||||
(meval-body '((:const . 3)) #())
|
||||
'3)
|
||||
|
||||
(deftest (meval meval-body)
|
||||
(meval-body '((:const . 3) (:call cons (:const . 1) (:const . 2))) #())
|
||||
'(1 . 2))
|
||||
|
||||
(deftest (meval meval-args)
|
||||
(meval-args '((:const . 3)) #())
|
||||
'(3))
|
||||
|
||||
(deftest (meval meval-args)
|
||||
(meval-args '((:const . 3) (:const 1 2 3)) #())
|
||||
'(3 (1 2 3)))
|
||||
|
||||
(deftest (meval meval-args)
|
||||
(meval-args '((:cvar 0 1) (:call cons (:cvar 0 3)
|
||||
(:cvar 0 2))) #(() 1 2 3))
|
||||
'(1 (3 . 2)))
|
||||
|
||||
(deftest (meval :mcall :lclosure)
|
||||
(meval (lisp2li '((lambda (x y) (cons x y)) 1 2) ()))
|
||||
'(1 . 2))
|
||||
|
|
@ -201,12 +258,3 @@ la valeur de la dernier"
|
|||
(deftest (meval :mcall :lclosure)
|
||||
(meval (lisp2li '((lambda (x &rest y) (cons x y)) 1 2 3 4) ()))
|
||||
'(1 2 3 4))
|
||||
|
||||
(deftest (meval defun)
|
||||
(meval '(defun foo (x) x))
|
||||
foo)
|
||||
|
||||
(deftest (meval defun)
|
||||
(meval '(defun foo (x y z) (list x y z)))
|
||||
foo)
|
||||
|
||||
|
|
|
|||
|
|
@ -77,8 +77,11 @@
|
|||
nil))))))
|
||||
|
||||
(defmacro deftestvar (module name value)
|
||||
`(test-add-variable ',module
|
||||
(list ',name (list 'copy-tree ',value))))
|
||||
(if (arrayp value)
|
||||
`(test-add-variable ',module
|
||||
(list ',name (list 'copy-seq ',value)))
|
||||
`(test-add-variable ',module
|
||||
(list ',name (list 'copy-tree ',value)))))
|
||||
|
||||
(defvar run-tests-counter 0)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user