exercise-13.scm (22424B)
1 (define-library (sicp solutions chapter-4 exercise-13) 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 (dpp (list exp env)) 103 (let ((value (cond ((self-evaluating? exp) 104 exp) 105 ((variable? exp) 106 (lookup-variable-value exp env)) 107 ((pair? exp) 108 ((get-form-handler exp) exp env)) 109 (else 110 (error "Unknown expression type -- EVAL" exp))))) 111 (dpp `(eval value: ,value)) 112 value)) 113 114 (define (apply procedure arguments) 115 (cond ((primitive-procedure? procedure) 116 (apply-primitive-procedure 117 procedure 118 arguments)) 119 ((compound-procedure? procedure) 120 (eval-sequence 121 (procedure-body procedure) 122 (extend-environment 123 (procedure-parameters 124 procedure) 125 arguments 126 (procedure-environment 127 procedure)))) 128 (else 129 (error "Unknown procedure type -- APPLY" 130 procedure)))) 131 132 ;;; Procedure arguments: 133 134 (define (list-of-values exps env) 135 (if (no-operands? exps) 136 '() 137 (cons (eval (first-operand exps) env) 138 (list-of-values (rest-operands exps) env)))) 139 140 ;;; Conditionals: 141 142 (define (eval-if exp env) 143 (if (true? (eval (if-predicate exp) env)) 144 (eval (if-consequent exp) env) 145 (eval (if-alternative exp) env))) 146 147 ;;; Sequences: 148 149 (define (eval-sequence exps env) 150 (cond ((last-exp? exps) 151 (eval (first-exp exps) env)) 152 (else 153 (eval (first-exp exps) env) 154 (eval-sequence (rest-exps exps) 155 env)))) 156 157 ;;; Assignments and definitions 158 159 (define (eval-assignment exp env) 160 (set-variable-value! 161 (assignment-variable exp) 162 (eval (assignment-value exp) env) 163 env) 164 'ok) 165 166 (define (eval-definition exp env) 167 (define-variable! 168 (definition-variable exp) 169 (eval (definition-value exp) env) 170 env) 171 'ok) 172 173 ;;; end 4.1.1 174 175 ;;; 4.1.2 176 177 178 (define (self-evaluating? exp) 179 (cond ((number? exp) true) 180 ((string? exp) true) 181 (else false))) 182 183 (define (variable? exp) (symbol? exp)) 184 185 (define (quoted? exp) 186 (tagged-list? exp 'quote)) 187 188 (define (text-of-quotation exp) 189 (cadr exp)) 190 191 (define (tagged-list? exp tag) 192 (if (pair? exp) 193 (eq? (car exp) tag) 194 false)) 195 196 (define (assignment? exp) 197 (tagged-list? exp 'set!)) 198 199 (define (assignment-variable exp) 200 (cadr exp)) 201 202 (define (assignment-value exp) (caddr exp)) 203 204 (define (definition? exp) 205 (tagged-list? exp 'define)) 206 207 (define (definition-variable exp) 208 (if (symbol? (cadr exp)) 209 (cadr exp) 210 (caadr exp))) 211 212 (define (definition-value exp) 213 (if (symbol? (cadr exp)) 214 (caddr exp) 215 (make-lambda 216 (cdadr exp) ; formal-parameters 217 (cddr exp)))) ; body 218 219 (define (lambda? exp) 220 (tagged-list? exp 'lambda)) 221 (define (lambda-parameters exp) (cadr exp)) 222 (define (lambda-body exp) (cddr exp)) 223 224 (define (make-lambda parameters body) 225 (cons 'lambda (cons parameters body))) 226 227 (define (if? exp) (tagged-list? exp 'if)) 228 (define (if-predicate exp) (cadr exp)) 229 (define (if-consequent exp) (caddr exp)) 230 (define (if-alternative exp) 231 (if (not (null? (cdddr exp))) 232 (cadddr exp) 233 'false)) 234 235 (define (make-if predicate 236 consequent 237 alternative) 238 (list 'if 239 predicate 240 consequent 241 alternative)) 242 243 (define (begin? exp) 244 (tagged-list? exp 'begin)) 245 (define (begin-actions exp) (cdr exp)) 246 (define (last-exp? seq) (null? (cdr seq))) 247 (define (first-exp seq) (car seq)) 248 (define (rest-exps seq) (cdr seq)) 249 250 (define (sequence->exp seq) 251 (cond ((null? seq) seq) 252 ((last-exp? seq) (first-exp seq)) 253 (else (make-begin seq)))) 254 255 (define (make-begin seq) (cons 'begin seq)) 256 257 (define (application? exp) (pair? exp)) 258 (define (operator exp) (car exp)) 259 (define (operands exp) (cdr exp)) 260 (define (no-operands? ops) (null? ops)) 261 (define (first-operand ops) (car ops)) 262 (define (rest-operands ops) (cdr ops)) 263 264 (define (cond? exp) 265 (tagged-list? exp 'cond)) 266 (define (cond-clauses exp) (cdr exp)) 267 (define (cond-else-clause? clause) 268 (eq? (cond-predicate clause) 'else)) 269 (define (cond-predicate clause) 270 (car clause)) 271 (define (cond-actions clause) 272 (cdr clause)) 273 (define (cond->if exp) 274 (expand-clauses (cond-clauses exp))) 275 (define (expand-clauses clauses) 276 (match clauses 277 ('() 'false) 278 ((('else actions ...)) 279 (sequence->exp actions)) 280 ((('else actions ...) rest ...) 281 (error "ELSE clause isn't last: COND->IF" 282 clauses)) 283 (((predicate '=> recipient) rest ...) 284 `((lambda (value) 285 (if value 286 (,recipient value) 287 ,(expand-clauses rest))) 288 ,predicate)) 289 (((predicate actions ...) rest ...) 290 (make-if predicate 291 (sequence->exp actions) 292 (expand-clauses rest))) 293 (otherwise 294 (error "-- EXPAND-CLAUSES" clauses)))) 295 296 (define (let->combination exp) 297 (match exp 298 (('let (var-exps ...) 299 body ...) 300 (let ((vars (map car var-exps)) 301 (exps (map cadr var-exps))) 302 `((lambda ,vars 303 ,@body) 304 ,@exps))) 305 (('let name (var-exps ...) 306 body ...) 307 (let ((vars (map car var-exps)) 308 (exps (map cadr var-exps))) 309 `(let ((,name '())) 310 (set! ,name 311 (lambda ,vars 312 ,@body)) 313 (,name ,@exps)))))) 314 315 (define (let*->nested-lets exp) 316 (match exp 317 (('let* () 318 body ...) 319 (make-begin body)) 320 (`(let* ((,var ,exp) . ,rest-of-var-exps) 321 . ,body) 322 `(let ((,var ,exp)) 323 ,(let*->nested-lets 324 `(let* ,rest-of-var-exps 325 ,@body)))))) 326 327 ;;; end 4.1.2 328 329 ;;; 4.1.3 330 331 ;; XXX: By default, false's value is #f, which is the only true 332 ;; false. All others are fake and would have the truthitousness 333 ;; property. Consult `info r7rs-small` or `C-h 334 (define (true? x) 335 (not (eq? x false))) 336 337 (define (false? x) 338 (eq? x false)) 339 340 (define (make-procedure parameters body env) 341 (list 'procedure parameters body env)) 342 (define (compound-procedure? p) 343 (tagged-list? p 'procedure)) 344 (define (procedure-parameters p) (cadr p)) 345 (define (procedure-body p) (caddr p)) 346 (define (procedure-environment p) (cadddr p)) 347 348 (define (enclosing-environment env) (cdr env)) 349 (define (first-frame env) (car env)) 350 (define the-empty-environment '()) 351 352 (define (make-frame variables values) 353 (let loop ((variables variables) 354 (values values) 355 (frame '(frame))) 356 (match (list variables values) 357 ('(() ()) (reverse frame)) 358 (((variable rest-of-variables ...) (value rest-of-values ...)) 359 (loop rest-of-variables 360 rest-of-values 361 (alist-cons variable 362 value 363 frame)))))) 364 (define (frame-variables frame) (map car (cdr frame))) 365 (define (frame-values frame) (map cdr (cdr frame))) 366 (define (add-binding-to-frame! var val frame) 367 (set-cdr! frame (alist-cons var 368 val 369 (cdr frame)))) 370 (define (get-frame-variable-value var frame) 371 (assoc var (cdr frame) eq?)) 372 (define (set-frame-variable-value! var val frame) 373 (match (get-frame-variable-value var frame) 374 (#f 375 (set-cdr! frame 376 (alist-cons var 377 val 378 (cdr frame)))) 379 (pair 380 (set-cdr! pair 381 val)))) 382 383 (define (extend-environment vars vals base-env) 384 (if (= (length vars) (length vals)) 385 (cons (make-frame vars vals) base-env) 386 (if (< (length vars) (length vals)) 387 (error "Too many arguments supplied" 388 vars 389 vals) 390 (error "Too few arguments supplied" 391 vars 392 vals)))) 393 394 (define (lookup-variable-value var env) 395 (dpp `(,var ,env)) 396 (define (env-loop env) 397 (if (eq? env the-empty-environment) 398 (error "Unbound variable -- LOOKUP-VARIABLE-VALUE" var) 399 (let ((frame (first-frame env))) 400 (match (get-frame-variable-value var 401 frame) 402 (#f 403 (env-loop (enclosing-environment env))) 404 ((existing-var . existing-val) 405 existing-val))))) 406 (env-loop env)) 407 408 (define (set-variable-value! var val env) 409 ;; XXX: Just trying to see what it would look like if I just used named lets. 410 ;; 411 ;; (let loop-over-environments ((env env)) 412 ;; (cond 413 ;; ((eq? env the-empty-enviornment) 414 ;; (error "Unbound variable: SET!" var)) 415 ;; (else 416 ;; (let ((frame (first-frame env))) 417 ;; (let loop-over-frame ((vars (frame-variables frame)) 418 ;; (vals (frame-values frame))) 419 ;; (cond 420 ;; ((null? vars) 421 ;; (loop-over-environments (enclosing-environment env))) 422 ;; ((eq? var (car vars)) 423 ;; (set-car! vals val)) 424 ;; (else 425 ;; (loop-over-frame ((cdr vars) 426 ;; (cdr vals)))))))))) 427 428 (dpp `(before set-variable-value! ,var ,val ,env)) 429 (let env-loop ((env env)) 430 (cond 431 ((eq? env the-empty-environment) 432 (error "Unbound variable: SET!" var)) 433 (else 434 (let ((frame (first-frame env))) 435 (match (get-frame-variable-value var frame) 436 (#f 437 (env-loop (enclosing-environment env))) 438 (pair 439 (set-cdr! pair val))))))) 440 (dpp `(after set-variable-value! ,var ,val ,env))) 441 442 (define (define-variable! var val env) 443 "Add a new variable VAR with value VAL in the top frame of environment ENV. 444 445 If variable VAR already exists in the top frame, set VAR in the top 446 frame to VAL." 447 448 ;; We will CHANGE (why did I all uppercase "CHANGE" here? I 449 ;; don't remember. Maybe it is some sort of a joke?) only 450 ;; the first frame. 451 (let ((frame (first-frame env))) 452 (match (get-frame-variable-value var frame) 453 (#f 454 (add-binding-to-frame! var 455 val 456 frame)) 457 (pair 458 (set-cdr! pair 459 val))))) 460 461 (define (make-unbound! var env) 462 (cond 463 ((eq? env 464 the-empty-environment) 465 #f) 466 (else 467 (let ((frame (first-frame env))) 468 (let loop ((frame-alist (cdr frame)) 469 (new-frame '(frame)) 470 (hit #f)) 471 (cond 472 ((null? frame-alist) 473 (cond 474 (hit hit) 475 (else (make-unbound! var 476 (enclosing-environment env))))) 477 ((eq? (car frame-alist) 478 var) 479 (loop (cdr frame-alist) 480 new-frame 481 #t)) 482 (else 483 (loop (cdr frame-alist) 484 (cons (car frame-alist) 485 new-frame) 486 hit)))))))) 487 488 ;;; 4.1.4 489 490 (define (setup-environment) 491 (let* ( ;; XXX: See bug below on the quoted (define 492 ;; primitive-procedures ...) 493 (primitive-procedures 494 (list (list 'car car) 495 (list 'cdr cdr) 496 (list 'cons cons) 497 (list 'null? null?) 498 (list '+ +) 499 (list '- -) 500 (list '* *) 501 (list '/ /) 502 (list '= =) 503 (list 'display display) 504 (list 'write write) 505 (list 'read read))) 506 (initial-env 507 (extend-environment 508 (primitive-procedure-names primitive-procedures) 509 (primitive-procedure-objects primitive-procedures) 510 the-empty-environment))) 511 (dpp initial-env) 512 (define-variable! 'true true initial-env) 513 (define-variable! 'false false initial-env) 514 (dpp initial-env) 515 initial-env)) 516 517 (define the-global-environment 518 (setup-environment)) 519 520 (define (primitive-procedure? proc) 521 (tagged-list? proc 'primitive)) 522 523 (define (primitive-implementation proc) 524 (cadr proc)) 525 526 ;; XXX: There is a bug here in SICP or GNU Guile or both. 527 ;; primitive-procedures is `#<unspecified>` when this library is 528 ;; being loaded. 529 '(define primitive-procedures 530 (list (list 'car car) 531 (list 'cdr cdr) 532 (list 'cons cons) 533 (list 'null? null?) 534 (list '+ +) 535 (list '- -) 536 (list '* *) 537 (list '/ /) 538 (list 'display display) 539 (list 'write write) 540 (list 'read read))) 541 542 (define (primitive-procedure-names primitive-procedures) 543 (map car 544 primitive-procedures)) 545 546 (define (primitive-procedure-objects primitive-procedures) 547 (map (lambda (proc) 548 (list 'primitive (cadr proc))) 549 primitive-procedures)) 550 551 (define (apply-primitive-procedure proc args) 552 (apply-in-underlying-scheme 553 (primitive-implementation proc) args)) 554 555 (define input-prompt ";;; M-Eval input:") 556 (define output-prompt ";;; M-Eval value:") 557 558 (define (driver-loop) 559 (prompt-for-input input-prompt) 560 (let ((input (read))) 561 (let ((output 562 (eval input 563 the-global-environment))) 564 (announce-output output-prompt) 565 (user-print output))) 566 (driver-loop)) 567 568 (define (prompt-for-input string) 569 (newline) (newline) 570 (display string) (newline)) 571 572 (define (announce-output string) 573 (newline) (display string) (newline)) 574 575 (define (user-print object) 576 (if (compound-procedure? object) 577 (display 578 (list 'compound-procedure 579 (procedure-parameters object) 580 (procedure-body object) 581 '<procedure-env>)) 582 (display object))) 583 584 ;; XXX: Already defined above: 585 ;; (define the-global-environment 586 ;; (setup-environment)) 587 588 (define (main args) 589 (match args 590 ('() 591 (error "Arguments should have something rather than nothing.")) 592 (`(,arg0) 593 (display arg0) 594 (newline)) 595 (`(,arg0 "--debug") 596 (display "DEBUG TURN ON!\n") 597 (set! *debug* #t)) 598 (args (error "Unknown arguments:" args))) 599 600 (driver-loop)) 601 602 (define (run-internal-tests) 603 (test-eq 1 604 (lookup-variable-value 'a 605 (extend-environment '(a +) 606 `(1 ,+) 607 the-empty-environment))) 608 (test-eq 1 609 (lookup-variable-value 'a 610 (extend-environment '(+ a) 611 `(,+ 1) 612 the-empty-environment))) 613 (test-eq + 614 (lookup-variable-value '+ 615 (extend-environment '(a +) 616 `(1 ,+) 617 the-empty-environment)))) 618 619 (add-form-handler! application? 620 (lambda (exp env) 621 (apply (eval (operator exp) env) 622 (list-of-values 623 (operands exp) 624 env)))) 625 (add-form-handler! (lambda (exp) 626 (tagged-list? exp 'or)) 627 (lambda (exp env) 628 (eval (let loop ((seq (cdr exp))) 629 (match seq 630 ('() 'false) 631 ((expression . rest) 632 (list (list 'lambda (list 'value) 633 (list 'if 634 'value 635 'value 636 (loop rest))) 637 expression)) 638 (otherwise 639 (error "Weird expression -- AND" 640 otherwise)))) 641 env))) 642 (add-form-handler! (lambda (exp) 643 (tagged-list? exp 'and)) 644 (lambda (exp env) 645 (eval (let loop ((seq (cdr exp))) 646 (match seq 647 ('() 'false) 648 ((expression) 649 `((lambda (value) 650 (if value 651 value 652 false)) 653 ,expression) 654 ) 655 ((expression . rest) 656 `((lambda (value) 657 (if value 658 ,(loop rest) 659 false)) 660 ,expression)) 661 (otherwise 662 (error "Weird expression -- AND" 663 otherwise)))) 664 env))) 665 (add-form-handler! cond? 666 (lambda (exp env) 667 (eval (cond->if exp) env))) 668 (add-form-handler! begin? 669 (lambda (exp env) 670 (eval-sequence 671 (begin-actions exp) 672 env))) 673 (add-form-handler! lambda? 674 (lambda (exp env) 675 (make-procedure (lambda-parameters exp) 676 (lambda-body exp) 677 env))) 678 (add-form-handler! if? eval-if) 679 (add-form-handler! definition? eval-definition) 680 (add-form-handler! assignment? eval-assignment) 681 (add-form-handler! quoted? (lambda (exp env) (text-of-quotation exp))) 682 (add-form-handler! (lambda (exp) (tagged-list? exp 'let)) 683 (lambda (exp env) 684 (eval (let->combination exp) env))) 685 (add-form-handler! (lambda (exp) (tagged-list? exp 'let*)) 686 (lambda (exp env) 687 (eval (let*->nested-lets exp) env))) 688 689 ))