SICP 問題 5.08

start
 (goto (label here))
here
 (assign a (const 3))
 (goto (label there))
here
 (assign a (const 4))
 (goto (label there))
there

この時thereに達した時のaの値は何かという問題．

(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      (extract-labels (cdr text)
                      (lambda (insts labels)
                        (let ((next-inst (car text)))
                          ;; symbolであればlabel
                          (if (symbol? next-inst)
                              ;; (receive insts labels)なのでsymbolならlabelsにcons
                              ;; falseならinstsにcons
                              (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 ps)))
     insts)))

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

からlabelsは順番を保持してlabelsに登録されていく． lookup-labelではassocが使われているので先頭に近いものが先に選ばれる．
そのため(goto (label here))で向かうのは最初のhere. aには3が入っている．
　
これを同じラベルを違う場所に登録しようとするとエラーとなるようにする．

(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      (extract-labels (cdr text)
                      (lambda (insts labels)
                        (let ((next-inst (car text)))
                          ;; symbolであればlabel
                          (if (symbol? next-inst)
                              (if (assoc next-inst labels) ;;labelsに既に登録されていればここでtrueが返る
                                  (error "The same label name is used to indicate two different location " label-name)
                                  (receive insts
                                      (cons (make-label-entry next-inst insts)
                                            labels)))
                              (receive (cons (make-instruction next-inst)
                                             insts)
                                  labels)))))))