ヤドカリ自習室(第二倉庫)

 | 

2009-11-24

[]問題5.12 02:13

;; 補助関数
(define (filter pred lst)
  (cond ((null? lst) '())
        ((pred (car lst))
         (cons (car lst)
               (filter pred (cdr lst))))
        (else (filter pred (cdr lst)))))

(define (remove-duplicates lst)
  (define (iter lst result)
    (if (null? lst) result
        (if (member (car lst) (cdr lst))
            (iter (cdr lst) result)
            (iter (cdr lst) (cons (car lst) result)))))
  (iter lst '()))

;; 命令列情報の生成関数
(define (make-information insts)
  (let ((insts-text (map instruction-text insts)))
    (apply append
           (map
            (lambda (name)
              (remove-duplicates
               (filter
                (lambda (i) (eq? (car i) name))
                insts-text)))
            '(assign test branch goto save restore perform)))))

;; 処理系の書き換え分
(define (assemble controller-text machine)
  (extract-labels controller-text
    (lambda (insts labels)
      (update-insts! insts labels machine)
      (cons insts (make-information insts)))))

(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)
    (let ((assembled (assemble controller-text machine)))
      ((machine 'install-instruction-sequence)
       (car assembled))
      ((machine 'install-information)
       (cdr assembled)))
    machine))

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (information '()))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))))
          (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 (get-goto-reg information)
        (define (iter info result)
          (if (null? info) result
              (if (and (eq? (caar info) 'goto)
                       (eq? (car (cadr (car info))) 'reg))
                  (iter (cdr info) (cons (cadr (cadr (car info))) result))
                  (iter (cdr info) result))))
        (iter information '()))
      (define (get-save-restore-reg information)
        (define (iter info result)
          (if (null? info) result
              (if (or (eq? (caar info) 'save)
                      (eq? (caar info) 'restore))
                  (iter (cdr info) (cons (cadr (car info)) result))
                  (iter (cdr info) result))))
        (remove-duplicates (iter information '())))
      (define (get-assign-source information)
        (define (iter info result)
          (if (null? info) result
              (if (eq? (caar info) 'assign)
                  (iter (cdr info)
                        (cons
                         (if (null? (cdddr (car info)))
                             (cdr (car info))
                             (list (cadr (car info)) (cddr (car info))))
                         result))
                  (iter (cdr info) result))))
        (iter information '()))
      (define (aggregate source)
        (map (lambda (r)
               (cons r
                     (map cadr
                          (filter (lambda (p) (eq? (car p) r)) source))))
             (remove-duplicates (map car source))))
      (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 'install-information)
               (lambda (info) (set! information (append information info))))
              ((eq? message 'get-insts-info)
               information)
              ((eq? message 'get-goto-reg-info)
               (get-goto-reg information))
              ((eq? message 'get-save-restore-reg-info)
               (get-save-restore-reg information))
              ((eq? message 'get-assign-source-info)
               (aggregate (get-assign-source information)))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

;; 大域環境用の関数インタフェース
(define (get-insts-info machine)
  (machine 'get-insts-info))
(define (get-goto-reg-info machine)
  (machine 'get-goto-reg-info))
(define (get-save-restore-reg-info machine)
  (machine 'get-save-restore-reg-info))
(define (get-assign-source-info machine)
  (machine 'get-assign-source-info))

;; fib計算機
(define fib-machine
  (make-machine
   '(n val continue)
   (list (list '< <) (list '- -) (list '+ +))
   '(
       (assign continue (label fib-done))
     fib-loop
       (test (op <) (reg n) (const 2))
       (branch (label immediate-answer))
       ;; set up to compute Fib(n - 1)
       (save continue)
       (assign continue (label afterfib-n-1))
       (save n)                           ; save old value of n
       (assign n (op -) (reg n) (const 1)); clobber n to n - 1
       (goto (label fib-loop))            ; perform recursive call
     afterfib-n-1                         ; upon return, val contains Fib(n - 1)
       (restore n)
       (restore continue)
       ;; set up to compute Fib(n - 2)
       (assign n (op -) (reg n) (const 2))
       (save continue)
       (assign continue (label afterfib-n-2))
       (save val)                         ; save Fib(n - 1)
       (goto (label fib-loop))
     afterfib-n-2                         ; upon return, val contains Fib(n - 2)
       (assign n (reg val))               ; n now contains Fib(n - 2)
       (restore val)                      ; val now contains Fib(n - 1)
       (restore continue)
       (assign val                        ;  Fib(n - 1) +  Fib(n - 2)
               (op +) (reg val) (reg n)) 
     (goto (reg continue))              ; return to caller, answer is in val
     immediate-answer
       (assign val (reg n))               ; base case:  Fib(n) = n
       (goto (reg continue))
     fib-done)))

;; fib計算機の情報を表示
(define (info-fib-machine)
  (display "instructions: ")
  (display (get-insts-info fib-machine))
  (newline) (newline)
  (display "label registers: ")
  (display (get-goto-reg-info fib-machine))
  (newline)  (newline)
  (display "stacked registers: ")
  (display (get-save-restore-reg-info fib-machine))
  (newline)  (newline)
  (display "assign sources: ")
  (display (get-assign-source-info fib-machine))
  (newline)
  'done)

FoutleweefbofikFoutleweefbofik 2014/01/19 08:08 <a href="http://freecialiscialissaleyce.com/#nuan">cialis prescription</a> .,You can <a href="http://freecialiscialissalestrh.com/#wugk">cialis reviews</a> at large discounts with great service,Excellent health benefits are attainable when you <a href="http://cialisukcialissoftarry.com/#rhyw">buy cialis online</a>

jydnasgpsljydnasgpsl 2014/12/03 22:33 vxfqgtjdq, <a href="http://www.nwodugbkxi.com/">ctbkxbogyv</a> , [url=http://www.ebfdacihvr.com/]tblosnothx[/url], http://www.yqzlddjudk.com/ ctbkxbogyv

ゲスト



トラックバック - http://sicp.g.hatena.ne.jp/yad-EL/20091124
 |