commit 062e23d5d35c65680f37b3e7d6472a5f84093575
parent bab5b89784fa0b2d7c5f3f9cc53b9aa6d7a7ba35
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Mon, 22 Jul 2024 15:19:50 +0300
Add solution to exercise 4.3. . Also, save olde solutions.
Diffstat:
9 files changed, 1085 insertions(+), 0 deletions(-)
diff --git a/sicp/solutions/chapter-4/exercise-3.scm b/sicp/solutions/chapter-4/exercise-3.scm
@@ -0,0 +1,564 @@
+(define-library (sicp solutions chapter-4 exercise-3)
+ (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 *form-table* '())
+
+ (define (add-form-handler! form? handler)
+ (set! *form-table*
+ (cons (cons form?
+ handler)
+ *form-table*)))
+
+ (define (get-form-handler exp)
+ (let loop ((table *form-table*))
+ (match table
+ ('()
+ (error "Unknown form" exp))
+ (`((,form? . ,handler) . ,rest)
+ (if (form? exp)
+ handler
+ (loop rest))))))
+
+ (define (eval exp env)
+ (cond ((self-evaluating? exp)
+ exp)
+ ((variable? exp)
+ (lookup-variable-value exp env))
+ ((pair? exp)
+ ((get-form-handler exp) 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 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))
+
+ (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))))
+
+ (add-form-handler! quoted? (lambda (exp env) (text-of-quotation exp)))
+ (add-form-handler! assignment? eval-assignment)
+ (add-form-handler! definition? eval-definition)
+
+ (add-form-handler! if? eval-if)
+ (add-form-handler! lambda?
+ (lambda (exp env)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env)))
+ (add-form-handler! begin?
+ (lambda (exp env)
+ (eval-sequence
+ (begin-actions exp)
+ env)))
+ (add-form-handler! cond?
+ (lambda (exp env)
+ (eval (cond->if exp) env)))
+ (add-form-handler! application?
+ (lambda (exp env)
+ (apply (eval (operator exp) env)
+ (list-of-values
+ (operands exp)
+ env))))
+
+ ))
diff --git a/sicp/solutions/chapter-4/old/exercise-3.scm b/sicp/solutions/chapter-4/old/exercise-3.scm
@@ -0,0 +1,134 @@
+(define-library (sicp chapter-4 exercise-3)
+ (import
+ (scheme base)
+ (scheme process-context)
+ (scheme write)
+
+ (srfi :1)
+ (srfi :64)
+
+ (ice-9 format)
+ (ice-9 match)
+ (ice-9 pretty-print)
+
+ (sicp utils))
+
+ (begin
+ (define *forms-table* '())
+
+ '((define-record-type <compound-procedure>
+ (make-compound-procedure parameters body env)
+ compound-procedure?
+ (parameters compound-procedure-parameters)
+ (body compound-procedure-body)
+ (env compound-procedure-env))
+
+ (define (put-form form-type form-handler)
+ (set! *forms-table*
+ (alist-cons form-type
+ form-handler
+ (alist-delete form-type *forms-table*))))
+
+ (define (get-form form-type)
+ (match (assoc form-type *forms-table*)
+ (`(,form-type . ,form-handler)
+ form-handler)
+ (_ #f)))
+
+ (define (get-variable variable-name env)
+ (match (assoc variable-name env)
+ (`(,variable-name . ,variable-value)
+ variable-value)
+ (_ (error "Unknown variable:" variable-name))))
+
+ (define (form-symbol exp) (car exp))
+
+ (define host-eval eval)
+
+ (define (eval exp env)
+ (pretty-print (list 'eval exp))
+ (match exp
+ ((? self-evaluating?) exp)
+ ((? variable?) (lookup-variable-value exp env))
+ (_
+ (match (get-form (form-symbol exp))
+ ((our-form-symbol . our-form-handler)
+ (our-form-handler
+ (form-parameters exp)
+ env))
+ (_
+ (match exp
+ ((? application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (_
+ (pretty-print (list "uknown express -- EVAL" exp))
+ (error "Unknown expression type -- EVAL" exp))))))))
+
+ (define (form-parameters exp) (cdr exp))
+
+ (define (operator exp) (car exp))
+ (define (operands exp) (cdr exp))
+
+ (define (application? exp) (pair? exp))
+
+ (define (apply-in-underlying-scheme proc arguments)
+ (apply proc arguments))
+
+ (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
+ (pretty-print (list "Unknown procedure type -- APPLY" procedure))
+ (error
+ "Unknown procedure type -- APPLY" procedure))))
+
+ (define (primitive-implementation proc) (cadr proc))
+
+ (define (apply-primitive-procedure procedure arguments)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc)
+ arguments))
+
+ (define (primitive-procedure? procedure) (symbol? procedure))
+
+ (define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps)
+ env)
+ (list-of-values (rest-operands exps)
+ env))))
+ (define (first-operand exps) (car exps))
+ (define (rest-operands exps) (cdr exps))
+ (define (no-operands? exp) (null? (cdr exp)))
+
+ (define (println-handler exp env)
+ (display exp) (newline)
+ (values '() env))
+
+ (define (self-evaluating? exp)
+ (or (string? exp)
+ (number? exp)
+ (null? exp)
+ (vector? exp)
+ (symbol? exp)))
+
+ (define (variable? exp) (symbol? exp))
+
+ (define (quote-handler exp env) (cadr exp))
+
+ (put-form 'quote quote-handler)
+ ((get-form 'quote) '(quote 1) '())
+
+ (eval (quote 1) '())
+ (eval (list 'quote 1) '())
+ (eval '(quote a) `())
+ )))
diff --git a/sicp/solutions/chapter-4/old/exercise-4.scm b/sicp/solutions/chapter-4/old/exercise-4.scm
@@ -0,0 +1,75 @@
+(define-library (sicp solutions chapter-4 exercise-4)
+ (import (schemb base)
+ (ice-9 match))
+
+ (begin
+ (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))
+ ((and? exp) (eval-and (cdr exp) env))
+ ((or? exp) (eval-or (cdr exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+ (define (and? exp) (tagged-list? exp 'and))
+ (define (or? exp) (tagged-list? exp 'or))
+
+ (define (eval-and exp env)
+ (match exp
+ ((and)
+ 'true)
+ ((and ,head ,rest ...)
+ (let ((head-value (eval rest env)))
+ (if (eqv? head-value 'true)
+ head-value
+ (eval-and rest env))))))
+
+ (define (eval-or exp env)
+ (match exp
+ ((or)
+ 'false)
+ ((or ,head ,rest ...)
+ (let ((head-value (eval rest env)))
+ (if (eqv? head-value 'true)
+ (eval-or rest env)
+ 'false)))))
+
+ (define (eval-and-2 exp env)
+ (eval
+ `(if (null? ,exp)
+ 'true
+ ((lambda (car-value)
+ (if (true? car-value)
+ (if (null? ,(cdr exp))
+ car-value
+ (and ,(cdr exp)))
+ 'false))
+ ,(car exp)))
+ env))
+
+ (define (eval-or-2 exp env)
+ (eval
+ `(if (null? ,exp)
+ 'false
+ ((lambda (car-value)
+ (if (true? car-value)
+ car-value
+ (if (null? ,(cdr exp))
+ 'false
+ (or ,(cdr exp)))))
+ ,(car exp)))
+ env))))
diff --git a/sicp/solutions/chapter-4/old/exercise-5.scm b/sicp/solutions/chapter-4/old/exercise-5.scm
@@ -0,0 +1,42 @@
+(define-library (sicp solutions chapter-4 exercise-5)
+ (import (schemb base)
+ (ice-9 match))
+
+ (begin
+ (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 (cond->if exp)
+ (let expand-clauses ((clauses (cdr exp)))
+ (match clauses
+ ((cond) 'false)
+ (`((else ,actions)) (sequence->exp actions))
+ (`((else ,actions) ,rest ...)
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses))
+ (`((,predicate ,actions) ,rest ...)
+ (make-if predicate
+ (sequence->exp actions)
+ (expand-clauses '())))
+ (`((,predicate => ,recipient) ,rest ...)
+ (let ((predicate-value (eval predicate)))
+ (make-if predicate-value
+ (recipient predicate-value)
+ rest))))))))
diff --git a/sicp/solutions/chapter-4/old/exercise-6.scm b/sicp/solutions/chapter-4/old/exercise-6.scm
@@ -0,0 +1,37 @@
+(define-library (sicp solutions chapter-4 exercise-6)
+ (import (scheme base)
+ (ice-9 match))
+
+ (begin
+ (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))
+ ((let? exp) (eval (let->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+ (define (let? exp) (eqv? (car exp) 'let))
+
+ (define (let->combination exp)
+ (match exp
+ (`(let ,variables ,first-code-expression . ,rest-of-code-expressions)
+ (let ((variable-names (map car variables))
+ (variable-expressions (map cadr variables)))
+ `((lambda ,variable-names
+ ,first-code-expression
+ ,@rest-of-code-expressions)
+ ,@variable-expressions)))))))
diff --git a/sicp/solutions/chapter-4/old/exercise-7.scm b/sicp/solutions/chapter-4/old/exercise-7.scm
@@ -0,0 +1,73 @@
+(define-library (sicp solutions chapter-4 exercise-7)
+ (import (scheme base)
+ (ice-9 match))
+
+ (begin
+ (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))
+ ((let? exp) (eval (let->combination exp) env))
+ ((let*? exp) (eval (let*->nested-lets exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+ (define (let*? exp) (eqv? (car exp) 'let*))
+
+ (let*->combination '(let* () a b c))
+ (let*->combination '(let* ((a (b)) (c (d))) 1))
+
+ (define (let*->combination exp)
+ (match exp
+ (`(let* () ,first-code-expression . ,rest-of-code-expressions)
+ `(begin ,first-code-expression
+ ,@rest-of-code-expressions))
+ (`(let* ((,variable-name ,variable-expression))
+ ,first-code-expression . ,rest-of-code-expressions)
+ `((lambda (,variable-name)
+ ,first-code-expression
+ ,@rest-of-code-expressions)
+ ,variable-expression))
+ (`(let* ((,variable-name ,variable-expression) . ,rest-of-variables)
+ ,first-code-expression . ,rest-of-code-expressions)
+ (let ((inner
+ (let*->combination `(let* ,rest-of-variables
+ ,first-code-expression
+ ,@rest-of-code-expressions))))
+ `((lambda (,variable-name)
+ ,inner)
+ ,variable-expression)))))
+
+ (let*->nested-lets '(let* () a b c))
+ (let*->nested-lets '(let* ((a (b)) (c (d))) 1 2 3))
+
+ (define (let*->nested-lets exp)
+ (match exp
+ (`(let* () ,first-code-expression . ,rest-of-code-expressions)
+ `(begin ,first-code-expression
+ ,@rest-of-code-expressions))
+ (`(let* ((,variable-name ,variable-expression))
+ ,first-code-expression . ,rest-of-code-expressions)
+ `(let ((,variable-name ,variable-expression))
+ ,first-code-expression
+ ,@rest-of-code-expressions))
+ (`(let* ((,variable-name ,variable-expression) . ,rest-of-variables)
+ ,first-code-expression . ,rest-of-code-expressions)
+ `(let ((,variable-name ,variable-expression))
+ ,(let*->nested-lets
+ `(let* ,rest-of-variables
+ ,first-code-expression
+ ,@rest-of-code-expressions))))))))
diff --git a/sicp/solutions/chapter-4/old/exercise-8.scm b/sicp/solutions/chapter-4/old/exercise-8.scm
@@ -0,0 +1,72 @@
+(define-library (sicp solutions chapter-4 exercise-8)
+ (import (scheme base)
+ (ice-9 match))
+
+ (begin
+ (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))
+ ((let*? exp) (eval (let*->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+ (define (let*? exp) (eqv? (car exp) 'let*))
+
+ (let*->combination '(let* () a b c))
+ (let*->combination '(let* ((a (b)) (c (d))) 1))
+
+ (define (let*->combination exp)
+ (match exp
+ (`(let* () ,first-code-expression . ,rest-of-code-expressions)
+ `(begin ,first-code-expression
+ ,@rest-of-code-expressions))
+ (`(let* ((,variable-name ,variable-expression))
+ ,first-code-expression . ,rest-of-code-expressions)
+ `((lambda (,variable-name)
+ ,first-code-expression
+ ,@rest-of-code-expressions)
+ ,variable-expression))
+ (`(let* ((,variable-name ,variable-expression) . ,rest-of-variables)
+ ,first-code-expression . ,rest-of-code-expressions)
+ (let ((inner
+ (let*->combination `(let* ,rest-of-variables
+ ,first-code-expression
+ ,@rest-of-code-expressions))))
+ `((lambda (,variable-name)
+ ,inner)
+ ,variable-expression)))))
+
+ (let*->nested-lets '(let* () a b c))
+ (let*->nested-lets '(let* ((a (b)) (c (d))) 1 2 3))
+
+ (define (let*->nested-lets exp)
+ (match exp
+ (`(let* () ,first-code-expression . ,rest-of-code-expressions)
+ `(begin ,first-code-expression
+ ,@rest-of-code-expressions))
+ (`(let* ((,variable-name ,variable-expression))
+ ,first-code-expression . ,rest-of-code-expressions)
+ `(let ((,variable-name ,variable-expression))
+ ,first-code-expression
+ ,@rest-of-code-expressions))
+ (`(let* ((,variable-name ,variable-expression) . ,rest-of-variables)
+ ,first-code-expression . ,rest-of-code-expressions)
+ `(let ((,variable-name ,variable-expression))
+ ,(let*->nested-lets
+ `(let* ,rest-of-variables
+ ,first-code-expression
+ ,@rest-of-code-expressions))))))))
diff --git a/sicp/solutions/chapter-4/old/exercise-9.scm b/sicp/solutions/chapter-4/old/exercise-9.scm
@@ -0,0 +1,72 @@
+(define-library (sicp solutions chapter-4 exercise-9)
+ (import (scheme base)
+ (ice-9 match))
+
+ (begin
+ (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))
+ ((let*? exp) (eval (let*->combination exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp) env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+ (define (let*? exp) (eqv? (car exp) 'let*))
+
+ (let*->combination '(let* () a b c))
+ (let*->combination '(let* ((a (b)) (c (d))) 1))
+
+ (define (let*->combination exp)
+ (match exp
+ (`(let* () ,first-code-expression . ,rest-of-code-expressions)
+ `(begin ,first-code-expression
+ ,@rest-of-code-expressions))
+ (`(let* ((,variable-name ,variable-expression))
+ ,first-code-expression . ,rest-of-code-expressions)
+ `((lambda (,variable-name)
+ ,first-code-expression
+ ,@rest-of-code-expressions)
+ ,variable-expression))
+ (`(let* ((,variable-name ,variable-expression) . ,rest-of-variables)
+ ,first-code-expression . ,rest-of-code-expressions)
+ (let ((inner
+ (let*->combination `(let* ,rest-of-variables
+ ,first-code-expression
+ ,@rest-of-code-expressions))))
+ `((lambda (,variable-name)
+ ,inner)
+ ,variable-expression)))))
+
+ (let*->nested-lets '(let* () a b c))
+ (let*->nested-lets '(let* ((a (b)) (c (d))) 1 2 3))
+
+ (define (let*->nested-lets exp)
+ (match exp
+ (`(let* () ,first-code-expression . ,rest-of-code-expressions)
+ `(begin ,first-code-expression
+ ,@rest-of-code-expressions))
+ (`(let* ((,variable-name ,variable-expression))
+ ,first-code-expression . ,rest-of-code-expressions)
+ `(let ((,variable-name ,variable-expression))
+ ,first-code-expression
+ ,@rest-of-code-expressions))
+ (`(let* ((,variable-name ,variable-expression) . ,rest-of-variables)
+ ,first-code-expression . ,rest-of-code-expressions)
+ `(let ((,variable-name ,variable-expression))
+ ,(let*->nested-lets
+ `(let* ,rest-of-variables
+ ,first-code-expression
+ ,@rest-of-code-expressions))))))))
diff --git a/sicp/tests/chapter-4/exercise-3.scm b/sicp/tests/chapter-4/exercise-3.scm
@@ -0,0 +1,16 @@
+(define-library (sicp tests chapter-4 exercise-3)
+ (import (scheme base)
+
+ (srfi :64)
+
+ (sicp solutions chapter-4 exercise-3))
+
+ (begin
+ (test-begin "chapter-4-exercise-3")
+
+ (test-equal -1
+ (eval '(+ -2 1)
+ (make-environment '(+)
+ `((primitive ,+)))))
+
+ (test-end "chapter-4-exercise-3")))
