felixm
/
SICP
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Implement 5.19

main
Felix Martin 2021-03-31 21:16:22 -04:00
parent bb870cbdf1
commit ea9b0dd752
2 changed files with 56 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
ex-5_14-19.scm
View File

@ -74,4 +74,27 @@
(display "\nex-5.19 - breakpoint\n")
(define (set-breakpoint machine label n)
((machine 'set-breakpoint) label n))
(define (cancel-breakpoint machine label n)
((machine 'cancel-breakpoint) label n))
(define (proceed machine)
(machine 'proceed))
(set-register-contents! factorial-machine 'n 6)
(set-register-contents! factorial-machine 'val 0)
(set-breakpoint factorial-machine 'fact-loop 1)
(start factorial-machine)
(assert (get-register-contents factorial-machine 'n) 6)
(proceed factorial-machine)
(assert (get-register-contents factorial-machine 'n) 5)
(proceed factorial-machine)
(cancel-breakpoint factorial-machine 'fact-loop 1)
(assert (get-register-contents factorial-machine 'n) 4)
(proceed factorial-machine)
(assert (get-register-contents factorial-machine 'val) 720)

41
misc/sicp-regsim.scm
View File

@ -121,6 +121,9 @@
(stack (make-stack))
(instruction-count 0)
(instruction-trace #f)
(breakpoints '())
(location (list 'none 0))
(proceed #f)
(the-instruction-sequence '()))
(let ((the-ops
(list (list 'initialize-stack
@ -143,19 +146,32 @@
(if val
(cadr val)
(error "Unknown register:" name))))
(define (update-location inst-text)
(if (eq? (car inst-text) 'label)
(set! location (list (cadr inst-text) 0))
(set-cdr! location (list (+ (cadr location) 1)))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
((instruction-execution-proc (car insts)))
(if instruction-trace
(update-location (instruction-text (car insts)))
(if (and (member location breakpoints)
(not proceed))
(begin
(display "stopped @ ")
(display (instruction-text (car insts)))
(newline)))
(if (not (eq? 'label (car (instruction-text (car insts)))))
(set! instruction-count (+ instruction-count 1)))
(execute)))))
(newline))
(begin
(set! proceed #f)
((instruction-execution-proc (car insts)))
(if instruction-trace
(begin
(display (instruction-text (car insts)))
(newline)))
(if (not (eq? 'label (car (instruction-text (car insts)))))
(set! instruction-count (+ instruction-count 1)))
(execute)))))))
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
@ -175,6 +191,13 @@
((eq? message 'get-register) lookup-register)
((eq? message 'install-operations)
(lambda (ops) (set! the-ops (append the-ops ops))))
((eq? message 'set-breakpoint)
(lambda (label count) (set! breakpoints (cons (list label count) breakpoints))))
((eq? message 'cancel-breakpoint)
(lambda (label count) (set! breakpoints (delete (list label count) breakpoints))))
((eq? message 'proceed)
(set! proceed #t) (execute))
((eq? message 'cancel-all-breakpoints) (set! breakpoints '()))
((eq? message 'stack) stack)
((eq? message 'operations) the-ops)
(else (error "Unknown request -- MACHINE" message))))
@ -207,10 +230,12 @@
(lambda (insts labels)
(let ((next-inst (car text)))
(if (symbol? next-inst)
(receive (cons (make-instruction (list 'label next-inst)) insts)
(begin
(set! insts (cons (make-instruction (list 'label next-inst)) insts))
(receive insts
(cons (make-label-entry next-inst
insts)
labels))
labels)))
(receive (cons (make-instruction next-inst)
insts)
labels)))))))