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

instructions.lisp

@@ -63,14 +63,15 @@
 
 (defun position1 (x l) (+ 1 (position x l)))
 
-(defun split-bytes (n nb-bytes append)
-  "Découpe N en plusieurs valeurs inférieures à 256,
-en renvoyant une liste de longueur NB-BYTES,
-et termine par la liste APPEND."
-  (if (<= nb-bytes 0)
-      append
-      (cons (ldb (byte 8 (* 8 (- nb-bytes 1))) n)
-            (split-bytes n (- nb-bytes 1) append))))
+;; TODO : faire une fonction (append-bits n1 size2 n2 size3 n3 ... sizen nn)
+
+(defun append-bits (&optional (n1 0) &rest rest)
+  (if (endp rest)
+      n1
+      (apply #'append-bits
+             (logior (ash n1 (car rest))
+                     (cadr rest))
+             (cddr rest))))
 
 (defvar nb-operateurs (length table-operateurs))
 (defvar nb-modes-adressage (length table-modes-adressage))
@@ -88,25 +89,21 @@ et termine par la liste APPEND."
 ;; '(operateur mode-adressage-1 valeur-1 mode-adressage-2 valeur-2)
 ;; Si l'instruction ne prend qu'un (ou zéro) paramètre, les champs
 ;; correspondants sont mis à nil.
-;; TODO : encoder en entier les registres de valeur-1 et valeur-2.
+
 (defun isn-encode (instruction)
-  (let ((operateur (first instruction))
-        (mode-adressage-1 (second instruction))
-        (valeur-1 (third instruction))
-        (mode-adressage-2 (fourth instruction))
-        (valeur-2 (fifth instruction)))
-    (let* ((opcode (position1 operateur table-operateurs))
-           (opcode (ash opcode nb-modes-adressage))
-           (opcode (logior opcode (position1 mode-adressage-1 table-modes-adressage)))
-           (opcode (ash opcode nb-modes-adressage))
-           (opcode (logior opcode (position1 mode-adressage-2 table-modes-adressage))))
-      (split-bytes opcode nb-opcode-bytes
-                   (list (if (eq mode-adressage-1 'registre)
-							 (position1 valeur-1 (get-register-list (make-vm 1)))
-						   valeur-1)
-						 (if (eq mode-adressage-2 'registre)
-							 (position1 valeur-2 (get-register-list (make-vm 1)))
-						   valeur-2))))))
+  (loop
+     for (operateur mode-adressage-1 valeur-1 mode-adressage-2 valeur-2) = instruction
+     return (list (append-bits (position1 operateur table-operateurs)
+                               nb-modes-adressage
+                               (position1 mode-adressage-1 table-modes-adressage) 
+                               nb-modes-adressage
+                               (position1 mode-adressage-2 table-modes-adressage))
+                  (if (eq mode-adressage-1 'registre)
+                      (position1 valeur-1 (get-register-list (make-vm 1)))
+                      valeur-1)
+                  (if (eq mode-adressage-2 'registre)
+                      (position1 valeur-2 (get-register-list (make-vm 1)))
+                      valeur-2))))
 
 ;;TODO : Faire les registres
 (defun dump-vm (vm)

lisp2li.lisp

@@ -1,4 +1,5 @@
 (load "util.lisp")
+
 ;; `
 (defvar my-quasiquote (car '`(,a)))
 
@@ -140,7 +141,8 @@ par le compilateur et par l’interpréteur"
    ((eq 'setf (car expr))
     (if (symbolp (cadr expr))
         (let ((cell (assoc (cadr expr) env)))
-          `(:set-var (,(second cell) ,(third cell)) ,(third expr)))
+          `(:set-var (,(second cell) ,(third cell))
+                     ,(lisp2li (third expr) env)))
       `(:set-fun ,(caadr expr) ,@(last expr) ,@(cdadr expr))))
    ;; progn
    ((eq 'progn (car expr))

meval.lisp

@@ -100,35 +100,43 @@ d’arguments dans un certain environnement."
          (meval lclosure
                 (make-env size args env rest))))
 
+(defun msetf (place val env)
+  (let ((sub-env (get-env-num (first place) env)))
+    (if sub-env
+        (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 meval (expr &optional (env #()))
   "Interprète le langage intermédiaire passé en paramètre."
-  (cond ((eq ':const (first expr))
-         (match (:nil :const :val . _) expr val))
-        ((eq ':cvar (first expr))
-         (match (:nil :cvar :num-env (? integerp) :index (? integerp)) expr
+  (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" expr)))))
-        ((eq ':if (first expr))
-         (match (:nil :if :predicat @. :expr1 @. :expr2 @.) expr
+                  (error "The variable unbound" expr))))
+              ((:nil :if :predicat @. :expr1 @. :expr2 @.)
                 (if (meval predicat env)
                     (meval expr1 env)
-                  (meval expr2 env))))
-        ((eq ':call (first expr))
-         (match (:nil :call :func-name _ :body _*) expr
-                (apply (symbol-function func-name) (map-meval body env))))
-        ((eq ':mcall (first expr))
-         (match (:nil :mcall :lambda (:nil :lclosure (? integerp) (? integerp)? _*) :args _*) expr
-                (meval-lambda lambda (meval-args args env) env)))
-        ((eq ':progn (first expr))
-         (match (:nil :progn :body @.+) expr
-                (meval-body body env)))
-        ((eq ':lclosure (first expr))
-         (match (:nil :lclosure (? integerp) (? integerp)? :body _*) expr
-                (meval-body `(,body) env)))
-        (T
-         (error "form special ~S not yet implemented" (car expr)))))
+                  (meval expr2 env)))
+              ((:nil :call :func-name _ :body _*)
+               (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))
+              (match (:nil :progn :body @.+)
+                     (meval-body body env))
+              ((:nil :lclosure (? integerp) (? integerp)? :body _*)
+                (meval-body `(,body) env))
+              ((:nil :set-var :place @. :value _)
+               (msetf place value env))
+              (_*
+               (error "form special ~S not yet implemented" expr))))
 
         
 ;; Test unitaire
@@ -244,3 +252,10 @@ d’arguments dans un certain environnement."
 (deftest (meval :mcall :lclosure)
   (meval (lisp2li '((lambda (x &rest y) (cons x y)) 1 2 3 4) ()))
   '(1 2 3 4))
+
+(deftestvar (meval :set-var) env #(() 2))
+(deftest (meval :set-var)
+  (progn
+    (meval (lisp2li '(setf x 42) ()) env)
+    env)
+  #(() 42))

util.lisp

@@ -76,14 +76,16 @@
 		   (propper-list-p (cdr l)))))
 
 (defun m-macroexpand-1 (macro)
+  ;; TODO : not implemented yet m-macroexpand-1
+  macro ;; Pour éviter le unused variable.
   ())
 
 (defmacro get-defun (symb)
   `(get ,symb :defun))
 
 (defun set-defun (symb expr)
-  (setf (get-defun (cdaddr li))
-        (cdddr li)))
+  (setf (get-defun symb)
+        expr))
 
 (defmacro get-defmacro (symb)
   `(get ,symb :defmacro))
@@ -108,7 +110,6 @@
 ;; compte dans les tests unitaires etc.
 (defun copy-all (data)
   "Copie récursivement un arbre de listes et de tableaux."
-  (print data)
   (cond 
     ((consp data)
      (cons (copy-all (car data))