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

Implement till 5.18

Browse Source
This commit is contained in:
Felix Martin
2021-03-30 19:49:09 -04:00
parent e22a52b7f3
commit bb870cbdf1
3 changed files with 69 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

38
misc/sicp-regsim.scm
View File

@@ -24,12 +24,21 @@
machine))
(define (make-register name)
(let ((contents '*unassigned*))
(let ((contents '*unassigned*)
(trace #f))
(define (set value)
(if trace
(begin
(display "set! ") (display name)
(display " from ") (display contents)
(display " to ") (display value) (newline)))
(set! contents value))
(define (dispatch message)
(cond ((eq? message 'get) contents)
((eq? message 'set)
(lambda (value) (set! contents value)))
((eq? message 'set) set)
((eq? message 'name?) name)
((eq? message 'trace-on) (set! trace #t))
((eq? message 'trace-off) (set! trace #f))
(else
(error "Unknown request -- REGISTER" message))))
dispatch))
@@ -110,6 +119,8 @@
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(instruction-count 0)
(instruction-trace #f)
(the-instruction-sequence '()))
(let ((the-ops
(list (list 'initialize-stack
@@ -138,6 +149,12 @@
'done
(begin
((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)
@@ -145,6 +162,15 @@
(execute))
((eq? message 'install-instruction-sequence)
(lambda (seq) (set! the-instruction-sequence seq)))
((eq? message 'instruction-count) instruction-count)
((eq? message 'reset-instruction-acount)
(set! instruction-count 0) 'ok)
((eq? message 'trace-on) (set! instruction-trace #t) 'ok)
((eq? message 'trace-off) (set! instruction-trace #f) 'ok)
((eq? message 'trace-on-reg)
(lambda (reg-name) ((lookup-register reg-name) 'trace-on)))
((eq? message 'trace-off-reg)
(lambda (reg-name) ((lookup-register reg-name) 'trace-off)))
((eq? message 'allocate-register) allocate-register)
((eq? message 'get-register) lookup-register)
((eq? message 'install-operations)
@@ -181,7 +207,7 @@
(lambda (insts labels)
(let ((next-inst (car text)))
(if (symbol? next-inst)
(receive insts
(receive (cons (make-instruction (list 'label next-inst)) insts)
(cons (make-label-entry next-inst
insts)
labels))
@@ -239,6 +265,8 @@
(make-save inst machine stack pc))
((eq? (car inst) 'restore)
(make-restore inst machine stack pc))
((eq? (car inst) 'label)
(make-label pc))
((eq? (car inst) 'perform)
(make-perform inst machine labels ops pc))
((eq? (car inst) 'inc)
@@ -246,6 +274,8 @@
(else (error "Unknown instruction type -- ASSEMBLE"
inst))))
(define (make-label pc)
(lambda () (advance-pc pc)))
(define (make-assign inst machine labels operations pc)
(let ((target