www

commit 1bd2db29f63a8abff8d73a2e7c9c71cabb77b322
parent bc8dedf65248efed9adced52b1741757e74b43db
Author: Bertrand BRUN <bertrand.brun@me.com>
Date:   Fri,  5 Nov 2010 23:37:00 +0100

Correction de la fonction make-stat-env. Maintenant elle marche parfaitement (normalement)

Diffstat:
M
lisp2li.lisp
 | 
44
+++++++++++++++++++++++++++++++++-----------
M
meval.lisp
 | 
2
--

2 files changed, 33 insertions(+), 13 deletions(-)
diff --git a/lisp2li.lisp b/lisp2li.lisp
@@ -11,16 +11,31 @@
 (defun map-lisp2li (expr env)
   (mapcar (lambda (x) (lisp2li x env)) expr))
 
-(defun make-stat-env (params &optional env)
-   (append
-    (loop
-     for var in (remove '&optional (remove '&rest params))
-     for num-env = (+ (or (second (first env)) -1) 1)
-     for position = 1 then (+ position 1)
-     unless (member var '(&optional &rest))
-     collect (list var num-env position))
-    env))
-     
+(defun make-stat-env-optional (params env position num-env)
+  (cond ((endp params)
+         env)
+        ((consp (car params))
+         `((,(caar params) ,num-env ,position)
+           (,(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))
+        (T
+         `((,(car params) ,num-env ,position)
+           . ,(make-stat-env-optional (cdr params) env (+ 1 position) num-env)))))
+  
+(defun make-stat-env (params &optional env (position 1) num-env)
+  (unless num-env (setq num-env (+ (or (second (first env)) -1) 1)))
+  (cond ((endp params)
+         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))))))
+
 (defun transform-quasiquote (expr)
   (cond
    ;; a
@@ -61,7 +76,7 @@ par le compilateur et par l’interpréteur"
    ;; lambda solitaire ex: (lambda (x) x)
    ((eq 'lambda (car expr))
     `(:lclosure . ,(cons (length (second expr))
-                         (lisp2li (third expr)
+                         (lisp2li (caddr expr)
                                   (make-stat-env (second expr))))))
    ;; lambda ex: ((lambda (x) x) 1)
    ((and (consp (car expr))
@@ -207,6 +222,13 @@ par le compilateur et par l’interpréteur"
                      (:cvar 0 3))
           (:const . 1) (:const . 2) (:const . 3)))
 
+(deftest (lisp2li lambda)
+  (lisp2li `(lambda (x y z) (list x y z)) ())
+  '(:lclosure 3 :call list
+                      (:cvar 0 1)
+                      (:cvar 0 2)
+                      (:cvar 0 3)))
+
 (deftest (lisp2li unknown)
   (lisp2li '(foo 3) ())
   '(:unknown (foo 3) ()))
diff --git a/meval.lisp b/meval.lisp
@@ -18,8 +18,6 @@
 (defun map-meval (list env)
   (mapcar (lambda (x) (meval x env)) list))
 
-(defun foo (x) x)
-
 ;; Test unitaire
 (load "test-unitaire")
 (erase-tests meval)