From cb07628ee8fb85745c46bfa793c824eeccbb425a Mon Sep 17 00:00:00 2001 From: Bertrand BRUN Date: Fri, 12 Nov 2010 22:06:54 +0100 Subject: [PATCH] Ajout de la mise a jour de l'environnement lors d'un appel a une methode meta-defini --- lisp2li.lisp | 210 ++++++++++++++++++++++++++------------------------- meval.lisp | 27 ++++--- 2 files changed, 127 insertions(+), 110 deletions(-) diff --git a/lisp2li.lisp b/lisp2li.lisp index c23d72e..fb81b1d 100644 --- 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 index 24d3980..35377f7 100644 --- 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 _*)