2014年12月11日木曜日

開発環境

計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の5(レジスタ計算機での計算)、5.3(記憶の割り当てとごみ集め)、5.3.1(ベクターとしてのメモリー)、Lispデータの表現、基本リスト演算の実装、スタックの実装、問題 5.21-a.を解いてみる。

その他参考書籍

問題 5.21-a.

コード(BBEdit, Emacs)

simulator.scm

;; -*- coding: utf-8 -*-

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

(define (make-machine ops controller-text)
  (let ((machine (make-new-machine)))
    ((machine 'install-operations) ops)
    ((machine 'install-instruction-sequence)
     (assemble controller-text machine))
    machine))

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

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

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

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

(define (print-statistics machine)
  ((machine 'stack) 'print-statistics))

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (instruction-counting 0)
        (trace-flag #f)
        (label '())
        (breakpoints '())
        (current-n -1))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 (list 'print-stack-statisstics
                       (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)
              (begin (allocate-register name)
                     (lookup-register name)))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin                
                (if (eq? (caaar insts) 'label)
                    (begin (set! label (cadr (caar insts)))
                           (set! current-n 0))
                    (set! instruction-counting (+ instruction-counting 1)))
                (if trace-flag
                    (print "label: " label ", trace: " (caar insts)))
                (let ((val (assoc label breakpoints)))
                  (if (and val
                           (memq current-n (cdr val)))
                      (print "break label:" label " offset:" current-n)
                      (begin ((instruction-execution-proc (car insts)))
                             (set! current-n (+ current-n 1))
                             (execute))))))))
      (define (set-breakpoint label n)
        (let ((val (assoc label breakpoints)))
          (if val
              (set-cdr! val (cons n (cdr val)))
              (set! breakpoints (cons (cons label (list n)) breakpoints))))
        'done)
      (define (proceed-machine)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin                
                (if (eq? (caaar insts) 'label)
                    (begin (set! label (cadr (caar insts)))
                           (set! current-n 0))
                    (set! instruction-counting (+ instruction-counting 1)))
                (if trace-flag
                    (print "label: " label ", trace: " (caar insts)))
                (begin ((instruction-execution-proc (car insts)))
                       (set! current-n (+ current-n 1))
                       (execute))))))
      (define (cancel-breakpoint label n)
        (let ((val (assoc label breakpoints)))
          (if val
              (set-cdr! val (filter (lambda (i)
                                      (not (= i n)))
                                    (cdr val))))))
      (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)
              ((eq? message 'print-instruction-counting)
               (print "(instruction-counting = " instruction-counting ")"))
              ((eq? message 'initialize-instruction-counting)
               (set! instruction-counting 0)
               'done)
              ((eq? message 'trace-on) (set! trace-flag #t))
              ((eq? message 'trace-off) (set! trace-flag #f))
              ((eq? message 'trace-register-on)
               (lambda (reg-name)
                 (let ((val (lookup-register reg-name)))
                   (if val
                       (val 'trace-on)
                       (error "Unknown register:" reg-name)))))
              ((eq? message 'trace-register-off)
               (lambda (reg-name)
                 (let ((val (lookup-register reg-name)))
                   (if val
                       (val 'trace-off)
                       (error "Unknown register:" reg-name)))))
              ((eq? message 'set-breakpoint) set-breakpoint)               
              ((eq? message 'proceed-machine) proceed-machine)
              ((eq? message 'cancel-breakpoint) cancel-breakpoint)
              ((eq? message 'cancel-all-breakpoints)
               (set! breakpoints '()))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

(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 (print-instruction-counting machine)
  (machine 'print-instruction-counting))

(define (initialize-instruction-counting machine)
  (machine 'initialize-instruction-counting))

(define (trace-register-on machine register-name)
  ((machine 'trace-register-on) register-name))

(define (trace-register-off machine register-name)
  ((machine 'trace-register-off) register-name))

(define (set-breakpoint machine label n)
  ((machine 'set-breakpoint) label n))

(define (proceed-machine machine)
  ((machine 'proceed-machine)))

(define (cancel-breakpoint machine label n)
  ((machine 'cancel-breakpoint) label n))

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

(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)
               (if (assoc next-inst labels)
                   (error "Multiply defined label:" next-inst)
                   (begin (set! insts (cons (list (list 'label next-inst))
                                            insts))
                          (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))))

(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) 'del)
         ((make-del inst machine pc)))
        ((eq? (car inst) 'label)
         (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)))
    (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 ()
        (if (target 'trace?)
            (print "register-name:" (assign-reg-name inst)
                   " old:" (get-contents target)
                   " new:" (value-proc)))
        (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)))
    (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))

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

(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)
                (if (label-exp? e)
                    (error "Bad OPERANDS instruction -- ASSEMBLE" 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 (make-del inst machine pc)
  (let ((target
         (get-register machine (del-reg-name inst))))
    (lambda ()
      (set-contents! target '*unassigned*)
      (advance-pc pc))))

(define (del-reg-name delete-instruction)
  (cadr delete-instruction))

sample21_a.scm

#!/usr/bin/env gosh
;;-*- coding: utf-8 -*-

(load "./simulator.scm")

(define count-leaves-machine
  (make-machine
   (list (list 'cdr cdr)
         (list 'car car)
         (list 'null? null?)
         (list 'pair? pair?)
         (list '+ +))
   '((assign continue (label count-leaves-done))
     loop
     (test (op null?) (reg tree))
     (branch (label null))
     (test (op pair?) (reg tree))
     (branch (label pair))
     (assign val (const 1))
     (goto (reg continue))
     after-left
     (restore tree)
     (assign tree (op cdr) (reg tree))
     (assign continue (label after-right))
     (save val)
     (goto (label loop))
     after-right
     (assign right-val (reg val))
     (restore val)
     (assign val (op +) (reg val) (reg right-val))
     (restore continue)
     (goto (reg continue))
     pair
     (save continue)
     (save tree)
     (assign continue (label after-left))
     (assign tree (op car) (reg tree))
     (goto (label loop))
     null
     (assign val (const 0))
     (goto (reg continue))
     count-leaves-done)))

(print "tree: ()")
(set-register-contents! count-leaves-machine 'tree '())
(start count-leaves-machine)
(print (get-register-contents count-leaves-machine 'val))

(print "tree: (())")
(set-register-contents! count-leaves-machine 'tree '(()))
(start count-leaves-machine)
(print (get-register-contents count-leaves-machine 'val))

(print "tree: (a . b)")
(set-register-contents! count-leaves-machine 'tree (cons 'a 'b))
(start count-leaves-machine)
(print (get-register-contents count-leaves-machine 'val))

(print "tree: ((a . b) . (c . (d . e)))")
(set-register-contents! count-leaves-machine 'tree (cons (cons 'a 'b)
                                                         (cons 'c
                                                               (cons 'd 'e))))
(start count-leaves-machine)
(print (get-register-contents count-leaves-machine 'val))

(print "tree: ((a . '()) . (c . (d . e)))")
(set-register-contents! count-leaves-machine 'tree (cons (cons 'a '())
                                                         (cons 'c
                                                               (cons 'd 'e))))
(start count-leaves-machine)
(print (get-register-contents count-leaves-machine 'val))



入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))

$ ./sample21_a.scm 
tree: ()
0
tree: (())
0
tree: (a . b)
2
tree: ((a . b) . (c . (d . e)))
5
tree: ((a . '()) . (c . (d . e)))
4
$

0 コメント:

コメントを投稿