SICP
Exercise 5.20
;;; pair pointer の形式を (vector index)+10000000 とした。
(define ex5.20
(make-machine
'(the-cars the-cdrs free pointerID
x y ret val sval)
(list (list 'vector-ref vector-ref) (list 'vector-set! vector-set!)
(list 'make-vector make-vector)
(list '+ +) (list '- -) (list 'format format) (list '>= >=))
'(machine
(assign the-cars (op make-vector) (const 100))
(assign the-cdrs (op make-vector) (const 100))
(assign pointerID (const 10000000))
(assign free (reg pointerID))
(goto (label main))
;; (define (list x y)
;; (cons x (cons y '())))
;; val:x sval:y / val:list
list
(save ret)
(save val)
(assign val (reg sval))
(assign sval (const ()))
(assign ret (label list-1))
(goto (label cons))
list-1
(assign sval (reg val))
(restore val)
(assign continue (label list-2))
(goto (label cons))
list-2
(restore continue)
(goto (reg continue))
;; (define (car x))
;; val:x / val:(car x)
car
(assign val (op -) (reg val) (reg pointerID))
(assign val (op vector-ref) (reg the-cars) (reg val))
(goto (reg continue))
;; (define (cdr x))
;; val:x / val:(cdr x)
cdr
(assign val (op -) (reg val) (reg pointerID))
(assign val (op vector-ref) (reg the-cdrs) (reg val))
(goto (reg continue))
;; (define (cons x y))
;; val:x sval:y / val:cons
cons
(assign free (op -) (reg free) (reg pointerID))
(perform (op vector-set!) (reg the-cars) (reg free) (reg val))
(perform (op vector-set!) (reg the-cdrs) (reg free) (reg sval))
(assign free (op +) (reg free) (reg pointerID))
(assign val (reg free))
(assign free (op +) (reg free) (const 1))
(goto (reg continue))
;;
;;
main
;; (define x (cons 1 2))
(assign val (const 1))
(assign sval (const 2))
(assign continue (label main-1))
(goto (label cons))
main-1
(assign x (reg val))
;; (define y (list x x))
(assign val (reg x))
(assign sval (reg x))
(assign continue (label main-2))
(goto (label list))
main-2
(assign y (reg val))
;;
;;
(perform (op format)
(const #t) (const "reg x:~s y:~s free:~s~%Pair-index~%")
(reg x) (reg y) (reg free))
(assign sval (reg pointerID))
loop
(test (op >=) (reg sval) (reg free))
(branch (label loop-end))
(assign val (reg sval))
(assign continue (label loop-1))
(goto (label car))
loop-1
(assign x (reg val))
(assign val (reg sval))
(assign continue (label loop-2))
(goto (label cdr))
loop-2
(assign y (reg val))
(perform (op format) (const #t) (const " ~8d car:~8s cdr:~8s~%")
(reg sval) (reg x) (reg y))
(assign sval (op +) (reg sval) (const 1))
(goto (label loop))
loop-end)
))
;;gosh> (start ex5.20)
;;reg x:10000000 y:10000002 free:10000003
;;Pair-index
;; 10000000 car:1 cdr:2
;; 10000001 car:10000000 cdr:()
;; 10000002 car:10000000 cdr:10000001
Exercise 5.21
;;; a
(define count-leaves-a
(make-machine
'(tree val continue w)
(list (list 'null? null?) (list 'not not) (list 'pair? pair?)
(list '+ +) (list 'car car) (list 'cdr cdr)
(list 'display display) (list 'newline newline))
'(machine
(assign continue (label count-leaves-end))
count-leaves
(test (op null?) (reg tree))
(assign val (const 0))
(branch (label return))
(assign val (op pair?) (reg tree))
(test (op not) (reg val))
(assign val (const 1))
(branch (label return))
;;
(save continue)
(assign continue (label car-count-end))
(save tree)
(assign tree (op car) (reg tree))
(goto (label count-leaves))
car-count-end
(restore tree)
(save val)
(assign continue (label cdr-count-end))
(assign tree (op cdr) (reg tree))
(goto (label count-leaves))
cdr-count-end
(restore w)
(assign val (op +) (reg val) (reg w))
(restore continue)
return
(goto (reg continue))
count-leaves-end
(perform (op display) (reg val))
(perform (op newline))
)))
(define t0 '())
(define t1 '1)
(define t2 '(1 . 2))
(define t3 '((1 . 2) 3))
(define t4 '((() . 1) (2 . 3) (4 . ())))
;;gosh> (set-register-contents! count-leaves-a 'tree t0)
;;gosh> (start count-leaves-a)
;;0
;;gosh> (set-register-contents! count-leaves-a 'tree t1)
;;gosh> (start count-leaves-a)
;;1
;;gosh> (set-register-contents! count-leaves-a 'tree t2)
;;gosh> (start count-leaves-a)
;;2
;;gosh> (set-register-contents! count-leaves-a 'tree t3)
;;gosh> (start count-leaves-a)
;;3
;;gosh> (set-register-contents! count-leaves-a 'tree t4)
;;gosh> (start count-leaves-a)
;;4
;;; b
(define count-leaves-b
(make-machine
'(tree n val continue)
(list (list 'null? null?) (list 'not not) (list 'pair? pair?)
(list '+ +) (list 'cdr cdr) (list 'car car)
(list 'display display) (list 'newline newline))
'(machine
(assign n (const 0))
(assign continue (label count-leaves-end))
count-iter
(test (op null?) (reg tree))
(assign val (reg n))
(branch (label return))
(assign val (op pair?) (reg tree))
(test (op not) (reg val))
(assign val (op +) (reg n) (const 1))
(branch (label return))
;;
(save continue)
(assign continue (label car-iter))
(save tree)
(assign tree (op car) (reg tree))
(goto (label count-iter))
car-iter
(assign n (reg val))
(assign continue (label cdr-iter))
(restore tree)
(assign tree (op cdr) (reg tree))
(goto (label count-iter))
cdr-iter
(restore continue)
return
(goto (reg continue))
count-leaves-end
(perform (op display) (reg val))
(perform (op newline))
)))
;;gosh> (set-register-contents! count-leaves-b 'tree t1)
;;gosh> (start count-leaves-b)
;;1
;;gosh> (set-register-contents! count-leaves-b 'tree t2)
;;gosh> (start count-leaves-b)
;;2
;;gosh> (set-register-contents! count-leaves-b 'tree t3)
;;gosh> (start count-leaves-b)
;;3
;;gosh> (set-register-contents! count-leaves-b 'tree t4)
;;gosh> (start count-leaves-b)
;;4
Exercise 5.22
;;; (define (append x y)
;;; (if (null? x)
;;; y
;;; (cons (car x) (append (cdr x) y))))
(define append
(make-machine
'(x y val continue)
(list (list 'null? null?) (list 'cons cons) (list 'car car) (list 'cdr cdr)
(list 'display display) (list 'newline newline))
'(machine
(assign continue (label append-end))
append
(test (op null?) (reg x))
(assign val (reg y))
(branch (label return))
;;
(save x)
(assign x (op cdr) (reg x))
(save continue)
(assign continue (label append-cdr-end))
(goto (label append))
append-cdr-end
(restore continue)
(restore x)
(assign x (op car) (reg x))
(assign val (op cons) (reg x) (reg val))
return
(goto (reg continue))
append-end
(perform (op display) (reg val))
(perform (op newline))
)))
(set-register-contents! append 'x '(a b c))
(set-register-contents! append 'y '(x y z))
;;gosh> (start append)
;;(a b c x y z)
;;done
;;; (define (append! x y)
;;; (set-cdr! (last-pair x) y)
;;; x)
;;; (define (last-pair x)
;;; (if (null? (cdr x))
;;; x
;;; (last-pair (cdr x))))
(define append!
(make-machine
'(x y val continue)
(list (list 'null? null?) (list 'cdr cdr) (list 'set-cdr! set-cdr!)
(list 'display display) (list 'newline newline))
'(machine
(save x)
(assign continue (label set-cdr))
(goto (label last-pair))
set-cdr
(perform (op set-cdr!) (reg val) (reg y))
(restore val)
(goto (label append!-end))
;;
last-pair
(assign val (op cdr) (reg x))
(test (op null?) (reg val))
(assign val (reg x))
(branch (label return))
(assign x (op cdr) (reg x))
(goto (label last-pair))
return
(goto (reg continue))
;;
append!-end
(perform (op display) (reg val))
(perform (op newline))
)))
(set-register-contents! append! 'x '(a b c))
(set-register-contents! append! 'y '(x y z))
;;gosh> (start append!)
;;(a b c x y z)
;;done
最終更新：2009年06月21日 10:04
