├── .gitattributes ├── .gitignore ├── README.org ├── evaluator ├── amb-evaluator.scm ├── base-evaluator.scm ├── eval-driver.scm ├── evaluator-analyzer.scm ├── lazy-evaluator.scm └── query-evaluator.scm ├── machine ├── gui.scm ├── register.scm └── regmach.scm ├── picture.rkt ├── sicp1.scm ├── sicp2.rkt ├── sicp3.scm ├── sicp4.scm ├── sicp5.scm ├── test ├── evaluator.scm └── machine.scm └── vendor ├── cons12cons34.png ├── cons_123.png ├── cons_with_cycle.png ├── gui.jpg └── microshaft.scm /.gitattributes: -------------------------------------------------------------------------------- 1 | *.scm linguist-language=Racket 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.log 2 | *.go 3 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * Structure and Interpretation of Computer Programs 2 | /Structure and Interpretation of Computer Programs/ (SICP) is a computing 3 | textbook by [[http://groups.csail.mit.edu/mac/projects/mac/][Hal Abelson]] & [[http://groups.csail.mit.edu/mac/users/gjs/][Gerald Sussman]], published by MIT in two editions 4 | (1985, 1995) and noted for it's ambitious approach to instruction in the logic 5 | of computer programming. 6 | 7 | This repository includes answers to a bit more than 90% of the book's 360-some 8 | exercises as well as material intended to help others get an idea of how to 9 | begin with the book, avoid many common pitfalls as they continue, and review 10 | interesting secondary material along the way. 11 | 12 | ** Why? 13 | It's likely that you've ended up on this page precisely because you don't 14 | need much persuading on the merits of the book, but I've included some famous 15 | comments on the book from internet authority figures to help seal the case: 16 | 17 | #+BEGIN_QUOTE 18 | ... I bought my first copy 15 years ago, and I still don't feel I have 19 | learned everything the book has to teach. I have learned enough to write a 20 | couple books on Lisp that (currently) have four to five stars. Yet SICP, 21 | which is pretty much the bible of our world, has only three? How can this be? 22 | Reading the reviews made it clear what happened. An optimistic professor 23 | somewhere has been feeding SICP to undergrads who are not ready for it. But 24 | it is encouraging to see how many thoughtful people have come forward to 25 | defend the book. Let's see if we can put this in terms that the undergrads 26 | will understand -- a problem set: 27 | 28 | 1. Kenneth Clark said that if a lot of smart people have liked something that 29 | you don't, you should try and figure out what they saw in it. List 10 qualities 30 | that SICP's defenders have claimed for it. 31 | 2. How is the intention of SICP different from that of Knuth? Kernighan & Ritchie? 32 | An algorithms textbook? 33 | 3. Does any other book fulfill this purpose better? 34 | 4. What other programming books first published in the mid 1980s are still 35 | relevant today? 36 | 5. Could the concepts in this book have been presented any better in a language 37 | other than Scheme? 38 | 6. Who is al? Why is his name in lowercase? 39 | 40 | -- Paul Graham 41 | #+END_QUOTE 42 | 43 | The work isn't just admired in industry, one of the most famous computer 44 | scientists gave it high marks as well: 45 | 46 | #+BEGIN_QUOTE 47 | Those who hate SICP think it doesn't deliver enough tips and tricks for the 48 | amount of time it takes to read. But if you're like me, you're not looking 49 | for one more trick, rather you're looking for a way of synthesizing what you 50 | already know, and building a rich framework onto which you can add new 51 | learning over a career. That's what SICP has done for me. I read a draft 52 | version of the book around 1982, when I was in grad school, and it changed 53 | the way I think about my profession. If you're a thoughtful computer 54 | scientist (or want to be one), it will change your life too. 55 | 56 | -- Peter Norvig 57 | #+END_QUOTE 58 | 59 | A tour of some of the most interesting concepts of computing, foundations of 60 | the tools we use every day, a way to begin "/building a rich framework for 61 | which you can add new learning over a career/", a book for which "/none 62 | others fulfill it's purpose better/", and a genuinely good time too. It's 63 | free too! 64 | 65 | You won't get much out of the book if you just read it cover-to-cover 66 | however. SICP makes it your responsibility to learn what the book has to 67 | teach by doing the exercises - the true "soul" of the book. 68 | 69 | ** How To Do It 70 | **** Getting It 71 | 72 | This guide expects you to read from the 2nd (1995) edition, which while [[https://mitpress.mit.edu/sicp/][available online]], I'd recommend you /either/ strip down to a 73 | minimal-distraction version in texinfo *or* gear up to the fully-featured 74 | experience on the web. 75 | 76 | - [[http://sarabander.github.io/sicp/html/4_002e4.xhtml#g_t4_002e4][Sara Bander's Fully-Featured SICP (Web)]] 77 | - [[http://zv.github.io/sicp-in-texinfo][SICP in Emacs / texinfo]] 78 | - [[https://mitpress.mit.edu/sicp/][Original Text from MIT]] [Not Recommended] 79 | 80 | **** Environment 81 | An important first step to having fun with SICP is to have a pain free 82 | environment and REPL. I personally couldn't imagine doing it with anything 83 | except Emacs. [[http://spacemacs.org/][If you are a vim user, you can be at home /in/ Emacs too.]] 84 | 85 | With that said, the Racket community has put together something truly 86 | astonishing with [[http://docs.racket-lang.org/drracket/interface-essentials.html?q=faq][DrRacket]]. I have used its excellent debugger over and 87 | over (when you want true enlightenment, debug chapter 2's =partial-tree=) 88 | and could imagine it as a great SICP environment, perhaps even surpassing 89 | Emacs in this regard. 90 | 91 | **** Language 92 | SICP avoids implementation-dependent behavior and, by happy coincidence, 93 | doesn't indicate the result of functions whose behavior differs between 94 | implementations. Still, SICP is intended to be done with [[https://www.gnu.org/software/mit-scheme/][MIT Scheme]]. 95 | 96 | Many readers have used other other Schemes, Lisps and languages pretending 97 | to be both quite successfully. I've seen some of the following used and 98 | have tried to approximate their fitness for the task with some features 99 | I've found useful: 100 | 101 | + SICP builds an OOP system, but a proper object system is tremendously useful throughout the book. 102 | + Function 'redefinition' is useful when tackling SICP linearly, with each exercise's answer added onto a single file of source code for each chapter. 103 | + A few subchapters of Chapter 3 require facilities for parallel computation. 104 | + Several chapters require mutable lists. Languages like Racket do /have/ mutable lists but use different method names and so will require you rewrite some code from the book. 105 | + The evaluator chapters (and others), are made much easier with the introduction of tests beyond ~assert~. 106 | 107 | | Language | Ease | Unit Tests | Native OOP | Function Redefinition | ~set!~ | Notes | 108 | |-----------+------+------------+------------+--------------+--------+-------------------------------------------------------------------------------------| 109 | | Guile | 5/5 | ✓ | ✓ | ✓ | ✓ | Fully featured Lisp used by many programs like GDB as an extension language. | 110 | | Racket | 3/5 | ✓ | ✓ | | | New SAT solvers and dynamic PL researchers have spawned from this schism of scheme. | 111 | | MITScheme | 4/5 | ? | | ✓ | ✓ | The Default SICP Choice | 112 | | LFErlang | 2/5 | ✓ | | | | An ambitious competitor to Elixir by the co-creator of Erlang | 113 | | Clojure | 1/5 | ✓ | ✓ | | | Needs no introduction | 114 | 115 | I've left out two very popular choices: [[https://common-lisp.net/][Common Lisp]] and [[https://www.call-cc.org/][Chicken Scheme]], 116 | both I've heard are servicable. 117 | 118 | ***** Using a Non-Lisp? 119 | The original SICP stresses the importance of Scheme's simple syntax. 120 | Still, because of this book's extraordinary influence, it's been 121 | "translated" to a number of non-lisp languages including: [[http://www-inst.eecs.berkeley.edu/~cs61a/sp12/][Python]], 122 | [[http://www.comp.nus.edu.sg/~cs1101s/sicp/][Javascript]] and others. 123 | 124 | If you want to do SICP in another language it's possible (if slightly 125 | unhinged) to do so. You will greatly suffer if your choice doesn't support 126 | lexical closures, first-class functions and it may be the conceit of a 127 | lisp-less SICP is plainly dangerous as you will walk away with a message 128 | subtly, perhaps insidiously, different from the one the authors tried to 129 | convey. 130 | 131 | Caveat Emptor. 132 | 133 | ***** Helpful Details 134 | SICP doesn't rely on implementation details in MIT Scheme to communicate 135 | it's points and translates well across implementations. Still, if this is 136 | your first time using Scheme, you might be able to benefit from a few 137 | modern implementation-specific details: 138 | 139 | ****** Macros 140 | In addition to being useful for reducing redundancy and writing 141 | specialized unit-testing code, macros help cement your knowledge by 142 | forcing you to go beyond the motion of the exercises. 143 | 144 | Be prepared to spend a few hours on this topic, =syntax-rules= are much 145 | more safe & sophisticated than 'replacement macro systems'. The most 146 | common use-cases will be covered in your language-of-choice's 147 | documentation; for everything else there is [[http://www.phyast.pitt.edu/~micheles/syntax-rules.pdf][Syntax Rules for the Merely 148 | Eccentric]] 149 | 150 | ****** Object System 151 | SICP will instruct you in building your own 'OOP' system and is helpful 152 | in organizing some of the more complex exercises. With that said, it's 153 | more expedient to use your own Lisp's object system (usually some 154 | descendent of Common Lisp's) as well as didactic in its own right. 155 | 156 | There's really no conflict here. The places where SICP asks you to use 157 | its own 'objects' system aren't the places you'd want to use your 158 | language's object system. Bigger exercises (particularly those in 159 | Chapter 3) are where you benefit from a 'proper' object system. You could 160 | also make your own, because while it's true that Lisp object systems can 161 | provide many features with varying degrees of adherance to the doctrine 162 | of object-orientation (whatever that implies), SICP is eased by the 163 | basics: parametricity, generic functions and/or inheritance. 164 | 165 | ****** Unit Testing With SRFI-78 166 | There's many ways to test Scheme code, I recommend the simplest thing 167 | that works: [[https://srfi.schemers.org/srfi-78/srfi-78.html][SRFI-78]]. If you haven't used it before, you can read some 168 | tests for my implementation of interpreter and compiler code in =test/=. 169 | 170 | **** Mechanics 171 | ***** Keeping your exercises under version control 172 | SICP regularly makes reference to itself at later chapters. For example, 173 | one of the Lisp interpreter exercises in Chapter 4 makes reference to 174 | 2.71 (Chapter 2). This means that having the results of your work 175 | chronicled will make your life considerably easier. 176 | 177 | Also, as you get deeper into the book, increasingly serious challenges 178 | will be posed. You'll be building a Lisp interpreter, a JIT compiler, then 179 | an "actual" compiler - these are serious software engineering projects 180 | and you'll benefit from the tools of software engineering. 181 | 182 | ***** Keeping a Diary 183 | SICP contains so much information that's easy to lose track of later on if 184 | you don't refresh your memory. A diary can also help you learn about your 185 | own learning process, serve as a reference and be personal evidence of this 186 | challenge you are about to embark on. 187 | 188 | ***** Doing both at once? 189 | A variety of schemes allow you to write comments of the form: =#| BLOCK COMMENT |#=. 190 | You can assign heading that you think are appropriate to each scheme file you include and 191 | later extract those comments using a shell script. 192 | 193 | ** Contents 194 | *** Chapter 1 195 | If you've got experience programming in any functional programming language, 196 | this chapter will be pretty straitforward for you. 197 | 198 | Even if you feel like the foundational material is old news to your, there are 199 | many numerical routines that you might be exposed to for the first time here. 200 | 201 | **** Chapter Review: 202 | 203 | - Foundational Scheme 204 | - Implementing loops with recursive functions 205 | - car/cdr/cons and other lisp list manipulation functions 206 | - Function definition and limited explanation of "scope" 207 | - Conditionals & predicates 208 | - Expressions, value and defintions 209 | - Computability and Mathematics 210 | - Newton's method 211 | - Ackermann's function 212 | - Big O / Orders of Growth 213 | - The Fibonacci function and various methods of implementing it 214 | - Order of evaluation 215 | - Monte Carlo methods for approximating PI 216 | - Speeding up numeric procedures by "doubling" the amount of work done in each step. 217 | - Recursion 218 | - Linear & tree recursion (along with other methods of accumulating return values) 219 | - Euclid's method for greatest common denominator 220 | - A change counting "machine" 221 | - Pascals's Triangle 222 | - Contrast with using function arguments or iterative solutions 223 | - High Level Functions 224 | - Define, convert and calculate fixed points of lots of common functions 225 | - Use fixed points to deal with functions as proceduers 226 | - Use `fixed-point' function to build other, such as those that find an approximation of a continued fraction. 227 | - Procedures as returned values 228 | - Explore Newton's method for approximating functions . 229 | 230 | 231 | **** Notes 232 | ***** "recursive procedures" and "recursive processes" 233 | Chapter 1 often asks you to consider two implementations of a function, a 234 | /recursive/ and an /iterative/, *both* of which invoke themselves within 235 | their own function's body. 236 | 237 | This is confusing because many programmers refer to *any* self-invoking 238 | function as simply /"recursive"/. The book tries to tackle this "common 239 | misconception" in 1.2: 240 | 241 | #+BEGIN_QUOTE 242 | In contrasting iteration and recursion, we must be careful not to confuse the notion of a recursive process with the notion of a recursive procedure. When we describe a procedure as recursive, we are referring to the syntactic fact that the procedure definition refers (either directly or indirectly) to the procedure itself. But when we describe a process as following a pattern that is, say, linearly recursive, we are speaking about how the process evolves, not about the syntax of how a procedure is written. It may seem disturbing that we refer to a recursive procedure such as fact-iter as generating an iterative process. However, the process really is iterative: Its state is captured completely by its three state variables, and an interpreter need keep track of only three variables in order to execute the process. 243 | #+END_QUOTE 244 | 245 | ***** ~trace~ builtin 246 | The [[https://www.gnu.org/software/guile/manual/html_node/Tracing-Traps.html][trace builtin]] is a tool for printing the procedure call trace from 247 | within the Guile VM and is incredibly useful. Scheme implementations 248 | elsewhere have similar builtins. 249 | 250 | ***** ↦ Symbol 251 | ↦ (pronounced “maps to”) is the mathematician’s way of writing lambda. y↦x/y 252 | means =(lambda (y) (/ x y))=, that is, the function whose value at y is x/y. 253 | 254 | *** Chapter 2 255 | This chapter is broadly concerned with the generality and principles of 256 | recursion or even more broadly with how abstract structures are built from 257 | concrete components. 258 | 259 | This is quite a broad brush and in turn the chapter doesn't stay put in one 260 | place for long. 261 | 262 | **** Chapter Review 263 | 264 | - Abstractions for arithmetic 265 | - Rationals 266 | - Interval 267 | - Representing lists & trees with =cons= cells or pointers 268 | - More advanced uses of recursion 269 | - The 8 Queens Problem 270 | - Permuting numbers 271 | - Building a picture-drawing 'language' or library 272 | - The mechanics of graphics 273 | - Encoding higher order operations on graphics into lower-order actions 274 | - Lambda calculus 275 | - Symbolic Computation 276 | - Computer algebra systems with automatic integration & differentiation 277 | - Encoding, Decoding and everything in-between for Huffman Trees. 278 | - The universality of the ~(list)~ datastructure in Lisp 279 | - Dynamic Programming and hierarchical data structures 280 | - Different ways to achieve language features like type-dispatch, message passing and inheritance 281 | 282 | This book starts to give you a few nuggets of profound realization that the book 283 | is known for. It gets even better. 284 | 285 | **** Notes 286 | 287 | ***** Why in Racket? 288 | I've done this chapter in Racket almost exclusively because of the 289 | picture-language issue I've described below. It's a neat language and I 290 | don't think it has any features shown "upfront" that let you cheat, 291 | intentionally or otherwise, on the SICP exercises. 292 | 293 | ***** Picture Language and Racket 294 | This chapter employs a "picture language" library not built inside SICP, 295 | however Racket and MITScheme come with these built-in or easily fetchable. 296 | 297 | ***** Subchapter 2.3 - /Symbolic Data/ 298 | I found the material in section 2.3, especially related to Huffman Coding, 299 | notably elegant, although it covers a wider variety of topics, each 300 | interesting in it's own right. 301 | 302 | - Symbolic Calculator by Integration & Differentiation 303 | - Variety of binary trees and set data structures 304 | - Huffman encoder/decoder 305 | 306 | You will also have the advantage of being able to implement =partial-tree= 307 | [[https://twitter.com/mxcl/status/608682016205344768?ref_src=twsrc%255Etfw][and get a job at Google]]. The method is also genuinely beautiful - a 308 | personal favorite of mine. 309 | 310 | ***** Subchapter 2.4 - /Multiple Representation of Abstract Data/ 311 | This chapter covers the well-worn tactics of abstraction. How to go beyond just 312 | equipping structures with operations, with or without 'genericity', etc. 313 | 314 | It's at once the least memorable and yet possibly the *most* important for 315 | practice of programming at large. The chapter justifies and presents 316 | simplified summaries of the implementation details of important programming 317 | language features and why they are useful. 318 | 319 | There are only 4 exercises, so you can mostly relax and focus on the 320 | content, although both /2.73/ and /2.75/ show up later, so be sure you 321 | record your answers. 322 | 323 | *** Chapter 3 324 | This chapter is the end of standard computing textbook and the beginning of 325 | SICP. If you are already a programmer, Chapter 3 presents some huge 326 | temptations to skip content, the first paragraphs of some chapters give the 327 | impression of covering what seems like already well-worn ground as a 328 | programmer - the content of the chapters differ wildly from whats "on the 329 | tin". 330 | 331 | Even if you are familiar, SICP has something of a reputation for taking the 332 | well-worn concepts and turning them inside out to expose their "true" structure [fn:2]. 333 | 334 | An important tip for chapter 3 is to *use a language with mutable lists*: 335 | I was forced to rewrite my work after the realization that Racket's ~mlists~ 336 | wouldn't cut it in a chapter /focused/ on the uses and dangers of mutable 337 | structures. 338 | 339 | Another important consideration is the parallel programming facilities of your 340 | language, the book demands a true concurrency enviroment in order for some 341 | exercises and examples to work right. 342 | **** Notes 343 | ***** Visually debugging =cons= cells 344 | It's often helpful to have a visual representation of what a particular 345 | list looks like, particularly once you start dealing with cycles. 346 | 347 | The scheme script generates [[http://www.graphviz.org/][Graphviz]] diagrams which you can use to this end. 348 | 349 | ****** Examples 350 | Here's some example S-expressions with their corresponding diagram: 351 | 352 | ******* =(1 2 3)= 353 | #+NAME: fig:(cons (cons 1 2) (cons 3 4)) 354 | #+CAPTION: (1 2 3) 355 | [[./vendor/cons_123.png]] 356 | 357 | ******* =(cons (cons 1 2) (cons 3 4))= 358 | #+NAME: fig:(cons (cons 1 2) (cons 3 4)) 359 | #+CAPTION: (cons (cons 1 2) (cons 3 4)) 360 | [[./vendor/cons12cons34.png]] 361 | 362 | ******* Cycles: 363 | #+NAME: fig: cons with cycle 364 | #+CAPTION: Cons with Cycle 365 | [[./vendor/cons_with_cycle.png]] 366 | 367 | ****** Script 368 | #+BEGIN_SRC scheme 369 | (define (list->graphviz lst) 370 | """Convert a list into a set of Graphviz instructions""" 371 | (define number 0) 372 | (define result "") 373 | (define ordinals '()) 374 | (define (result-append! str) 375 | (set! result (string-append result str))) 376 | 377 | (define* (nodename n #:optional cell) 378 | (format #f "cons~a~a" n (if cell (string-append ":" cell) ""))) 379 | 380 | (define* (build-connector from to #:optional from-cell) 381 | (format #f "\t~a -> ~a;~%" (nodename from from-cell) (nodename to))) 382 | 383 | (define (build-shape elt) 384 | (define (build-label cell) 385 | (cond ((null? cell) "∅") ; null character 386 | ((pair? cell) "•") ; bullet dot character 387 | (else (format #f "~a" cell)))) 388 | (set! number (+ number 1)) 389 | 390 | (format #f "\t~a [shape=record,label=\" ~a | ~a\"];~%" 391 | (nodename number) 392 | (build-label (car elt)) 393 | (build-label (cdr elt)))) 394 | 395 | (define* (search xs #:optional from-id from-cell) 396 | (let ((existing (assq xs ordinals))) 397 | (if (pair? existing) ;; handle lists with cycles 398 | ;; we've already built a node for this entry, just make a connector 399 | (result-append! (build-connector from-id (cdr existing) from-cell)) 400 | (begin 401 | (result-append! (build-shape xs)) 402 | (set! ordinals (assq-set! ordinals xs number)) 403 | (let ((parent-id number)) 404 | ;; make a X->Y connector 405 | (if (number? from-id) 406 | (result-append! (build-connector from-id parent-id from-cell))) 407 | ;; recurse 408 | (if (pair? (car xs)) (search (car xs) parent-id "car")) 409 | (if (pair? (cdr xs)) (search (cdr xs) parent-id "cdr"))))))) 410 | 411 | (search lst) 412 | (string-append "digraph G {\n" result "}\n")) 413 | #+END_SRC 414 | 415 | ****** Usage 416 | When =list->graphviz= is called, it returns a string representing the graphviz script, which you'll 417 | then need to feed to graphviz. 418 | 419 | If you don't have graphviz installed already, you can fetch it from [[http://www.graphviz.org/Download..php][here]] 420 | or with your favorite package manager: 421 | 422 | - OSX :: =brew install graphviz= 423 | - Redhat / Fedora :: =dnf install graphviz= 424 | - Ubuntu :: =apt-get install graphviz= 425 | 426 | Once you have Graphviz installed, make a file that does =(display 427 | (list->grapviz *elt*))=, where =*elt*= is the list you'd like to display and 428 | feed that to =dot=, like so: 429 | 430 | #+BEGIN_SRC console 431 | zv@sicp $ guile box_ptr.scm | dot -o /dev/stdout -Tpng > bot_pointer_diagram.png 432 | #+END_SRC 433 | 434 | ***** An in-place list reversal you might remember - 3.14 435 | SICP gives classic algorithm for in-place reversal of lists. It's beauty is self-evident. 436 | #+begin_src scheme 437 | (define (mystery x) 438 | (define (loop x y) 439 | (if (null? x) 440 | y 441 | (let ((temp (cdr x))) 442 | (set-cdr! x y) 443 | (loop temp x)))) 444 | (loop x '())) 445 | #+end_src 446 | 447 | ***** Constraint Solver - 3.34 448 | Section 3.34 focuses on implementing a constraint solver, which, if SICP's 449 | lead is followed rigidly, will result in a collection of functions written 450 | to mimic some of the functionality found in OOP-style objects. 451 | 452 | You can solve these exercises faster, write fewer lines and likely be 453 | /more/ satisfied with your results by using the object system provided by 454 | your language of choice (In my case, [[https://www.gnu.org/software/guile/manual/html_node/GOOPS.html][GOOPS]]). 455 | 456 | ****** Skeletons of Constraint Solver Classes 457 | The following are example base-classes for the primary classes along with their 458 | entire implementation, which allow method introduced later later in the chapter 459 | such as ~process-new-value~ and ~process-forget-value~ to share implementation 460 | details regardless of if they are operating on an ~adder~ or ~multiplier~. 461 | 462 | ******* Constraint 463 | [[https://github.com/zv/SICP-guile/blob/232a32fcc6091d4f167ea6c4458ab1e55645f11b/sicp3.scm#L823-L925][Implementation]] 464 | 465 | #+BEGIN_SRC scheme 466 | (define-class () 467 | (lhs #:getter lhs 468 | #:init-keyword #:lhs) 469 | (rhs #:getter rhs 470 | #:init-keyword #:rhs) 471 | (total #:getter total 472 | #:init-keyword #:total) 473 | (operator #:getter constraint-operator) 474 | (inverse-operator #:getter constraint-inv-operator)) 475 | #+END_SRC 476 | 477 | ****** Connector 478 | [[https://github.com/zv/SICP-guile/blob/232a32fcc6091d4f167ea6c4458ab1e55645f11b/sicp3.scm#L777-L821][Implementation]] 479 | 480 | #+BEGIN_SRC scheme 481 | (define-class () 482 | (value #:init-value #f 483 | #:accessor connector-value 484 | #:setter set-connector-value) 485 | 486 | (informant #:init-value #f 487 | #:accessor informant 488 | #:setter set-informant) 489 | 490 | (constraints #:accessor constraints 491 | #:setter set-constraints 492 | #:init-form '())) 493 | 494 | (define (make-connector) 495 | (make )) 496 | #+END_SRC 497 | 498 | ****** Probe 499 | [[https://github.com/zv/SICP-guile/blob/232a32fcc6091d4f167ea6c4458ab1e55645f11b/sicp3.scm#L918-L933][Implementation]] 500 | 501 | #+BEGIN_SRC scheme 502 | (define-class () 503 | (name #:getter name 504 | #:setter set-name 505 | #:init-keyword #:name) 506 | (connector #:getter connector 507 | #:setter set-connector 508 | #:init-keyword #:connector)) 509 | 510 | (define (probe name connector) 511 | (let ((cs (make #:name name #:connector connector))) 512 | (connect connector cs) cs)) 513 | #+END_SRC 514 | 515 | *** Chapter 4 516 | This chapter centers around the creation of a number of Scheme evaluators 517 | and is widely regarded as the most substantial chapter of SICP for 518 | experienced programmers. 519 | 520 | This is the first chapter where preparation really pays off, the reason 521 | being that the structure of this chapter is different from the others which 522 | I've decided to call the /4I loop/ 523 | 524 | 1. Introduce 525 | 2. Implement 526 | 3. Improve 527 | 4. Interchange 528 | 529 | In other words, you'll build out an interpreter, improve it and then rebuild 530 | it it from the ground up with a different strategy. You're going to have at 531 | least 3+1 different interpreters by the end of the chapter and so having 532 | tests will ensure the correctness of each. This pattern makes adopting a 533 | testing framework a very profitable use of your time. 534 | 535 | If you've chosen a language that stresses immutability (like Racket or 536 | Clojure) you'll have a fair amount of extra work ahead of you - The default 537 | evaluator uses a stack that is manipulated with the use of ~set!~. 538 | 539 | You don't have to take my word for it though: 540 | 541 | #+BEGIN_QUOTE 542 | I'm close the finishing the last major chunk of the book. Working with two 543 | colleagues for around two hours a week, it's taken us nearly a year to get this 544 | far. Of course, we did every exercise, and lost a lot of time trying to work 545 | around incompatibilities between standard Scheme and the interesting corners of 546 | DrScheme [now DrRacket - ~mcons~, I'm looking at you]. Now we use mit-scheme and 547 | I wish we had done so from the very beginning. 548 | 549 | I don't think the book is perfect. I found the structure of Chapter 4, where a 550 | Scheme interpreter is built, confusing and irritating. The exercises are 551 | interspersed with the text in a way that doesn't allow you to test any of your 552 | solutions unless you read ahead to get more infrastructure. This seems deeply 553 | unREPLy to me. Once I had typed in enough of the supporting code to actually run 554 | my proposed solutions, and pulled some hair out debugging my broken code, I had 555 | some marvellous moments of epiphany. That Ahah! is what maks [sic] the book's 556 | reputation, and what makes the effort worthwhile. But it could have been better. 557 | #+END_QUOTE 558 | 559 | **** Chapter Review 560 | - Simple Evaluator 561 | - Implement a variable-only '/stack/' without stored function pointers. 562 | - Implement Type-Dispatching Evaluator 563 | - Implement all major features of scheme used thus far 564 | - Various forms of ~let~ 565 | - ~letrec~ 566 | - ~cond~ 567 | - Predicates 568 | - etc. 569 | - Simultaneous vs. Ordered ~define~ 570 | - The Implementation of Closures 571 | - Just-in-Time Interpreter/Compiler (the 'analyzer') 572 | - Challenges of a JIT 573 | - Lazy Evaluator 574 | - Differences between lazy variables and a lazy interpreter 575 | - Relationship to the promise functions ~force~ and ~delay~ 576 | - Build a model of side-effects in lazy (or otherwise) evaluators 577 | - Implementation and use of '[[https://en.wikipedia.org/wiki/Thunk][thunks]]' 578 | - Permitting choice by adding lazy features to basic eval 579 | - "Nondeterministic" & Logic Evaluator 580 | - Apply our earlier DFS with backtracking knowledge to build logic solvers 581 | - Implement a system of closures for tracking logic unification state 582 | - Understanding rule-oriented (as opposed to procedure-oriented) computing 583 | - Simplify problems to their essential logical form (and solve them) 584 | - Implementation of 'Pattern Matching' ala Erlang 585 | - A "true" parser 586 | - Specify a grammar for natural language 587 | - ...and then writing something that emits all possible sentences 588 | - Use a random evaluator to explore choices in a truly nondeterministic fashion 589 | 590 | **** Tips 591 | ***** Functional-First Approach 592 | Some evaluator exercises occur prior to their implementation, most frequently 593 | taking the following form: 594 | 595 | 1. Talk about the motivation and abstract concepts employed by an evaluator 596 | 2. Discuss Implementation 597 | 3. Exercises asking for implementation of various features 598 | 4. Actual scheme code defining the implementation 599 | 600 | Instead of following the book linearly, I think that having a working 601 | implementation is extremely important throughout the book, so I'd recommend you 602 | include the entire evaluator prior to completing exercises related to it. [[https://mitpress.mit.edu/sicp/code/index.html][The 603 | Complete Code from SICP 2/e]] is available and can be used directly if you are 604 | using a mainline scheme distribution. 605 | 606 | ***** Testing 607 | Starting with a testing strategy is essential to preserving sanity here; I 608 | recommend using the input → result REPL 'dialogues' listed in the text to ensure 609 | that you are conforming to the features that the authors expect you to use in the 610 | coming exercises. 611 | 612 | ****** The Test Runner 613 | The default Guile test runner will output a =.log= file to your current directory 614 | instead of printing errors to =stdout=. This is an example test-runner that allows 615 | for more immediate testing. 616 | 617 | #+BEGIN_SRC scheme 618 | (use-modules (srfi srfi-64)) 619 | (define (sicp-evaluator-runner) 620 | (let* ((runner (test-runner-null)) 621 | (num-passed 0) 622 | (num-failed 0)) 623 | (test-runner-on-test-end! runner 624 | (lambda (runner) 625 | (case (test-result-kind runner) 626 | ((pass xpass) (set! num-passed (+ num-passed 1))) 627 | ((fail xfail) 628 | (begin 629 | (let 630 | ((rez (test-result-alist runner))) 631 | (format #t 632 | "~a::~a\n Expected Value: ~a | Actual Value: ~a\n Error: ~a\n Form: ~a\n" 633 | (assoc-ref rez 'source-file) 634 | (assoc-ref rez 'source-line) 635 | (assoc-ref rez 'expected-value) 636 | (assoc-ref rez 'actual-value) 637 | (assoc-ref rez 'actual-error) 638 | (assoc-ref rez 'source-form)) 639 | (set! num-failed (+ num-failed 1))))) 640 | (else #t)))) 641 | (test-runner-on-final! runner 642 | (lambda (runner) 643 | (format #t "Passed: ~d || Failed: ~d.~%" 644 | num-passed num-failed))) 645 | runner)) 646 | 647 | (test-runner-factory 648 | (lambda () (sicp-evaluator-runner))) 649 | #+END_SRC 650 | 651 | ****** ~test-eval~ Macro 652 | This simple macro allows you to directly extract the expected/result pairs from 653 | the REPL excerpts. 654 | #+BEGIN_SRC scheme 655 | ;; Standard Evaluator Tests 656 | (define-syntax test-eval 657 | (syntax-rules (=> test-environment test-equal) 658 | ((test-eval expr =>) 659 | (syntax-error "no expect statement")) 660 | ((test-eval expr => expect) 661 | (test-eqv expect (test-evaluator 'expr test-environment))) 662 | ((test-eval expr expect) 663 | (test-eqv expect (test-evaluator 'expr test-environment))))) 664 | #+END_SRC 665 | 666 | ****** Unit Tests 667 | Now just add tests! The next section of this guide will show you how to 668 | automatically run tests at sensible points as part of the ~driver-loop~. 669 | 670 | #+BEGIN_SRC scheme 671 | (test-begin "Tests") ; Begin our tests 672 | (test-begin "Evaluator") ; Begin evaluator tests 673 | (test-begin "Basic") ; The basic (4.1) evaluator 674 | (define test-environment (setup-environment)) ; Initialize the test environment 675 | (define test-evaluator eval) ; Set the evaluator you wish to use 676 | 677 | ;; You can choose to use `=>' or not 678 | (test-eval (and 1 2) => 2) 679 | 680 | (test-eval 681 | (let fib-iter ((a 1) (b 0) (count 4)) 682 | (if (= count 0) b 683 | (fib-iter (+ a b) a (- count 1)))) 684 | => 3) 685 | 686 | ;; cleanup 687 | (set! test-environment '()) 688 | 689 | (test-end "Basic") 690 | (test-end "Evaluator") 691 | (test-end "Tests") 692 | #+END_SRC 693 | 694 | ***** Code Reuse 695 | 696 | ****** Evaluator 697 | Features common to 698 | - An evaluator function driven by a switch statement 699 | - An application function that extends the frame 700 | - A driver loop that makes both accessible in the form of a REPL 701 | 702 | ******* Type-dispatch for the core evaluator switch statement 703 | [[http://sarabander.github.io/sicp/html/4_002e1.xhtml#Exercise-4_002e3][Exercise 4.3]] asks you to implement a type-dispatch scheme for the base 704 | evaluator, allowing you to incrementally introduce functionality rather than 705 | rewrite ~eval~ with each new feature. This turns out to be very useful 706 | and I wrote all my evaluators in this style. 707 | 708 | The concept is demonstrated here: 709 | 710 | #+BEGIN_SRC scheme 711 | (define-class () 712 | (method-table #:init-value (make-hash-table) 713 | #:getter method-table)) 714 | 715 | (define (table-ordinal op type) 716 | (let ((opstr (symbol->string op)) 717 | (typestr (symbol->string type))) 718 | (string-append opstr "/" typestr))) 719 | 720 | (define-method (get (dt ) op type) 721 | (if (and (symbol? op) (symbol? type)) 722 | (hash-ref (method-table dt) (table-ordinal op type)) 723 | #f)) 724 | 725 | (define-method (put (dt ) op type item) 726 | (hash-set! (method-table dt) (table-ordinal op type) item)) 727 | 728 | (define dispatch-tt (make )) 729 | 730 | (define (install-procedure p) 731 | "Install a procedure to the base evaluator" 732 | (put dispatch-tt 'eval ; instead of 'eval 733 | (car p) 734 | (cadr p)) 735 | 736 | ... 737 | 738 | (install-procedure `(and ,eval-and)) 739 | 740 | (install-procedure `(let* ,(λ (exp env) (zeval (let*->nested-lets exp) env)))) 741 | 742 | (install-procedure `(undefine ,eval-undefinition)) 743 | 744 | (install-procedure `(while ,(λ (exp env) (zeval (make-while exp) env)))) 745 | #+END_SRC 746 | 747 | ******* Driver Loops 748 | Just as you dispatched a procedure specific to an evaluator above, you can do 749 | the same with the ~driver-loop~ implementation provided to each evaluator. 750 | 751 | 1. You'll want to be able to quickly switch the evaluator invoked by ~driver-loop~ as you progress through the chapter and later chapters have a radically different loop. 752 | 2. [[http://www.nongnu.org/geiser/][Geiser]] is a very popular scheme integration module for Emacs Lisp that you will probably use. Like many IDE-integrated IDE's it doesn't deal well with a program that requests user input on =stdin=. 753 | 3. You can share more code, even between radically different implementations. 754 | 755 | My approach is simple - add an entry to a table of ~driver-loop~ implementations 756 | which are chosen at runtime. 757 | 758 | #+BEGIN_SRC scheme 759 | ;; This function is what actually gets called to invoke your evaluator's REPL 760 | (define (driver-loop evaluator) 761 | ((get dispatch-tt 'driver-loop evaluator))) 762 | 763 | (define (install-driver-loop evaluator fn) 764 | "Install a new `driver-loop' REPL" 765 | (put dispatch-tt 'driver-loop evaluator fn)) 766 | 767 | ; base evaluator implementation from 4.14 768 | (define (base-driver-loop) 769 | (prompt-for-input ";;; Base(zeval) input:") 770 | (let ((input (read))) 771 | (let ((output 772 | (zeval input 773 | the-global-environment))) 774 | (announce-output output-prompt) 775 | (user-print output))) 776 | (base-driver-loop)) 777 | 778 | ;; install the base driver loop 779 | (install-driver-loop 'eval base-driver-loop) 780 | 781 | (define inside-repl? 782 | "A method to determine if we are inside a REPL or being executed directly" 783 | (eq? #f (assq-ref (current-source-location) 'filename))) 784 | 785 | ... 786 | 787 | ;; at the end of the file, you can specify which loop you want to invoke when 788 | ;; you run. 789 | (if inside-repl? 'ready ;; we want the repl available ASAP if were inside emacs 790 | (begin 791 | ;; load our tests 792 | (load "test/evaluator.scm") 793 | ;; start the REPL 794 | (driver-loop 'amb))) 795 | ;;; EOF 796 | #+END_SRC 797 | 798 | ***** Missing Functions 799 | Many code excerpts from the text cannot be directly used in the evaluator 800 | /provided/ by the book itself. Before you initialize your evaluators environment, 801 | be sure to add the following to your ~primitive-procedures~ 802 | 803 | #+BEGIN_SRC lisp 804 | (append! primitive-procedures 805 | `((+ ,+) (- ,-) (* ,*) (/ ,/) (abs ,abs) 806 | (= ,=) (< ,<) (<= ,<=) (> ,>) (> ,>=) 807 | (not ,not) 808 | (list ,list) 809 | (member ,member) 810 | (display ,display))) 811 | #+END_SRC 812 | 813 | Additionally, ~let~ is missing from the `amb` interpreter as well. Just add the 814 | one used by the ~analyze~ evaluator. 815 | 816 | ***** 4.3 - Variations on a Scheme 817 | The `amb` evaluator presented in 4.3 is far from simple and requires patience and 818 | an eye for detail to work out whats really going on. 819 | 820 | ***** 4.4 - Query Evaluator 821 | The query evaluator may be the most difficult material yet, particularly if you 822 | aren't previously familiar with a language like Prolog. 823 | 824 | This material requires very careful reading to grasp its operation and the book 825 | frequently spends more time on its consequences over its content. 826 | 827 | If you want to grasp its implementation, you will have to read and reread 828 | chapter 4.4.4. 829 | 830 | The unification step, which the book itself describes as the most unintuitive aspect, 831 | should be read thoroughly: It's the material that actually does the process of generating 832 | deductions from premises. 833 | 834 | It's also important to remember that much of the rest of the material is devoted to various 835 | 'optimizations' and implementation details that can easily derail you. 836 | 837 | ****** Missing Stuff 838 | ******* Stack Overflows on Exercises 839 | The query evaluator presented as is cannot compute rules of the form ~(?x rule 840 | ?y)~ as many questions ask to, simply translate them to the postfix form and you 841 | will be fine. 842 | 843 | #+BEGIN_EXAMPLE 844 | (rule (?x next-to ?y in (?x ?y . ?u))) 845 | ⇩ 846 | (rule (next-to ?x ?y in (?x ?y . ?u))) 847 | #+END_EXAMPLE 848 | **** Notes 849 | ***** 4.19 850 | This is a neat exercise and I think it's interesting to try to run it in 851 | other Lisps (I actually found a bug in a development version of Guile with 852 | this exercise) 853 | 854 | Here's some useful definitions: 855 | - Sequential Rule :: Identifiers are bound and evaluated sequentially. 856 | - Simultaneous Scope Rule :: Identifiers are bound simultaneously 857 | 858 | You might also notice that translating it directly to other languages wont work. 859 | *** Chapter 5 860 | Chapter 5 begins with modeling a 'register machine', approximate to many 861 | contemporary architectures. Asking you to implement (or invent) a register 862 | machine language, complete with the control flow constructs and data 863 | structures needed. 864 | 865 | This is where the chapter is known for /'going off the deep end'/: building 866 | a scheme compiler with tail call optimization, garbage collection, lexical 867 | addressing, tracing and so on. 868 | 869 | **** ZV's Graphical Debugger & REPL 870 | I've built a REPL debugger for the Ch5 machine language. This can be used 871 | with whichever assembly variant you decide to write your exercises in, but 872 | if are familiar with x86 assembly, I think it will seem like a little slice 873 | of home. 874 | 875 | If you'd like to use it, you can find its source code in ~machine/gui.scm~. 876 | 877 | #+CAPTION: SICP Chapter 5 GUI Debugger 878 | #+NAME: guidebugger 879 | [[./vendor/gui.jpg]] 880 | 881 | 882 | ***** A better way to run register machines 883 | Here is a macro and runner function for generating a quick register machine definition as follows: 884 | #+BEGIN_SRC lisp 885 | (define-register-machine newtons 886 | #:registers (x guess) 887 | #:ops ((good-enough ,newton/good-enough?) 888 | (improve ,newton/improve)) 889 | #:assembly ((assign guess (const 1.0)) 890 | improve 891 | (test (op good-enough) (reg guess) (reg x)) 892 | (branch (label end-newton)) 893 | (assign guess (op improve) (reg guess) (reg x)) 894 | (goto (label improve)) 895 | end-newton)) 896 | #+END_SRC 897 | 898 | 899 | #+BEGIN_SRC scheme 900 | (define (machine-run mach init) 901 | "Run a machine with the registers initialized to the alist in `init' and 902 | then dumps the values of all registers" 903 | (map (λ (el) (set-register-contents! mach (car el) (cdr el))) init) 904 | (start mach) 905 | (map 906 | (λ (reg) (cons (car reg) 907 | (get-contents (get-register mach (car reg))))) 908 | (mach 'dump-registers))) 909 | 910 | (define-syntax define-register-machine 911 | (syntax-rules () 912 | ((define-register-machine var #:registers registers #:ops ops #:assembly assembly) 913 | (define var (build-rmachine 914 | #:registers 'registers 915 | #:ops `ops 916 | #:assembly 'assembly))))) 917 | #+END_SRC 918 | 919 | ** If I could do it all again... 920 | Everyone has regrets, let's hope you have fewer by reading mine. 921 | 922 | *** TODO Turns out SICP doesn't include stupid material 923 | So many books have irrelevant exercises, SICP doesnt. 924 | I sped through the end of SICP Chapter 3 - I won't do it again. 925 | *** TODO Pay more attention to Lazy evaluator 926 | *** DONE A case of the or-bores 927 | CLOSED: [2016-08-01 Mon 13:34] 928 | Implementing ~or~, ~and~ and other other connective logical statements in the 929 | =amb= evaluator would really be neat -- I just installed a primitive procedure. 930 | 931 | *** TODO Permutations and the Floor Puzzle 932 | Donald Knuth wrote a whole book (fascicle) on permutation problems and I can 933 | see why. I've come up with no less than 2 dozen ways reformulations do them 934 | over the years: including counting in base-N (where N is the number of 935 | permuted items), the traditional map-n-slap, round-robin (what is called 936 | "bell method") 937 | 938 | I always feel guilty not giving an honest effort before looking up an algorithm 939 | online and I always feel somewhat stumped on permutation problems. Sure, I know 940 | the "classic" swap algorithm, I've (obviously) implemented the method for 941 | permuting a list in Chapter 2, but something essential feels like it's getting 942 | left out. 943 | 944 | Take Exercise 4.39, which (loosely) is to solve the floor puzzle without using 945 | ~amb~ *AND* take advantage of knowledge about the puzzle to make it perform 946 | better than 'depth first'. 947 | 948 | *** Exercise 4.43 949 | I ended up looking at someone elses solution here - This one is hard to solve 950 | *without* resorting "tricks", such as applying eliminative logic beforehand to 951 | solve the problem. This mixes all sorts of different kinds of representations 952 | of data and many solutions are incorrect. 953 | *** ~parse_words~ 954 | I completed the exercises but I started to get to a really 955 | uncomfortable point, especially in Exercise 4.49 that this was some deep 956 | metaphor for parsing fully-specified grammars. 957 | 958 | ** TODO Exercises 959 | This is a list of exercises I *haven't* completed for some reason or another. 960 | *** Chapter 4 961 | - 4.32 962 | - 4.33 963 | - 4.34 964 | - 4.44 965 | - 4.47 (started to get unbelievably bored of these exercises) 966 | - 4.48 (started to get unbelievably bored of these exercises) 967 | - 4.49 (started to get unbelievably bored of these exercises) 968 | - 4.69 (This is both tricky and somewhat irrelevant) 969 | - 4.71 970 | - 4.74 971 | 972 | 973 | * Footnotes 974 | [fn:1] Including all exercises asking you to draw with pen and paper as well as those specified above. 975 | [fn:2] Ever wonder how people make calculators and webservers using ONLY 976 | type-inference without ANY instructions specified? Turns out thats actually 977 | fairly simple and you are just going to have to read the whole thing to find 978 | ou. 979 | 980 | * Special Thanks 981 | This guide would never have gotten done without the inspiration of a coworker who 982 | called himself Turtle Kitty a very long time ago. 983 | 984 | In addition to turning me onto Lisp, he was highly elite, extremely patient 985 | effortlessly cool, a damn good programmer, whom I think embodies the spirit and 986 | attitude this book is meant to convey. 987 | -------------------------------------------------------------------------------- /evaluator/amb-evaluator.scm: -------------------------------------------------------------------------------- 1 | (define (amb/analyze exp) 2 | (let ([dispatch-fn (get dispatch-tt 'amb (list-tag exp))]) 3 | (cond 4 | [(self-evaluating? exp) 5 | (amb/self-evaluating exp)] 6 | [(quoted? exp) 7 | (amb/quoted exp)] 8 | [(variable? exp) 9 | (amb/variable exp)] 10 | [(procedure? dispatch-fn) 11 | (dispatch-fn exp)] 12 | [(application? exp) 13 | (amb/application exp)] 14 | [else 15 | (error "Unknown expression type: ANALYZE" exp)]))) 16 | 17 | (define (amb/choices exp) (cdr exp)) 18 | (define (ambeval exp env succeed fail) 19 | "The top-level procedure ambeval analyzes the given expression and applies the 20 | resulting execution procedure to the given environment, together with two given 21 | continuations" 22 | ((amb/analyze exp) env succeed fail)) 23 | 24 | 25 | 26 | (define (amb/self-evaluating exp) 27 | (λ (env succeed fail) 28 | (succeed exp fail))) 29 | 30 | (define (amb/quoted exp) 31 | (let ([qval (text-of-quotation exp)]) 32 | (λ (env succeed fail) 33 | (succeed qval fail)))) 34 | 35 | (define (amb/variable exp) 36 | (λ (env succeed fail) 37 | (succeed (lookup-variable-value exp env) fail))) 38 | 39 | (define (amb/analyze-lambda exp) 40 | (let ((vars (lambda-parameters exp)) 41 | (bproc (amb/analyze-sequence 42 | (lambda-body exp)))) 43 | (λ (env succeed fail) 44 | (succeed (make-procedure vars bproc env) fail)))) 45 | 46 | (define (amb/analyze-if exp) 47 | "The execution procedure generated by amb/analyze-if invokes the predicate execution 48 | procedure predicate with a success continuation that checks whether the predicate 49 | value is true and goes on to execute either the consequent or the alternative. 50 | If the execution of predicate fails, the original failure continuation for the if 51 | expression is called." 52 | (let ((predicate (amb/analyze (if-predicate exp))) 53 | (consequent (amb/analyze (if-consequent exp))) 54 | (alternative (amb/analyze (if-alternative exp)))) 55 | (λ (env succeed fail) 56 | (predicate 57 | env 58 | ;; success: evaluate the pred `pred-value' 59 | (λ (pred-value fail2) 60 | (if (true? pred-value) 61 | (consequent env succeed fail2) 62 | (alternative env succeed fail2))) 63 | ;; failure 64 | fail)))) 65 | 66 | (define (amb/analyze-sequence exps) 67 | "Sequences are also handled in the same way as in the previous evaluator, 68 | except for the machinations in the subprocedure sequentially that are required 69 | for passing the continuations. Namely, to sequentially execute a and then b, we 70 | call a with a success continuation that calls b. " 71 | (define (sequentially a b) 72 | (lambda (env succeed fail) 73 | (a env 74 | ;; success 75 | (lambda (a-value fail2) 76 | (b env succeed fail2)) 77 | ;; failure 78 | fail))) 79 | 80 | (define (loop first-proc rest-procs) 81 | (if (null? rest-procs) 82 | first-proc 83 | (loop (sequentially first-proc (car rest-procs)) 84 | (cdr rest-procs)))) 85 | 86 | (let ((procs (map amb/analyze exps))) 87 | (if (null? procs) 88 | (error "Empty sequence: ANALYZE")) 89 | (loop (car procs) (cdr procs)))) 90 | 91 | (define (amb/analyze-definition exp) 92 | "definition-value execution procedure vproc is called with the environment, a 93 | success continuation, and the failure continuation. If the execution of vproc 94 | succeeds, obtaining a value val for the defined variable, the variable is 95 | defined and the success is propagated" 96 | (let ((var (definition-variable exp)) 97 | (vproc (amb/analyze (definition-value exp)))) 98 | (lambda (env succeed fail) 99 | (vproc env 100 | ;; success 101 | (λ (val fail2) 102 | (define-variable! var val env) 103 | (succeed 'ok fail2)) 104 | ;; failure 105 | fail)))) 106 | 107 | (define (amb/analyze-assignment exp) 108 | "The execution procedure for assignments starts out like the one for 109 | definitions. It first attempts to obtain the new value to be assigned to the 110 | variable. If this evaluation of vproc fails, the assignment fails." 111 | (let ([var (assignment-variable exp)] 112 | [vproc (amb/analyze (assignment-value exp))]) 113 | (lambda (env succeed fail) 114 | (vproc env 115 | ;; vproc's success continuation at saves the old value of the 116 | ;; variable before assigning the new value to the variable and 117 | ;; proceeding from the assignment. 118 | (λ (val fail2) ; *1* 119 | (let ([old-value (lookup-variable-value var env)]) 120 | (set-variable-value! var val env) 121 | (succeed 122 | 'ok 123 | ;; a failure restores the old value of the variable before 124 | ;; continuing the failure 125 | (λ () ; *2* 126 | (set-variable-value! var old-value env) 127 | (fail2))))) 128 | fail)))) 129 | 130 | (define (amb/application exp) 131 | (let ([fn (amb/analyze (operator exp))] 132 | [aprocs (map amb/analyze (operands exp))]) 133 | (lambda (env succeed fail) 134 | (fn env 135 | ;; success 136 | (λ (proc fail2) 137 | (get-args aprocs 138 | env 139 | (λ (args fail3) 140 | (amb/apply proc args succeed fail3)) 141 | fail2)) 142 | ;; fail 143 | fail)))) 144 | 145 | (define (get-args aprocs env succeed fail) 146 | (if (null? aprocs) (succeed '() fail) 147 | ((car aprocs) 148 | env 149 | ;; success continuation for this aproc 150 | (lambda (arg fail2) 151 | (get-args 152 | (cdr aprocs) 153 | env 154 | ;; success continuation for recursive call to get-args 155 | (lambda (args fail3) 156 | (succeed (cons arg args) 157 | fail3)) 158 | fail2)) 159 | fail))) 160 | 161 | (define (amb/apply proc args succeed fail) 162 | "The actual procedure application, which is performed by amb/apply, is 163 | accomplished in the same way as for the ordinary evaluator, except for the need 164 | to manage the continuations." 165 | (cond ((primitive-procedure? proc) 166 | (succeed (apply-primitive-procedure proc args) fail)) 167 | ((compound-procedure? proc) 168 | ((procedure-body proc) 169 | (extend-environment 170 | (procedure-parameters proc) 171 | args 172 | (procedure-environment proc)) 173 | succeed 174 | fail)) 175 | (else (error "Unknown procedure type: EXECUTE-APPLICATION" proc)))) 176 | 177 | 178 | (define (amb/analyze-amb exp) 179 | "The amb special form is the key element in the nondeterministic language. 180 | Here we see the essence of the interpretation process and the reason for keeping 181 | track of the continuations. The execution procedure for amb defines a loop 182 | try-next that cycles through the execution procedures for all the possible 183 | values of the amb expression. Each execution procedure is called with a failure 184 | continuation that will try the next one. When there are no more alternatives to 185 | try, the entire amb expression fails." 186 | (let ((cprocs (map amb/analyze (amb/choices exp)))) 187 | (lambda (env succeed fail) 188 | (define (try-next choices) 189 | (if (null? choices) 190 | (fail) 191 | ((car choices) 192 | env 193 | succeed 194 | (lambda () 195 | (try-next (cdr choices)))))) 196 | (try-next cprocs)))) 197 | 198 | (define (amb/driver-loop) 199 | (define (internal-loop try-again) 200 | (prompt-for-input ";;; Amb/Eval input:") 201 | (let ((input (read))) 202 | (if (eq? input 'nx) (try-again) 203 | (begin 204 | (newline) 205 | (display ";;; Starting a new problem ") 206 | (ambeval 207 | input 208 | the-global-environment 209 | ;; ambeval success 210 | (lambda (val next-alternative) 211 | (announce-output ";;; Amb/Eval value:") 212 | (user-print val) 213 | (internal-loop next-alternative)) 214 | ;; ambeval failure 215 | (lambda () 216 | (announce-output 217 | ";;; There are no more values of") 218 | (user-print input) 219 | (amb/driver-loop))))))) 220 | (internal-loop 221 | (lambda () 222 | (newline) 223 | (display 224 | ";;; There is no current problem") 225 | (amb/driver-loop)))) 226 | -------------------------------------------------------------------------------- /evaluator/base-evaluator.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (zeval. exp env) 3 | (cond [(self-evaluating? exp) 4 | exp] 5 | [(variable? exp) 6 | (lookup-variable-value exp env)] 7 | [(quoted? exp) 8 | (text-of-quotation exp)] 9 | [(assignment? exp) 10 | (eval-assignment exp env)] 11 | [(definition? exp) 12 | (eval-definition exp env)] 13 | [(if? exp) 14 | (eval-if exp env)] 15 | [(lambda? exp) 16 | (make-procedure 17 | (lambda-parameters exp) 18 | (lambda-body exp) 19 | env)] 20 | [(begin? exp) 21 | (eval-sequence 22 | (begin-actions exp) 23 | env)] 24 | [(cond? exp) 25 | (zeval (cond->if exp) env)] 26 | [(application? exp) 27 | (zapply (zeval (operator exp) env) 28 | (list-of-values 29 | (operands exp) 30 | env))] 31 | (else 32 | (error "Unknown expression type: EVAL" exp)))) 33 | 34 | 35 | (define (zapply procedure arguments) 36 | "Apply takes two arguments, a procedure and a list of arguments to which the 37 | procedure should be applied. Apply classifies procedures into two kinds: It 38 | calls apply-primitive-procedure to apply primitives; it applies compound 39 | procedures by sequentially evaluating the expressions that make up the body of 40 | the procedure. The environment for the evaluation of the body of a compound 41 | procedure is constructed by extending the base environment carried by the 42 | procedure to include a frame that binds the parameters of the procedure to the 43 | arguments to which the procedure is to be applied. Here is the definition of 44 | apply" 45 | (cond ((primitive-procedure? procedure) 46 | (apply-primitive-procedure 47 | procedure 48 | arguments)) 49 | ((compound-procedure? procedure) 50 | (eval-sequence 51 | (procedure-body procedure) 52 | (extend-environment 53 | (procedure-parameters procedure) 54 | arguments 55 | (procedure-environment procedure)))) 56 | (else 57 | (error "Unknown procedure 58 | type: APPLY" 59 | procedure)))) 60 | 61 | 62 | 63 | ; Procedure arguments 64 | 65 | ;; When eval processes a procedure application, it uses list-of-values to 66 | ;; produce the list of arguments to which the procedure is to be applied. 67 | ;; List-of-values takes as an argument the operands of the combination. It 68 | ;; evaluates each operand and returns a list of the corresponding values:209 69 | 70 | (define (list-of-values exps env) 71 | (if (no-operands? exps) 72 | '() 73 | (cons (zeval (first-operand exps) env) 74 | (list-of-values 75 | (rest-operands exps) 76 | env)))) 77 | 78 | 79 | ; Conditionals 80 | 81 | (define (eval-if exp env) 82 | "Eval-if evaluates the predicate part of an if expression in the given 83 | environment. If the result is true, eval-if evaluates the consequent, otherwise 84 | it evaluates the alternative:" 85 | (if (true? (zeval (if-predicate exp) env)) 86 | (zeval (if-consequent exp) env) 87 | (zeval (if-alternative exp) env))) 88 | 89 | 90 | (define (eval-sequence exps env) 91 | "Eval-sequence is used by apply to evaluate the sequence of expressions in a 92 | procedure body and by eval to evaluate the sequence of expressions in a begin 93 | expression. It takes as arguments a sequence of expressions and an environment, 94 | and evaluates the expressions in the order in which they occur. The value 95 | returned is the value of the final expression." 96 | (cond ((last-exp? exps) 97 | (zeval (first-exp exps) env)) 98 | (else 99 | (zeval (first-exp exps) env) 100 | (eval-sequence (rest-exps exps) 101 | env)))) 102 | 103 | 104 | ; Assignments and definitions 105 | 106 | 107 | (define (eval-assignment exp env) 108 | "handles assignments to variables. It calls eval to find the value to be 109 | assigned and transmits the variable and the resulting value to 110 | set-variable-value! to be installed in the designated environment." 111 | (set-variable-value! 112 | (assignment-variable exp) 113 | (zeval (assignment-value exp) env) 114 | env) 115 | 'ok) 116 | 117 | ;; Definitions of variables are handled in a similar manner. 118 | 119 | (define (eval-definition exp env) 120 | (define-variable! 121 | (definition-variable exp) 122 | (zeval (definition-value exp) env) 123 | env) 124 | 'ok) 125 | 126 | 127 | ; Syntax Specification 128 | 129 | ;; The only self-evaluating items are numbers and strings: 130 | (define (self-evaluating? exp) 131 | (cond ((number? exp) #t) 132 | ((string? exp) #t) 133 | (else #f))) 134 | 135 | ;; Variables are represented by symbols: 136 | (define (variable? exp) (symbol? exp)) 137 | 138 | ;; Quotations have the form (quote ⟨text-of-quotation⟩) 139 | (define (quoted? exp) 140 | (tagged-list? exp 'quote)) 141 | 142 | (define (text-of-quotation exp) 143 | (cadr exp)) 144 | 145 | ;; Quoted? is defined in terms of the procedure tagged-list?, which identifies lists beginning with a designated symbol: 146 | (define (tagged-list? exp tag) 147 | (if (pair? exp) 148 | (eq? (car exp) tag) 149 | #f)) 150 | 151 | (define (assignment? exp) (tagged-list? exp 'set!)) 152 | (define (assignment-variable exp) (cadr exp)) 153 | (define (assignment-value exp) (caddr exp)) 154 | (define (definition? exp) (tagged-list? exp 'define)) 155 | 156 | (define (definition-variable exp) 157 | (if (symbol? (cadr exp)) 158 | (cadr exp) 159 | (caadr exp))) 160 | 161 | (define (definition-value exp) 162 | (if (symbol? (cadr exp)) 163 | (caddr exp) 164 | (make-lambda 165 | (cdadr exp) ; formal parameters 166 | (cddr exp)))) ; body 167 | 168 | ;; Lambda expressions are lists that begin with the symbol lambda: 169 | (define (lambda? exp) 170 | (tagged-list? exp 'lambda)) 171 | (define (lambda-parameters exp) (cadr exp)) 172 | (define (lambda-body exp) (cddr exp)) 173 | 174 | ;; We also provide a constructor for lambda expressions, which is used by definition-value, above: 175 | (define (make-lambda parameters body) 176 | (cons 'lambda (cons parameters body))) 177 | 178 | ;; Conditionals begin with if and have a predicate, a consequent, and an 179 | ;; (optional) alternative. If the expression has no alternative part, we provide 180 | ;; false as the alternative.214 181 | (define (if? exp) (tagged-list? exp 'if)) 182 | (define (if-predicate exp) (cadr exp)) 183 | (define (if-consequent exp) (caddr exp)) 184 | (define (if-alternative exp) 185 | (if (not (null? (cdddr exp))) 186 | (cadddr exp) 187 | 'false)) 188 | 189 | ;; We also provide a constructor for if expressions, to be used by cond->if to 190 | ;; transform cond expressions into if expressions: 191 | (define (make-if predicate consequent alternative) 192 | (list 'if 193 | predicate 194 | consequent 195 | alternative)) 196 | 197 | ;; Begin packages a sequence of expressions into a single expression. We include 198 | ;; syntax operations on begin expressions to extract the actual sequence from the 199 | ;; begin expression, as well as selectors that return the first expression and the 200 | ;; rest of the expressions in the sequence. 201 | (define (begin? exp) 202 | (tagged-list? exp 'begin)) 203 | (define (begin-actions exp) (cdr exp)) 204 | (define (last-exp? seq) (null? (cdr seq))) 205 | (define (first-exp seq) (car seq)) 206 | (define (rest-exps seq) (cdr seq)) 207 | 208 | ;; We also include a constructor sequence->exp (for use by cond->if) that 209 | ;; transforms a sequence into a single expression, using begin if necessary: 210 | (define (sequence->exp seq) 211 | (cond ((null? seq) seq) 212 | ((last-exp? seq) (first-exp seq)) 213 | (else (make-begin seq)))) 214 | 215 | (define (make-begin seq) (cons 'begin seq)) 216 | 217 | ;; A procedure application is any compound expression that is not one of the 218 | ;; above expression types. The car of the expression is the operator, and the cdr 219 | ;; is the list of operands: 220 | (define (application? exp) (pair? exp)) 221 | (define (operator exp) (car exp)) 222 | (define (operands exp) (cdr exp)) 223 | (define (no-operands? ops) (null? ops)) 224 | (define (first-operand ops) (car ops)) 225 | (define (rest-operands ops) (cdr ops)) 226 | 227 | (define (cond? exp) 228 | (tagged-list? exp 'cond)) 229 | (define (cond-clauses exp) (cdr exp)) 230 | (define (cond-else-clause? clause) 231 | (eq? (cond-predicate clause) 'else)) 232 | (define (cond-predicate clause) 233 | (car clause)) 234 | (define (cond-actions clause) 235 | (cdr clause)) 236 | (define (cond->if exp) 237 | (expand-clauses (cond-clauses exp))) 238 | (define (expand-clauses clauses) 239 | (if (null? clauses) 240 | 'false ; no else clause 241 | (let ((first (car clauses)) 242 | (rest (cdr clauses))) 243 | (if (cond-else-clause? first) 244 | (if (null? rest) 245 | (sequence->exp 246 | (cond-actions first)) 247 | (error "ELSE clause isn't 248 | last: COND->IF" 249 | clauses)) 250 | (make-if (cond-predicate first) 251 | (sequence->exp 252 | (cond-actions first)) 253 | (expand-clauses 254 | rest)))))) 255 | 256 | 257 | 258 | ; Evaluator Data Structures 259 | (define (true? x) 260 | (not (eq? x #f))) 261 | 262 | (define (false? x) 263 | (eq? x #f)) 264 | 265 | (define (make-procedure parameters body env) 266 | (list 'procedure parameters body env)) 267 | (define (compound-procedure? p) 268 | (tagged-list? p 'procedure)) 269 | (define (procedure-parameters p) (cadr p)) 270 | (define (procedure-body p) (caddr p)) 271 | (define (procedure-environment p) (cadddr p)) 272 | 273 | (define (enclosing-environment env) (cdr env)) 274 | (define (first-frame env) (car env)) 275 | (define the-empty-environment '()) 276 | 277 | ;; Each (stack) frame of an environment is represented as a pair of lists: a list of the 278 | ;; variables bound in that frame and a list of the associated values. 279 | ;; Each frame of an environment is represented as a pair of lists: a list of the 280 | ;; variables bound in that frame and a list of the associated values. 281 | #| 282 | (define (make-frame variables values) 283 | (cons variables values)) 284 | |# 285 | (define (frame-variables frame) (car frame)) 286 | (define (frame-values frame) (cdr frame)) 287 | (define (add-binding-to-frame! var val frame) 288 | (set-car! frame (cons var (car frame))) 289 | (set-cdr! frame (cons val (cdr frame)))) 290 | 291 | (define (extend-environment vars vals base-env) 292 | "To extend an environment by a new frame that associates variables with 293 | values, we make a frame consisting of the list of variables and the list of 294 | values, and we adjoin this to the environment. We signal an error if the number 295 | of variables does not match the number of values." 296 | (if (= (length vars) (length vals)) 297 | (cons (make-frame vars vals) base-env) 298 | (if (< (length vars) (length vals)) 299 | (error "Too many arguments supplied" vars vals) 300 | (error "Too few arguments supplied" vars vals)))) 301 | 302 | (define (lookup-variable-value var env) 303 | "To look up a variable in an environment, we scan the list of variables in the 304 | first frame. If we find the desired variable, we return the corresponding 305 | element in the list of values. If we do not find the variable in the current 306 | frame, we search the enclosing environment, and so on. If we reach the empty 307 | environment, we signal an “unbound variable” error." 308 | (define (env-loop env) 309 | (define (scan vars vals) 310 | (cond ((null? vars) 311 | (env-loop 312 | (enclosing-environment env))) 313 | ((eq? var (car vars)) 314 | (car vals)) 315 | (else (scan (cdr vars) 316 | (cdr vals))))) 317 | (if (eq? env the-empty-environment) 318 | (error "Unbound variable" var) 319 | (let ((frame (first-frame env))) 320 | (scan (frame-variables frame) 321 | (frame-values frame))))) 322 | (env-loop env)) 323 | 324 | 325 | (define (set-variable-value! var val env) 326 | "To set a variable to a new value in a specified environment, we scan for the 327 | variable, just as in lookup-variable-value, and change the corresponding value 328 | when we find it." 329 | (define (env-loop env) 330 | (define (scan vars vals) 331 | (cond ((null? vars) 332 | (env-loop 333 | (enclosing-environment env))) 334 | ((eq? var (car vars)) 335 | (set-car! vals val)) 336 | (else (scan (cdr vars) 337 | (cdr vals))))) 338 | (if (eq? env the-empty-environment) 339 | (error "Unbound variable: SET!" var) 340 | (let ((frame (first-frame env))) 341 | (scan (frame-variables frame) 342 | (frame-values frame))))) 343 | (env-loop env)) 344 | 345 | 346 | (define (define-variable! var val env) 347 | "To define a variable, we search the first frame for a binding for the 348 | variable, and change the binding if it exists (just as in set-variable-value!). 349 | If no such binding exists, we adjoin one to the first frame." 350 | (let ((frame (first-frame env))) 351 | (define (scan vars vals) 352 | (cond ((null? vars) 353 | (add-binding-to-frame! 354 | var val frame)) 355 | ((eq? var (car vars)) 356 | (set-car! vals val)) 357 | (else (scan (cdr vars) 358 | (cdr vals))))) 359 | (scan (frame-variables frame) 360 | (frame-values frame)))) 361 | 362 | 363 | (define (primitive-procedure? proc) 364 | (tagged-list? proc 'primitive)) 365 | 366 | (define (primitive-implementation proc) 367 | (cadr proc)) 368 | 369 | (define primitive-procedures 370 | (list (list 'car car) 371 | (list 'cdr cdr) 372 | (list 'cons cons) 373 | (list 'null? null?))) 374 | 375 | (define (primitive-procedure-names) 376 | (map car primitive-procedures)) 377 | 378 | (define (primitive-procedure-objects) 379 | (map (lambda (proc) 380 | (list 'primitive (cadr proc))) 381 | primitive-procedures)) 382 | 383 | 384 | (define (apply-primitive-procedure proc args) 385 | "To apply a primitive procedure, we simply apply the implementation procedure 386 | to the arguments, using the underlying Lisp system" 387 | (apply 388 | (primitive-implementation proc) args)) 389 | 390 | 391 | (define (setup-environment) 392 | (let ((initial-env 393 | (extend-environment 394 | (primitive-procedure-names) 395 | (primitive-procedure-objects) 396 | the-empty-environment))) 397 | (define-variable! 'true #t initial-env) 398 | (define-variable! 'false #f initial-env) 399 | initial-env)) 400 | 401 | (define (base-driver-loop) 402 | (prompt-for-input ";;; Base(zeval) input:") 403 | (let ((input (read))) 404 | (let ((output 405 | (zeval input 406 | the-global-environment))) 407 | (announce-output output-prompt) 408 | (user-print output))) 409 | (base-driver-loop)) 410 | -------------------------------------------------------------------------------- /evaluator/eval-driver.scm: -------------------------------------------------------------------------------- 1 | ; Driver Functions 2 | 3 | ;;; For convenience in running the metacircular evaluator, we provide a driver 4 | ;;; loop that models the read-eval-print loop of the underlying Lisp system. It 5 | ;;; prints a prompt, reads an input expression, evaluates this expression in the 6 | ;;; global environment, and prints the result. We precede each printed result by an 7 | ;;; output prompt so as to distinguish the value of the expression from other output 8 | ;;; that may be printed. 9 | 10 | (define input-prompt ";;; M-Eval input:") 11 | (define output-prompt ";;; M-Eval value:") 12 | 13 | (define (user-print object) 14 | (if (compound-procedure? object) 15 | (display 16 | (list 'compound-procedure 17 | (procedure-parameters object) 18 | (procedure-body object) 19 | ')) 20 | (display object))) 21 | 22 | (define (prompt-for-input string) 23 | (newline) (newline) 24 | (display string) (newline)) 25 | 26 | (define (announce-output string) 27 | (newline) (display string) (newline)) 28 | 29 | (define (driver-loop evaluator) 30 | ((get dispatch-tt 'driver-loop evaluator))) 31 | 32 | -------------------------------------------------------------------------------- /evaluator/evaluator-analyzer.scm: -------------------------------------------------------------------------------- 1 | (define (analyze exp) 2 | "The procedure analyze takes only the expression. It performs the syntactic 3 | analysis and returns a new procedure, the execution procedure, that encapsulates 4 | the work to be done in executing the analyzed expression. The execution 5 | procedure takes an environment as its argument and completes the evaluation. 6 | This saves work because analyze will be called only once on an expression, while 7 | the execution procedure may be called many times." 8 | (cond ((self-evaluating? exp) 9 | (analyze-self-evaluating exp)) 10 | ((quoted? exp) 11 | (analyze-quoted exp)) 12 | ((variable? exp) 13 | (analyze-variable exp)) 14 | ((assignment? exp) 15 | (analyze-assignment exp)) 16 | ((definition? exp) 17 | (analyze-definition exp)) 18 | ((if? exp) 19 | (analyze-if exp)) 20 | ((lambda? exp) 21 | (analyze-lambda exp)) 22 | ((begin? exp) 23 | (analyze-sequence 24 | (begin-actions exp))) 25 | ((cond? exp) 26 | (analyze (cond->if exp))) 27 | ((application? exp) 28 | (analyze-application exp)) 29 | (else 30 | (error "Unknown expression type: ANALYZE" exp)))) 31 | 32 | (define (analyze-self-evaluating exp) 33 | "It returns an execution procedure that ignores its environment argument and 34 | just returns the expression:" 35 | (lambda (env) exp)) 36 | 37 | (define (analyze-quoted exp) 38 | "For a quoted expression, we can gain a little efficiency by extracting the 39 | text of the quotation only once, in the analysis phase, rather than in the 40 | execution phase." 41 | (let ((qval (text-of-quotation exp))) 42 | (lambda (env) qval))) 43 | 44 | (define (analyze-variable exp) 45 | "Looking up a variable value must still be done in the execution phase, since 46 | this depends upon knowing the environment." 47 | (lambda (env) 48 | (lookup-variable-value exp env))) 49 | 50 | (define (analyze-assignment exp) 51 | "analyze-assignment also must defer actually setting the variable until the 52 | execution, when the environment has been supplied. However, the fact that the 53 | assignment-value expression can be analyzed (recursively) during analysis is a 54 | major gain in efficiency, because the assignment-value expression will now be 55 | analyzed only once. The same holds true for definitions." 56 | (let ((var (assignment-variable exp)) 57 | (vproc (analyze 58 | (assignment-value exp)))) 59 | (lambda (env) 60 | (set-variable-value! 61 | var (vproc env) env) 62 | 'ok))) 63 | 64 | (define (analyze-definition exp) 65 | (let ((var (definition-variable exp)) 66 | (vproc (analyze 67 | (definition-value exp)))) 68 | (lambda (env) 69 | (define-variable! var (vproc env) env) 70 | 'ok))) 71 | 72 | (define (analyze-if exp) 73 | "For if expressions, we extract and analyze the predicate, consequent, and alternative at analysis time." 74 | (let ((pproc (analyze (if-predicate exp))) 75 | (cproc (analyze (if-consequent exp))) 76 | (aproc (analyze (if-alternative exp)))) 77 | (lambda (env) 78 | (if (true? (pproc env)) 79 | (cproc env) 80 | (aproc env))))) 81 | 82 | (define (analyze-lambda exp) 83 | "Analyzing a lambda expression also achieves a major gain in efficiency: We 84 | analyze the lambda body only once, even though procedures resulting from 85 | evaluation of the lambda may be applied many times." 86 | (let ((vars (lambda-parameters exp)) 87 | (bproc (analyze-sequence 88 | (lambda-body exp)))) 89 | (lambda (env) 90 | (make-procedure vars bproc env)))) 91 | 92 | 93 | (define (analyze-sequence exps) 94 | "Analysis of a sequence of expressions (as in a begin or the body of a lambda 95 | expression) is more involved.234 Each expression in the sequence is analyzed, 96 | yielding an execution procedure. These execution procedures are combined to 97 | produce an execution procedure that takes an environment as argument and 98 | sequentially calls each individual execution procedure with the environment as 99 | argument." 100 | (define (sequentially proc1 proc2) 101 | (lambda (env) (proc1 env) (proc2 env))) 102 | (define (loop first-proc rest-procs) 103 | (if (null? rest-procs) 104 | first-proc 105 | (loop (sequentially first-proc 106 | (car rest-procs)) 107 | (cdr rest-procs)))) 108 | (let ((procs (map analyze exps))) 109 | (if (null? procs) 110 | (error "Empty sequence: ANALYZE")) 111 | (loop (car procs) (cdr procs)))) 112 | 113 | 114 | (define (analyze-application exp) 115 | "To analyze an application, we analyze the operator and operands and construct 116 | an execution procedure that calls the operator execution procedure (to obtain 117 | the actual procedure to be applied) and the operand execution procedures (to 118 | obtain the actual arguments). We then pass these to execute-application, which 119 | is the analog of apply in 4.1.1. Execute-application differs from apply in that 120 | the procedure body for a compound procedure has already been analyzed, so there 121 | is no need to do further analysis. Instead, we just call the execution procedure 122 | for the body on the extended environment." 123 | (let ((fproc (analyze (operator exp))) 124 | (aprocs (map analyze (operands exp)))) 125 | (lambda (env) 126 | (execute-application 127 | (fproc env) 128 | (map (lambda (aproc) (aproc env)) 129 | aprocs))))) 130 | 131 | (define (execute-application proc args) 132 | (cond ((primitive-procedure? proc) 133 | (apply-primitive-procedure proc args)) 134 | ((compound-procedure? proc) 135 | ((procedure-body proc) 136 | (extend-environment 137 | (procedure-parameters proc) 138 | args 139 | (procedure-environment proc)))) 140 | (else (error "Unknown procedure type: 141 | EXECUTE-APPLICATION" 142 | proc)))) 143 | -------------------------------------------------------------------------------- /evaluator/lazy-evaluator.scm: -------------------------------------------------------------------------------- 1 | (define (leval expr env) 2 | (let ([dispatch-fn (get dispatch-tt 'leval (list-tag expr))]) 3 | (cond 4 | [(self-evaluating? expr) expr] 5 | [(variable? expr) 6 | (lookup-variable-value expr env)] 7 | [(procedure? dispatch-fn) 8 | (dispatch-fn expr env)] 9 | [(application? expr) 10 | (lapply (actual-value (operator expr) env) 11 | (operands expr) env)] 12 | [else (error "Bad Expression" expr)]))) 13 | 14 | (define (lapply procedure arguments env) 15 | (cond ((primitive-procedure? procedure) 16 | (apply-primitive-procedure 17 | procedure 18 | (list-of-arg-values arguments env))) ; changed 19 | ((compound-procedure? procedure) 20 | (leval-sequence 21 | (procedure-body procedure) 22 | (extend-environment 23 | (procedure-parameters procedure) 24 | (list-of-delayed-args arguments env) ; changed 25 | (procedure-environment procedure)))) 26 | (else (error "Unknown procedure type: APPLY" 27 | procedure)))) 28 | 29 | #| 30 | The procedures that process the arguments are just like list-of-values from 31 | 4.1.1, except that list-of-delayed-args delays the arguments instead of 32 | evaluating them, and list-of-arg-values uses actual-value instead of eval: 33 | |# 34 | 35 | (define (list-of-arg-values exps env) 36 | (if (no-operands? exps) 37 | '() 38 | (cons (actual-value 39 | (first-operand exps) 40 | env) 41 | (list-of-arg-values 42 | (rest-operands exps) 43 | env)))) 44 | 45 | (define (list-of-delayed-args exps env) 46 | (if (no-operands? exps) '() 47 | (cons (delay-it (first-operand exps) env) 48 | (list-of-delayed-args (rest-operands exps) env)))) 49 | 50 | ;; Laziness Datastfuctures 51 | (define (actual-value exp env) 52 | "Force the lazy value" 53 | (force-it (leval exp env))) 54 | 55 | (define (force-it obj) 56 | "To force the thunk, we simply extract the expression and environment from the 57 | thunk and evaluate the expression in the environment." 58 | (if (thunk? obj) 59 | (actual-value (thunk-exp obj) 60 | (thunk-env obj)) 61 | obj)) 62 | 63 | (define (delay-it exp env) 64 | (list 'thunk exp env)) 65 | (define (thunk? obj) (tagged-list? obj 'thunk)) 66 | (define (thunk-exp thunk) (cadr thunk)) 67 | (define (thunk-env thunk) (caddr thunk)) 68 | 69 | (define (evaluated-thunk? obj) 70 | (tagged-list? obj 'evaluated-thunk)) 71 | 72 | (define (thunk-value evaluated-thunk) 73 | (cadr evaluated-thunk)) 74 | 75 | (define (force-it obj) 76 | "This is just a memoizing version of `force-it'" 77 | (cond ((thunk? obj) 78 | (let ((result 79 | (actual-value 80 | (thunk-exp obj) 81 | (thunk-env obj)))) 82 | (set-car! obj 'evaluated-thunk) 83 | ;; replace exp with its value: 84 | (set-car! (cdr obj) result) 85 | ;; forget unneeded env: 86 | (set-cdr! (cdr obj) '()) 87 | result)) 88 | ((evaluated-thunk? obj) 89 | (thunk-value obj)) 90 | (else obj))) 91 | 92 | 93 | ;; Procedures 94 | 95 | (define (leval-if exp env) 96 | "The other place we must change the evaluator is in the handling of if, where 97 | we must use actual-value instead of eval to get the value of the predicate 98 | expression before testing whether it is true or false: " 99 | (if (true? (actual-value (if-predicate exp) 100 | env)) 101 | (leval (if-consequent exp) env) 102 | (leval (if-alternative exp) env))) 103 | 104 | (define (leval-assignment exp env) 105 | "handles assignments to variables. It calls eval to find the value to be 106 | assigned and transmits the variable and the resulting value to 107 | set-variable-value! to be installed in the designated environment." 108 | (set-variable-value! 109 | (assignment-variable exp) 110 | (leval (assignment-value exp) env) 111 | env) 112 | 'ok) 113 | 114 | (define (leval-definition exp env) 115 | (define-variable! 116 | (definition-variable exp) 117 | (leval (definition-value exp) env) 118 | env) 119 | 'ok) 120 | 121 | (define (leval-sequence exps env) 122 | (cond ((last-exp? exps) 123 | (leval (first-exp exps) env)) 124 | (else 125 | (leval (first-exp exps) env) 126 | (leval-sequence (rest-exps exps) 127 | env)))) 128 | 129 | ;; Install our procedures 130 | (define (install-lazy-procedure p) (put dispatch-tt 'leval (car p) (cadr p))) 131 | (map 132 | install-lazy-procedure 133 | `([quote ,(λ (expr env) (text-of-quotation expr))] 134 | [set! ,leval-assignment] 135 | [define ,leval-definition] 136 | [if ,leval-if] 137 | [lambda ,(λ (expr env) (make-procedure (lambda-parameters expr) (lambda-body expr) env))] 138 | [begin ,(λ (expr env) (leval-sequence (begin-actions expr) env))] 139 | [cond ,(λ (expr env) (leval (cond->if expr) env))])) 140 | -------------------------------------------------------------------------------- /evaluator/query-evaluator.scm: -------------------------------------------------------------------------------- 1 | (define (query-driver-loop) 2 | "If the expression is a rule or assertion to be added to the data 3 | base, then the information is added. Otherwise the expression is 4 | assumed to be a query. The driver passes this query to `qeval' 5 | together with an initial frame stream consisting of a single empty 6 | frame resulting in a stream of frames generated by satisfying the 7 | query with variable values found in the data base. These frames are 8 | used to form a new stream consisting of copies of the original query 9 | in which the variables are instantiated with values supplied by the 10 | stream of frames, and this final stream is printed at the terminal" 11 | (prompt-for-input ";;; Query input:") 12 | (let ((q (query-syntax-process (read)))) 13 | (cond 14 | ;; Add an assertion 15 | [(assertion-to-be-added? q) 16 | (add-rule-or-assertion! (add-assertion-body q)) 17 | (newline) 18 | (display 19 | "Assertion added to data base.") 20 | (query-driver-loop)] 21 | ;; Otherwise this is a query 22 | [else 23 | (format #t "\n;;; Query Results: ") 24 | (display-stream 25 | (stream-map 26 | (lambda (frame) 27 | (instantiate 28 | q 29 | frame 30 | (λ (v f) (contract-question-mark v)))) 31 | (qeval q (singleton-stream '())))) 32 | (query-driver-loop)]))) 33 | 34 | 35 | (define (assertion-to-be-added? exp) (eq? (type exp) 'assert!)) 36 | (define (add-assertion-body exp) (car (contents exp))) 37 | 38 | (define (instantiate exp frame unbound-var-handler) 39 | "To instantiate an expression, we copy it, replacing any variables 40 | in the expression by their values in a given frame. The values are 41 | themselves instantiated, since they could contain variables (for 42 | example, if `?x' in exp is bound to `?y' as the result of unification 43 | and `?y' is in turn bound to 5). The action to take if a variable 44 | cannot be instantiated is given by the unbound-var-handler callback" 45 | (define (copy exp) 46 | (cond 47 | [(var? exp) 48 | (let ([binding (binding-in-frame exp frame)]) 49 | (if binding 50 | (copy (binding-value binding)) 51 | (unbound-var-handler exp frame)))] 52 | [(pair? exp) 53 | (cons (copy (car exp)) 54 | (copy (cdr exp)))] 55 | [else exp])) 56 | (copy exp)) 57 | 58 | (define (qeval query frame-stream) 59 | "The qeval procedure, called by the query-driver-loop, is the basic 60 | evaluator of the query system. It takes as inputs a query and a stream 61 | of frames, and it returns a stream of extended frames." 62 | (let ([qproc (get dispatch-tt 'qeval (type query))]) 63 | (if qproc 64 | (qproc (contents query) frame-stream) 65 | (simple-query query frame-stream)))) 66 | 67 | ;; Type and contents, used by qeval (4.4.4.2), specify that a special form is 68 | ;; identified by the symbol in its car. They are the same as the type-tag and 69 | ;; contents procedures in 2.4.2, except for the error message. 70 | (define (type exp) (if (pair? exp) (car exp) (error "Invalid TYPE" exp))) 71 | (define (contents exp) (if (pair? exp) (cdr exp) (error "Invalid CONTENTS" exp))) 72 | (define (install-query-procedure p) (put dispatch-tt 'qeval (car p) (cadr p))) 73 | 74 | ;; Here are the syntax definitions for the and, or, not, and 75 | ;; lisp-value special forms 76 | 77 | (define (empty-conjunction? exps) (null? exps)) 78 | (define (first-conjunct exps) (car exps)) 79 | (define (rest-conjuncts exps) (cdr exps)) 80 | (define (empty-disjunction? exps) (null? exps)) 81 | (define (first-disjunct exps) (car exps)) 82 | (define (rest-disjuncts exps) (cdr exps)) 83 | (define (negated-query exps) (car exps)) 84 | (define (predicate exps) (car exps)) 85 | (define (args exps) (cdr exps)) 86 | 87 | 88 | ;; Simple Queries 89 | (define (simple-query query-pattern frame-stream) 90 | "The simple-query procedure handles simple queries. It takes as 91 | arguments a simple query (a pattern) together with a stream of frames, 92 | and it returns the stream formed by extending each frame by all 93 | data-base matches of the query." 94 | (stream-flatmap 95 | (λ (frame) 96 | (stream-append-delayed 97 | (find-assertions query-pattern frame) 98 | (delay (apply-rules query-pattern frame)))) 99 | frame-stream)) 100 | 101 | ;; Compound Queries 102 | (define (conjoin conjuncts frame-stream) 103 | "And queries are handled as illustrated in Figure 4.5 by the conjoin 104 | procedure. Conjoin takes as inputs the conjuncts and the frame stream 105 | and returns the stream of extended frames. First, conjoin processes 106 | the stream of frames to find the stream of all possible frame 107 | extensions that satisfy the first query in the conjunction. Then, 108 | using this as the new frame stream, it recursively applies conjoin to 109 | the rest of the queries." 110 | (if (empty-conjunction? conjuncts) 111 | frame-stream 112 | (conjoin (rest-conjuncts conjuncts) 113 | (qeval 114 | (first-conjunct conjuncts) 115 | frame-stream)))) 116 | 117 | (install-query-procedure `(and ,conjoin)) 118 | 119 | (define (disjoin disjuncts frame-stream) 120 | "Disjoin handles `or' queries, which are handled similarly, as shown in Figure 121 | 4.6. The output streams for the various disjuncts of the or are computed 122 | separately and merged using the interleave-delayed procedure from 4.4.4.6. (See 123 | Exercise 4.71 and Exercise 4.72.)" 124 | (if (empty-disjunction? disjuncts) 125 | stream-null 126 | (interleave-delayed 127 | (qeval (first-disjunct disjuncts) 128 | frame-stream) 129 | (delay (disjoin 130 | (rest-disjuncts disjuncts) 131 | frame-stream))))) 132 | 133 | (install-query-procedure `(or ,disjoin)) 134 | 135 | ;; Filters 136 | 137 | (define (negate operands frame-stream) 138 | "Not is handled by the method outlined in 4.4.2. We attempt to 139 | extend each frame in the input stream to satisfy the query being 140 | negated, and we include a given frame in the output stream only if it 141 | cannot be extended." 142 | (stream-flatmap 143 | (lambda (frame) 144 | (if (stream-null? 145 | (qeval (negated-query operands) 146 | (singleton-stream frame))) 147 | (singleton-stream frame) 148 | stream-null)) 149 | frame-stream)) 150 | 151 | (install-query-procedure `(not ,negate)) 152 | 153 | (define (lisp-value call frame-stream) 154 | "Lisp-value is a filter similar to not. Each frame in the stream is 155 | used to instantiate the variables in the pattern, the indicated 156 | predicate is applied, and the frames for which the predicate returns 157 | false are filtered out of the input stream. An error results if there 158 | are unbound pattern variables. " 159 | (stream-flatmap 160 | (lambda (frame) 161 | (if (execute 162 | (instantiate 163 | call 164 | frame 165 | (λ (v f) 166 | (error "Unknown pat var: LISP-VALUE" v)))) 167 | (singleton-stream frame) 168 | stream-null)) 169 | frame-stream)) 170 | 171 | (install-query-procedure `(lisp-value ,lisp-value)) 172 | 173 | (define (execute exp) 174 | "Execute applies the predicate to the arguments. However, it must 175 | not evaluate the arguments, since they are already the actual 176 | arguments, not expressions whose evaluation (in Lisp) will produce the 177 | arguments. Note that execute is implemented using eval and apply from 178 | the underlying Lisp system. " 179 | (apply (eval (predicate exp) 180 | (interaction-environment)) 181 | (args exp))) 182 | 183 | (define (always-true ignore frame-stream) 184 | "The always-true special form provides for a query that is always 185 | satisfied. It ignores its contents (normally empty) and simply passes 186 | through all the frames in the input stream" 187 | frame-stream) 188 | 189 | (install-query-procedure `(always-true ,always-true)) 190 | 191 | ;; Finding Assertions By Pattern Matching 192 | (define (find-assertions pattern frame) 193 | "Find-assertions, called by simple-query, takes as input a pattern 194 | and a frame. It returns a stream of frames, each extending the given 195 | one by a data-base match of the given pattern. 196 | 197 | This function is not strictly required, it simply eliminates vacously 198 | false statements" 199 | (stream-flatmap 200 | (λ (datum) (check-an-assertion datum pattern frame)) 201 | (fetch-assertions pattern frame))) 202 | 203 | (define (check-an-assertion assertion query-pat query-frame) 204 | "Check-an-assertion takes as arguments a pattern, a data object 205 | (assertion), and a frame and returns either a one-element stream 206 | containing the extended frame or stream-null if the match fails. 207 | " 208 | (let ([match-result 209 | (pattern-match query-pat assertion query-frame)]) 210 | (if (eq? match-result 'failed) stream-null 211 | (singleton-stream match-result)))) 212 | 213 | (define (pattern-match pat dat frame) 214 | (cond ((eq? frame 'failed) 'failed) 215 | ((equal? pat dat) frame) 216 | ((var? pat) 217 | (extend-if-consistent 218 | pat dat frame)) 219 | ((and (pair? pat) (pair? dat)) 220 | (pattern-match 221 | (cdr pat) 222 | (cdr dat) 223 | (pattern-match 224 | (car pat) (car dat) frame))) 225 | (else 'failed))) 226 | 227 | (define (extend-if-consistent var dat frame) 228 | "Extends a frame by adding a new binding, if this is consistent with 229 | the bindings already in the frame" 230 | (let ([binding (binding-in-frame var frame)]) 231 | (if binding 232 | (pattern-match 233 | (binding-value binding) dat frame) 234 | (extend var dat frame)))) 235 | 236 | (define (apply-rules pattern frame) 237 | "Apply-rules is the rule analog of `find-assertions'. It takes as 238 | input a pattern and a frame, and it forms a stream of extension frames 239 | by applying rules from the data base. `stream-flatmap' maps 240 | apply-a-rule down the stream of possibly applicable rules (selected by 241 | `fetch-rules') and combines the resulting streams of frames." 242 | (stream-flatmap 243 | (λ (rule) (apply-a-rule rule pattern frame)) 244 | (fetch-rules pattern frame))) 245 | 246 | (define (apply-a-rule rule query-pattern query-frame) 247 | "`apply-a-rule' applies rules using the method outlined in 4.4.2. It 248 | first augments its argument frame by unifying the rule conclusion with 249 | the pattern in the given frame. If this succeeds, it evaluates the 250 | rule body in this new frame. " 251 | (let* ([clean-rule 252 | (rename-variables-in rule)] ; alpha-conversion 253 | [unify-result 254 | (unify-match query-pattern 255 | (conclusion clean-rule) 256 | query-frame)]) 257 | (if (eq? unify-result 'failed) 258 | stream-null 259 | (qeval (rule-body clean-rule) 260 | (singleton-stream 261 | unify-result))))) 262 | 263 | (define (rename-variables-in rule) 264 | "We generate unique variable names by associating a unique 265 | identifier (such as a number) with each rule application and combining 266 | this identifier with the original variable names. For example, if the 267 | rule-application identifier is 7, we might change each ?x in the rule 268 | to ?x-7 and each ?y in the rule to ?y-7." 269 | (let ([rule-application-id (new-rule-application-id)]) 270 | (define (tree-walk exp) 271 | (cond [(var? exp) 272 | (make-new-variable 273 | exp 274 | rule-application-id)] 275 | [(pair? exp) 276 | (cons (tree-walk (car exp)) 277 | (tree-walk (cdr exp)))] 278 | [else exp])) 279 | (tree-walk rule))) 280 | 281 | (define (unify-match p1 p2 frame) 282 | "The unification algorithm is implemented as a procedure that takes 283 | as inputs two patterns and a frame and returns either the extended 284 | frame or the symbol failed. The unifier is like the pattern matcher 285 | except that it is symmetrical—variables are allowed on both sides of 286 | the match. Unify-match is basically the same as pattern-match, except 287 | that there is extra code to handle the case where the object on the 288 | right side of the match is a variable. " 289 | (cond 290 | [(eq? frame 'failed) 'failed] 291 | [(equal? p1 p2) frame] 292 | [(var? p1) (extend-if-possible p1 p2 frame)] 293 | [(var? p2) ; handle object on right side as variable 294 | (extend-if-possible p2 p1 frame)] 295 | [(and (pair? p1) (pair? p2)) 296 | (unify-match 297 | (cdr p1) 298 | (cdr p2) 299 | (unify-match (car p1) (car p2) frame))] 300 | [else 'failed])) 301 | 302 | (define (extend-if-possible var val frame) 303 | "In unification, as in one-sided pattern matching, we want to accept 304 | a proposed extension of the frame only if it is consistent with 305 | existing bindings. The procedure `extend-if-possible' used in 306 | unification is the same as the `extend-if-consistent' used in pattern 307 | matching except for two special checks, marked “***” in the program 308 | below. In the first case, if the variable we are trying to match is 309 | not bound, but the value we are trying to match it with is itself a 310 | (different) variable, it is necessary to check to see if the value is 311 | bound, and if so, to match its value. If both parties to the match are 312 | unbound, we may bind either to the other. 313 | 314 | The second check deals with attempts to bind a variable to a pattern 315 | that includes that variable. Such a situation can occur whenever a 316 | variable is repeated in both patterns. Consider, for example, unifying 317 | the two patterns (?x ?x) and (?y ⟨expression involving ?y⟩) in a frame 318 | where both ?x and ?y are unbound. First ?x is matched against ?y, 319 | making a binding of ?x to ?y. Next, the same ?x is matched against the 320 | given expression involving ?y. Since ?x is already bound to ?y, this 321 | results in matching ?y against the expression. If we think of the 322 | unifier as finding a set of values for the pattern variables that make 323 | the patterns the same, then these patterns imply instructions to find 324 | a ?y such that ?y is equal to the expression involving ?y. There is no 325 | general method for solving such equations, so we reject such bindings; 326 | these cases are recognized by the predicate depends-on?.284 On the 327 | other hand, we do not want to reject attempts to bind a variable to 328 | itself. For example, consider unifying (?x ?x) and (?y ?y). The second 329 | attempt to bind ?x to ?y matches ?y (the stored value of ?x) against 330 | ?y (the new value of ?x). This is taken care of by the equal? clause 331 | of unify-match." 332 | (let ((binding (binding-in-frame var frame))) 333 | (cond (binding 334 | (unify-match 335 | (binding-value binding) val frame)) 336 | ((var? val) ; *** 337 | (let ((binding 338 | (binding-in-frame 339 | val 340 | frame))) 341 | (if binding 342 | (unify-match 343 | var 344 | (binding-value binding) 345 | frame) 346 | (extend var val frame)))) 347 | ((depends-on? val var frame) ; *** 348 | 'failed) 349 | (else (extend var val frame))))) 350 | 351 | (define (depends-on? exp var frame) 352 | "Depends-on? is a predicate that tests whether an expression 353 | proposed to be the value of a pattern variable depends on the 354 | variable. This must be done relative to the current frame because the 355 | expression may contain occurrences of a variable that already has a 356 | value that depends on our test variable. The structure of depends-on? 357 | is a simple recursive tree walk in which we substitute for the values 358 | of variables whenever necessary." 359 | (define (tree-walk e) 360 | (cond ((var? e) 361 | (if (equal? var e) 362 | #t 363 | (let 364 | ((b (binding-in-frame e frame))) 365 | (if b 366 | (tree-walk 367 | (binding-value b)) 368 | #f)))) 369 | ((pair? e) 370 | (or (tree-walk (car e)) 371 | (tree-walk (cdr e)))) 372 | (else #f))) 373 | (tree-walk exp)) 374 | 375 | ;; Database Maintainence 376 | 377 | ;; One important problem in designing logic programming languages is that 378 | ;; of arranging things so that as few irrelevant data-base entries as 379 | ;; possible will be examined in checking a given pattern. In our system, 380 | ;; in addition to storing all assertions in one big stream, we store all 381 | ;; assertions whose cars are constant symbols in separate streams, in a 382 | ;; table indexed by the symbol. To fetch an assertion that may match a 383 | ;; pattern, we first check to see if the car of the pattern is a constant 384 | ;; symbol. If so, we return (to be tested using the matcher) all the 385 | ;; stored assertions that have the same car. If the pattern’s car is not 386 | ;; a constant symbol, we return all the stored assertions. Cleverer 387 | ;; methods could also take advantage of information in the frame, or try 388 | ;; also to optimize the case where the car of the pattern is not a 389 | ;; constant symbol. We avoid building our criteria for indexing (using 390 | ;; the car, handling only the case of constant symbols) into the program; 391 | ;; instead we call on predicates and selectors that embody our criteria. 392 | 393 | (define THE-ASSERTIONS stream-null) 394 | 395 | (define (fetch-assertions pattern frame) 396 | (if (use-index? pattern) 397 | (get-indexed-assertions pattern) 398 | (get-all-assertions))) 399 | 400 | (define (get-all-assertions) THE-ASSERTIONS) 401 | 402 | ;; TODO get-stream && `get' 403 | (define stream-table (make )) 404 | (define (get-indexed-assertions pattern) 405 | (get-stream (index-key-of pattern) 'assertion-stream)) 406 | 407 | (define (get-stream key1 key2) 408 | "Get-stream looks up a stream in the table and returns an empty 409 | stream if nothing is stored there." 410 | (let ((s (get stream-table key1 key2))) 411 | (if s s stream-null))) 412 | 413 | ;; Rules are stored similarly, using the car of the rule conclusion. Rule 414 | ;; conclusions are arbitrary patterns, however, so they differ from 415 | ;; assertions in that they can contain variables. A pattern whose car is 416 | ;; a constant symbol can match rules whose conclusions start with a 417 | ;; variable as well as rules whose conclusions have the same car. Thus, 418 | ;; when fetching rules that might match a pattern whose car is a constant 419 | ;; symbol we fetch all rules whose conclusions start with a variable as 420 | ;; well as those whose conclusions have the same car as the pattern. For 421 | ;; this purpose we store all rules whose conclusions start with a 422 | ;; variable in a separate stream in our table, indexed by the symbol ?. 423 | 424 | (define THE-RULES stream-null) 425 | 426 | (define (fetch-rules pattern frame) 427 | (if (use-index? pattern) 428 | (get-indexed-rules pattern) 429 | (get-all-rules))) 430 | 431 | (define (get-all-rules) THE-RULES) 432 | 433 | (define (get-indexed-rules pattern) 434 | (stream-append 435 | (get-stream (index-key-of pattern) 436 | 'rule-stream) 437 | (get-stream '? 'rule-stream))) 438 | 439 | (define (add-rule-or-assertion! assertion) 440 | "Add-rule-or-assertion! is used by query-driver-loop to add 441 | assertions and rules to the data base. Each item is stored in the 442 | index, if appropriate, and in a stream of all assertions or rules in 443 | the data base." 444 | (if (rule? assertion) 445 | (add-rule! assertion) 446 | (add-assertion! assertion))) 447 | 448 | (define (add-assertion! assertion) 449 | (store-assertion-in-index assertion) 450 | (let ((old-assertions THE-ASSERTIONS)) 451 | (set! THE-ASSERTIONS 452 | (stream-cons assertion 453 | old-assertions)) 454 | 'ok)) 455 | 456 | (define (add-rule! rule) 457 | (store-rule-in-index rule) 458 | (let ((old-rules THE-RULES)) 459 | (set! THE-RULES 460 | (stream-cons rule old-rules)) 461 | 'ok)) 462 | 463 | (define (store-assertion-in-index assertion) 464 | "To actually store an assertion or a rule, we check to see if it can 465 | be indexed. If so, we store it in the appropriate stream." 466 | (if (indexable? assertion) 467 | (let ((key (index-key-of assertion))) 468 | (let ((current-assertion-stream 469 | (get-stream 470 | key 'assertion-stream))) 471 | (put stream-table 472 | key 473 | 'assertion-stream 474 | (stream-cons 475 | assertion 476 | current-assertion-stream)))))) 477 | 478 | (define (store-rule-in-index rule) 479 | (let ((pattern (conclusion rule))) 480 | (if (indexable? pattern) 481 | (let ((key (index-key-of pattern))) 482 | (let ((current-rule-stream 483 | (get-stream 484 | key 'rule-stream))) 485 | (put stream-table 486 | key 487 | 'rule-stream 488 | (stream-cons 489 | rule 490 | current-rule-stream))))))) 491 | 492 | (define (indexable? pat) 493 | "The following procedures define how the data-base index is used. A 494 | pattern (an assertion or a rule conclusion) will be stored in the 495 | table if it starts with a variable or a constant symbol." 496 | (or (constant-symbol? (car pat)) 497 | (var? (car pat)))) 498 | 499 | 500 | (define (index-key-of pat) 501 | "The key under which a pattern is stored in the table is either ? 502 | (if it starts with a variable) or the constant symbol with which it 503 | starts." 504 | (let ((key (car pat))) 505 | (if (var? key) '? key))) 506 | 507 | (define (use-index? pat) 508 | "The index will be used to retrieve items that might match a pattern 509 | if the pattern starts with a constant symbol." 510 | (constant-symbol? (car pat))) 511 | 512 | ;; Stream operations 513 | ;; (use-modules (ice-9 streams)) 514 | (define (display-stream s) 515 | (stream-for-each display-line s)) 516 | 517 | (define (display-line x) 518 | (newline) 519 | (display x)) 520 | 521 | (define (interleave s1 s2) 522 | (if (stream-null? s1) 523 | s2 524 | (stream-cons (stream-car s1) 525 | (interleave s2 (stream-cdr s1))))) 526 | 527 | #| Streams: 528 | 529 | Stream-append-delayed and interleave-delayed are just like stream-append and 530 | interleave (3.5.3), except that they take a delayed argument (like the integral 531 | procedure in 3.5.4). This postpones looping in some cases 532 | |# 533 | 534 | (define (stream-append-delayed s1 delayed-s2) 535 | (if (stream-null? s1) 536 | (force delayed-s2) 537 | (stream-cons 538 | (stream-car s1) 539 | (stream-append-delayed (stream-cdr s1) delayed-s2)))) 540 | 541 | (define (interleave-delayed s1 delayed-s2) 542 | (if (stream-null? s1) 543 | (force delayed-s2) 544 | (stream-cons 545 | (stream-car s1) 546 | (interleave-delayed (force delayed-s2) 547 | (delay (stream-cdr s1)))))) 548 | 549 | (define (stream-flatmap proc s) 550 | (flatten-stream (stream-map proc s))) 551 | 552 | (define (flatten-stream stream) 553 | (if (stream-null? stream) stream-null 554 | (interleave-delayed 555 | (stream-car stream) 556 | (delay (flatten-stream (stream-cdr stream)))))) 557 | 558 | (define (singleton-stream x) 559 | "Stream-flatmap, which is used throughout the query evaluator to map a 560 | procedure over a stream of frames and combine the resulting streams of frames, 561 | is the stream analog of the flatmap procedure introduced for ordinary lists in 562 | As long as `old-assertions' is being copied (and isn't simply a new 563 | reference), this creates an infinite loop when referncing an assertion that 564 | 2.2.3. Unlike ordinary flatmap, however, we accumulate the streams with an 565 | interleaving process, rather than simply appending them" 566 | (stream-cons x stream-null)) 567 | 568 | ;; The following three procedures define the syntax of rules: 569 | 570 | (define (rule? statement) 571 | (tagged-list? statement 'rule)) 572 | 573 | (define (conclusion rule) (cadr rule)) 574 | 575 | (define (rule-body rule) 576 | (if (null? (cddr rule)) 577 | '(always-true) 578 | (caddr rule))) 579 | 580 | ;; Query-driver-loop (4.4.4.1) calls query-syntax-process to transform 581 | ;; pattern variables in the expression, which have the form ?symbol, into 582 | ;; the internal format (? symbol). That is to say, a pattern such as (job 583 | ;; ?x ?y) is actually represented internally by the system as (job (? x) 584 | ;; (? y)). This increases the efficiency of query processing, since it 585 | ;; means that the system can check to see if an expression is a pattern 586 | ;; variable by checking whether the car of the expression is the symbol 587 | ;; ?, rather than having to extract characters from the symbol. The 588 | ;; syntax transformation is accomplished by the following procedure:285 589 | 590 | (define (query-syntax-process exp) 591 | "Transform `(job ?x ?y)' => `(job (? x) (? y))'" 592 | (map-over-symbols expand-question-mark exp)) 593 | 594 | (define (map-over-symbols proc exp) 595 | (cond ((pair? exp) 596 | (cons (map-over-symbols 597 | proc (car exp)) 598 | (map-over-symbols 599 | proc (cdr exp)))) 600 | ((symbol? exp) (proc exp)) 601 | (else exp))) 602 | 603 | (define (expand-question-mark symbol) 604 | (let ((chars (symbol->string symbol))) 605 | (if (string=? (substring chars 0 1) "?") 606 | (list '? (string->symbol 607 | (substring 608 | chars 609 | 1 610 | (string-length chars)))) 611 | symbol))) 612 | 613 | ;; Once the variables are transformed in this way, the variables in a 614 | ;; pattern are lists starting with ?, and the constant symbols are just 615 | ;; the symbols. 616 | 617 | (define (var? exp) (tagged-list? exp '?)) 618 | (define (constant-symbol? exp) (symbol? exp)) 619 | 620 | ;; Unique variables are constructed during rule application (in 4.4.4.4) 621 | ;; by means of the following procedures. The unique identifier for a rule 622 | ;; application is a number, which is incremented each time a rule is 623 | ;; applied. 624 | 625 | (define rule-counter 0) 626 | 627 | (define (new-rule-application-id) 628 | (set! rule-counter (+ 1 rule-counter)) 629 | rule-counter) 630 | 631 | (define (make-new-variable 632 | var rule-application-id) 633 | (cons '? (cons rule-application-id 634 | (cdr var)))) 635 | 636 | ;; When query-driver-loop instantiates the query to print the answer, 637 | ;; it converts any unbound pattern variables back to the right form for 638 | ;; printing, using 639 | (define (contract-question-mark variable) 640 | (string->symbol 641 | (string-append "?" 642 | (if (number? (cadr variable)) 643 | (string-append 644 | (symbol->string (caddr variable)) 645 | "-" 646 | (number->string (cadr variable))) 647 | (symbol->string (cadr variable)))))) 648 | 649 | ;; Frames are represented as lists of bindings, which are variable-value pairs: 650 | 651 | (define (make-binding variable value) 652 | (cons variable value)) 653 | 654 | (define (binding-variable binding) 655 | (car binding)) 656 | 657 | (define (binding-value binding) 658 | (cdr binding)) 659 | 660 | (define (binding-in-frame variable frame) 661 | (assoc variable frame)) 662 | 663 | (define (extend variable value frame) 664 | (cons (make-binding variable value) frame)) 665 | -------------------------------------------------------------------------------- /machine/gui.scm: -------------------------------------------------------------------------------- 1 | ;; -*- mode: scheme; fill-column: 75; comment-column: 50; coding: utf-8; geiser-scheme-implementation: guile -*- 2 | (use-modules (srfi srfi-1) 3 | (ice-9 popen) 4 | (ice-9 hash-table) 5 | (ice-9 unicode) 6 | (srfi srfi-98) 7 | (ice-9 format) 8 | (ice-9 rdelim)) 9 | 10 | ;; (srfi srfi-13)) ; for 'string-join' 11 | 12 | ;; add machine 13 | ;; hook machine register 14 | ;; process table 15 | 16 | (define (%% format-string . format-args) 17 | (apply format `(#f 18 | ,format-string 19 | ,@format-args))) 20 | 21 | (include "/home/zv/z/practice/sicp/machine/register.scm") 22 | 23 | ;; We use special box-building characters, we need to set the appropriate locale. 24 | (setlocale LC_ALL "") 25 | 26 | (define *input-prompt* ">>> ") 27 | (define *assembly-context* 20) 28 | (define *stack-context* 15) 29 | (define *opcode-padding* 15) 30 | (define *command-table* '(next step continue bp)) 31 | (define *tracing* #t) 32 | 33 | (define *machine* 34 | (make-machine 35 | '())) 36 | 37 | ;; initialize machine 38 | ;; (map (λ (elt) (set-register-contents! *machine* (car elt) (cdr elt))) '((n . 10))) 39 | ;; (map (λ (elt) (set-register-contents! *machine* (car elt) (cdr elt))) '((tree . (1 (3 4) 5 (6 (7 3) 9))))) 40 | (*machine* 'init) 41 | 42 | 43 | ; Termcap 44 | (define *ansi-color-tables* 45 | (alist->hash-table 46 | '((CLEAR . "0") (RESET . "0") (BOLD . "1") 47 | (DARK . "2") (UNDERLINE . "4") (UNDERSCORE . "4") 48 | (BLINK . "5") (REVERSE . "6") (CONCEALED . "8") 49 | (BLACK . "30") (RED . "31") (GREEN . "32") 50 | (YELLOW . "33") (BLUE . "34") (MAGENTA . "35") 51 | (CYAN . "36") (WHITE . "37") (ON-BLACK . "40") 52 | (ON-RED . "41") (ON-GREEN . "42") (ON-YELLOW . "43") 53 | (ON-BLUE . "44") (ON-MAGENTA . "45") (ON-CYAN . "46") 54 | (ON-WHITE . "47")))) 55 | 56 | (define (color . lst) 57 | (let ((color-list 58 | (remove not 59 | (map (λ (color) (hash-ref *ansi-color-tables* color)) lst)))) 60 | (if (null? color-list) 61 | "" 62 | (string-append 63 | (string #\esc #\[) 64 | (string-join color-list ";" 'infix) 65 | "m")))) 66 | 67 | (define (colorize-string str . color-list) 68 | (string-append 69 | (apply color color-list) 70 | str 71 | (color 'RESET))) 72 | 73 | (define (clear) (system "tput clear")) 74 | 75 | 76 | (define (element-index e lst) 77 | (cond [(eqv? e (caar lst)) 0] 78 | [else (+ (element-index e (cdr lst)) 1)])) 79 | 80 | (define (extract-readable elt) (if (pair? elt) (caar elt) elt)) 81 | (define (extract-readable elt) elt) 82 | 83 | (define (wrap-rows str n) 84 | "Wrap a string to a max of `n' rows" 85 | (define (next lines ctr) 86 | (cond 87 | ((= ctr n) "") 88 | ((null? lines) 89 | (string-append "\n" (next lines (+ ctr 1)))) 90 | (else 91 | (string-append (car lines) 92 | "\n" 93 | (next (cdr lines) (+ ctr 1)))))) 94 | (next (string-split str #\newline) 0)) 95 | 96 | 97 | ; Header Drawing Code 98 | 99 | (define break (integer->char #x2500)) ;; Box-drawing char '─' 100 | (define arrow "🡆") 101 | 102 | ;; Because the terminal shell operates in it's own process, we need a fluid <-> thread binding 103 | (define (terminal-width) 104 | (or (let* ((port (open-input-pipe "tput cols")) 105 | (str (read-line port)) 106 | (w (false-if-exception (string->number str)))) 107 | (close-pipe port) 108 | (and (integer? w) (exact? w) (> w 0) w)) 109 | 72)) 110 | 111 | (define (build-header hdr) 112 | "Build a line of the format ─── HDR ────" 113 | (let* ([colored-hdr (colorize-string hdr 'YELLOW)] 114 | [left (format #f "~a ~a " (make-string 7 break) colored-hdr)] 115 | [len (string-length left)]) 116 | (string-pad-right left (+ 9 (terminal-width)) break))) 117 | 118 | (define (print-section-header hdr) 119 | "Print a section header" 120 | (format #t "~a\n" (build-header hdr))) 121 | 122 | 123 | ; Assembly 124 | 125 | ;; TODO REWRITE THIS FUCKING JUNK 126 | (define (format-instr insts instr-seq) 127 | (define (format-instr inst first) 128 | (define (format-arg arg) 129 | (match arg 130 | [('reg var) (%% "~a" var)] 131 | [('const var) (%% "$~x" var)] 132 | [('label var) (%% ".~a" var)] 133 | [('op var) (%% "~a" var)] 134 | [var (%% "~a" var)])) 135 | (cond 136 | [(null? inst) "\n"] 137 | [else 138 | (string-append 139 | (if first 140 | (string-pad-right (%% " 0x~4,'0x\t~a" 141 | (element-index inst instr-seq) 142 | (format-arg (car inst))) 143 | *opcode-padding*) 144 | (format-arg (car inst))) 145 | " " 146 | (format-instr (cdr inst) #f) 147 | )])) 148 | 149 | (define (process instrs first) 150 | (cond 151 | [(null? instrs) ""] 152 | [else 153 | (string-append 154 | (if first arrow " ") 155 | (format-instr (caar instrs) #t) 156 | (process (cdr instrs) #f))])) 157 | 158 | (wrap-rows (process insts #t) *assembly-context*)) 159 | 160 | (define (display-assembly machine) 161 | (print-section-header "Assembly") 162 | (display (format-instr (get-contents (get-register machine 'pc)) 163 | (machine 'dump-instruction-seq))) 164 | (display "\n")) 165 | 166 | 167 | ; Registers 168 | (define (display-registers machine) 169 | (print-section-header "Registers") 170 | (format-register-contents (extract-registers machine))) 171 | 172 | (define (format-register-contents regs) 173 | (define (print reg) 174 | (format #t " ~a ~s ~%" 175 | (string-pad-right (colorize-string (symbol->string (car reg)) 'BOLD) 30) 176 | (cdr reg))) 177 | (map print regs)) 178 | 179 | (define (extract-registers machine) 180 | (map 181 | (λ (register) 182 | (cons (car register) 183 | (extract-readable (get-contents (cadr register))))) 184 | (remove (λ (elt) (eq? (car elt) 'pc)) (machine 'dump-registers)))) 185 | 186 | ; Memory 187 | (define (display-memory machine) 188 | (print-section-header "Memory") 189 | (display "\n")) 190 | 191 | 192 | ; Stack 193 | (define (display-stack machine) 194 | (print-section-header "Stack") 195 | (display (format-stack ((machine 'stack) 'raw) 196 | (machine 'dump-instruction-seq) 197 | *stack-context*))) 198 | 199 | (define (format-stack stk instr-seq max) 200 | (define (next rest ctr) 201 | (cond 202 | ((= ctr max) " [+]\n") 203 | ((null? rest) "") 204 | (else 205 | (let ((head (car rest))) 206 | (string-append 207 | (format #f " [~a] ~a\n" (colorize-string (number->string ctr) 208 | (if (= ctr 0) 'BOLD 'DARK)) 209 | (if (pair? head) 210 | (format #f "*0x~4,'0x" 9999) 211 | head) 212 | ;; (extract-readable head) 213 | ) 214 | (next (cdr rest) (+ 1 ctr))))))) 215 | 216 | (next stk 0)) 217 | 218 | 219 | ; Metainfo 220 | (define (display-metainfo machine) 221 | (if *tracing* 222 | (begin 223 | (print-section-header "Meta") 224 | (format #t "Executed: ~a\n" (machine 'instructions-executed))))) 225 | 226 | (define (toggle-tracing status) 227 | (if (equal? status "on") 228 | (set! *tracing* #t) 229 | (set! *tracing* #f))) 230 | 231 | 232 | ; Loading 233 | 234 | 235 | ; Driver Loop 236 | (define (print-machine-state machine) 237 | "This function is responsible for building the 'view' of the GUI, 238 | handling appropriate termcap values and so on" 239 | (clear) 240 | (display-assembly machine) 241 | (display-registers machine) 242 | (display-stack machine) 243 | (display-metainfo machine) 244 | (format #t "~a\n" (make-string (terminal-width) break))) 245 | 246 | (define (load-machine filename) 247 | (load filename)) 248 | 249 | (define (run-machine machine args) 250 | (let* ((machine (eval-string machine)) 251 | (arguments (eval-string args))) 252 | (set! *machine* machine) 253 | (map (λ (elt) 254 | (display elt) 255 | (set-register-contents! *machine* (car elt) (cdr elt))) 256 | arguments) 257 | (*machine* 'init))) 258 | 259 | (define (process-prompt-input) 260 | (let* ((line (read-line))) 261 | (match (string-split line #\space) 262 | [("q") (exit)] 263 | [("quit") (exit)] 264 | [("step") ((*machine* 'step))] 265 | [("j") ((*machine* 'step))] 266 | [("load" filename) (load-machine filename)] 267 | [("run" machine args ...) 268 | (run-machine machine (if (null? args) "'()" (string-join args)))] 269 | [("trace" status) (toggle-tracing status)] 270 | [_ ((*machine* 'step))]))) 271 | 272 | (define (driver-loop) 273 | (print-machine-state *machine*) 274 | (display *input-prompt*) 275 | (process-prompt-input) 276 | (driver-loop)) 277 | 278 | (driver-loop) 279 | 280 | -------------------------------------------------------------------------------- /machine/register.scm: -------------------------------------------------------------------------------- 1 | ;; -*- mode: scheme; fill-column: 75; comment-column: 50; coding: utf-8; geiser-scheme-implementation: guile -*- 2 | (use-modules (ice-9 q)) 3 | (use-modules (ice-9 match)) 4 | (use-modules (srfi srfi-1)) 5 | (use-modules (srfi srfi-111)) 6 | (use-modules (srfi srfi-26)) 7 | 8 | (define (make-machine controller-text) 9 | "`Make-machine' then extends this basic model (by sending it 10 | messages) to include the registers, operations, and controller of the 11 | particular machine being defined. First it allocates a register in the 12 | new machine for each of the supplied register names and installs the 13 | designated operations in the machine. Then it uses an 'assembler' 14 | (described below in section *Note 5-2-2::) to transform the controller 15 | list into instructions for the new machine and installs these as the 16 | machine's instruction sequence. `Make-machine' returns as its value 17 | the modified machine model. " 18 | (let ((machine (make-new-machine))) 19 | (for-each (lambda (register-name) 20 | ((machine 'allocate-register) register-name)) 21 | (select-registers controller-text)) 22 | 23 | ((machine 'install-operations) (select-operations controller-text)) 24 | 25 | ((machine 'install-instruction-sequence) 26 | (assemble controller-text machine)) 27 | machine)) 28 | 29 | 30 | ; Stack 31 | 32 | (define (make-stack) 33 | "We can also represent a stack as a procedure with local state. The 34 | procedure `make-stack' creates a stack whose local state consists of a 35 | list of the items on the stack. A stack accepts requests to `push' an 36 | item onto the stack, to `pop' the top item off the stack and return it, 37 | and to `initialize' the stack to empty." 38 | (let ((s '())) 39 | (define (push x) 40 | (set! s (cons x s))) 41 | (define (pop) 42 | (if (null? s) 43 | (error "Empty stack: POP") 44 | (let ((top (car s))) 45 | (set! s (cdr s)) 46 | top))) 47 | (define (initialize) 48 | (set! s '()) 49 | 'done) 50 | (define (dispatch msg) 51 | (match msg 52 | ['push push] 53 | ['pop (pop)] 54 | ['initialize (initialize)] 55 | ['raw s] 56 | [_ (error "Unknown request -- STACK" msg)])) 57 | dispatch)) 58 | 59 | (define (pop stack) (stack 'pop)) 60 | (define (push stack value) ((stack 'push) value)) 61 | 62 | ; Register 63 | (define (make-register name) 64 | (let ([contents (box #nil)] 65 | [before-set-hook (make-hook 3)]) 66 | (define (dispatch message) 67 | (match message 68 | ['get (unbox contents)] 69 | ['set (λ (value) 70 | (run-hook before-set-hook name (unbox contents) value) 71 | (set-box! contents value))] 72 | ['add-hook (λ (fn) (add-hook! before-set-hook fn))] 73 | ['remove-hook! (λ (fn) (remove-hook! before-set-hook fn))] 74 | [_ (error "Unknown request -- REGISTER" message)])) 75 | dispatch)) 76 | 77 | (define (get-contents register) (register 'get)) 78 | (define (set-contents! register value) ((register 'set) value)) 79 | (define (get-register machine reg-name) ((machine 'get-register) reg-name)) 80 | (define (set-register-hook register fn) ((register 'add-hook) fn)) 81 | (define (remove-register-hook register fn) ((register 'remove-hook) fn)) 82 | 83 | 84 | ; The Basic Machine 85 | 86 | (define (make-new-machine) 87 | "The `make-new-machine' procedure, shown in*Note , constructs an object 88 | whose local state consists of a stack, an initially empty instruction 89 | sequence, a list of operations that initially contains an operation to 90 | initialize the stack, and a 'register table' that initially contains two 91 | registers, named `flag' and `pc'" 92 | (let* ([pc (make-register 'pc)] 93 | [flag (make-register 'flag)] 94 | [stack (make-stack)] 95 | [the-instruction-sequence '()] 96 | [breakpoints '()] 97 | [instructions-executed 0] 98 | [the-ops `((initialize-stack ,(λ () (stack 'initialize))))] 99 | [register-table `((pc ,pc) 100 | (flag ,flag))]) 101 | (define (allocate-register name) 102 | (if (assoc name register-table) 103 | (error "Multiply defined register: " name) 104 | (set! register-table 105 | (cons (list name (make-register name)) 106 | register-table))) 107 | 'register-allocated) 108 | (define (lookup-register name) 109 | (let ((val (assoc name register-table))) 110 | (if val 111 | (cadr val) 112 | (error "Unknown register:" name)))) 113 | (define (execute) 114 | (match (get-contents pc) 115 | [() 'done] 116 | [insts (begin 117 | ;; rework execution to be a sequence of steps 118 | (step) 119 | (execute))])) 120 | (define (step) 121 | (let ((insts (get-contents pc))) 122 | (if (null? insts) 'done 123 | (begin 124 | (set! instructions-executed (+ 1 instructions-executed)) 125 | ((instruction-execution-proc (car insts))))))) 126 | (define (hook-registers fn) 127 | (map (λ (elt) (set-register-hook (cadr elt) fn)) register-table)) 128 | (define (dispatch message) 129 | (match message 130 | ['init 131 | (set-contents! pc the-instruction-sequence)] 132 | ['start 133 | (set-contents! pc the-instruction-sequence) 134 | (execute)] 135 | ['dump-instruction-seq the-instruction-sequence] 136 | ['step step] 137 | ['install-instruction-sequence 138 | (λ (seq) (set! the-instruction-sequence seq))] 139 | ['allocate-register allocate-register] 140 | ['get-register lookup-register] 141 | ['install-operations 142 | (λ (ops) (set! the-ops (append the-ops ops)))] 143 | ['stack stack] 144 | ['instructions-executed instructions-executed] 145 | ['install-register-hook (cut hook-registers <>)] 146 | ['operations the-ops] 147 | ['dump-registers register-table] 148 | [_ (error "Unknown request -- MACHINE" message)])) 149 | dispatch)) 150 | 151 | (define (start machine) 152 | (machine 'start)) 153 | 154 | (define (get-register-contents machine register-name) 155 | (get-contents (get-register machine register-name))) 156 | 157 | (define (set-register-contents! machine register-name value) 158 | (set-contents! (get-register machine register-name) value) 159 | 'done) 160 | 161 | (define (get-register machine reg-name) 162 | ((machine 'get-register) reg-name)) 163 | 164 | 165 | ; Assembler 166 | 167 | (define (find-arguments controller-text pred) 168 | "This function takes in a predicate and controller-text, looking for 169 | bottom-most opcode arguments such as (op *), (reg register) or (const 1)" 170 | (delete-duplicates 171 | (fold 172 | (lambda (elt each) 173 | (let ((results (filter pred elt))) 174 | (if results (append (map cadr results) each) each))) 175 | '() 176 | (filter list? controller-text)))) 177 | 178 | (define (select-operations controller-text) 179 | "Returns a duplicates-free copy of all external 'syscalls' as '((op fn))" 180 | (map 181 | (λ (op) 182 | (list op (eval op (interaction-environment)))) 183 | (find-arguments controller-text 184 | (λ (e) (tagged-list? e 'op))))) 185 | 186 | (define (select-registers controller-text) 187 | "Returns a duplicates-free copy of all used registers" 188 | (delete-duplicates 189 | (let ((result (find-arguments controller-text register-exp?))) 190 | ;; bullshit haqing to get assign/push registers 191 | (for-each 192 | (lambda (exp) 193 | (match exp 194 | [('assign register rest ...) (append! result (list register))] 195 | [('push register rest ...) (append! result (list register))] 196 | [_ #f])) 197 | controller-text) 198 | result))) 199 | 200 | (define (assemble controller-text machine) 201 | "The `assemble' procedure is the main entry to the assembler. It 202 | takes the controller text and the machine model as arguments and 203 | returns the instruction sequence to be stored in the model. `Assemble' 204 | calls `select-labels' to build the initial instruction list and label 205 | table from the supplied controller text. The second argument to 206 | `select-labels' is a procedure to be called to process these results: 207 | This procedure uses `update-insts!' to generate the instruction 208 | execution procedures and insert them into the instruction list, and 209 | returns the modified list." 210 | (select-labels controller-text 211 | (lambda (insts labels) 212 | (update-insts! insts labels machine) 213 | insts))) 214 | 215 | (define (select-labels text receive) 216 | "`Select-labels' takes as arguments a list `text' (the sequence of 217 | controller instruction expressions) and a `receive' procedure. `Receive' 218 | will be called with two values: (1) a list `insts' of instruction data 219 | structures, each containing an instruction from `text'; and (2) a table 220 | called `labels', which associates each label from `text' with the position 221 | in the list `insts' that the label designates. 222 | 223 | `Select-labels' works by sequentially scanning the elements of the 224 | `text' and accumulating the `insts' and the `labels'. If an element is a 225 | symbol (and thus a label) an appropriate entry is added to the `labels' 226 | table. Otherwise the element is accumulated onto the `insts' list." 227 | (if (null? text) (receive '() '()) 228 | (select-labels (cdr text) 229 | (lambda (insts labels) 230 | (let ((next-inst (car text))) 231 | (if (symbol? next-inst) 232 | (receive insts 233 | (cons (make-label-entry next-inst insts) 234 | labels)) 235 | 236 | (receive 237 | (cons (make-instruction next-inst) insts) 238 | labels))))))) 239 | 240 | 241 | (define (update-insts! insts labels machine) 242 | "`Update-insts!' modifies the instruction list, which initially contains 243 | only the text of the instructions, to include the corresponding execution 244 | procedures: " 245 | (let ((pc (get-register machine 'pc)) 246 | (flag (get-register machine 'flag)) 247 | (stack (machine 'stack)) 248 | (ops (machine 'operations))) 249 | (for-each 250 | (lambda (inst) 251 | (set-instruction-execution-proc! 252 | inst 253 | (make-execution-procedure (instruction-text inst) 254 | labels 255 | machine 256 | pc 257 | flag 258 | stack 259 | ops))) 260 | insts))) 261 | 262 | (define (make-instruction text) (list text 263 | '() 264 | '())) 265 | (define (instruction-text inst) (car inst)) 266 | (define (instruction-execution-proc inst) (cadr inst)) 267 | (define (set-instruction-execution-proc! inst proc) (set-car! (cdr inst) proc)) 268 | 269 | 270 | ;; Elements of the label table are pairs: 271 | 272 | (define (make-label-entry label-name insts) 273 | (cons label-name insts)) 274 | 275 | ;; Entries will be looked up in the table with 276 | 277 | (define (lookup-label labels label-name) 278 | (let ((val (assoc label-name labels))) 279 | (if val 280 | (cdr val) 281 | (error "Undefined label -- ASSEMBLE" label-name)))) 282 | 283 | 284 | ; Generating Execution Procedures 285 | (define (make-execution-procedure inst labels machine pc flag stack ops) 286 | (match (car inst) 287 | ['movw (make-assign inst machine labels ops pc)] 288 | ['test (make-test inst machine labels ops flag pc)] 289 | ['jeq (make-branch inst machine labels flag pc)] 290 | ['goto (make-goto inst machine labels pc)] 291 | ['push (make-save inst machine stack pc)] 292 | ['pop (make-restore inst machine stack pc)] 293 | ['perform (make-perform inst machine labels ops pc)] 294 | [_ (error "Unknown instruction type -- ASSEMBLE" inst)])) 295 | 296 | (define (make-assign inst machine labels operations pc) 297 | "`Make-assign' extracts the target register name (the second element of 298 | the instruction) and the value expression (the rest of the list that forms 299 | the instruction) from the `assign' instruction using the selectors " 300 | (let ((target 301 | (get-register machine (assign-reg-name inst))) 302 | (value-exp (assign-value-exp inst))) 303 | (let ((value-proc 304 | (if (operation-exp? value-exp) 305 | (make-operation-exp 306 | value-exp machine labels operations) 307 | (make-primitive-exp 308 | (car value-exp) machine labels)))) 309 | (lambda () ; execution procedure for assign 310 | (set-contents! target (value-proc)) 311 | (advance-pc pc))))) 312 | 313 | (define (assign-reg-name assign-instruction) (cadr assign-instruction)) 314 | (define (assign-value-exp assign-instruction) (cddr assign-instruction)) 315 | 316 | ;; Move the instruction pointer one forward 317 | (define (advance-pc pc) (set-contents! pc (cdr (get-contents pc)))) 318 | 319 | 320 | 321 | (define (make-test inst machine labels operations flag pc) 322 | "`Make-test' handles `test' instructions in a similar way. It extracts 323 | the expression that specifies the condition to be tested and generates an 324 | execution procedure for it. At simulation time, the procedure for the 325 | condition is called, the result is assigned to the `flag' register, and the 326 | `pc' is advanced:" 327 | (let ((condition (test-condition inst))) 328 | (if (operation-exp? condition) 329 | (let ((condition-proc 330 | (make-operation-exp 331 | condition machine labels operations))) 332 | (lambda () 333 | (set-contents! flag (condition-proc)) 334 | (advance-pc pc))) 335 | (error "Bad TEST instruction -- ASSEMBLE" inst)))) 336 | 337 | (define (test-condition test-instruction) (cdr test-instruction)) 338 | 339 | 340 | (define (make-branch inst machine labels flag pc) 341 | " The execution procedure for a `branch' instruction checks the contents 342 | of the `flag' register and either sets the contents of the `pc' to the 343 | branch destination (if the branch is taken) or else just advances the `pc' 344 | (if the branch is not taken). Notice that the indicated destination in a 345 | `branch' instruction must be a label, and the `make-branch' procedure 346 | enforces this. Notice also that the label is looked up at assembly time, 347 | not each time the `branch' instruction is simulated. " 348 | (let ((dest (branch-dest inst))) 349 | (if (label-exp? dest) 350 | (let ((insts 351 | (lookup-label labels (label-exp-label dest)))) 352 | (lambda () 353 | (if (get-contents flag) 354 | (set-contents! pc insts) 355 | (advance-pc pc)))) 356 | (error "Bad BRANCH instruction -- ASSEMBLE" inst)))) 357 | 358 | (define (branch-dest branch-instruction) (cadr branch-instruction)) 359 | 360 | 361 | (define (make-goto inst machine labels pc) 362 | " A `goto' instruction is similar to a branch, except that the 363 | destination may be specified either as a label or as a register, and there 364 | is no condition to check--the `pc' is always set to the new destination. " 365 | (let ((dest (goto-dest inst))) 366 | (cond ((label-exp? dest) 367 | (let ((insts (lookup-label labels (label-exp-label dest)))) 368 | (lambda () (set-contents! pc insts)))) 369 | ((register-exp? dest) 370 | (let ((reg (get-register machine (register-exp-reg dest)))) 371 | (lambda () 372 | (set-contents! pc (get-contents reg))))) 373 | (else (error "Bad GOTO instruction -- ASSEMBLE" inst))))) 374 | 375 | (define (goto-dest goto-instruction) (cadr goto-instruction)) 376 | 377 | 378 | ; Other Instructions 379 | ;; The stack instructions `save' and `restore' simply use the stack with 380 | ;; the designated register and advance the `pc': 381 | (define (make-save inst machine stack pc) 382 | (let ((reg (get-register machine 383 | (stack-inst-reg-name inst)))) 384 | (lambda () 385 | (push stack (get-contents reg)) 386 | (advance-pc pc)))) 387 | 388 | (define (make-restore inst machine stack pc) 389 | (let ((reg (get-register machine 390 | (stack-inst-reg-name inst)))) 391 | (lambda () 392 | (set-contents! reg (pop stack)) 393 | (advance-pc pc)))) 394 | 395 | (define (stack-inst-reg-name stack-instruction) 396 | (cadr stack-instruction)) 397 | 398 | (define (make-perform inst machine labels operations pc) 399 | " `make-perform', generates an execution procedure for the action to be 400 | performed. At simulation time, the action procedure is executed and the 401 | `pc' advanced. " 402 | (let ((action (perform-action inst))) 403 | (if (operation-exp? action) 404 | (let ((action-proc 405 | (make-operation-exp 406 | action machine labels operations))) 407 | (lambda () 408 | (action-proc) 409 | (advance-pc pc))) 410 | (error "Bad PERFORM instruction -- ASSEMBLE" inst)))) 411 | 412 | (define (perform-action inst) (cdr inst)) 413 | 414 | ; Execution procedure for subexpressions 415 | 416 | ;; The value of a `reg', `label', or `const' expression may be needed for 417 | ;; assignment to a register (`make-assign') or for input to an operation 418 | ;; (`make-operation-exp', below). The following procedure generates 419 | ;; execution procedures to produce values for these expressions during the 420 | ;; simulation: 421 | 422 | (define (make-primitive-exp exp machine labels) 423 | (cond ((constant-exp? exp) 424 | (let ((c (constant-exp-value exp))) 425 | (lambda () c))) 426 | ((label-exp? exp) 427 | (let ((insts 428 | (lookup-label labels 429 | (label-exp-label exp)))) 430 | (lambda () insts))) 431 | ((register-exp? exp) 432 | (let ((r (get-register machine 433 | (register-exp-reg exp)))) 434 | (lambda () (get-contents r)))) 435 | (else 436 | (error "Unknown expression type -- ASSEMBLE" exp)))) 437 | 438 | (define (register-exp? exp) (tagged-list? exp 'reg)) 439 | (define (register-exp-reg exp) (cadr exp)) 440 | (define (constant-exp? exp) (tagged-list? exp 'const)) 441 | (define (constant-exp-value exp) (cadr exp)) 442 | (define (label-exp? exp) (tagged-list? exp 'label)) 443 | (define (label-exp-label exp) (cadr exp)) 444 | 445 | (define (make-operation-exp exp machine labels operations) 446 | (let ((op (lookup-prim (operation-exp-op exp) operations)) 447 | (aprocs 448 | (map (lambda (e) 449 | (make-primitive-exp e machine labels)) 450 | (operation-exp-operands exp)))) 451 | (lambda () 452 | (apply op (map (lambda (p) (p)) aprocs))))) 453 | 454 | (define (operation-exp? exp) 455 | (and (pair? exp) (tagged-list? (car exp) 'op))) 456 | (define (operation-exp-op operation-exp) 457 | (cadr (car operation-exp))) 458 | (define (operation-exp-operands operation-exp) 459 | (cdr operation-exp)) 460 | 461 | (define (lookup-prim symbol operations) 462 | (let ((val (assoc symbol operations))) 463 | (if val 464 | (cadr val) 465 | (error "Unknown operation -- ASSEMBLE" symbol)))) 466 | 467 | 468 | ;; from 4.1 469 | (define (tagged-list? exp tag) 470 | (if (pair? exp) 471 | (eq? (car exp) tag) 472 | #f)) 473 | -------------------------------------------------------------------------------- /machine/regmach.scm: -------------------------------------------------------------------------------- 1 | (use-modules (oop goops)) 2 | (use-modules (ice-9 format)) 3 | (use-modules (ice-9 match)) 4 | (use-modules (ice-9 pretty-print)) 5 | (use-modules (ice-9 q)) 6 | 7 | 8 | ; Stack 9 | (define (pop stk) (q-pop! stk)) 10 | (define (push stk value) (q-push! stk value)) 11 | 12 | 13 | ; Register 14 | (define-class () 15 | (contents #:init-value '*unassigned* 16 | #:getter get-contents 17 | #:setter set-contents!)) 18 | 19 | 20 | 21 | 22 | (define-class () 23 | (registers #:init-thunk (make-hash-table 31)) 24 | (pc #:init-value #nil 25 | #:allocation #:virtual 26 | #:slot-ref (λ (o) (fetchr o 'pc)) 27 | #:slot-set (λ (o a) (setr o 'pc))) 28 | (flag #:init-value #nil 29 | #:allocation #:virtual 30 | #:slot-ref (λ (o) (fetchr o 'flag)) 31 | #:slot-set (λ (o a) (setr o 'flag)))) 32 | 33 | -------------------------------------------------------------------------------- /picture.rkt: -------------------------------------------------------------------------------- 1 | #lang sicp 2 | (#%require sicp-pict) 3 | ;; ----------------------------------------------------------- 4 | ;; Utilities 5 | ;; ----------------------------------------------------------- 6 | (define (flipped-pairs painter) 7 | (let [(painter2 (beside painter (flip-vert painter)))] 8 | (below painter2 painter2))) 9 | (define (right-split painter n) 10 | (if (= n 0) painter 11 | (let [(smaller (right-split painter (- n 1)))] 12 | (beside painter (below smaller smaller))))) 13 | (define (corner-split painter n) 14 | (if (= n 0) painter 15 | (let [(up (up-split painter (- n 1))) 16 | (right (right-split painter (- n 1)))] 17 | (let [(top-left (beside up up)) 18 | (bottom-right (below right right)) 19 | (corner (corner-split painter (- n 1)))] 20 | (beside (below painter top-left) 21 | (below bottom-right corner)))))) 22 | 23 | (define (square-of-four tl tr bl br) 24 | (lambda (painter) 25 | (let ((top (beside (tl painter) 26 | (tr painter))) 27 | (bottom (beside (bl painter) 28 | (br painter)))) 29 | (below bottom top)))) 30 | (define (flipped-pairs-z painter) 31 | (let ((combine4 32 | (square-of-four identity 33 | flip-vert 34 | identity 35 | flip-vert))) 36 | (combine4 painter))) 37 | ;; ----------------------------------------------------------- 38 | ;;; /Utilities (End) 39 | ;; ----------------------------------------------------------- 40 | 41 | ;; 2.44 42 | (define (up-split painter n) 43 | (if (= n 0) 44 | painter 45 | (let [(smaller (up-split painter (- n 1)))] 46 | (below painter 47 | (beside smaller smaller))))) 48 | 49 | ;; 2.45 50 | (define (split stepa stepb) 51 | (define (new-painter painter n) 52 | (if (= n 0) painter 53 | (let [(smaller (new-painter painter (dec n)))] 54 | (stepa painter (stepb smaller smaller))))) 55 | painter) 56 | 57 | (define right-split-z (split beside below)) 58 | (define up-split-z (split below beside)) 59 | 60 | ;; 2.46 61 | -------------------------------------------------------------------------------- /sicp5.scm: -------------------------------------------------------------------------------- 1 | ;; -*- mode: scheme; fill-column: 75; comment-column: 50; coding: utf-8; geiser-scheme-implementation: guile -*- 2 | 3 | #| Structure and Interpretation of Computer Programs - Chapter 5 |# 4 | 5 | ;; The Register Machine Simulation 6 | (use-modules (ice-9 format)) 7 | (use-modules (ice-9 match)) 8 | (use-modules (ice-9 pretty-print)) 9 | ;; (use-modules (oop goops)) 10 | 11 | (define inside-repl? 12 | ;; current-source-location is formatted in a line, column, filename alist 13 | ;; e.g ((line . INTEGER) (column . INTEGER) (filename . SYMBOL|FALSE)) 14 | (eq? #f (assq-ref (current-source-location) 'filename))) 15 | 16 | (define do-debug? #t) 17 | 18 | (define (reg-debug format-string . format-args) 19 | (if do-debug? 20 | (apply format `(#t 21 | ,(string-append format-string "~&") 22 | ,@format-args)))) 23 | 24 | 25 | ;; Section 4.1 26 | (include "/home/zv/z/practice/sicp/machine/register.scm") 27 | (define (extract-config-names items) 28 | (map (lambda (elt) 29 | (if (list? elt) 30 | (car elt) 31 | elt)) 32 | items)) 33 | 34 | (define (machine-run mach init) 35 | "Run a machine with the registers initialized to the alist in `init' and 36 | then dumps the values of all registers" 37 | (map (λ (el) (set-register-contents! mach (car el) (cdr el))) init) 38 | (start mach) 39 | (map 40 | (λ (reg) (cons (car reg) 41 | (get-contents (get-register mach (car reg))))) 42 | (mach 'dump-registers))) 43 | 44 | (define-syntax define-register-machine 45 | (syntax-rules () 46 | ((define-register-machine var #:assembly assembly) 47 | (define var (make-machine 'assembly))))) 48 | 49 | 50 | #| Exercise 5.1 51 | Design a register machine to compute factorials using the iterative 52 | algorithm specified by the following procedure. Draw data-path and 53 | controller diagrams for this machine. 54 | 55 | (define (factorial n) 56 | (define (iter product counter) 57 | (if (> counter n) 58 | product 59 | (iter (* counter product) 60 | (+ counter 1)))) 61 | (iter 1 1)) 62 | |# 63 | 64 | (define-register-machine factorial 65 | #:assembly ((movw counter (const 1)) 66 | (movw product (const 1)) 67 | loop 68 | (test (op >) (reg counter) (reg n)) 69 | (jeq (label end-fib)) 70 | (movw product (op *) (reg counter) (reg product)) 71 | (movw counter (op +) (reg counter) (const 1)) 72 | (goto (label loop)) 73 | end-fib)) 74 | 75 | 76 | #| Exercise 5.3 77 | Design a machine to compute square roots using Newton’s method, as 78 | described in 1.1.7: 79 | 80 | (define (sqrt x) 81 | (define (good-enough? guess) 82 | (< (abs (- (square guess) x)) 0.001)) 83 | (define (improve guess) 84 | (average guess (/ x guess))) 85 | (define (sqrt-iter guess) 86 | (if (good-enough? guess) 87 | guess 88 | (sqrt-iter (improve guess)))) 89 | (sqrt-iter 1.0)) 90 | 91 | Begin by assuming that good-enough? and improve operations are available as 92 | primitives. Then show how to expand these in terms of arithmetic 93 | operations. Describe each version of the sqrt machine design by drawing a 94 | data-path diagram and writing a controller definition in the 95 | register-machine language. 96 | |# 97 | 98 | (define (average a b) (/ (+ a b) 2)) 99 | (define (square x) (* x x)) 100 | (define (newton/good-enough? guess x) (< (abs (- (square guess) x)) 0.001)) 101 | (define (newton/improve guess x) (average guess (/ x guess))) 102 | 103 | (define-register-machine newtons 104 | #:assembly ((movw guess (const 1.0)) 105 | improve 106 | (test (op newton/good-enough?) (reg guess) (reg x)) 107 | (jeq (label end-newton)) 108 | (movw guess (op newton/improve) (reg guess) (reg x)) 109 | (goto (label improve)) 110 | end-newton)) 111 | 112 | 113 | #| Exercise 5.4 114 | Specify register machines that implement each of the following procedures. 115 | For each machine, write a controller instruction sequence and draw a 116 | diagram showing the data paths. 117 | 118 | Recursive exponentiation: 119 | 120 | (define (expt b n) 121 | (if (= n 0) 122 | 1 123 | (* b 124 | (expt b (- n 1))))) 125 | 126 | Iterative exponentiation: 127 | 128 | (define (expt b n) 129 | (define (expt-iter counter product) 130 | (if (= counter 0) 131 | product 132 | (expt-iter (- counter 1) 133 | (* b product)))) 134 | (expt-iter n 1)) 135 | |# 136 | 137 | (define-register-machine recursive-expt 138 | #:assembly ((movw retnaddr (label immediate)) 139 | (movw counter (const 0)) 140 | start 141 | (test (op =) (reg n) (reg counter)) ;; if n == 0 142 | (jeq (label immediate)) 143 | (movw retnaddr (label stkretn)) 144 | (push b) 145 | (movw counter (op +) (reg counter) (reg n)) 146 | (goto (label start)) 147 | ;; now sum our values by popping off `counter' elts from the stack 148 | stkretn 149 | (movw result (op *) (reg result) (reg b)) 150 | ;; store our popped value in `result' 151 | (movw counter (op -) (reg counter) (const 1)) 152 | (test (op =) (const 0) (reg counter)) 153 | (jeq (label done)) 154 | (goto (label stkretn)) 155 | ;; We're done, store '2' in 'eax' 156 | immediate 157 | (movw result (const 1)) 158 | (goto (reg retnaddr)) 159 | done)) 160 | 161 | (define-register-machine iter-expt 162 | #:assembly ((movw result (const 1)) 163 | (movw counter (const 1)) 164 | for-loop 165 | (movw result (op *) (reg result) (reg b)) 166 | (test (op =) (reg n) (reg counter)) ;; is n == counter 167 | (jeq (label done)) 168 | (movw counter (op +) (reg counter) (const 1)) 169 | (goto (label for-loop)) 170 | done)) 171 | 172 | 173 | #| Exercise 5.5 DONE 174 | Hand-simulate the factorial and Fibonacci machines, using some nontrivial 175 | input (requiring execution of at least one recursive call). Show the 176 | contents of the stack at each significant point in the execution. |# 177 | 178 | 179 | #| Exercise 5.6 180 | Ben Bitdiddle observes that the Fibonacci machine’s controller sequence has 181 | an extra save and an extra restore, which can be removed to make a faster 182 | machine. Where are these instructions? |# 183 | 184 | #| Answer: 185 | Both the save & restore of `continue' are useless. 186 | |# 187 | 188 | ; The Simulator 189 | 190 | 191 | #| Exercise 5.7: Use the simulator to test the machines you designed in Exercise 5.4. |# 192 | 193 | 194 | #| Exercise 5.8 195 | The following register-machine code is ambiguous, because the label `here' 196 | is defined more than once: 197 | 198 | start 199 | (goto (label here)) 200 | here 201 | (movw a (const 3)) 202 | (goto (label there)) 203 | here 204 | (movw a (const 4)) 205 | (goto (label there)) 206 | there 207 | 208 | With the simulator as written, what will the contents of register `a' be 209 | when control reaches `there'? Modify the `extract-labels' procedure so that 210 | the assembler will signal an error if the same label name is used to 211 | indicate two different locations. |# 212 | 213 | #| Answer: extract-label updated in 57a079eda7d4a0dc58ba2f8324f4b03c55ad27cc |# 214 | 215 | 216 | #| Exercise 5.9 217 | The treatment of machine operations above permits them to operate on labels 218 | as well as on constants and the contents of registers. Modify the 219 | expression-processing procedures to enforce the condition that operations 220 | can be used only with registers and constants. |# 221 | (define (make-operation-exp exp machine labels operations) 222 | (let ((op (lookup-prim (operation-exp-op exp) operations)) 223 | (aprocs 224 | (map (lambda (e) 225 | (if (or (register-exp? e) (constant-exp? e)) 226 | (make-primitive-exp e machine labels) 227 | (error "neither register nor constant exp in `make-operation-exp'"))) 228 | (operation-exp-operands exp)))) 229 | (lambda () 230 | (apply op (map (lambda (p) (p)) aprocs))))) 231 | 232 | 233 | #| Exercise 5.10 234 | Design a new syntax for register-machine instructions and modify the 235 | simulator to use your new syntax. Can you implement your new syntax without 236 | changing any part of the simulator except the syntax procedures in this 237 | section? |# 238 | 239 | #| Answer: 240 | Yes, I can. |# 241 | 242 | 243 | #| TODO Exercise 5.11 244 | When we introduced `save' and `restore' in section *Note 5-1-4, we didn't 245 | specify what would happen if you tried to restore a register that was not 246 | the last one saved, as in the sequence 247 | 248 | (save y) 249 | (save x) 250 | (restore y) 251 | 252 | There are several reasonable possibilities for the meaning of 253 | `restore': 254 | 255 | a. `(restore y)' puts into `y' the last value saved on the stack, 256 | regardless of what register that value came from. This is 257 | the way our simulator behaves. Show how to take advantage of 258 | this behavior to eliminate one instruction from the Fibonacci 259 | machine of section *Note 5-1-4:: (*Note Figure 5-12::). 260 | 261 | b. `(restore y)' puts into `y' the last value saved on the 262 | stack, but only if that value was saved from `y'; otherwise, 263 | it signals an error. Modify the simulator to behave this 264 | way. You will have to change `save' to put the register name 265 | on the stack along with the value. 266 | 267 | c. `(restore y)' puts into `y' the last value saved from `y' 268 | regardless of what other registers were saved after `y' and 269 | not restored. Modify the simulator to behave this way. You 270 | will have to associate a separate stack with each register. 271 | You should make the `initialize-stack' operation initialize 272 | all the register stacks. 273 | |# 274 | 275 | 276 | #| Exercise 5.12 277 | The simulator can be used to help determine the data paths required for 278 | implementing a machine with a given controller. Extend the assembler to 279 | store the following information in the machine model: 280 | 281 | * DONE a list of all instructions, with duplicates removed, sorted by 282 | instruction type (`assign', `goto', and so on); 283 | 284 | * DONE a list (without duplicates) of the registers used to hold entry points 285 | (these are the registers referenced by `goto' instructions); 286 | 287 | * DONE a list (without duplicates) of the registers that are `save'd or 288 | `restore'd; 289 | 290 | * DONE for each register, a list (without duplicates) of the sources from which 291 | it is assigned (for example, the sources for register `val' in the 292 | factorial machine of *Note Figure 5-11 are `(const 1)' and `((op *) (reg n) 293 | (reg val))'). 294 | 295 | Extend the message-passing interface to the machine to provide access to 296 | this new information. To test your analyzer, define the Fibonacci machine 297 | from Figure 5.12 and examine the lists you constructed. 298 | |# 299 | (define (filter-opcodes text fn) 300 | "Filter controller text down to those opcodes for which `fn' == #t" 301 | (map car (filter fn 302 | (select-labels text (λ (insts labels) insts))))) 303 | 304 | (define (extract-goto-destinations text) 305 | (fold 306 | (λ (elt acc) 307 | (if (member (car elt) acc) acc (append acc elt))) 308 | '() ;; initial argument to fold 309 | (map cdadr (filter-opcodes text 310 | (λ (inst) (eq? (caar inst) 'goto)))))) 311 | 312 | (define (extract-stack-manipulations text) 313 | (fold 314 | (λ (elt acc) 315 | (if (member (car elt) acc) acc (append acc elt))) 316 | '() ;; initial argument to fold 317 | (map cdr 318 | (filter-opcodes text 319 | (λ (inst) 320 | (let ((opcode (caar inst))) 321 | (or (eq? opcode 'pop) 322 | (eq? opcode 'push)))))))) 323 | 324 | 325 | #| Exercise 5.13 326 | Modify the simulator so that it uses the controller sequence to determine 327 | what registers the machine has rather than requiring a list of registers as 328 | an argument to `make-machine'. Instead of pre-allocating the registers in 329 | `make-machine', you can allocate them one at a time when they are first 330 | seen during assembly of the instructions. |# 331 | 332 | #| Answer: 333 | I modified `make-machine' directly to support this change in rev:f68d783 334 | |# 335 | 336 | 337 | #| Exercise 5.14 338 | Measure the number of pushes and the maximum stack depth required to 339 | compute n! for various small values of n using the factorial machine shown 340 | Figure 5-11. From your data determine formulas in terms of n for 341 | the total number of push operations and the maximum stack depth used in 342 | computing n! for any n > 1. Note that each of these is a linear function of 343 | n and is thus determined by two constants. In order to get the statistics 344 | printed, you will have to augment the factorial machine with instructions 345 | to initialize the stack and print the statistics. You may want to also 346 | modify the machine so that it repeatedly reads a value for n, computes the 347 | factorial, and prints the result (as we did for the GCD machine in Figure 348 | 5.4, so that you will not have to repeatedly invoke `get-register-contents', 349 | `set-register-contents!', and `start'. |# 350 | 351 | 352 | #| Answer: 353 | Because no operations pop elements off the stack until the function 354 | terminates, the total amount of stack space used is 2N - 2 where N is the 355 | space used by a particular stack frame. 356 | |# 357 | 358 | 359 | #| Exercise 5.15 360 | Add counting "instruction counting" to the register machine simulation. 361 | That is, have the machine model keep track of the number of instructions 362 | executed. Extend the machine model's interface to accept a new message that 363 | prints the value of the instruction count and resets the count to zero. |# 364 | 365 | #| Answer: 366 | I've modified `make-new-machine' to return 'instruction-count', and 367 | machine/gui to automatically return this upon every step / continue 368 | |# 369 | 370 | 371 | #| Exercise 5.16 372 | Augment the simulator to provide for "instruction tracing". That is, before 373 | each instruction is executed, the simulator should print the text of the 374 | instruction. Make the machine model accept `trace-on' and `trace-off' 375 | messages to turn tracing on and off. |# 376 | 377 | #| Answer: Added to machine/gui |# 378 | 379 | 380 | #| Exercise 5.17 381 | Extend the instruction tracing of *Note Exercise 5-16 so that before 382 | printing an instruction, the simulator prints any labels that immediately 383 | precede that instruction in the controller sequence. Be careful to do this 384 | in a way that does not interfere with instruction counting (*Note Exercise 385 | 5-15). You will have to make the simulator retain the necessary label 386 | information. |# 387 | 388 | #| Answer: 389 | This is already a feature :) 390 | |# 391 | 392 | 393 | #| Exercise 5.18 394 | Modify the `make-register' procedure of section *Note 5-2-1 so that 395 | registers can be traced. Registers should accept messages that turn tracing 396 | on and off. When a register is traced, assigning a value to the register 397 | should print the name of the register, the old contents of the register, 398 | and the new contents being assigned. Extend the interface to the machine 399 | model to permit you to turn tracing on and off for designated machine 400 | registers. |# 401 | 402 | #| Answer: Added in `before-set-hook'|# 403 | 404 | 405 | #| TODO Exercise 5.19 406 | Alyssa P. Hacker wants a "breakpoint" feature in the simulator to help her 407 | debug her machine designs. You have been hired to install this feature for 408 | her. She wants to be able to specify a place in the controller sequence 409 | where the simulator will stop and allow her to examine the state of the 410 | machine. You are to implement a procedure 411 | 412 | (set-breakpoint