;;; Objektsystem aus der Vorlesung

(define ask
  (lambda (object message . args)
    (let ((method (get-method object message)))
      (if (method? method)
	  (apply method (cons object args))
	  (error "No method" message (cadr method))))))

(define get-method
  (lambda (object message)
    (object message)))

(define no-method
  (lambda (name)
    (list 'no-method name)))

(define method?
  (lambda (x)
    (not (no-method? x))))

(define no-method?
  (lambda (x)
    (if (pair? x)
	(eq? (car x) 'no-method)
	#f)))

;; Einfacher Simulator für Registermaschinen

(define (make-machine register-names ops controller-text mem-size)
  (let ((machine (make-new-machine mem-size)))
    (for-each (lambda (register-name)
                (ask machine 'allocate-register register-name))
              register-names)
    (ask machine 'install-alu (make-alu ops))
    (let ((controller (make-new-controller)))
      (ask controller 'install-instruction-sequence
	   (assemble controller-text machine))
      (ask machine 'install-controller controller))
    machine))

;; Register

(define (make-register name)
  (let ((contents '*unassigned*))
    (lambda (message)
      (cond ((eq? message 'get-contents)
	     (lambda (self)
	       contents))
	    ((eq? message 'set-contents)
	     (lambda (self value)
	       (set! contents value)))
	    (else
	     (no-method name))))))

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

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

;; Maschine

(define (make-new-machine mem-size)
  (let* ((ip (make-register 'ip))
	 (flag (make-register 'flag))
	 (register-alist
	  (list (cons 'ip ip)
		(cons 'flag flag)))
	 (memory (make-vector mem-size '*unassigned*))
	 (alu '*unassigned*)
	 (controller '*unassigned*))

    (lambda (message)
      (cond ((eq? message 'install-controller)
	     (lambda (self the-controller)
	       (set! controller the-controller)
	       (ask controller 'attach-machine self)))
	    ((eq? message 'controller)
	     (lambda (self)
	       controller))
	    ((eq? message 'run)
	     (lambda (self)
	       (ask controller 'run)))
	    ((eq? message 'install-alu)
	     (lambda (self the-alu)
	       (set! alu the-alu)))
	    ((eq? message 'alu)
	     (lambda (self)
	       alu))
	    ((eq? message 'allocate-register)
	     (lambda (self name)
	       (if (assoc name register-alist)
		   (error "Multiply defined register: " name)
		   (set! register-alist
			 (cons (cons name (make-register name))
			       register-alist)))))
	    ((eq? message 'get-register)
	     (lambda (self name)
	       (let ((val (assoc name register-alist)))
		 (if val
		     (cdr val)
		     (error "Unknown register: " name)))))
	    ((eq? message 'memory)
	     (lambda (self)
	       memory))
	    (else
	     (no-method 'machine))))))

(define (run machine)
  (ask machine 'run))

(define (get-register machine reg-name)
  (ask machine 'get-register reg-name))

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

(define (set-register-contents! machine register-name value)
  (set-contents! (get-register machine register-name) value))

(define (get-memory machine)
  (ask machine 'memory))

;; Controller

(define (make-new-controller)

  (let ((machine '*unassigned*)
	(instruction-sequence '*unassigned*))
    
    (lambda (message)
      (cond ((eq? message 'attach-machine)
	     (lambda (self the-machine)
	       (set! machine the-machine)))
	    ((eq? message 'install-instruction-sequence)
	     (lambda (self seq)
	       (set! instruction-sequence seq)))
	    ((eq? message 'run)
	     (lambda (self)
	       (set-register-contents! machine 'ip
				       instruction-sequence)
	       (letrec ((fetch
			 (lambda ()
			   (let ((instructions
				  (get-register-contents machine 'ip)))
			     (if (null? instructions)
				 #f
				 (car instructions)))))
			(decode
			 (lambda (instruction)
			   (instruction-execution-proc instruction)))
			(execute
			 (lambda (decoded-instruction)
			   (decoded-instruction)))
			(cycle
			 (lambda ()
			   (let ((instruction (fetch)))
			     (if instruction
				 (begin
				   (execute (decode instruction))
				   (cycle)))))))
	       (cycle))))
	    (else
	     (no-method 'controller))))))

;; ALU

(define (make-alu operations)
  (lambda (operator . operands)
    (let ((val (assq operator operations)))
      (if val
	  (apply (cdr val) operands)
	  (error "Unknown ALU operation" operator)))))

;; Assembler

(define (assemble controller-text machine)
  (extract-labels controller-text
    (lambda (insts labels)
      (update-insts! insts labels machine)
      insts)))

(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      (extract-labels (cdr text)
       (lambda (insts labels)
         (let ((next-inst (car text)))
           (if (symbol? next-inst)
               (receive insts
                        (cons (make-label-entry next-inst
                                                insts)
                              labels))
               (receive (cons (make-instruction next-inst)
                              insts)
                        labels)))))))

(define (update-insts! insts labels machine)
  (let ((ip (get-register machine 'ip))
        (flag (get-register machine 'flag)))
    (for-each
     (lambda (inst)
       (set-instruction-execution-proc! 
        inst
        (make-execution-procedure
         (instruction-text inst) labels machine
         ip flag)))
     insts)))

(define (make-instruction text)
  (cons text 'unassigned))

(define (instruction-text inst)
  (car inst))

(define (instruction-execution-proc inst)
  (cdr inst))

(define (set-instruction-execution-proc! inst proc)
  (set-cdr! inst proc))

(define (make-label-entry label-name insts)
  (cons label-name insts))

(define (lookup-label labels label-name)
  (let ((val (assoc label-name labels)))
    (if val
        (cdr val)
        (error "Undefined label -- ASSEMBLE" label-name))))

;; Instruktionssatz

(define (make-execution-procedure inst labels machine
                                  ip flag)
  (cond
   ((eq? (car inst) 'assign)
    (make-assign inst machine labels ip))
   ((eq? (car inst) 'test)
    (make-test inst machine labels flag ip))
   ((eq? (car inst) 'branch)
    (make-branch inst machine labels flag ip))
   ((eq? (car inst) 'goto)
    (make-goto inst machine labels ip))
   ((eq? (car inst) 'perform)
    (make-perform inst machine labels ip))
   ((eq? (car inst) 'load)
    (make-load inst machine labels ip))
   ((eq? (car inst) 'store)
    (make-store inst machine labels ip))
   (else (error "Unknown instruction type -- ASSEMBLE"
		inst))))

(define (make-assign inst machine labels ip)
  (let ((target
         (get-register machine (assign-reg-name inst)))
        (value-exp (assign-value-exp inst)))
    (let ((value-proc
           (if (operation-exp? value-exp)
               (make-operation-exp
                value-exp machine labels)
               (make-primitive-exp
                (car value-exp) machine labels))))
      (lambda ()
        (set-contents! target (value-proc))
        (advance-ip ip)))))

(define (assign-reg-name assign-instruction)
  (cadr assign-instruction))

(define (assign-value-exp assign-instruction)
  (cddr assign-instruction))

(define (advance-ip ip)
  (set-contents! ip (cdr (get-contents ip))))

(define (make-test inst machine labels flag ip)
  (let ((condition (test-condition inst)))
    (if (operation-exp? condition)
        (let ((condition-proc
               (make-operation-exp
                condition machine labels)))
          (lambda ()
            (set-contents! flag (condition-proc))
            (advance-ip ip)))
        (error "Bad TEST instruction -- ASSEMBLE" inst))))

(define (test-condition test-instruction)
  (cdr test-instruction))


(define (make-branch inst machine labels flag ip)
  (let ((dest (branch-dest inst)))
    (if (label-exp? dest)
        (let ((insts
               (lookup-label labels (label-exp-label dest))))
          (lambda ()
            (if (get-contents flag)
                (set-contents! ip insts)
                (advance-ip ip))))
        (error "Bad BRANCH instruction -- ASSEMBLE" inst))))

(define (branch-dest branch-instruction)
  (cadr branch-instruction))


(define (make-goto inst machine labels ip)
  (let ((dest (goto-dest inst)))
    (cond ((label-exp? dest)
           (let ((insts
                  (lookup-label labels
                                (label-exp-label dest))))
             (lambda ()
	       (set-contents! ip insts))))
          ((register-exp? dest)
           (let ((reg
                  (get-register machine
                                (register-exp-reg dest))))
             (lambda ()
               (set-contents! ip (get-contents reg)))))
          (else (error "Bad GOTO instruction -- ASSEMBLE"
                       inst)))))

(define (goto-dest goto-instruction)
  (cadr goto-instruction))

(define (make-perform inst machine labels ip)
  (let ((action (perform-action inst)))
    (if (operation-exp? action)
        (let ((action-proc
               (make-operation-exp
                action machine labels)))
          (lambda ()
            (action-proc)
            (advance-ip ip)))
        (error "Bad PERFORM instruction -- ASSEMBLE" inst))))

(define (perform-action inst) (cdr inst))

(define (make-load inst machine labels ip)
  (let ((memory (get-memory machine))
	(target (get-register machine (load-reg-name inst)))
	(address-exp (load-address-exp inst)))
    (let ((address-proc
	   (make-primitive-exp address-exp machine labels)))
      (lambda ()
	(set-contents! target (vector-ref memory (address-proc)))
	(advance-ip ip)))))

(define (load-reg-name inst) (cadr inst))
(define (load-address-exp inst) (caddr inst))

(define (make-store inst machine labels ip)
  (let ((memory (get-memory machine))
	(address-exp (store-address-exp inst))
	(value-exp (store-source-exp inst)))
    (let ((address-proc
	   (make-primitive-exp address-exp machine labels))
	  (value-proc
	   (make-primitive-exp value-exp machine labels)))
      (lambda ()
	(vector-set! memory (address-proc) (value-proc))
	(advance-ip ip)))))

(define (store-address-exp inst) (cadr inst))
(define (store-source-exp inst) (caddr inst))

(define (make-primitive-exp exp machine labels)
  (cond ((constant-exp? exp)
         (let ((c (constant-exp-value exp)))
           (lambda () c)))
        ((label-exp? exp)
         (let ((insts
                (lookup-label labels
                              (label-exp-label exp))))
           (lambda () insts)))
        ((register-exp? exp)
         (let ((r (get-register machine
                                (register-exp-reg exp))))
           (lambda () (get-contents r))))
        (else
         (error "Unknown expression type -- ASSEMBLE" exp))))

(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      #f))

(define (register-exp? exp) (tagged-list? exp 'reg))

(define (register-exp-reg exp) (cadr exp))

(define (constant-exp? exp) (tagged-list? exp 'const))

(define (constant-exp-value exp) (cadr exp))

(define (label-exp? exp) (tagged-list? exp 'label))

(define (label-exp-label exp) (cadr exp))

(define (make-operation-exp exp machine labels)
  (let ((operator (operation-exp-op exp))
        (aprocs
         (map (lambda (e)
                (make-primitive-exp e machine labels))
              (operation-exp-operands exp))))
    (lambda ()
      (apply (ask machine 'alu)
	     operator (map (lambda (p) (p)) aprocs)))))

(define (operation-exp? exp)
  (and (pair? exp)
       (tagged-list? (car exp) 'op)))
(define (operation-exp-op operation-exp)
  (cadr (car operation-exp)))
(define (operation-exp-operands operation-exp)
  (cdr operation-exp))