| 1 | (import (scheme base)) |
| 2 | (import (scheme write)) |
| 3 | (import (scheme process-context)) |
| 4 | |
| 5 | (import (lib util)) |
| 6 | (import (lib reader)) |
| 7 | (import (lib printer)) |
| 8 | (import (lib types)) |
| 9 | (import (lib env)) |
| 10 | (import (lib core)) |
| 11 | |
| 12 | (define (READ input) |
| 13 | (read-str input)) |
| 14 | |
| 15 | (define (eval-ast ast env) |
| 16 | (let ((type (and (mal-object? ast) (mal-type ast))) |
| 17 | (value (and (mal-object? ast) (mal-value ast)))) |
| 18 | (case type |
| 19 | ((symbol) (env-get env value)) |
| 20 | ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) |
| 21 | ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) |
| 22 | ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) |
| 23 | (else ast)))) |
| 24 | |
| 25 | (define (is-pair? ast) |
| 26 | (let ((type (and (mal-object? ast) (mal-type ast)))) |
| 27 | (if (memq type '(list vector)) |
| 28 | (pair? (->list (mal-value ast))) |
| 29 | #f))) |
| 30 | |
| 31 | (define (QUASIQUOTE ast) |
| 32 | (if (not (is-pair? ast)) |
| 33 | (mal-list (list (mal-symbol 'quote) ast)) |
| 34 | (let* ((items (->list (mal-value ast))) |
| 35 | (a0 (car items))) |
| 36 | (if (and (mal-object? a0) |
| 37 | (eq? (mal-type a0) 'symbol) |
| 38 | (eq? (mal-value a0) 'unquote)) |
| 39 | (cadr items) |
| 40 | (if (and (is-pair? a0) |
| 41 | (mal-object? (car (mal-value a0))) |
| 42 | (eq? (mal-type (car (mal-value a0))) 'symbol) |
| 43 | (eq? (mal-value (car (mal-value a0))) 'splice-unquote)) |
| 44 | (mal-list (list (mal-symbol 'concat) |
| 45 | (cadr (mal-value a0)) |
| 46 | (QUASIQUOTE (mal-list (cdr items))))) |
| 47 | (mal-list (list (mal-symbol 'cons) |
| 48 | (QUASIQUOTE a0) |
| 49 | (QUASIQUOTE (mal-list (cdr items)))))))))) |
| 50 | |
| 51 | (define (EVAL ast env) |
| 52 | (let ((type (and (mal-object? ast) (mal-type ast)))) |
| 53 | (if (not (eq? type 'list)) |
| 54 | (eval-ast ast env) |
| 55 | (let ((items (mal-value ast))) |
| 56 | (if (null? items) |
| 57 | ast |
| 58 | (let ((a0 (car items))) |
| 59 | (case (and (mal-object? a0) (mal-value a0)) |
| 60 | ((def!) |
| 61 | (let ((symbol (mal-value (cadr items))) |
| 62 | (value (EVAL (list-ref items 2) env))) |
| 63 | (env-set env symbol value) |
| 64 | value)) |
| 65 | ((let*) |
| 66 | (let ((env* (make-env env)) |
| 67 | (binds (->list (mal-value (cadr items)))) |
| 68 | (form (list-ref items 2))) |
| 69 | (let loop ((binds binds)) |
| 70 | (when (pair? binds) |
| 71 | (let ((key (mal-value (car binds)))) |
| 72 | (when (null? (cdr binds)) |
| 73 | (error "unbalanced list")) |
| 74 | (let ((value (EVAL (cadr binds) env*))) |
| 75 | (env-set env* key value) |
| 76 | (loop (cddr binds)))))) |
| 77 | (EVAL form env*))) ; TCO |
| 78 | ((do) |
| 79 | (let ((forms (cdr items))) |
| 80 | (if (null? forms) |
| 81 | mal-nil |
| 82 | ;; the evaluation order of map is unspecified |
| 83 | (let loop ((forms forms)) |
| 84 | (let ((form (car forms)) |
| 85 | (tail (cdr forms))) |
| 86 | (if (null? tail) |
| 87 | (EVAL form env) ; TCO |
| 88 | (begin |
| 89 | (EVAL form env) |
| 90 | (loop tail)))))))) |
| 91 | ((if) |
| 92 | (let* ((condition (EVAL (cadr items) env)) |
| 93 | (type (and (mal-object? condition) |
| 94 | (mal-type condition)))) |
| 95 | (if (memq type '(false nil)) |
| 96 | (if (< (length items) 4) |
| 97 | mal-nil |
| 98 | (EVAL (list-ref items 3) env)) ; TCO |
| 99 | (EVAL (list-ref items 2) env)))) ; TCO |
| 100 | ((quote) (cadr items)) |
| 101 | ((quasiquote) (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO |
| 102 | ((fn*) |
| 103 | (let* ((binds (->list (mal-value (cadr items)))) |
| 104 | (binds (map mal-value binds)) |
| 105 | (body (list-ref items 2)) |
| 106 | (fn (lambda args |
| 107 | (let ((env* (make-env env binds args))) |
| 108 | (EVAL body env*))))) |
| 109 | (make-func body binds env fn))) |
| 110 | (else |
| 111 | (let* ((items (mal-value (eval-ast ast env))) |
| 112 | (op (car items)) |
| 113 | (ops (cdr items))) |
| 114 | (if (func? op) |
| 115 | (let* ((outer (func-env op)) |
| 116 | (binds (func-params op)) |
| 117 | (env* (make-env outer binds ops))) |
| 118 | (EVAL (func-ast op) env*)) ; TCO |
| 119 | (apply op ops))))))))))) |
| 120 | |
| 121 | (define (PRINT ast) |
| 122 | (pr-str ast #t)) |
| 123 | |
| 124 | (define repl-env (make-env #f)) |
| 125 | (for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) |
| 126 | |
| 127 | (define (rep input) |
| 128 | (PRINT (EVAL (READ input) repl-env))) |
| 129 | |
| 130 | (define argv (cdr (command-line))) |
| 131 | |
| 132 | (env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) |
| 133 | (env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe argv)))) |
| 134 | |
| 135 | (rep "(def! not (fn* (a) (if a false true)))") |
| 136 | (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") |
| 137 | |
| 138 | (define (readline prompt) |
| 139 | (display prompt) |
| 140 | (flush-output-port) |
| 141 | (let ((input (read-line))) |
| 142 | (if (eof-object? input) |
| 143 | #f |
| 144 | input))) |
| 145 | |
| 146 | (define (main) |
| 147 | (let loop () |
| 148 | (let ((input (readline "user> "))) |
| 149 | (when input |
| 150 | (guard |
| 151 | (ex ((error-object? ex) |
| 152 | (when (not (memv 'empty-input (error-object-irritants ex))) |
| 153 | (display "[error] ") |
| 154 | (display (error-object-message ex)) |
| 155 | (newline)))) |
| 156 | (display (rep input)) |
| 157 | (newline)) |
| 158 | (loop)))) |
| 159 | (newline)) |
| 160 | |
| 161 | (if (null? argv) |
| 162 | (main) |
| 163 | (rep (string-append "(load-file \"" (car argv) "\")"))) |