scheme/step3_env.scm

   1 (import (scheme base))
   2 (import (scheme write))
   3
   4 (import (lib util))
   5 (import (lib reader))
   6 (import (lib printer))
   7 (import (lib types))
   8 (import (lib env))
   9
  10 (define (READ input)
  11   (read-str input))
  12
  13 (define (eval-ast ast env)
  14   (let ((type (and (mal-object? ast) (mal-type ast)))
  15         (value (and (mal-object? ast) (mal-value ast))))
  16     (case type
  17       ((symbol) (env-get env value))
  18       ((list) (mal-list (map (lambda (item) (EVAL item env)) value)))
  19       ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value)))
  20       ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value)))
  21       (else ast))))
  22
  23 (define (EVAL ast env)
  24   (let ((type (and (mal-object? ast) (mal-type ast))))
  25     (if (not (eq? type 'list))
  26         (eval-ast ast env)
  27         (let ((items (mal-value ast)))
  28           (if (null? items)
  29               ast
  30               (case (mal-value (car items))
  31                 ((def!)
  32                  (let ((symbol (mal-value (cadr items)))
  33                        (value (EVAL (list-ref items 2) env)))
  34                    (env-set env symbol value)
  35                    value))
  36                 ((let*)
  37                  (let* ((env* (make-env env))
  38                         (binds (mal-value (cadr items)))
  39                         (binds (if (vector? binds) (vector->list binds) binds))
  40                         (form (list-ref items 2)))
  41                    (let loop ((binds binds))
  42                      (when (pair? binds)
  43                        (let ((key (mal-value (car binds))))
  44                          (when (null? (cdr binds))
  45                            (error "unbalanced list"))
  46                          (let ((value (EVAL (cadr binds) env*)))
  47                            (env-set env* key value)
  48                            (loop (cddr binds))))))
  49                    (EVAL form env*)))
  50                 (else
  51                  (let* ((items (mal-value (eval-ast ast env)))
  52                         (op (car items))
  53                         (ops (cdr items)))
  54                    (apply op ops)))))))))
  55
  56 (define (PRINT ast)
  57   (pr-str ast #t))
  58
  59 (define repl-env (make-env #f))
  60 (env-set repl-env '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))))
  61 (env-set repl-env '- (lambda (a b) (mal-number (- (mal-value a) (mal-value b)))))
  62 (env-set repl-env '* (lambda (a b) (mal-number (* (mal-value a) (mal-value b)))))
  63 (env-set repl-env '/ (lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))))
  64
  65 (define (rep input)
  66   (PRINT (EVAL (READ input) repl-env)))
  67
  68 (define (main)
  69   (let loop ()
  70     (let ((input (readline "user> ")))
  71       (when input
  72         (guard
  73          (ex ((error-object? ex)
  74               (when (not (memv 'empty-input (error-object-irritants ex)))
  75                 (display "[error] ")
  76                 (display (error-object-message ex))
  77                 (newline))))
  78          (display (rep input))
  79          (newline))
  80         (loop))))
  81   (newline))
  82
  83 (main)