commit b21671ddbc8e13949930c3c62976ee8f174ef230 (patch)
parent 9f2452e6555c909dd8142dd32ee2b9e122cfec47
Author: Alex Karle <alex@alexkarle.com>
Date: Fri, 11 Nov 2022 00:45:06 -0500
Add SICP implementation up to ch4.1.4
yes, I typed it by hand! :O
Diffstat:
| A | sicp.scm | | | 322 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
1 file changed, 322 insertions(+), 0 deletions(-)
diff --git a/sicp.scm b/sicp.scm
@@ -0,0 +1,322 @@
+#!/usr/local/bin/chicken-csi -ss
+;; sicp.scm -- pretty much verbatim the SICP version
+;; (with a few extensions / CHICKEN-isms)
+(import (chicken io))
+
+(define (_eval expr env)
+ (cond
+ ((self-evaluating? expr) expr)
+ ((variable? expr) (lookup-variable-value expr env))
+ ((quoted? expr) (text-of-quotation expr))
+ ((assignment? expr) (eval-assignment expr env))
+ ((definition? expr) (eval-definition expr env))
+ ((if? expr) (eval-if expr env))
+ ((lambda? expr)
+ (make-procedure (lambda-parameters expr)
+ (lambda-body expr)
+ env))
+ ((begin? expr)
+ (eval-sequence (begin-actions expr) env))
+ ((cond? expr) (_eval (cond->if expr) env))
+ ((application? expr)
+ (_apply (_eval (operator expr) env)
+ (map (lambda (o) (_eval o env)) (operands expr))))
+ (else
+ (error "Unknown expr type -- EVAL" expr))))
+
+(define (_apply proc args)
+ (cond
+ ((primitive-procedure? proc)
+ (apply-primitive-procedure proc args))
+ ((compound-procedure? proc)
+ (eval-sequence
+ (procedure-body proc)
+ (extend-environment
+ (procedure-parameters proc)
+ args
+ (procedure-environment proc))))
+ (else (error "Unknown proc type -- APPLY" proc))))
+
+(define (eval-if expr env)
+ (if (true? (_eval (if-predicate expr) env))
+ (_eval (if-consequent expr) env)
+ (_eval (if-alternative expr) env)))
+
+(define (eval-sequence exprs env)
+ (cond
+ ((last-exp? exprs) (_eval (first-exp exprs) env))
+ (else (_eval (first-exp exprs) env)
+ (eval-sequence (rest-exps exprs) env))))
+
+(define (eval-assignment expr env)
+ (set-variable-value! (assignment-variable expr)
+ (_eval (assignment-value expr) env)
+ env)
+ 'ok)
+
+(define (eval-definition expr env)
+ (define-variable! (definition-variable expr)
+ (_eval (definition-value expr) env)
+ env)
+ 'ok)
+
+(define (self-evaluating? expr)
+ (cond ((number? expr) #t)
+ ((string? expr) #t)
+ (else #f)))
+
+(define (variable? expr) (symbol? expr))
+
+(define (tagged-list? l sym)
+ (and (pair? l) (eq? (car l) sym)))
+
+(define (quoted? expr)
+ (tagged-list? expr 'quote))
+
+(define (text-of-quotation expr) (cadr expr))
+
+(define (assignment? expr)
+ (tagged-list? expr 'set!))
+
+(define (assignment-variable expr) (cadr expr))
+
+(define (assignment-value expr) (caddr expr))
+
+(define (definition? expr)
+ (tagged-list? expr 'define))
+
+(define (definition-variable expr)
+ (if (symbol? (cadr expr))
+ (cadr expr)
+ (caadr expr)))
+
+(define (definition-value expr)
+ (if (symbol? (cadr expr))
+ (caddr expr)
+ (make-lambda (cdadr expr) (cddr expr))))
+
+(define (lambda? expr) (tagged-list? expr 'lambda))
+
+(define (lambda-parameters expr) (cadr expr))
+
+(define (lambda-body expr) (cddr expr))
+
+(define (make-lambda parameters body)
+ ;; `(lambda ,parameters ,@body)) ?
+ (cons 'lambda (cons parameters body)))
+
+(define (if? expr) (tagged-list? expr 'if))
+
+(define (if-predicate expr) (cadr expr))
+
+(define (if-consequent expr) (caddr expr))
+
+(define (if-alternative expr)
+ (if (not (null? (cdddr expr)))
+ (cadddr expr)
+ 'false))
+
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (begin? expr) (tagged-list? expr 'begin))
+
+(define (begin-actions expr) (cdr expr))
+
+(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? expr) (pair? expr))
+
+(define (operator expr) (car expr))
+
+(define (operands expr) (cdr expr))
+
+(define (no-operands? ops) (null? ops))
+
+(define (first-operand ops) (car ops))
+
+(define (rest-operands ops) (cdr ops))
+
+(define (cond? expr) (tagged-list? expr 'cond))
+
+(define (cond-clauses expr) (cdr expr))
+
+(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 expr)
+ (expand-clauses (cond-clauses expr)))
+
+(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))))))
+
+(define (true? x) (not (false? x)))
+
+(define (false? x) (eq? x #f))
+
+(define (make-procedure params body env)
+ (list 'procedure params 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-env '())
+
+(define (make-frame vars vals)
+ (cons vars vals))
+
+(define (frame-variables f) (car f))
+
+(define (frame-values f) (cdr f))
+
+(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-lookup env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-lookup (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (eq? env the-empty-env)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-lookup env))
+
+
+(define (set-variable-value! var val env)
+ (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-env)
+ (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)
+ (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 (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-env)))
+ (define-variable! 'true #t initial-env)
+ (define-variable! 'false #f initial-env)
+ initial-env))
+
+
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+
+(define primitive-procedures
+ `((car ,car)
+ (cdr ,cdr)
+ (cons ,cons)
+ (null? ,null?)
+ (< ,<)
+ (<= ,<=)
+ (> ,>)
+ (>= ,>=)
+ (= ,=)
+ (+ ,+)
+ (* ,*)
+ (- ,-)
+ (/ ,/)))
+
+(define (primitive-procedure-names)
+ (map car primitive-procedures))
+
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+
+(define the-global-env (setup-environment))
+
+(define (apply-primitive-procedure proc args)
+ (apply (primitive-implementation proc) args))
+
+(define input-prompt "#;> ")
+
+(define (user-print object)
+ (if (compound-procedure? object)
+ (print (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (print object)))
+
+(define (driver-loop)
+ (display input-prompt)
+ (let ((input (read)))
+ (if (not (eof-object? input))
+ (begin
+ (user-print (_eval input the-global-env))
+ (driver-loop)))))
+
+(define (main args)
+ (driver-loop))
