code.kerkeslager.com Git - sandbox/blob - LiSP/chapter1.scm

   1 ; this allows (begin), which is almost certainly undesirable behavior
   2 (define (eprogn exps env trace)
   3   (if (pair? exps)
   4       (if (pair? (cdr exps))
   5           (begin (evaluate (car exps) env trace)
   6                  (eprogn (cdr exps) env trace))
   7           (evaluate (car exps env trace)))
   8       '()))
   9
  10 ; Complication is to avoid excess recursion (exercise 1.2)
  11 (define (evlis exps env trace)
  12   (define (evlis-internal exps env trace)
  13     (let ((current-result (evaluate (car exps) env trace)))
  14       (cons current-result (if (pair? (cdr exps))
  15                                (evlis (cdr exps) env trace)
  16                                '()))))
  17   (if (pair? exps)
  18       (evlis-internal exps env trace)
  19       '()))
  20
  21 (define (lookup id env)
  22   (if (pair? env)
  23       (if (eq? (caar env) id)
  24           (cdar env)
  25           (lookup id (cdr env)))
  26       (wrong "No such binding" id)))
  27
  28 (define (update! id env value)
  29   (if (pair? env)
  30       (if (eq? (caar env) id)
  31           (begin (set-cdr! (car env) value)
  32                  value)
  33           (update! id (cdr env) value))
  34       (wrong "No such binding" id)))
  35
  36 (define (extend env variables values)
  37   (cond ((pair? variables) (if (pair? values)
  38                                (cons (cons (car variables) (car values))
  39                                      (extend env (cdr variables) (cdr values)))
  40                                (wrong "Too many variables")))
  41         ((null? variables) (if (null? values)
  42                                env
  43                                (wrong "Too many values")))
  44         ; I'm not sure I like this, it creates an inconsistent
  45         ; interface for extend
  46         ((symbol? variables?) (cons (cons variables values) env))))
  47
  48 (define (invoke fn args)
  49   (if (procedure? fn)
  50       (fn args)
  51       (wrong "Not a function" fn)))
  52
  53 ; variables are lexically scoped
  54 (define (make-function variables body env trace)
  55   (lambda (values) (eprogn body (extend env variables values) trace)))
  56
  57 (define env.init '())
  58
  59 (define env.global env.init)
  60
  61 (define-syntax def-initial
  62   (syntax-rules ()
  63     ((def-initial name) (begin (set! env.global (cons (cons 'name 'void) env.global))
  64                                'name))
  65     ((def-initial name value) (begin (set! env.global (cons (cons 'name value) env.global))
  66                                      'name))))
  67
  68 (define-syntax def-primitive
  69   (syntax-rules ()
  70     ((def-primitive name value arity) (def-initial name (lambda (values) (if (= arity (length values))
  71                                                                         (apply value values) ; the real apply of Scheme
  72                                                                         (wrong "Incorrect arity" (list 'name values))))))))
  73
  74
  75 ; Implementing the exercise suggested in section 1.8
  76 (define exit-sentinel (gensym 'exit-sentinel-))
  77 (define (exit) exit-sentinel)
  78
  79 (def-initial true #t)
  80 (def-initial false #f)
  81 (def-initial nil '())
  82
  83 (def-primitive cons cons 2)
  84 (def-primitive car car 1)
  85 (def-primitive cdr cdr 1)
  86 (def-primitive set-car! set-car! 2)
  87 (def-primitive set-cdr! set-cdr! 2)
  88 (def-primitive + + 2)
  89 (def-primitive - - 2)
  90 (def-primitive * * 2)
  91 (def-primitive / / 2)
  92 (def-primitive eq? eq? 2)
  93 (def-primitive < < 2)
  94 (def-primitive > > 2)
  95 (def-primitive <= <= 2)
  96 (def-primitive >= >= 2)
  97 (def-primitive exit exit 0)
  98
  99 (define (atom? e)
 100   (not (pair? e)))
 101
 102 (define (display-args args)
 103   (if (pair? args)
 104       (begin (display " ")
 105              (display (car args))
 106              (display-args (cdr args)))))
 107
 108 ; `trace` is there to implement exercise 1.1
 109 ; Pass #t to output trace information
 110 (define (evaluate e env trace)
 111   (if (atom? e)
 112       (cond ((symbol? e) (lookup e env))
 113             ((or (number? e) (string? e) (char? e) (boolean? e) (vector? e)) e)
 114             (else (wrong "Cannot evaluate" e)))
 115       (case (car e)
 116         ((quote) (cadr e))
 117         ((if) (if (evaluate (cadr e) env trace)
 118                   (evaluate (caddr e) env trace)
 119                   (evaluate (cadddr e) env trace)))
 120         ((begin) (eprogn (cdr e) env trace))
 121         ((set!) (update! (cadr e) env (evaluate (caddr e) env trace)))
 122         ((lambda) (make-function (cadr e) (cddr e) env trace))
 123         (else
 124          (let ((fn (evaluate (car e) env trace))
 125                (args (evlis (cdr e) env trace)))
 126            (begin (if trace
 127                       (begin (display "(")
 128                              (display (car e))
 129                              (display-args args)
 130                              (display ")\n")))
 131                   (let ((result (invoke fn args)))
 132                     (begin (display result)
 133                            (display "\n")
 134                            result))))))))
 135
 136 (define (chapter1-scheme trace)
 137   (define (toplevel)
 138     (let ((result (evaluate (read) env.global trace)))
 139       (if (not (and (symbol? result) (equal? result exit-sentinel)))
 140           (begin (display result)
 141                  (display "\n")
 142                  (toplevel)))))
 143   (toplevel))