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

Ajout de la reconnaissant du ((lambda (..) ..) ..) avec gestion du &rest dans meval

Browse Source
This commit is contained in:
Bertrand BRUN 2010-11-06 21:33:25 +01:00
parent 95e76ef163
commit a08a7e9875
3 changed files with 146 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
lisp2li.lisp
View File

@ -61,7 +61,7 @@
,(transform-quasiquote (cdr expr))))))
(defun get-nb-params (params)
"renvoie le nombre exact de paramètres sans les &optional et &rest"
"Renvoie le nombre exact de paramètres sans les &optional et &rest"
(defun get-nb-params-t (params r)
(cond ((endp params)
r)
@ -72,6 +72,11 @@
(get-nb-params-t (cdr params) (+ 1 r)))))
(get-nb-params-t params 0))
(defun implicit-progn (expr)
(if (n-consp 2 expr)
(cons 'progn expr)
(car expr)))
(defun lisp2li (expr env)
"Convertit le code LISP en un code intermédiaire reconnu
par le compilateur et par l’interpréteur"
@ -90,11 +95,11 @@ 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 (caddr expr)
(make-stat-env (second expr)))))
,(lisp2li (implicit-progn (cddr expr))
(make-stat-env (second expr) env))))
`(:lclosure . ,(cons (get-nb-params (second expr))
(lisp2li (caddr expr)
(make-stat-env (second expr)))))))
(lisp2li (implicit-progn (cddr expr))
(make-stat-env (second expr) env))))))
;; lambda ex: ((lambda (x) x) 1)
((and (consp (car expr))
(eq 'lambda (caar expr)))
@ -140,6 +145,9 @@ par le compilateur et par l’interpréteur"
;; progn
((eq 'progn (car expr))
(cons :progn (map-lisp2li (cdr expr) env)))
;; declaim
((eq 'declaim (car expr))
(cons :const nil))
;; macros
((macro-function (car expr))
(lisp2li (macroexpand expr) env))
@ -246,9 +254,25 @@ par le compilateur et par l’interpréteur"
(:cvar 0 2)
(:cvar 0 3)))
(deftest (lisp2li lambda)
(lisp2li `(lambda (x y z) (list x y z) (+ x y)) ())
'(:lclosure 3 :progn (:call list
(:cvar 0 1)
(:cvar 0 2)
(:cvar 0 3))
(:call +
(:cvar 0 1)
(:cvar 0 2))))
(deftest (lisp2li rest)
(lisp2li `(lambda (x &rest y) (cons x y)) ())
'(:lclosure 2 2 (:call cons
(:cvar 0 1)
(:cvar 0 2))))
(deftest (lisp2li unknown)
(lisp2li '(foo 3) ())
'(:unknown (foo 3) ()))
(lisp2li '(bar 3) ())
'(:unknown (bar 3) ()))
(deftest (lisp2li function)
(lisp2li '#'car ())

116
meval.lisp
View File

@ -1,7 +1,10 @@
(setq *debug* nil)
(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
@ -9,10 +12,38 @@
)))
(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)
"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)
(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))
@ -21,23 +52,96 @@
(meval (car list) env)
(meval-progn (cdr list) env)))))
(defun meval (expr &optional 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 (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))
(meval-progn (cdr 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)
(if (and (atom (caddr expr))
(constantp (caddr expr))
(integerp (caddr expr)))
(meval-progn (cdddr expr) env)
(meval-progn `(,(cddr expr)) env)))
(T
(error "form special ~S not yet implemented" (car expr)))))
@ -90,6 +194,14 @@
(:const . nil)) #(() 1 2 3))
T)
(deftest (meval :mcall :lclosure)
(meval (lisp2li '((lambda (x y) (cons x y)) 1 2) ()))
'(1 . 2))
(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)

2
util.lisp
View File

@ -73,7 +73,7 @@
(defmacro get-defun (symb)
`(get ,symb :defun))
(defun set-defun (li)
(defun set-defun (symb expr)
(setf (get-defun (cdaddr li))
(cdddr li)))