;;レジスタ計算機シミュレータ p.308

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

;;レジスタ p.308

(define (make-register name)
  (let ((contents '*unassigned*))
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set)
             (lambda (value) (set! contents value)))
            (else
             (error "Unknown request -- REGISTER" message))))
    dispatch))

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

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

;;スタック p.308

;; p.308のmake-stackをスタック使用統計監視用make-stackで置き換えた p.318

(define (make-stack)
  (let ((s '())
        (number-pushes 0)
        (max-depth 0)
        (current-depth 0))
    (define (push x)
      (set! s (cons x s))
      (set! number-pushes (+ 1 number-pushes))
      (set! current-depth (+ 1 current-depth))
      (set! max-depth (max current-depth max-depth)))
    (define (pop)
      (if (null? s)
          (error "Empty stack -- POP")
          (let ((top (car s)))
            (set! s (cdr s))
            (set! current-depth (- current-depth 1))
            top)))    
    (define (initialize)
      (set! s '())
      (set! number-pushes 0)
      (set! max-depth 0)
      (set! current-depth 0)
      'done)
    (define (print-statistics)
      (newline)
      (display (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))

;;基本計算機 p.309

(define (start machine)
  (machine 'start))

(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)
  'done)

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

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '()))
    (let ((the-ops
             (list (list 'initialize-stack
                         (lambda () (stack 'initialize)))
                   (list 'print-stack-statistics                  ;スタック使用
                         (lambda () (stack 'print-statistics))))) ;統計監視用
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                ((instruction-execution-proc (car insts)))
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

;;アセンブラ p.310

(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 ((pc (get-register machine 'pc))
        (flag (get-register machine 'flag))
        (stack (machine 'stack))
        (ops (machine 'operations)))
    (for-each
     (lambda (inst)
       (set-instruction-execution-proc! 
        inst
        (make-execution-procedure
         (instruction-text inst) labels machine
         pc flag stack ops)))
     insts)))

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

(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))))

;;命令の実行手続きの生成 p.313

(define (make-execution-procedure inst labels machine
                                  pc flag stack ops)
  (cond ((eq? (car inst) 'assign)
         (make-assign inst machine labels ops pc))
        ((eq? (car inst) 'test)
         (make-test inst machine labels ops flag pc))
        ((eq? (car inst) 'branch)
         (make-branch inst machine labels flag 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 ops pc))
        (else (error "Unknown instruction type -- ASSEMBLE"
                     inst))))


;;assign命令 p.313

(define (make-assign inst machine labels operations pc)
  (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 operations)
               (make-primitive-exp
                (car value-exp) machine labels))))
      (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))

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

;;test, branchおよびgoto命令 p.314

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

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

(define (make-branch inst machine labels flag pc)
  (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! pc insts)
                (advance-pc pc))))
        (error "Bad BRANCH instruction -- ASSEMBLE" inst))))

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

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

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

;;その他の命令 p.315

(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))

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

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

;;部分式の実行手続き p.315

(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 (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 operations)
  (let ((op (lookup-prim (operation-exp-op exp) operations))
        (aprocs
         (map (lambda (e)
                (make-primitive-exp e machine labels))
              (operation-exp-operands exp))))
    (lambda ()
      (apply op (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))

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

;;抽象構文用手続き p.218

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

(load "regmacheceval2.sch")

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

(define (make-register name)
  (let ((contents '*unassigned*) (trace-flag '()))  ;;ex5.18
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set)
             (lambda (value) 
              (if trace-flag   ;ex5.18
                (begin (newline) (display "register name:") (display name)
                       (newline) (display "old content:") (display contents)
                       (newline) (display "new content:") (display value)))
              (set! contents value)))
            ((eq? message 'trace-on) (set! trace-flag #t)) ;ex5.18
            ((eq? message 'trace-off) (set! trace-falg '())) ;ex5.18
            (else
             (error "Unknown request -- REGISTER" message))))
    dispatch))

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

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

;; スタック使用統計監視用make-stack
(define (make-stack)
  (let ((s '())
        (number-pushes 0)
        (max-depth 0)
        (current-depth 0))
    (define (push x)
      (set! s (cons x s))
      (set! number-pushes (+ 1 number-pushes))
      (set! current-depth (+ 1 current-depth))
      (set! max-depth (max current-depth max-depth)))
    (define (pop)
      (if (null? s)
          (error "Empty stack -- POP")
          (let ((top (car s)))
            (set! s (cdr s))
            (set! current-depth (- current-depth 1))
            top)))    
    (define (initialize)
      (set! s '())
      (set! number-pushes 0)
      (set! max-depth 0)
      (set! current-depth 0)
      'done)
    (define (print-statistics)
      (newline)
      (display (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))

(define (start machine)
  (machine 'start))

(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)
  'done)

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

(define (get-db machine)    ;ex5.12
  (machine 'get-db))

(define (reset-inst-count machine) ;ex5.15
  (machine 'reset-inst-count))

(define (get-inst-count machine) ;ex5.15
  (machine 'get-inst-count))

(define (set-register-trace! machine register-name)  ;ex5.18
  (set-trace (get-register machine register-name)))

(define (reset-register-trace! machine register-name)  ;ex5.18
  (reset-trace (get-register machine register-name)))

(define (set-trace register)  ;ex5.18
  (register 'trace-on))

(define (reset-trace register) ;ex5.18
   (register 'trace-off))

(define (set-breakpoint machine label n) ;ex5.19
  ((machine 'set-breakpoint) label n))

(define (cancel-breakpoint machine label n) ;ex5.19
  ((machine 'cancel-breakpoint) label n))

(define (cancel-all-breakpoints machine) ;ex5.19
  (machine 'cancel-all-breakpoints))

(define (proceed-machine machine) ;ex5.19
  (machine 'proceed-machine))

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (the-labels '()) ;ex5.19
        (trace-flag '()) ;ex5.16
        (inst-count 0) ;ex5.15
        (db '()))      ;ex5.12
    (let ((the-ops
             (list (list 'initialize-stack
                         (lambda () (stack 'initialize)))
                   (list 'print-stack-statistics
                         (lambda () (stack 'print-statistics)))
                   (list 'trace-on  ;ex5.16
                         (lambda () (set! trace-flag #t)))
                   (list 'trace-off ;ex5.16
                         (lambda () (set! trace-flag '())))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))
      (define (init-db)
               (set! db (map (lambda (x) (list x)) 
                   (list 'assign 'test 'branch 'goto 'save 'restore 'perform
                         'label-reg 'save-reg 'restore-reg 'source)))
               'done)
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (if (pair? (caaar insts)) (cdaaar insts) ;ex5.19

              (begin
                (if trace-flag
                 (cond ((eq? (caaar insts) 'label)
                        (newline) (display (cadaar insts)) (display ":"))
                       (else (newline) (display (caar insts)))))
                (if (not (eq? (caaar insts) 'label))
                    (set! inst-count (+ inst-count 1)))
                ((instruction-execution-proc (car insts)))
                 (execute))))))

      (define (set-breakpoint label n)  ;ex5.19 設定
        (let ((insts (lookup-label the-labels label))
          (breakpoint-id (list 'breakpoint label n)))
        (define (insert-breakpoint insts n) ;設定の下請け ループ
          (cond ((null? insts) (error "breakpoint too far -- SETBREAKPOINT" n))
                ((eq? (caaar insts) 'label) (insert-breakpoint (cdr insts) n))
                ((> n 0) (insert-breakpoint (cdr insts) (- n 1)))
                (else (set-car! (caar insts) 
                                (cons (caaar insts) breakpoint-id)))))
        (insert-breakpoint insts n)
       'done))

      (define (cancel-breakpoint label n)   ;ex5.19 削除
        (let ((insts (lookup-label the-labels label)))
       (define (remove-breakpoint insts n)  ;削除の下請け ループ
         (cond ((null? insts) 
                (error "breakpoint too far -- CANCELBREAKPOINT" n))
               ((eq? (caaar insts) 'label) (remove-breakpoint (cdr insts) n))
               ((> n 0) (remove-breakpoint (cdr insts) (- n 1)))
               ((pair? (caaar insts))
                (set-car! (caar insts) (caaaar insts)))))
       (remove-breakpoint insts n)
        'done))

      (define (reset insts)       ;ex5.19 ブレークポイント全部削除 
        (if (pair? insts)
          (begin
          (if (pair? (caaar insts))
                     (set-car! (caar insts) (caaaar insts)))
          (reset (cdr insts)))
          'done))

      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'init-db) (init-db)) ;ex5.12
              ((eq? message 'get-db) db) ;ex5.12


              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence (car seq))
                             (set! the-labels (cdr seq))))  ;ex5.19

              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              ((eq? message 'get-inst-count) inst-count) ;ex5.15
              ((eq? message 'reset-inst-count) (set! inst-count 0) 'ok);ex5.15
              ((eq? message 'set-breakpoint)            ;ex5.19
               (lambda (label n) (set-breakpoint label n)))
              ((eq? message 'cancel-breakpoint)         ;ex5.19
               (lambda (label n) (cancel-breakpoint label n)))
              ((eq? message 'cancel-all-breakpoints)    ;ex5.19
               (reset the-instruction-sequence))
              ((eq? message 'proceed-machine)           ;ex5.19
               ((instruction-execution-proc (car (get-contents pc))))
               (execute))
              (else (error "Unknown request -- MACHINE" message))))
     (init-db)     ;ex5.12 databaseの初期化
      dispatch)))

;;assembly program

(define (assemble controller-text machine)
  (extract-labels controller-text
    (lambda (insts labels)
      (update-insts! insts labels machine)
      (cons insts labels)))) ;ex5.19

(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)
             (let ((insts (cons (list (list 'label next-inst)) insts)));;ex5.17
               (receive insts
                        (cons (make-label-entry next-inst
                                                insts)
                              labels)))
               (receive (cons (make-instruction next-inst)
                              insts)
                        labels)))))))

(define (insert! value record)
  (if (not (member value (cdr record)))
      (set-cdr! record (cons value (cdr record)))))

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

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

(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))))

(define (make-execution-procedure inst labels machine
                                  pc flag stack ops)
  (cond ((eq? (car inst) 'assign)
         (make-assign inst machine labels ops pc))
        ((eq? (car inst) 'test)
         (make-test inst machine labels ops flag pc))
        ((eq? (car inst) 'branch)
         (make-branch inst machine labels flag 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 ops pc))
        ((eq? (car inst) 'label)      ;;ex5.17
         (lambda () (advance-pc pc)))
        (else (error "Unknown instruction type -- ASSEMBLE"
                     inst))))

(define (make-assign inst machine labels operations pc)
  (let ((target
         (get-register machine (assign-reg-name inst)))
        (value-exp (assign-value-exp inst)))
    (insert! inst (assoc 'assign (machine 'get-db)))
    (let ((reg (assign-reg-name inst))
          (val (assign-value-exp inst))
          (record (assoc 'source (machine 'get-db))))
;(newline) (display record)
     (if (assoc reg (cdr record))
        (insert! val (assoc reg (cdr record)))
        (set-cdr! record (cons (list reg val) (cdr record)))))
    (let ((value-proc
           (if (operation-exp? value-exp)
               (make-operation-exp
                value-exp machine labels operations)
               (make-primitive-exp
                (car value-exp) machine labels))))
      (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))

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

(define (make-test inst machine labels operations flag pc)
  (let ((condition (test-condition inst)))
    (insert! inst (assoc 'test (machine 'get-db)))
    (if (operation-exp? condition)
        (let ((condition-proc
               (make-operation-exp
                condition machine labels operations)))
          (lambda ()
            (set-contents! flag (condition-proc))
            (advance-pc pc)))
        (error "Bad TEST instruction -- ASSEMBLE" inst))))

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

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

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

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

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

(define (make-save inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (insert! inst (assoc 'save (machine 'get-db)))
    (insert! (stack-inst-reg-name inst)
                  (assoc 'save-reg (machine 'get-db)))
    (lambda ()
;      (display (list 'push reg)) (newline)
      (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))))
    (insert! inst (assoc 'restore (machine 'get-db)))
    (insert! (stack-inst-reg-name inst)
                  (assoc 'restore-reg (machine 'get-db)))
    (lambda ()
;      (display (list 'pop reg)) (newline)
      (set-contents! reg (pop stack))    
      (advance-pc pc))))

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

(define (make-perform inst machine labels operations pc)
  (let ((action (perform-action inst)))
    (insert! inst (assoc 'perform (machine 'get-db)))
    (if (operation-exp? action)
        (let ((action-proc
               (make-operation-exp
                action machine labels operations)))
          (lambda ()
            (action-proc)
            (advance-pc pc)))
        (error "Bad PERFORM instruction -- ASSEMBLE" inst))))

(define (perform-action inst) (cdr 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 (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 operations)
  (let ((op (lookup-prim (operation-exp-op exp) operations))
        (aprocs
         (map (lambda (e)
                (make-primitive-exp e machine labels))
              (operation-exp-operands exp))))
    (lambda ()
      (apply op (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))

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

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

;再帰版
(define expt-machine
  (make-machine
   '(b n val continue)
   (list (list '- -) (list '* *) (list '= =))
   '((assign continue (label expt-done))
   expt-loop
     (assign val (const 1))
     (test (op =) (reg n) (const 0))
     (branch (label return))
     (save continue)
     (assign continue (label after-expt))
     (assign n (op -) (reg n) (const 1))
     (goto (label expt-loop))
  after-expt
     (restore continue)
     (assign val (op *) (reg b) (reg val))
     (goto (reg continue))
  return
     (assign val (const 1))
     (goto (reg continue))
  expt-done)))

(set-register-contents! expt-machine 'b 2)

(set-register-contents! expt-machine 'n 8)

(start expt-machine)

(get-register-contents expt-machine 'val)

;反復版
(define expt-machine
  (make-machine
   '(b n counter product)
   (list (list '- -) (list '* *) (list '= =))
   '((assign counter (reg n))
     (assign product (const 1))
   expt-loop
     (test (op =) (reg counter) (const 0))
     (branch (label expt-done))
     (assign counter (op -) (reg counter) (const 1))
     (assign product (op *) (reg b) (reg product))
     (goto (label expt-loop))
  expt-done)))

(set-register-contents! expt-machine 'b 2)

(set-register-contents! expt-machine 'n 8)

(start expt-machine)

(get-register-contents expt-machine 'product)

(define ex5.8machine
  (make-machine
 '(a)
 '()
 '(start
    (goto (label here))
   here
    (assign a (const 3))
    (goto (label there))
   here
    (assign a (const 4))
    (goto (label there))
   there)))

(start ex5.8machine)
(get-register-contents ex5.8machine 'a)
; 実行してみると -> 3 

; labelをlabelsに追加するときに，すでに存在していたらエラーとする．
; 以下のように修正する．

(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)
             (if (assoc next-inst labels)
                 (error "The same label name used --- ASSEMBLE" 
                        next-inst)
                 (receive insts
                          (cons (make-label-entry next-inst
                                                  insts)
                                labels)))
               (receive (cons (make-instruction next-inst)
                              insts)
                        labels)))))))

;上のプログラムを実行してみると，
;The same label name used --- ASSEMBLE here
問題 5.9

make-assign (p.313)をみると，演算子なしの代入でmake-primitive-expを使い，
演算子があるときはmake-operation-expを呼ぶ．このmake-operation-exp(p.316)
はまたmake-primitive-expを使っている．

make-primitive-expでlabelが見つかるが，演算から呼ばれたときはlabelは使えない
ようにすればよい．

たとえば

(define ex5.9machine
 (make-machine
 '()
 (list (list '= =))
 '(start
   (test (op =) (label start) (label start)))))

は通過する．

そこで次のように修正する．
(define (make-assign inst machine labels operations pc)
  (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 operations)
               (make-primitive-exp
                (car value-exp) machine labels '#t))))
      (lambda ()
        (set-contents! target (value-proc))
        (advance-pc pc)))))

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

(define (make-operation-exp exp machine labels operations)
  (let ((op (lookup-prim (operation-exp-op exp) operations))
        (aprocs
         (map (lambda (e)
                (make-primitive-exp e machine labels '()))
              (operation-exp-operands exp))))
    (lambda ()
      (apply op (map (lambda (p) (p)) aprocs)))))

;これで上のプログラムを実行すると
;Label used in operation --- ASSEMBLE (label start)


問題 5.11

a.

afterfib-n-2
の下の2行
(assign n (reg val))
(restore val)
を
(restore n)
に変える. 
Fib(n-1) Fib(n-2)は反対のレジスタに入るが結果は同じになる. 

問題 5.12

make-new-machine の変数に db (database) を追加

dbを読むインターフェース手続き
 (define (get-db machine)
   (machine 'get-db))

dbを初期化する手続き make-new-machineの内部
 (define (init-db)
          (set! db (map (lambda (x) (list x))
              (list 'assign 'test 'branch 'goto 'save 'restore 'perform
                    'label-reg 'save-reg 'restore-reg 'source)))
          'done)

二つのメッセージを追加
 ((eq? message 'init-db) (init-db))
 ((eq? message 'get-db) db)

初期化を起動
(init-db)

dbに新規追加する手続き
 (define (insert! value record)
   (if (not (member value (cdr record)))
       (set-cdr! record (cons value (cdr record)))))

make-assocの中
     (insert! inst (assoc 'assign (machine 'get-db)))
     (let ((reg (assign-reg-name inst))
           (val (assign-value-exp inst))
           (record (assoc 'source (machine 'get-db))))
      (if (assoc reg (cdr record))
         (insert! val (assoc reg (cdr record)))
         (set-cdr! record (cons (list reg val) (cdr record)))))

make-test
     (insert! inst (assoc 'test (machine 'get-db)))
make-branch
     (insert! inst (assoc 'branch (machine 'get-db)))
make-goto
     (insert! inst (assoc 'goto (machine 'get-db)))

            (insert! (register-exp-reg dest)
                     (assoc 'label-reg (machine 'get-db)))
make-save
     (insert! inst (assoc 'save (machine 'get-db)))
     (insert! (stack-inst-reg-name inst)
                   (assoc 'save-reg (machine 'get-db)))
make-restore
     (insert! inst (assoc 'restore (machine 'get-db)))
     (insert! (stack-inst-reg-name inst)
                   (assoc 'restore-reg (machine 'get-db)))
make-perform
     (insert! inst (assoc 'perform (machine 'get-db)))

を追加する

fibonacci-machineを定義し (get-db 'fibonacci-machine)を実行すると

((assign
 (assign val (reg n))
 (assign val (op +) (reg val) (reg n))
 (assign n (reg val))
 (assign continue (label afterfib-n-2))
 (assign n (op -) (reg n) (const 2))
 (assign n (op -) (reg n) (const 1))
 (assign continue (label afterfib-n-1))
 (assign continue (label fib-done)))
 (test
 (test (op <) (reg n) (const 2)))
 (branch
 (branch (label immediate-answer)))
 (goto
 (goto (reg continue))
 (goto (label fib-loop)))
 (save
 (save val)
 (save n)
 (save continue))
 (restore
 (restore val)
 (restore continue)
 (restore n))
 (perform)
 (label-reg continue)
 (save-reg val n continue)
 (restore-reg val continue n)
 (source
 (val ((reg n)) ((op +) (reg val) (reg n)))
 (n ((reg val)) ((op -) (reg n) (const 2)) ((op -) (reg n) (const 1)))
 (continue ((label afterfib-n-2)) ((label afterfib-n-1)) ((label fib-done)))))
が得られる. 


問題 5.14

まず階乗計算機を定義し

(define fact-machine
  (make-machine
   '(continue n val)
   (list (list '= =) (list '- -) (list '* *))
   '((perform (op initialize-stack))
     (assign continue (label fact-done))
 fact-loop
   (test (op =) (reg n) (const 1))
   (branch (label base-case))
   (save continue)
   (save n)
   (assign n (op -) (reg n) (const 1))
   (assign continue (label after-fact))
   (goto (label fact-loop))
 after-fact
   (restore n)
   (restore continue)
   (assign val (op *) (reg n) (reg val))
   (goto (reg continue))
 base-case
   (assign val (const 1))
   (goto (reg continue))
 fact-done
   (perform (op print-stack-statistics)))))

スタックをテストするプログラムを書き
(define (stack-test n)
(newline)(display "n = ") (display n)
(set-register-contents! fact-machine 'n n)
(start fact-machine)
(newline)(display (get-register-contents fact-machine 'val)))


(stack-test 1) 
(stack-test 2)
(stack-test 3)
(stack-test 4)
(stack-test 5)
(stack-test 6)
(stack-test 7)
(stack-test 8)
(stack-test 9)
(stack-test 10)

でテストする．実行結果

n = 1
(total-pushes = 0 maximum-depth = 0)
1
n = 2
(total-pushes = 2 maximum-depth = 2)
2
n = 3
(total-pushes = 4 maximum-depth = 4)
6
n = 4
(total-pushes = 6 maximum-depth = 6)
24
n = 5
(total-pushes = 8 maximum-depth = 8)
120
n = 6
(total-pushes = 10 maximum-depth = 10)
720
n = 7
(total-pushes = 12 maximum-depth = 12)
5040
n = 8
(total-pushes = 14 maximum-depth = 14)
40320
n = 9
(total-pushes = 16 maximum-depth = 16)
362880
n = 10
(total-pushes = 18 maximum-depth = 18)
3628800 -- done
Unspecified return value

問題 5.15

make-new-machineの変数にinst-countを用意する

(execute)の中でinst-countを増やす

 (set! inst-count (+ inst-count 1))

インターフェース
(define (reset-inst-count machine)
  (machine 'reset-inst-count))

(define (get-inst-count machine)
  (machine 'get-inst-count))

メッセージ処理

 ((eq? message 'get-inst-count) inst-count)
 ((eq? message 'reset-inst-count) (set! inst-count 0) 'ok)


fibonacci-machineを実行してみる


;Value: fibonacci-machine

1 ]=> (set-register-contents! fibonacci-machine 'n 10)

;Value: done

1 ]=> (start fibonacci-machine)

;Value: done

1 ]=> (get-inst-count fibonacci-machine)

;Value: 2029

1 ]=> (get-register-contents fibonacci-machine 'val)

;Value: 55


問題 5.16

make-new-machineの中に

(define trace-flag '())

を追加し

executeの中でトレースする

  (if trace-flag
      (begin (newline) (display (caar insts))))

 (perform (op trace-on))  でトレース開始
 (perform (op trace-off)) でトレース終了


(define fibonacci-machine
  (make-machine
   '(continue n val)
   (list (list '< <) (list '- -) (list '+ +))
;;         (list 'trace-on trace-on) (list 'trace-off trace-off)) ;;opを追加
;; 演算子のリストにtrace-on, trace-offはいらない, make-new-machineで定義済み

   '(
   (assign continue (label fib-done))
 fib-loop
   (test (op <) (reg n) (const 2))
   (branch (label immediate-answer))
   (save continue)
   (assign continue (label afterfib-n-1))
   (save n)
   (assign n (op -) (reg n) (const 1))
   (goto (label fib-loop))
 afterfib-n-1
   (restore n)
   (perform (op trace-on))          ;; trace-on
   (restore continue)
   (assign n (op -) (reg n) (const 2))
   (save continue)
   (assign continue (label afterfib-n-2))
   (save val)
   (goto (label fib-loop))
 afterfib-n-2
   (assign n (reg val))
   (restore val)
   (perform (op trace-off))
   (restore continue)
   (assign val (op +) (reg val) (reg n)) 
   (goto (reg continue))
 immediate-answer
   (assign val (reg n))
   (goto (reg continue))
 fib-done)))

(set-register-contents! fibonacci-machine 'n 2)
(start fibonacci-machine)
(get-register-contents fibonacci-machine 'val)

n=2で実行してみる

(assign continue (label fib-done))
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(assign val (reg n))
(goto (reg continue))
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(assign val (reg n))
(goto (reg continue))
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue)) -- done
;Value: 1


問題 5.17

ラベルが現れたらextract-labelsでinstの前に ((label )) を追加しておく．

(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)
             (let ((insts (cons (list (list 'label next-inst)) insts)));;ex5.17
               (receive insts
                        (cons (make-label-entry next-inst
                                                insts)
                              labels)))
               (receive (cons (make-instruction next-inst)
                              insts)
                        labels)))))))

make-execution-procedure では(label )が来たら

        ((eq? (car inst) 'label) 
         (lambda () (monitor machine inst) (advance-pc pc)))

と実行手続きを返す．

一方(execute)は

(define (monitor machine inst)   ;;ex5.12
 (cond ((eq? (car inst) 'label)(newline)(display (cadr inst)) (display ':))
       (else ...

(label )ならdatabaseの処理にいかず，:を印字する．


fibonacci-machine で n=2 のアセンブリとトレースは以下のようになる

insts

(((assign continue (label fib-done))) ((label fib-loop))
 ((test (op <) (reg n) (const 2))) ((branch (label immediate-answer)))
 ((save continue)) ((assign continue (label afterfib-n-1))) ((save n))
 ((assign n (op -) (reg n) (const 1))) ((goto (label fib-loop)))
 ((label afterfib-n-1)) ((restore n)) ((restore continue))
 ((assign n (op -) (reg n) (const 2))) ((save continue))
 ((assign continue (label afterfib-n-2))) ((save val))
 ((goto (label fib-loop))) ((label afterfib-n-2)) ((assign n (reg val)))
 ((restore val)) ((restore continue)) ((assign val (op +) (reg val) (reg n)))
 ((goto (reg continue))) ((label immediate-answer)) ((assign val (reg n)))
 ((goto (reg continue))) ((label fib-done)))

labels

((fib-loop ((label fib-loop)) ((test (op <) (reg n) (const 2)))
 ((branch (label immediate-answer))) ((save continue))
 ((assign continue (label afterfib-n-1))) ((save n))
 ((assign n (op -) (reg n) (const 1))) ((goto (label fib-loop)))
 ((label afterfib-n-1)) ((restore n)) ((restore continue))
 ((assign n (op -) (reg n) (const 2))) ((save continue))
 ((assign continue (label afterfib-n-2))) ((save val))
 ((goto (label fib-loop))) ((label afterfib-n-2)) ((assign n (reg val)))
 ((restore val)) ((restore continue)) ((assign val (op +) (reg val) (reg n)))
 ((goto (reg continue))) ((label immediate-answer)) ((assign val (reg n)))
 ((goto (reg continue))) ((label fib-done)))

 (afterfib-n-1 ((label afterfib-n-1)) ((restore n)) ((restore continue))
 ((assign n (op -) (reg n) (const 2))) ((save continue))
 ((assign continue (label afterfib-n-2))) ((save val))
 ((goto (label fib-loop))) ((label afterfib-n-2)) ((assign n (reg val)))
 ((restore val)) ((restore continue)) ((assign val (op +) (reg val) (reg n)))
 ((goto (reg continue))) ((label immediate-answer)) ((assign val (reg n)))
 ((goto (reg continue))) ((label fib-done)))

 (afterfib-n-2 ((label afterfib-n-2)) ((assign n (reg val))) ((restore val))
 ((restore continue)) ((assign val (op +) (reg val) (reg n)))
 ((goto (reg continue))) ((label immediate-answer)) ((assign val (reg n)))
 ((goto (reg continue))) ((label fib-done)))

 (immediate-answer ((label immediate-answer)) ((assign val (reg n)))
 ((goto (reg continue))) ((label fib-done)))

 (fib-done ((label fib-done))))

実行トレース
(assign continue (label fib-done))
fib-loop:
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
(save continue)
(assign continue (label afterfib-n-1))
(save n)
(assign n (op -) (reg n) (const 1))
(goto (label fib-loop))
fib-loop:
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer:
(assign val (reg n))
(goto (reg continue))
afterfib-n-1:
(restore n)
(restore continue)
(assign n (op -) (reg n) (const 2))
(save continue)
(assign continue (label afterfib-n-2))
(save val)
(goto (label fib-loop))
fib-loop:
(test (op <) (reg n) (const 2))
(branch (label immediate-answer))
immediate-answer:
(assign val (reg n))
(goto (reg continue))
afterfib-n-2:
(assign n (reg val))
(restore val)
(restore continue)
(assign val (op +) (reg val) (reg n))
(goto (reg continue))
fib-done: -- done
;Value: 1
問題 5.18

;レジスタの内容を見る/止める ;ex5.18
;(set-register-trace!  )
;(reset-register-trace!  )

make-registerの変数にtrace-flagを追加する

(let ((contents '*unassigned*) (trace-flag '()))  ;;ex5.18

メッセージsetを修正する

      ((eq? message 'set)
       (lambda (value) 
         (if trace-flag
           (begin (newline) (display "register name:") (display name)
                  (newline) (display "old content:") (display contents)
                  (newline) (display "new content:") (display value)))
         (set! contents value)))

メッセージtrace-on trace-offを追加する

      ((eq? message 'trace-on) (set! trace-flag #t))
      ((eq? message 'trace-off) (set! trace-falg '()))

インターフェースを追加する

(define (set-register-trace! machine register-name)
  (set-trace (get-register machine register-name)))

(define (reset-register-trace! machine register-name)
  (reset-trace (get-register machine register-name)))


問題 5.19

;ブレークポイント ;ex5.19
;(set-breakpoint   )    ;設定
;(cancel-breakpoint   ) ;削除
;(cancel-all-breakpoints )    ;全体削除
;(proceed-machine )           ;再起動

ブレークポイントの命令は
(assign  ...)
の代わりに
((assign  )  ...)
のように作る. 
(execute)で命令の先頭がpairなら止まる. 

インターフェース

(define (set-breakpoint machine label n) ;ex5.19
  ((machine 'set-breakpoint) label n))

(define (cancel-breakpoint machine label n) ;ex5.19
  ((machine 'cancel-breakpoint) label n))

(define (cancel-all-breakpoints machine)
  (machine 'cancel-all-breakpoints))

(define (proceed-machine machine) ;ex5.19
  (machine 'proceed-machine))

ラベルを探すため make-new-machineにthe-labelsを変数を追加する
        (the-labels '()) ;ex5.19

executeでブレークポイントをさがす. 
              (if (pair? (caaar insts)) (cdaaar insts) ;ex5.19

make-new-machineにブレークポイント設定削除の手続きをおく. 

      (define (set-breakpoint label n)  ;ex5.19 設定
        (let ((insts (lookup-label the-labels label))
          (breakpoint-id (list 'breakpoint label n)))
        (define (insert-breakpoint insts n) ;設定の下請け ループ
          (cond ((null? insts) (error "breakpoint too far -- SETBREAKPOINT" n))
                ((eq? (caaar insts) 'label) (insert-breakpoint (cdr insts) n))
                ((> n 0) (insert-breakpoint (cdr insts) (- n 1)))
                (else (set-car! (caar insts) 
                                (cons (caaar insts) breakpoint-id)))))
        (insert-breakpoint insts n)
       'done))

      (define (cancel-breakpoint label n)   ;ex5.19 削除
        (let ((insts (lookup-label the-labels label)))
       (define (remove-breakpoint insts n)  ;削除の下請け ループ
         (cond ((null? insts) 
                (error "breakpoint too far -- CANCELBREAKPOINT" n))
               ((eq? (caaar insts) 'label) (remove-breakpoint (cdr insts) n))
               ((> n 0) (remove-breakpoint (cdr insts) (- n 1)))
               ((pair? (caaar insts))
                (set-car! (caar insts) (caaaar insts)))))
       (remove-breakpoint insts n)
       'done))

      (define (dispatch message)
(define (reset insts)
  (if (pair? insts)
      (if (pair? (caaar insts))
                 (set-car! (caar insts) (caaaar insts)))
                 (reset (cdr insts))))

メッセージ処理の追加
              ((eq? message 'set-breakpoint)            ;ex5.19
               (lambda (label n) (set-breakpoint label n)))
              ((eq? message 'cancel-breakpoint)         ;ex5.19
               (lambda (label n) (cancel-breakpoint label n)))
              ((eq? message 'cancel-all-breakpoints)    ;ex5.19
               (reset the-instruction-sequence)
               'done)

the-labelsを設定するため, assembleはinstsの他にlabelsもドット対にして返す. 
(define (assemble controller-text machine)
  (extract-labels controller-text
    (lambda (insts labels)
      (update-insts! insts labels machine)
      (cons insts labels)))) ;ex5.19

install-instruction-sequenceでもどってきたthe-labelsを設定する

              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence (car seq))

                             (set! the-labels (cdr seq))))  ;ex5.19