scheme/step2_eval.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
   9 (define (READ input)
  10   (read-str input))
  11
  12 (define (eval-ast ast env)
  13   (let ((type (and (mal-object? ast) (mal-type ast)))
  14         (value (and (mal-object? ast) (mal-value ast))))
  15     (case type
  16       ((symbol) (or (alist-ref value env)
  17                     (error (str "'" value "' not found"))))
  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             (let* ((items (mal-value (eval-ast ast env)))
  31                    (op (car items))
  32                    (ops (cdr items)))
  33               (apply op ops)))))))
  34
  35 (define (PRINT ast)
  36   (pr-str ast #t))
  37
  38 (define repl-env
  39   `((+ . ,(lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))))
  40     (- . ,(lambda (a b) (mal-number (- (mal-value a) (mal-value b)))))
  41     (* . ,(lambda (a b) (mal-number (* (mal-value a) (mal-value b)))))
  42     (/ . ,(lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))))))
  43
  44 (define (rep input)
  45   (PRINT (EVAL (READ input) repl-env)))
  46
  47 (define (main)
  48   (let loop ()
  49     (let ((input (readline "user> ")))
  50       (when input
  51         (guard
  52          (ex ((error-object? ex)
  53               (when (not (memv 'empty-input (error-object-irritants ex)))
  54                 (display "[error] ")
  55                 (display (error-object-message ex))
  56                 (newline))))
  57          (display (rep input))
  58          (newline))
  59         (loop))))
  60   (newline))
  61
  62 (main)