2017-09-04 20:49:02 +03:00
|
|
|
(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 env)
|
2022-01-10 02:15:40 +03:00
|
|
|
(let ((dbgeval (env-get env 'DEBUG-EVAL)))
|
|
|
|
(when (and (mal-object? dbgeval)
|
|
|
|
(not (memq (mal-type dbgeval) '(false nil))))
|
|
|
|
(display (str "EVAL: " (pr-str ast #t) "\n"))))
|
|
|
|
(case (and (mal-object? ast) (mal-type ast))
|
|
|
|
((symbol)
|
|
|
|
(let ((key (mal-value ast)))
|
|
|
|
(or (env-get env key) (error (str "'" key "' not found")))))
|
|
|
|
((vector)
|
|
|
|
(mal-vector (vector-map (lambda (item) (EVAL item env))
|
|
|
|
(mal-value ast))))
|
|
|
|
((map)
|
|
|
|
(mal-map (alist-map (lambda (key value) (cons key (EVAL value env)))
|
|
|
|
(mal-value ast))))
|
|
|
|
((list)
|
2017-09-04 20:49:02 +03:00
|
|
|
(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
|
2022-01-10 02:15:40 +03:00
|
|
|
(let ((op (EVAL (car items) env))
|
|
|
|
(ops (map (lambda (item) (EVAL item env)) (cdr items))))
|
|
|
|
(apply op ops)))))))
|
|
|
|
(else ast)))
|
2017-09-04 20:49:02 +03:00
|
|
|
|
|
|
|
(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)
|