;;; Assembler

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

;;; EXTRACT-LABELS is called with a receiver, so that it can pass back
;;; two values.  The first is the list of instructions, with the
;;; labels removed.  The second is a table (lists of lists) where each
;;; entry is of the form
;;;     (LABEL <sequence of instructions beginning at that label>)
;;; This table will be used in looking up the instruction to transfer
;;; to when when branching or going to a label.
;;; The list of instructions and the sequences associated with the labels
;;; all share structure.  Think of it as there being only one sequence
;;; of instructions, and the table associating each label with a
;;; pointer into a position in that sequence.  This is important,
;;; because REPLACE-INSTS! is going to modify the sequence.


(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 next-inst insts)
                        labels)))))))

#|
;;Explanation of how to do it without receiver

(define (assemble controller-text machine)
  (let ((result (extract-labels controller-text)))
    (let ((insts (car result))
          (labels (cdr result)))
      (replace-insts! insts labels machine)
      insts)))

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

|#
;;; INSTS is initially a sequence of the text of the
;;; instructions.  For each one, generate the corresponding procedure
;;; (of no args) to executed to simulate the instruction.  Modify the
;;; sequence, replacing each element <text> by an instruction
;;; (generated by make-instruction) that includes both the text and
;;; the procedure.  We don't need the text to run the machine, but it
;;; is useful to keep the text around for debugging purposes.

(define (replace-insts! insts labels machine)
  (let ((pc (get-register machine 'pc))
        (flags (get-register machine 'flags))
        (stack (machine 'stack)))
    (for-each-list-tail
     (lambda (tail)
       (let ((inst (car tail)))
         (set-car! 
          tail
          (make-instruction
           inst
           (cond ((eq? (car inst) 'assign)
                  (make-assign inst machine labels pc))
                 ((eq? (car inst) 'test)
                  (make-test inst machine labels flags pc))
                 ((eq? (car inst) 'branch)
                  (make-branch inst machine labels flags pc))
                 ((eq? (car inst) 'goto)
                  (make-goto inst machine labels pc))
                 ((eq? (car inst) 'save)
                  (make-save inst machine stack pc))
                 ((eq? (car inst) 'restore)
                  (make-restore inst machine stack pc))
                 ((eq? (car inst) 'perform)
                  (make-perform inst machine labels pc))
                 (else
                  (error "Unknown instruction type" inst)))))))
     insts)))

;;; FOR-EACH-LIST-TAIL is a control abstraction similar to FOR-EACH,
;;; except that it applies the given procedure to successive tails of
;;; the list, rather than to successive elements of the list.

(define (for-each-list-tail proc list)
  (if (null? list)
      'done
      (begin (proc list)
             (for-each-list-tail proc (cdr list)))))

;;; Constructors for instruction execution procedures.

;;; (ASSIGN target . value-expression)

(define (make-assign inst machine labels pc)
  (let ((target (get-register machine (assign-reg-name inst)))
        (value-proc
         (parse-exp (assign-value-exp inst)
                    machine
                    labels
                    (machine 'operations))))
    (lambda ()
      (set-contents! target (value-proc))
      (advance-pc pc))))

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

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

;;; (TEST . condition)

(define (make-test inst machine labels flags pc)
  (let ((condition-proc
         (parse-exp (test-condition inst)
                    machine
                    labels
                    (machine 'operations))))
    (lambda ()
      (set-contents! flags (condition-proc))
      (advance-pc pc))))

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

;;; (BRANCH (LABEL l))

(define (make-branch inst machine labels flags pc)
  (let ((dest (branch-dest inst)))
    (if (label-exp? dest)
        (let ((l (lookup-label labels (label-exp-label dest))))
          (lambda ()
            (if (get-contents flags)
                (set-contents! pc l)
                (advance-pc pc))))
        (error "Bad branch instruction -- ASSEMBLE" inst))))

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

;;; (GOTO (REG r)) or (GOTO (LABEL l))

(define (make-goto inst machine labels pc)
  (let ((dest (goto-dest inst)))
    (cond ((label-exp? dest)
           (let ((l (lookup-label labels (label-exp-label dest))))
             (lambda () (set-contents! pc l))))
          ((register-exp? dest)
           (let ((reg (get-register machine (register-exp-reg dest))))
             (lambda () (set-contents! pc (get-contents reg)))))
          (else (error "Badly formed GOTO instruction" inst)))))

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


;;; (SAVE reg)
;;; (RESTORE reg)

(define (make-save inst machine stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (push stack (get-contents reg))
      (advance-pc pc))))

(define (make-restore inst machine stack pc)
  (let ((reg (get-register machine (stack-inst-reg-name inst))))
    (lambda ()
      (set-contents! reg (pop stack))    
      (advance-pc pc))))

(define (stack-inst-reg-name stack-instruction)
  (cadr stack-instruction))

;;; (PERFORM . action)

(define (make-perform inst machine labels pc)
  (let ((action-proc
         (parse-exp (perform-action inst)
                    machine
                    labels
                    (machine 'operations))))
    (lambda ()
      (action-proc)
      (advance-pc pc))))

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


;;; ADVANCE-PC is included in execution procedures to simulate
;;; advancing the PC to the next instruction, which is the normal
;;; termination for all instructions aside from branches and gotos.

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

;;; INSTRUCTION data abstraction includes a text and
;;; an execution procedure.

(define (make-instruction text proc)
  (cons text proc))

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

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


(define (make-label-entry label sequence)
  (cons label sequence))

;;; Look up a label name in the label table (genrated by
;;; EXTRACT-LABELS).  Return the corresponding instruction sequence,
;;; or signal an error is the label is not found.

(define (lookup-label labels label-name)
  (let ((val (assq label-name labels)))
    (if val
        (cdr val)
        (error "undefined label" label-name))))

;;; Syntax of expression types:

(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 (application-exp? exp)
  (and (pair? exp)
       (tagged-list? (car exp) 'op)))

(define (application-exp-op application-exp)
  (cadr (car application-exp)))

(define (application-exp-operands application-exp)
  (cdr application-exp))

;;; Given an expression, return a procedure of no arguments, which,
;;; when evaluated, returns the value of the expression.  Legal
;;; primitive expressions are:
;;;    (reg <register>)
;;;    (const <c>)
;;;    (label <l>)
;;; An expression is either a list containing a primitive expression or else
;;;    ((op <p>) e1 e2 ... en)
;;; where each e is a primitive expression

(define (parse-exp exp machine labels operations)
  (cond ((application-exp? exp)
         (let ((op (lookup-prim (application-exp-op exp) operations))
               (aprocs
                (map (lambda (e)
                       (parse-primitive-exp e machine labels))
                     (application-exp-operands exp))))
           (lambda () (apply op (map (lambda (p) (p)) aprocs)))))
        ((and (pair? exp) (null? (cdr exp))) ;list has a single element
         (parse-primitive-exp (car exp) machine labels))
        (else (error "bad expression -- ASSEMBLE" exp))))

;;; Parse a primitive expression.  Result is a procedure of no
;;; arguments, which when evaluated, produces the actual argument

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

;;;lookup a name in the table of operations.  Signal error
;;;if operation not in table. 

(define (lookup-prim symbol operations)
  (let ((val (assq symbol operations)))
    (if val
        (cadr val)
        (error "Unknown operator -- ASSEMBLE" symbol))))