-#lang racket
+#lang planet neil/sicp
-(require "ex4_8.rkt" ;; for let and named let
+(#%require "ex4_8.rkt" ;; for let and named let
"ex4_7.rkt")
;; metacircular evaluator
(else
(error "unknown expression type -- EVAL" exp))))
+;; capture the underlying apply before redefining it
+(define apply-in-underlying-scheme apply)
+
(define (apply procedure arguments)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
-(define (rest-exp seq) (cdr seq))
+(define (rest-exps seq) (cdr seq))
(define (sequence->exp seq)
(cond ((null? seq) seq)
clauses))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
- (expand-clauses rest))))))
\ No newline at end of file
+ (expand-clauses rest))))))
+
+;; true and false
+(define (true? x)
+ (not (eq? x false)))
+
+(define (false? x)
+ (eq? x false))
+
+;; procedures
+(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))
+
+;; operations on environment
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+
+;; frame operations
+(define (make-frame variables values)
+ (cons variables values))
+
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-bindings-to-frame! var val frame)
+ (set-car! frame (cons var (frame-variables frame)))
+ (set-cdr! frame (cons val (frame-values 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 args supplied" vars vals)
+ (error "Too many args 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)
+ (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" 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-bindings-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))))
+
+
+;; primitive procedures
+(define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+(define (primitive-implementation proc) (cadr proc))
+
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '+ +)
+ (list '- -)
+ (list '= =)))
+
+(define (primitive-procedure-names)
+ (map car primitive-procedures))
+
+(define (primitive-procedure-objects)
+ (map (lambda (proc) (list 'primitive (cadr proc)))
+ primitive-procedures))
+
+;; apply from implementation language
+(define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+;; setting up the environment
+(define (setup-environment)
+ (let ((initial-env
+ (extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ the-empty-environment)))
+ (define-variable! 'true #t initial-env)
+ (define-variable! 'false #f initial-env)
+ initial-env))
+
+(define the-global-environment (setup-environment))
+
+