(apply apply-in-underlying-scheme)
(eval eval-in-underlying-scheme)))
+(provide (all-defined-out))
+
(define (self-evaluating? expr)
(match expr
[(? number? expr) #t]
(define (variable? expr) (symbol? expr))
-
;; sequence
(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))))
+ (cond
+ [(last-exp? exps) (eval (first-exp exps) env)]
+ [else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env)]))
;; begin
(define (last-exp? seq) (null? (cdr seq)))
;; lambda
(define (make-lambda parameters body)
- (cons 'lambda (cons parameters (list body))))
+ (cons 'lambda (cons parameters body)))
;; environment data structures
(define (enclosing-environment env) (cdr env))
(define (lookup-variable-value var env)
(if (eq? env the-empty-environment)
- (error "unbound variable:" var)
+ (error "unbound variable: " var)
(let ([frame (first-frame env)])
- (hash-ref frame var (lambda () (lookup-variable-value var (enclosing-environment env)))))))
+ (let ([value (hash-ref frame var (lambda () (lookup-variable-value var (enclosing-environment env))))])
+ (if (eq? value '*unassigned*)
+ (error "evaluating a variable that is not assigned a value -- " var)
+ value)))))
(define (set-variable-value! var val env)
(if (eq? env the-empty-environment)
- (error "unbound variable")
+ (error "unbound variable: " var)
(let ([frame (first-frame env)])
(if (hash-has-key? frame var)
(hash-set! frame var val)
(list '+ +)
(list '- -)
(list '* *)
- (list '/ /)))
+ (list '/ /)
+ (list '= =)
+ (list '> >)
+ (list '< <)))
(define (primitive-procedure-names)
(map car primitive-procedures))
(primitive-implementation proc) args))
;; global env
-(define (setup-environment)
+(define (make-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
(define-variable! 'false false initial-env)
initial-env))
-(define the-global-environment (setup-environment))
+(define the-global-environment (make-environment))
;; application
(define (list-of-values exps env)
;; compound procedure
(define (make-procedure params body env)
- (list 'procedure params body env))
+ (list 'procedure params (scan-out-definitions body) env))
(define (procedure-parameters p) (cadr p))
-(define (procedure-body p) (caddr p))
+(define (procedure-body p) (scan-out-definitions (caddr p)))
(define (procedure-environment p) (cadddr p))
(define (apply procedure arguments)
(match procedure
[`(primitive ,f ...) (apply-primitive-procedure procedure arguments)]
[`(procedure ,f ...) (eval-sequence
- (procedure-body procedure)
- (extend-environment
- (procedure-parameters procedure)
- arguments
- (procedure-environment procedure)))]
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters procedure)
+ arguments
+ (procedure-environment procedure)))]
[_ (error "Unknown procedure type -- APPLY" procedure)]))
;; truth
;; let
(define (let->combination lexpr)
- (match-let* ([`(let ,bindings ,body) lexpr]
+ (match-let* ([`(let ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) lexpr]
[`((,var ,val) ...) bindings])
- `((lambda ,var ,body) ,@val)))
+ `((lambda ,var ,@body) ,@val)))
+
+;; named let
+(define (named-let->combination lexpr)
+ (match-let* ([`(let ,(? symbol? name) ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) lexpr]
+ [`((,var ,val) ...) bindings])
+ `(begin (define ,name (lambda ,var ,@body))
+ (,name ,@val))))
;; let*
(define (let*->nested-lets lexpr)
(match lexpr
- [`(let* (,first-binding ,rest-bindings ...) ,body)
- `(let (,first-binding) ,(let*->nested-lets `(let* ,rest-bindings ,body)))]
- [`(let* () ,body) body]))
+ [`(let* (,first-binding ,rest-bindings ...) ,body ..1)
+ `(let (,first-binding) ,(let*->nested-lets `(let* ,rest-bindings ,@body)))]
+ [`(let* () ,body ..1) `(let () ,@body)]))
+
+;; internal definitions
+(define (scan-out-definitions body)
+ (match body
+ [`((define ,var ,e) ..1 ,rest)
+ `((let ,(map (lambda (v) (list (car v) ''*unassigned*)) var)
+ ,@(map (lambda (v e) `(set! ,(car v) (lambda ,(cdr v) ,e))) var e)
+ ,rest))]
+ [_ body]))
+
+;; letrec
+(define (letrec->combination lexpr)
+ (match lexpr
+ [`(letrec (,bindings ...) ,body ..1)
+ `(let ,(map (lambda (v) (list (car v) ''*unassigned*)) bindings)
+ ,@(map (lambda (binding)
+ (let ([name (car binding)]
+ [value (cadr binding)])
+ `(set! ,name ,value)))
+ bindings)
+ ,@body)]))
;; eval
(define (eval exp env)
+ ;; use this display statement to visualize the recursive evaluation process
+ ;;(display (format "~s~%" exp))
(match exp
[(? self-evaluating? exp) exp]
[(? variable? exp) (lookup-variable-value exp env)]
[`(quote ,x) x]
[`(set! ,var ,val) (set-variable-value! var (eval val env) env)]
[`(define ,(? (lambda (x) (not (pair? x))) var) ,b) (define-variable! var (eval b env) env)]
- [`(define ,(? pair? var) ,b) (define-variable! (car var) (eval (make-lambda (cdr var) b) env) env)]
+ [`(define ,(? pair? var) ,b ..1) (define-variable! (car var) (eval (make-lambda (cdr var) b) env) env)]
[`(if ,pred ,consequent ,alternative) (if (true? (eval pred env)) (eval consequent env) (eval alternative env))]
- [`(lambda ,parameters ,body ...) (make-procedure parameters body env)]
+ [`(unless ,condition ,consequent ,alternative) (if (true? (eval condition env)) (eval alternative env) (eval consequent env))]
+ [`(lambda ,parameters ,body ..1) (make-procedure parameters body env)]
[`(begin ,exp ...) (eval-sequence exp env)]
[`(cond ,clauses ...) (eval (cond->if clauses) env)]
- [`(let ,bindings ,body) (eval (let->combination exp) env)]
- [`(let* ,bindings ,body) (eval (let*->nested-lets exp) env)]
- [(list f x ...) (apply (eval f env) (list-of-values x env))]
+ [`(let ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) (eval (let->combination exp) env)]
+ [`(let ,(? symbol? name) ,bindings ,body ..1) (eval (named-let->combination exp) env)]
+ [`(let* ,bindings ,body ..1) (eval (let*->nested-lets exp) env)]
+ [`(letrec ,bindings ,body ..1) (eval (letrec->combination exp) env)]
+ [`(,f ,x ...) (apply (eval f env) (list-of-values x env))]
[_ (error "unable to evaluate expression -- EVAL " exp)]))
projects / sicp.git / blobdiff