;;;;  6.001 Register Machine Simulator

;;; Syntactic sugar for DEFINE-MACHINE
;;;   Magic syntax hack... DO NOT expect to understand this. 
;;;   Hal doesn't and he wrote it!
;;; This procedure was modified by Henry Wu, 3-31-87,
;;;   because add-syntax did not work.  
 (enable-language-features)
 (add-syntax! 'define-machine
	      (macro (name registers controller)
		     `(define ,name
			(build-model ',(cdr registers) ',(cdr controller))))
	      (access student-syntax-table student-package))
;;; More magic code
 (define unsyntax unsyntax)
 (disable-language-features)
 
;;;model building

(define (build-model registers controller)
  (let ((machine (make-new-machine)))
    (set-up-registers machine registers)
    (set-up-controller machine controller)
    machine))

(define (set-up-registers machine registers)
  (mapc (lambda (register-name)
          (make-machine-register machine register-name))
        registers))

(define (mapc proc l)
  (if (null? l)
      'done
      (sequence (proc (car l))
                (mapc proc (cdr l)))))

(define (set-up-controller machine controller)
  (build-instruction-list machine (cons '*start* controller)))

(define (build-instruction-list machine op-list)
  (if (null? op-list)
      '()
      (let ((rest-of-instructions
             (build-instruction-list machine (cdr op-list))))
        (if (label? (car op-list))
            (sequence
             (declare-label machine
                             (car op-list)
                             rest-of-instructions)
             rest-of-instructions)
            (cons (make-machine-instruction machine
                                            (car op-list))
                  rest-of-instructions)))))

(define (label? expression)
  (symbol? expression))

(define (make-machine-register machine name)
  (remote-define machine name (make-register name)))

;;;register model
;;; Modified by DPC to trace register assignments
(define (make-register name)
  (define contents nil)
  (define trace false)     ;;;
  (define (get) contents)
  (define (set value)
    (if trace                                             ;;;
	(print (list 'reg-trace: name 'new-value: value))) ;;;
    (set! contents value))
  (define (dispatch message)
    (cond ((eq? message 'get) (get))	  
          ((eq? message 'set) set)
	  ((eq? message 'trace-on) (set! trace t))            ;;; 
	  ((eq? message 'trace-off) (set! trace false)) ;;;
          (else (error "Unknown request -- REGISTER"
                       name
                       message))))
  dispatch)

(define (get-contents register)
  (register 'get))

(define (set-contents register value)
  ((register 'set) value))

(define (declare-label machine label labeled-entry)
  (let ((defined-labels (remote-get machine '*labels*)))
    (if (memq label defined-labels)
        (error "Multiply-defined label" label)
        (sequence
         (remote-define machine label labeled-entry)
         (remote-set machine
                      '*labels*
                      (cons label defined-labels))))))


;;; stack model -- monitored stack
;;; modified by DPC as marked to show stack dynamics graphically
(define (make-stack)
  (define s '())
  (define number-pushes 0)
  (define max-depth 0)
  (define stack-ops 0)                                 ;;;
  (define (push x)
    (set! s (cons x s))
    (set! number-pushes (1+ number-pushes))
    (set! max-depth (max (length s) max-depth))
    (set! stack-ops (1+ stack-ops))                    ;;;
    (show-stack))                                      ;;;
  (define (pop)
    (if (null? s)
        (error "Empty stack -- POP")
        (let ((top (car s)))
	  (set! s (cdr s))
	  (set! stack-ops (1+ stack-ops))              ;;;
	  (show-stack)                                 ;;;
	  top)))    
  (define (show-stack)                                 ;;;
    (draw-point (screen-map stack-ops) (screen-map (* 3 (length s)))));;;
  (define (screen-map x) (- (remainder x 320) 160))    ;;;
  (define (initialize)
    (set! stack-ops 0)                                 ;;;
    (set! s '())
    (set! number-pushes 0)
    (set! max-depth 0))
  (define (print-statistics)
    (print (list 'total-pushes: number-pushes
                 'maximum-depth: max-depth)))
  (define (dispatch message)
    (cond ((eq? message 'push) push)
          ((eq? message 'pop) (pop))
          ((eq? message 'initialize) (initialize))
          ((eq? message 'print-statistics) (print-statistics))
          (else (error "Unknown request -- STACK" message))))
  dispatch)


(define (pop stack)
  (stack 'pop))

(define (push stack value)
  ((stack 'push) value))

;;;name-value association

(define (remote-get machine variable)
  (eval variable machine))

(define (remote-set machine variable value)
  (eval (list 'set! variable (list 'quote value))
        machine))

(define (remote-define machine variable value)
  (eval (list 'define variable (list 'quote value))
        machine))

(define (make-machine-instruction machine op)
  (eval (list 'lambda '() op) machine))

;;; Monitored stack machine maker.
;;; Changed by DPC as marked to count operations and enable instruction
;;; traces.
(define (make-new-machine)
  (make-environment
   (define machine-ops 0)                              ;;;
   (define trace-flag nil)
   (define *labels* '())
   (define *the-stack* (make-stack))
   (define (initialize-stack)
     (*the-stack* 'print-statistics)
     (*the-stack* 'initialize))
   (define (initialize-ops-counter)                    ;;;
     (print (list 'machine 'operations: machine-ops))  ;;;
     (set! machine-ops 0))                             ;;;
   (define fetch get-contents)
   (define *program-counter* '())
   (define (execute sequence)
     (set! *program-counter* sequence)
     (if (null? *program-counter*)
	 'done
	 (sequence (set! machine-ops (1+ machine-ops)) ;;;
		   (if trace-flag                      ;;; Print out code
		       (pp (caddr (unsyntax (car *program-counter*))) 'as-code))
		   ((car *program-counter*)))))        ;;;
   (define (normal-next-instruction)
     (execute (cdr *program-counter*)))

   (define (assign register value)
     (set-contents register value)
     (normal-next-instruction))
   
   (define (save reg)
     (push *the-stack* (get-contents reg))
     (normal-next-instruction))

   (define (restore reg)
     (set-contents reg (pop *the-stack*))
     (normal-next-instruction))

   (define (goto new-sequence)
     (execute new-sequence))

   (define (branch predicate alternate-next)
     (if predicate
	 (goto alternate-next)
	 (normal-next-instruction)))

   (define (perform operation)
     (normal-next-instruction))

   ;; end of make-new-machine
   ))



;;;rest of simulator interface

(define (remote-fetch machine register-name)
  (get-contents (remote-get machine register-name)))

(define (remote-assign machine register-name value)
  (set-contents (remote-get machine register-name) value)
  'done)

(define (start machine)
  (eval '(goto *start*) machine))

;;;  Added by DPC to trace instructions and register assignments
(define (remote-trace-on machine)                      ;;;
  (eval '(set! trace-flag t) machine))                 ;;;

(define (remote-trace-off machine)                     ;;;
  (eval '(set! trace-flag false) machine))             ;;;
  
(define (remote-trace-reg-on reg-name machine)         ;;;
  ((remote-get reg-name machine) 'trace-on))           ;;;

(define (remote-trace-reg-off reg-name machine)        ;;;
  ((remote-get reg-name machine) 'trace-off))          ;;;
