commit bd200d3356773db0289d8adce9447cd7a5213536
parent 6f917965f4befb50660b36245c769f7590e9e44d
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Mon, 22 Jul 2024 14:10:27 +0300
Use the Guile extensions of GNU Make. Also, move exercise 4.1.'s two solutions each into its own file.
Diffstat:
6 files changed, 1689 insertions(+), 568 deletions(-)
diff --git a/Makefile b/Makefile
@@ -1,24 +1,24 @@
#tests = $(wildcard sicp/tests/chapter-*/exercise-*.scm)
-chapter_numbers := 1 2 3 4 5
-exercises_per_chapter := 46 97 82 79 52
-solutions := $(foreach chapter,$(chapter_numbers),$(foreach exercise,$(shell seq 1 $(word $(chapter),$(exercises_per_chapter))),sicp/solutions/chapter-$(chapter)/exercise-$(exercise).scm))
-tests := $(foreach chapter,$(chapter_numbers),$(foreach exercise,$(shell seq 1 $(word $(chapter),$(exercises_per_chapter))),sicp/tests/chapter-$(chapter)/exercise-$(exercise).scm))
-tests_logs := $(foreach chapter,$(chapter_numbers),$(foreach exercise,$(shell seq 1 $(word $(chapter),$(exercises_per_chapter))),chapter-$(chapter)-exercise-$(exercise).log))
+$(guile (load "make.scm"))
-.PHONY: all
-all: $(tests_logs)
+solutions := $(guile solutions)
+tests := $(guile tests)
+tests_logs := $(guile tests-logs)
.PHONY: print_variables
print_variables:
- @printf "%s\n" $(solutions)
- @printf "%s\n" $(tests)
- @printf "%s\n" $(tests_logs)
+ @printf "solutions:\n%s\n" $(solutions)
+ @printf "tests:\n%s\n" $(tests)
+ @printf "tests logs:\n%s\n" $(tests_logs)
+
+.PHONY: all
+all: $(tests_logs)
$(tests_logs):
- guile -L . `printf $@ | sed -E 's#(chapter-[0-9]*)-(exercise-[0-9]+).log#sicp/tests/\1/\2.scm#g'`
+ guile --fresh-auto-compile -L . $(guile (log-to-test "$@"))
original-repl-tests.log:
- guile --no-auto-compile -L . sicp/tests/chapter-4/original-repl-tests.scm
+ guile --fresh-auto-compile -L . sicp/tests/chapter-4/original-repl-tests.scm
.PHONY: statistics
statistics:
diff --git a/make.scm b/make.scm
@@ -0,0 +1,44 @@
+(import (srfi srfi-1)
+
+ (ice-9 pretty-print)
+ (ice-9 regex))
+
+(define chapter-numbers '(1 2 3 4 5))
+(define number-of-exercises-per-chapter '(46 97 82 79 52))
+
+(define result
+ (map (lambda (chapter number-of-exercises)
+ (map (lambda (exercise)
+ (list (format #f
+ "sicp/solutions/chapter-~A/exercise-~A.scm"
+ chapter
+ exercise)
+ (format #f
+ "sicp/tests/chapter-~A/exercise-~A.scm"
+ chapter
+ exercise)
+ (format #f
+ "chapter-~A-exercise-~A.log"
+ chapter
+ exercise)))
+ (iota number-of-exercises
+ 1)))
+ chapter-numbers
+ number-of-exercises-per-chapter))
+
+(define-values (solutions tests tests-logs)
+ (unzip3 (concatenate result)))
+
+(define (log-to-test log-name)
+ (let* ((m (string-match "(chapter-[0-9]+)-(exercise-[0-9]+).log" log-name))
+ (chapter (match:substring m 1))
+ (exercise (match:substring m 2)))
+ (format #t
+ "sicp/tests/~A/~A.scm~%"
+ chapter
+ exercise)
+ (format #f
+ "sicp/tests/~A/~A.scm"
+ chapter
+ exercise)
+))
diff --git a/sicp/solutions/chapter-4/exercise-1-left-to-right.scm b/sicp/solutions/chapter-4/exercise-1-left-to-right.scm
@@ -0,0 +1,545 @@
+(define-library (sicp solutions chapter-4 exercise-1-left-to-right)
+ (export
+ eval
+ main
+
+ run-internal-tests
+
+ make-environment
+ setup-environment
+ extend-environment
+ )
+ (import
+ (rename (scheme base) (apply scheme:base:apply))
+ (scheme cxr)
+ (scheme read)
+ (scheme write)
+
+ (srfi srfi-1)
+ (srfi srfi-9)
+ (srfi srfi-64)
+
+ (system vm trace)
+
+ (ice-9 match)
+ (ice-9 pretty-print)
+
+ (sicp utils)
+ )
+
+ (begin
+ ;; XXX: In 4.1.3 we see that the procedure `true?` is defined
+ ;; using the host-variable `false` whose value is 'false, but we
+ ;; don't see it defined anywhere in the good book, so we need to
+ ;; define the host-variable false ourselves.
+ ;;
+ ;; In MIT Scheme, the one the SICP people seem to love to use for
+ ;; SICP, the values of `false` and `true` are #f and #t, #f being
+ ;; the only value that is falsituous and #t there for having a
+ ;; truthious value that has no other meaning other than being
+ ;; truthitiousic.
+ ;;
+ ;; ```
+ ;; # `scheme` is the MIT Scheme executable:
+ ;; $ guix shell mit-scheme -- scheme
+ ;; MIT/GNU Scheme running under GNU/Linux
+ ;; Type `^C' (control-C) followed by `H' to obtain information about interrupts.
+ ;;
+ ;; Copyright (C) 2020 Massachusetts Institute of Technology
+ ;; This is free software; see the source for copying conditions. There is NO warranty; not even for
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+ ;;
+ ;; Image saved on Sunday March 7, 2021 at 3:24:56 PM
+ ;; Release 11.2 || SF || LIAR/x86-64
+ ;;
+ ;; 1 ]=> false
+ ;;
+ ;; ;Value: #f
+ ;;
+ ;; 1 ]=> true
+ ;;
+ ;; ;Value: #t
+ ;;
+ ;; 1 ]=>
+ ;; ```
+ (define false #f)
+ (define true #t)
+
+ (define (make-environment vars vals)
+ "A comfort procedure because calling extend on the-empty-environment is a PITA."
+ (extend-environment vars
+ vals
+ the-empty-environment))
+
+ ;; XXX: As described in chapter 4.1.4 note 2, we need to name the
+ ;; host `apply`, and the guest `apply` differently. I define the
+ ;; host's `apply` to be the name used in the book.
+ (define apply-in-underlying-scheme scheme:base:apply)
+
+;;; Start:
+
+;;; 4.1.1
+
+ (define (eval exp env)
+ (cond ((self-evaluating? exp)
+ exp)
+ ((variable? exp)
+ (lookup-variable-value exp env))
+ ((quoted? exp)
+ (text-of-quotation exp))
+ ((assignment? exp)
+ (eval-assignment exp env))
+ ((definition? exp)
+ (eval-definition exp env))
+ ((if? exp)
+ (eval-if exp env))
+ ((lambda? exp)
+ (make-procedure
+ (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence
+ (begin-actions exp)
+ env))
+ ((cond? exp)
+ (eval (cond->if exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values
+ (operands exp)
+ env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+ (define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters
+ procedure)
+ arguments
+ (procedure-environment
+ procedure))))
+ (else
+ (error "Unknown procedure type -- APPLY"
+ procedure))))
+
+;;; Procedure arguments:
+
+ ;;; Exercise 4.1.
+ (define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (let ((left (eval (first-operand exps) env)))
+ (cons left
+ (list-of-values (rest-operands exps) env)))))
+
+;;; Conditionals:
+
+ (define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+;;; Sequences:
+
+ (define (eval-sequence exps env)
+ (cond ((last-exp? exps)
+ (eval (first-exp exps) env))
+ (else
+ (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps)
+ env))))
+
+;;; Assignments and definitions
+
+ (define (eval-assignment exp env)
+ (set-variable-value!
+ (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+
+ (define (eval-definition exp env)
+ (define-variable!
+ (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+
+;;; end 4.1.1
+
+;;; 4.1.2
+
+
+ (define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+
+ (define (variable? exp) (symbol? exp))
+
+ (define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+ (define (text-of-quotation exp)
+ (cadr exp))
+
+ (define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+ (define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+ (define (assignment-variable exp)
+ (cadr exp))
+
+ (define (assignment-value exp) (caddr exp))
+
+ (define (definition? exp)
+ (tagged-list? exp 'define))
+
+ (define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+
+ (define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda
+ (cdadr exp) ; formal-parameters
+ (cddr exp)))) ; body
+
+ (define (lambda? exp)
+ (tagged-list? exp 'lambda))
+ (define (lambda-parameters exp) (cadr exp))
+ (define (lambda-body exp) (cddr exp))
+
+ (define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+ (define (if? exp) (tagged-list? exp 'if))
+ (define (if-predicate exp) (cadr exp))
+ (define (if-consequent exp) (caddr exp))
+ (define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+
+ (define (make-if predicate
+ consequent
+ alternative)
+ (list 'if
+ predicate
+ consequent
+ alternative))
+
+ (define (begin? exp)
+ (tagged-list? exp 'begin))
+ (define (begin-actions exp) (cdr exp))
+ (define (last-exp? seq) (null? (cdr seq)))
+ (define (first-exp seq) (car seq))
+ (define (rest-exps seq) (cdr seq))
+
+ (define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+
+ (define (make-begin seq) (cons 'begin seq))
+
+ (define (application? exp) (pair? exp))
+ (define (operator exp) (car exp))
+ (define (operands exp) (cdr exp))
+ (define (no-operands? ops) (null? ops))
+ (define (first-operand ops) (car ops))
+ (define (rest-operands ops) (cdr ops))
+
+ (define (cond? exp)
+ (tagged-list? exp 'cond))
+ (define (cond-clauses exp) (cdr exp))
+ (define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+ (define (cond-predicate clause)
+ (car clause))
+ (define (cond-actions clause)
+ (cdr clause))
+ (define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp
+ (cond-actions first))
+ (error "ELSE clause isn't last: COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp
+ (cond-actions first))
+ (expand-clauses
+ rest))))))
+
+;;; end 4.1.2
+
+;;; 4.1.3
+
+ ;; XXX: By default, false's value is #f, which is the only true
+ ;; false. All others are fake and would have the truthitousness
+ ;; property. Consult `info r7rs-small` or `C-h
+ (define (true? x)
+ (not (eq? x false)))
+
+ (define (false? x)
+ (eq? x false))
+
+ (define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+ (define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+ (define (procedure-parameters p) (cadr p))
+ (define (procedure-body p) (caddr p))
+ (define (procedure-environment p) (cadddr p))
+
+ (define (enclosing-environment env) (cdr env))
+ (define (first-frame env) (car env))
+ (define the-empty-environment '())
+
+ (define (make-frame variables values)
+ (cons variables values))
+ (define (frame-variables frame) (car frame))
+ (define (frame-values frame) (cdr frame))
+ (define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+
+ (define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied"
+ vars
+ vals)
+ (error "Too few arguments supplied"
+ vars
+ vals))))
+
+ (define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop
+ (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars)
+ (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+
+ (define (set-variable-value! var val env)
+ ;; XXX: Just trying to see what it would look like if I just used named lets.
+ ;;
+ ;; (let loop-over-environments ((env env))
+ ;; (cond
+ ;; ((eq? env the-empty-enviornment)
+ ;; (error "Unbound variable: SET!" var))
+ ;; (else
+ ;; (let ((frame (first-frame env)))
+ ;; (let loop-over-frame ((vars (frame-variables frame))
+ ;; (vals (frame-values frame)))
+ ;; (cond
+ ;; ((null? vars)
+ ;; (loop-over-environments (enclosing-environment env)))
+ ;; ((eq? var (car vars))
+ ;; (set-car! vals val))
+ ;; (else
+ ;; (loop-over-frame ((cdr vars)
+ ;; (cdr vals))))))))))
+
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop
+ (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars)
+ (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable: SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+
+ (define (define-variable! var val env)
+ "Add a new variable VAR with value VAL in the top frame of environment ENV.
+
+If variable VAR already exists in the top frame, set VAR in the top
+frame to VAL."
+
+ ;; We will CHANGE (why did I all uppercase "CHANGE" here? I
+ ;; don't remember. Maybe it is some sort of a joke?) only
+ ;; the first frame.
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame!
+ var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars)
+ (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;;; 4.1.4
+
+ (define (setup-environment)
+ (dpp 'moo)
+ (let* (;; XXX: See bug below on the quoted (define
+ ;; primitive-procedures ...)
+ (primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '/ /)
+ (list '= =)
+ (list 'display display)
+ (list 'write write)
+ (list 'read read)))
+ (initial-env
+ (extend-environment
+ (primitive-procedure-names primitive-procedures)
+ (primitive-procedure-objects primitive-procedures)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+
+ (define the-global-environment
+ (begin
+ (dpp 'moo)
+ (setup-environment)))
+
+ (define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+ (define (primitive-implementation proc)
+ (cadr proc))
+
+ ;; XXX: There is a bug here in SICP or GNU Guile or both.
+ ;; primitive-procedures is `#<unspecified>` when this library is
+ ;; being loaded.
+ '(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '/ /)
+ (list 'display display)
+ (list 'write write)
+ (list 'read read)))
+
+ (define (primitive-procedure-names primitive-procedures)
+ (map car
+ primitive-procedures))
+
+ (define (primitive-procedure-objects primitive-procedures)
+ (map (lambda (proc)
+ (list 'primitive (cadr proc)))
+ primitive-procedures))
+
+ (define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+ (define input-prompt ";;; M-Eval input:")
+ (define output-prompt ";;; M-Eval value:")
+
+ (define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output
+ (eval input
+ the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+
+ (define (prompt-for-input string)
+ (newline) (newline)
+ (display string) (newline))
+
+ (define (announce-output string)
+ (newline) (display string) (newline))
+
+ (define (user-print object)
+ (if (compound-procedure? object)
+ (display
+ (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+ ;; XXX: Already defined above:
+ ;; (define the-global-environment
+ ;; (setup-environment))
+
+ (define (main args)
+ (match args
+ ('()
+ (error "Arguments should have something rather than nothing."))
+ (`(,arg0)
+ (display arg0)
+ (newline))
+ (`(,arg0 "--debug")
+ (display "DEBUG TURN ON!\n")
+ (set! *debug* #t))
+ (args (error "Unknown arguments:" args)))
+
+ (driver-loop))
+
+ (define (run-internal-tests)
+ (test-eq 1
+ (lookup-variable-value 'a
+ (extend-environment '(a +)
+ `(1 ,+)
+ the-empty-environment)))
+ (test-eq 1
+ (lookup-variable-value 'a
+ (extend-environment '(+ a)
+ `(,+ 1)
+ the-empty-environment)))
+ (test-eq +
+ (lookup-variable-value '+
+ (extend-environment '(a +)
+ `(1 ,+)
+ the-empty-environment))))
+
+ ))
diff --git a/sicp/solutions/chapter-4/exercise-1-right-to-left.scm b/sicp/solutions/chapter-4/exercise-1-right-to-left.scm
@@ -0,0 +1,545 @@
+(define-library (sicp solutions chapter-4 exercise-1-right-to-left)
+ (export
+ eval
+ main
+
+ run-internal-tests
+
+ make-environment
+ setup-environment
+ extend-environment
+ )
+ (import
+ (rename (scheme base) (apply scheme:base:apply))
+ (scheme cxr)
+ (scheme read)
+ (scheme write)
+
+ (srfi srfi-1)
+ (srfi srfi-9)
+ (srfi srfi-64)
+
+ (system vm trace)
+
+ (ice-9 match)
+ (ice-9 pretty-print)
+
+ (sicp utils)
+ )
+
+ (begin
+ ;; XXX: In 4.1.3 we see that the procedure `true?` is defined
+ ;; using the host-variable `false` whose value is 'false, but we
+ ;; don't see it defined anywhere in the good book, so we need to
+ ;; define the host-variable false ourselves.
+ ;;
+ ;; In MIT Scheme, the one the SICP people seem to love to use for
+ ;; SICP, the values of `false` and `true` are #f and #t, #f being
+ ;; the only value that is falsituous and #t there for having a
+ ;; truthious value that has no other meaning other than being
+ ;; truthitiousic.
+ ;;
+ ;; ```
+ ;; # `scheme` is the MIT Scheme executable:
+ ;; $ guix shell mit-scheme -- scheme
+ ;; MIT/GNU Scheme running under GNU/Linux
+ ;; Type `^C' (control-C) followed by `H' to obtain information about interrupts.
+ ;;
+ ;; Copyright (C) 2020 Massachusetts Institute of Technology
+ ;; This is free software; see the source for copying conditions. There is NO warranty; not even for
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+ ;;
+ ;; Image saved on Sunday March 7, 2021 at 3:24:56 PM
+ ;; Release 11.2 || SF || LIAR/x86-64
+ ;;
+ ;; 1 ]=> false
+ ;;
+ ;; ;Value: #f
+ ;;
+ ;; 1 ]=> true
+ ;;
+ ;; ;Value: #t
+ ;;
+ ;; 1 ]=>
+ ;; ```
+ (define false #f)
+ (define true #t)
+
+ (define (make-environment vars vals)
+ "A comfort procedure because calling extend on the-empty-environment is a PITA."
+ (extend-environment vars
+ vals
+ the-empty-environment))
+
+ ;; XXX: As described in chapter 4.1.4 note 2, we need to name the
+ ;; host `apply`, and the guest `apply` differently. I define the
+ ;; host's `apply` to be the name used in the book.
+ (define apply-in-underlying-scheme scheme:base:apply)
+
+;;; Start:
+
+;;; 4.1.1
+
+ (define (eval exp env)
+ (cond ((self-evaluating? exp)
+ exp)
+ ((variable? exp)
+ (lookup-variable-value exp env))
+ ((quoted? exp)
+ (text-of-quotation exp))
+ ((assignment? exp)
+ (eval-assignment exp env))
+ ((definition? exp)
+ (eval-definition exp env))
+ ((if? exp)
+ (eval-if exp env))
+ ((lambda? exp)
+ (make-procedure
+ (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence
+ (begin-actions exp)
+ env))
+ ((cond? exp)
+ (eval (cond->if exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values
+ (operands exp)
+ env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+ (define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters
+ procedure)
+ arguments
+ (procedure-environment
+ procedure))))
+ (else
+ (error "Unknown procedure type -- APPLY"
+ procedure))))
+
+;;; Procedure arguments:
+
+ ;;; Exercise 4.1.
+ (define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (let ((right (list-of-values (rest-operands exps) env)))
+ (cons (eval (first-operand exps) env)
+ right))))
+
+;;; Conditionals:
+
+ (define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+;;; Sequences:
+
+ (define (eval-sequence exps env)
+ (cond ((last-exp? exps)
+ (eval (first-exp exps) env))
+ (else
+ (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps)
+ env))))
+
+;;; Assignments and definitions
+
+ (define (eval-assignment exp env)
+ (set-variable-value!
+ (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+
+ (define (eval-definition exp env)
+ (define-variable!
+ (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+
+;;; end 4.1.1
+
+;;; 4.1.2
+
+
+ (define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+
+ (define (variable? exp) (symbol? exp))
+
+ (define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+ (define (text-of-quotation exp)
+ (cadr exp))
+
+ (define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+ (define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+ (define (assignment-variable exp)
+ (cadr exp))
+
+ (define (assignment-value exp) (caddr exp))
+
+ (define (definition? exp)
+ (tagged-list? exp 'define))
+
+ (define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+
+ (define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda
+ (cdadr exp) ; formal-parameters
+ (cddr exp)))) ; body
+
+ (define (lambda? exp)
+ (tagged-list? exp 'lambda))
+ (define (lambda-parameters exp) (cadr exp))
+ (define (lambda-body exp) (cddr exp))
+
+ (define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+ (define (if? exp) (tagged-list? exp 'if))
+ (define (if-predicate exp) (cadr exp))
+ (define (if-consequent exp) (caddr exp))
+ (define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+
+ (define (make-if predicate
+ consequent
+ alternative)
+ (list 'if
+ predicate
+ consequent
+ alternative))
+
+ (define (begin? exp)
+ (tagged-list? exp 'begin))
+ (define (begin-actions exp) (cdr exp))
+ (define (last-exp? seq) (null? (cdr seq)))
+ (define (first-exp seq) (car seq))
+ (define (rest-exps seq) (cdr seq))
+
+ (define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+
+ (define (make-begin seq) (cons 'begin seq))
+
+ (define (application? exp) (pair? exp))
+ (define (operator exp) (car exp))
+ (define (operands exp) (cdr exp))
+ (define (no-operands? ops) (null? ops))
+ (define (first-operand ops) (car ops))
+ (define (rest-operands ops) (cdr ops))
+
+ (define (cond? exp)
+ (tagged-list? exp 'cond))
+ (define (cond-clauses exp) (cdr exp))
+ (define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+ (define (cond-predicate clause)
+ (car clause))
+ (define (cond-actions clause)
+ (cdr clause))
+ (define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp
+ (cond-actions first))
+ (error "ELSE clause isn't last: COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp
+ (cond-actions first))
+ (expand-clauses
+ rest))))))
+
+;;; end 4.1.2
+
+;;; 4.1.3
+
+ ;; XXX: By default, false's value is #f, which is the only true
+ ;; false. All others are fake and would have the truthitousness
+ ;; property. Consult `info r7rs-small` or `C-h
+ (define (true? x)
+ (not (eq? x false)))
+
+ (define (false? x)
+ (eq? x false))
+
+ (define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+ (define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+ (define (procedure-parameters p) (cadr p))
+ (define (procedure-body p) (caddr p))
+ (define (procedure-environment p) (cadddr p))
+
+ (define (enclosing-environment env) (cdr env))
+ (define (first-frame env) (car env))
+ (define the-empty-environment '())
+
+ (define (make-frame variables values)
+ (cons variables values))
+ (define (frame-variables frame) (car frame))
+ (define (frame-values frame) (cdr frame))
+ (define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+
+ (define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied"
+ vars
+ vals)
+ (error "Too few arguments supplied"
+ vars
+ vals))))
+
+ (define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop
+ (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars)
+ (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+
+ (define (set-variable-value! var val env)
+ ;; XXX: Just trying to see what it would look like if I just used named lets.
+ ;;
+ ;; (let loop-over-environments ((env env))
+ ;; (cond
+ ;; ((eq? env the-empty-enviornment)
+ ;; (error "Unbound variable: SET!" var))
+ ;; (else
+ ;; (let ((frame (first-frame env)))
+ ;; (let loop-over-frame ((vars (frame-variables frame))
+ ;; (vals (frame-values frame)))
+ ;; (cond
+ ;; ((null? vars)
+ ;; (loop-over-environments (enclosing-environment env)))
+ ;; ((eq? var (car vars))
+ ;; (set-car! vals val))
+ ;; (else
+ ;; (loop-over-frame ((cdr vars)
+ ;; (cdr vals))))))))))
+
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop
+ (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars)
+ (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable: SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+
+ (define (define-variable! var val env)
+ "Add a new variable VAR with value VAL in the top frame of environment ENV.
+
+If variable VAR already exists in the top frame, set VAR in the top
+frame to VAL."
+
+ ;; We will CHANGE (why did I all uppercase "CHANGE" here? I
+ ;; don't remember. Maybe it is some sort of a joke?) only
+ ;; the first frame.
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame!
+ var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars)
+ (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;;; 4.1.4
+
+ (define (setup-environment)
+ (dpp 'moo)
+ (let* (;; XXX: See bug below on the quoted (define
+ ;; primitive-procedures ...)
+ (primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '/ /)
+ (list '= =)
+ (list 'display display)
+ (list 'write write)
+ (list 'read read)))
+ (initial-env
+ (extend-environment
+ (primitive-procedure-names primitive-procedures)
+ (primitive-procedure-objects primitive-procedures)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+
+ (define the-global-environment
+ (begin
+ (dpp 'moo)
+ (setup-environment)))
+
+ (define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+ (define (primitive-implementation proc)
+ (cadr proc))
+
+ ;; XXX: There is a bug here in SICP or GNU Guile or both.
+ ;; primitive-procedures is `#<unspecified>` when this library is
+ ;; being loaded.
+ '(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '/ /)
+ (list 'display display)
+ (list 'write write)
+ (list 'read read)))
+
+ (define (primitive-procedure-names primitive-procedures)
+ (map car
+ primitive-procedures))
+
+ (define (primitive-procedure-objects primitive-procedures)
+ (map (lambda (proc)
+ (list 'primitive (cadr proc)))
+ primitive-procedures))
+
+ (define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+ (define input-prompt ";;; M-Eval input:")
+ (define output-prompt ";;; M-Eval value:")
+
+ (define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output
+ (eval input
+ the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+
+ (define (prompt-for-input string)
+ (newline) (newline)
+ (display string) (newline))
+
+ (define (announce-output string)
+ (newline) (display string) (newline))
+
+ (define (user-print object)
+ (if (compound-procedure? object)
+ (display
+ (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+ ;; XXX: Already defined above:
+ ;; (define the-global-environment
+ ;; (setup-environment))
+
+ (define (main args)
+ (match args
+ ('()
+ (error "Arguments should have something rather than nothing."))
+ (`(,arg0)
+ (display arg0)
+ (newline))
+ (`(,arg0 "--debug")
+ (display "DEBUG TURN ON!\n")
+ (set! *debug* #t))
+ (args (error "Unknown arguments:" args)))
+
+ (driver-loop))
+
+ (define (run-internal-tests)
+ (test-eq 1
+ (lookup-variable-value 'a
+ (extend-environment '(a +)
+ `(1 ,+)
+ the-empty-environment)))
+ (test-eq 1
+ (lookup-variable-value 'a
+ (extend-environment '(+ a)
+ `(,+ 1)
+ the-empty-environment)))
+ (test-eq +
+ (lookup-variable-value '+
+ (extend-environment '(a +)
+ `(1 ,+)
+ the-empty-environment))))
+
+ ))
diff --git a/sicp/solutions/chapter-4/exercise-1.scm b/sicp/solutions/chapter-4/exercise-1.scm
@@ -1,551 +1,22 @@
-(define-library (sicp solutions chapter-4 original-repl)
+(define-library (sicp solutions chapter-4 exercise-1)
(export
- eval
- main
+ left-to-right:eval
+ left-to-right:main
- run-internal-tests
+ left-to-right:run-internal-tests
+ left-to-right:make-environment
+ left-to-right:setup-environment
+ left-to-right:extend-environment
- make-environment
- setup-environment
- extend-environment
- )
- (import
- (rename (scheme base) (apply scheme:base:apply))
- (scheme cxr)
- (scheme read)
- (scheme write)
-
- (srfi srfi-1)
- (srfi srfi-9)
- (srfi srfi-64)
-
- (system vm trace)
-
- (ice-9 match)
- (ice-9 pretty-print)
+ right-to-left:eval
+ right-to-left:main
- (sicp utils)
+ right-to-left:run-internal-tests
+ right-to-left:make-environment
+ right-to-left:setup-environment
+ right-to-left:extend-environment
)
-
- (begin
- ;; XXX: In 4.1.3 we see that the procedure `true?` is defined
- ;; using the host-variable `false` whose value is 'false, but we
- ;; don't see it defined anywhere in the good book, so we need to
- ;; define the host-variable false ourselves.
- ;;
- ;; In MIT Scheme, the one the SICP people seem to love to use for
- ;; SICP, the values of `false` and `true` are #f and #t, #f being
- ;; the only value that is falsituous and #t there for having a
- ;; truthious value that has no other meaning other than being
- ;; truthitiousic.
- ;;
- ;; ```
- ;; # `scheme` is the MIT Scheme executable:
- ;; $ guix shell mit-scheme -- scheme
- ;; MIT/GNU Scheme running under GNU/Linux
- ;; Type `^C' (control-C) followed by `H' to obtain information about interrupts.
- ;;
- ;; Copyright (C) 2020 Massachusetts Institute of Technology
- ;; This is free software; see the source for copying conditions. There is NO warranty; not even for
- ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- ;;
- ;; Image saved on Sunday March 7, 2021 at 3:24:56 PM
- ;; Release 11.2 || SF || LIAR/x86-64
- ;;
- ;; 1 ]=> false
- ;;
- ;; ;Value: #f
- ;;
- ;; 1 ]=> true
- ;;
- ;; ;Value: #t
- ;;
- ;; 1 ]=>
- ;; ```
- (define false #f)
- (define true #t)
-
- (define (make-environment vars vals)
- "A comfort procedure because calling extend on the-empty-environment is a PITA."
- (extend-environment vars
- vals
- the-empty-environment))
-
- ;; XXX: As described in chapter 4.1.4 note 2, we need to name the
- ;; host `apply`, and the guest `apply` differently. I define the
- ;; host's `apply` to be the name used in the book.
- (define apply-in-underlying-scheme scheme:base:apply)
-
-;;; Start:
-
-;;; 4.1.1
-
- (define (eval exp env)
- (cond ((self-evaluating? exp)
- exp)
- ((variable? exp)
- (lookup-variable-value exp env))
- ((quoted? exp)
- (text-of-quotation exp))
- ((assignment? exp)
- (eval-assignment exp env))
- ((definition? exp)
- (eval-definition exp env))
- ((if? exp)
- (eval-if exp env))
- ((lambda? exp)
- (make-procedure
- (lambda-parameters exp)
- (lambda-body exp)
- env))
- ((begin? exp)
- (eval-sequence
- (begin-actions exp)
- env))
- ((cond? exp)
- (eval (cond->if exp) env))
- ((application? exp)
- (apply (eval (operator exp) env)
- (list-of-values
- (operands exp)
- env)))
- (else
- (error "Unknown expression type -- EVAL" exp))))
-
- (define (apply procedure arguments)
- (cond ((primitive-procedure? procedure)
- (apply-primitive-procedure
- procedure
- arguments))
- ((compound-procedure? procedure)
- (eval-sequence
- (procedure-body procedure)
- (extend-environment
- (procedure-parameters
- procedure)
- arguments
- (procedure-environment
- procedure))))
- (else
- (error "Unknown procedure type -- APPLY"
- procedure))))
-
-;;; Procedure arguments:
-
- (define (list-of-values-left-to-right exps env)
- (if (no-operands? exps)
- '()
- (let ((left (eval (first-operand exps) env)))
- (cons left
- (list-of-values (rest-operands exps) env)))))
-
- (define (list-of-values-right-to-left exps env)
- (if (no-operands? exps)
- '()
- (let ((right (list-of-values (rest-operands exps) env)))
- (cons (eval (first-operand exps) env)
- right))))
-
-;;; Conditionals:
-
- (define (eval-if exp env)
- (if (true? (eval (if-predicate exp) env))
- (eval (if-consequent exp) env)
- (eval (if-alternative exp) env)))
-
-;;; Sequences:
-
- (define (eval-sequence exps env)
- (cond ((last-exp? exps)
- (eval (first-exp exps) env))
- (else
- (eval (first-exp exps) env)
- (eval-sequence (rest-exps exps)
- env))))
-
-;;; Assignments and definitions
-
- (define (eval-assignment exp env)
- (set-variable-value!
- (assignment-variable exp)
- (eval (assignment-value exp) env)
- env)
- 'ok)
-
- (define (eval-definition exp env)
- (define-variable!
- (definition-variable exp)
- (eval (definition-value exp) env)
- env)
- 'ok)
-
-;;; end 4.1.1
-
-;;; 4.1.2
-
-
- (define (self-evaluating? exp)
- (cond ((number? exp) true)
- ((string? exp) true)
- (else false)))
-
- (define (variable? exp) (symbol? exp))
-
- (define (quoted? exp)
- (tagged-list? exp 'quote))
-
- (define (text-of-quotation exp)
- (cadr exp))
-
- (define (tagged-list? exp tag)
- (if (pair? exp)
- (eq? (car exp) tag)
- false))
-
- (define (assignment? exp)
- (tagged-list? exp 'set!))
-
- (define (assignment-variable exp)
- (cadr exp))
-
- (define (assignment-value exp) (caddr exp))
-
- (define (definition? exp)
- (tagged-list? exp 'define))
-
- (define (definition-variable exp)
- (if (symbol? (cadr exp))
- (cadr exp)
- (caadr exp)))
-
- (define (definition-value exp)
- (if (symbol? (cadr exp))
- (caddr exp)
- (make-lambda
- (cdadr exp) ; formal-parameters
- (cddr exp)))) ; body
-
- (define (lambda? exp)
- (tagged-list? exp 'lambda))
- (define (lambda-parameters exp) (cadr exp))
- (define (lambda-body exp) (cddr exp))
-
- (define (make-lambda parameters body)
- (cons 'lambda (cons parameters body)))
-
- (define (if? exp) (tagged-list? exp 'if))
- (define (if-predicate exp) (cadr exp))
- (define (if-consequent exp) (caddr exp))
- (define (if-alternative exp)
- (if (not (null? (cdddr exp)))
- (cadddr exp)
- 'false))
-
- (define (make-if predicate
- consequent
- alternative)
- (list 'if
- predicate
- consequent
- alternative))
-
- (define (begin? exp)
- (tagged-list? exp 'begin))
- (define (begin-actions exp) (cdr exp))
- (define (last-exp? seq) (null? (cdr seq)))
- (define (first-exp seq) (car seq))
- (define (rest-exps seq) (cdr seq))
-
- (define (sequence->exp seq)
- (cond ((null? seq) seq)
- ((last-exp? seq) (first-exp seq))
- (else (make-begin seq))))
-
- (define (make-begin seq) (cons 'begin seq))
-
- (define (application? exp) (pair? exp))
- (define (operator exp) (car exp))
- (define (operands exp) (cdr exp))
- (define (no-operands? ops) (null? ops))
- (define (first-operand ops) (car ops))
- (define (rest-operands ops) (cdr ops))
-
- (define (cond? exp)
- (tagged-list? exp 'cond))
- (define (cond-clauses exp) (cdr exp))
- (define (cond-else-clause? clause)
- (eq? (cond-predicate clause) 'else))
- (define (cond-predicate clause)
- (car clause))
- (define (cond-actions clause)
- (cdr clause))
- (define (cond->if exp)
- (expand-clauses (cond-clauses exp)))
- (define (expand-clauses clauses)
- (if (null? clauses)
- 'false
- (let ((first (car clauses))
- (rest (cdr clauses)))
- (if (cond-else-clause? first)
- (if (null? rest)
- (sequence->exp
- (cond-actions first))
- (error "ELSE clause isn't last: COND->IF"
- clauses))
- (make-if (cond-predicate first)
- (sequence->exp
- (cond-actions first))
- (expand-clauses
- rest))))))
-
-;;; end 4.1.2
-
-;;; 4.1.3
-
- ;; XXX: By default, false's value is #f, which is the only true
- ;; false. All others are fake and would have the truthitousness
- ;; property. Consult `info r7rs-small` or `C-h
- (define (true? x)
- (not (eq? x false)))
-
- (define (false? x)
- (eq? x false))
-
- (define (make-procedure parameters body env)
- (list 'procedure parameters body env))
- (define (compound-procedure? p)
- (tagged-list? p 'procedure))
- (define (procedure-parameters p) (cadr p))
- (define (procedure-body p) (caddr p))
- (define (procedure-environment p) (cadddr p))
-
- (define (enclosing-environment env) (cdr env))
- (define (first-frame env) (car env))
- (define the-empty-environment '())
-
- (define (make-frame variables values)
- (cons variables values))
- (define (frame-variables frame) (car frame))
- (define (frame-values frame) (cdr frame))
- (define (add-binding-to-frame! var val frame)
- (set-car! frame (cons var (car frame)))
- (set-cdr! frame (cons val (cdr frame))))
-
- (define (extend-environment vars vals base-env)
- (if (= (length vars) (length vals))
- (cons (make-frame vars vals) base-env)
- (if (< (length vars) (length vals))
- (error "Too many arguments supplied"
- vars
- vals)
- (error "Too few arguments supplied"
- vars
- vals))))
-
- (define (lookup-variable-value var env)
- (define (env-loop env)
- (define (scan vars vals)
- (cond ((null? vars)
- (env-loop
- (enclosing-environment env)))
- ((eq? var (car vars))
- (car vals))
- (else (scan (cdr vars)
- (cdr vals)))))
- (if (eq? env the-empty-environment)
- (error "Unbound variable" var)
- (let ((frame (first-frame env)))
- (scan (frame-variables frame)
- (frame-values frame)))))
- (env-loop env))
-
- (define (set-variable-value! var val env)
- ;; XXX: Just trying to see what it would look like if I just used named lets.
- ;;
- ;; (let loop-over-environments ((env env))
- ;; (cond
- ;; ((eq? env the-empty-enviornment)
- ;; (error "Unbound variable: SET!" var))
- ;; (else
- ;; (let ((frame (first-frame env)))
- ;; (let loop-over-frame ((vars (frame-variables frame))
- ;; (vals (frame-values frame)))
- ;; (cond
- ;; ((null? vars)
- ;; (loop-over-environments (enclosing-environment env)))
- ;; ((eq? var (car vars))
- ;; (set-car! vals val))
- ;; (else
- ;; (loop-over-frame ((cdr vars)
- ;; (cdr vals))))))))))
-
- (define (env-loop env)
- (define (scan vars vals)
- (cond ((null? vars)
- (env-loop
- (enclosing-environment env)))
- ((eq? var (car vars))
- (set-car! vals val))
- (else (scan (cdr vars)
- (cdr vals)))))
- (if (eq? env the-empty-environment)
- (error "Unbound variable: SET!" var)
- (let ((frame (first-frame env)))
- (scan (frame-variables frame)
- (frame-values frame)))))
- (env-loop env))
-
- (define (define-variable! var val env)
- "Add a new variable VAR with value VAL in the top frame of environment ENV.
-
-If variable VAR already exists in the top frame, set VAR in the top
-frame to VAL."
-
- ;; We will CHANGE (why did I all uppercase "CHANGE" here? I
- ;; don't remember. Maybe it is some sort of a joke?) only
- ;; the first frame.
- (let ((frame (first-frame env)))
- (define (scan vars vals)
- (cond ((null? vars)
- (add-binding-to-frame!
- var val frame))
- ((eq? var (car vars))
- (set-car! vals val))
- (else (scan (cdr vars)
- (cdr vals)))))
- (scan (frame-variables frame)
- (frame-values frame))))
-
-;;; 4.1.4
-
- (define (setup-environment)
- (dpp 'moo)
- (let* (;; XXX: See bug below on the quoted (define
- ;; primitive-procedures ...)
- (primitive-procedures
- (list (list 'car car)
- (list 'cdr cdr)
- (list 'cons cons)
- (list 'null? null?)
- (list '+ +)
- (list '- -)
- (list '* *)
- (list '/ /)
- (list '= =)
- (list 'display display)
- (list 'write write)
- (list 'read read)))
- (initial-env
- (extend-environment
- (primitive-procedure-names primitive-procedures)
- (primitive-procedure-objects primitive-procedures)
- the-empty-environment)))
- (define-variable! 'true true initial-env)
- (define-variable! 'false false initial-env)
- initial-env))
-
- (define the-global-environment
- (begin
- (dpp 'moo)
- (setup-environment)))
-
- (define (primitive-procedure? proc)
- (tagged-list? proc 'primitive))
-
- (define (primitive-implementation proc)
- (cadr proc))
-
- ;; XXX: There is a bug here in SICP or GNU Guile or both.
- ;; primitive-procedures is `#<unspecified>` when this library is
- ;; being loaded.
- '(define primitive-procedures
- (list (list 'car car)
- (list 'cdr cdr)
- (list 'cons cons)
- (list 'null? null?)
- (list '+ +)
- (list '- -)
- (list '* *)
- (list '/ /)
- (list 'display display)
- (list 'write write)
- (list 'read read)))
-
- (define (primitive-procedure-names primitive-procedures)
- (map car
- primitive-procedures))
-
- (define (primitive-procedure-objects primitive-procedures)
- (map (lambda (proc)
- (list 'primitive (cadr proc)))
- primitive-procedures))
-
- (define (apply-primitive-procedure proc args)
- (apply-in-underlying-scheme
- (primitive-implementation proc) args))
-
- (define input-prompt ";;; M-Eval input:")
- (define output-prompt ";;; M-Eval value:")
-
- (define (driver-loop)
- (prompt-for-input input-prompt)
- (let ((input (read)))
- (let ((output
- (eval input
- the-global-environment)))
- (announce-output output-prompt)
- (user-print output)))
- (driver-loop))
-
- (define (prompt-for-input string)
- (newline) (newline)
- (display string) (newline))
-
- (define (announce-output string)
- (newline) (display string) (newline))
-
- (define (user-print object)
- (if (compound-procedure? object)
- (display
- (list 'compound-procedure
- (procedure-parameters object)
- (procedure-body object)
- '<procedure-env>))
- (display object)))
-
- ;; XXX: Already defined above:
- ;; (define the-global-environment
- ;; (setup-environment))
-
- (define (main args)
- (match args
- ('()
- (error "Arguments should have something rather than nothing."))
- (`(,arg0)
- (display arg0)
- (newline))
- (`(,arg0 "--debug")
- (display "DEBUG TURN ON!\n")
- (set! *debug* #t))
- (args (error "Unknown arguments:" args)))
-
- (driver-loop))
-
- (define (run-internal-tests)
- (test-eq 1
- (lookup-variable-value 'a
- (extend-environment '(a +)
- `(1 ,+)
- the-empty-environment)))
- (test-eq 1
- (lookup-variable-value 'a
- (extend-environment '(+ a)
- `(,+ 1)
- the-empty-environment)))
- (test-eq +
- (lookup-variable-value '+
- (extend-environment '(a +)
- `(1 ,+)
- the-empty-environment))))
-
- ))
+ (import
+ (rename (sicp solutions chapter-4 exercise-1-left-to-right) left-to-right:)
+ (rename (sicp solutions chapter-4 exercise-1-right-to-left) right-to-left:)
+ ))
diff --git a/sicp/solutions/chapter-4/exercise-2.scm b/sicp/solutions/chapter-4/exercise-2.scm
@@ -1,13 +1,85 @@
(define-library (sicp solutions chapter-4 exercise-2)
- (import (scheme base)
+ (export
+ eval
+ main
- (srfi :9)
- (srfi :19)
+ run-internal-tests
- (ice-9 pretty-print)
- (ice-9 match))
+ make-environment
+ setup-environment
+ extend-environment
+ )
+ (import
+ (rename (scheme base) (apply scheme:base:apply))
+ (scheme cxr)
+ (scheme read)
+ (scheme write)
+
+ (srfi srfi-1)
+ (srfi srfi-9)
+ (srfi srfi-64)
+
+ (system vm trace)
+
+ (ice-9 match)
+ (ice-9 pretty-print)
+
+ (sicp utils)
+ )
(begin
+ ;; XXX: In 4.1.3 we see that the procedure `true?` is defined
+ ;; using the host-variable `false` whose value is 'false, but we
+ ;; don't see it defined anywhere in the good book, so we need to
+ ;; define the host-variable false ourselves.
+ ;;
+ ;; In MIT Scheme, the one the SICP people seem to love to use for
+ ;; SICP, the values of `false` and `true` are #f and #t, #f being
+ ;; the only value that is falsituous and #t there for having a
+ ;; truthious value that has no other meaning other than being
+ ;; truthitiousic.
+ ;;
+ ;; ```
+ ;; # `scheme` is the MIT Scheme executable:
+ ;; $ guix shell mit-scheme -- scheme
+ ;; MIT/GNU Scheme running under GNU/Linux
+ ;; Type `^C' (control-C) followed by `H' to obtain information about interrupts.
+ ;;
+ ;; Copyright (C) 2020 Massachusetts Institute of Technology
+ ;; This is free software; see the source for copying conditions. There is NO warranty; not even for
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+ ;;
+ ;; Image saved on Sunday March 7, 2021 at 3:24:56 PM
+ ;; Release 11.2 || SF || LIAR/x86-64
+ ;;
+ ;; 1 ]=> false
+ ;;
+ ;; ;Value: #f
+ ;;
+ ;; 1 ]=> true
+ ;;
+ ;; ;Value: #t
+ ;;
+ ;; 1 ]=>
+ ;; ```
+ (define false #f)
+ (define true #t)
+
+ (define (make-environment vars vals)
+ "A comfort procedure because calling extend on the-empty-environment is a PITA."
+ (extend-environment vars
+ vals
+ the-empty-environment))
+
+ ;; XXX: As described in chapter 4.1.4 note 2, we need to name the
+ ;; host `apply`, and the guest `apply` differently. I define the
+ ;; host's `apply` to be the name used in the book.
+ (define apply-in-underlying-scheme scheme:base:apply)
+
+;;; Start:
+
+;;; 4.1.1
+
(define (eval exp env)
(cond ((self-evaluating? exp)
exp)
@@ -15,6 +87,12 @@
(lookup-variable-value exp env))
((quoted? exp)
(text-of-quotation exp))
+ ;; XXX: Exercise 4.2.b.
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values
+ (operands exp)
+ env)))
((assignment? exp)
(eval-assignment exp env))
((definition? exp)
@@ -32,17 +110,455 @@
env))
((cond? exp)
(eval (cond->if exp) env))
- ((application? exp)
- (apply (eval (operator exp) env)
- (list-of-values
- (operands exp)
- env)))
(else
(error "Unknown expression type -- EVAL" exp))))
+ (define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters
+ procedure)
+ arguments
+ (procedure-environment
+ procedure))))
+ (else
+ (error "Unknown procedure type -- APPLY"
+ procedure))))
+
+;;; Procedure arguments:
+
+ ;; XXX: Does not change in exercise 4.2.b. .
+ (define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+;;; Conditionals:
+
+ (define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+;;; Sequences:
+
+ (define (eval-sequence exps env)
+ (cond ((last-exp? exps)
+ (eval (first-exp exps) env))
+ (else
+ (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps)
+ env))))
+
+;;; Assignments and definitions
+
+ (define (eval-assignment exp env)
+ (set-variable-value!
+ (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+
+ (define (eval-definition exp env)
+ (define-variable!
+ (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+
+;;; end 4.1.1
+
+;;; 4.1.2
+
+
+ (define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+
+ (define (variable? exp) (symbol? exp))
+
+ (define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+ (define (text-of-quotation exp)
+ (cadr exp))
+
+ (define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+ (define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+ (define (assignment-variable exp)
+ (cadr exp))
+
+ (define (assignment-value exp) (caddr exp))
+
+ (define (definition? exp)
+ (tagged-list? exp 'define))
+
+ (define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+
+ (define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda
+ (cdadr exp) ; formal-parameters
+ (cddr exp)))) ; body
+
+ (define (lambda? exp)
+ (tagged-list? exp 'lambda))
+ (define (lambda-parameters exp) (cadr exp))
+ (define (lambda-body exp) (cddr exp))
+
+ (define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+ (define (if? exp) (tagged-list? exp 'if))
+ (define (if-predicate exp) (cadr exp))
+ (define (if-consequent exp) (caddr exp))
+ (define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+
+ (define (make-if predicate
+ consequent
+ alternative)
+ (list 'if
+ predicate
+ consequent
+ alternative))
+
+ (define (begin? exp)
+ (tagged-list? exp 'begin))
+ (define (begin-actions exp) (cdr exp))
+ (define (last-exp? seq) (null? (cdr seq)))
+ (define (first-exp seq) (car seq))
+ (define (rest-exps seq) (cdr seq))
+
+ (define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+
+ (define (make-begin seq) (cons 'begin seq))
+
+ ;; Exercise 4.2.b. answer:
(define (application? exp) (tagged-list? exp 'call))
(define (operator exp) (cadr exp))
(define (operands exp) (cddr exp))
+ ;; XXX: In exercise 4.2.b. `no-operands?`, `first-operand`,
+ ;; `rest-operands`, and `list-of-values` do not change because the
+ ;; representation of operands does not change.
+ (define (no-operands? ops) (null? ops))
+ (define (first-operand ops) (car ops))
+ (define (rest-operands ops) (cdr ops))
+
+ (define (cond? exp)
+ (tagged-list? exp 'cond))
+ (define (cond-clauses exp) (cdr exp))
+ (define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+ (define (cond-predicate clause)
+ (car clause))
+ (define (cond-actions clause)
+ (cdr clause))
+ (define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+ (define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp
+ (cond-actions first))
+ (error "ELSE clause isn't last: COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp
+ (cond-actions first))
+ (expand-clauses
+ rest))))))
+
+;;; end 4.1.2
+
+;;; 4.1.3
+
+ ;; XXX: By default, false's value is #f, which is the only true
+ ;; false. All others are fake and would have the truthitousness
+ ;; property. Consult `info r7rs-small` or `C-h
+ (define (true? x)
+ (not (eq? x false)))
+
+ (define (false? x)
+ (eq? x false))
+
+ (define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+ (define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+ (define (procedure-parameters p) (cadr p))
+ (define (procedure-body p) (caddr p))
+ (define (procedure-environment p) (cadddr p))
+
+ (define (enclosing-environment env) (cdr env))
+ (define (first-frame env) (car env))
+ (define the-empty-environment '())
+
+ (define (make-frame variables values)
+ (cons variables values))
+ (define (frame-variables frame) (car frame))
+ (define (frame-values frame) (cdr frame))
+ (define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+
+ (define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied"
+ vars
+ vals)
+ (error "Too few arguments supplied"
+ vars
+ vals))))
+
+ (define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop
+ (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars)
+ (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+
+ (define (set-variable-value! var val env)
+ ;; XXX: Just trying to see what it would look like if I just used named lets.
+ ;;
+ ;; (let loop-over-environments ((env env))
+ ;; (cond
+ ;; ((eq? env the-empty-enviornment)
+ ;; (error "Unbound variable: SET!" var))
+ ;; (else
+ ;; (let ((frame (first-frame env)))
+ ;; (let loop-over-frame ((vars (frame-variables frame))
+ ;; (vals (frame-values frame)))
+ ;; (cond
+ ;; ((null? vars)
+ ;; (loop-over-environments (enclosing-environment env)))
+ ;; ((eq? var (car vars))
+ ;; (set-car! vals val))
+ ;; (else
+ ;; (loop-over-frame ((cdr vars)
+ ;; (cdr vals))))))))))
+
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop
+ (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars)
+ (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable: SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+
+ (define (define-variable! var val env)
+ "Add a new variable VAR with value VAL in the top frame of environment ENV.
+
+If variable VAR already exists in the top frame, set VAR in the top
+frame to VAL."
+
+ ;; We will CHANGE (why did I all uppercase "CHANGE" here? I
+ ;; don't remember. Maybe it is some sort of a joke?) only
+ ;; the first frame.
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame!
+ var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars)
+ (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;;; 4.1.4
+
+ (define (setup-environment)
+ (dpp 'moo)
+ (let* (;; XXX: See bug below on the quoted (define
+ ;; primitive-procedures ...)
+ (primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '/ /)
+ (list '= =)
+ (list 'display display)
+ (list 'write write)
+ (list 'read read)))
+ (initial-env
+ (extend-environment
+ (primitive-procedure-names primitive-procedures)
+ (primitive-procedure-objects primitive-procedures)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+
+ (define the-global-environment
+ (begin
+ (dpp 'moo)
+ (setup-environment)))
+
+ (define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+ (define (primitive-implementation proc)
+ (cadr proc))
+
+ ;; XXX: There is a bug here in SICP or GNU Guile or both.
+ ;; primitive-procedures is `#<unspecified>` when this library is
+ ;; being loaded.
+ '(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '/ /)
+ (list 'display display)
+ (list 'write write)
+ (list 'read read)))
+
+ (define (primitive-procedure-names primitive-procedures)
+ (map car
+ primitive-procedures))
+
+ (define (primitive-procedure-objects primitive-procedures)
+ (map (lambda (proc)
+ (list 'primitive (cadr proc)))
+ primitive-procedures))
+
+ (define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+ (define input-prompt ";;; M-Eval input:")
+ (define output-prompt ";;; M-Eval value:")
+
+ (define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output
+ (eval input
+ the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+
+ (define (prompt-for-input string)
+ (newline) (newline)
+ (display string) (newline))
+
+ (define (announce-output string)
+ (newline) (display string) (newline))
+
+ (define (user-print object)
+ (if (compound-procedure? object)
+ (display
+ (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+ ;; XXX: Already defined above:
+ ;; (define the-global-environment
+ ;; (setup-environment))
+
+ (define (main args)
+ (match args
+ ('()
+ (error "Arguments should have something rather than nothing."))
+ (`(,arg0)
+ (display arg0)
+ (newline))
+ (`(,arg0 "--debug")
+ (display "DEBUG TURN ON!\n")
+ (set! *debug* #t))
+ (args (error "Unknown arguments:" args)))
+
+ (driver-loop))
+
+ (define (run-internal-tests)
+ (test-eq 1
+ (lookup-variable-value 'a
+ (extend-environment '(a +)
+ `(1 ,+)
+ the-empty-environment)))
+ (test-eq 1
+ (lookup-variable-value 'a
+ (extend-environment '(+ a)
+ `(,+ 1)
+ the-empty-environment)))
+ (test-eq +
+ (lookup-variable-value '+
+ (extend-environment '(a +)
+ `(1 ,+)
+ the-empty-environment))))
+
+ ))
+(define-library (sicp solutions chapter-4 exercise-2)
+ (import (scheme base)
+
+ (srfi :9)
+ (srfi :19)
+
+ (ice-9 pretty-print)
+ (ice-9 match))
+
+ (begin
+
+
;; XXX: `no-operands?`, `first-operand`, `rest-operands`, and
;; `list-of-values` do not change because the representation of
;; operands does not change.
