mal/scm/step7_quote.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 (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
              (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))
                  ((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 argv (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 argv))))

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

(define (readline prompt)
  (display prompt)
  (flush-output-port)
  (let ((input (read-line)))
    (if (eof-object? input)
        #f
        input)))

(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))

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