Fix eval test

[jackhill/mal.git] / scheme / step3_env.scm

(import (scheme base))
(import (scheme write))

(import (lib util))
(import (lib reader))
(import (lib printer))
(import (lib types))
(import (lib env))

(define (READ input)
  (read-str input))

(define (eval-ast ast env)
  (let ((type (and (mal-object? ast) (mal-type ast)))
        (value (and (mal-object? ast) (mal-value ast))))
    (case type
      ((symbol) (env-get env value))
      ((list) (mal-list (map (lambda (item) (EVAL item env)) value)))
      ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value)))
      ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value)))
      (else ast))))

(define (EVAL ast env)
  (let ((type (and (mal-object? ast) (mal-type ast))))
    (if (not (eq? type 'list))
        (eval-ast ast env)
        (let ((items (mal-value ast)))
          (if (null? items)
              ast
              (case (mal-value (car items))
                ((def!)
                 (let ((symbol (mal-value (cadr items)))
                       (value (EVAL (list-ref items 2) env)))
                   (env-set env symbol value)
                   value))
                ((let*)
                 (let* ((env* (make-env env))
                        (binds (mal-value (cadr items)))
                        (binds (if (vector? binds) (vector->list binds) binds))
                        (form (list-ref items 2)))
                   (let loop ((binds binds))
                     (when (pair? binds)
                       (let ((key (mal-value (car binds))))
                         (when (null? (cdr binds))
                           (error "unbalanced list"))
                         (let ((value (EVAL (cadr binds) env*)))
                           (env-set env* key value)
                           (loop (cddr binds))))))
                   (EVAL form env*)))
                (else
                 (let* ((items (mal-value (eval-ast ast env)))
                        (op (car items))
                        (ops (cdr items)))
                   (apply op ops)))))))))

(define (PRINT ast)
  (pr-str ast #t))

(define repl-env (make-env #f))
(env-set repl-env '+ (lambda (a b) (mal-number (+ (mal-value a) (mal-value b)))))
(env-set repl-env '- (lambda (a b) (mal-number (- (mal-value a) (mal-value b)))))
(env-set repl-env '* (lambda (a b) (mal-number (* (mal-value a) (mal-value b)))))
(env-set repl-env '/ (lambda (a b) (mal-number (/ (mal-value a) (mal-value b)))))

(define (rep input)
  (PRINT (EVAL (READ input) repl-env)))

(define (main)
  (let loop ()
    (let ((input (readline "user> ")))
      (when input
        (guard
         (ex ((error-object? ex)
              (when (not (memv 'empty-input (error-object-irritants ex)))
                (display "[error] ")
                (display (error-object-message ex))
                (newline))))
         (display (rep input))
         (newline))
        (loop))))
  (newline))

(main)