From 6d3071d9e8ee1f0035fa15130e17846b8dca2483 Mon Sep 17 00:00:00 2001 From: Bertrand BRUN Date: Tue, 26 Oct 2010 17:24:15 +0200 Subject: [PATCH] Ajout de la fonction meval. Pour l'instant la fonction meval gerer les variables, les if, les litteraux, les macros predefinie et les fonctions predefinie. Attention la macro 'OR' n'est pas gerer car elle utilise un let qui n'est pas encore implemente --- lisp2li.lisp | 50 ++++++++++++++++++++-------- main.lisp | 3 +- meval.lisp | 93 ++++++++++++++++++++++++++++++++++++---------------- 3 files changed, 103 insertions(+), 43 deletions(-) diff --git a/lisp2li.lisp b/lisp2li.lisp index bfefd38..7ab2e42 100644 --- a/lisp2li.lisp +++ b/lisp2li.lisp @@ -1,17 +1,23 @@ - -;; TODO : reste a gere les variables, les macros predefinies, les defuns. +;; TODO : reste a gerer les defuns, les let, les lambda expression, les setf, les progn, ... (defun lisp2li (expr env) - (cond ((and (atom expr) (constantp expr)) + (cond ((and (atom expr) (constantp expr)) ;;cas des litteraux (cons :lit expr)) - ((eq 'if (car expr)) + ((atom expr) ;;cas des variables + (let ((cell (get-binding env expr))) + (if cell + (cons :var (car cell)) + (warn "Variable ~S unknown" (car expr))))) + ((eq 'if (car expr)) ;;cas des if (list :if (lisp2li (second expr) env) (lisp2li (third expr) env) (lisp2li (fourth expr) env))) - ((eq 'quote (car expr)) + ((eq 'quote (car expr)) ;;cas des quotes (cons :lit (second expr))) - ((fboundp (car expr)) + ((and (fboundp (car expr)) (eq (macroexpand-1 expr) expr)) ;;cas des fonctions (cons :call (cons (first expr) (map-lisp2li (cdr expr) env)))) + ((and (fboundp (car expr)) (not (eq (macroexpand-1 expr) expr))) ;;cas des macros + (lisp2li (macroexpand-1 expr) env)) (T (list :unknown expr env)) )) @@ -58,7 +64,26 @@ (deftest lisp2li (lisp2li '(and 1 1) ()) - '(:call and (:lit . 1) (:lit . 1))) + '(:if (:lit . 1) (:call the (:lit . T) (:lit . 1)) (:lit . nil))) + +;; test des variables +(deftest lisp2li + (lisp2li 'x '(("TOP-LEVEL" (x . 1) (y . 2)))) + '(:var . x)) + +(deftest lisp2li + (lisp2li '(if (eq x 3) (- x 3) (+ x 3)) '(("TOP-LEVEL" (x . 3)))) + '(:if (:call eq (:var . x) (:lit . 3)) + (:call - (:var . x) (:lit . 3)) + (:call + (:var . x) (:lit . 3)))) + +(deftest lisp2li + (lisp2li '(if (eq x 3) + (- z 3) + (- x 5)) + '(("TEST" (z . 5)) ("TOP-LEVEL" (x . 4)))) + '(:IF (:CALL EQ (:VAR . X) (:LIT . 3)) (:CALL - (:VAR . Z) (:LIT . 3)) + (:CALL - (:VAR . X) (:LIT . 5)))) ;; Test avec des expression plus complexe (deftest lisp2li @@ -70,14 +95,13 @@ '(:IF (:CALL EQ (:LIT . "abc") (:LIT . 1)) (:LIT . "abc") (:LIT . 2))) (deftest lisp2li - (lisp2li '(if (and (eq 1 1) (= 2 2)) (or 1 2) (and 1 2)) ()) - '(:if (:call and (:call eq (:lit . 1) (:lit . 1)) - (:call = (:lit . 2) (:lit . 2))) - (:call or (:lit . 1) (:lit . 2)) - (:call and (:lit . 1) (:lit . 2)))) + (lisp2li '(if (and (eq 1 1) (= 2 2)) (foo 1 2) (bar 3 4)) ()) + '(:if (:if (:call eq (:lit . 1) (:lit . 1)) + (:call the (:lit . T) (:call = (:lit . 2) (:lit . 2))) (:lit . nil)) + (:unknown (foo 1 2) nil) (:unknown (bar 3 4) nil))) (deftest lisp2li (lisp2li '(foo 1 1) ()) '(:unknown (foo 1 1) ())) -(run-tests t) \ No newline at end of file +;(run-tests t) \ No newline at end of file diff --git a/main.lisp b/main.lisp index 193e125..c93ee48 100644 --- a/main.lisp +++ b/main.lisp @@ -7,6 +7,7 @@ (load "environnement") (load "instructions") (load "lisp2li") +(load "meval") ;; ... -(run-tests t) +;(run-tests t) ;(print-env-stack exemple-env-stack) diff --git a/meval.lisp b/meval.lisp index bd3dffc..d7314d8 100644 --- a/meval.lisp +++ b/meval.lisp @@ -1,37 +1,72 @@ -;; meval donnee en cours - (defun meval (expr env) - (cond ((and (atom expr) (constantp expr)) expr) ;; Literal - ((atom expr) ;; symboles - (let ((cell (assoc expr env))) - (if cell (cdr cell) - (error "")))) - ;; . - ;; . - ;; . - ((eq 'quote (car expr)) (cadr expr)) ;;Quote (' ou quote) - ((and (consp (car expr)) (eq 'lambda (caar expr))) - (meval-lambda (car expr) (cdr expr) env env)) ;; TODO : a remplir - ((eq 'defun (car expr)) - (set-defun (cadr expr) (cons 'lambda (cddr expr))) ;; TODO : sera remplacer par add-top-level-binding - (get-defun (car expr)) - (meval-lambda (get-defun (car expr)) (cdr expr) env ())) - ((eq 'if (car expr)) + (cond ((eq ':lit (first expr)) + (cdr expr)) + ((eq ':var (first expr)) + (let ((cell (get-binding env (cdr expr)))) + (if cell + (cdr cell) + (error "The variable ~S is unbound" (cdr expr))))) + ((eq ':if (car expr)) (if (meval (second expr) env) (meval (third expr) env) (meval (fourth expr) env))) - ;;cas des marcros/forme speciale deja traiter - ((fboundp (car expr)) ;;denier cas vrais fonctin globale predefinie - (apply (car expr) (map-meval (cdr expr) env)) - ) - )) + ((eq ':call (first expr)) + (apply (second expr) (map-meval (cddr expr) env))) + )) (defun map-meval (list env) (mapcar (lambda (x) (meval x env)) list)) -(defun meval-lambda (lbd args env-args old-env) - (meval (third (car lbd)) - (make-env (second (car lbd)) - (map-meval args env-args) - old-env)) -) \ No newline at end of file +;; Test unitaire +(deftest meval + (meval '(:lit . 3) ()) + 3) + +(deftest meval + (meval '(:var . x) '(("TEST" (s . ()) (z . 4) (x . 5) (u . 6)))) + 5) + +(deftest meval + (meval '(:var . s2) '(("TEST" (s . ()) (s1 . 7) (s2 . 8)) + ("TOP-LEVEL" (x . 4) (x1 . 5) (x2 . 6)))) + 8) + +(deftest meval + (meval '(:call + (:lit . 3) (:var . x)) '(("TOP-LEVEL" (x1 . 4) (x . 5) (z . 6)))) + 8) + + +;; meval donnee en cours + +;(defun meval (expr env) +; (cond ((and (atom expr) (constantp expr)) expr) ;; Literal +; ((atom expr) ;; symboles +; (let ((cell (assoc expr env))) +; (if cell (cdr cell) +; (error "")))) + ;; . + ;; . + ;; . +; ((eq 'quote (car expr)) (cadr expr)) ;;Quote (' ou quote) +; ((and (consp (car expr)) (eq 'lambda (caar expr))) +; (meval-lambda (car expr) (cdr expr) env env)) ;; TODO : a remplir +; ((eq 'defun (car expr)) +; (set-defun (cadr expr) (cons 'lambda (cddr expr))) ;; TODO : sera remplacer par add-top-level-binding +; (get-defun (car expr)) +; (meval-lambda (get-defun (car expr)) (cdr expr) env ())) +; ((eq 'if (car expr)) +; (if (meval (second expr) env) +; (meval (third expr) env) +; (meval (fourth expr) env))) +; ;;cas des marcros/forme speciale deja traiter +; ((fboundp (car expr)) ;;denier cas vrais fonctin globale predefinie +; (apply (car expr) (map-meval (cdr expr) env)) +; ) +; )) + +;(defun meval-lambda (lbd args env-args old-env) +; (meval (third (car lbd)) +; (make-env (second (car lbd)) +; (map-meval args env-args) +; old-env)) +;) \ No newline at end of file