exercise-2.scm (16952B)
1 (define-library (sicp solutions chapter-4 exercise-2) 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 (eval exp env) 84 (cond ((self-evaluating? exp) 85 exp) 86 ((variable? exp) 87 (lookup-variable-value exp env)) 88 ((quoted? exp) 89 (text-of-quotation exp)) 90 ;; XXX: Exercise 4.2.b. 91 ((application? exp) 92 (apply (eval (operator exp) env) 93 (list-of-values 94 (operands exp) 95 env))) 96 ((assignment? exp) 97 (eval-assignment exp env)) 98 ((definition? exp) 99 (eval-definition exp env)) 100 ((if? exp) 101 (eval-if exp env)) 102 ((lambda? exp) 103 (make-procedure 104 (lambda-parameters exp) 105 (lambda-body exp) 106 env)) 107 ((begin? exp) 108 (eval-sequence 109 (begin-actions exp) 110 env)) 111 ((cond? exp) 112 (eval (cond->if exp) env)) 113 (else 114 (error "Unknown expression type -- EVAL" exp)))) 115 116 (define (apply procedure arguments) 117 (cond ((primitive-procedure? procedure) 118 (apply-primitive-procedure 119 procedure 120 arguments)) 121 ((compound-procedure? procedure) 122 (eval-sequence 123 (procedure-body procedure) 124 (extend-environment 125 (procedure-parameters 126 procedure) 127 arguments 128 (procedure-environment 129 procedure)))) 130 (else 131 (error "Unknown procedure type -- APPLY" 132 procedure)))) 133 134 ;;; Procedure arguments: 135 136 ;; XXX: Does not change in exercise 4.2.b. . 137 (define (list-of-values exps env) 138 (if (no-operands? exps) 139 '() 140 (cons (eval (first-operand exps) env) 141 (list-of-values (rest-operands exps) env)))) 142 143 ;;; Conditionals: 144 145 (define (eval-if exp env) 146 (if (true? (eval (if-predicate exp) env)) 147 (eval (if-consequent exp) env) 148 (eval (if-alternative exp) env))) 149 150 ;;; Sequences: 151 152 (define (eval-sequence exps env) 153 (cond ((last-exp? exps) 154 (eval (first-exp exps) env)) 155 (else 156 (eval (first-exp exps) env) 157 (eval-sequence (rest-exps exps) 158 env)))) 159 160 ;;; Assignments and definitions 161 162 (define (eval-assignment exp env) 163 (set-variable-value! 164 (assignment-variable exp) 165 (eval (assignment-value exp) env) 166 env) 167 'ok) 168 169 (define (eval-definition exp env) 170 (define-variable! 171 (definition-variable exp) 172 (eval (definition-value exp) env) 173 env) 174 'ok) 175 176 ;;; end 4.1.1 177 178 ;;; 4.1.2 179 180 181 (define (self-evaluating? exp) 182 (cond ((number? exp) true) 183 ((string? exp) true) 184 (else false))) 185 186 (define (variable? exp) (symbol? exp)) 187 188 (define (quoted? exp) 189 (tagged-list? exp 'quote)) 190 191 (define (text-of-quotation exp) 192 (cadr exp)) 193 194 (define (tagged-list? exp tag) 195 (if (pair? exp) 196 (eq? (car exp) tag) 197 false)) 198 199 (define (assignment? exp) 200 (tagged-list? exp 'set!)) 201 202 (define (assignment-variable exp) 203 (cadr exp)) 204 205 (define (assignment-value exp) (caddr exp)) 206 207 (define (definition? exp) 208 (tagged-list? exp 'define)) 209 210 (define (definition-variable exp) 211 (if (symbol? (cadr exp)) 212 (cadr exp) 213 (caadr exp))) 214 215 (define (definition-value exp) 216 (if (symbol? (cadr exp)) 217 (caddr exp) 218 (make-lambda 219 (cdadr exp) ; formal-parameters 220 (cddr exp)))) ; body 221 222 (define (lambda? exp) 223 (tagged-list? exp 'lambda)) 224 (define (lambda-parameters exp) (cadr exp)) 225 (define (lambda-body exp) (cddr exp)) 226 227 (define (make-lambda parameters body) 228 (cons 'lambda (cons parameters body))) 229 230 (define (if? exp) (tagged-list? exp 'if)) 231 (define (if-predicate exp) (cadr exp)) 232 (define (if-consequent exp) (caddr exp)) 233 (define (if-alternative exp) 234 (if (not (null? (cdddr exp))) 235 (cadddr exp) 236 'false)) 237 238 (define (make-if predicate 239 consequent 240 alternative) 241 (list 'if 242 predicate 243 consequent 244 alternative)) 245 246 (define (begin? exp) 247 (tagged-list? exp 'begin)) 248 (define (begin-actions exp) (cdr exp)) 249 (define (last-exp? seq) (null? (cdr seq))) 250 (define (first-exp seq) (car seq)) 251 (define (rest-exps seq) (cdr seq)) 252 253 (define (sequence->exp seq) 254 (cond ((null? seq) seq) 255 ((last-exp? seq) (first-exp seq)) 256 (else (make-begin seq)))) 257 258 (define (make-begin seq) (cons 'begin seq)) 259 260 ;; Exercise 4.2.b. answer: 261 (define (application? exp) (tagged-list? exp 'call)) 262 (define (operator exp) (cadr exp)) 263 (define (operands exp) (cddr exp)) 264 ;; XXX: In exercise 4.2.b. `no-operands?`, `first-operand`, 265 ;; `rest-operands`, and `list-of-values` do not change because the 266 ;; representation of operands does not change. 267 (define (no-operands? ops) (null? ops)) 268 (define (first-operand ops) (car ops)) 269 (define (rest-operands ops) (cdr ops)) 270 271 (define (cond? exp) 272 (tagged-list? exp 'cond)) 273 (define (cond-clauses exp) (cdr exp)) 274 (define (cond-else-clause? clause) 275 (eq? (cond-predicate clause) 'else)) 276 (define (cond-predicate clause) 277 (car clause)) 278 (define (cond-actions clause) 279 (cdr clause)) 280 (define (cond->if exp) 281 (expand-clauses (cond-clauses exp))) 282 (define (expand-clauses clauses) 283 (if (null? clauses) 284 'false 285 (let ((first (car clauses)) 286 (rest (cdr clauses))) 287 (if (cond-else-clause? first) 288 (if (null? rest) 289 (sequence->exp 290 (cond-actions first)) 291 (error "ELSE clause isn't last: COND->IF" 292 clauses)) 293 (make-if (cond-predicate first) 294 (sequence->exp 295 (cond-actions first)) 296 (expand-clauses 297 rest)))))) 298 299 ;;; end 4.1.2 300 301 ;;; 4.1.3 302 303 ;; XXX: By default, false's value is #f, which is the only true 304 ;; false. All others are fake and would have the truthitousness 305 ;; property. Consult `info r7rs-small` or `C-h 306 (define (true? x) 307 (not (eq? x false))) 308 309 (define (false? x) 310 (eq? x false)) 311 312 (define (make-procedure parameters body env) 313 (list 'procedure parameters body env)) 314 (define (compound-procedure? p) 315 (tagged-list? p 'procedure)) 316 (define (procedure-parameters p) (cadr p)) 317 (define (procedure-body p) (caddr p)) 318 (define (procedure-environment p) (cadddr p)) 319 320 (define (enclosing-environment env) (cdr env)) 321 (define (first-frame env) (car env)) 322 (define the-empty-environment '()) 323 324 (define (make-frame variables values) 325 (cons variables values)) 326 (define (frame-variables frame) (car frame)) 327 (define (frame-values frame) (cdr frame)) 328 (define (add-binding-to-frame! var val frame) 329 (set-car! frame (cons var (car frame))) 330 (set-cdr! frame (cons val (cdr frame)))) 331 332 (define (extend-environment vars vals base-env) 333 (if (= (length vars) (length vals)) 334 (cons (make-frame vars vals) base-env) 335 (if (< (length vars) (length vals)) 336 (error "Too many arguments supplied" 337 vars 338 vals) 339 (error "Too few arguments supplied" 340 vars 341 vals)))) 342 343 (define (lookup-variable-value var env) 344 (define (env-loop env) 345 (define (scan vars vals) 346 (cond ((null? vars) 347 (env-loop 348 (enclosing-environment env))) 349 ((eq? var (car vars)) 350 (car vals)) 351 (else (scan (cdr vars) 352 (cdr vals))))) 353 (if (eq? env the-empty-environment) 354 (error "Unbound variable" var) 355 (let ((frame (first-frame env))) 356 (scan (frame-variables frame) 357 (frame-values frame))))) 358 (env-loop env)) 359 360 (define (set-variable-value! var val env) 361 ;; XXX: Just trying to see what it would look like if I just used named lets. 362 ;; 363 ;; (let loop-over-environments ((env env)) 364 ;; (cond 365 ;; ((eq? env the-empty-enviornment) 366 ;; (error "Unbound variable: SET!" var)) 367 ;; (else 368 ;; (let ((frame (first-frame env))) 369 ;; (let loop-over-frame ((vars (frame-variables frame)) 370 ;; (vals (frame-values frame))) 371 ;; (cond 372 ;; ((null? vars) 373 ;; (loop-over-environments (enclosing-environment env))) 374 ;; ((eq? var (car vars)) 375 ;; (set-car! vals val)) 376 ;; (else 377 ;; (loop-over-frame ((cdr vars) 378 ;; (cdr vals)))))))))) 379 380 (define (env-loop env) 381 (define (scan vars vals) 382 (cond ((null? vars) 383 (env-loop 384 (enclosing-environment env))) 385 ((eq? var (car vars)) 386 (set-car! vals val)) 387 (else (scan (cdr vars) 388 (cdr vals))))) 389 (if (eq? env the-empty-environment) 390 (error "Unbound variable: SET!" var) 391 (let ((frame (first-frame env))) 392 (scan (frame-variables frame) 393 (frame-values frame))))) 394 (env-loop env)) 395 396 (define (define-variable! var val env) 397 "Add a new variable VAR with value VAL in the top frame of environment ENV. 398 399 If variable VAR already exists in the top frame, set VAR in the top 400 frame to VAL." 401 402 ;; We will CHANGE (why did I all uppercase "CHANGE" here? I 403 ;; don't remember. Maybe it is some sort of a joke?) only 404 ;; the first frame. 405 (let ((frame (first-frame env))) 406 (define (scan vars vals) 407 (cond ((null? vars) 408 (add-binding-to-frame! 409 var val frame)) 410 ((eq? var (car vars)) 411 (set-car! vals val)) 412 (else (scan (cdr vars) 413 (cdr vals))))) 414 (scan (frame-variables frame) 415 (frame-values frame)))) 416 417 ;;; 4.1.4 418 419 (define (setup-environment) 420 (dpp 'moo) 421 (let* (;; XXX: See bug below on the quoted (define 422 ;; primitive-procedures ...) 423 (primitive-procedures 424 (list (list 'car car) 425 (list 'cdr cdr) 426 (list 'cons cons) 427 (list 'null? null?) 428 (list '+ +) 429 (list '- -) 430 (list '* *) 431 (list '/ /) 432 (list '= =) 433 (list 'display display) 434 (list 'write write) 435 (list 'read read))) 436 (initial-env 437 (extend-environment 438 (primitive-procedure-names primitive-procedures) 439 (primitive-procedure-objects primitive-procedures) 440 the-empty-environment))) 441 (define-variable! 'true true initial-env) 442 (define-variable! 'false false initial-env) 443 initial-env)) 444 445 (define the-global-environment 446 (begin 447 (dpp 'moo) 448 (setup-environment))) 449 450 (define (primitive-procedure? proc) 451 (tagged-list? proc 'primitive)) 452 453 (define (primitive-implementation proc) 454 (cadr proc)) 455 456 ;; XXX: There is a bug here in SICP or GNU Guile or both. 457 ;; primitive-procedures is `#<unspecified>` when this library is 458 ;; being loaded. 459 '(define primitive-procedures 460 (list (list 'car car) 461 (list 'cdr cdr) 462 (list 'cons cons) 463 (list 'null? null?) 464 (list '+ +) 465 (list '- -) 466 (list '* *) 467 (list '/ /) 468 (list 'display display) 469 (list 'write write) 470 (list 'read read))) 471 472 (define (primitive-procedure-names primitive-procedures) 473 (map car 474 primitive-procedures)) 475 476 (define (primitive-procedure-objects primitive-procedures) 477 (map (lambda (proc) 478 (list 'primitive (cadr proc))) 479 primitive-procedures)) 480 481 (define (apply-primitive-procedure proc args) 482 (apply-in-underlying-scheme 483 (primitive-implementation proc) args)) 484 485 (define input-prompt ";;; M-Eval input:") 486 (define output-prompt ";;; M-Eval value:") 487 488 (define (driver-loop) 489 (prompt-for-input input-prompt) 490 (let ((input (read))) 491 (let ((output 492 (eval input 493 the-global-environment))) 494 (announce-output output-prompt) 495 (user-print output))) 496 (driver-loop)) 497 498 (define (prompt-for-input string) 499 (newline) (newline) 500 (display string) (newline)) 501 502 (define (announce-output string) 503 (newline) (display string) (newline)) 504 505 (define (user-print object) 506 (if (compound-procedure? object) 507 (display 508 (list 'compound-procedure 509 (procedure-parameters object) 510 (procedure-body object) 511 '<procedure-env>)) 512 (display object))) 513 514 ;; XXX: Already defined above: 515 ;; (define the-global-environment 516 ;; (setup-environment)) 517 518 (define (main args) 519 (match args 520 ('() 521 (error "Arguments should have something rather than nothing.")) 522 (`(,arg0) 523 (display arg0) 524 (newline)) 525 (`(,arg0 "--debug") 526 (display "DEBUG TURN ON!\n") 527 (set! *debug* #t)) 528 (args (error "Unknown arguments:" args))) 529 530 (driver-loop)) 531 532 (define (run-internal-tests) 533 (test-eq 1 534 (lookup-variable-value 'a 535 (extend-environment '(a +) 536 `(1 ,+) 537 the-empty-environment))) 538 (test-eq 1 539 (lookup-variable-value 'a 540 (extend-environment '(+ a) 541 `(,+ 1) 542 the-empty-environment))) 543 (test-eq + 544 (lookup-variable-value '+ 545 (extend-environment '(a +) 546 `(1 ,+) 547 the-empty-environment)))) 548 549 ))