Merge branch 'master' of github.com:dumbs/2010-m1s1-compilation
Conflicts: main.lisp
This commit is contained in:
SliTaz User
commit
77b3ec876c
|
|
@ -156,7 +156,7 @@ et termine par la liste APPEND."
|
|||
(defun ISN-JMP (vm dst)
|
||||
(set-register vm 'PC (- dst 1)))
|
||||
|
||||
(defun JSR (vm dst)
|
||||
(defun ISN-JSR (vm dst)
|
||||
(ISN-PUSH vm 'PC)
|
||||
(ISN-JMP vm dst))
|
||||
|
||||
|
|
@ -268,5 +268,3 @@ et termine par la liste APPEND."
|
|||
(get-memory vm (get-register vm 'SP)))
|
||||
(t-r1-value))
|
||||
|
||||
|
||||
(dump-vm vm)
|
||||
|
|
|
|||
131
lisp2li.lisp
Normal file
131
lisp2li.lisp
Normal file
|
|
@ -0,0 +1,131 @@
|
|||
;; TODO : reste a gerer les defuns, les let, les lambda expression, les setf, les progn, ...
|
||||
(defun lisp2li (expr env)
|
||||
(cond ((and (atom expr) (constantp expr)) ; literaux
|
||||
(cons :lit expr))
|
||||
((symbolp expr) ; symboles
|
||||
(let ((cell (get-binding env expr)))
|
||||
(if cell
|
||||
(cons :var (car cell))
|
||||
(warn "Variable ~S unknown" (car expr)))))
|
||||
((and (consp (car expr)) ; λ-expressions
|
||||
; => recursion sur arguments
|
||||
; => construction environnement
|
||||
; => recursion sur corps de la λ-fonction
|
||||
(eq 'lambda (caar expr)))
|
||||
(error "Lambda expression NYI"))
|
||||
((not (symbolp (car expr)))
|
||||
(warn "~S isn't a symbol" (car expr)))
|
||||
((not (fboundp (car expr)))
|
||||
(list :unknown expr env))
|
||||
((eq 'if (car expr)) ; if
|
||||
(list :if
|
||||
(lisp2li (second expr) env)
|
||||
(lisp2li (third expr) env)
|
||||
(lisp2li (fourth expr) env)))
|
||||
((eq 'quote (car expr)) ;; quotes
|
||||
(cons :lit (second expr)))
|
||||
((eq 'defun (car expr)) ;; TODO : a verifier que le cas de defun est bien gerer comme on le veux
|
||||
(cons :call (cons 'add-binding (list (list :call 'push-new-env `(:lit . ,env) '(:lit . "DEFUN"))
|
||||
(cons :lit (second expr))
|
||||
(cons :lit (cons (length (third expr))
|
||||
(lisp2li (fourth expr)
|
||||
(make-stat-env env (third expr)))))))))
|
||||
((eq 'setq (car expr))
|
||||
(cons :call (cons 'set-binding (list `(:lit . ,env)
|
||||
(cons :lit (second expr))
|
||||
(cons :lit (third expr))))))
|
||||
((macro-function (car expr))
|
||||
(lisp2li (macroexpand-1 expr) env)) ; macros
|
||||
((not (special-operator-p (car expr))) ; fonctions normales. (Attention) sur sbcl special-form-p ne marche pas il faut utiliser special-operator-p
|
||||
; => recursion sur tous les arguments
|
||||
; => eventuellement construction d'environnement
|
||||
; => et analyse du corps de la fonction appelee
|
||||
(cons :call (cons (first expr) (map-lisp2li (cdr expr) env))))
|
||||
(T
|
||||
(error "special forme NYI ~S" (car expr)))
|
||||
))
|
||||
|
||||
(defun map-lisp2li (expr env)
|
||||
(mapcar (lambda (x) (lisp2li x env)) expr))
|
||||
|
||||
(defun make-stat-env (env params) ;; TODO : Verifier si on ne doit pas plutot chercher s'il existe pas deja un environnement avec la valeur et le mettre plutot que nil.
|
||||
(mapcar (lambda (x) (add-binding env x nil)) params)
|
||||
env)
|
||||
|
||||
;; Test unitaire
|
||||
(load "test-unitaire")
|
||||
;(erase-tests)
|
||||
|
||||
(deftest lisp2li
|
||||
(lisp2li '3 ())
|
||||
'(:lit . 3))
|
||||
|
||||
(deftest lisp2li
|
||||
(lisp2li ''x ())
|
||||
'(:lit . x))
|
||||
|
||||
(deftest lisp2li
|
||||
(lisp2li ''(1 2 3) ())
|
||||
'(:lit 1 2 3))
|
||||
|
||||
;; test des if
|
||||
(deftest lisp2li
|
||||
(lisp2li '(if T T nil) ())
|
||||
'(:if (:lit . T) (:lit . T) (:lit . nil)))
|
||||
|
||||
(deftest lisp2li
|
||||
(lisp2li '(if T nil T) ())
|
||||
'(:if (:lit . T) (:lit . nil) (:lit . T)))
|
||||
|
||||
;; test des fonctions predefinies
|
||||
(deftest lisp2li
|
||||
(lisp2li '(eq 1 1) ())
|
||||
'(:call eq (:lit . 1) (:lit . 1)))
|
||||
|
||||
(deftest lisp2li
|
||||
(lisp2li '(and 1 1) ())
|
||||
'(:lit . 1))
|
||||
|
||||
;; test des variables
|
||||
(deftest lisp2li
|
||||
(lisp2li 'x '(("TOP-LEVEL" (x . 1) (y . 2))))
|
||||
'(:var . x))
|
||||
|
||||
(deftest lisp2li
|
||||
(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
|
||||
(lisp2li '(if (eq x 3)
|
||||
(- z 3)
|
||||
(- x 5))
|
||||
'(("TEST" (z . 5)) ("TOP-LEVEL" (x . 4))))
|
||||
'(:IF (:CALL EQ (:VAR . X) (:LIT . 3)) (:CALL - (:VAR . Z) (:LIT . 3))
|
||||
(:CALL - (:VAR . X) (:LIT . 5))))
|
||||
|
||||
;; Test avec des expression plus complexe
|
||||
(deftest lisp2li
|
||||
(lisp2li '(if (eq 1 1) 2 2) ())
|
||||
'(:if (:call eq (:lit . 1) (:lit . 1)) (:lit . 2) (:lit . 2)))
|
||||
|
||||
(deftest lisp2li
|
||||
(lisp2li '(if (eq "abc" 1) "abc" 2) ())
|
||||
'(:IF (:CALL EQ (:LIT . "abc") (:LIT . 1)) (:LIT . "abc") (:LIT . 2)))
|
||||
|
||||
(deftest lisp2li
|
||||
(lisp2li '(foo 1 1) ())
|
||||
'(:unknown (foo 1 1) ()))
|
||||
|
||||
(deftest lisp2li
|
||||
(lisp2li '(if (and (eq 1 1) (= 2 2)) (foo 1 2) (bar 3 4)) ())
|
||||
'(:IF (:CALL = (:LIT . 2) (:LIT . 2)) (:UNKNOWN (FOO 1 2) NIL) (:UNKNOWN (BAR 3 4) NIL)))
|
||||
|
||||
;; Test sur le setq
|
||||
(deftestvar lisp2li env (add-binding (empty-env-stack) 'x 1))
|
||||
(deftest lisp2li
|
||||
(lisp2li '(setq x 2) env)
|
||||
'(:call set-binding (:lit (("TOP-LEVEL" (x . 1)))) (:lit . x) (:lit . 2)))
|
||||
|
||||
;(run-tests t)
|
||||
|
|
@ -1,5 +1,8 @@
|
|||
(load "environnement")
|
||||
(load "instructions")
|
||||
(load "lisp2li")
|
||||
(load "meval")
|
||||
;; ...
|
||||
(run-tests)
|
||||
;(run-tests t)
|
||||
;(print-env-stack exemple-env-stack)
|
||||
|
|
|
|||
91
meval.lisp
91
meval.lisp
|
|
@ -1,37 +1,72 @@
|
|||
;; meval donnee en cours
|
||||
|
||||
(defun meval (expr env)
|
||||
(cond ((and (atom expr) (constantp expr)) expr) ;; Literal
|
||||
((atom expr) ;; symboles
|
||||
(let ((cell (assoc expr env)))
|
||||
(if cell (cdr cell)
|
||||
(error ""))))
|
||||
;; .
|
||||
;; .
|
||||
;; .
|
||||
((eq 'quote (car expr)) (cadr expr)) ;;Quote (' ou quote)
|
||||
((and (consp (car expr)) (eq 'lambda (caar expr)))
|
||||
(meval-lambda (car expr) (cdr expr) env env)) ;; TODO : a remplir
|
||||
((eq 'defun (car expr))
|
||||
(set-defun (cadr expr) (cons 'lambda (cddr expr))) ;; TODO : sera remplacer par add-top-level-binding
|
||||
(get-defun (car expr))
|
||||
(meval-lambda (get-defun (car expr)) (cdr expr) env ()))
|
||||
((eq 'if (car expr))
|
||||
(cond ((eq ':lit (first expr))
|
||||
(cdr expr))
|
||||
((eq ':var (first expr))
|
||||
(let ((cell (get-binding env (cdr expr))))
|
||||
(if cell
|
||||
(cdr cell)
|
||||
(error "The variable ~S is unbound" (cdr expr)))))
|
||||
((eq ':if (car expr))
|
||||
(if (meval (second expr) env)
|
||||
(meval (third expr) env)
|
||||
(meval (fourth expr) env)))
|
||||
;;cas des marcros/forme speciale deja traiter
|
||||
((fboundp (car expr)) ;;denier cas vrais fonctin globale predefinie
|
||||
(apply (car expr) (map-meval (cdr expr) env))
|
||||
)
|
||||
((eq ':call (first expr))
|
||||
(apply (second expr) (map-meval (cddr expr) env)))
|
||||
))
|
||||
|
||||
(defun map-meval (list env)
|
||||
(mapcar (lambda (x) (meval x env)) list))
|
||||
|
||||
(defun meval-lambda (lbd args env-args old-env)
|
||||
(meval (third (car lbd))
|
||||
(make-env (second (car lbd))
|
||||
(map-meval args env-args)
|
||||
old-env))
|
||||
)
|
||||
;; Test unitaire
|
||||
(deftest meval
|
||||
(meval '(:lit . 3) ())
|
||||
3)
|
||||
|
||||
(deftest meval
|
||||
(meval '(:var . x) '(("TEST" (s . ()) (z . 4) (x . 5) (u . 6))))
|
||||
5)
|
||||
|
||||
(deftest meval
|
||||
(meval '(:var . s2) '(("TEST" (s . ()) (s1 . 7) (s2 . 8))
|
||||
("TOP-LEVEL" (x . 4) (x1 . 5) (x2 . 6))))
|
||||
8)
|
||||
|
||||
(deftest meval
|
||||
(meval '(:call + (:lit . 3) (:var . x)) '(("TOP-LEVEL" (x1 . 4) (x . 5) (z . 6))))
|
||||
8)
|
||||
|
||||
|
||||
;; meval donnee en cours
|
||||
|
||||
;(defun meval (expr env)
|
||||
; (cond ((and (atom expr) (constantp expr)) expr) ;; Literal
|
||||
; ((atom expr) ;; symboles
|
||||
; (let ((cell (assoc expr env)))
|
||||
; (if cell (cdr cell)
|
||||
; (error ""))))
|
||||
;; .
|
||||
;; .
|
||||
;; .
|
||||
; ((eq 'quote (car expr)) (cadr expr)) ;;Quote (' ou quote)
|
||||
; ((and (consp (car expr)) (eq 'lambda (caar expr)))
|
||||
; (meval-lambda (car expr) (cdr expr) env env)) ;; TODO : a remplir
|
||||
; ((eq 'defun (car expr))
|
||||
; (set-defun (cadr expr) (cons 'lambda (cddr expr))) ;; TODO : sera remplacer par add-top-level-binding
|
||||
; (get-defun (car expr))
|
||||
; (meval-lambda (get-defun (car expr)) (cdr expr) env ()))
|
||||
; ((eq 'if (car expr))
|
||||
; (if (meval (second expr) env)
|
||||
; (meval (third expr) env)
|
||||
; (meval (fourth expr) env)))
|
||||
; ;;cas des marcros/forme speciale deja traiter
|
||||
; ((fboundp (car expr)) ;;denier cas vrais fonctin globale predefinie
|
||||
; (apply (car expr) (map-meval (cdr expr) env))
|
||||
; )
|
||||
; ))
|
||||
|
||||
;(defun meval-lambda (lbd args env-args old-env)
|
||||
; (meval (third (car lbd))
|
||||
; (make-env (second (car lbd))
|
||||
; (map-meval args env-args)
|
||||
; old-env))
|
||||
;)
|
||||
|
|
@ -70,12 +70,12 @@
|
|||
(defun erase-tests ()
|
||||
(setf all-tests nil))
|
||||
|
||||
(deftest moda nil nil)
|
||||
(deftest moda (eq 42 42) t)
|
||||
(deftest modb (eq 'a 'a) t)
|
||||
(deftest modb (eq 'a 'b) nil)
|
||||
(deftest modb (eq 'a 'c) t)
|
||||
(deftest modb 1 1)
|
||||
(deftest modc (+ 1 2) (+ 2 1))
|
||||
(deftestvar modc x 1)
|
||||
(deftest modc (+ x 2) (+ 2 1))
|
||||
;(deftest moda nil nil)
|
||||
;(deftest moda (eq 42 42) t)
|
||||
;(deftest modb (eq 'a 'a) t)
|
||||
;(deftest modb (eq 'a 'b) nil)
|
||||
;(deftest modb (eq 'a 'c) t)
|
||||
;(deftest modb 1 1)
|
||||
;(deftest modc (+ 1 2) (+ 2 1))
|
||||
;(deftestvar modc x 1)
|
||||
;(deftest modc (+ x 2) (+ 2 1))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user