src/sicp/ex4_31.rkt

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