commit 3d4f11147be704c7c0a38a1e3b99b1eac5315398
parent 564293eac05f64de4457d87bf71dc87b4b71b7a9
Author: Bertrand BRUN <bertrand.brun@me.com>
Date: Fri, 12 Nov 2010 01:36:49 +0100
Manque la gestion des variables dans simplify + ajout de la gestion des defuns dans lisp2li et meval
Diffstat:
3 files changed, 69 insertions(+), 33 deletions(-)
diff --git a/lisp2li.lisp b/lisp2li.lisp
@@ -30,7 +30,7 @@
(+ (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)))
+ (unless num-env (setf num-env (env-depth env)))
(cond ((endp params)
env)
((eq '&optional (car params))
@@ -82,22 +82,46 @@
(cons 'progn expr)
(car expr)))
-(defun simplify (li)
+
+(defun simplify (li) ;; TODO : a finir
(cond-match li
((:nil :progn :expr _)
(simplify expr))
- ((:nil :progn _* (:nil :progn :body1 _*)+ :body2 _*)
- (simplify `(:progn body1 body2)))
- ((:nil :let _* (:nil :progn :body1 _*)+ :body2 _*)
- (simplify `))
- (_* li)))
-
-(defun lisp2li (expr env)
+ ((:nil :progn :body0 _* (:nil :progn :body1 _*)+ :body2 _*)
+ (simplify `(:progn ,@body0 ,@(car body1) ,@body2)))
+ ((:nil :progn :body0 _* (:nil :let :size (? integerp) :body1 _*)+ :body2 _*)
+ (simplify `(:let ,@size ,@body0 ,@(car body1) ,@body2)))
+ ((:nil :let :size1 (? integerp) :body1 _*
+ (:nil :let :size2 (? integerp)
+ (:nil :set-var (:depth-set (? integerp) :index-set (? integerp)) @.)+
+ :var1 (:nil :cvar :depth1 (? integerp) :index1 (? integerp))*
+ :body2 _* :var2 (:nil :cvar :depth2 (? integerp) :index2 (? integerp))*)
+ :body3 _*)
+ (simplify `(:let ,(+ size1 size2)
+ ,@body1
+ ,@(mapcar
+ (lambda (depth index)
+ `(:cvar ,(- depth 1) ,(+ index size1))) depth1 index1)
+ ,@body2
+ ,@(if (and depth2 index2)
+ (mapcar
+ (lambda (depth index)
+ `(:cvar ,(- depth 1) ,(+ index size1))) depth2 index2))
+ ,@body3)))
+ ((:nil :let :body0 _* (:nil :progn :body1 _*)+ :body2 _*)
+ (simplify `(:let ,@body0 ,@(car body1) ,@body2)))
+ ((:nil :let :size1 (? integerp) :body0 _* (:nil :let :size2 (? integerp) :body1 _*)+ :body2 _*)
+ (simplify `(:let ,(+ size1 (car size2)) ,@body0 ,@(car body1) ,@body2)))
+ ((:nil :if (:nil :const :cond . _) :then @. :else @.)
+ (simplify (if cond then else)))
+ (@. li)))
+
+(defun lisp2li (expr &optional env)
"Convertit le code LISP en un code intermédiaire reconnu
par le compilateur et par l’interpréteur"
(cond
;; literaux
- ((and (atom expr) (constantp expr))
+ ((and (atom expr) (constantp expr))
(cons :const expr))
;; symboles
((symbolp expr)
@@ -125,6 +149,10 @@ par le compilateur et par l’interpréteur"
;; (not-symbol ...)
((not (symbolp (car expr)))
(warn "~S isn't a symbol" (car expr)))
+ ;; fonction meta-definie
+ ((get-defun (car expr))
+ `(:mcall ,(car expr)
+ ,@(mapcar (lambda (x) (lisp2li x env)) (cdr expr))))
;; fonction inconnue
((and (not (fboundp (car expr)))
(not (get-defun (car expr))))
@@ -166,7 +194,7 @@ par le compilateur et par l’interpréteur"
,@body)) env))))
;; defun
((eq 'defun (car expr))
- `(:call set-defun (:const . ,(second expr))
+ `(:mcall set-defun (:const . ,(second expr))
,(lisp2li `(lambda ,(third expr) ,@(cdddr expr)) env)))
;; apply
((eq 'apply (car expr))
@@ -194,7 +222,6 @@ par le compilateur et par l’interpréteur"
((not (special-operator-p (car expr)))
`(:call ,(first expr) ,@(map-lisp2li (cdr expr) env)))
(T
- (print expr)
(error "special form not yet implemented ~S" (car expr)))))
;; Test unitaire
@@ -303,29 +330,29 @@ par le compilateur et par l’interpréteur"
(deftest (lisp2li simplify :if)
(simplify '(:if (:const . nil) (:const . nil) (:progn (:let 2 (:const . 1)) (:const . 2)) ))
- '(:call list (:const 1 2 3)))
+ '(:let 2 (:const . 1) (:const . 2)))
(deftest (lisp2li simplify :if)
- (simplify '(:if (:const . 2) (:const .nil) (:const . T)))
+ (simplify '(:if (:const . 2) (:const . nil) (:const . T)))
'(:const . nil))
(deftest (lisp2li simplify :if)
(simplify '(:if (:const . T) (:const . 3) (:const . 4)))
- '(: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) (:const . 4)))
+ '(:let 7 (:const . 3) (:const . 4)))
-(deftest (lisp2li simplify :let-cvar)
- (simplify '(:let 3 (:const . T) (:let 4 (:cvar 0 1) (:const . 4))))
- '(:let 7 (:const . T) (:cvar 0 1) (: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 (:CONST . T)
- (:LET (:PROGN (:CVAR 0 1) (:cvar 1 1) (:cvar 2 1) (:CONST . 4))))))
- '(:let 6 (:const . T) (:cvar 0 1) (:cvar 0 1) (:cvar 0 2)))
+;; (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)
diff --git a/meval.lisp b/meval.lisp
@@ -101,6 +101,11 @@ d’arguments dans un certain environnement."
(defun meval-closure (clos args)
(meval-lambda (cadr clos) args (cddr clos)))
+(defun make-empty-list (size)
+ (if (= size 0)
+ nil
+ (cons nil (make-empty-list (- size 1)))))
+
(defun meval (expr &optional (env #()))
"Interprète le langage intermédiaire passé en paramètre."
(cond-match expr
@@ -118,14 +123,25 @@ d’arguments dans un certain environnement."
(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))
((:nil :progn :body @.+)
(meval-body body env))
- ((:nil :lclosure (? integerp) (? integerp)? :body _*)
- (meval-body `(,body) env))
+ ((:nil :lclosure :size (? integerp) :rest (? integerp)? :body _*)
+ (meval-body `(,body) (make-env size
+ (make-empty-list size)
+ env
+ rest)))
((:nil :set-var :place @. :value _)
(msetf place value env))
((:nil :let :size (? integerp) :affectations (:nil :set-var :places @ :values _)* :body _*)
(meval-body body (make-env size (meval-args values env) env)))
+ ((:nil :unknown :call (:name $ :params _*) :environ _*)
+ (lisp2li call environ))
(_*
(error "form special ~S not yet implemented" expr))))
diff --git a/util.lisp b/util.lisp
@@ -80,13 +80,6 @@
macro ;; Pour éviter le unused variable.
())
-(defmacro get-defun (symb)
- `(get ,symb :defun))
-
-(defun set-defun (symb expr)
- (setf (get-defun symb)
- expr))
-
(defmacro get-defmacro (symb)
`(get ,symb :defmacro))
