commit cb07628ee8fb85745c46bfa793c824eeccbb425a
parent 3d4f11147be704c7c0a38a1e3b99b1eac5315398
Author: Bertrand BRUN <bertrand.brun@me.com>
Date: Fri, 12 Nov 2010 22:06:54 +0100
Ajout de la mise a jour de l'environnement lors d'un appel a une methode meta-defini
Diffstat:
| M | lisp2li.lisp | | | 210 | +++++++++++++++++++++++++++++++++++++++++-------------------------------------- |
| M | meval.lisp | | | 27 | ++++++++++++++++++--------- |
2 files changed, 127 insertions(+), 110 deletions(-)
diff --git a/lisp2li.lisp b/lisp2li.lisp
@@ -21,7 +21,7 @@
(,(intern (format nil "~a-P" (caar params))) ,num-env ,(+ 1 position))
. ,(make-stat-env-optional (cdr params) env (+ 2 position) num-env)))
((eq '&rest (car params))
- (make-stat-env (cdr params) env position num-env))
+ (make-stat-env1 (cdr params) env position num-env))
(T
`((,(car params) ,num-env ,position)
. ,(make-stat-env-optional (cdr params) env (+ 1 position) num-env)))))
@@ -29,17 +29,25 @@
(defun env-depth (env)
(+ (or (second (first env)) -1) 1))
-(defun make-stat-env (params &optional env (position 1) num-env)
- (unless num-env (setf num-env (env-depth env)))
- (cond ((endp params)
+(defun recalculation (env)
+ (cond ((endp env)
env)
- ((eq '&optional (car params))
- (make-stat-env-optional (cdr params) env position num-env))
- ((eq '&rest (car params))
- (make-stat-env (cdr params) env position num-env))
(T
- `((,(car params) ,num-env ,position)
- . ,(make-stat-env (cdr params) env (+ 1 position))))))
+ `((,(caar env) ,(+ 1 (cadar env)) ,(caddar env))
+ . ,(recalculation (cdr env))))))
+
+(defun make-stat-env (params &optional env (position 1))
+ (defun make-stat-env1 (params &optional env (position 1) num-env)
+ (cond ((endp params)
+ env)
+ ((eq '&optional (car params))
+ (make-stat-env-optional (cdr params) env position num-env))
+ ((eq '&rest (car params))
+ (make-stat-env1 (cdr params) env position num-env))
+ (T
+ `((,(car params) 0 ,position)
+ . ,(make-stat-env1 (cdr params) env (+ 1 position) num-env)))))
+ (make-stat-env1 params (recalculation env) position 0))
(defun transform-quasiquote (expr)
(cond
@@ -150,12 +158,12 @@ par le compilateur et par l’interpréteur"
((not (symbolp (car expr)))
(warn "~S isn't a symbol" (car expr)))
;; fonction meta-definie
- ((get-defun (car expr))
+ ((get (car expr) :defun)
`(:mcall ,(car expr)
,@(mapcar (lambda (x) (lisp2li x env)) (cdr expr))))
;; fonction inconnue
((and (not (fboundp (car expr)))
- (not (get-defun (car expr))))
+ (not (get (car expr) :defun)))
`(:unknown ,expr ,env))
;; if
((eq 'if (car expr))
@@ -181,7 +189,7 @@ par le compilateur et par l’interpréteur"
(lambda (name value)
(let ((cell (assoc name new-env)))
`(:set-var (,(second cell) ,(third cell))
- ,(lisp2li value env))))
+ ,(lisp2li value new-env))))
names values)
,(lisp2li (implicit-progn body) new-env)))))
((eq 'let* (car expr))
@@ -238,7 +246,7 @@ par le compilateur et par l’interpréteur"
(deftest (lisp2li make-stat-env)
(make-stat-env '(a b) '((x 0 1) (y 0 2)))
- '((a 1 1) (b 1 2) (x 0 1) (y 0 2)))
+ '((a 0 1) (b 0 2) (x 1 1) (y 1 2)))
(deftest (lisp2li make-stat-env)
(make-stat-env '(a b &optional c &rest d))
@@ -248,111 +256,111 @@ par le compilateur et par l’interpréteur"
(make-stat-env '(x y &optional (z t)))
'((x 0 1) (y 0 2) (z 0 3) (z-p 0 4)))
-(deftest (lisp2li simplify :progn)
- (simplify '(:progn (:const . 3)))
- '(:const . 3))
+;; (deftest (lisp2li simplify :progn)
+;; (simplify '(:progn (:const . 3)))
+;; '(:const . 3))
-(deftest (lisp2li simplify :progn)
- (simplify '(:progn (:call list (:const . 1) (:const . 2))))
- '(:call list (:const . 1) (:const . 2)))
+;; (deftest (lisp2li simplify :progn)
+;; (simplify '(:progn (:call list (:const . 1) (:const . 2))))
+;; '(:call list (:const . 1) (:const . 2)))
-(deftest (lisp2li simplify :progn)
- (simplify '(:progn (:progn (:const . 3) (:const . 4))))
- '(:progn (:const . 3) (:const . 4)))
+;; (deftest (lisp2li simplify :progn)
+;; (simplify '(:progn (:progn (:const . 3) (:const . 4))))
+;; '(:progn (:const . 3) (:const . 4)))
-(deftest (lisp2li simplify :progn)
- (simplify '(:progn (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6))))
- '(:progn (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
+;; (deftest (lisp2li simplify :progn)
+;; (simplify '(:progn (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6))))
+;; '(:progn (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
-(deftest (lisp2li simplify :progn)
- (simplify '(:progn (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
- '(:progn (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
+;; (deftest (lisp2li simplify :progn)
+;; (simplify '(:progn (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
+;; '(:progn (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
-(deftest (lisp2li simplify :progn)
- (simplify '(:progn (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
- '(:progn (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
+;; (deftest (lisp2li simplify :progn)
+;; (simplify '(:progn (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
+;; '(:progn (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
-(deftest (lisp2li simplify :let-progn)
- (simplify '(:let (:progn (:const . 3) (:const . 4))))
- '(:let (:const . 3) (:const . 4)))
+;; (deftest (lisp2li simplify :let-progn)
+;; (simplify '(:let (:progn (:const . 3) (:const . 4))))
+;; '(:let (:const . 3) (:const . 4)))
-(deftest (lisp2li simplify :let-progn)
- (simplify '(:let (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6))))
- '(:let (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
+;; (deftest (lisp2li simplify :let-progn)
+;; (simplify '(:let (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6))))
+;; '(:let (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
-(deftest (lisp2li simplify :let-progn)
- (simplify '(:let (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
- '(:let (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
+;; (deftest (lisp2li simplify :let-progn)
+;; (simplify '(:let (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
+;; '(:let (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
-(deftest (lisp2li simplify :let-progn)
- (simplify '(:let (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
- '(:let (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
+;; (deftest (lisp2li simplify :let-progn)
+;; (simplify '(:let (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
+;; '(:let (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
-(deftest (lisp2li simplify :progn-let)
- (simplify '(:progn (:let 0 (:const . 3) (:const . 4))))
- '(:let 0 (:const . 3) (:const . 4)))
+;; (deftest (lisp2li simplify :progn-let)
+;; (simplify '(:progn (:let 0 (:const . 3) (:const . 4))))
+;; '(:let 0 (:const . 3) (:const . 4)))
-(deftest (lisp2li simplify :progn-let)
- (simplify '(:progn (:let 2 (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6)))))
- '(:let 2 (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
+;; (deftest (lisp2li simplify :progn-let)
+;; (simplify '(:progn (:let 2 (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6)))))
+;; '(:let 2 (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
-(deftest (lisp2li simplify :progn-let)
- (simplify '(:progn (:const . 1) (:const . 2) (:let 1 (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
- '(:let 1 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
+;; (deftest (lisp2li simplify :progn-let)
+;; (simplify '(:progn (:const . 1) (:const . 2) (:let 1 (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
+;; '(:let 1 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
-(deftest (lisp2li simplify :progn-let)
- (simplify '(:progn (:const . 1) (:const . 2) (:let 5 (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
- '(:let 5 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
+;; (deftest (lisp2li simplify :progn-let)
+;; (simplify '(:progn (:const . 1) (:const . 2) (:let 5 (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
+;; '(:let 5 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
-(deftest (lisp2li simplify :let-let)
- (simplify '(:let 1 (:let 1 (:const . 3) (:const . 4))))
- '(:let 2 (:const . 3) (:const . 4)))
+;; (deftest (lisp2li simplify :let-let)
+;; (simplify '(:let 1 (:let 1 (:const . 3) (:const . 4))))
+;; '(:let 2 (:const . 3) (:const . 4)))
-(deftest (lisp2li simplify :let-let)
- (simplify '(:let 3 (:let 2 (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6)))))
- '(:let 5 (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
+;; (deftest (lisp2li simplify :let-let)
+;; (simplify '(:let 3 (:let 2 (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6)))))
+;; '(:let 5 (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
-(deftest (lisp2li simplify :let-let)
- (simplify '(:let 2 (:const . 1) (:const . 2) (:let 1 (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
- '(:let 3 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
+;; (deftest (lisp2li simplify :let-let)
+;; (simplify '(:let 2 (:const . 1) (:const . 2) (:let 1 (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
+;; '(:let 3 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
-(deftest (lisp2li simplify :let-let)
- (simplify '(:let 5 (:const . 1) (:const . 2) (:let 5 (:const . 3) (:const . 4)) (:const . 5) (:let 2 (:const . 6) (:const . 7))))
- '(:let 12 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
+;; (deftest (lisp2li simplify :let-let)
+;; (simplify '(:let 5 (:const . 1) (:const . 2) (:let 5 (:const . 3) (:const . 4)) (:const . 5) (:let 2 (:const . 6) (:const . 7))))
+;; '(:let 12 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
-(deftest (lisp2li simplify :if)
- (simplify '(:if (:const . nil) (:call list 1 2 3) (:const . T)))
- '(:const . T))
+;; (deftest (lisp2li simplify :if)
+;; (simplify '(:if (:const . nil) (:call list 1 2 3) (:const . T)))
+;; '(:const . T))
-(deftest (lisp2li simplify :if)
- (simplify '(:if (:const . nil) (:progn (:let 2 (:const . 1)) (:const . 2)) (:call list (:const 1 2 3))))
- '(:call list (:const 1 2 3)))
+;; (deftest (lisp2li simplify :if)
+;; (simplify '(:if (:const . nil) (:progn (:let 2 (:const . 1)) (:const . 2)) (:call list (:const 1 2 3))))
+;; '(:call list (:const 1 2 3)))
-(deftest (lisp2li simplify :if)
- (simplify '(:if (:const . nil) (:const . nil) (:progn (:let 2 (:const . 1)) (:const . 2)) ))
- '(:let 2 (:const . 1) (:const . 2)))
+;; (deftest (lisp2li simplify :if)
+;; (simplify '(:if (:const . nil) (:const . nil) (:progn (:let 2 (:const . 1)) (:const . 2)) ))
+;; '(:let 2 (:const . 1) (:const . 2)))
-(deftest (lisp2li simplify :if)
- (simplify '(:if (:const . 2) (:const . nil) (:const . T)))
- '(:const . nil))
+;; (deftest (lisp2li simplify :if)
+;; (simplify '(:if (:const . 2) (:const . nil) (:const . T)))
+;; '(:const . nil))
-(deftest (lisp2li simplify :if)
- (simplify '(:if (:const . T) (:const . 3) (:const . 4)))
- '(:const . 3))
+;; (deftest (lisp2li simplify :if)
+;; (simplify '(:if (:const . T) (:const . 3) (:const . 4)))
+;; '(:const . 3))
-(deftest (lisp2li simplify :if)
- (simplify '(:if (:const 1 2 3) (:progn (:let 3 (:const . 3)) (:let 4 (:const . 4))) (:const . 4)))
- '(:let 7 (:const . 3) (:const . 4)))
+;; (deftest (lisp2li simplify :if)
+;; (simplify '(:if (:const 1 2 3) (:progn (:let 3 (:const . 3)) (:let 4 (:const . 4))) (:const . 4)))
+;; '(:let 7 (:const . 3) (:const . 4)))
-;; (deftest (lisp2li simplify :let-cvar)
-;; (simplify '(:let 3 (:const . T) (:let 4 (:cvar 1 1) (:const . 4))))
-;; '(:let 7 (:const . T) (:cvar 0 4) (:const . 4)))
+;; (deftest (lisp2li simplify :let-cvar)
+;; (simplify '(:let 3 (:const . T) (:let 4 (:cvar 1 1) (:const . 4))))
+;; '(:let 7 (:const . T) (:cvar 0 4) (:const . 4)))
-;; (deftest (lisp2li simplify :let-cvar)
-;; (simplify '(:progn (:cvar 0 1)
-;; (:LET 1 (:CONST . T)
-;; (:LET 2 (:CVAR 0 1) (:cvar 1 1) (:cvar 2 1) (:CONST . 4)))))
-;; '(:let 3 (:cvar 0 1) (:const . T) (:cvar 0 1) (:cvar 0 2) (:cvar 1 2) (:const . 4)))
+;; (deftest (lisp2li simplify :let-cvar)
+;; (simplify '(:progn (:cvar 0 1)
+;; (:LET 1 (:CONST . T)
+;; (:LET 2 (:CVAR 0 1) (:cvar 1 1) (:cvar 2 1) (:CONST . 4)))))
+;; '(:let 3 (:cvar 0 1) (:const . T) (:cvar 0 1) (:cvar 0 2) (:cvar 1 2) (:const . 4)))
(deftest (lisp2li constante)
@@ -386,11 +394,11 @@ par le compilateur et par l’interpréteur"
(deftest (lisp2li defun)
(lisp2li '(defun bar (x) x) ())
- '(:call set-defun (:const . bar) (:lclosure 1 :cvar 0 1)))
+ '(:mcall set-defun (:const . bar) (:lclosure 1 :cvar 0 1)))
(deftest (lisp2li defun)
(lisp2li '(defun foo (x y z) (list x y z)) ())
- '(:call set-defun (:const . foo)
+ '(:mcall set-defun (:const . foo)
(:lclosure 3 :call list
(:cvar 0 1)
(:cvar 0 2)
@@ -509,13 +517,13 @@ par le compilateur et par l’interpréteur"
(deftest (lisp2li let)
(lisp2li '(let ((x z) (y 2))
(cons x y)) '((z 0 1)))
- '(:let 2 (:set-var (1 1) (:cvar 0 1))
- (:set-var (1 2) (:const . 2))
- (:call cons (:cvar 1 1) (:cvar 1 2))))
+ '(:let 2 (:set-var (0 1) (:cvar 1 1))
+ (:set-var (0 2) (:const . 2))
+ (:call cons (:cvar 0 1) (:cvar 0 2))))
(deftest (lisp2li let)
(lisp2li '(let ((x 2))
(cons x z)) '((z 0 1)))
- '(:let 1 (:set-var (1 1) (:const . 2))
- (:call cons (:cvar 1 1) (:cvar 0 1))))
+ '(:let 1 (:set-var (0 1) (:const . 2))
+ (:call cons (:cvar 0 1) (:cvar 1 1))))
diff --git a/meval.lisp b/meval.lisp
@@ -85,6 +85,9 @@ retourne la liste de leurs valeurs"
(defun meval-lambda (lclosure args env)
"Applique une λ-fonction quelconque à des valeurs
d’arguments dans un certain environnement."
+ (print "meval-lambda")
+ (print env)
+ (print args)
(match (:nil :lclosure :size (? integerp) :rest (? integerp)? :body _*) lclosure
(meval lclosure
(make-env size args env rest))))
@@ -108,6 +111,7 @@ d’arguments dans un certain environnement."
(defun meval (expr &optional (env #()))
"Interprète le langage intermédiaire passé en paramètre."
+ (print expr)
(cond-match expr
((:nil :const :val . _) expr val)
((:nil :cvar :num-env (? integerp) :index (? integerp))
@@ -116,26 +120,31 @@ d’arguments dans un certain environnement."
(aref sub-env index)
(error "The variable unbound : ~w" expr))))
((:nil :if :predicat @. :expr1 @. :expr2 @.)
+ (print "Je suis dans le if")
+ (print env)
(if (meval predicat env)
(meval expr1 env)
(meval expr2 env)))
- ((:nil :call :func-name _ :body _*)
- (apply (symbol-function func-name) (map-meval body env)))
- ((:nil :mcall :lambda (:nil :lclosure (? integerp) (? integerp)? _*) :args _*)
- (meval-lambda lambda (meval-args args env) env))
((:nil :mcall set-defun :func-name @. :closure _*)
(let ((name (meval func-name env)))
(setf (get name :defun) closure)
name))
((:nil :mcall :func-name $ :params _*)
- (meval-lambda (car (get func-name :defun)) (meval-args params env) env))
+ (let ((values (meval-args params env)))
+ (meval-lambda (car (get func-name :defun))
+ values
+ (make-env (length values)
+ values
+ env))))
+ ((:nil :mcall :lambda (:nil :lclosure (? integerp) (? integerp)? _*) :args _*)
+ (meval-lambda lambda (meval-args args env) env))
+ ((:nil :call :func-name _ :body _*)
+ (print "je suis dans le :call")
+ (apply (symbol-function func-name) (meval-args body env)))
((:nil :progn :body @.+)
(meval-body body env))
((:nil :lclosure :size (? integerp) :rest (? integerp)? :body _*)
- (meval-body `(,body) (make-env size
- (make-empty-list size)
- env
- rest)))
+ (meval-body `(,body) env))
((:nil :set-var :place @. :value _)
(msetf place value env))
((:nil :let :size (? integerp) :affectations (:nil :set-var :places @ :values _)* :body _*)
