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