;;-----------------------------------------------------------------------
;;
;;	   VCMC97.loo 				version #1.0
;; 
;;     une adaptation par J. Ferber en Ptitloo de
;;     la machine virtuelle VCMC94 de JF Perrot, laquelle est une
;;     adaptation reduite de l'historique VCMC2 de Jerome Chailloux
;;     
;;     la pile est geree comme un vecteur
;;
;;-----------------------------------------------------------------------
;;  on a ajoute quelques instructions utiles pour la gestion des objets
;;  version 94/95, certains bugs de la precedentes
;; 

(define *vcmc94-trace* #t)

(define listreg '(A0 A1 A2 SP FP)) ; pour pouvoir augmenter le nb de registres

(define  A0 )
(define  A1 )
(define  A2 )
(define  CO )
(define  ENV )
(define  STACK (make-vector 50))    ;; gestion de pile par vecteur

(define MEM)    ;; represente la memoire

;; les nouveaux registres
(define SP 0)    ;; pointeur de pile (pointe vers l'element vide!!
(define FP 0)    ;; pointeur de blocs (frames)


(define (erreur ch obj) (looerror 'VCMC97 "erreur machine" (cons ch obj)))
 
(define (est-reg? R) (memq R (cons 'ENV listreg)))

(define set assign) ;; pour affecter des valeurs dans des registres

(define (val X) ; appel a Scheme pour certaines operations simples
  (if (atom? X) ; constante ou registre
    (cond ((memq X '(t ())) X)
          ((number? X) X)
          ((est-reg? X) (eval X nil))
          (t (erreur "registre" X))
          )
    (case (car X) 
      (quote (cadr X))
	  (loc ;; retourne la valeur d'une place memoire
	     (let ((data (cassq 'DATA MEM)))
		    (car (cassq (cadr X) data))))
      (t (erreur "valeur" X))
      )))

(define (affectGlobal x v)
   (let ((data (cassq 'DATA MEM)))
	  (set-car! (cassq x data) v))
)

;; pour obtenir l'indice d'un element dans une liste
;; ex: (ieme 'b '(a b c d) 0) -> 1
(define (ieme sel lst i)
   (cond
	    ((null? lst) -1)
	    ((eq? sel (car lst)) i)
	    (else (ieme sel (cdr lst) (1+ i)))))
  
(define (empiler X) 
    (vector-set! STACK SP X)
    (set! SP (1+ SP)))

(define (depiler) 
   (unless (= SP 0)
     (set! SP (1- SP))
     (vector-ref STACK SP)))

(define (sauter etiq) 
  (let ((but (ieme etiq MEM 0)))
    (if but (set!  CO  but) (erreur "etiquette inconnue" etiq))
    ))

(define (line inst)
 (when *vcmc94-trace*
    (prin1 CO " " inst "     " A0 " " A1 " " A2 " " SP " " FP)
    (let ((sp (1- SP)))
	  (prin1 " [")
      (while (>= sp 0)
         (prin1 " " (vector-ref STACK sp))
         (set! sp (1- sp))))
	  (prin1 "]")
    (terpri)))

(define (vrun form)    ;; l'instruction d'evaluation d'une expression
  (lancer form)
  (print "Resultat: " A0)
 )


(define (lancer depart) ; etiquette dans la liste-memoire
  (set! SP 0)
  (set! FP 0)
  (set! CO 0)
  (set!  A0  (set! A1 (set! A2 nil)))
  (set! MEM depart)
  (while CO
     (let ((inst (at MEM CO)))
     		(line inst)
     		(if (not (atom? inst))
     			(execute inst))
     		(if CO (set! CO (1+ CO))))) )



(define (execute inst)
  (case (car inst)
    (DATA ; declaration de variables. Ne fait rien
	)
    (MOV ; (MOV RB VS), RB <- VS
	  (let ((reg (cadr inst)))
		(if (and (pair? reg)(eq? (car reg) 'loc))
		   (affectGlobal (cadr reg) (val (caddr inst)))
     	   (set reg (val (caddr inst))) ))
     )
    (JMP ; (JMP etiq), saut inconditionnel
     (sauter (cadr inst))
     )
    (JIP ; (JIP VE), saut inconditionnel indirect
     (sauter (val (cadr inst)))
     )
    (JEQ ; (JEQ V1 V2 etiq), saut si EQ
     (when (eq? (val (cadr inst)) (val (caddr inst))) (sauter (cadddr inst)))
     )
    (JNE ; (JNE V1 V2 etiq), saut si NEQ
     (when (not (eq? (val (cadr inst)) (val (caddr inst)))) (sauter (cadddr inst)))
     )
    (JEG ; (JEG V1 V2 etiq), saut si egalite NUMERIQUE
     (when (= (val (cadr inst)) (val (caddr inst))) (sauter (cadddr inst)))
     )
	(JGT ; (JGT V1 V2 etiq), saut si V1 > V2
     (when (> (val (cadr inst)) (val (caddr inst))) (sauter (cadddr inst)))
	)
	(JGE ; (JGE V1 V2 etiq), saut si V1 >= V2
     (when (>= (val (cadr inst)) (val (caddr inst))) (sauter (cadddr inst)))
	) 
	(JLT ; (JLT V1 V2 etiq), saut si V1 < V2
     (when (< (val (cadr inst)) (val (caddr inst))) (sauter (cadddr inst)))
	)
	(JLE ; (JLE V1 V2 etiq), saut si V1 <= V2
     (when (<= (val (cadr inst)) (val (caddr inst))) (sauter (cadddr inst)))
	)
    (JNI ; (JNI VS etiq), saut si NIL
     (when (null? (val (cadr inst))) (sauter (caddr inst)))
     )
    (JNN ; (JNN VS etiq), saut si not NIL
     (unless (null? (val (cadr inst))) (sauter (caddr inst)))
     )
    (PUSH ; (PSH VS)
     (empiler (val (cadr inst))) 
     )
    (POP ; (POP RB)
     (set (cadr inst) (depiler)) 
     )
    (JSR ; (JSR etiq), appel re'cursif de sous-programme
     (empiler  CO ) (sauter (cadr inst))
     )
	(RTN ; (RTN) retour d'un sous-programme. Arrete la machine si rien a depiler
     (set! CO (depiler))
     )
    (CONS ; (CONS RB V1 V2), RB <- (cons V1 V2)
     (set (cadr inst) (cons (val (caddr inst)) (val (cadddr inst))))
     )
	(CAR ; (CAR RB V1), RB <- (car V1)
     (set (cadr inst) (car (val (caddr inst))))
     )
	(CDR ; (CDR RB V1), RB <- (cdr V1)
     (set (cadr inst) (cdr (val (caddr inst))))
     )
    (ADD ; (ADD RB V1 V2)
     (set (cadr inst) (+ (val (caddr inst)) (val (cadddr inst))))
     )
    (MUL ; (MUL RB V1 V2)
     (set (cadr inst) (* (val (caddr inst)) (val (cadddr inst))))
     )
    (SUB ; (SUB RB V1 V2)
     (set (cadr inst) (- (val (caddr inst)) (val (cadddr inst))))
     )
    (DIV ; (DIV RB V1 V2)
     (set (cadr inst) (quotient (val (caddr inst)) (val (cadddr inst))))
     )
    (MOD ; (MOD RB V1 V2)
     (set (cadr inst) (remainder (val (caddr inst)) (val (cadddr inst))))
     )
    (NTH ; (NTH R1 NS R2), met dans R1 le NS-eme element de la pile
         ; par rapport a R2. ex: (NTH A0 3 FP)
     (set (cadr inst) (vector-ref STACK (+ (val (caddr inst))
                                           (cadddr inst))))
     )
    (SAV ; (SAV)     sauve l'environnement (avant un appel)
       (let ((nbargs (vector-ref STACK (1- SP)))
       		 (tmpSP SP))
         (empiler (- SP (1+ nbargs)))	; SP avant arguments (a restaurer)
         (empiler FP)				    ; frame pointeur
         (empiler (1+ CO))				; empiler l'adresse de retour
         (set! FP (- tmpSP (1+ nbargs))) ; nouvel FP
       )
    )
    (REST ; (REST)    restore l'environnement (apres un appel)
    	; (set! CO (depiler)) ; deplace dans CALL-PROC
    	(set! FP (depiler))
    	(set! SP (depiler))
    )
    (LOCAL ;(LOCAL reg n), recupere le nieme element sur la pile
    	(set (cadr inst) (vector-ref STACK (+ FP (caddr inst))))
    )
    (SETLOCAL
    	(vector-set! STACK (+ FP (caddr inst)) (cadr inst))
    )
    (FENTRY	 ;; aucune utilite directe. Indique simplement le debut d'une proc.
		(print "=> " (cadr inst))
	)
    
    (CALL ; (CALL SYM) appel la primitive de nom SYM
      (let ((nbarg (depiler))(args_lst nil))
      		(while (> nbarg 0)
      		  (set! args_lst (cons (depiler) args_lst))
      		  (set! nbarg (1- nbarg)))
        (let ((res (eval (cons (cadr inst) args_lst) nil)))
			(set! A0 res)))
    )
    (else (erreur "instruction inconnue" inst))
    ))