www

commit 4b638bceaebf9263bf30872dd1c9e674d5c80c54
parent 5aabdd03c890d1148a8bac90a5d0ba1a74dca494
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date:   Sat, 20 Nov 2010 01:10:07 +0100

Merge branch 'master' of github:dumbs/2010-m1s1-compilation

Diffstat:
M
implementation/mini-meval.lisp
 | 
3
+--
M
instructions.lisp
 | 
26
++++++++++++++++++++------
M
test-unitaire.lisp
 | 
3
+--

3 files changed, 22 insertions(+), 10 deletions(-)
diff --git a/implementation/mini-meval.lisp b/implementation/mini-meval.lisp
@@ -555,4 +555,4 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
   (mini-meval '(block foo 1 2))
   2)
 
-(provide 'mini-meval)
-\ No newline at end of file
+(provide 'mini-meval)
diff --git a/instructions.lisp b/instructions.lisp
@@ -6,7 +6,7 @@
 ;;     (send vm set-memory 42 5)
 ;;     (send vm get-register R1)
 ;;     (send vm set-register R2 (send vm get-register 42))
-(defun make-vm (size)
+(defun make-vm (size &optional (debug nil))
   (let* ((memory (make-array size :initial-element 0))
          (registers `(;; Registres généraux.
                       (R0 . 0)
@@ -25,13 +25,16 @@
                       (EQ . nil)
                       (PG . nil)
                       ;; Quand HALT passe à t, on arrête la machine.
-                      (HALT . nil)))
+                      (HALT . nil)
+                      ;; Sert uniquement pour le debug
+                      (DEBUG . debug)))
          (actions `((get-memory . ,(lambda (index) (aref memory index)))
                     (set-memory . ,(lambda (index value) (setf (aref memory index) value)))
                     (get-register-list . ,(lambda () (mapcar #'car registers)))
                     (get-register . ,(lambda (reg) (cdr (assoc reg registers))))
                     (set-register . ,(lambda (reg value) (setf (cdr (assoc reg registers)) value)))
-                    (size-memory . ,(lambda () (length memory))))))
+                    (size-memory . ,(lambda () (length memory)))
+                    (get-debug-mode . ,(lambda () (cdr (assoc 'DEBUG registers)))))))
     (lambda (message &rest params)
       (apply (cdr (assoc message actions)) params))))
 
@@ -44,6 +47,19 @@
 (defun get-register (vm register) (send vm 'get-register register))
 (defun set-register (vm register value) (send vm 'set-register register value))
 (defun size-memory (vm) (send vm 'size-memory))
+(defun get-debug-mode (vm) (send vm 'get-debug-mode))
+
+
+;; TODO : Reste a ajouter la resolution d'etiquette
+(defun load-asm (asm &optional (stack-size 100) (debug nil))
+  (let ((vm (make-vm (+ (length asm) stack-size) debug))
+        (size-vm (+ (length asm) stack-size)))
+    (labels ((load-asm-rec (vm index asm debug)
+                           (if (endp asm)
+                               vm
+                             (progn (set-memory vm index (car asm))
+                                    (load-asm-rec vm (- index 1) (cdr asm) debug)))))
+      (load-asm-rec vm (- size-vm 1) asm debug))))
 
 ;;TODO : Rajouter une fonction resolve pour resoudre les differents modes d'adresssage.
 ;; TODO : Penser a ajouter une table des opcodes
@@ -105,7 +121,6 @@
                       (position1 valeur-2 (get-register-list (make-vm 1)))
                       valeur-2))))
 
-;;TODO : Faire les registres
 (defun dump-vm (vm)
   (dotimes (i (size-memory vm))
     (let ((val (get-memory vm i)))
@@ -267,4 +282,4 @@
          (get-memory vm (get-register vm 'SP)))
   t-r1-value)
 
-(provide 'instructions)
-\ No newline at end of file
+(provide 'instructions)
diff --git a/test-unitaire.lisp b/test-unitaire.lisp
@@ -188,4 +188,4 @@
 ;; (run-tests t)
 ;; (run-tests)
 
-(provide 'test-unitaire)
-\ No newline at end of file
+(provide 'test-unitaire)