exercise-8.scm (20780B)
1 (define-library (sicp solutions chapter-4 exercise-8) 2 (export 3 eval 4 main 5 6 run-internal-tests 7 8 make-environment 9 setup-environment 10 extend-environment 11 ) 12 (import 13 (rename (scheme base) (apply scheme:base:apply)) 14 (scheme cxr) 15 (scheme read) 16 (scheme write) 17 18 (srfi srfi-1) 19 (srfi srfi-9) 20 (srfi srfi-64) 21 22 (system vm trace) 23 24 (ice-9 match) 25 (ice-9 pretty-print) 26 27 (sicp utils) 28 ) 29 30 (begin 31 ;; XXX: In 4.1.3 we see that the procedure `true?` is defined 32 ;; using the host-variable `false` whose value is 'false, but we 33 ;; don't see it defined anywhere in the good book, so we need to 34 ;; define the host-variable false ourselves. 35 ;; 36 ;; In MIT Scheme, the one the SICP people seem to love to use for 37 ;; SICP, the values of `false` and `true` are #f and #t, #f being 38 ;; the only value that is falsituous and #t there for having a 39 ;; truthious value that has no other meaning other than being 40 ;; truthitiousic. 41 ;; 42 ;; ``` 43 ;; # `scheme` is the MIT Scheme executable: 44 ;; $ guix shell mit-scheme -- scheme 45 ;; MIT/GNU Scheme running under GNU/Linux 46 ;; Type `^C' (control-C) followed by `H' to obtain information about interrupts. 47 ;; 48 ;; Copyright (C) 2020 Massachusetts Institute of Technology 49 ;; This is free software; see the source for copying conditions. There is NO warranty; not even for 50 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 51 ;; 52 ;; Image saved on Sunday March 7, 2021 at 3:24:56 PM 53 ;; Release 11.2 || SF || LIAR/x86-64 54 ;; 55 ;; 1 ]=> false 56 ;; 57 ;; ;Value: #f 58 ;; 59 ;; 1 ]=> true 60 ;; 61 ;; ;Value: #t 62 ;; 63 ;; 1 ]=> 64 ;; ``` 65 (define false #f) 66 (define true #t) 67 68 (define (make-environment vars vals) 69 "A comfort procedure because calling extend on the-empty-environment is a PITA." 70 (extend-environment vars 71 vals 72 the-empty-environment)) 73 74 ;; XXX: As described in chapter 4.1.4 note 2, we need to name the 75 ;; host `apply`, and the guest `apply` differently. I define the 76 ;; host's `apply` to be the name used in the book. 77 (define apply-in-underlying-scheme scheme:base:apply) 78 79 ;;; Start: 80 81 ;;; 4.1.1 82 83 (define *form-table* '()) 84 85 (define (add-form-handler! form? handler) 86 (set! *form-table* 87 (cons (cons form? 88 handler) 89 *form-table*))) 90 91 (define (get-form-handler exp) 92 (let loop ((table *form-table*)) 93 (match table 94 ('() 95 (error "Unknown form" exp)) 96 (`((,form? . ,handler) . ,rest) 97 (if (form? exp) 98 handler 99 (loop rest)))))) 100 101 (define (eval exp env) 102 (cond ((self-evaluating? exp) 103 exp) 104 ((variable? exp) 105 (lookup-variable-value exp env)) 106 ((pair? exp) 107 ((get-form-handler exp) exp env)) 108 (else 109 (error "Unknown expression type -- EVAL" exp)))) 110 111 (define (apply procedure arguments) 112 (cond ((primitive-procedure? procedure) 113 (apply-primitive-procedure 114 procedure 115 arguments)) 116 ((compound-procedure? procedure) 117 (eval-sequence 118 (procedure-body procedure) 119 (extend-environment 120 (procedure-parameters 121 procedure) 122 arguments 123 (procedure-environment 124 procedure)))) 125 (else 126 (error "Unknown procedure type -- APPLY" 127 procedure)))) 128 129 ;;; Procedure arguments: 130 131 (define (list-of-values exps env) 132 (if (no-operands? exps) 133 '() 134 (cons (eval (first-operand exps) env) 135 (list-of-values (rest-operands exps) env)))) 136 137 ;;; Conditionals: 138 139 (define (eval-if exp env) 140 (if (true? (eval (if-predicate exp) env)) 141 (eval (if-consequent exp) env) 142 (eval (if-alternative exp) env))) 143 144 ;;; Sequences: 145 146 (define (eval-sequence exps env) 147 (cond ((last-exp? exps) 148 (eval (first-exp exps) env)) 149 (else 150 (eval (first-exp exps) env) 151 (eval-sequence (rest-exps exps) 152 env)))) 153 154 ;;; Assignments and definitions 155 156 (define (eval-assignment exp env) 157 (set-variable-value! 158 (assignment-variable exp) 159 (eval (assignment-value exp) env) 160 env) 161 'ok) 162 163 (define (eval-definition exp env) 164 (define-variable! 165 (definition-variable exp) 166 (eval (definition-value exp) env) 167 env) 168 'ok) 169 170 ;;; end 4.1.1 171 172 ;;; 4.1.2 173 174 175 (define (self-evaluating? exp) 176 (cond ((number? exp) true) 177 ((string? exp) true) 178 (else false))) 179 180 (define (variable? exp) (symbol? exp)) 181 182 (define (quoted? exp) 183 (tagged-list? exp 'quote)) 184 185 (define (text-of-quotation exp) 186 (cadr exp)) 187 188 (define (tagged-list? exp tag) 189 (if (pair? exp) 190 (eq? (car exp) tag) 191 false)) 192 193 (define (assignment? exp) 194 (tagged-list? exp 'set!)) 195 196 (define (assignment-variable exp) 197 (cadr exp)) 198 199 (define (assignment-value exp) (caddr exp)) 200 201 (define (definition? exp) 202 (tagged-list? exp 'define)) 203 204 (define (definition-variable exp) 205 (if (symbol? (cadr exp)) 206 (cadr exp) 207 (caadr exp))) 208 209 (define (definition-value exp) 210 (if (symbol? (cadr exp)) 211 (caddr exp) 212 (make-lambda 213 (cdadr exp) ; formal-parameters 214 (cddr exp)))) ; body 215 216 (define (lambda? exp) 217 (tagged-list? exp 'lambda)) 218 (define (lambda-parameters exp) (cadr exp)) 219 (define (lambda-body exp) (cddr exp)) 220 221 (define (make-lambda parameters body) 222 (cons 'lambda (cons parameters body))) 223 224 (define (if? exp) (tagged-list? exp 'if)) 225 (define (if-predicate exp) (cadr exp)) 226 (define (if-consequent exp) (caddr exp)) 227 (define (if-alternative exp) 228 (if (not (null? (cdddr exp))) 229 (cadddr exp) 230 'false)) 231 232 (define (make-if predicate 233 consequent 234 alternative) 235 (list 'if 236 predicate 237 consequent 238 alternative)) 239 240 (define (begin? exp) 241 (tagged-list? exp 'begin)) 242 (define (begin-actions exp) (cdr exp)) 243 (define (last-exp? seq) (null? (cdr seq))) 244 (define (first-exp seq) (car seq)) 245 (define (rest-exps seq) (cdr seq)) 246 247 (define (sequence->exp seq) 248 (cond ((null? seq) seq) 249 ((last-exp? seq) (first-exp seq)) 250 (else (make-begin seq)))) 251 252 (define (make-begin seq) (cons 'begin seq)) 253 254 (define (application? exp) (pair? exp)) 255 (define (operator exp) (car exp)) 256 (define (operands exp) (cdr exp)) 257 (define (no-operands? ops) (null? ops)) 258 (define (first-operand ops) (car ops)) 259 (define (rest-operands ops) (cdr ops)) 260 261 (define (cond? exp) 262 (tagged-list? exp 'cond)) 263 (define (cond-clauses exp) (cdr exp)) 264 (define (cond-else-clause? clause) 265 (eq? (cond-predicate clause) 'else)) 266 (define (cond-predicate clause) 267 (car clause)) 268 (define (cond-actions clause) 269 (cdr clause)) 270 (define (cond->if exp) 271 (expand-clauses (cond-clauses exp))) 272 (define (expand-clauses clauses) 273 (match clauses 274 ('() 'false) 275 ((('else actions ...)) 276 (sequence->exp actions)) 277 ((('else actions ...) rest ...) 278 (error "ELSE clause isn't last: COND->IF" 279 clauses)) 280 (((predicate '=> recipient) rest ...) 281 `((lambda (value) 282 (if value 283 (,recipient value) 284 ,(expand-clauses rest))) 285 ,predicate)) 286 (((predicate actions ...) rest ...) 287 (make-if predicate 288 (sequence->exp actions) 289 (expand-clauses rest))) 290 (otherwise 291 (error "-- EXPAND-CLAUSES" clauses)))) 292 293 (define (let->combination exp) 294 (match exp 295 (('let (var-exps ...) 296 body ...) 297 (let ((vars (map car var-exps)) 298 (exps (map cadr var-exps))) 299 `((lambda ,vars 300 ,@body) 301 ,@exps))) 302 (('let name (var-exps ...) 303 body ...) 304 (let ((vars (map car var-exps)) 305 (exps (map cadr var-exps))) 306 `(let ((,name '())) 307 (set! ,name 308 (lambda ,vars 309 ,@body)) 310 (,name ,@exps)))))) 311 312 (define (let*->nested-lets exp) 313 (match exp 314 (('let* () 315 body ...) 316 (make-begin body)) 317 (`(let* ((,var ,exp) . ,rest-of-var-exps) 318 . ,body) 319 `(let ((,var ,exp)) 320 ,(let*->nested-lets 321 `(let* ,rest-of-var-exps 322 ,@body)))))) 323 324 ;;; end 4.1.2 325 326 ;;; 4.1.3 327 328 ;; XXX: By default, false's value is #f, which is the only true 329 ;; false. All others are fake and would have the truthitousness 330 ;; property. Consult `info r7rs-small` or `C-h 331 (define (true? x) 332 (not (eq? x false))) 333 334 (define (false? x) 335 (eq? x false)) 336 337 (define (make-procedure parameters body env) 338 (list 'procedure parameters body env)) 339 (define (compound-procedure? p) 340 (tagged-list? p 'procedure)) 341 (define (procedure-parameters p) (cadr p)) 342 (define (procedure-body p) (caddr p)) 343 (define (procedure-environment p) (cadddr p)) 344 345 (define (enclosing-environment env) (cdr env)) 346 (define (first-frame env) (car env)) 347 (define the-empty-environment '()) 348 349 (define (make-frame variables values) 350 (cons variables values)) 351 (define (frame-variables frame) (car frame)) 352 (define (frame-values frame) (cdr frame)) 353 (define (add-binding-to-frame! var val frame) 354 (set-car! frame (cons var (car frame))) 355 (set-cdr! frame (cons val (cdr frame)))) 356 357 (define (extend-environment vars vals base-env) 358 (if (= (length vars) (length vals)) 359 (cons (make-frame vars vals) base-env) 360 (if (< (length vars) (length vals)) 361 (error "Too many arguments supplied" 362 vars 363 vals) 364 (error "Too few arguments supplied" 365 vars 366 vals)))) 367 368 (define (lookup-variable-value var env) 369 (define (env-loop env) 370 (define (scan vars vals) 371 (cond ((null? vars) 372 (env-loop 373 (enclosing-environment env))) 374 ((eq? var (car vars)) 375 (car vals)) 376 (else (scan (cdr vars) 377 (cdr vals))))) 378 (if (eq? env the-empty-environment) 379 (error "Unbound variable -- LOOKUP-VARIABLE-VALUE" var) 380 (let ((frame (first-frame env))) 381 (scan (frame-variables frame) 382 (frame-values frame))))) 383 (env-loop env)) 384 385 (define (set-variable-value! var val env) 386 ;; XXX: Just trying to see what it would look like if I just used named lets. 387 ;; 388 ;; (let loop-over-environments ((env env)) 389 ;; (cond 390 ;; ((eq? env the-empty-enviornment) 391 ;; (error "Unbound variable: SET!" var)) 392 ;; (else 393 ;; (let ((frame (first-frame env))) 394 ;; (let loop-over-frame ((vars (frame-variables frame)) 395 ;; (vals (frame-values frame))) 396 ;; (cond 397 ;; ((null? vars) 398 ;; (loop-over-environments (enclosing-environment env))) 399 ;; ((eq? var (car vars)) 400 ;; (set-car! vals val)) 401 ;; (else 402 ;; (loop-over-frame ((cdr vars) 403 ;; (cdr vals)))))))))) 404 405 (define (env-loop env) 406 (define (scan vars vals) 407 (cond ((null? vars) 408 (env-loop 409 (enclosing-environment env))) 410 ((eq? var (car vars)) 411 (set-car! vals val)) 412 (else (scan (cdr vars) 413 (cdr vals))))) 414 (if (eq? env the-empty-environment) 415 (error "Unbound variable: SET!" var) 416 (let ((frame (first-frame env))) 417 (scan (frame-variables frame) 418 (frame-values frame))))) 419 (env-loop env)) 420 421 (define (define-variable! var val env) 422 "Add a new variable VAR with value VAL in the top frame of environment ENV. 423 424 If variable VAR already exists in the top frame, set VAR in the top 425 frame to VAL." 426 427 ;; We will CHANGE (why did I all uppercase "CHANGE" here? I 428 ;; don't remember. Maybe it is some sort of a joke?) only 429 ;; the first frame. 430 (let ((frame (first-frame env))) 431 (define (scan vars vals) 432 (cond ((null? vars) 433 (add-binding-to-frame! 434 var val frame)) 435 ((eq? var (car vars)) 436 (set-car! vals val)) 437 (else (scan (cdr vars) 438 (cdr vals))))) 439 (scan (frame-variables frame) 440 (frame-values frame)))) 441 442 ;;; 4.1.4 443 444 (define (setup-environment) 445 (let* (;; XXX: See bug below on the quoted (define 446 ;; primitive-procedures ...) 447 (primitive-procedures 448 (list (list 'car car) 449 (list 'cdr cdr) 450 (list 'cons cons) 451 (list 'null? null?) 452 (list '+ +) 453 (list '- -) 454 (list '* *) 455 (list '/ /) 456 (list '= =) 457 (list 'display display) 458 (list 'write write) 459 (list 'read read))) 460 (initial-env 461 (extend-environment 462 (primitive-procedure-names primitive-procedures) 463 (primitive-procedure-objects primitive-procedures) 464 the-empty-environment))) 465 (define-variable! 'true true initial-env) 466 (define-variable! 'false false initial-env) 467 initial-env)) 468 469 (define the-global-environment 470 (setup-environment)) 471 472 (define (primitive-procedure? proc) 473 (tagged-list? proc 'primitive)) 474 475 (define (primitive-implementation proc) 476 (cadr proc)) 477 478 ;; XXX: There is a bug here in SICP or GNU Guile or both. 479 ;; primitive-procedures is `#<unspecified>` when this library is 480 ;; being loaded. 481 '(define primitive-procedures 482 (list (list 'car car) 483 (list 'cdr cdr) 484 (list 'cons cons) 485 (list 'null? null?) 486 (list '+ +) 487 (list '- -) 488 (list '* *) 489 (list '/ /) 490 (list 'display display) 491 (list 'write write) 492 (list 'read read))) 493 494 (define (primitive-procedure-names primitive-procedures) 495 (map car 496 primitive-procedures)) 497 498 (define (primitive-procedure-objects primitive-procedures) 499 (map (lambda (proc) 500 (list 'primitive (cadr proc))) 501 primitive-procedures)) 502 503 (define (apply-primitive-procedure proc args) 504 (apply-in-underlying-scheme 505 (primitive-implementation proc) args)) 506 507 (define input-prompt ";;; M-Eval input:") 508 (define output-prompt ";;; M-Eval value:") 509 510 (define (driver-loop) 511 (prompt-for-input input-prompt) 512 (let ((input (read))) 513 (let ((output 514 (eval input 515 the-global-environment))) 516 (announce-output output-prompt) 517 (user-print output))) 518 (driver-loop)) 519 520 (define (prompt-for-input string) 521 (newline) (newline) 522 (display string) (newline)) 523 524 (define (announce-output string) 525 (newline) (display string) (newline)) 526 527 (define (user-print object) 528 (if (compound-procedure? object) 529 (display 530 (list 'compound-procedure 531 (procedure-parameters object) 532 (procedure-body object) 533 '<procedure-env>)) 534 (display object))) 535 536 ;; XXX: Already defined above: 537 ;; (define the-global-environment 538 ;; (setup-environment)) 539 540 (define (main args) 541 (match args 542 ('() 543 (error "Arguments should have something rather than nothing.")) 544 (`(,arg0) 545 (display arg0) 546 (newline)) 547 (`(,arg0 "--debug") 548 (display "DEBUG TURN ON!\n") 549 (set! *debug* #t)) 550 (args (error "Unknown arguments:" args))) 551 552 (driver-loop)) 553 554 (define (run-internal-tests) 555 (test-eq 1 556 (lookup-variable-value 'a 557 (extend-environment '(a +) 558 `(1 ,+) 559 the-empty-environment))) 560 (test-eq 1 561 (lookup-variable-value 'a 562 (extend-environment '(+ a) 563 `(,+ 1) 564 the-empty-environment))) 565 (test-eq + 566 (lookup-variable-value '+ 567 (extend-environment '(a +) 568 `(1 ,+) 569 the-empty-environment)))) 570 571 (add-form-handler! application? 572 (lambda (exp env) 573 (apply (eval (operator exp) env) 574 (list-of-values 575 (operands exp) 576 env)))) 577 (add-form-handler! (lambda (exp) 578 (tagged-list? exp 'or)) 579 (lambda (exp env) 580 (eval (let loop ((seq (cdr exp))) 581 (match seq 582 ('() 'false) 583 ((expression . rest) 584 (list (list 'lambda (list 'value) 585 (list 'if 586 'value 587 'value 588 (loop rest))) 589 expression)) 590 (otherwise 591 (error "Weird expression -- AND" 592 otherwise)))) 593 env))) 594 (add-form-handler! (lambda (exp) 595 (tagged-list? exp 'and)) 596 (lambda (exp env) 597 (eval (let loop ((seq (cdr exp))) 598 (match seq 599 ('() 'false) 600 ((expression) 601 `((lambda (value) 602 (if value 603 value 604 false)) 605 ,expression) 606 ) 607 ((expression . rest) 608 `((lambda (value) 609 (if value 610 ,(loop rest) 611 false)) 612 ,expression)) 613 (otherwise 614 (error "Weird expression -- AND" 615 otherwise)))) 616 env))) 617 (add-form-handler! cond? 618 (lambda (exp env) 619 (eval (cond->if exp) env))) 620 (add-form-handler! begin? 621 (lambda (exp env) 622 (eval-sequence 623 (begin-actions exp) 624 env))) 625 (add-form-handler! lambda? 626 (lambda (exp env) 627 (make-procedure (lambda-parameters exp) 628 (lambda-body exp) 629 env))) 630 (add-form-handler! if? eval-if) 631 (add-form-handler! definition? eval-definition) 632 (add-form-handler! assignment? eval-assignment) 633 (add-form-handler! quoted? (lambda (exp env) (text-of-quotation exp))) 634 (add-form-handler! (lambda (exp) (tagged-list? exp 'let)) 635 (lambda (exp env) 636 (eval (let->combination exp) env))) 637 (add-form-handler! (lambda (exp) (tagged-list? exp 'let*)) 638 (lambda (exp env) 639 (eval (let*->nested-lets exp) env))) 640 641 ))