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