mal/scheme/stepA_mal.scm

(import (scheme base))
(import (scheme write))
(import (scheme process-context))

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

(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 (is-pair? ast)
  (let ((type (and (mal-object? ast) (mal-type ast))))
    (if (memq type '(list vector))
        (pair? (->list (mal-value ast)))
        #f)))

(define (QUASIQUOTE ast)
  (if (not (is-pair? ast))
      (mal-list (list (mal-symbol 'quote) ast))
      (let* ((items (->list (mal-value ast)))
             (a0 (car items)))
        (if (and (mal-object? a0)
                 (eq? (mal-type a0) 'symbol)
                 (eq? (mal-value a0) 'unquote))
            (cadr items)
            (if (and (is-pair? a0)
                     (mal-object? (car (mal-value a0)))
                     (eq? (mal-type (car (mal-value a0))) 'symbol)
                     (eq? (mal-value (car (mal-value a0))) 'splice-unquote))
                (mal-list (list (mal-symbol 'concat)
                                (cadr (mal-value a0))
                                (QUASIQUOTE (mal-list (cdr items)))))
                (mal-list (list (mal-symbol 'cons)
                                (QUASIQUOTE a0)
                                (QUASIQUOTE (mal-list (cdr items))))))))))

(define (is-macro-call? ast env)
  (if (mal-instance-of? ast 'list)
      (let ((op (car-safe (mal-value ast))))
        (if (mal-instance-of? op 'symbol)
            (let ((x (env-find env (mal-value op))))
              (if x
                  (if (and (func? x) (func-macro? x))
                      #t
                      #f)
                  #f))
            #f))
      #f))

(define (macroexpand ast env)
  (let loop ((ast ast))
    (if (is-macro-call? ast env)
        (let* ((items (mal-value ast))
               (op (car items))
               (ops (cdr items))
               (fn (func-fn (env-get env (mal-value op)))))
          (loop (apply fn ops)))
        ast)))

(define (EVAL ast env)
  (define (handle-catch value handler)
    (let* ((symbol (mal-value (cadr handler)))
           (form (list-ref handler 2))
           (env* (make-env env (list symbol) (list value))))
      (EVAL form env*)))
  (let ((type (and (mal-object? ast) (mal-type ast))))
    (if (not (eq? type 'list))
        (eval-ast ast env)
        (if (null? (mal-value ast))
            ast
            (let* ((ast (macroexpand ast env))
                   (items (mal-value ast)))
              (if (not (mal-instance-of? ast 'list))
                  (eval-ast ast env)
                  (let ((a0 (car items)))
                    (case (and (mal-object? a0) (mal-value a0))
                      ((def!)
                       (let ((symbol (mal-value (cadr items)))
                             (value (EVAL (list-ref items 2) env)))
                         (env-set env symbol value)
                         value))
                      ((defmacro!)
                       (let ((symbol (mal-value (cadr items)))
                             (value (EVAL (list-ref items 2) env)))
                         (when (func? value)
                           (func-macro?-set! value #t))
                         (env-set env symbol value)
                         value))
                      ((macroexpand)
                       (macroexpand (cadr items) env))
                      ((try*)
                       (if (< (length items) 3)
                         (EVAL (cadr items) env)
                         (let* ((form (cadr items))
                                (handler (mal-value (list-ref items 2))))
                           (guard
                            (ex ((error-object? ex)
                                 (handle-catch
                                  (mal-string (error-object-message ex))
                                  handler))
                                ((and (pair? ex) (eq? (car ex) 'user-error))
                                 (handle-catch (cdr ex) handler)))
                            (EVAL form env)))))
                      ((let*)
                       (let ((env* (make-env env))
                             (binds (->list (mal-value (cadr items))))
                             (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*))) ; TCO
                      ((do)
                       (let ((forms (cdr items)))
                         (if (null? forms)
                             mal-nil
                             ;; the evaluation order of map is unspecified
                             (let loop ((forms forms))
                               (let ((form (car forms))
                                     (tail (cdr forms)))
                                 (if (null? tail)
                                     (EVAL form env) ; TCO
                                     (begin
                                       (EVAL form env)
                                       (loop tail))))))))
                      ((if)
                       (let* ((condition (EVAL (cadr items) env))
                              (type (and (mal-object? condition)
                                         (mal-type condition))))
                         (if (memq type '(false nil))
                             (if (< (length items) 4)
                                 mal-nil
                                 (EVAL (list-ref items 3) env)) ; TCO
                             (EVAL (list-ref items 2) env)))) ; TCO
                      ((quote)
                       (cadr items))
                      ((quasiquote)
                       (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO
                      ((fn*)
                       (let* ((binds (->list (mal-value (cadr items))))
                              (binds (map mal-value binds))
                              (body (list-ref items 2))
                              (fn (lambda args
                                    (let ((env* (make-env env binds args)))
                                      (EVAL body env*)))))
                         (make-func body binds env fn)))
                      (else
                       (let* ((items (mal-value (eval-ast ast env)))
                              (op (car items))
                              (ops (cdr items)))
                         (if (func? op)
                             (let* ((outer (func-env op))
                                    (binds (func-params op))
                                    (env* (make-env outer binds ops)))
                               (EVAL (func-ast op) env*)) ; TCO
                             (apply op ops))))))))))))

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

(define repl-env (make-env #f))
(for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns)

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

(define args (cdr (command-line)))

(env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env)))
(env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args))))
(let ((scheme (or (get-environment-variable "scheme_MODE") "chibi")))
  (env-set repl-env '*host-language* (mal-string (str "scheme (" scheme ")"))))

(rep "(def! not (fn* (a) (if a false true)))")
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")

(rep "(def! *gensym-counter* (atom 0))")
(rep "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))")

(rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))")
(rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))")

(define (main)
  (rep "(println (str \"Mal [\" *host-language* \"]\"))")
  (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)))
             ((and (pair? ex) (eq? (car ex) 'user-error))
              (display "[error] ")
              (display (pr-str (cdr ex) #t))
              (newline)))
         (display (rep input))
         (newline))
        (loop))))
  (newline))

(if (null? args)
    (main)
    (rep (string-append "(load-file \"" (car args) "\")")))