commit a26860d1fd71a1893d0d57266a62e13a303bcaf3
parent bb021278e94127a230d01ef47cb4236d770b7477
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Thu, 25 Jan 2024 13:41:23 +0200
Add original REPL from chapter 4. Also, two debug prints procedures.
Diffstat:
2 files changed, 402 insertions(+), 3 deletions(-)
diff --git a/sicp/solutions/chapter-4/original-repl.scm b/sicp/solutions/chapter-4/original-repl.scm
@@ -0,0 +1,391 @@
+#!/usr/bin/env -S guile --r7rs -L . -e '(sicp solutions chapter-4 original-repl)'
+!#
+
+(define-library (sicp solutions chapter-4 original-repl)
+ (import (scheme base)
+ (scheme read)
+ (scheme write)
+
+ (srfi srfi-1)
+
+ (ice-9 match)
+
+ (sicp utils))
+ (export main)
+
+ (begin
+ (define *debug* #f)
+
+ (define apply-in-underlying-scheme apply)
+
+;;; 4.1.1
+
+ (define (eval exp env)
+ (when *debug* (dp exp))
+ (cond
+ ((self-evaluating? exp)
+ (when *debug* (dp (list 'self-evaluating exp)))
+ exp)
+ ((variable? exp)
+ (when *debug* (dp (list 'variable exp)))
+ (lookup-variable-value exp env))
+ ((quoted? exp)
+ (when *debug* (dp (list 'quoted exp)))
+ (text-of-quotation exp))
+ ((definition? exp)
+ (when *debug* (dp (list 'definition exp)))
+ (eval-definition exp env))
+ ((if? exp)
+ (when *debug* (dp (list 'if exp)))
+ (eval-if exp env))
+ ((lambda? exp)
+ (when *debug* (dp (list 'lambda exp)))
+ (make-procedure
+ (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (when *debug* (dp (list 'begin exp)))
+ (eval-sequence
+ (begin-actions exp)
+ env))
+ ((cond? exp)
+ (when *debug* (dp (list 'cond exp)))
+ (eval (cond->if exp) env))
+ ((application? exp)
+ (when *debug* (dp (list 'application exp)))
+ ;; XXX: Renaming apply is an headache. Let's just call it
+ ;; our-apply.
+ (our-apply (eval (operator exp) env)
+ (list-of-values
+ (operands exp)
+ env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+ (define (our-apply procedure arguments)
+ ;; XXX: Renaming apply is an headache. Let's just call it
+ ;; our-apply.
+ (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))))
+
+;;; Conditionals:
+
+ (define (eval-if exp env)
+ (cond
+ ((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))))
+
+;;; 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)
+ (or (number? exp)
+ (string? exp)))
+ (define (variable? exp) (symbol? exp))
+ ;; XXX: I can't get the host language to support the guest
+ ;; language's quote, therefore we'll use (list 'qt blah) to quote
+ ;; blah.
+ (define (quoted? exp) (tagged-list? exp 'qt))
+ (define (text-of-quotation exp) (cadr exp))
+
+ (define (tagged-list? exp tag)
+ (and (pair? exp)
+ (eq? (car exp) tag)))
+
+ (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)
+ (cond
+ ((symbol? (cadr exp))
+ (cadr exp))
+ (else
+ (caadr exp))))
+ (define (definition-value exp)
+ (cond
+ ((symbol? (cadr exp))
+ (caddr exp))
+ (else
+ (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
+ 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)
+ (cond
+ ((not (null? (cdddr exp)))
+ (cdddr 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)
+ (cond
+ ((null? clauses)
+ 'false
+ (let ((first-clause (car clauses))
+ (rest-of-clauses (cdr clauses)))
+ (cond
+ ((cond-else-clause? first-clause)
+ (cond
+ ((null? rest-of-clauses)
+ (sequence->exp
+ (cond-actions first-clause)))
+ (else
+ (error "ELSE clause isn't last: COND->IF"))))
+ (else
+ (make-if (cond-predicate first-clause)
+ (sequence->exp (cond-actions first-clause))
+ (expand-clauses rest-of-clauses))))))))
+
+;;; end 4.1.2
+
+;;; 4.1.3
+
+ ;; The symbol false is the only false in the language.
+
+ (define (true? x) (not (false? x)))
+ (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 (define-variable! var val env)
+ (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))))
+
+ (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)
+ (let ((vars-length (length vars))
+ (vals-length (length vals)))
+ (cond
+ ((= vars-length vals-length)
+ (cons (make-frame vars vals) base-env))
+ ((< vars-length vals-length)
+ (error "Too many arguments supplied:" vars vals))
+ (else
+ (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)))))
+ (cond
+ ((eq? env the-empty-environment)
+ (error "Unbound variable" var))
+ (else
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame))))))
+ (env-loop env))
+
+
+ (define (set-variable-value! var val env)
+ (define (env-lookup env)
+ (define (scan vars vals)
+ (cond
+ ((null? vars)
+ (env-lookup
+ (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-lookup env))
+
+ (define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+;;; 4.1.4
+
+
+ (define (setup-environment)
+ (let* ((primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '/ /)))
+ (primitive-procedure-names (map car primitive-procedures))
+ (primitive-procedure-objects (map (lambda (proc)
+ (list 'primitive (cadr proc)))
+ primitive-procedures))
+ (initial-env
+ (extend-environment
+ primitive-procedure-names
+ primitive-procedure-objects
+ the-empty-environment)))
+ (define-variable! 'true 'true initial-env)
+ (define-variable! 'false 'false initial-env)
+ initial-env))
+
+ (define the-global-environment
+ (setup-environment))
+
+ (define (primitive-procedure? proc) (tagged-list? proc 'primitive))
+ (define (primitive-implementation proc) (cadr proc))
+
+ (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))
+ (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)
+ (cond
+ ((compound-procedure? object)
+ (display
+ (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>)))
+ (else
+ (display object))))
+
+ (define (main args)
+ (match args
+ (`(,arg0)
+ '())
+ (`(,arg0 "--debug")
+ (set! *debug* #t))
+ (_ (error "Unknown arguments:" args)))
+ (driver-loop))))
diff --git a/sicp/utils.scm b/sicp/utils.scm
@@ -1,15 +1,23 @@
(define-library (sicp utils)
- (import (scheme base))
- (import (scheme write))
+ (import (scheme base)
+ (scheme write)
+
+ (ice-9 pretty-print))
(export
accumulate
+ dp
+ enumerate-interval
filter
flatmap
- enumerate-interval)
+ pp
+ )
(begin
(define nil '())
+ (define (dp x) (write x) (newline))
+ (define (pp x) (pretty-print x))
+
(define (filter predicate sequence)
;; From 2.2.3 Sequences as Conventional Interfaces
(cond ((null? sequence) nil)
