commit 1fb31367c8ade216a90e006ee401b169e50d896e
parent 5277544ada79e632afb328dcdf5e414e579bbc73
Author: Bertrand BRUN <bertrand.brun@me.com>
Date: Thu, 4 Nov 2010 13:35:29 +0100
Ajout des quasiquotes et compagnie. Plus defvar et function sont reconnues par lisp2li
Diffstat:
| M | lisp2li.lisp | | | 116 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------- |
1 file changed, 88 insertions(+), 28 deletions(-)
diff --git a/lisp2li.lisp b/lisp2li.lisp
@@ -1,5 +1,49 @@
(load "environnement")
(erase-tests lisp2li)
+
+;; `
+(defvar my-quasiquote (car '`(,foo)))
+
+;; ,
+(defvar my-unquote (caaadr '`(,foo)))
+
+;; ,@
+(defvar my-unquote-unsplice (caaadr '`(,@foo)))
+
+(defun map-lisp2li (expr env-var env-fun)
+ (mapcar (lambda (x) (lisp2li x env-var env-fun)) expr))
+
+(defun map-lisp2li-let (expr env)
+ (mapcar (lambda (x) (add-binding env (car x) (lisp2li (cadr x) env))) (cadr expr)))
+
+(defun make-stat-env (env params)
+ (mapcar (lambda (x) (add-binding env x nil)) params)
+ env)
+
+(defun transform-quasiquote (expr)
+ (cond
+ ;; a
+ ((atom expr)
+ `',expr)
+ ;; (a)
+ ((atom (car expr))
+ `(cons ',(car expr)
+ ,(transform-quasiquote (cdr expr))))
+ ;; (,a)
+ ((eq my-unquote (caar expr))
+ `(cons ,(cadar expr)
+ ,(transform-quasiquote (cdr expr))))
+ ;; (,@a)
+ ((eq my-unquote-unsplice (caar expr))
+ (if (endp (cdr expr))
+ (cadar expr)
+ `(append ,(cadar expr)
+ ,(transform-quasiquote (cdr expr)))))
+ ;; ((a ...) ...)
+ (T
+ `(cons ,(transform-quasiquote (car expr))
+ ,(transform-quasiquote (cdr expr))))))
+
(defun lisp2li (expr env-var env-fun)
"Convertit le code LISP en un code intermédiaire reconnu
par le compilateur et par l’interpréteur"
@@ -39,9 +83,15 @@ par le compilateur et par l’interpréteur"
(lisp2li (second expr) env-var env-fun)
(lisp2li (third expr) env-var env-fun)
(lisp2li (fourth expr) env-var env-fun)))
- ;; quotes
+ ;; quote
((eq 'quote (car expr))
(cons :lit (second expr)))
+ ;; quasiquote `
+ ((eq my-quasiquote (car expr))
+ (lisp2li (transform-quasiquote (cadr expr)) env-var env-fun))
+ ;; #'fn (FUNCTION fn)
+ ((eq 'function (car expr))
+ (list :call 'function (car expr)))
;; defun
((eq 'defun (car expr))
(let ((env-bis (make-stat-env (push-new-env env-var "DEFUN") (third expr))))
@@ -51,6 +101,11 @@ par le compilateur et par l’interpréteur"
(map-lisp2li (cdddr expr)
env-bis env-fun)))))
(cons :lit (second expr)))
+ ;; defvar
+ ((eq 'defvar (car expr))
+ (add-top-level-binding env-var
+ (second expr)
+ (lisp2li (third expr) env-var env-fun)))
;; setq/setf
((eq 'setq (car expr))
(cons :call (cons 'set-binding (list `(:lit . ,env-var)
@@ -82,65 +137,56 @@ par le compilateur et par l’interpréteur"
((not (special-operator-p (car expr)))
(cons :call (cons (first expr) (map-lisp2li (cdr expr) env-var env-fun))))
(T
+ (print expr)
(error "special form not yet implemented ~S" (car expr)))
))
-(defun map-lisp2li (expr env-var env-fun)
- (mapcar (lambda (x) (lisp2li x env-var env-fun)) expr))
-
-(defun map-lisp2li-let (expr env)
- (mapcar (lambda (x) (add-binding env (car x) (lisp2li (cadr x) env))) (cadr expr)))
-
-(defun make-stat-env (env params)
- (mapcar (lambda (x) (add-binding env x nil)) params)
- env)
-
;; Test unitaire
(load "test-unitaire")
(erase-tests lisp2li)
-(deftest lisp2li
+(deftest (lisp2li :lit)
(lisp2li '3 () ())
'(:lit . 3))
-(deftest lisp2li
+(deftest (lisp2li :lit)
(lisp2li ''x () ())
'(:lit . x))
-(deftest lisp2li
+(deftest (lisp2li :lit)
(lisp2li ''(1 2 3) () ())
'(:lit 1 2 3))
;; test des if
-(deftest lisp2li
+(deftest (lisp2li :if)
(lisp2li '(if T T nil) () ())
'(:if (:lit . T) (:lit . T) (:lit . nil)))
-(deftest lisp2li
+(deftest (lisp2li :if)
(lisp2li '(if T nil T) () ())
'(:if (:lit . T) (:lit . nil) (:lit . T)))
;; test des fonctions predefinies
-(deftest lisp2li
+(deftest (lisp2li :call)
(lisp2li '(eq 1 1) () ())
'(:call eq (:lit . 1) (:lit . 1)))
-(deftest lisp2li
+(deftest (lisp2li macros)
(lisp2li '(and 1 1) () ())
'(:lit . 1))
;; test des variables
-(deftest lisp2li
+(deftest (lisp2li :var)
(lisp2li 'x '(("TOP-LEVEL" (x . 1) (y . 2))) ())
'(:var . x))
-(deftest lisp2li
+(deftest (lisp2li :var)
(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
+(deftest (lisp2li :var)
(lisp2li '(if (eq x 3)
(- z 3)
(- x 5))
@@ -149,19 +195,19 @@ par le compilateur et par l’interpréteur"
(:CALL - (:VAR . X) (:LIT . 5))))
;; Test avec des expression plus complexe
-(deftest lisp2li
+(deftest (lisp2li complexe)
(lisp2li '(if (eq 1 1) 2 2) () ())
'(:if (:call eq (:lit . 1) (:lit . 1)) (:lit . 2) (:lit . 2)))
-(deftest lisp2li
+(deftest (lisp2li complexe)
(lisp2li '(if (eq "abc" 1) "abc" 2) () ())
'(:IF (:CALL EQ (:LIT . "abc") (:LIT . 1)) (:LIT . "abc") (:LIT . 2)))
-(deftest lisp2li
+(deftest (lisp2li :unknown)
(lisp2li '(foo 1 1) () ())
'(:unknown (foo 1 1) ((("TOP-LEVEL")) ("TOP-LEVEL"))))
-(deftest lisp2li
+(deftest (lisp2li :unknown)
(lisp2li '(if (and (eq 1 1) (= 2 2)) (foo 1 2) (bar 3 4)) () ())
'(:IF (:CALL = (:LIT . 2)
(:LIT . 2))
@@ -169,13 +215,13 @@ par le compilateur et par l’interpréteur"
(:UNKNOWN (BAR 3 4) ((("TOP-LEVEL")) ("TOP-LEVEL")))))
;; Test sur le setq
-(deftestvar lisp2li env (add-binding (empty-env-stack) 'x 1))
-(deftest lisp2li
+(deftestvar (lisp2li setq) env (add-binding (empty-env-stack) 'x 1))
+(deftest (lisp2li setq)
(lisp2li '(setq x 2) env ())
'(:call set-binding (:lit . (("TOP-LEVEL" (x . 1)))) (:lit . x) (:lit . 2)))
;; Test sur le defun
-(deftest lisp2li
+(deftest (lisp2li defun valeur-de-retour)
(lisp2li '(defun fact (n r)
(if (= n 0)
r
@@ -183,6 +229,20 @@ par le compilateur et par l’interpréteur"
() ())
'(:lit . fact))
+(deftestvar (lisp2li defun environnement) env (empty-env-stack))
+(deftest (lisp2li defun environnement)
+ (progn
+ (lisp2li '(defun fact (n r)
+ (if (= n 0)
+ r
+ (fact (- n 1) (* n r))))
+ () env)
+ env)
+ '#1=(("TOP-LEVEL"
+ (FACT :LCLOSURE (#2=(("DEFUN" (R) (N)) ("TOP-LEVEL")) . #1#)
+ (:IF (:CALL = (:VAR . N) (:LIT . 0)) (:VAR . R)
+ (:UNKNOWN (FACT (- N 1) (* N R)) (#2# . #1#)))))))
+
;; Test sur la lambda expression
(deftest lisp2li
(lisp2li '(mapcar (lambda (x) x) '(1 2 3))
