commit 8978894f0dbf87ac414fd70911405156379eacc0
parent a26860d1fd71a1893d0d57266a62e13a303bcaf3
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Thu, 18 Jul 2024 11:33:46 +0300
Make the original SICP REPL kinda work.
- `quote` works.
- `if` works.
- some other stuff works, probably.
- NEEDS MORE TESTING.
Diffstat:
4 files changed, 226 insertions(+), 158 deletions(-)
diff --git a/Makefile b/Makefile
@@ -17,6 +17,9 @@ print_variables:
$(tests_logs):
guile -L . `printf $@ | sed -E 's#(chapter-[0-9]*)-(exercise-[0-9]+).log#sicp/tests/\1/\2.scm#g'`
+original-repl-tests.log:
+ guile --no-auto-compile -L . sicp/tests/chapter-4/original-repl-tests.scm
+
.PHONY: statistics
statistics:
guile -L . -e '(@ (sicp statistics) main)' -s sicp/statistics.scm
diff --git a/sicp/solutions/chapter-1/exercise-22.scm b/sicp/solutions/chapter-1/exercise-22.scm
@@ -1,57 +1,62 @@
+(define-library (sicp solutions chapter-1 exercise-22)
+ ;; Exercise 1.22
+ (import (scheme base)
+ (scheme write)
+
+ (sicp utils))
+
+ (begin
+ (define (run-delay-if-full-flag d)
+ (if (any (cut equal? "--full" <>)
+ (command-line))
+ (force d)))
+
+ (run-delay-if-full-flag
+ (delay
+ (let ((port (open-output-file "primes.txt")))
+
+ (define (runtime)
+ (time-nanosecond (current-time time-process)))
+
+ (define (display x)
+ (format port "~a" x))
+
+ (define (newline)
+ (format port "\n"))
+
+ (define (timed-prime-test n)
+ ;; (newline)
+ ;; (display n)
+ (start-timed-test n (runtime)))
+
+ (define (start-timed-test n start-time)
+ (cond
+ ((prime? n)
+ (newline)
+ (display "[")
+ (display n)
+ (report-prime (- (runtime)
+ start-time)))
+ (else #f)))
+
+ (define (report-prime elapsed-time)
+ (display ", ")
+ (display elapsed-time)
+ (display "],")
+ (newline)
+ #t)
+
+ (define (search-for-primes start-number end-number)
+ (cond
+ ((> start-number end-number) '())
+ ((timed-prime-test start-number)
+ (cons start-number
+ (search-for-primes (+ start-number 2) end-number)))
+ (else (search-for-primes (+ start-number 2) end-number))))
-;; Exercise 1.22
-
-(define (run-delay-if-full-flag d)
- (if (any (cut equal? "--full" <>)
- (command-line))
- (force d)))
-
-(run-delay-if-full-flag
- (delay
- (let ((port (open-output-file "primes.txt")))
-
- (define (runtime)
- (time-nanosecond (current-time time-process)))
-
- (define (display x)
- (format port "~a" x))
-
- (define (newline)
- (format port "\n"))
+ (display "[")
- (define (timed-prime-test n)
- ;; (newline)
- ;; (display n)
- (start-timed-test n (runtime)))
+ (search-for-primes 3 100001)
- (define (start-timed-test n start-time)
- (cond
- ((prime? n)
- (newline)
- (display "[")
- (display n)
- (report-prime (- (runtime)
- start-time)))
- (else #f)))
-
- (define (report-prime elapsed-time)
- (display ", ")
- (display elapsed-time)
- (display "],")
- (newline)
- #t)
-
- (define (search-for-primes start-number end-number)
- (cond
- ((> start-number end-number) '())
- ((timed-prime-test start-number)
- (cons start-number
- (search-for-primes (+ start-number 2) end-number)))
- (else (search-for-primes (+ start-number 2) end-number))))
-
- (display "[")
-
- (search-for-primes 3 100001)
-
- (display "]")
- (newline))))
+ (display "]")
+ (newline))))))
diff --git a/sicp/solutions/chapter-4/original-repl.scm b/sicp/solutions/chapter-4/original-repl.scm
@@ -1,71 +1,68 @@
-#!/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)
+ (export main eval)
+ (import (rename (scheme base) (apply scheme:base:apply))
+ (prefix (scheme cxr) scheme:cxr:)
+ (prefix (scheme read) scheme:read:)
+ (prefix (scheme write) scheme:write:)
- (srfi srfi-1)
+ (srfi srfi-9)
(ice-9 match)
(sicp utils))
- (export main)
(begin
(define *debug* #f)
- (define apply-in-underlying-scheme apply)
+;;; Start:
;;; 4.1.1
(define (eval exp env)
- (when *debug* (dp exp))
+ (when *debug* (pp (list 'eval exp)))
(cond
((self-evaluating? exp)
- (when *debug* (dp (list 'self-evaluating exp)))
+ (when *debug* (pp (list 'self-evaluating exp)))
exp)
((variable? exp)
- (when *debug* (dp (list 'variable exp)))
- (lookup-variable-value exp env))
+ (when *debug* (pp (list 'variable exp
+ 'env env)))
+ (let ((value (lookup-variable-value exp env)))
+ (when *debug* (pp (list 'value value)))
+ value))
((quoted? exp)
- (when *debug* (dp (list 'quoted exp)))
+ (when *debug* (pp (list 'quoted exp)))
(text-of-quotation exp))
((definition? exp)
- (when *debug* (dp (list 'definition exp)))
+ (when *debug* (pp (list 'definition exp)))
(eval-definition exp env))
((if? exp)
- (when *debug* (dp (list 'if exp)))
+ (when *debug* (pp (list 'if exp)))
(eval-if exp env))
((lambda? exp)
- (when *debug* (dp (list 'lambda exp)))
+ (when *debug* (pp (list 'lambda exp)))
(make-procedure
(lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
- (when *debug* (dp (list 'begin exp)))
+ (when *debug* (pp (list 'begin exp)))
(eval-sequence
(begin-actions exp)
env))
((cond? exp)
- (when *debug* (dp (list 'cond exp)))
+ (when *debug* (pp (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)))
+ (when *debug* (pp (list 'application exp)))
+ (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.
+ (define (apply procedure arguments)
(cond
((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
@@ -81,13 +78,13 @@
;;; Conditionals:
(define (eval-if exp env)
- (cond
- ((true? (eval (if-predicate exp) env))
- (eval (if-consequent exp) env)
- (eval (if-alternative 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)
@@ -96,6 +93,7 @@
;;; Assignments and definitions
+
(define (eval-assignment exp env)
(set-variable-value!
(assignment-variable exp)
@@ -104,24 +102,29 @@
'ok)
(define (eval-definition exp env)
- (define-variable!
- (definition-variable exp)
- (eval (definition-value exp) env)
- env)
+ (when *debug* (dp (list 'eval-definition exp)))
+ (let ((def-var (definition-variable exp))
+ (def-val (definition-value exp)))
+ (when *debug*
+ (dp (list 'definition-variable def-var))
+ (dp (list 'definition-value def-val)))
+ (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 (quoted? exp) (tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
@@ -130,7 +133,7 @@
(define (assignment? exp) (tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
- (define (assignment-value exp) (caddr exp))
+ (define (assignment-value exp) (scheme:cxr:caddr exp))
(define (definition? exp)
(tagged-list? exp 'define))
@@ -139,33 +142,43 @@
((symbol? (cadr exp))
(cadr exp))
(else
- (caadr exp))))
+ (scheme:cxr:caadr exp))))
(define (definition-value exp)
(cond
((symbol? (cadr exp))
- (caddr exp))
+ (scheme:cxr:caddr exp))
(else
- (make-lambda
- (cdadr exp) ; Formal parameters.
- (cddr exp) ; Body.
- ))))
+ (let ((formal-parameters (scheme:cxr:cdadr exp))
+ (body (cddr exp)))
+ (when *debug*
+ (dp (list 'formal-parameters formal-parameters))
+ (dp (list 'body body)))
+ (make-lambda formal-parameters
+ 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))
+ (let ((our-lambda `(lambda ,parameters ,@body)))
+ (when *debug* (dp (list 'our-lambda our-lambda)))
+ our-lambda))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
- (define (if-consequent exp) (caddr exp))
+ (define (if-consequent exp) (scheme:cxr:caddr exp))
(define (if-alternative exp)
- (cond
- ((not (null? (cdddr exp)))
- (cdddr exp)
- 'false)))
+ (match exp
+ (`(if ,p ,c ,a)
+ a)
+ (`(if ,p ,c)
+ 'false)
+ (otherwise (error "Malformed if:" otherwise)))
+ ;; (cond
+ ;; ((not (null? (scheme:cxr:cdddr exp)))
+ ;; (scheme:cxr:cdddr exp)
+ ;; 'false))
+ )
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
@@ -219,26 +232,32 @@
;; 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 (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 (frame-variables frame)))
+ (set-cdr! frame (cons val (frame-values frame))))
(define (define-variable! var val env)
+ "Add variable VAR with value VAL to environment ENV."
+
+ ;; We will CHANGE only the first frame
(let ((frame (first-frame env)))
(define (scan vars vals)
(cond ((null? vars)
- (add-binding-to-frame!
- var val frame))
+ (add-binding-to-frame! var
+ val
+ frame))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars)
(cdr vals)))))
+ (when *debug* (dp (frame-values frame)))
(scan (frame-variables frame)
(frame-values frame))))
@@ -246,13 +265,13 @@
(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 (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) (scheme:cxr:caddr p))
+ (define (procedure-environment p) (scheme:cxr:cadddr p))
(define (extend-environment vars vals base-env)
(let ((vars-length (length vars))
@@ -315,17 +334,13 @@
(define (setup-environment)
(let* ((primitive-procedures
- (list (list 'car car)
- (list 'cdr cdr)
- (list 'cons cons)
- (list 'null? null?)
- (list '+ +)
- (list '- -)
- (list '* *)
- (list '/ /)))
+ `((car ,car)
+ (cdr ,cdr)
+ (cons ,cons)
+ (null? ,null?)))
(primitive-procedure-names (map car primitive-procedures))
(primitive-procedure-objects (map (lambda (proc)
- (list 'primitive (cadr proc)))
+ `(primitive ,(cadr proc)))
primitive-procedures))
(initial-env
(extend-environment
@@ -343,7 +358,7 @@
(define (primitive-implementation proc) (cadr proc))
(define (apply-primitive-procedure proc args)
- (apply-in-underlying-scheme
+ (scheme:base:apply
(primitive-implementation proc) args))
(define input-prompt ";;; M-Eval input:")
@@ -351,41 +366,67 @@
(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))
+ (let loop ((input (scheme:read:read)))
+
+ (when *debug* (pp (list 'input input)))
+ (cond
+ ((eof-object? input)
+ (when *debug* (pp (list 'the-global-environment
+ the-global-environment))))
+ (else
+ (when *debug* (pp (list 'the-global-environment
+ the-global-environment)))
+ (let* ((output (eval input the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output))
+ (prompt-for-input input-prompt)
+ (loop (scheme:read:read))))))
(define (prompt-for-input string)
(newline)
(newline)
- (display string)
+ (scheme:write:display string)
(newline))
(define (announce-output string)
(newline)
- (display string)
+ (scheme:write:display string)
(newline))
(define (user-print object)
(cond
- ((compound-procedure? object)
- (display
- (list 'compound-procedure
- (procedure-parameters object)
- (procedure-body object)
- '<procedure-env>)))
+ ((procedure? object)
+ (let ((proc (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>)))
+ (when *debug* (pp proc))
+ proc))
(else
- (display object))))
+ (pp object))))
(define (main args)
(match args
+ ('()
+ (error "Arguments should have something rather than nothing."))
(`(,arg0)
- '())
+ (scheme:write:display arg0)
+ (newline))
(`(,arg0 "--debug")
+ (scheme:write:display "DEBUG TURN ON!\n")
(set! *debug* #t))
- (_ (error "Unknown arguments:" args)))
- (driver-loop))))
+ (args (error "Unknown arguments:" args)))
+
+ (eval '(define (x y)
+ (cond
+ ((null? x)
+ y)
+ (else
+ (cons (car x)
+ (append (cdr x)
+ y)))))
+ the-global-environment)
+
+ (when *debug* (dp (list 'starting-with-the-global-environment: the-global-environment)))
+ (driver-loop))
+ ))
diff --git a/sicp/utils.scm b/sicp/utils.scm
@@ -2,7 +2,9 @@
(import (scheme base)
(scheme write)
- (ice-9 pretty-print))
+ (ice-9 pretty-print)
+
+ (srfi srfi-19))
(export
accumulate
dp
@@ -15,8 +17,8 @@
(begin
(define nil '())
- (define (dp x) (write x) (newline))
- (define (pp x) (pretty-print x))
+ (define (dp x) (write x) (newline) x)
+ (define (pp x) (pretty-print x) x)
(define (filter predicate sequence)
;; From 2.2.3 Sequences as Conventional Interfaces
@@ -49,4 +51,21 @@
(define (flatmap proc seq)
(accumulate append
'()
- (map proc seq)))))
+ (map proc seq)))
+
+ (define (current-time->microseconds t)
+ (let* ((start-seconds (time-second start-time))
+ (start-nanoseconds (time-nanosecond start-time)))
+ (+ (* start-seconds (expt 10 6))
+ (quotient start-nanoseconds
+ (expt 10 3)))))
+
+ '(define runtime
+ (let* ((start-time (current-time time-utc))
+ (start-microseconds (current-time->microseconds start-time)))
+
+ (lambda ()
+ (let* ((t (current-time time-utc))
+ (t-microseconds (current-time->microseconds t)))
+ (- start-microseconds t-microseconds)))))
+ ))
