diff --git a/lisp2li.lisp b/lisp2li.lisp index 1d08da5..c23d72e 100644 --- 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))) + ((: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 env) +(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 index bf14312..24d3980 100644 --- 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 index 45bd1d6..b7df50b 100644 --- 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))