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

Clean up

Browse Source
This commit is contained in:
Felix Martin
2021-04-25 08:57:17 -04:00
parent 1fdb733d0c
commit 335d011db8
62 changed files with 88 additions and 81 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
shared/draw-corner-split-3.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 52 KiB

11
shared/ex-5_01.html Normal file
View File

@@ -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="{&quot;highlight&quot;:&quot;#0000ff&quot;,&quot;nav&quot;:true,&quot;resize&quot;:true,&quot;toolbar&quot;:&quot;zoom layers lightbox&quot;,&quot;edit&quot;:&quot;_blank&quot;,&quot;xml&quot;:&quot;&lt;mxfile host=\&quot;app.diagrams.net\&quot; modified=\&quot;2021-03-19T01:15:36.875Z\&quot; agent=\&quot;5.0 (X11)\&quot; etag=\&quot;5I5GmRiGB6iXz3EgVuhn\&quot; version=\&quot;14.4.9\&quot; type=\&quot;device\&quot;&gt;&lt;diagram id=\&quot;C5RBs43oDa-KdzZeNtuy\&quot; name=\&quot;Page-1\&quot;&gt;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=&lt;/diagram&gt;&lt;/mxfile&gt;&quot;}"></div>
<script type="text/javascript" src="https://viewer.diagrams.net/js/viewer-static.min.js"></script>
</body>
</html>

72
shared/lib-agenda.scm Normal file
View File

@@ -0,0 +1,72 @@
(define (make-time-segment time queue)
(cons time queue))
(define (segment-time s) (car s))
(define (segment-queue s) (cdr s))
(define (make-agenda) (list 0))
(define (current-time agenda) (car agenda))
(define (set-current-time! agenda time)
(set-car! agenda time))
(define (segments agenda) (cdr agenda))
(define (set-segments! agenda segments)
(set-cdr! agenda segments))
(define (first-segment agenda) (car (segments agenda)))
(define (rest-segments agenda) (cdr (segments agenda)))
(define (empty-agenda? agenda)
(null? (segments agenda)))
(define (add-to-agenda! time action agenda)
(define (belongs-before? segments)
(or (null? segments)
(< time (segment-time (car segments)))))
(define (make-new-time-segment time action)
(let ((q (make-queue)))
(insert-queue! q action)
(make-time-segment time q)))
(define (add-to-segments! segments)
(if (= (segment-time (car segments)) time)
(insert-queue! (segment-queue (car segments))
action)
(let ((rest (cdr segments)))
(if (belongs-before? rest)
(set-cdr!
segments
(cons (make-new-time-segment time action)
(cdr segments)))
(add-to-segments! rest)))))
(let ((segments (segments agenda)))
(if (belongs-before? segments)
(set-segments!
agenda
(cons (make-new-time-segment time action)
segments))
(add-to-segments! segments))))
(define (remove-first-agenda-item! agenda)
(let ((q (segment-queue (first-segment agenda))))
(delete-queue! q)
(if (empty-queue? q)
(set-segments! agenda (rest-segments agenda)))))
(define (first-agenda-item agenda)
(if (empty-agenda? agenda)
(error "Agenda is empty -- FIRST-AGENDA-ITEM")
(let ((first-seg (first-segment agenda)))
(set-current-time! agenda (segment-time first-seg))
(front-queue (segment-queue first-seg)))))
(define (after-delay delay action)
(add-to-agenda! (+ delay (current-time the-agenda))
action
the-agenda))
(define (propagate)
(if (empty-agenda? the-agenda)
'done
(let ((first-item (first-agenda-item the-agenda)))
(first-item)
(remove-first-agenda-item! the-agenda)
(propagate))))
'agenda-loaded

186
shared/lib-amb.scm Normal file
View File

@@ -0,0 +1,186 @@
;;; from http://www.shido.info/lisp/scheme_amb_e.html
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Nondeterminsm using macro amb
;;; T.Shido
;;; November 15, 2005
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; felixm: This amb implementation does not manage the state of defines. That
; means procedures that use define and set! will not work. To make all amb
; procedures work I had to use the amb evaluator from the book.
;;; abbreviation for call-with-current-continuation
(define call/cc call-with-current-continuation)
;;; This function is re-assigned in `choose' and `fail' itself.
(define fail #f)
;;; nondeterminsm macro operator
(define-syntax amb
(syntax-rules ()
((_) (fail))
((_ a) a)
((_ a b ...)
(let ((fail0 fail))
(call/cc
(lambda (cc)
(set! fail
(lambda ()
(set! fail fail0)
(cc (amb b ...))))
(cc a)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; for MIT-Scheme only
; use it if you don't like warning during compilation
; (define-syntax amb
; (sc-macro-transformer
; (lambda (exp env)
; (if (null? (cdr exp))
; `(fail)
; `(let ((fail0 fail))
; (call/cc
; (lambda (cc)
; (set! fail
; (lambda ()
; (set! fail fail0)
; (cc (amb ,@(map (lambda (x)
; (make-syntactic-closure env '() x))
; (cddr exp))))))
; (cc ,(make-syntactic-closure env '() (second exp))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; function for nondeterminsm
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (define (choose . ls)
; (if (null? ls)
; (fail)
; (let ((fail0 fail))
; (call/cc
; (lambda (cc)
; (begin
; (set! fail
; (lambda ()
; (set! fail fail0)
; (cc (apply choose (cdr ls)))))
; (cc (car ls))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; returning all possibilities
(define-syntax set-of
(syntax-rules ()
((_ s)
(let ((acc '()))
(amb (let ((v s))
(set! acc (cons v acc))
(fail))
(reverse! acc))))))
;;; if not pred backtrack
(define (assert pred)
(or pred (amb)))
;;; returns arbitrary number larger or equal to n
(define (an-integer-starting-from n)
(amb n (an-integer-starting-from (1+ n))))
;;; returns arbitrary number between a and b
(define (number-between a b)
(let loop ((i a))
(if (> i b)
(amb)
(amb i (loop (1+ i))))))
;;;;;;;;;;;; other
(define (gen-prime n)
(let ((i (number-between 2 n)))
(assert (prime? i))
i))
(define (prime? n)
(let ((m (sqrt n)))
(let loop ((i 2))
(or (< m i)
(and (not (zero? (modulo n i)))
(loop (+ i (if (= i 2) 1 2))))))))
(define (sum-prime n)
(let* ((i (number-between 1 n))
(j (number-between i n)))
(assert (prime? (+ i j)))
(list i j)))
(define (sq x) (* x x))
(define (pythag i j k)
(assert (= (sq k) (+ (sq i) (sq j))))
(list i j k))
;;; small functions for SICP Exercise 4.42
(define (xor a b)
(if a (not b) b))
(define (all-different? . ls)
(let loop ((obj (car ls)) (ls (cdr ls)))
(or (null? ls)
(and (not (memv obj ls))
(loop (car ls) (cdr ls))))))
;;; SICP Exercise 4.42
(define (girls-exam)
(let ((kitty (number-between 1 5))
(betty (number-between 1 5)))
(assert (xor (= kitty 2) (= betty 3)))
(let ((mary (number-between 1 5)))
(assert (xor (= kitty 2) (= mary 4)))
(assert (xor (= mary 4) (= betty 1)))
(let ((ethel (number-between 1 5))
(joan (number-between 1 5)))
(assert (xor (= ethel 1) (= joan 2)))
(assert (xor (= joan 3) (= ethel 5)))
(assert (all-different? kitty betty ethel joan mary))
(map list '(kitty betty ethel joan mary) (list kitty betty ethel joan mary))))))
;;; Bad answer for ex 4.42
(define (girls-exam-x)
(let ((kitty (number-between 1 5))
(betty (number-between 1 5))
(mary (number-between 1 5))
(ethel (number-between 1 5))
(joan (number-between 1 5)))
(assert (xor (= kitty 2) (= betty 3)))
(assert (xor (= kitty 2) (= mary 4)))
(assert (xor (= mary 4) (= betty 1)))
(assert (xor (= ethel 1) (= joan 2)))
(assert (xor (= joan 3) (= ethel 5)))
(assert (all-different? kitty betty ethel joan mary))
(map list '(kitty betty ethel joan mary) (list kitty betty ethel joan mary))))
;;; to show cpu time
(define-syntax cpu-time/sec
(syntax-rules ()
((_ s)
(with-timings
(lambda () s)
(lambda (run-time gc-time real-time)
(write (internal-time/ticks->seconds run-time))
(write-char #\space)
(write (internal-time/ticks->seconds gc-time))
(write-char #\space)
(write (internal-time/ticks->seconds real-time))
(newline))))))
;;; initializing fail
(call/cc
(lambda (cc)
(set! fail
(lambda ()
(cc 'no-choise)))))

26
shared/lib-draw.scm Normal file
View File

@@ -0,0 +1,26 @@
(define (draw-to-py painter name)
(define py-name (string-append "shared/" name ".py"))
(define img-name (string-append name ".png"))
(define head (string-append
"from PIL import Image, ImageDraw\n"
"im = Image.new('RGB', (1921, 1081))\n"
"draw = ImageDraw.Draw(im)\n"))
(define tail (string-append
"im.save('" img-name "', 'PNG')\n"))
(let ((port (open-output-file py-name)))
(define (draw-line v1 v2)
(define n2s number->string)
(display
(string-append
"draw.line(("
(n2s (xcor-vect v1)) ", "
(n2s (ycor-vect v1)) ", "
(n2s (xcor-vect v2)) ", "
(n2s (ycor-vect v2)) "), "
"fill=128)\n") port))
(display head port)
(painter draw-line)
(display tail port)
(close-output-port port)))

33
shared/lib-queue.scm Normal file
View File

@@ -0,0 +1,33 @@
; Queue implementation from 3.21
(define (front-ptr queue) (car queue))
(define (rear-ptr queue) (cdr queue))
(define (set-front-ptr! queue item) (set-car! queue item))
(define (set-rear-ptr! queue item) (set-cdr! queue item))
(define (empty-queue? queue) (null? (front-ptr queue)))
(define (make-queue) (cons '() '()))
(define (front-queue queue)
(if (empty-queue? queue)
(error "FRONT called with an empty queue" queue)
(car (front-ptr queue))))
(define (insert-queue! queue item)
(let ((new-pair (cons item '())))
(cond ((empty-queue? queue)
(set-front-ptr! queue new-pair)
(set-rear-ptr! queue new-pair)
queue)
(else
(set-cdr! (rear-ptr queue) new-pair)
(set-rear-ptr! queue new-pair)
queue))))
(define (delete-queue! queue)
(cond ((empty-queue? queue)
(error "DELETE! called with an empty queue" queue))
(else
(set-front-ptr! queue (cdr (front-ptr queue)))
queue)))
'queue-loaded

710
shared/sicp-ambeval.scm Normal file
View File

@@ -0,0 +1,710 @@
; COPIED FROM: https://mitpress.mit.edu/sites/default/files/sicp/code/index.html
;;;;METACIRCULAR EVALUATOR FROM CHAPTER 4 (SECTIONS 4.1.1-4.1.4) of
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
;;;;Matches code in ch4.scm
;;;;This file can be loaded into Scheme as a whole.
;;;;Then you can initialize and start the evaluator by evaluating
;;;; the two commented-out lines at the end of the file (setting up the
;;;; global environment and starting the driver loop).
;;;;**WARNING: Don't load this file twice (or you'll lose the primitives
;;;; interface, due to renamings of apply).
;;;from section 4.1.4 -- must precede def of metacircular apply
(define apply-in-underlying-scheme apply)
;;;SECTION 4.1.1
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- EVAL" exp))))
(define (apply procedure arguments)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
((compound-procedure? procedure)
(eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure))))
(else
(error
"Unknown procedure type -- APPLY" procedure))))
(define (list-of-values exps env)
(if (no-operands? exps)
'()
(cons (eval (first-operand exps) env)
(list-of-values (rest-operands exps) env))))
(define (eval-if exp env)
(if (true? (eval (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
(define (eval-sequence exps env)
(cond ((last-exp? exps) (eval (first-exp exps) env))
(else (eval (first-exp exps) env)
(eval-sequence (rest-exps exps) env))))
(define (eval-assignment exp env)
(set-variable-value! (assignment-variable exp)
(eval (assignment-value exp) env)
env)
'ok)
(define (eval-definition exp env)
(define-variable! (definition-variable exp)
(eval (definition-value exp) env)
env)
'ok)
;;;SECTION 4.1.2
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
((eq? exp #t) true)
((eq? exp #f) true)
(else false)))
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
(define (variable? exp) (symbol? exp))
(define (assignment? exp)
(tagged-list? exp 'set!))
(define (permanent-assignment? exp)
(tagged-list? exp 'permanent-set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (definition? exp)
(tagged-list? exp 'define))
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp)
(cddr exp))))
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)
'false))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false ; no else clause
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "ELSE clause isn't last -- COND->IF"
clauses))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))))))
;;;SECTION 4.1.3
(define (true? x)
(not (eq? x false)))
(define (false? x)
(eq? x false))
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p)
(tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())
(define (make-frame variables values)
(cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))
(define (extend-environment vars vals base-env)
(if (= (length vars) (length vals))
(cons (make-frame vars vals) base-env)
(if (< (length vars) (length vals))
(error "Too many arguments supplied" vars vals)
(error "Too few arguments supplied" vars vals))))
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(car vals))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable -- SET!" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (define-variable! var val env)
(let ((frame (first-frame env)))
(define (scan vars vals)
(cond ((null? vars)
(add-binding-to-frame! var val frame))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(scan (frame-variables frame)
(frame-values frame))))
;;;SECTION 4.1.4
(define (setup-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(define-variable! 'true true initial-env)
(define-variable! 'false false initial-env)
initial-env))
;[do later] (define the-global-environment (setup-environment))
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define primitive-procedures
(list (list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'null? null?)
;; more primitives
))
(define (primitive-procedure-names)
(map car
primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda (proc) (list 'primitive (cadr proc)))
primitive-procedures))
;[moved to start of file] (define apply-in-underlying-scheme apply)
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme
(primitive-implementation proc) args))
(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((input (read)))
(let ((output (eval input the-global-environment)))
(announce-output output-prompt)
(user-print output)))
(driver-loop))
(define (prompt-for-input string)
(newline) (newline) (display string) (newline))
(define (announce-output string)
(newline) (display string) (newline))
(define (user-print object)
(if (compound-procedure? object)
(display (list 'compound-procedure
(procedure-parameters object)
(procedure-body object)
'<procedure-env>))
(display object)))
;;;Following are commented out so as not to be evaluated when
;;; the file is loaded.
;;(define the-global-environment (setup-environment))
;;(driver-loop)
'METACIRCULAR-EVALUATOR-LOADED
;;;Code from SECTION 4.3.3, modified as needed to run it
(define (amb? exp) (tagged-list? exp 'amb))
(define (amb-choices exp) (cdr exp))
(define (ramb? exp) (tagged-list? exp 'ramb))
(define (ramb-choices exp) (cdr exp))
;; lamb takes a list and treats each element as a separate amb-value
(define (lamb? exp) (tagged-list? exp 'lamb))
(define (lamb-arg exp) (cadr exp))
(define (analyze-lamb exp)
(let ((p (analyze (lamb-arg exp))))
(lambda (env succeed fail)
(define (try-options options fail2)
(if (null? options)
(fail)
(succeed (car options) (lambda () (try-options (cdr options) fail2)))))
(p env try-options fail))))
;; analyze from 4.1.6, with clause from 4.3.3 added and also support for let
(define (analyze exp)
(cond ((self-evaluating? exp)
(analyze-self-evaluating exp))
((quoted? exp) (analyze-quoted exp))
((variable? exp) (analyze-variable exp))
((assignment? exp) (analyze-assignment exp))
((permanent-assignment? exp) (analyze-permanent-assignment exp))
((definition? exp) (analyze-definition exp))
((if? exp) (analyze-if exp))
((if-fail? exp) (analyze-if-fail exp))
((lambda? exp) (analyze-lambda exp))
((begin? exp) (analyze-sequence (begin-actions exp)))
((cond? exp) (analyze (cond->if exp)))
((let? exp) (analyze (let->combination exp))) ;**
((amb? exp) (analyze-amb exp)) ;**
((ramb? exp) (analyze-ramb exp)) ;**
((lamb? exp) (analyze-lamb exp)) ;**
((or? exp) (analyze-or (clauses exp)))
((and? exp) (analyze-and (clauses exp)))
((application? exp) (analyze-application exp))
(else
(error "Unknown expression type -- ANALYZE" exp))))
(define (ambeval exp env succeed fail)
((analyze exp) env succeed fail))
(define (analyze-self-evaluating exp)
(lambda (env succeed fail)
(succeed exp fail)))
(define (analyze-quoted exp)
(let ((qval (text-of-quotation exp)))
(lambda (env succeed fail)
(succeed qval fail))))
(define (analyze-variable exp)
(lambda (env succeed fail)
(succeed (lookup-variable-value exp env)
fail)))
(define (analyze-lambda exp)
(let ((vars (lambda-parameters exp))
(bproc (analyze-sequence (lambda-body exp))))
(lambda (env succeed fail)
(succeed (make-procedure vars bproc env)
fail))))
(define (or? exp) (tagged-list? exp 'or))
(define (and? exp) (tagged-list? exp 'and))
(define (clauses exp) (cdr exp))
(define (no-clauses? exp) (null? exp))
(define (first-clause exp) (car exp))
(define (rest-clauses exp) (cdr exp))
(define (analyze-or exp)
(if (no-clauses? exp)
(lambda (env succeed fail) (succeed #f fail))
(let ((cproc (analyze (first-clause exp))))
(lambda (env succeed fail)
(cproc
env
;; success continuation for clause value
(lambda (clause-value fail2)
(if (true? clause-value)
(succeed #t fail2)
((analyze-or (rest-clauses exp)) env succeed fail2)))
fail)))))
(define (analyze-and exp)
(if (no-clauses? exp)
(lambda (env succeed fail) (succeed #t fail))
(let ((cproc (analyze (first-clause exp))))
(lambda (env succeed fail)
(cproc
env
;; success continuation for clause value
(lambda (clause-value fail2)
(if (true? clause-value)
((analyze-and (rest-clauses exp)) env succeed fail2)
(succeed #f fail2)))
fail)))))
;;;Conditionals and sequences
(define (analyze-if exp)
(let ((pproc (analyze (if-predicate exp)))
(cproc (analyze (if-consequent exp)))
(aproc (analyze (if-alternative exp))))
(lambda (env succeed fail)
(pproc env
;; success continuation for evaluating the predicate
;; to obtain pred-value
(lambda (pred-value fail2)
(if (true? pred-value)
(cproc env succeed fail2)
(aproc env succeed fail2)))
;; failure continuation for evaluating the predicate
fail))))
(define (if-fail? exp) (tagged-list? exp 'if-fail))
(define (if-fail-first exp) (cadr exp))
(define (if-fail-second exp) (caddr exp))
(define (analyze-sequence exps)
(define (sequentially a b)
(lambda (env succeed fail)
(a env
;; success continuation for calling a
(lambda (a-value fail2)
(b env succeed fail2))
;; failure continuation for calling a
fail)))
(define (loop first-proc rest-procs)
(if (null? rest-procs)
first-proc
(loop (sequentially first-proc (car rest-procs))
(cdr rest-procs))))
(let ((procs (map analyze exps)))
(if (null? procs)
(error "Empty sequence -- ANALYZE"))
(loop (car procs) (cdr procs))))
;;;Definitions and assignments
(define (analyze-definition exp)
(let ((var (definition-variable exp))
(vproc (analyze (definition-value exp))))
(lambda (env succeed fail)
(vproc env
(lambda (val fail2)
(define-variable! var val env)
(succeed 'ok fail2))
fail))))
(define (analyze-assignment exp)
(let ((var (assignment-variable exp))
(vproc (analyze (assignment-value exp))))
(lambda (env succeed fail)
(vproc env
(lambda (val fail2) ; *1*
(let ((old-value
(lookup-variable-value var env)))
(set-variable-value! var val env)
(succeed 'ok
(lambda () ; *2*
(set-variable-value! var
old-value
env)
(fail2)))))
fail))))
(define (analyze-permanent-assignment exp)
(let ((var (assignment-variable exp))
(vproc (analyze (assignment-value exp))))
(lambda (env succeed fail)
(vproc env
(lambda (val fail2)
(set-variable-value! var val env)
(succeed 'ok
(lambda () (fail2))))
fail))))
;;;Procedure applications
(define (analyze-application exp)
(let ((fproc (analyze (operator exp)))
(aprocs (map analyze (operands exp))))
(lambda (env succeed fail)
(fproc env
(lambda (proc fail2)
(get-args aprocs
env
(lambda (args fail3)
(execute-application
proc args succeed fail3))
fail2))
fail))))
(define (get-args aprocs env succeed fail)
(if (null? aprocs)
(succeed '() fail)
((car aprocs) env
;; success continuation for this aproc
(lambda (arg fail2)
(get-args (cdr aprocs)
env
;; success continuation for recursive
;; call to get-args
(lambda (args fail3)
(succeed (cons arg args)
fail3))
fail2))
fail)))
(define (execute-application proc args succeed fail)
(cond ((primitive-procedure? proc)
(succeed (apply-primitive-procedure proc args)
fail))
((compound-procedure? proc)
((procedure-body proc)
(extend-environment (procedure-parameters proc)
args
(procedure-environment proc))
succeed
fail))
(else
(error
"Unknown procedure type -- EXECUTE-APPLICATION"
proc))))
;;;amb expressions
(define (analyze-amb exp)
(let ((cprocs (map analyze (amb-choices exp))))
(lambda (env succeed fail)
(define (try-next choices)
(if (null? choices)
(fail)
((car choices) env
succeed
(lambda ()
(try-next (cdr choices))))))
(try-next cprocs))))
;;;Driver loop
(define input-prompt ";;; Amb-Eval input:")
(define output-prompt ";;; Amb-Eval value:")
(define (driver-loop)
(define (internal-loop try-again)
(prompt-for-input input-prompt)
(let ((input (read)))
(if (eq? input 'try-again)
(try-again)
(begin
(newline)
(display ";;; Starting a new problem ")
(ambeval input
the-global-environment
;; ambeval success
(lambda (val next-alternative)
(announce-output output-prompt)
(user-print val)
(internal-loop next-alternative))
;; ambeval failure
(lambda ()
(announce-output
";;; There are no more values of")
(user-print input)
(driver-loop)))))))
(internal-loop
(lambda ()
(newline)
(display ";;; There is no current problem")
(driver-loop))))
;;; Support for Let (as noted in footnote 56, p.428)
(define (let? exp) (tagged-list? exp 'let))
(define (let-bindings exp) (cadr exp))
(define (let-body exp) (cddr exp))
(define (let-var binding) (car binding))
(define (let-val binding) (cadr binding))
(define (make-combination operator operands) (cons operator operands))
(define (let->combination exp)
;;make-combination defined in earlier exercise
(let ((bindings (let-bindings exp)))
(make-combination (make-lambda (map let-var bindings)
(let-body exp))
(map let-val bindings))))
;; A longer list of primitives -- suitable for running everything in 4.3
;; Overrides the list in ch4-mceval.scm
;; Has Not to support Require; various stuff for code in text (including
;; support for Prime?); integer? and sqrt for exercise code;
;; eq? for ex. solution
(define primitive-procedures
(list (list '* *)
(list '+ +)
(list '- -)
(list '< <)
(list '<= <=)
(list '= =)
(list '> >)
(list '>= >=)
(list 'abs abs)
(list 'append append)
(list 'assoc assoc)
(list 'caddr caddr)
(list 'cadr cadr)
(list 'car car)
(list 'cddr cddr)
(list 'cdr cdr)
(list 'cons cons)
(list 'display display)
(list 'eq? eq?)
(list 'equal? equal?)
(list 'integer? integer?)
(list 'list list)
(list 'member member)
(list 'memq memq)
(list 'newline newline)
(list 'not not)
(list 'null? null?)
(list 'number? number?)
(list 'pair? pair?)
(list 'remainder remainder)
(list 'set-car! set-car!)
(list 'set-cdr! set-cdr!)
(list 'sqrt sqrt)
(list 'string->symbol string->symbol)
(list 'string-append string-append)
(list 'string-length string-length)
(list 'string=? string=?)
(list 'substring substring)
(list 'symbol->string symbol->string)
(list 'symbol? symbol?)
))
'AMB-EVALUATOR-LOADED

402
shared/sicp-compiler-lexical-addressing.scm Normal file
View File

@@ -0,0 +1,402 @@
;;;;COMPILER FROM SECTION 5.5 OF
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
;;;;Matches code in ch5.scm
;;;;This file can be loaded into Scheme as a whole.
;;;;**NOTE**This file loads the metacircular evaluator's syntax procedures
;;;; from section 4.1.2
;;;; You may need to change the (load ...) expression to work in your
;;;; version of Scheme.
;;;;Then you can compile Scheme programs as shown in section 5.5.5
;;**implementation-dependent loading of syntax procedures
(load "shared/sicp-syntax.scm") ;section 4.1.2 syntax procedures
(load "shared/sicp-eceval-support.scm") ;; for let support
;;;SECTION 5.5.1
(define (compile exp ct-env target linkage)
(cond ((self-evaluating? exp)
(compile-self-evaluating exp target linkage))
((quoted? exp) (compile-quoted exp target linkage))
((variable? exp)
(compile-variable exp ct-env target linkage))
((assignment? exp)
(compile-assignment exp ct-env target linkage))
((definition? exp)
(compile-definition exp ct-env target linkage))
((if? exp) (compile-if exp ct-env target linkage))
((let? exp) (compile (let->combination exp) ct-env target linkage))
((lambda? exp) (compile-lambda exp ct-env target linkage))
((begin? exp)
(compile-sequence (begin-actions exp)
ct-env
target
linkage))
((cond? exp) (compile (cond->if exp) ct-env target linkage))
((primitive-procedure? exp)
(compile-primitive exp target linkage))
((application? exp)
(compile-application exp ct-env target linkage))
(else
(error "Unknown expression type -- COMPILE" exp))))
(define (make-instruction-sequence needs modifies statements)
(list needs modifies statements))
(define (empty-instruction-sequence)
(make-instruction-sequence '() '() '()))
;; Implemented in 5.38
(define (primitive-procedure? exp) #f)
;; Implemented in 5.43
(define (lambda->lambda-without-defines exp) exp)
;;;SECTION 5.5.2
;;;linkage code
(define (compile-linkage linkage)
(cond ((eq? linkage 'return)
(make-instruction-sequence '(continue) '()
'((goto (reg continue)))))
((eq? linkage 'next)
(empty-instruction-sequence))
(else
(make-instruction-sequence '() '()
`((goto (label ,linkage)))))))
(define (end-with-linkage linkage instruction-sequence)
(preserving '(continue)
instruction-sequence
(compile-linkage linkage)))
;;;simple expressions
(define (compile-self-evaluating exp target linkage)
(end-with-linkage linkage
(make-instruction-sequence '() (list target)
`((assign ,target (const ,exp))))))
(define (compile-quoted exp target linkage)
(end-with-linkage linkage
(make-instruction-sequence '() (list target)
`((assign ,target (const ,(text-of-quotation exp)))))))
(define (compile-variable exp ct-env target linkage)
(let ((adr (find-variable exp ct-env)))
(if (eq? adr 'not-found)
(end-with-linkage linkage
(make-instruction-sequence '(env) (list target 'env)
`((assign env (op get-global-environment) (reg env))
(assign ,target
(op lookup-variable-value)
(const ,exp)
(reg env)))))
(end-with-linkage linkage
(make-instruction-sequence '(env) (list target)
`((assign ,target
(op lexical-address-lookup)
(const ,adr)
(reg env))))))))
(define (compile-assignment exp ct-env target linkage)
(let* ((var (assignment-variable exp))
(get-value-code (compile (assignment-value exp) ct-env 'val 'next))
(adr (find-variable var ct-env)))
(if (eq? adr 'not-found)
(error "var not found -- compile-assignment" var)
(end-with-linkage linkage
(preserving '(env)
get-value-code
(make-instruction-sequence '(env val) (list target)
`((perform (op lexical-address-set!)
(const ,adr) ;; (const ,var) before
(reg val)
(reg env))
(assign ,target (const ok)))))))))
(define (compile-definition exp ct-env target linkage)
(let ((var (definition-variable exp))
(get-value-code
(compile (definition-value exp) ct-env 'val 'next)))
(end-with-linkage linkage
(preserving '(env)
get-value-code
(make-instruction-sequence '(env val) (list target)
`((perform (op define-variable!)
(const ,var)
(reg val)
(reg env))
(assign ,target (const ok))))))))
;;;conditional expressions
;;;labels (from footnote)
(define label-counter 0)
(define (new-label-number)
(set! label-counter (+ 1 label-counter))
label-counter)
(define (make-label name)
(string->symbol
(string-append (symbol->string name)
(number->string (new-label-number)))))
;; end of footnote
(define (compile-if exp ct-env target linkage)
(let ((t-branch (make-label 'true-branch))
(f-branch (make-label 'false-branch))
(after-if (make-label 'after-if)))
(let ((consequent-linkage
(if (eq? linkage 'next) after-if linkage)))
(let ((p-code (compile (if-predicate exp) ct-env 'val 'next))
(c-code
(compile
(if-consequent exp) ct-env target consequent-linkage))
(a-code
(compile (if-alternative exp) ct-env target linkage)))
(preserving '(env continue)
p-code
(append-instruction-sequences
(make-instruction-sequence '(val) '()
`((test (op false?) (reg val))
(branch (label ,f-branch))))
(parallel-instruction-sequences
(append-instruction-sequences t-branch c-code)
(append-instruction-sequences f-branch a-code))
after-if))))))
;;; sequences
(define (compile-sequence seq ct-env target linkage)
(if (last-exp? seq)
(compile (first-exp seq) ct-env target linkage)
(preserving '(env continue)
(compile (first-exp seq) ct-env target 'next)
(compile-sequence (rest-exps seq) ct-env target linkage))))
;;;lambda expressions
(define (compile-lambda exp ct-env target linkage)
(let ((proc-entry (make-label 'entry))
(after-lambda (make-label 'after-lambda)))
(let ((lambda-linkage (if (eq? linkage 'next) after-lambda linkage))
(exp (lambda->lambda-without-defines exp)))
(append-instruction-sequences
(tack-on-instruction-sequence
(end-with-linkage lambda-linkage
(make-instruction-sequence '(env) (list target)
`((assign ,target
(op make-compiled-procedure)
(label ,proc-entry)
(reg env)))))
(compile-lambda-body exp ct-env proc-entry))
after-lambda))))
(define (compile-lambda-body exp ct-env proc-entry)
(let* ((formals (lambda-parameters exp))
(ct-env (extend-compile-time-env formals ct-env)))
(append-instruction-sequences
(make-instruction-sequence '(env proc argl) '(env)
`(,proc-entry
(assign env (op compiled-procedure-env) (reg proc))
(assign env
(op extend-environment)
(const ,formals)
(reg argl)
(reg env))))
(compile-sequence (lambda-body exp) ct-env 'val 'return))))
;;;SECTION 5.5.3
;;;combinations
(define (compile-application exp ct-env target linkage)
(let ((proc-code (compile (operator exp) ct-env 'proc 'next))
(operand-codes
(map (lambda (operand) (compile operand ct-env 'val 'next))
(operands exp))))
(preserving '(env continue)
proc-code
(preserving '(proc continue)
(construct-arglist operand-codes)
(compile-procedure-call target linkage)))))
(define (construct-arglist operand-codes)
(let ((operand-codes (reverse operand-codes)))
(if (null? operand-codes)
(make-instruction-sequence '() '(argl)
'((assign argl (const ()))))
(let ((code-to-get-last-arg
(append-instruction-sequences
(car operand-codes)
(make-instruction-sequence '(val) '(argl)
'((assign argl (op list) (reg val)))))))
(if (null? (cdr operand-codes))
code-to-get-last-arg
(preserving '(env)
code-to-get-last-arg
(code-to-get-rest-args
(cdr operand-codes))))))))
(define (code-to-get-rest-args operand-codes)
(let ((code-for-next-arg
(preserving '(argl)
(car operand-codes)
(make-instruction-sequence '(val argl) '(argl)
'((assign argl
(op cons) (reg val) (reg argl)))))))
(if (null? (cdr operand-codes))
code-for-next-arg
(preserving '(env)
code-for-next-arg
(code-to-get-rest-args (cdr operand-codes))))))
;;;applying procedures
(define (compile-procedure-call target linkage)
(let ((primitive-branch (make-label 'primitive-branch))
(compiled-branch (make-label 'compiled-branch))
(after-call (make-label 'after-call)))
(let ((compiled-linkage
(if (eq? linkage 'next) after-call linkage)))
(append-instruction-sequences
(make-instruction-sequence '(proc) '()
`((test (op primitive-procedure?) (reg proc))
(branch (label ,primitive-branch))))
(parallel-instruction-sequences
(append-instruction-sequences
compiled-branch
(compile-proc-appl target compiled-linkage))
(append-instruction-sequences
primitive-branch
(end-with-linkage linkage
(make-instruction-sequence '(proc argl)
(list target)
`((assign ,target
(op apply-primitive-procedure)
(reg proc)
(reg argl)))))))
after-call))))
;;;applying compiled procedures
(define (compile-proc-appl target linkage)
(cond ((and (eq? target 'val) (not (eq? linkage 'return)))
(make-instruction-sequence '(proc) all-regs
`((assign continue (label ,linkage))
(assign val (op compiled-procedure-entry)
(reg proc))
(goto (reg val)))))
((and (not (eq? target 'val))
(not (eq? linkage 'return)))
(let ((proc-return (make-label 'proc-return)))
(make-instruction-sequence '(proc) all-regs
`((assign continue (label ,proc-return))
(assign val (op compiled-procedure-entry)
(reg proc))
(goto (reg val))
,proc-return
(assign ,target (reg val))
(goto (label ,linkage))))))
((and (eq? target 'val) (eq? linkage 'return))
(make-instruction-sequence '(proc continue) all-regs
'((assign val (op compiled-procedure-entry)
(reg proc))
(goto (reg val)))))
((and (not (eq? target 'val)) (eq? linkage 'return))
(error "return linkage, target not val -- COMPILE"
target))))
;; footnote
(define all-regs '(env proc val argl continue))
;;;SECTION 5.5.4
(define (registers-needed s)
(if (symbol? s) '() (car s)))
(define (registers-modified s)
(if (symbol? s) '() (cadr s)))
(define (statements s)
(if (symbol? s) (list s) (caddr s)))
(define (needs-register? seq reg)
(memq reg (registers-needed seq)))
(define (modifies-register? seq reg)
(memq reg (registers-modified seq)))
(define (append-instruction-sequences . seqs)
(define (append-2-sequences seq1 seq2)
(make-instruction-sequence
(list-union (registers-needed seq1)
(list-difference (registers-needed seq2)
(registers-modified seq1)))
(list-union (registers-modified seq1)
(registers-modified seq2))
(append (statements seq1) (statements seq2))))
(define (append-seq-list seqs)
(if (null? seqs)
(empty-instruction-sequence)
(append-2-sequences (car seqs)
(append-seq-list (cdr seqs)))))
(append-seq-list seqs))
(define (list-union s1 s2)
(cond ((null? s1) s2)
((memq (car s1) s2) (list-union (cdr s1) s2))
(else (cons (car s1) (list-union (cdr s1) s2)))))
(define (list-difference s1 s2)
(cond ((null? s1) '())
((memq (car s1) s2) (list-difference (cdr s1) s2))
(else (cons (car s1)
(list-difference (cdr s1) s2)))))
(define (preserving regs seq1 seq2)
(if (null? regs)
(append-instruction-sequences seq1 seq2)
(let ((first-reg (car regs)))
(if (and (needs-register? seq2 first-reg)
(modifies-register? seq1 first-reg))
(preserving (cdr regs)
(make-instruction-sequence
(list-union (list first-reg)
(registers-needed seq1))
(list-difference (registers-modified seq1)
(list first-reg))
(append `((save ,first-reg))
(statements seq1)
`((restore ,first-reg))))
seq2)
(preserving (cdr regs) seq1 seq2)))))
(define (tack-on-instruction-sequence seq body-seq)
(make-instruction-sequence
(registers-needed seq)
(registers-modified seq)
(append (statements seq) (statements body-seq))))
(define (parallel-instruction-sequences seq1 seq2)
(make-instruction-sequence
(list-union (registers-needed seq1)
(registers-needed seq2))
(list-union (registers-modified seq1)
(registers-modified seq2))
(append (statements seq1) (statements seq2))))
'(COMPILER LOADED)

384
shared/sicp-compiler.scm Normal file
View File

@@ -0,0 +1,384 @@
;;;;COMPILER FROM SECTION 5.5 OF
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
;;;;Matches code in ch5.scm
;;;;This file can be loaded into Scheme as a whole.
;;;;**NOTE**This file loads the metacircular evaluator's syntax procedures
;;;; from section 4.1.2
;;;; You may need to change the (load ...) expression to work in your
;;;; version of Scheme.
;;;;Then you can compile Scheme programs as shown in section 5.5.5
;;**implementation-dependent loading of syntax procedures
(load "shared/sicp-syntax.scm") ;section 4.1.2 syntax procedures
;;;SECTION 5.5.1
(define (compile exp target linkage)
(cond ((self-evaluating? exp)
(compile-self-evaluating exp target linkage))
((quoted? exp) (compile-quoted exp target linkage))
((variable? exp)
(compile-variable exp target linkage))
((assignment? exp)
(compile-assignment exp target linkage))
((definition? exp)
(compile-definition exp target linkage))
((if? exp) (compile-if exp target linkage))
((lambda? exp) (compile-lambda exp target linkage))
((begin? exp)
(compile-sequence (begin-actions exp)
target
linkage))
((cond? exp) (compile (cond->if exp) target linkage))
((primitive-procedure? exp)
(compile-primitive exp target linkage))
((application? exp)
(compile-application exp target linkage))
(else
(error "Unknown expression type -- COMPILE" exp))))
(define (make-instruction-sequence needs modifies statements)
(list needs modifies statements))
(define (empty-instruction-sequence)
(make-instruction-sequence '() '() '()))
;; Implemented in 5.38.
(define (primitive-procedure? exp) #f)
;;;SECTION 5.5.2
;;;linkage code
(define (compile-linkage linkage)
(cond ((eq? linkage 'return)
(make-instruction-sequence '(continue) '()
'((goto (reg continue)))))
((eq? linkage 'next)
(empty-instruction-sequence))
(else
(make-instruction-sequence '() '()
`((goto (label ,linkage)))))))
(define (end-with-linkage linkage instruction-sequence)
(preserving '(continue)
instruction-sequence
(compile-linkage linkage)))
;;;simple expressions
(define (compile-self-evaluating exp target linkage)
(end-with-linkage linkage
(make-instruction-sequence '() (list target)
`((assign ,target (const ,exp))))))
(define (compile-quoted exp target linkage)
(end-with-linkage linkage
(make-instruction-sequence '() (list target)
`((assign ,target (const ,(text-of-quotation exp)))))))
(define (compile-variable exp target linkage)
(end-with-linkage linkage
(make-instruction-sequence '(env) (list target)
`((assign ,target
(op lookup-variable-value)
(const ,exp)
(reg env))))))
(define (compile-assignment exp target linkage)
(let ((var (assignment-variable exp))
(get-value-code
(compile (assignment-value exp) 'val 'next)))
(end-with-linkage linkage
(preserving '(env)
get-value-code
(make-instruction-sequence '(env val) (list target)
`((perform (op set-variable-value!)
(const ,var)
(reg val)
(reg env))
(assign ,target (const ok))))))))
(define (compile-definition exp target linkage)
(let ((var (definition-variable exp))
(get-value-code
(compile (definition-value exp) 'val 'next)))
(end-with-linkage linkage
(preserving '(env)
get-value-code
(make-instruction-sequence '(env val) (list target)
`((perform (op define-variable!)
(const ,var)
(reg val)
(reg env))
(assign ,target (const ok))))))))
;;;conditional expressions
;;;labels (from footnote)
(define label-counter 0)
(define (new-label-number)
(set! label-counter (+ 1 label-counter))
label-counter)
(define (make-label name)
(string->symbol
(string-append (symbol->string name)
(number->string (new-label-number)))))
;; end of footnote
(define (compile-if exp target linkage)
(let ((t-branch (make-label 'true-branch))
(f-branch (make-label 'false-branch))
(after-if (make-label 'after-if)))
(let ((consequent-linkage
(if (eq? linkage 'next) after-if linkage)))
(let ((p-code (compile (if-predicate exp) 'val 'next))
(c-code
(compile
(if-consequent exp) target consequent-linkage))
(a-code
(compile (if-alternative exp) target linkage)))
(preserving '(env continue)
p-code
(append-instruction-sequences
(make-instruction-sequence '(val) '()
`((test (op false?) (reg val))
(branch (label ,f-branch))))
(parallel-instruction-sequences
(append-instruction-sequences t-branch c-code)
(append-instruction-sequences f-branch a-code))
after-if))))))
;;; sequences
(define (compile-sequence seq target linkage)
(if (last-exp? seq)
(compile (first-exp seq) target linkage)
(preserving '(env continue)
(compile (first-exp seq) target 'next)
(compile-sequence (rest-exps seq) target linkage))))
;;;lambda expressions
(define (compile-lambda exp target linkage)
(let ((proc-entry (make-label 'entry))
(after-lambda (make-label 'after-lambda)))
(let ((lambda-linkage
(if (eq? linkage 'next) after-lambda linkage)))
(append-instruction-sequences
(tack-on-instruction-sequence
(end-with-linkage lambda-linkage
(make-instruction-sequence '(env) (list target)
`((assign ,target
(op make-compiled-procedure)
(label ,proc-entry)
(reg env)))))
(compile-lambda-body exp proc-entry))
after-lambda))))
(define (compile-lambda-body exp proc-entry)
(let ((formals (lambda-parameters exp)))
(append-instruction-sequences
(make-instruction-sequence '(env proc argl) '(env)
`(,proc-entry
(assign env (op compiled-procedure-env) (reg proc))
(assign env
(op extend-environment)
(const ,formals)
(reg argl)
(reg env))))
(compile-sequence (lambda-body exp) 'val 'return))))
;;;SECTION 5.5.3
;;;combinations
(define (compile-application exp target linkage)
(let ((proc-code (compile (operator exp) 'proc 'next))
(operand-codes
(map (lambda (operand) (compile operand 'val 'next))
(operands exp))))
(preserving '(env continue)
proc-code
(preserving '(proc continue)
(construct-arglist operand-codes)
(compile-procedure-call target linkage)))))
(define (construct-arglist operand-codes)
(let ((operand-codes (reverse operand-codes)))
(if (null? operand-codes)
(make-instruction-sequence '() '(argl)
'((assign argl (const ()))))
(let ((code-to-get-last-arg
(append-instruction-sequences
(car operand-codes)
(make-instruction-sequence '(val) '(argl)
'((assign argl (op list) (reg val)))))))
(if (null? (cdr operand-codes))
code-to-get-last-arg
(preserving '(env)
code-to-get-last-arg
(code-to-get-rest-args
(cdr operand-codes))))))))
(define (code-to-get-rest-args operand-codes)
(let ((code-for-next-arg
(preserving '(argl)
(car operand-codes)
(make-instruction-sequence '(val argl) '(argl)
'((assign argl
(op cons) (reg val) (reg argl)))))))
(if (null? (cdr operand-codes))
code-for-next-arg
(preserving '(env)
code-for-next-arg
(code-to-get-rest-args (cdr operand-codes))))))
;;;applying procedures
(define (compile-procedure-call target linkage)
(let ((primitive-branch (make-label 'primitive-branch))
(compiled-branch (make-label 'compiled-branch))
(after-call (make-label 'after-call)))
(let ((compiled-linkage
(if (eq? linkage 'next) after-call linkage)))
(append-instruction-sequences
(make-instruction-sequence '(proc) '()
`((test (op primitive-procedure?) (reg proc))
(branch (label ,primitive-branch))))
(parallel-instruction-sequences
(append-instruction-sequences
compiled-branch
(compile-proc-appl target compiled-linkage))
(append-instruction-sequences
primitive-branch
(end-with-linkage linkage
(make-instruction-sequence '(proc argl)
(list target)
`((assign ,target
(op apply-primitive-procedure)
(reg proc)
(reg argl)))))))
after-call))))
;;;applying compiled procedures
(define (compile-proc-appl target linkage)
(cond ((and (eq? target 'val) (not (eq? linkage 'return)))
(make-instruction-sequence '(proc) all-regs
`((assign continue (label ,linkage))
(assign val (op compiled-procedure-entry)
(reg proc))
(goto (reg val)))))
((and (not (eq? target 'val))
(not (eq? linkage 'return)))
(let ((proc-return (make-label 'proc-return)))
(make-instruction-sequence '(proc) all-regs
`((assign continue (label ,proc-return))
(assign val (op compiled-procedure-entry)
(reg proc))
(goto (reg val))
,proc-return
(assign ,target (reg val))
(goto (label ,linkage))))))
((and (eq? target 'val) (eq? linkage 'return))
(make-instruction-sequence '(proc continue) all-regs
'((assign val (op compiled-procedure-entry)
(reg proc))
(goto (reg val)))))
((and (not (eq? target 'val)) (eq? linkage 'return))
(error "return linkage, target not val -- COMPILE"
target))))
;; footnote
(define all-regs '(env proc val argl continue))
;;;SECTION 5.5.4
(define (registers-needed s)
(if (symbol? s) '() (car s)))
(define (registers-modified s)
(if (symbol? s) '() (cadr s)))
(define (statements s)
(if (symbol? s) (list s) (caddr s)))
(define (needs-register? seq reg)
(memq reg (registers-needed seq)))
(define (modifies-register? seq reg)
(memq reg (registers-modified seq)))
(define (append-instruction-sequences . seqs)
(define (append-2-sequences seq1 seq2)
(make-instruction-sequence
(list-union (registers-needed seq1)
(list-difference (registers-needed seq2)
(registers-modified seq1)))
(list-union (registers-modified seq1)
(registers-modified seq2))
(append (statements seq1) (statements seq2))))
(define (append-seq-list seqs)
(if (null? seqs)
(empty-instruction-sequence)
(append-2-sequences (car seqs)
(append-seq-list (cdr seqs)))))
(append-seq-list seqs))
(define (list-union s1 s2)
(cond ((null? s1) s2)
((memq (car s1) s2) (list-union (cdr s1) s2))
(else (cons (car s1) (list-union (cdr s1) s2)))))
(define (list-difference s1 s2)
(cond ((null? s1) '())
((memq (car s1) s2) (list-difference (cdr s1) s2))
(else (cons (car s1)
(list-difference (cdr s1) s2)))))
(define (preserving regs seq1 seq2)
(if (null? regs)
(append-instruction-sequences seq1 seq2)
(let ((first-reg (car regs)))
(if (and (needs-register? seq2 first-reg)
(modifies-register? seq1 first-reg))
(preserving (cdr regs)
(make-instruction-sequence
(list-union (list first-reg)
(registers-needed seq1))
(list-difference (registers-modified seq1)
(list first-reg))
(append `((save ,first-reg))
(statements seq1)
`((restore ,first-reg))))
seq2)
(preserving (cdr regs) seq1 seq2)))))
(define (tack-on-instruction-sequence seq body-seq)
(make-instruction-sequence
(registers-needed seq)
(registers-modified seq)
(append (statements seq) (statements body-seq))))
(define (parallel-instruction-sequences seq1 seq2)
(make-instruction-sequence
(list-union (registers-needed seq1)
(registers-needed seq2))
(list-union (registers-modified seq1)
(registers-modified seq2))
(append (statements seq1) (statements seq2))))
'(COMPILER LOADED)

370
shared/sicp-eceval-compiler.scm Normal file
View File

@@ -0,0 +1,370 @@
;;;;EXPLICIT-CONTROL EVALUATOR FROM SECTION 5.4 OF
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
;;;; MODIFIED TO SUPPORT COMPILED CODE (AS IN SECTION 5.5.7)
;;;;Changes to basic evaluator machine are
;;;; (1) some new eceval controller code for the driver and apply-dispatch;
;;;; (2) some additional machine operations from;
;;;; (3) support for compiled code to call interpreted code (exercise 5.47) --
;;;; (new register and 1 new instruction at start)
;;;; (4) new startup aid start-eceval
;; Explicit-control evaluator.
;; To use it, load "load-eceval-compiler.scm", which loads this file and the
;; support it needs (including the register-machine simulator)
;; To start, can use compile-and-go as in section 5.5.7
;; or start-eceval as in the section 5.5.7 footnote.
;; To resume the machine without reinitializing the global environment
;; if you have somehow interrupted out of the machine back to Scheme, do
;: (set-register-contents! eceval 'flag false)
;: (start eceval)
;;;;;;;;
;; any old value to create the variable so that
;; compile-and-go and/or start-eceval can set! it.
(define the-global-environment '())
;;; Interfacing compiled code with eceval machine
;;; From section 5.5.7
(define (start-eceval)
(set! the-global-environment (setup-environment))
(set-register-contents! eceval 'flag false)
(start eceval))
;; Modification of section 4.1.4 procedure
;; **replaces version in syntax file
(define (user-print object)
(cond ((compound-procedure? object)
(display (list 'compound-procedure
(procedure-parameters object)
(procedure-body object)
'<procedure-env>)))
((compiled-procedure? object)
(display '<compiled-procedure>))
(else (display object))))
(define (compile-and-go expression)
(let ((instructions
(assemble (statements
(compile expression 'val 'return))
eceval)))
(set! the-global-environment (setup-environment))
(set-register-contents! eceval 'val instructions)
(set-register-contents! eceval 'flag true)
(start eceval)))
;;**NB. To [not] monitor stack operations, comment in/[out] the line after
;; print-result in the machine controller below
;;**Also choose the desired make-stack version in regsim.scm
(define eceval-operations
(list
;;primitive Scheme operations
(list 'read read) ;used by eceval
;;used by compiled code
(list 'list list)
(list 'cons cons)
;;operations in syntax.scm
(list 'self-evaluating? self-evaluating?)
(list 'quoted? quoted?)
(list 'text-of-quotation text-of-quotation)
(list 'variable? variable?)
(list 'assignment? assignment?)
(list 'assignment-variable assignment-variable)
(list 'assignment-value assignment-value)
(list 'definition? definition?)
(list 'definition-variable definition-variable)
(list 'definition-value definition-value)
(list 'lambda? lambda?)
(list 'lambda-parameters lambda-parameters)
(list 'lambda-body lambda-body)
(list 'if? if?)
(list 'if-predicate if-predicate)
(list 'if-consequent if-consequent)
(list 'if-alternative if-alternative)
(list 'begin? begin?)
(list 'begin-actions begin-actions)
(list 'last-exp? last-exp?)
(list 'first-exp first-exp)
(list 'rest-exps rest-exps)
(list 'application? application?)
(list 'operator operator)
(list 'operands operands)
(list 'no-operands? no-operands?)
(list 'first-operand first-operand)
(list 'rest-operands rest-operands)
;;operations in eceval-support.scm
(list 'true? true?)
(list 'false? false?) ;for compiled code
(list 'make-procedure make-procedure)
(list 'compound-procedure? compound-procedure?)
(list 'procedure-parameters procedure-parameters)
(list 'procedure-body procedure-body)
(list 'procedure-environment procedure-environment)
(list 'extend-environment extend-environment)
(list 'lookup-variable-value lookup-variable-value)
(list 'set-variable-value! set-variable-value!)
(list 'define-variable! define-variable!)
(list 'primitive-procedure? primitive-procedure?)
(list 'apply-primitive-procedure apply-primitive-procedure)
(list 'prompt-for-input prompt-for-input)
(list 'announce-output announce-output)
(list 'user-print user-print)
(list 'empty-arglist empty-arglist)
(list 'adjoin-arg adjoin-arg)
(list 'last-operand? last-operand?)
(list 'no-more-exps? no-more-exps?) ;for non-tail-recursive machine
(list 'get-global-environment get-global-environment)
;;for compiled code (also in eceval-support.scm)
(list 'make-compiled-procedure make-compiled-procedure)
(list 'compiled-procedure? compiled-procedure?)
(list 'compiled-procedure-entry compiled-procedure-entry)
(list 'compiled-procedure-env compiled-procedure-env)
))
(define eceval
(make-machine
'(exp env val proc argl continue unev
compapp ;*for compiled to call interpreted
)
eceval-operations
'(
;;SECTION 5.4.4, as modified in 5.5.7
;;*for compiled to call interpreted (from exercise 5.47)
(assign compapp (label compound-apply))
;;*next instruction supports entry from compiler (from section 5.5.7)
(branch (label external-entry))
read-eval-print-loop
(perform (op initialize-stack))
(perform
(op prompt-for-input) (const ";;; EC-Eval input:"))
(assign exp (op read))
(assign env (op get-global-environment))
(assign continue (label print-result))
(goto (label eval-dispatch))
print-result
;;**following instruction optional -- if use it, need monitored stack
(perform (op print-stack-statistics))
(perform
(op announce-output) (const ";;; EC-Eval value:"))
(perform (op user-print) (reg val))
(goto (label read-eval-print-loop))
;;*support for entry from compiler (from section 5.5.7)
external-entry
(perform (op initialize-stack))
(assign env (op get-global-environment))
(assign continue (label print-result))
(goto (reg val))
unknown-expression-type
(assign val (const unknown-expression-type-error))
(goto (label signal-error))
unknown-procedure-type
(restore continue)
(assign val (const unknown-procedure-type-error))
(goto (label signal-error))
signal-error
(perform (op user-print) (reg val))
(goto (label read-eval-print-loop))
;;SECTION 5.4.1
eval-dispatch
(test (op self-evaluating?) (reg exp))
(branch (label ev-self-eval))
(test (op variable?) (reg exp))
(branch (label ev-variable))
(test (op quoted?) (reg exp))
(branch (label ev-quoted))
(test (op assignment?) (reg exp))
(branch (label ev-assignment))
(test (op definition?) (reg exp))
(branch (label ev-definition))
(test (op if?) (reg exp))
(branch (label ev-if))
(test (op lambda?) (reg exp))
(branch (label ev-lambda))
(test (op begin?) (reg exp))
(branch (label ev-begin))
(test (op application?) (reg exp))
(branch (label ev-application))
(goto (label unknown-expression-type))
ev-self-eval
(assign val (reg exp))
(goto (reg continue))
ev-variable
(assign val (op lookup-variable-value) (reg exp) (reg env))
(goto (reg continue))
ev-quoted
(assign val (op text-of-quotation) (reg exp))
(goto (reg continue))
ev-lambda
(assign unev (op lambda-parameters) (reg exp))
(assign exp (op lambda-body) (reg exp))
(assign val (op make-procedure)
(reg unev) (reg exp) (reg env))
(goto (reg continue))
ev-application
(save continue)
(save env)
(assign unev (op operands) (reg exp))
(save unev)
(assign exp (op operator) (reg exp))
(assign continue (label ev-appl-did-operator))
(goto (label eval-dispatch))
ev-appl-did-operator
(restore unev)
(restore env)
(assign argl (op empty-arglist))
(assign proc (reg val))
(test (op no-operands?) (reg unev))
(branch (label apply-dispatch))
(save proc)
ev-appl-operand-loop
(save argl)
(assign exp (op first-operand) (reg unev))
(test (op last-operand?) (reg unev))
(branch (label ev-appl-last-arg))
(save env)
(save unev)
(assign continue (label ev-appl-accumulate-arg))
(goto (label eval-dispatch))
ev-appl-accumulate-arg
(restore unev)
(restore env)
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(assign unev (op rest-operands) (reg unev))
(goto (label ev-appl-operand-loop))
ev-appl-last-arg
(assign continue (label ev-appl-accum-last-arg))
(goto (label eval-dispatch))
ev-appl-accum-last-arg
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(restore proc)
(goto (label apply-dispatch))
apply-dispatch
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-apply))
(test (op compound-procedure?) (reg proc))
(branch (label compound-apply))
;;*next added to call compiled code from evaluator (section 5.5.7)
(test (op compiled-procedure?) (reg proc))
(branch (label compiled-apply))
(goto (label unknown-procedure-type))
;;*next added to call compiled code from evaluator (section 5.5.7)
compiled-apply
(restore continue)
(assign val (op compiled-procedure-entry) (reg proc))
(goto (reg val))
primitive-apply
(assign val (op apply-primitive-procedure)
(reg proc)
(reg argl))
(restore continue)
(goto (reg continue))
compound-apply
(assign unev (op procedure-parameters) (reg proc))
(assign env (op procedure-environment) (reg proc))
(assign env (op extend-environment)
(reg unev) (reg argl) (reg env))
(assign unev (op procedure-body) (reg proc))
(goto (label ev-sequence))
;;;SECTION 5.4.2
ev-begin
(assign unev (op begin-actions) (reg exp))
(save continue)
(goto (label ev-sequence))
ev-sequence
(assign exp (op first-exp) (reg unev))
(test (op last-exp?) (reg unev))
(branch (label ev-sequence-last-exp))
(save unev)
(save env)
(assign continue (label ev-sequence-continue))
(goto (label eval-dispatch))
ev-sequence-continue
(restore env)
(restore unev)
(assign unev (op rest-exps) (reg unev))
(goto (label ev-sequence))
ev-sequence-last-exp
(restore continue)
(goto (label eval-dispatch))
;;;SECTION 5.4.3
ev-if
(save exp)
(save env)
(save continue)
(assign continue (label ev-if-decide))
(assign exp (op if-predicate) (reg exp))
(goto (label eval-dispatch))
ev-if-decide
(restore continue)
(restore env)
(restore exp)
(test (op true?) (reg val))
(branch (label ev-if-consequent))
ev-if-alternative
(assign exp (op if-alternative) (reg exp))
(goto (label eval-dispatch))
ev-if-consequent
(assign exp (op if-consequent) (reg exp))
(goto (label eval-dispatch))
ev-assignment
(assign unev (op assignment-variable) (reg exp))
(save unev)
(assign exp (op assignment-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-assignment-1))
(goto (label eval-dispatch))
ev-assignment-1
(restore continue)
(restore env)
(restore unev)
(perform
(op set-variable-value!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
ev-definition
(assign unev (op definition-variable) (reg exp))
(save unev)
(assign exp (op definition-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-definition-1))
(goto (label eval-dispatch))
ev-definition-1
(restore continue)
(restore env)
(restore unev)
(perform
(op define-variable!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
)))
'(EXPLICIT CONTROL EVALUATOR FOR COMPILER LOADED)

301
shared/sicp-eceval-lazy.scm Normal file
View File

@@ -0,0 +1,301 @@
; Uncomment the import if you want to use the lazy-evaluator standalone. We
; only use it in ex-5_23-30.scm right now and in that context everything is
; already imported for the regular evaluator.
;(load "shared/sicp-eceval-support.scm")
; Below is the original version of the evaluator-machine from the book modified
; for lazy-evaluation.
(define eceval-lazy
(make-machine
'(exp env val proc argl continue unev)
eceval-operations
'(
(perform (op initialize-stack))
(assign env (op get-global-environment))
(assign continue (label ev-almost-done))
(goto (label eval-dispatch))
unknown-expression-type
(assign val (const unknown-expression-type-error))
(goto (label signal-error))
unknown-procedure-type
(restore continue)
(assign val (const unknown-procedure-type-error))
(goto (label signal-error))
signal-error
(perform (op user-print) (reg val))
(goto (label ev-done))
;;SECTION 5.4.1
eval-dispatch
(test (op self-evaluating?) (reg exp))
(branch (label ev-self-eval))
(test (op variable?) (reg exp))
(branch (label ev-variable))
(test (op quoted?) (reg exp))
(branch (label ev-quoted))
(test (op assignment?) (reg exp))
(branch (label ev-assignment))
(test (op definition?) (reg exp))
(branch (label ev-definition))
(test (op if?) (reg exp))
(branch (label ev-if))
(test (op cond?) (reg exp))
(branch (label ev-cond))
(test (op let?) (reg exp))
(branch (label ev-let))
(test (op lambda?) (reg exp))
(branch (label ev-lambda))
(test (op begin?) (reg exp))
(branch (label ev-begin))
(test (op application?) (reg exp))
(branch (label ev-application))
(goto (label unknown-expression-type))
ev-self-eval
(assign val (reg exp))
(goto (reg continue))
ev-variable
(assign val (op lookup-variable-value) (reg exp) (reg env))
(goto (reg continue))
ev-quoted
(assign val (op text-of-quotation) (reg exp))
(goto (reg continue))
ev-lambda
(assign unev (op lambda-parameters) (reg exp))
(assign exp (op lambda-body) (reg exp))
(assign val (op make-procedure)
(reg unev) (reg exp) (reg env))
(goto (reg continue))
ev-application
(save continue)
(save env)
(assign unev (op operands) (reg exp))
(save unev)
(assign exp (op operator) (reg exp))
(assign continue (label ev-appl-did-operator))
(goto (label eval-dispatch))
ev-appl-did-operator
(restore unev)
(restore env)
(assign argl (op empty-arglist))
(assign proc (reg val))
(test (op no-operands?) (reg unev))
(branch (label apply-dispatch))
(save proc)
(test (op primitive-procedure?) (reg proc))
(branch (label ev-appl-operand-loop-force))
(test (op compound-procedure?) (reg proc))
(branch (label ev-appl-operand-loop-delay))
(goto (label unknown-procedure-type))
ev-force-it
(assign env (op thunk-env) (reg val))
(assign exp (op thunk-exp) (reg val))
(goto (label eval-dispatch))
ev-appl-operand-loop-force
(save argl)
(assign exp (op first-operand) (reg unev))
(test (op last-operand?) (reg unev))
(branch (label ev-appl-last-arg-force))
(save env)
(save unev)
(assign continue (label ev-appl-accumulate-arg-force))
(goto (label eval-dispatch))
ev-appl-accumulate-arg-force
(test (op thunk?) (reg val))
(branch (label ev-force-it))
(restore unev)
(restore env)
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(assign unev (op rest-operands) (reg unev))
(goto (label ev-appl-operand-loop-force))
ev-appl-last-arg-force
(assign continue (label ev-appl-accum-last-arg-force))
(goto (label eval-dispatch))
ev-appl-accum-last-arg-force
(test (op thunk?) (reg val))
(branch (label ev-force-it))
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(restore proc)
(goto (label apply-dispatch))
ev-appl-operand-loop-delay
;(save argl)
(assign exp (op first-operand) (reg unev))
(test (op last-operand?) (reg unev))
(branch (label ev-appl-last-arg-delay))
;(save env)
;(save unev)
(assign val (op delay-it) (reg exp) (reg env))
;(assign continue (label ev-appl-accumulate-arg-delay))
;(goto (label eval-dispatch))
ev-appl-accumulate-arg-delay
;(restore unev)
;(restore env)
;(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(assign unev (op rest-operands) (reg unev))
(goto (label ev-appl-operand-loop-delay))
ev-appl-last-arg-delay
(assign val (op delay-it) (reg exp) (reg env))
;(assign continue (label ev-appl-accum-last-arg-delay))
;(goto (label eval-dispatch))
ev-appl-accum-last-arg-delay
;(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(restore proc)
(goto (label apply-dispatch))
apply-dispatch
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-apply))
(test (op compound-procedure?) (reg proc))
(branch (label compound-apply))
(goto (label unknown-procedure-type))
primitive-apply
(assign val (op apply-primitive-procedure)
(reg proc)
(reg argl))
(restore continue)
(goto (reg continue))
compound-apply
(assign unev (op procedure-parameters) (reg proc))
(assign env (op procedure-environment) (reg proc))
(assign env (op extend-environment)
(reg unev) (reg argl) (reg env))
(assign unev (op procedure-body) (reg proc))
(goto (label ev-sequence))
;;;SECTION 5.4.2
ev-begin
(assign unev (op begin-actions) (reg exp))
(save continue)
(goto (label ev-sequence))
ev-sequence
(assign exp (op first-exp) (reg unev))
(test (op last-exp?) (reg unev))
(branch (label ev-sequence-last-exp))
(save unev)
(save env)
(assign continue (label ev-sequence-continue))
(goto (label eval-dispatch))
ev-sequence-continue
(restore env)
(restore unev)
(assign unev (op rest-exps) (reg unev))
(goto (label ev-sequence))
ev-sequence-last-exp
(restore continue)
(goto (label eval-dispatch))
;;; ex-5.23
ev-cond-transform
(assign exp (op cond->if) (reg exp))
(goto (label eval-dispatch))
;;; ex-5.24
ev-cond
(save continue)
(assign unev (op cond-clauses) (reg exp)) ; unev contains all clauses
ev-cond-loop
(assign exp (op cond-first-clause) (reg unev)) ; exp contains first clause
(test (op cond-else-clause?) (reg exp)) ; test for else-clause
(branch (label ev-cond-done))
(assign continue (label ev-cond-decide))
(save unev)
(assign exp (op cond-predicate) (reg exp)) ; exp contains first predicate
(goto (label eval-dispatch)) ; eval predicate
ev-cond-decide
(restore unev)
(test (op true?) (reg val)) ; test if predicate is true
(branch (label ev-cond-done))
(assign unev (op cond-clauses) (reg unev)) ; unev contains remainging clauses
(goto (label ev-cond-loop))
ev-cond-done
(restore continue)
(assign exp (op cond-first-clause) (reg unev)) ; exp contains true clause
(goto (label ev-begin))
ev-let
(assign exp (op let->combination) (reg exp))
(goto (label eval-dispatch))
;;;SECTION 5.4.3
ev-if
(save exp)
(save env)
(save continue)
(assign continue (label ev-if-decide))
(assign exp (op if-predicate) (reg exp))
(goto (label eval-dispatch))
ev-if-decide
(restore continue)
(restore env)
(restore exp)
(test (op true?) (reg val))
(branch (label ev-if-consequent))
ev-if-alternative
(assign exp (op if-alternative) (reg exp))
(goto (label eval-dispatch))
ev-if-consequent
(assign exp (op if-consequent) (reg exp))
(goto (label eval-dispatch))
ev-assignment
(assign unev (op assignment-variable) (reg exp))
(save unev)
(assign exp (op assignment-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-assignment-1))
(goto (label eval-dispatch))
ev-assignment-1
(restore continue)
(restore env)
(restore unev)
(perform
(op set-variable-value!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
ev-definition
(assign unev (op definition-variable) (reg exp))
(save unev)
(assign exp (op definition-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-definition-1))
(goto (label eval-dispatch))
ev-definition-1
(restore continue)
(restore env)
(restore unev)
(perform
(op define-variable!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
ev-almost-done
(test (op thunk?) (reg val))
(branch (label ev-thunk-before-done))
(goto (label ev-done))
ev-thunk-before-done
(assign env (op thunk-env) (reg val))
(assign exp (op thunk-exp) (reg val))
(assign continue (label ev-done))
(goto (label eval-dispatch))
ev-done
;;(perform (op print-stack-statistics))
)))

341
shared/sicp-eceval-support.scm Normal file
View File

@@ -0,0 +1,341 @@
;;;;SIMULATION OF ECEVAL MACHINE OPERATIONS --
;;;;loaded by load-eceval.scm and by load-eceval-compiler.scm
;;;;FIRST A LOT FROM 4.1.2-4.1.4
;(load "sicp-syntax.scm"); ;section 4.1.2 syntax procedures
(load "shared/sicp-eceval-syntax.scm") ;section 4.1.2 syntax procedures
(load "shared/sicp-leval.scm") ; for lazy evaluation in eceval
;;;SECTION 4.1.3
;;; operations used by compiled code and eceval except as noted
(define (true? x)
(not (eq? x false)))
;;* not used by eceval itself -- used by compiled code when that
;; is run in the eceval machine
(define (false? x)
(eq? x false))
;;following compound-procedure operations not used by compiled code
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p)
(tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))
;;(end of compound procedures)
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())
(define (make-frame variables values)
(cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))
(define (extend-environment vars vals base-env)
(if (= (length vars) (length vals))
(cons (make-frame vars vals) base-env)
(if (< (length vars) (length vals))
(error "Too many arguments supplied" vars vals)
(error "Too few arguments supplied" vars vals))))
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(car vals))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
'unbound-variable-error
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (unbound-variable? var)
(eq? var 'unbound-variable-error))
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable -- SET!" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (define-variable! var val env)
(let ((frame (first-frame env)))
(define (scan vars vals)
(cond ((null? vars)
(add-binding-to-frame! var val frame))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(scan (frame-variables frame)
(frame-values frame))))
;;; cond-support
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-first-clause exp) (car exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false ; no else clause
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "ELSE clause isn't last -- COND->IF"
clauses))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))))))
;;; lambda-support
;;; let-support
(define (let? exp) (tagged-list? exp 'let))
(define (let-bindings exp) (cadr exp))
(define (let-body exp) (cddr exp))
(define (let-binding-var binding) (car binding))
(define (let-binding-exp binding) (cadr binding))
(define (let-vars exp) (map let-binding-var (let-bindings exp)))
(define (let-exps exp) (map let-binding-exp (let-bindings exp)))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (let->combination exp)
(let ((let-variables (let-vars exp))
(let-expressions (let-exps exp)))
(cons (make-lambda let-variables (let-body exp))
let-expressions)))
;;;SECTION 4.1.4
(define (setup-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(define-variable! 'true true initial-env)
(define-variable! 'false false initial-env)
initial-env))
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define primitive-procedures
(list (list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'null? null?)
;;above from book -- here are some more
(list '+ +)
(list '- -)
(list '* *)
(list '= =)
(list '/ /)
(list '> >)
(list '< <)
))
(define (primitive-procedure-names)
(map car
primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda (proc) (list 'primitive (cadr proc)))
primitive-procedures))
(define apply-in-underlying-scheme apply)
(define (check-apply-primitive proc args)
(cond
((eq? proc /) (check-apply-division args))
((eq? proc car) (check-apply-car args))
(else 'ok)))
(define (apply-primitive-error? val)
(eq? (car val) 'error))
(define (apply-primitive-result val) (cadr val))
(define (apply-primitive-procedure-safe proc args)
(let ((code (check-apply-primitive
(primitive-implementation proc)
args)))
(if (eq? code 'ok)
(list 'ok
(apply-in-underlying-scheme
(primitive-implementation proc)
args))
(list 'error code))))
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme
(primitive-implementation proc)
args))
(define (prompt-for-input string)
(newline) (newline) (display string) (newline))
(define (announce-output string)
(newline) (display string) (newline))
(define (user-print object)
(if (compound-procedure? object)
(display (list 'compound-procedure
(procedure-parameters object)
(procedure-body object)
'<procedure-env>))
(display object)))
;;; Simulation of new machine operations needed by
;;; eceval machine (not used by compiled code)
;;; From section 5.4.1 footnote
(define (empty-arglist) '())
(define (adjoin-arg arg arglist)
(append arglist (list arg)))
(define (last-operand? ops)
(null? (cdr ops)))
;;; From section 5.4.2 footnote, for non-tail-recursive sequences
(define (no-more-exps? seq) (null? seq))
;;; From section 5.4.4 footnote
(define (get-global-environment)
the-global-environment)
;; will do following when ready to run, not when load this file
;;(define the-global-environment (setup-environment))
;;; Simulation of new machine operations needed for compiled code
;;; and eceval/compiler interface (not used by plain eceval machine)
;;; From section 5.5.2 footnote
(define (make-compiled-procedure entry env)
(list 'compiled-procedure entry env))
(define (compiled-procedure? proc)
(tagged-list? proc 'compiled-procedure))
(define (compiled-procedure-entry c-proc) (cadr c-proc))
(define (compiled-procedure-env c-proc) (caddr c-proc))
(define eceval-operations
(list
;;primitive Scheme operations
(list 'display display)
(list 'newline newline)
(list 'read read)
;;operations in syntax.scm
(list 'application? application?)
(list 'assignment-value assignment-value)
(list 'assignment-variable assignment-variable)
(list 'assignment? assignment?)
(list 'begin-actions begin-actions)
(list 'begin? begin?)
(list 'definition-value definition-value)
(list 'definition-variable definition-variable)
(list 'definition? definition?)
(list 'first-exp first-exp)
(list 'first-operand first-operand)
(list 'if-alternative if-alternative)
(list 'if-consequent if-consequent)
(list 'if-predicate if-predicate)
(list 'if? if?)
(list 'lambda-body lambda-body)
(list 'lambda-parameters lambda-parameters)
(list 'lambda? lambda?)
(list 'last-exp? last-exp?)
(list 'no-operands? no-operands?)
(list 'operands operands)
(list 'operator operator)
(list 'quoted? quoted?)
(list 'rest-exps rest-exps)
(list 'rest-operands rest-operands)
(list 'self-evaluating? self-evaluating?)
(list 'text-of-quotation text-of-quotation)
(list 'variable? variable?)
;;operations in eceval-support.scm
(list 'adjoin-arg adjoin-arg)
(list 'announce-output announce-output)
(list 'apply-primitive-procedure apply-primitive-procedure)
(list 'compound-procedure? compound-procedure?)
(list 'define-variable! define-variable!)
(list 'empty-arglist empty-arglist)
(list 'extend-environment extend-environment)
(list 'get-global-environment get-global-environment)
(list 'last-operand? last-operand?)
(list 'lookup-variable-value lookup-variable-value)
(list 'make-procedure make-procedure)
(list 'no-more-exps? no-more-exps?) ;for non-tail-recursive machine
(list 'primitive-procedure? primitive-procedure?)
(list 'procedure-body procedure-body)
(list 'procedure-environment procedure-environment)
(list 'procedure-parameters procedure-parameters)
(list 'prompt-for-input prompt-for-input)
(list 'set-variable-value! set-variable-value!)
(list 'true? true?)
(list 'user-print user-print)
;;5.23
(list 'cond->if cond->if)
(list 'cond-actions cond-actions)
(list 'cond-clauses cond-clauses)
(list 'cond-else-clause? cond-else-clause?)
(list 'cond-first-clause cond-first-clause)
(list 'cond-predicate cond-predicate)
(list 'cond? cond?)
(list 'let->combination let->combination)
(list 'let? let?)
;;5.25
(list 'delay-it delay-it)
(list 'thunk? thunk?)
(list 'thunk-exp thunk-exp)
(list 'thunk-env thunk-env)
;;5.30
(list 'unbound-variable? unbound-variable?)
(list 'apply-primitive-procedure-safe apply-primitive-procedure-safe)
(list 'apply-primitive-result apply-primitive-result)
(list 'apply-primitive-error? apply-primitive-error?)
))

120
shared/sicp-eceval-syntax.scm Normal file
View File

@@ -0,0 +1,120 @@
;;;;SCHEME SYNTAX FROM SECTION 4.1.2 OF STRUCTURE AND INTERPRETATION OF
;;; COMPUTER PROGRAMS, TO SUPPORT CHAPTER 5
;;;;Loaded by compiler.scm (for use by compiler), and by eceval-support.scm
;;;; (for simulation of eceval machine operations)
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
(else false)))
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
(define (variable? exp) (symbol? exp))
(define (assignment? exp)
(tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (definition? exp)
(tagged-list? exp 'define))
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp)
(cddr exp))))
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)
'false))
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
;;;**following needed only to implement COND as derived expression,
;;; not needed by eceval machine in text. But used by compiler
;; from 4.1.2
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false ; no else clause
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "ELSE clause isn't last -- COND->IF"
clauses))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))))))
;; end of Cond support

267
shared/sicp-eceval.scm Normal file
View File

@@ -0,0 +1,267 @@
; Copied and adapted from:
; https://mitpress.mit.edu/sites/default/files/sicp/code/index.html
(load "shared/sicp-eceval-support.scm")
; To run:
; - Setup global environment
; > (define the-global-environment (setup-environment))
; - Assign code to exp register
; > (set-register-contents! eceval 'exp '(if false 1 2))
; - And start the machine
; > (start eceval)
; Below is the machine evaluator with some changes:
; - Remove the read-eval-print lool and instead execute from exp.
; - Machine does not print the result. Get it from val instead after running.
; - Add support for let and cond.
(define eceval
(make-machine
'(exp env val proc argl continue unev)
eceval-operations
'(
ev-start
(perform (op initialize-stack))
(assign env (op get-global-environment))
(assign continue (label ev-done))
(goto (label eval-dispatch))
unknown-expression-type
(assign val (const unknown-expression-type-error))
(goto (label signal-error))
unknown-procedure-type
(restore continue)
(assign val (const unknown-procedure-type-error))
(goto (label signal-error))
error-unbound-variable
(assign val (const error-unbound-variable))
(goto (label signal-error))
apply-primitive-error
(assign val (op apply-primitive-result) (reg val))
(goto (label signal-error))
signal-error
(perform (op user-print) (reg val))
(goto (label ev-done))
;;SECTION 5.4.1
eval-dispatch
(test (op cond?) (reg exp))
(branch (label ev-cond))
(test (op let?) (reg exp))
(branch (label ev-let))
(test (op self-evaluating?) (reg exp))
(branch (label ev-self-eval))
(test (op variable?) (reg exp))
(branch (label ev-variable))
(test (op quoted?) (reg exp))
(branch (label ev-quoted))
(test (op assignment?) (reg exp))
(branch (label ev-assignment))
(test (op definition?) (reg exp))
(branch (label ev-definition))
(test (op if?) (reg exp))
(branch (label ev-if))
(test (op lambda?) (reg exp))
(branch (label ev-lambda))
(test (op begin?) (reg exp))
(branch (label ev-begin))
(test (op application?) (reg exp))
(branch (label ev-application))
(goto (label unknown-expression-type))
ev-self-eval
(assign val (reg exp))
(goto (reg continue))
ev-variable
(assign val (op lookup-variable-value) (reg exp) (reg env))
(test (op unbound-variable?) (reg val))
(branch (label error-unbound-variable))
(goto (reg continue))
ev-quoted
(assign val (op text-of-quotation) (reg exp))
(goto (reg continue))
ev-lambda
(assign unev (op lambda-parameters) (reg exp))
(assign exp (op lambda-body) (reg exp))
(assign val (op make-procedure)
(reg unev) (reg exp) (reg env))
(goto (reg continue))
ev-application
(save continue)
(save env)
(assign unev (op operands) (reg exp))
(save unev)
(assign exp (op operator) (reg exp))
(assign continue (label ev-appl-did-operator))
(goto (label eval-dispatch))
ev-appl-did-operator
(restore unev)
(restore env)
(assign argl (op empty-arglist))
(assign proc (reg val))
(test (op no-operands?) (reg unev))
(branch (label apply-dispatch))
(save proc)
ev-appl-operand-loop
(save argl)
(assign exp (op first-operand) (reg unev))
(test (op last-operand?) (reg unev))
(branch (label ev-appl-last-arg))
(save env)
(save unev)
(assign continue (label ev-appl-accumulate-arg))
(goto (label eval-dispatch))
ev-appl-accumulate-arg
(restore unev)
(restore env)
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(assign unev (op rest-operands) (reg unev))
(goto (label ev-appl-operand-loop))
ev-appl-last-arg
(assign continue (label ev-appl-accum-last-arg))
(goto (label eval-dispatch))
ev-appl-accum-last-arg
(restore argl)
(assign argl (op adjoin-arg) (reg val) (reg argl))
(restore proc)
(goto (label apply-dispatch))
apply-dispatch
(test (op primitive-procedure?) (reg proc))
(branch (label primitive-apply))
(test (op compound-procedure?) (reg proc))
(branch (label compound-apply))
(goto (label unknown-procedure-type))
primitive-apply
(assign val (op apply-primitive-procedure-safe)
(reg proc)
(reg argl))
;(perform (op user-print) (reg val))
;(perform (op newline))
(test (op apply-primitive-error?) (reg val))
(branch (label apply-primitive-error))
(assign val (op apply-primitive-result) (reg val))
(restore continue)
(goto (reg continue))
compound-apply
(assign unev (op procedure-parameters) (reg proc))
(assign env (op procedure-environment) (reg proc))
(assign env (op extend-environment)
(reg unev) (reg argl) (reg env))
(assign unev (op procedure-body) (reg proc))
(goto (label ev-sequence))
ev-cond
(save continue)
(assign unev (op cond-clauses) (reg exp)) ; unev contains all clauses
ev-cond-loop
(assign exp (op cond-first-clause) (reg unev)) ; exp contains first clause
(test (op cond-else-clause?) (reg exp)) ; test for else-clause
(branch (label ev-cond-done))
(assign continue (label ev-cond-decide))
(save unev)
(assign exp (op cond-predicate) (reg exp)) ; exp contains first predicate
(goto (label eval-dispatch)) ; eval predicate
ev-cond-decide
(restore unev)
(test (op true?) (reg val)) ; test if predicate is true
(branch (label ev-cond-done))
(assign unev (op cond-clauses) (reg unev)) ; unev contains remainging clauses
(goto (label ev-cond-loop))
ev-cond-done
(restore continue)
(assign exp (op cond-first-clause) (reg unev)) ; exp contains true clause
(goto (label ev-begin))
ev-let
(assign exp (op let->combination) (reg exp))
(goto (label eval-dispatch))
ev-begin
(assign unev (op begin-actions) (reg exp))
(save continue)
(goto (label ev-sequence))
ev-sequence
(assign exp (op first-exp) (reg unev))
(test (op last-exp?) (reg unev))
(branch (label ev-sequence-last-exp))
(save unev)
(save env)
(assign continue (label ev-sequence-continue))
(goto (label eval-dispatch))
ev-sequence-continue
(restore env)
(restore unev)
(assign unev (op rest-exps) (reg unev))
(goto (label ev-sequence))
ev-sequence-last-exp
(restore continue)
(goto (label eval-dispatch))
ev-if
(save exp)
(save env)
(save continue)
(assign continue (label ev-if-decide))
(assign exp (op if-predicate) (reg exp))
(goto (label eval-dispatch))
ev-if-decide
(restore continue)
(restore env)
(restore exp)
(test (op true?) (reg val))
(branch (label ev-if-consequent))
ev-if-alternative
(assign exp (op if-alternative) (reg exp))
(goto (label eval-dispatch))
ev-if-consequent
(assign exp (op if-consequent) (reg exp))
(goto (label eval-dispatch))
ev-assignment
(assign unev (op assignment-variable) (reg exp))
(save unev)
(assign exp (op assignment-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-assignment-1))
(goto (label eval-dispatch))
ev-assignment-1
(restore continue)
(restore env)
(restore unev)
(perform
(op set-variable-value!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
ev-definition
(assign unev (op definition-variable) (reg exp))
(save unev)
(assign exp (op definition-value) (reg exp))
(save env)
(save continue)
(assign continue (label ev-definition-1))
(goto (label eval-dispatch))
ev-definition-1
(restore continue)
(restore env)
(restore unev)
(perform
(op define-variable!) (reg unev) (reg val) (reg env))
(assign val (const ok))
(goto (reg continue))
ev-done
;(perform (op print-stack-statistics))
)))
'(EXPLICIT CONTROL EVALUATOR LOADED)

315
shared/sicp-evaluator.scm Normal file
View File

@@ -0,0 +1,315 @@
(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((unless? exp) (eval (unless->combination exp) env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp) (eval (cond->if exp) env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- EVAL" exp))))
(define apply-in-underlying-scheme apply)
(define (apply procedure arguments)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
((compound-procedure? procedure)
(eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure))))
(else
(error
"Unknown procedure type -- APPLY" procedure))))
(define (list-of-values exps env)
(if (no-operands? exps)
'()
(cons (eval (first-operand exps) env)
(list-of-values (rest-operands exps) env))))
(define (eval-if exp env)
(if (true? (eval (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
(define (eval-sequence exps env)
(cond ((last-exp? exps) (eval (first-exp exps) env))
(else (eval (first-exp exps) env)
(eval-sequence (rest-exps exps) env))))
(define (eval-assignment exp env)
(set-variable-value! (assignment-variable exp)
(eval (assignment-value exp) env)
env)
'ok)
(define (eval-definition exp env)
(define-variable! (definition-variable exp)
(eval (definition-value exp) env)
env)
'ok)
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
((eq? exp #t) true)
((eq? exp #f) true)
(else false)))
(define (variable? exp) (symbol? exp))
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
(define (assignment? exp)
(tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (definition? exp)
(tagged-list? exp 'define))
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp) ; formal parameters
(cddr exp)))) ; body
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (unless? exp) (tagged-list? exp 'unless))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)
'false))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false ; no else clause
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "ELSE clause isn't last -- COND->IF"
clauses))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))))))
(define (true? x)
(not (eq? x false)))
(define (false? x)
(eq? x false))
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p)
(tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())
(define (make-frame variables values)
(cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))
(define (extend-environment vars vals base-env)
(if (= (length vars) (length vals))
(cons (make-frame vars vals) base-env)
(if (< (length vars) (length vals))
(error "Too many arguments supplied" vars vals)
(error "Too few arguments supplied" vars vals))))
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(car vals))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable -- SET!" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
(define (define-variable! var val env)
(let ((frame (first-frame env)))
(define (scan vars vals)
(cond ((null? vars)
(add-binding-to-frame! var val frame))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(scan (frame-variables frame)
(frame-values frame))))
(define (primitive-procedure-objects)
(map (lambda (proc) (list 'primitive (cadr proc)))
primitive-procedures))
(define primitive-procedures
(list (list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'null? null?)
(list 'display display)
(list 'equal? equal?)
(list 'newline newline)
(list '= =)
(list '+ +)
(list '* *)
(list '/ /)
(list '- -)
(list '< <)
;;<more primitives>
))
(define (primitive-procedure-names)
(map car
primitive-procedures))
(define (setup-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(define-variable! 'true true initial-env)
(define-variable! 'false false initial-env)
initial-env))
(define the-global-environment (setup-environment))
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme
(primitive-implementation proc) args))
(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((input (read)))
(let ((output (eval input the-global-environment)))
(announce-output output-prompt)
(user-print output)))
(driver-loop))
(define (prompt-for-input string)
(newline) (newline) (display string) (newline))
(define (announce-output string)
(newline) (display string) (newline))
(define (user-print object)
(if (compound-procedure? object)
(display (list 'compound-procedure
(procedure-parameters object)
(procedure-body object)
'<procedure-env>))
(display object)))
(define (eval-force exp env)
(let ((output (actual-value exp env)))
output))
(define the-global-environment (setup-environment))
;(driver-loop)

92
shared/sicp-leval.scm Normal file
View File

@@ -0,0 +1,92 @@
;;;;LAZY EVALUATOR FROM SECTION 4.2 OF
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
;;;;Matches code in ch4.scm
;;;; Also includes enlarged primitive-procedures list
;;;;This file can be loaded into Scheme as a whole.
;;;;**NOTE**This file loads the metacircular evaluator of
;;;; sections 4.1.1-4.1.4, since it uses the expression representation,
;;;; environment representation, etc.
;;;; You may need to change the (load ...) expression to work in your
;;;; version of Scheme.
;;;;**WARNING: Don't load mceval twice (or you'll lose the primitives
;;;; interface, due to renamings of apply).
;;;;Then you can initialize and start the evaluator by evaluating
;;;; the two lines at the end of the file ch4-mceval.scm
;;;; (setting up the global environment and starting the driver loop).
;;;; To run without memoization, reload the first version of force-it below
;;**implementation-dependent loading of evaluator file
;;Note: It is loaded first so that the section 4.2 definition
;; of eval overrides the definition from 4.1.1
;;;SECTION 4.2.2
;;; Modifying the evaluator
(define (actual-value exp env)
(force-it (eval exp env)))
(define (list-of-arg-values exps env)
(if (no-operands? exps)
'()
(cons (actual-value (first-operand exps) env)
(list-of-arg-values (rest-operands exps)
env))))
(define (list-of-delayed-args exps env)
(if (no-operands? exps)
'()
(cons (delay-it (first-operand exps) env)
(list-of-delayed-args (rest-operands exps)
env))))
(define (eval-if exp env)
(if (true? (actual-value (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
(define (force-it obj)
(if (thunk? obj)
(actual-value (thunk-exp obj) (thunk-env obj))
obj))
;; thunks
(define (delay-it exp env)
(list 'thunk exp env))
(define (thunk? obj)
(and (pair? obj)
(= (length obj) 3)
(tagged-list? obj 'thunk)))
(define (thunk-exp thunk) (cadr thunk))
(define (thunk-env thunk) (caddr thunk))
;; "thunk" that has been forced and is storing its (memoized) value
(define (evaluated-thunk? obj)
(tagged-list? obj 'evaluated-thunk))
(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))
;; memoizing version of force-it
(define (force-it obj)
(cond ((thunk? obj)
(let ((result (actual-value
(thunk-exp obj)
(thunk-env obj))))
(set-car! obj 'evaluated-thunk)
(set-car! (cdr obj) result) ; replace exp with its value
(set-cdr! (cdr obj) '()) ; forget unneeded env
result))
((evaluated-thunk? obj)
(thunk-value obj))
(else obj)))
'LAZY-EVALUATOR-LOADED

713
shared/sicp-query.scm Normal file
View File

@@ -0,0 +1,713 @@
;;;;QUERY SYSTEM FROM SECTION 4.4.4 OF
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
;;;;Matches code in ch4.scm
;;;;Includes:
;;;; -- supporting code from 4.1, chapter 3, and instructor's manual
;;;; -- data base from Section 4.4.1 -- see microshaft-data-base below
;;;;This file can be loaded into Scheme as a whole.
;;;;In order to run the query system, the Scheme must support streams.
;;;;NB. PUT's are commented out and no top-level table is set up.
;;;;Instead use initialize-data-base (from manual), supplied in this file.
;;;SECTION 4.4.4.1
;;;The Driver Loop and Instantiation
(define input-prompt ";;; Query input:")
(define output-prompt ";;; Query results:")
(define (query-driver-loop)
(prompt-for-input input-prompt)
(let ((q (query-syntax-process (read))))
(cond ((assertion-to-be-added? q)
(add-rule-or-assertion! (add-assertion-body q))
(newline)
(display "Assertion added to data base.")
(query-driver-loop))
(else
(newline)
(display output-prompt)
;; [extra newline at end] (announce-output output-prompt)
(display-stream
(stream-map
(lambda (frame)
(instantiate q
frame
(lambda (v f)
(contract-question-mark v))))
(qeval q (singleton-stream '()))))
(query-driver-loop)))))
(define (instantiate exp frame unbound-var-handler)
(define (copy exp)
(cond ((var? exp)
(let ((binding (binding-in-frame exp frame)))
(if binding
(copy (binding-value binding))
(unbound-var-handler exp frame))))
((pair? exp)
(cons (copy (car exp)) (copy (cdr exp))))
(else exp)))
(copy exp))
;;;SECTION 4.4.4.2
;;;The Evaluator
(define (qeval query frame-stream)
(let ((qproc (get (type query) 'qeval)))
(if qproc
(qproc (contents query) frame-stream)
(simple-query query frame-stream))))
;;;Simple queries
(define (simple-query query-pattern frame-stream)
;; (display "SIMPLE-QUERY ") (display query-pattern) (newline)
(stream-flatmap
(lambda (frame)
(stream-append-delayed
(find-assertions query-pattern frame)
(delay (apply-rules query-pattern frame))))
frame-stream))
;;;Compound queries
(define (conjoin conjuncts frame-stream)
(if (empty-conjunction? conjuncts)
frame-stream
(conjoin (rest-conjuncts conjuncts)
(qeval (first-conjunct conjuncts)
frame-stream))))
;;(put 'and 'qeval conjoin)
(define (disjoin disjuncts frame-stream)
(if (empty-disjunction? disjuncts)
the-empty-stream
(interleave-delayed
(qeval (first-disjunct disjuncts) frame-stream)
(delay (disjoin (rest-disjuncts disjuncts)
frame-stream)))))
;;(put 'or 'qeval disjoin)
;;;Filters
(define (negate operands frame-stream)
(stream-flatmap
(lambda (frame)
(if (stream-null? (qeval (negated-query operands)
(singleton-stream frame)))
(singleton-stream frame)
the-empty-stream))
frame-stream))
(define (uniquely-asserted query frame-stream)
(stream-flatmap
(lambda (frame)
(let ((matches (qeval (car query) (singleton-stream frame))))
(cond ((stream-null? matches) matches)
((stream-null? (stream-cdr matches)) matches)
(else the-empty-stream))))
frame-stream))
;;(put 'not 'qeval negate)
(define (lisp-value call frame-stream)
(stream-flatmap
(lambda (frame)
(if (execute
(instantiate
call
frame
(lambda (v f)
(error "Unknown pat var -- LISP-VALUE" v))))
(singleton-stream frame)
the-empty-stream))
frame-stream))
;;(put 'lisp-value 'qeval lisp-value)
(define (execute exp)
(apply (eval (predicate exp) user-initial-environment)
(args exp)))
(define (always-true ignore frame-stream) frame-stream)
;;(put 'always-true 'qeval always-true)
;;;SECTION 4.4.4.3
;;;Finding Assertions by Pattern Matching
(define (find-assertions pattern frame)
(stream-flatmap (lambda (datum)
(check-an-assertion datum pattern frame))
(fetch-assertions pattern frame)))
(define (check-an-assertion assertion query-pat query-frame)
(let ((match-result
(pattern-match query-pat assertion query-frame)))
(if (eq? match-result 'failed)
the-empty-stream
(singleton-stream match-result))))
(define (pattern-match pat dat frame)
(cond ((eq? frame 'failed) 'failed)
((equal? pat dat) frame)
((var? pat) (extend-if-consistent pat dat frame))
((and (pair? pat) (pair? dat))
(pattern-match (cdr pat)
(cdr dat)
(pattern-match (car pat)
(car dat)
frame)))
(else 'failed)))
(define (extend-if-consistent var dat frame)
(let ((binding (binding-in-frame var frame)))
(if binding
(pattern-match (binding-value binding) dat frame)
(extend var dat frame))))
;;;SECTION 4.4.4.4
;;;Rules and Unification
(define (apply-rules pattern frame)
(stream-flatmap (lambda (rule)
(apply-a-rule rule pattern frame))
(fetch-rules pattern frame)))
(define (apply-a-rule rule query-pattern query-frame)
(let ((clean-rule (rename-variables-in rule)))
(let ((unify-result
(unify-match query-pattern
(conclusion clean-rule)
query-frame)))
(if (eq? unify-result 'failed)
the-empty-stream
(qeval (rule-body clean-rule)
(singleton-stream unify-result))))))
(define (rename-variables-in rule)
(let ((rule-application-id (new-rule-application-id)))
(define (tree-walk exp)
(cond ((var? exp)
(make-new-variable exp rule-application-id))
((pair? exp)
(cons (tree-walk (car exp))
(tree-walk (cdr exp))))
(else exp)))
(tree-walk rule)))
(define (unify-match p1 p2 frame)
(cond ((eq? frame 'failed) 'failed)
((equal? p1 p2) frame)
((var? p1) (extend-if-possible p1 p2 frame))
((var? p2) (extend-if-possible p2 p1 frame)) ; {\em ; ***}
((and (pair? p1) (pair? p2))
(unify-match (cdr p1)
(cdr p2)
(unify-match (car p1)
(car p2)
frame)))
(else 'failed)))
(define (extend-if-possible var val frame)
(let ((binding (binding-in-frame var frame)))
(cond (binding
(unify-match
(binding-value binding) val frame))
((var? val) ; {\em ; ***}
(let ((binding (binding-in-frame val frame)))
(if binding
(unify-match
var (binding-value binding) frame)
(extend var val frame))))
((depends-on? val var frame) ; {\em ; ***}
'failed)
(else (extend var val frame)))))
(define (depends-on? exp var frame)
(define (tree-walk e)
(cond ((var? e)
(if (equal? var e)
true
(let ((b (binding-in-frame e frame)))
(if b
(tree-walk (binding-value b))
false))))
((pair? e)
(or (tree-walk (car e))
(tree-walk (cdr e))))
(else false)))
(tree-walk exp))
;;;SECTION 4.4.4.5
;;;Maintaining the Data Base
(define THE-ASSERTIONS the-empty-stream)
(define (fetch-assertions pattern frame)
(if (use-index? pattern)
(get-indexed-assertions pattern)
(get-all-assertions)))
(define (get-all-assertions) THE-ASSERTIONS)
(define (get-indexed-assertions pattern)
(get-stream (index-key-of pattern) 'assertion-stream))
(define (get-stream key1 key2)
(let ((s (get key1 key2)))
(if s s the-empty-stream)))
(define THE-RULES the-empty-stream)
(define (fetch-rules pattern frame)
(if (use-index? pattern)
(get-indexed-rules pattern)
(get-all-rules)))
(define (get-all-rules) THE-RULES)
(define (get-indexed-rules pattern)
(stream-append
(get-stream (index-key-of pattern) 'rule-stream)
(get-stream '? 'rule-stream)))
(define (add-rule-or-assertion! assertion)
(if (rule? assertion)
(add-rule! assertion)
(add-assertion! assertion)))
(define (add-assertion! assertion)
(store-assertion-in-index assertion)
(let ((old-assertions THE-ASSERTIONS))
(set! THE-ASSERTIONS
(cons-stream assertion old-assertions))
'ok))
(define (add-rule! rule)
(store-rule-in-index rule)
(let ((old-rules THE-RULES))
(set! THE-RULES (cons-stream rule old-rules))
'ok))
(define (store-assertion-in-index assertion)
(if (indexable? assertion)
(let ((key (index-key-of assertion)))
(let ((current-assertion-stream
(get-stream key 'assertion-stream)))
(put key
'assertion-stream
(cons-stream assertion
current-assertion-stream))))))
(define (store-rule-in-index rule)
(let ((pattern (conclusion rule)))
(if (indexable? pattern)
(let ((key (index-key-of pattern)))
(let ((current-rule-stream
(get-stream key 'rule-stream)))
(put key
'rule-stream
(cons-stream rule
current-rule-stream)))))))
(define (indexable? pat)
(or (constant-symbol? (car pat))
(var? (car pat))))
(define (index-key-of pat)
(let ((key (car pat)))
(if (var? key) '? key)))
(define (use-index? pat)
(constant-symbol? (car pat)))
;;;SECTION 4.4.4.6
;;;Stream operations
(define (stream-append-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(stream-append-delayed (stream-cdr s1) delayed-s2))))
(define (interleave-delayed s1 delayed-s2)
(if (stream-null? s1)
(force delayed-s2)
(cons-stream
(stream-car s1)
(interleave-delayed (force delayed-s2)
(delay (stream-cdr s1))))))
(define (stream-flatmap proc s)
(flatten-stream (stream-map proc s)))
(define (flatten-stream stream)
(if (stream-null? stream)
the-empty-stream
(interleave-delayed
(stream-car stream)
(delay (flatten-stream (stream-cdr stream))))))
(define (singleton-stream x)
(cons-stream x the-empty-stream))
;;;SECTION 4.4.4.7
;;;Query syntax procedures
(define (type exp)
(if (pair? exp)
(car exp)
(error "Unknown expression TYPE" exp)))
(define (contents exp)
(if (pair? exp)
(cdr exp)
(error "Unknown expression CONTENTS" exp)))
(define (assertion-to-be-added? exp)
(eq? (type exp) 'assert!))
(define (add-assertion-body exp)
(car (contents exp)))
(define (empty-conjunction? exps) (null? exps))
(define (first-conjunct exps) (car exps))
(define (rest-conjuncts exps) (cdr exps))
(define (empty-disjunction? exps) (null? exps))
(define (first-disjunct exps) (car exps))
(define (rest-disjuncts exps) (cdr exps))
(define (negated-query exps) (car exps))
(define (predicate exps) (car exps))
(define (args exps) (cdr exps))
(define (rule? statement)
(tagged-list? statement 'rule))
(define (conclusion rule) (cadr rule))
(define (rule-body rule)
(if (null? (cddr rule))
'(always-true)
(caddr rule)))
(define (query-syntax-process exp)
(map-over-symbols expand-question-mark exp))
(define (map-over-symbols proc exp)
(cond ((pair? exp)
(cons (map-over-symbols proc (car exp))
(map-over-symbols proc (cdr exp))))
((symbol? exp) (proc exp))
(else exp)))
(define (expand-question-mark symbol)
(let ((chars (symbol->string symbol)))
(if (string=? (substring chars 0 1) "?")
(list '?
(string->symbol
(substring chars 1 (string-length chars))))
symbol)))
(define (var? exp)
(tagged-list? exp '?))
(define (constant-symbol? exp) (symbol? exp))
(define rule-counter 0)
(define (new-rule-application-id)
(set! rule-counter (+ 1 rule-counter))
rule-counter)
(define (make-new-variable var rule-application-id)
(cons '? (cons rule-application-id (cdr var))))
(define (contract-question-mark variable)
(string->symbol
(string-append "?"
(if (number? (cadr variable))
(string-append (symbol->string (caddr variable))
"-"
(number->string (cadr variable)))
(symbol->string (cadr variable))))))
;;;SECTION 4.4.4.8
;;;Frames and bindings
(define (make-binding variable value)
(cons variable value))
(define (binding-variable binding)
(car binding))
(define (binding-value binding)
(cdr binding))
(define (binding-in-frame variable frame)
(assoc variable frame))
(define (extend variable value frame)
(cons (make-binding variable value) frame))
;;;;From Section 4.1
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
(define (prompt-for-input string)
(newline) (newline) (display string) (newline))
;;;;Stream support from Chapter 3
(define (stream-map proc s)
(if (stream-null? s)
the-empty-stream
(cons-stream (proc (stream-car s))
(stream-map proc (stream-cdr s)))))
(define (stream-for-each proc s)
(if (stream-null? s)
'done
(begin (proc (stream-car s))
(stream-for-each proc (stream-cdr s)))))
(define (display-stream s)
(stream-for-each display-line s))
(define (display-line x)
(newline)
(display x))
(define (stream-filter pred stream)
(cond ((stream-null? stream) the-empty-stream)
((pred (stream-car stream))
(cons-stream (stream-car stream)
(stream-filter pred
(stream-cdr stream))))
(else (stream-filter pred (stream-cdr stream)))))
(define (stream-append s1 s2)
(if (stream-null? s1)
s2
(cons-stream (stream-car s1)
(stream-append (stream-cdr s1) s2))))
(define (interleave s1 s2)
(if (stream-null? s1)
s2
(cons-stream (stream-car s1)
(interleave s2 (stream-cdr s1)))))
;;;;Table support from Chapter 3, Section 3.3.3 (local tables)
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
;;;; From instructor's manual
(define get '())
(define put '())
(define (initialize-data-base rules-and-assertions)
(define (deal-out r-and-a rules assertions)
(cond ((null? r-and-a)
(set! THE-ASSERTIONS (list->stream assertions))
(set! THE-RULES (list->stream rules))
'done)
(else
(let ((s (query-syntax-process (car r-and-a))))
(cond ((rule? s)
(store-rule-in-index s)
(deal-out (cdr r-and-a)
(cons s rules)
assertions))
(else
(store-assertion-in-index s)
(deal-out (cdr r-and-a)
rules
(cons s assertions))))))))
(let ((operation-table (make-table)))
(set! get (operation-table 'lookup-proc))
(set! put (operation-table 'insert-proc!)))
(put 'and 'qeval conjoin)
(put 'or 'qeval disjoin)
(put 'not 'qeval negate)
(put 'unique 'qeval uniquely-asserted)
(put 'lisp-value 'qeval lisp-value)
(put 'always-true 'qeval always-true)
(deal-out rules-and-assertions '() '()))
;; Do following to reinit the data base from microshaft-data-base
;; in Scheme (not in the query driver loop)
;; (initialize-data-base microshaft-data-base)
(define microshaft-data-base
'(
;; from section 4.4.1
(address (Bitdiddle Ben) (Slumerville (Ridge Road) 10))
(id (Bitdiddle Ben) 0)
(job (Bitdiddle Ben) (computer wizard))
(salary (Bitdiddle Ben) 60000)
(address (Hacker Alyssa P) (Cambridge (Mass Ave) 78))
(id (Hacker Alyssa P) 1)
(job (Hacker Alyssa P) (computer programmer))
(salary (Hacker Alyssa P) 40000)
(supervisor (Hacker Alyssa P) (Bitdiddle Ben))
(address (Fect Cy D) (Cambridge (Ames Street) 3))
(id (Fect Cy D) 2)
(job (Fect Cy D) (computer programmer))
(salary (Fect Cy D) 35000)
(supervisor (Fect Cy D) (Bitdiddle Ben))
(address (Tweakit Lem E) (Boston (Bay State Road) 22))
(id (Tweakit Lem E) 3)
(job (Tweakit Lem E) (computer technician))
(salary (Tweakit Lem E) 25000)
(supervisor (Tweakit Lem E) (Bitdiddle Ben))
(address (Reasoner Louis) (Slumerville (Pine Tree Road) 80))
(id (Reasoner Louis) 4)
(job (Reasoner Louis) (computer programmer trainee))
(salary (Reasoner Louis) 30000)
(supervisor (Reasoner Louis) (Hacker Alyssa P))
(supervisor (Bitdiddle Ben) (Warbucks Oliver))
(address (Warbucks Oliver) (Swellesley (Top Heap Road)))
(id (Warbucks Oliver) 5)
(job (Warbucks Oliver) (administration big wheel))
(salary (Warbucks Oliver) 150000)
(address (Scrooge Eben) (Weston (Shady Lane) 10))
(id (Scrooge Eben) 6)
(job (Scrooge Eben) (accounting chief accountant))
(salary (Scrooge Eben) 75000)
(supervisor (Scrooge Eben) (Warbucks Oliver))
(address (Cratchet Robert) (Allston (N Harvard Street) 16))
(id (Cratchet Robert) 7)
(job (Cratchet Robert) (accounting scrivener))
(salary (Cratchet Robert) 18000)
(supervisor (Cratchet Robert) (Scrooge Eben))
(address (Aull DeWitt) (Slumerville (Onion Square) 5))
(id (Aull DeWitt) 8)
(job (Aull DeWitt) (administration secretary))
(salary (Aull DeWitt) 25000)
(supervisor (Aull DeWitt) (Warbucks Oliver))
(meeting accounting (Monday 9am))
(meeting administration (Monday 10am))
(meeting computer (Wednesday 3pm))
(meeting administration (Friday 1pm))
(meeting whole-company (Wednesday 4pm))
(can-do-job (computer wizard) (computer programmer))
(can-do-job (computer wizard) (computer technician))
(can-do-job (computer programmer)
(computer programmer trainee))
(can-do-job (administration secretary)
(administration big wheel))
(rule (lives-near ?person-1 ?person-2)
(and (address ?person-1 (?town . ?rest-1))
(address ?person-2 (?town . ?rest-2))
(not (same ?person-1 ?person-2))))
(rule (same ?x ?x))
(rule (wheel ?person)
(and (supervisor ?middle-manager ?person)
(supervisor ?x ?middle-manager)))
(rule (outranked-by ?staff-person ?boss)
(or (supervisor ?staff-person ?boss)
(and (supervisor ?staff-person ?middle-manager)
(outranked-by ?middle-manager ?boss))))
; From 4.63
(son Adam Cain)
(son Cain Enoch)
(son Enoch Irad)
(son Irad Mehujael)
(son Mehujael Methushael)
(son Methushael Lamech)
(wife Lamech Ada)
(son Ada Jabal)
(son Ada Jubal)
(married Mickey Minnie)
))
;; felixm: for easier use from MIT-Scheme
(define (rule-to-be-added? exp)
(eq? (car exp) 'rule))
(define (eval-query input)
(let ((q (query-syntax-process input)))
(cond ((assertion-to-be-added? q)
(add-rule-or-assertion! (add-assertion-body q)))
((rule-to-be-added? q)
(add-rule-or-assertion! q))
(else
(display-stream
(stream-map
(lambda (frame)
(instantiate q
frame
(lambda (v f)
(contract-question-mark v))))
(qeval q (singleton-stream '()))))))))

464
shared/sicp-regsim.scm Normal file
View File

@@ -0,0 +1,464 @@
;;;;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*)
(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) 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))
(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))
(instruction-count 0)
(instruction-trace #f)
(breakpoints '())
(location (list 'none 0))
(proceed #f)
(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 (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
(update-location (instruction-text (car insts)))
(if (and (member location breakpoints)
(not proceed))
(begin
(display "stopped @ ")
(display (instruction-text (car insts)))
(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)
(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)
(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))))
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)
(begin
(set! insts (cons (make-instruction (list 'label next-inst)) insts))
(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) 'label)
(make-label pc))
((eq? (car inst) 'perform)
(make-perform inst machine labels ops pc))
((eq? (car inst) 'inc)
(make-inc inst machine labels ops pc))
(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
(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)

120
shared/sicp-syntax.scm Normal file
View File

@@ -0,0 +1,120 @@
;;;;SCHEME SYNTAX FROM SECTION 4.1.2 OF STRUCTURE AND INTERPRETATION OF
;;; COMPUTER PROGRAMS, TO SUPPORT CHAPTER 5
;;;;Loaded by compiler.scm (for use by compiler), and by eceval-support.scm
;;;; (for simulation of eceval machine operations)
(define (self-evaluating? exp)
(cond ((number? exp) true)
((string? exp) true)
(else false)))
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
(define (variable? exp) (symbol? exp))
(define (assignment? exp)
(tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (definition? exp)
(tagged-list? exp 'define))
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp)
(cddr exp))))
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)
'false))
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
;;;**following needed only to implement COND as derived expression,
;;; not needed by eceval machine in text. But used by compiler
;; from 4.1.2
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false ; no else clause
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "ELSE clause isn't last -- COND->IF"
clauses))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))))))
;; end of Cond support

132
shared/util.scm Normal file
View File

@@ -0,0 +1,132 @@
(define (assert a b)
(cond ((equal? a b) (display "[ok]"))
(else
(display "[error] ")
(display a)
(display " != ")
(display b)))
(newline))
; I have this here to avoid name-conflicts with the amb implementation in
; amb.scm.
(define (my-assert a b)
(cond ((equal? a b) (display "[ok]"))
(else
(display "[error] ")
(display a)
(display " != ")
(display b)))
(newline))
(define (gcd a b)
(if (= b 0) (abs a) (gcd b (remainder a b))))
(define (average a b) (/ (+ a b) 2.0))
(define (id n) n)
(define identity id)
(define (inc n) (+ n 1))
(define nil '())
(define (divides? a b) (= (remainder b a) 0))
(define (cube n) (* n n n))
(define (even? n) (= (remainder n 2) 0))
(define (odd? n) (= (remainder n 2) 1))
; copied prime? from 1.21
(define (find-divisor n test-divisor)
(cond ((> (square test-divisor) n) n)
((divides? test-divisor n) test-divisor)
(else (find-divisor n (+ test-divisor 1)))))
(define (smallest-divisor n)
(find-divisor n 2))
(define (prime? n) (if (= n 1) #f (= n (smallest-divisor n))))
; https://mitpress.mit.edu/sites/default/files/sicp/full-text/book/book-Z-H-15.html
(define (enumerate-interval low high)
(if (> low high)
nil
(cons low (enumerate-interval (+ low 1) high))))
; Returns #t if there is no #f in xs, otherwise returns #f.
(define (all? xs)
(cond ((null? xs) #t)
((eq? (car xs) #f) #f)
(else (all? (cdr xs)))))
(define (all-eq? xs)
(cond ((null? xs) #t)
((null? (cdr xs)) #t)
((eq? (car xs) (cadr xs)) (all-eq? (cdr xs)))
(else #f)))
(define (fold-right op initial sequence) ; same as accumulate
(if (null? sequence)
initial
(op (car sequence)
(fold-right op initial (cdr sequence)))))
; From exercise 3.5
(define (random-in-range low high)
(let ((range (- high low)))
(+ low (random range))))
(define (contains x xs)
(cond
((null? xs) #f)
((eq? x (car xs)) #t)
(else (contains x (cdr xs)))))
(define (display-line x)
(display x)
(newline))
(define (take n xs)
(if (= n 0)
'()
(cons (stream-car xs)
(take (- n 1) (stream-cdr xs)))))
(define (drop n xs)
(if (= n 0)
xs
(drop (- n 1) (stream-cdr xs))))
(define (find item stream)
(define (iter n stream)
(if (equal? (stream-car stream) item)
n
(iter (+ n 1) (stream-cdr stream))))
(iter 0 stream))
(define (display-stream s)
(stream-for-each display-line s))
(define (show x)
(display-line x)
x)
(define (stream-ref s n)
(if (= n 0)
(stream-car s)
(stream-ref (stream-cdr s) (- n 1))))
(define (partial-sums xs)
(cons-stream (stream-car xs)
(add-streams (partial-sums xs)
(stream-cdr xs))))
(define (scale-stream stream factor)
(stream-map (lambda (x) (* x factor)) stream))
(define (add-streams s1 s2)
(stream-map + s1 s2))
(define (list->stream xs)
(if (null? xs)
'()
(cons-stream (car xs) (list->stream (cdr xs)))))
(define ones (cons-stream 1 ones))
(define integers (cons-stream 1 (add-streams ones integers)))
'util-loaded