Merge branch 'master' into compilation-georges
This commit is contained in:
Georges Dupéron
commit
4f64b21908
294
lisp2li.lisp
294
lisp2li.lisp
|
|
@ -21,25 +21,33 @@
|
|||
(,(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))
|
||||
(make-stat-env1 (cdr params) env position num-env))
|
||||
(T
|
||||
`((,(car params) ,num-env ,position)
|
||||
. ,(make-stat-env-optional (cdr params) env (+ 1 position) num-env)))))
|
||||
|
||||
(defun env-depth (env)
|
||||
(+ (or (second (first env)) -1) 1))
|
||||
(or (cadar (last env)) 0))
|
||||
|
||||
(defun make-stat-env (params &optional env (position 1) num-env)
|
||||
(unless num-env (setf num-env (env-depth)))
|
||||
(cond ((endp params)
|
||||
(defun recalculation (env)
|
||||
(cond ((endp env)
|
||||
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))))))
|
||||
`((,(caar env) ,(+ 1 (cadar env)) ,(caddar env))
|
||||
. ,(recalculation (cdr env))))))
|
||||
|
||||
(defun make-stat-env (params &optional env (position 1))
|
||||
(defun make-stat-env1 (params &optional env (position 1) num-env)
|
||||
(cond ((endp params)
|
||||
env)
|
||||
((eq '&optional (car params))
|
||||
(make-stat-env-optional (cdr params) env position num-env))
|
||||
((eq '&rest (car params))
|
||||
(make-stat-env1 (cdr params) env position num-env))
|
||||
(T
|
||||
`((,(car params) 0 ,position)
|
||||
. ,(make-stat-env1 (cdr params) env (+ 1 position) num-env)))))
|
||||
(make-stat-env1 params (recalculation env) position 0))
|
||||
|
||||
(defun transform-quasiquote (expr)
|
||||
(cond
|
||||
|
|
@ -82,22 +90,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,9 +157,18 @@ 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 (car expr) :defun)
|
||||
`(:mcall ,(car expr)
|
||||
,@(mapcar (lambda (x) (lisp2li x env)) (cdr expr))))
|
||||
;; macro meta-definie
|
||||
((get (car expr) :defmacro)
|
||||
`(:mcall ,(car expr)
|
||||
,@(mapcar (lambda (x) `(:const . ,x)) (cdr expr))))
|
||||
;; fonction inconnue
|
||||
((and (not (fboundp (car expr)))
|
||||
(not (get-defun (car expr))))
|
||||
(not (get (car expr) :defun))
|
||||
(not (get (car expr) :defmacro)))
|
||||
`(:unknown ,expr ,env))
|
||||
;; if
|
||||
((eq 'if (car expr))
|
||||
|
|
@ -153,7 +194,7 @@ par le compilateur et par l’interpréteur"
|
|||
(lambda (name value)
|
||||
(let ((cell (assoc name new-env)))
|
||||
`(:set-var (,(second cell) ,(third cell))
|
||||
,(lisp2li value env))))
|
||||
,(lisp2li value new-env))))
|
||||
names values)
|
||||
,(lisp2li (implicit-progn body) new-env)))))
|
||||
((eq 'let* (car expr))
|
||||
|
|
@ -166,21 +207,39 @@ 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)))
|
||||
;; defmacro
|
||||
((eq 'defmacro (car expr))
|
||||
`(:mcall set-defmacro (:const . ,(second expr))
|
||||
,(lisp2li `(lambda ,(third expr) ,@(cdddr expr)) env)))
|
||||
;; apply
|
||||
((eq 'apply (car expr))
|
||||
`(:sapply ,(second expr) ,@(cddr expr)))
|
||||
;; setf
|
||||
((eq 'setf (car expr))
|
||||
(if (symbolp (cadr expr))
|
||||
(let ((cell (assoc (cadr expr) env)))
|
||||
`(:set-var (,(second cell) ,(third cell))
|
||||
,(lisp2li (third expr) env)))
|
||||
`(:set-fun ,(caadr expr) ,@(last expr) ,@(cdadr expr))))
|
||||
(cond ((symbolp (cadr expr))
|
||||
(let ((cell (assoc (cadr expr) env)))
|
||||
`(:set-var (,(second cell) ,(third cell))
|
||||
,(lisp2li (third expr) env))))
|
||||
((symbolp (cdadr expr))
|
||||
(let ((cell (assoc (cdadr expr) env)))
|
||||
`(:set-var (,(second cell) ,(third cell))
|
||||
,(third expr))))
|
||||
(T
|
||||
`(:set-fun ,(caadr expr) ,@(last expr) ,@(cdadr expr)))))
|
||||
;; setq
|
||||
((eq 'setq (car expr))
|
||||
(lisp2li `(setf ,@(cdr expr)) env))
|
||||
;; defvar
|
||||
((eq 'defvar (car expr))
|
||||
(let ((var `(,(cadr expr)
|
||||
,(if (eq nil env) 0 (cadar (last env)))
|
||||
,(if (eq nil env) 1 (+ (caddar (last env)) 1)))))
|
||||
(setf env (append env `(,var)))
|
||||
(print env)
|
||||
`(:set-var (,(second var) ,(third var))
|
||||
,(third expr))))
|
||||
;; progn
|
||||
((eq 'progn (car expr))
|
||||
(cons :progn (map-lisp2li (cdr expr) env)))
|
||||
|
|
@ -189,14 +248,15 @@ par le compilateur et par l’interpréteur"
|
|||
(cons :const nil))
|
||||
;; macros
|
||||
((macro-function (car expr))
|
||||
(lisp2li (macroexpand expr) env))
|
||||
(lisp2li (macroexpand-1 expr) env))
|
||||
;; foctions normales
|
||||
((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)))))
|
||||
|
||||
;; TODO : demander au prof comment corriger (or (= n 0) (= n 1)) qui rend nil car il fait 2 macroexpand 1: (COND ((= N 0)) (T (= N 1))) 2: (LET (#1=#:RESULT-7048) (IF (SETQ #1# (= N 0)) #1# (= N 1))) et 2 vaux nil car n != 0
|
||||
|
||||
;; Test unitaire
|
||||
(load "test-unitaire")
|
||||
(erase-tests lisp2li)
|
||||
|
|
@ -211,7 +271,7 @@ par le compilateur et par l’interpréteur"
|
|||
|
||||
(deftest (lisp2li make-stat-env)
|
||||
(make-stat-env '(a b) '((x 0 1) (y 0 2)))
|
||||
'((a 1 1) (b 1 2) (x 0 1) (y 0 2)))
|
||||
'((a 0 1) (b 0 2) (x 1 1) (y 1 2)))
|
||||
|
||||
(deftest (lisp2li make-stat-env)
|
||||
(make-stat-env '(a b &optional c &rest d))
|
||||
|
|
@ -221,111 +281,111 @@ par le compilateur et par l’interpréteur"
|
|||
(make-stat-env '(x y &optional (z t)))
|
||||
'((x 0 1) (y 0 2) (z 0 3) (z-p 0 4)))
|
||||
|
||||
(deftest (lisp2li simplify :progn)
|
||||
(simplify '(:progn (:const . 3)))
|
||||
'(:const . 3))
|
||||
;; (deftest (lisp2li simplify :progn)
|
||||
;; (simplify '(:progn (:const . 3)))
|
||||
;; '(:const . 3))
|
||||
|
||||
(deftest (lisp2li simplify :progn)
|
||||
(simplify '(:progn (:call list (:const . 1) (:const . 2))))
|
||||
'(:call list (:const . 1) (:const . 2)))
|
||||
;; (deftest (lisp2li simplify :progn)
|
||||
;; (simplify '(:progn (:call list (:const . 1) (:const . 2))))
|
||||
;; '(:call list (:const . 1) (:const . 2)))
|
||||
|
||||
(deftest (lisp2li simplify :progn)
|
||||
(simplify '(:progn (:progn (:const . 3) (:const . 4))))
|
||||
'(:progn (:const . 3) (:const . 4)))
|
||||
;; (deftest (lisp2li simplify :progn)
|
||||
;; (simplify '(:progn (:progn (:const . 3) (:const . 4))))
|
||||
;; '(:progn (:const . 3) (:const . 4)))
|
||||
|
||||
(deftest (lisp2li simplify :progn)
|
||||
(simplify '(:progn (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6))))
|
||||
'(:progn (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
;; (deftest (lisp2li simplify :progn)
|
||||
;; (simplify '(:progn (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6))))
|
||||
;; '(:progn (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
|
||||
(deftest (lisp2li simplify :progn)
|
||||
(simplify '(:progn (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
|
||||
'(:progn (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
;; (deftest (lisp2li simplify :progn)
|
||||
;; (simplify '(:progn (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
|
||||
;; '(:progn (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
|
||||
(deftest (lisp2li simplify :progn)
|
||||
(simplify '(:progn (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
|
||||
'(:progn (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
|
||||
;; (deftest (lisp2li simplify :progn)
|
||||
;; (simplify '(:progn (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
|
||||
;; '(:progn (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
|
||||
|
||||
(deftest (lisp2li simplify :let-progn)
|
||||
(simplify '(:let (:progn (:const . 3) (:const . 4))))
|
||||
'(:let (:const . 3) (:const . 4)))
|
||||
;; (deftest (lisp2li simplify :let-progn)
|
||||
;; (simplify '(:let (:progn (:const . 3) (:const . 4))))
|
||||
;; '(:let (:const . 3) (:const . 4)))
|
||||
|
||||
(deftest (lisp2li simplify :let-progn)
|
||||
(simplify '(:let (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6))))
|
||||
'(:let (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
;; (deftest (lisp2li simplify :let-progn)
|
||||
;; (simplify '(:let (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6))))
|
||||
;; '(:let (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
|
||||
(deftest (lisp2li simplify :let-progn)
|
||||
(simplify '(:let (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
|
||||
'(:let (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
;; (deftest (lisp2li simplify :let-progn)
|
||||
;; (simplify '(:let (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
|
||||
;; '(:let (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
|
||||
(deftest (lisp2li simplify :let-progn)
|
||||
(simplify '(:let (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
|
||||
'(:let (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
|
||||
;; (deftest (lisp2li simplify :let-progn)
|
||||
;; (simplify '(:let (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
|
||||
;; '(:let (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
|
||||
|
||||
(deftest (lisp2li simplify :progn-let)
|
||||
(simplify '(:progn (:let 0 (:const . 3) (:const . 4))))
|
||||
'(:let 0 (:const . 3) (:const . 4)))
|
||||
;; (deftest (lisp2li simplify :progn-let)
|
||||
;; (simplify '(:progn (:let 0 (:const . 3) (:const . 4))))
|
||||
;; '(:let 0 (:const . 3) (:const . 4)))
|
||||
|
||||
(deftest (lisp2li simplify :progn-let)
|
||||
(simplify '(:progn (:let 2 (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6)))))
|
||||
'(:let 2 (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
;; (deftest (lisp2li simplify :progn-let)
|
||||
;; (simplify '(:progn (:let 2 (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6)))))
|
||||
;; '(:let 2 (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
|
||||
(deftest (lisp2li simplify :progn-let)
|
||||
(simplify '(:progn (:const . 1) (:const . 2) (:let 1 (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
|
||||
'(:let 1 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
;; (deftest (lisp2li simplify :progn-let)
|
||||
;; (simplify '(:progn (:const . 1) (:const . 2) (:let 1 (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
|
||||
;; '(:let 1 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
|
||||
(deftest (lisp2li simplify :progn-let)
|
||||
(simplify '(:progn (:const . 1) (:const . 2) (:let 5 (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
|
||||
'(:let 5 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
|
||||
;; (deftest (lisp2li simplify :progn-let)
|
||||
;; (simplify '(:progn (:const . 1) (:const . 2) (:let 5 (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
|
||||
;; '(:let 5 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
|
||||
|
||||
(deftest (lisp2li simplify :let-let)
|
||||
(simplify '(:let 1 (:let 1 (:const . 3) (:const . 4))))
|
||||
'(:let 2 (:const . 3) (:const . 4)))
|
||||
;; (deftest (lisp2li simplify :let-let)
|
||||
;; (simplify '(:let 1 (:let 1 (:const . 3) (:const . 4))))
|
||||
;; '(:let 2 (:const . 3) (:const . 4)))
|
||||
|
||||
(deftest (lisp2li simplify :let-let)
|
||||
(simplify '(:let 3 (:let 2 (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6)))))
|
||||
'(:let 5 (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
;; (deftest (lisp2li simplify :let-let)
|
||||
;; (simplify '(:let 3 (:let 2 (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6)))))
|
||||
;; '(:let 5 (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
|
||||
(deftest (lisp2li simplify :let-let)
|
||||
(simplify '(:let 2 (:const . 1) (:const . 2) (:let 1 (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
|
||||
'(:let 3 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
;; (deftest (lisp2li simplify :let-let)
|
||||
;; (simplify '(:let 2 (:const . 1) (:const . 2) (:let 1 (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
|
||||
;; '(:let 3 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||||
|
||||
(deftest (lisp2li simplify :let-let)
|
||||
(simplify '(:let 5 (:const . 1) (:const . 2) (:let 5 (:const . 3) (:const . 4)) (:const . 5) (:let 2 (:const . 6) (:const . 7))))
|
||||
'(:let 12 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
|
||||
;; (deftest (lisp2li simplify :let-let)
|
||||
;; (simplify '(:let 5 (:const . 1) (:const . 2) (:let 5 (:const . 3) (:const . 4)) (:const . 5) (:let 2 (:const . 6) (:const . 7))))
|
||||
;; '(:let 12 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
|
||||
|
||||
(deftest (lisp2li simplify :if)
|
||||
(simplify '(:if (:const . nil) (:call list 1 2 3) (:const . T)))
|
||||
'(:const . T))
|
||||
;; (deftest (lisp2li simplify :if)
|
||||
;; (simplify '(:if (:const . nil) (:call list 1 2 3) (:const . T)))
|
||||
;; '(:const . T))
|
||||
|
||||
(deftest (lisp2li simplify :if)
|
||||
(simplify '(:if (:const . nil) (:progn (:let 2 (:const . 1)) (:const . 2)) (:call list (:const 1 2 3))))
|
||||
'(:call list (:const 1 2 3)))
|
||||
;; (deftest (lisp2li simplify :if)
|
||||
;; (simplify '(:if (:const . nil) (:progn (:let 2 (:const . 1)) (:const . 2)) (:call list (:const 1 2 3))))
|
||||
;; '(:call list (:const 1 2 3)))
|
||||
|
||||
(deftest (lisp2li simplify :if)
|
||||
(simplify '(:if (:const . nil) (:const . nil) (:progn (:let 2 (:const . 1)) (:const . 2)) ))
|
||||
'(:call list (:const 1 2 3)))
|
||||
;; (deftest (lisp2li simplify :if)
|
||||
;; (simplify '(:if (:const . nil) (:const . nil) (:progn (:let 2 (:const . 1)) (:const . 2)) ))
|
||||
;; '(:let 2 (:const . 1) (:const . 2)))
|
||||
|
||||
(deftest (lisp2li simplify :if)
|
||||
(simplify '(:if (:const . 2) (:const .nil) (:const . T)))
|
||||
'(:const . nil))
|
||||
;; (deftest (lisp2li simplify :if)
|
||||
;; (simplify '(:if (:const . 2) (:const . nil) (:const . T)))
|
||||
;; '(:const . nil))
|
||||
|
||||
(deftest (lisp2li simplify :if)
|
||||
(simplify '(:if (:const . T) (:const . 3) (:const . 4)))
|
||||
'(:const . 4))
|
||||
;; (deftest (lisp2li simplify :if)
|
||||
;; (simplify '(:if (:const . T) (:const . 3) (: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)))
|
||||
;; (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)))
|
||||
|
||||
(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)
|
||||
|
|
@ -359,11 +419,11 @@ par le compilateur et par l’interpréteur"
|
|||
|
||||
(deftest (lisp2li defun)
|
||||
(lisp2li '(defun bar (x) x) ())
|
||||
'(:call set-defun (:const . bar) (:lclosure 1 :cvar 0 1)))
|
||||
'(:mcall set-defun (:const . bar) (:lclosure 1 :cvar 0 1)))
|
||||
|
||||
(deftest (lisp2li defun)
|
||||
(lisp2li '(defun foo (x y z) (list x y z)) ())
|
||||
'(:call set-defun (:const . foo)
|
||||
'(:mcall set-defun (:const . foo)
|
||||
(:lclosure 3 :call list
|
||||
(:cvar 0 1)
|
||||
(:cvar 0 2)
|
||||
|
|
@ -482,13 +542,13 @@ par le compilateur et par l’interpréteur"
|
|||
(deftest (lisp2li let)
|
||||
(lisp2li '(let ((x z) (y 2))
|
||||
(cons x y)) '((z 0 1)))
|
||||
'(:let 2 (:set-var (1 1) (:cvar 0 1))
|
||||
(:set-var (1 2) (:const . 2))
|
||||
(:call cons (:cvar 1 1) (:cvar 1 2))))
|
||||
'(:let 2 (:set-var (0 1) (:cvar 1 1))
|
||||
(:set-var (0 2) (:const . 2))
|
||||
(:call cons (:cvar 0 1) (:cvar 0 2))))
|
||||
|
||||
(deftest (lisp2li let)
|
||||
(lisp2li '(let ((x 2))
|
||||
(cons x z)) '((z 0 1)))
|
||||
'(:let 1 (:set-var (1 1) (:const . 2))
|
||||
(:call cons (:cvar 1 1) (:cvar 0 1))))
|
||||
'(:let 1 (:set-var (0 1) (:const . 2))
|
||||
(:call cons (:cvar 0 1) (:cvar 1 1))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(setq *print-circle* t)
|
||||
;(setq *print-circle* t)
|
||||
(load "environnement")
|
||||
(load "instructions")
|
||||
(load "lisp2li")
|
||||
|
|
|
|||
102
meval.lisp
102
meval.lisp
|
|
@ -1,15 +1,29 @@
|
|||
(load "match")
|
||||
|
||||
(defun get-env-num (num env)
|
||||
"Récupère l’environnement correspondant à celui souhaité."
|
||||
(defun get-env-num-t (num env counter)
|
||||
(cond ((= counter num) env)
|
||||
((eq (aref env 0) nil) nil)
|
||||
(T
|
||||
(get-env-num-t num (aref env 0) (+ 1 counter))
|
||||
)))
|
||||
(get-env-num-t num env 0))
|
||||
(defun env-size (env)
|
||||
(if (or (equalp env #()) (eq env nil))
|
||||
0
|
||||
(+ 1 (env-size (aref env 0)))))
|
||||
|
||||
(defun get-env-num (num env)
|
||||
"Récupère l’environnement correspondant à celui souhaité."
|
||||
(defun get-env-num-r (num env counter)
|
||||
(cond ((or (equalp env #()) (eq env nil))
|
||||
env)
|
||||
((= num counter)
|
||||
env)
|
||||
(T
|
||||
(get-env-num-t num (aref env 0) (- counter 1)))))
|
||||
(get-env-num-r num env (- (env-size env) 1)))
|
||||
|
||||
(defun current-env (env)
|
||||
(let ((env-size (- (env-size env) 1)))
|
||||
(defun current-env-r (env counter)
|
||||
(if (= counter env-size)
|
||||
env
|
||||
(current-env-r (aref env 0) (+ counter 1))))
|
||||
(current-env-r env 0)))
|
||||
|
||||
(defun get-lower-env (env)
|
||||
"Récupère l’environnement le plus bas"
|
||||
(if (or (= (array-total-size env) 0)
|
||||
|
|
@ -37,16 +51,17 @@ du &rest dans une cellule de l'env sous forme d'une liste"
|
|||
correspondantes et signale une exception si paramètres et arguments
|
||||
ne concordent pas. Si l’environnement passe en paramètre n’est pas vide,
|
||||
le nouvel environnement y est inclus."
|
||||
(cond ((and (not pos-rest)
|
||||
(< size (length list-values)))
|
||||
(error "Too arguments"))
|
||||
((> size (length list-values))
|
||||
(error "Too few arguments"))
|
||||
(T
|
||||
(if (= (array-total-size env) 0)
|
||||
(setf env (make-array (+ 1 size)))
|
||||
(setf (aref (get-lower-env env) 0) (make-array (+ 1 size))))
|
||||
(let ((lower-env (get-lower-env env)))
|
||||
(let ((new-env (copy-all env)))
|
||||
(cond ((and (not pos-rest)
|
||||
(< size (length list-values)))
|
||||
(error "Too arguments"))
|
||||
((> size (length list-values))
|
||||
(error "Too few arguments"))
|
||||
(T
|
||||
(if (= (array-total-size new-env) 0)
|
||||
(setf new-env (make-array (+ 1 size)))
|
||||
(setf (aref (get-lower-env new-env) 0) (make-array (+ 1 size))))
|
||||
(let ((lower-env (get-lower-env new-env)))
|
||||
(if pos-rest
|
||||
(make-rest lower-env
|
||||
list-values
|
||||
|
|
@ -56,7 +71,7 @@ du &rest dans une cellule de l'env sous forme d'une liste"
|
|||
for rank = 1 then (+ rank 1)
|
||||
do (setf (aref lower-env rank) value)
|
||||
)))
|
||||
env)))
|
||||
new-env))))
|
||||
|
||||
(defun map-meval (list env)
|
||||
(mapcar (lambda (x) (meval x env)) list))
|
||||
|
|
@ -95,37 +110,60 @@ d’arguments dans un certain environnement."
|
|||
(setf (aref sub-env (second place))
|
||||
(meval val env)))))
|
||||
|
||||
(defun make-closure (lmbd env)
|
||||
`(,lmbd . ,env))
|
||||
|
||||
(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
|
||||
((:nil :const :val . _) expr val)
|
||||
((:nil :cvar :num-env (? integerp) :index (? integerp))
|
||||
(let ((sub-env (get-env-num num-env env)))
|
||||
(if sub-env
|
||||
(aref sub-env index)
|
||||
(error "The variable unbound : ~w" expr))))
|
||||
(if (= num-env 0)
|
||||
(aref (current-env env) index)
|
||||
(let ((sub-env (get-env-num num-env env)))
|
||||
(if sub-env
|
||||
(aref sub-env index)
|
||||
(error "The variable unbound : ~w" expr)))))
|
||||
((:nil :if :predicat @. :expr1 @. :expr2 @.)
|
||||
(if (meval predicat env)
|
||||
(meval expr1 env)
|
||||
(meval expr2 env)))
|
||||
((:nil :call :func-name _ :body _*)
|
||||
(apply (symbol-function func-name) (map-meval body env)))
|
||||
((:nil :mcall set-defun :func-name @. :closure _*)
|
||||
(let ((name (meval func-name env)))
|
||||
(setf (get name :defun) closure)
|
||||
name))
|
||||
((:nil :mcall set-defmacro :macro-name @. :closure _*)
|
||||
(let ((name (meval macro-name env)))
|
||||
(setf (get name :defmacro) closure)
|
||||
name))
|
||||
((:nil :mcall :func-name (? (get x :defun)) :params _*)
|
||||
(let ((values (meval-args params env)))
|
||||
(meval-lambda (car (get func-name :defun))
|
||||
values
|
||||
(make-env (length values) values env))))
|
||||
((:nil :mcall :macro-name (? (get x :defmacro)) :params _*)
|
||||
(let ((values (meval-args params env)))
|
||||
(meval (lisp2li (meval-lambda (car (get macro-name :defmacro))
|
||||
params
|
||||
(make-env (length values) values env))
|
||||
env)
|
||||
env)))
|
||||
((:nil :mcall :lambda (:nil :lclosure (? integerp) (? integerp)? _*) :args _*)
|
||||
(meval-lambda lambda (meval-args args env) env))
|
||||
((:nil :call :func-name _ :body _*)
|
||||
(apply (symbol-function func-name) (meval-args body env)))
|
||||
((:nil :progn :body @.+)
|
||||
(meval-body body env))
|
||||
((:nil :lclosure (? integerp) (? integerp)? :body _*)
|
||||
((:nil :lclosure :size (? integerp) :rest (? integerp)? :body _*)
|
||||
(meval-body `(,body) env))
|
||||
((: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))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user