src/sicp/eval-4.33.rkt

   1 #lang racket
   2
   3 (require (rename-in racket/base
   4                     [apply apply-in-underlying-scheme]
   5                     [eval eval-in-underlying-scheme]
   6                     [cons cons-in-underlying-scheme]
   7                     [car  car-in-underlying-scheme]
   8                     [cdr  cdr-in-underlying-scheme]))
   9
  10 (provide (all-defined-out))
  11
  12 (define (self-evaluating? expr)
  13   (match expr
  14     [(? number? expr) #t]
  15     [(? char? expr) #t]
  16     [(? string? expr) #t]
  17     [_ #f]))
  18
  19 (define (variable? expr) (symbol? expr))
  20
  21 ;; sequence
  22 (define (eval-sequence exps env)
  23   (cond
  24     [(last-exp? exps) (eval (first-exp exps) env)]
  25     [else (eval (first-exp exps) env)
  26           (eval-sequence (rest-exps exps) env)]))
  27
  28 ;; begin
  29 (define (last-exp? seq) (null? (cdr seq)))
  30 (define (first-exp seq) (car seq))
  31 (define (rest-exps seq) (cdr seq))
  32
  33 ;; lambda
  34 (define (make-lambda parameters body)
  35   (cons 'lambda (cons parameters body)))
  36
  37 ;; environment data structures
  38 (define (enclosing-environment env) (cdr env))
  39 (define (first-frame env) (car env))
  40 (define the-empty-environment '())
  41
  42 (define (make-frame variables values)
  43   (let ([ht (make-hash)])
  44     (for-each (lambda (var val)
  45                 (hash-set! ht var val))
  46               variables
  47               values)
  48     ht))
  49
  50 (define (frame-variables frame)
  51   (hash-keys frame))
  52
  53 (define (frame-values frame)
  54   (hash-values frame))
  55
  56 (define (add-binding-to-frame! var val frame)
  57   (hash-set! frame var val))
  58
  59 ;; environment is a list of frames, most recent being the last
  60 ;; one consed into the list
  61 (define (extend-environment vars vals base-env)
  62   (let ([frame (make-frame vars vals)])
  63     (cons-in-underlying-scheme frame base-env)))
  64
  65 (define (lookup-variable-value var env)
  66   (if (eq? env the-empty-environment)
  67       (error "unbound variable: " var)
  68       (let ([frame (first-frame env)])
  69         (let ([value (hash-ref frame var (lambda () (lookup-variable-value var (enclosing-environment env))))])
  70           (if (eq? value '*unassigned*)
  71               (error "evaluating a variable that is not assigned a value -- " var)
  72               value)))))
  73
  74 (define (set-variable-value! var val env)
  75   (if (eq? env the-empty-environment)
  76       (error "unbound variable: " var)
  77       (let ([frame (first-frame env)])
  78         (if (hash-has-key? frame var)
  79             (hash-set! frame var val)
  80             (set-variable-value! var val (enclosing-environment env))))))
  81
  82 (define (define-variable! var val env)
  83   (let ([frame (first-frame env)])
  84     (if (hash-has-key? frame var)
  85         (hash-set! frame var val)
  86         (add-binding-to-frame! var val frame))))
  87
  88 ;; primitive procedure
  89 (define (primitive-implementation proc) (cadr proc))
  90
  91 (define primitive-procedures
  92   (list  (list 'cons cons-in-underlying-scheme)
  93          (list 'car car-in-underlying-scheme)
  94          (list 'cdr cdr-in-underlying-scheme)
  95          (list 'null? null?)
  96          (list 'list list)
  97          (list '+ +)
  98          (list '- -)
  99          (list '* *)
 100          (list '/ /)
 101          (list '= =)
 102          (list '> >)
 103          (list '< <)
 104          (list 'newline newline)
 105          (list 'display display)))
 106
 107 (define (primitive-procedure-names)
 108   (map car-in-underlying-scheme primitive-procedures))
 109
 110 (define (primitive-procedure-objects)
 111   (map (lambda (proc) (list 'primitive (cadr proc)))
 112        primitive-procedures))
 113
 114 (define (apply-primitive-procedure proc args)
 115   (apply-in-underlying-scheme
 116    (primitive-implementation proc) args))
 117
 118 ;; global env
 119 (define (make-environment)
 120   (let ((initial-env
 121          (extend-environment (primitive-procedure-names)
 122                              (primitive-procedure-objects)
 123                              the-empty-environment)))
 124     (define-variable! 'true true initial-env)
 125     (define-variable! 'false false initial-env)
 126     initial-env))
 127
 128 (define the-global-environment (make-environment))
 129
 130 ;; application
 131 (define (list-of-values exps env)
 132   (if (no-operands? exps)
 133       '()
 134       (cons (eval (first-operand exps) env)
 135             (list-of-values (rest-operands exps) env))))
 136
 137 (define (no-operands? ops) (null? ops))
 138 (define (first-operand ops) (car ops))
 139 (define (rest-operands ops) (cdr ops))
 140
 141 ;; compound procedure
 142 (define (make-procedure params body env)
 143   (list 'procedure params (scan-out-definitions body) env))
 144
 145 (define (procedure-parameters p) (cadr p))
 146 (define (procedure-body p) (scan-out-definitions (caddr p)))
 147 (define (procedure-environment p) (cadddr p))
 148
 149 (define (apply procedure arguments env)
 150   ;;(display (format "~s~%" arguments))
 151   (match procedure
 152     [`(primitive ,f ...)  (apply-primitive-procedure procedure (list-of-arg-values arguments env))]
 153     [`(procedure ,f ...)  (eval-sequence
 154                            (procedure-body procedure)
 155                            (extend-environment
 156                             (procedure-parameters procedure)
 157                             (list-of-delayed-args arguments env)
 158                             (procedure-environment procedure)))]
 159     [_                (error "Unknown procedure type -- APPLY" procedure)]))
 160
 161 (define (list-of-arg-values exps env)
 162   (if (no-operands? exps)
 163       '()
 164       (cons (actual-value (first-operand exps) env)
 165             (list-of-arg-values (rest-operands exps) env))))
 166
 167 (define (list-of-delayed-args exps env)
 168   (if (no-operands? exps)
 169       '()
 170       (cons (delay-it (first-operand exps) env)
 171             (list-of-delayed-args (rest-operands exps) env))))
 172
 173 ;; truth
 174 (define (true? x)
 175   (not (eq? x false)))
 176
 177 (define (false? x)
 178   (eq? x false))
 179
 180 ;; cond
 181 (define (cond->if clauses)
 182   (define (seq->exp actions)
 183     (if (empty? (cdr actions))
 184         (car actions)
 185         `(begin ,@actions)))
 186   (if (empty? clauses)
 187       'false
 188       (let ([clause (car clauses)])
 189         (match clause
 190           [`(else ,action ...) (seq->exp action)]
 191           [`(,pred ,action ...) `(if ,pred
 192                                      ,(seq->exp action)
 193                                      ,(cond->if (cdr clauses)))]))))
 194
 195 ;; let
 196 (define (let->combination lexpr)
 197   (match-let* ([`(let ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) lexpr]
 198                [`((,var ,val) ...) bindings])
 199     `((lambda ,var ,@body) ,@val)))
 200
 201 ;; named let
 202 (define (named-let->combination lexpr)
 203   (match-let* ([`(let ,(? symbol? name) ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) lexpr]
 204                [`((,var ,val) ...) bindings])
 205     `(begin (define ,name (lambda ,var ,@body))
 206             (,name ,@val))))
 207
 208 ;; let*
 209 (define (let*->nested-lets lexpr)
 210   (match lexpr
 211     [`(let* (,first-binding ,rest-bindings ...) ,body ..1)
 212      `(let (,first-binding) ,(let*->nested-lets `(let* ,rest-bindings ,@body)))]
 213      [`(let* () ,body ..1) `(let () ,@body)]))
 214
 215 ;; internal definitions
 216 (define (scan-out-definitions body)
 217   (match body
 218     [`((define ,var ,e) ..1 ,rest)
 219      `((let ,(map (lambda (v) (list (car v) ''*unassigned*)) var)
 220         ,@(map (lambda (v e) `(set! ,(car v) (lambda ,(cdr v) ,e))) var e)
 221         ,rest))]
 222     [_  body]))
 223
 224 ;; letrec
 225 (define (letrec->combination lexpr)
 226   (match lexpr
 227     [`(letrec (,bindings ...) ,body ..1)
 228      `(let ,(map (lambda (v) (list (car v) ''*unassigned*)) bindings)
 229         ,@(map (lambda (binding)
 230                  (let ([name (car binding)]
 231                        [value (cadr binding)])
 232                    `(set! ,name ,value)))
 233                bindings)
 234         ,@body)]))
 235
 236 ;; thunks
 237 (define (actual-value exp env)
 238   ;(display (format "eval expr ~s~%" exp))
 239   ;(newline)
 240   (force-it (eval exp env)))
 241
 242 (define (force-it obj)
 243   ;; (display (format "~s~%" obj))
 244   (match obj
 245     [`(thunk ,exp ,env) (begin
 246                           ;(display (format "eval's output ~s~%" obj))
 247                           ;(newline)
 248                           (actual-value exp env))]
 249     [_ obj]))
 250
 251 (define (delay-it exp env)
 252   (list 'thunk exp env))
 253
 254 (define (quote->cons exp)
 255   ;(display (format "q->c: ~s~%" exp))
 256   (if (null? exp)
 257       '()
 258       (list 'cons (list 'quote (car exp)) (quote->cons (cdr exp)))))
 259
 260 ;; eval
 261 (define (eval exp env)
 262   ;; use this display statement to visualize the recursive evaluation process
 263   ;(display (format "eval: ~s~%" exp))
 264   (match exp
 265     [(? self-evaluating? exp) exp]
 266     [(? variable? exp) (lookup-variable-value exp env)]
 267     [`(quote ,x) (if (pair? x) (eval (quote->cons x) env) x)]
 268     [`(set! ,var ,val) (set-variable-value! var (eval val env) env)]
 269     [`(define ,(? (lambda (x) (not (pair? x))) var) ,b) (define-variable! var (eval b env) env)]
 270     [`(define ,(? pair? var) ,b ..1) (define-variable! (car var) (eval (make-lambda (cdr var) b) env) env)]
 271     [`(if ,pred ,consequent ,alternative) (if (true? (actual-value pred env)) (eval consequent env) (eval alternative env))]
 272     [`(unless ,condition ,consequent ,alternative) (if (true? (eval condition env)) (eval alternative env) (eval consequent env))]
 273     [`(lambda ,parameters ,body ..1) (make-procedure parameters body env)]
 274     [`(begin ,exp ...) (eval-sequence exp env)]
 275     [`(cond ,clauses ...) (eval (cond->if clauses) env)]
 276     [`(let ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) (eval (let->combination exp) env)]
 277     [`(let ,(? symbol? name) ,bindings ,body ..1) (eval (named-let->combination exp) env)]
 278     [`(let* ,bindings ,body ..1) (eval (let*->nested-lets exp) env)]
 279     [`(letrec ,bindings ,body ..1) (eval (letrec->combination exp) env)]
 280     [`(,f ,x ...) (apply (actual-value f env)
 281                          x
 282                          env)]
 283     [_ (error "unable to evaluate expression -- EVAL " exp)]))
 284
 285
 286 (define (interpret)
 287   (let loop ([input (read)]
 288              [env the-global-environment])
 289     (let ([output (actual-value input env)])
 290       (display output)
 291       (loop (read) env))))
 292
 293 (define (t expr)
 294   (let ([t1 (current-inexact-milliseconds)])
 295     (eval expr the-global-environment)
 296     (displayln (- (current-inexact-milliseconds) t1))))
 297