Implement till 5.2 and add register-machine simulator
parent
4608399b2d
commit
a3d665ea83
|
|
@ -1,3 +1,50 @@
|
|||
(load "util.scm")
|
||||
(load "misc/sicp-regsim.scm")
|
||||
|
||||
(display "\nex-5.1\n")
|
||||
(display "\nex-5.1 draw-factorial\n")
|
||||
|
||||
; See misc directory for drawing.
|
||||
|
||||
(display "[answered]\n")
|
||||
|
||||
(display "\nex-5.2 design-factorial\n")
|
||||
|
||||
(define factorial-machine
|
||||
(make-machine
|
||||
'(counter product n)
|
||||
(list (list '> >) (list '* *) (list '+ +))
|
||||
'(controller
|
||||
(assign product (const 1))
|
||||
(assign counter (const 1))
|
||||
test-counter
|
||||
(test (op >) (reg counter) (reg n))
|
||||
(branch (label factorial-done))
|
||||
(assign product (op *) (reg product) (reg counter))
|
||||
(assign counter (op +) (reg counter) (const 1))
|
||||
(goto (label test-counter))
|
||||
factorial-done)))
|
||||
|
||||
(set-register-contents! factorial-machine 'n 6)
|
||||
(start factorial-machine)
|
||||
(assert (get-register-contents factorial-machine 'product) 720)
|
||||
|
||||
(display "\nex-5.3 - sqrt-newton\n")
|
||||
|
||||
(define (sqrt-newton n)
|
||||
(define (improve guess)
|
||||
(average guess (/ n guess)))
|
||||
(define (average a b)
|
||||
(/ (+ a b) 2))
|
||||
(define (good-enough? guess)
|
||||
(< (abs (- (* guess guess) n)) 0.01))
|
||||
(define (iter guess)
|
||||
(if (good-enough? guess)
|
||||
guess
|
||||
(iter (average guess (/ n guess)))))
|
||||
(iter 1.))
|
||||
|
||||
|
||||
(display (sqrt-newton 2))
|
||||
|
||||
|
||||
;(display "\nex-5.4\n")
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
<!--[if IE]><meta http-equiv="X-UA-Compatible" content="IE=5,IE=9" ><![endif]-->
|
||||
<!DOCTYPE html>
|
||||
<html>
|
||||
<head>
|
||||
<title>sicp</title>
|
||||
<meta charset="utf-8"/>
|
||||
</head>
|
||||
<body><div class="mxgraph" style="max-width:100%;border:1px solid transparent;" data-mxgraph="{"highlight":"#0000ff","nav":true,"resize":true,"toolbar":"zoom layers lightbox","edit":"_blank","xml":"<mxfile host=\"app.diagrams.net\" modified=\"2021-03-19T01:15:36.875Z\" agent=\"5.0 (X11)\" etag=\"5I5GmRiGB6iXz3EgVuhn\" version=\"14.4.9\" type=\"device\"><diagram id=\"C5RBs43oDa-KdzZeNtuy\" name=\"Page-1\">7Vxbd6o4FP41vsxa7ZKEBH2stj1nZjozndWZ6TmPVKMwReKEeKr99RMk4RaqKAL18iRsQgjZ+/uyL8EOHM6WX5g9d36jY+J1QHe87MDbDgAGwF3xE0pWkcTqSsGUuWPZKBE8ue9EClWzhTsmQaYhp9Tj7jwrHFHfJyOekdmM0bdsswn1sk+d21OiCZ5GtqdLn90xdyJpD1iJ/Ctxp456soH70ZUXe/Q6ZXThy+d1ALw3743bu+jyzFZ9yRcNHHtM31IieNeBQ0Ypj45myyHxwrlV0/b88+rZe3jFX375M/jP/nvw61+//3MVdXa/yy3xGzLi8727doCJu5OFz1Z0NfoDvDyZj1dXUPYd8JWaTzIW0ytPfeqLn8F6kkjYT1ecUcYdOqW+7T1QOhdCQwj/JZyvpHHYC06FyOEzT14lS5d/C2+/RvLse+rK7VL2vD5ZqROfs1XqpvD0e/pactv6TN0XvBI+cmT3AWf0lQypR9n67eBd17pBYooGE+rzlBz24RBhIffsF+INYtNINZHGAQfRlIXzlLPALfpRc00XbEQ2KMWQBsptNiV8k/YSMxTwJnRGxESIGxnxbO7+yA7Pljibxu0SYxEH0l52sB01zB+2t5CPmjM6XgiM520qa0BvjsvJ09xeT8KbYKWssWQUOHE9L60DMBz27vdSrBwsYZws99CbPsuqFyj5QfInACg6f0vYyFAc4qSYSBHvwRUDYKOgNlKQTgC+DdQZSCcIP1lQKwvYCuqwVXughuAYFgTrzFaE0sZTeUVY33rDmL1KNZhT1+dBqufHUJBQIDSzFAhBzhXJtY9dquL24iAaQWLG8avsb9lms6x4cXUOathmq6yohplydUZiyjhhZ+XqgN6nc3VMTTGNoPwEkKdi9c/tj6iOUwr2zwpzZm5tjcON9jAHCjCH7Vk4z1MeT0UagZ7nzgOyXTd2MI9SRBN3Gerz6JRloSxBFigLFegK1aYrPUaPFy6pMi9U2VUzeaAToE1cljZbzc2oYab0rmuYM9f2p14JXB4ZDKGR40ygwxAXwLBXGwx7mjriVFkLMLzEKDtB3ioJ+Sgh2hrkrXOGvIE/GeShHjL+pKkjcOx5eMjF9JN3GnY4mBPmiiEQlpY/JsJtilu7ThL6x6jIXDodwrZjTIibIeU9U+P7kPnxk/JhEp1aZtLoZ63P7KJsF9HA5F0bUpxaVQjnOopWE62jXVOv2oDNzalXA1RrD+V7lG0Psu3rSe1Cfekrdq9mC68Qyw+hQedCUc+d+uJ4RPyIdkOqc0e2dyMvzNzxeL2QMhK47/bLur8QXFJlonM06KBbjYKrgqqAc+XeCjmITpxfT8NtA7d9SMbd6670XPfFlVqOjWtsZW+ik0lAeM44DpPpb4iwq3jRRpbkrdMvgJqgpBtdOXIuZiYzx8gmKsfIekfdLR19sEZUrapto2rtBXdsD9Fmas+3B1YDVTvUbxbLKSSX38twdvVoZZn1l+0+gEYu2oOgHu8KWm0UqvXI8YwCeTM35XGE3lYgr9atTLlDr3FcQvmt5eL2Q3lTDxSKyyGuP9IhR5a8vhghXJOCj1TdNAZV2Ugprq8rrlegN1CX3pSHldLbigSNega77HI8gQW+V8u6baEcuffLrduHWlqxvrT6tBEzOhWTKOHzIaui7VSjeL3UtmV3AnPo7GURnJwnhfPxGirH4rV5Ukjfy3PBXjnslf0iBLW660ANM6XgJzFk/XsQ3ZXKqkVqPo0xKSrvchWBOWtKrfpYOLcUFoDTbNTFumyP/ny4R2XzLKhqnqWa7ehuVdntLae8dRPntiEVRFHNhr/IvGD882G8bF2kckxWzXb0NFjZnaTnhHHDah3k+tbP2xDYFx9MU56Wjui17ITholzzJUIqw6JlN2niD0yiIRatslPlnHg0rry1xqP4GAKijKt0Bl/R47JfrdWUwMa56iQyc+Z3oMKz9pwtX1TjbrX2KjaptbCN9fxf+erbOZGfieojP3Ga/GVRpNnkf6Hg3f8=</diagram></mxfile>"}"></div>
|
||||
<script type="text/javascript" src="https://viewer.diagrams.net/js/viewer-static.min.js"></script>
|
||||
</body>
|
||||
</html>
|
||||
|
|
@ -0,0 +1,407 @@
|
|||
;;;;REGISTER-MACHINE SIMULATOR FROM SECTION 5.2 OF
|
||||
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
|
||||
|
||||
;;;;Matches code in ch5.scm
|
||||
|
||||
;;;;This file can be loaded into Scheme as a whole.
|
||||
;;;;Then you can define and simulate machines as shown in section 5.2
|
||||
|
||||
;;;**NB** there are two versions of make-stack below.
|
||||
;;; Choose the monitored or unmonitored one by reordering them to put the
|
||||
;;; one you want last, or by commenting one of them out.
|
||||
;;; Also, comment in/out the print-stack-statistics op in make-new-machine
|
||||
;;; To find this stack code below, look for comments with **
|
||||
|
||||
|
||||
(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*))
|
||||
(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))
|
||||
|
||||
;;**original (unmonitored) version from section 5.2.1
|
||||
(define (make-stack)
|
||||
(let ((s '()))
|
||||
(define (push x)
|
||||
(set! s (cons x s)))
|
||||
(define (pop)
|
||||
(if (null? s)
|
||||
(error "Empty stack -- POP")
|
||||
(let ((top (car s)))
|
||||
(set! s (cdr s))
|
||||
top)))
|
||||
(define (initialize)
|
||||
(set! s '())
|
||||
'done)
|
||||
(define (dispatch message)
|
||||
(cond ((eq? message 'push) push)
|
||||
((eq? message 'pop) (pop))
|
||||
((eq? message 'initialize) (initialize))
|
||||
(else (error "Unknown request -- STACK"
|
||||
message))))
|
||||
dispatch))
|
||||
|
||||
(define (pop stack)
|
||||
(stack 'pop))
|
||||
|
||||
(define (push stack value)
|
||||
((stack 'push) value))
|
||||
|
||||
;;**monitored version from section 5.2.4
|
||||
(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 (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)))
|
||||
;;**next for monitored stack (as in section 5.2.4)
|
||||
;; -- comment out if not wanted
|
||||
(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)))
|
||||
|
||||
|
||||
(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 (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))))
|
||||
|
||||
|
||||
(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))))
|
||||
|
||||
|
||||
(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 () ; execution procedure for assign
|
||||
(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)
|
||||
(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))))
|
||||
|
||||
;; from 4.1
|
||||
(define (tagged-list? exp tag)
|
||||
(if (pair? exp)
|
||||
(eq? (car exp) tag)
|
||||
false))
|
||||
|
||||
'(REGISTER SIMULATOR LOADED)
|
||||
Loading…
Reference in New Issue