exercise-1-left-to-right.scm (16705B)
1 (define-library (sicp solutions chapter-4 exercise-1-left-to-right) 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 ((assignment? exp) 91 (eval-assignment exp env)) 92 ((definition? exp) 93 (eval-definition exp env)) 94 ((if? exp) 95 (eval-if exp env)) 96 ((lambda? exp) 97 (make-procedure 98 (lambda-parameters exp) 99 (lambda-body exp) 100 env)) 101 ((begin? exp) 102 (eval-sequence 103 (begin-actions exp) 104 env)) 105 ((cond? exp) 106 (eval (cond->if exp) env)) 107 ((application? exp) 108 (apply (eval (operator exp) env) 109 (list-of-values 110 (operands exp) 111 env))) 112 (else 113 (error "Unknown expression type -- EVAL" exp)))) 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 ;;; Exercise 4.1. 136 (define (list-of-values exps env) 137 (if (no-operands? exps) 138 '() 139 (let ((left (eval (first-operand exps) env))) 140 (cons left 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 (define (application? exp) (pair? exp)) 261 (define (operator exp) (car exp)) 262 (define (operands exp) (cdr exp)) 263 (define (no-operands? ops) (null? ops)) 264 (define (first-operand ops) (car ops)) 265 (define (rest-operands ops) (cdr ops)) 266 267 (define (cond? exp) 268 (tagged-list? exp 'cond)) 269 (define (cond-clauses exp) (cdr exp)) 270 (define (cond-else-clause? clause) 271 (eq? (cond-predicate clause) 'else)) 272 (define (cond-predicate clause) 273 (car clause)) 274 (define (cond-actions clause) 275 (cdr clause)) 276 (define (cond->if exp) 277 (expand-clauses (cond-clauses exp))) 278 (define (expand-clauses clauses) 279 (if (null? clauses) 280 'false 281 (let ((first (car clauses)) 282 (rest (cdr clauses))) 283 (if (cond-else-clause? first) 284 (if (null? rest) 285 (sequence->exp 286 (cond-actions first)) 287 (error "ELSE clause isn't last: COND->IF" 288 clauses)) 289 (make-if (cond-predicate first) 290 (sequence->exp 291 (cond-actions first)) 292 (expand-clauses 293 rest)))))) 294 295 ;;; end 4.1.2 296 297 ;;; 4.1.3 298 299 ;; XXX: By default, false's value is #f, which is the only true 300 ;; false. All others are fake and would have the truthitousness 301 ;; property. Consult `info r7rs-small` or `C-h 302 (define (true? x) 303 (not (eq? x false))) 304 305 (define (false? x) 306 (eq? x false)) 307 308 (define (make-procedure parameters body env) 309 (list 'procedure parameters body env)) 310 (define (compound-procedure? p) 311 (tagged-list? p 'procedure)) 312 (define (procedure-parameters p) (cadr p)) 313 (define (procedure-body p) (caddr p)) 314 (define (procedure-environment p) (cadddr p)) 315 316 (define (enclosing-environment env) (cdr env)) 317 (define (first-frame env) (car env)) 318 (define the-empty-environment '()) 319 320 (define (make-frame variables values) 321 (cons variables values)) 322 (define (frame-variables frame) (car frame)) 323 (define (frame-values frame) (cdr frame)) 324 (define (add-binding-to-frame! var val frame) 325 (set-car! frame (cons var (car frame))) 326 (set-cdr! frame (cons val (cdr frame)))) 327 328 (define (extend-environment vars vals base-env) 329 (if (= (length vars) (length vals)) 330 (cons (make-frame vars vals) base-env) 331 (if (< (length vars) (length vals)) 332 (error "Too many arguments supplied" 333 vars 334 vals) 335 (error "Too few arguments supplied" 336 vars 337 vals)))) 338 339 (define (lookup-variable-value var env) 340 (define (env-loop env) 341 (define (scan vars vals) 342 (cond ((null? vars) 343 (env-loop 344 (enclosing-environment env))) 345 ((eq? var (car vars)) 346 (car vals)) 347 (else (scan (cdr vars) 348 (cdr vals))))) 349 (if (eq? env the-empty-environment) 350 (error "Unbound variable" var) 351 (let ((frame (first-frame env))) 352 (scan (frame-variables frame) 353 (frame-values frame))))) 354 (env-loop env)) 355 356 (define (set-variable-value! var val env) 357 ;; XXX: Just trying to see what it would look like if I just used named lets. 358 ;; 359 ;; (let loop-over-environments ((env env)) 360 ;; (cond 361 ;; ((eq? env the-empty-enviornment) 362 ;; (error "Unbound variable: SET!" var)) 363 ;; (else 364 ;; (let ((frame (first-frame env))) 365 ;; (let loop-over-frame ((vars (frame-variables frame)) 366 ;; (vals (frame-values frame))) 367 ;; (cond 368 ;; ((null? vars) 369 ;; (loop-over-environments (enclosing-environment env))) 370 ;; ((eq? var (car vars)) 371 ;; (set-car! vals val)) 372 ;; (else 373 ;; (loop-over-frame ((cdr vars) 374 ;; (cdr vals)))))))))) 375 376 (define (env-loop env) 377 (define (scan vars vals) 378 (cond ((null? vars) 379 (env-loop 380 (enclosing-environment env))) 381 ((eq? var (car vars)) 382 (set-car! vals val)) 383 (else (scan (cdr vars) 384 (cdr vals))))) 385 (if (eq? env the-empty-environment) 386 (error "Unbound variable: SET!" var) 387 (let ((frame (first-frame env))) 388 (scan (frame-variables frame) 389 (frame-values frame))))) 390 (env-loop env)) 391 392 (define (define-variable! var val env) 393 "Add a new variable VAR with value VAL in the top frame of environment ENV. 394 395 If variable VAR already exists in the top frame, set VAR in the top 396 frame to VAL." 397 398 ;; We will CHANGE (why did I all uppercase "CHANGE" here? I 399 ;; don't remember. Maybe it is some sort of a joke?) only 400 ;; the first frame. 401 (let ((frame (first-frame env))) 402 (define (scan vars vals) 403 (cond ((null? vars) 404 (add-binding-to-frame! 405 var val frame)) 406 ((eq? var (car vars)) 407 (set-car! vals val)) 408 (else (scan (cdr vars) 409 (cdr vals))))) 410 (scan (frame-variables frame) 411 (frame-values frame)))) 412 413 ;;; 4.1.4 414 415 (define (setup-environment) 416 (dpp 'moo) 417 (let* (;; XXX: See bug below on the quoted (define 418 ;; primitive-procedures ...) 419 (primitive-procedures 420 (list (list 'car car) 421 (list 'cdr cdr) 422 (list 'cons cons) 423 (list 'null? null?) 424 (list '+ +) 425 (list '- -) 426 (list '* *) 427 (list '/ /) 428 (list '= =) 429 (list 'display display) 430 (list 'write write) 431 (list 'read read))) 432 (initial-env 433 (extend-environment 434 (primitive-procedure-names primitive-procedures) 435 (primitive-procedure-objects primitive-procedures) 436 the-empty-environment))) 437 (define-variable! 'true true initial-env) 438 (define-variable! 'false false initial-env) 439 initial-env)) 440 441 (define the-global-environment 442 (begin 443 (dpp 'moo) 444 (setup-environment))) 445 446 (define (primitive-procedure? proc) 447 (tagged-list? proc 'primitive)) 448 449 (define (primitive-implementation proc) 450 (cadr proc)) 451 452 ;; XXX: There is a bug here in SICP or GNU Guile or both. 453 ;; primitive-procedures is `#<unspecified>` when this library is 454 ;; being loaded. 455 '(define primitive-procedures 456 (list (list 'car car) 457 (list 'cdr cdr) 458 (list 'cons cons) 459 (list 'null? null?) 460 (list '+ +) 461 (list '- -) 462 (list '* *) 463 (list '/ /) 464 (list 'display display) 465 (list 'write write) 466 (list 'read read))) 467 468 (define (primitive-procedure-names primitive-procedures) 469 (map car 470 primitive-procedures)) 471 472 (define (primitive-procedure-objects primitive-procedures) 473 (map (lambda (proc) 474 (list 'primitive (cadr proc))) 475 primitive-procedures)) 476 477 (define (apply-primitive-procedure proc args) 478 (apply-in-underlying-scheme 479 (primitive-implementation proc) args)) 480 481 (define input-prompt ";;; M-Eval input:") 482 (define output-prompt ";;; M-Eval value:") 483 484 (define (driver-loop) 485 (prompt-for-input input-prompt) 486 (let ((input (read))) 487 (let ((output 488 (eval input 489 the-global-environment))) 490 (announce-output output-prompt) 491 (user-print output))) 492 (driver-loop)) 493 494 (define (prompt-for-input string) 495 (newline) (newline) 496 (display string) (newline)) 497 498 (define (announce-output string) 499 (newline) (display string) (newline)) 500 501 (define (user-print object) 502 (if (compound-procedure? object) 503 (display 504 (list 'compound-procedure 505 (procedure-parameters object) 506 (procedure-body object) 507 '<procedure-env>)) 508 (display object))) 509 510 ;; XXX: Already defined above: 511 ;; (define the-global-environment 512 ;; (setup-environment)) 513 514 (define (main args) 515 (match args 516 ('() 517 (error "Arguments should have something rather than nothing.")) 518 (`(,arg0) 519 (display arg0) 520 (newline)) 521 (`(,arg0 "--debug") 522 (display "DEBUG TURN ON!\n") 523 (set! *debug* #t)) 524 (args (error "Unknown arguments:" args))) 525 526 (driver-loop)) 527 528 (define (run-internal-tests) 529 (test-eq 1 530 (lookup-variable-value 'a 531 (extend-environment '(a +) 532 `(1 ,+) 533 the-empty-environment))) 534 (test-eq 1 535 (lookup-variable-value 'a 536 (extend-environment '(+ a) 537 `(,+ 1) 538 the-empty-environment))) 539 (test-eq + 540 (lookup-variable-value '+ 541 (extend-environment '(a +) 542 `(1 ,+) 543 the-empty-environment)))) 544 545 ))