| 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 (starts-with? ast sym) |
| 26 | (let ((items (mal-value ast))) |
| 27 | (and (not (null? items)) |
| 28 | (let ((a0 (car items))) |
| 29 | (and (mal-instance-of? a0 'symbol) |
| 30 | (eq? (mal-value a0) sym)))))) |
| 31 | |
| 32 | (define (qq-lst xs) |
| 33 | (if (null? xs) |
| 34 | (mal-list '()) |
| 35 | (let ((elt (car xs)) |
| 36 | (acc (qq-lst (cdr xs)))) |
| 37 | (if (and (mal-instance-of? elt 'list) (starts-with? elt 'splice-unquote)) |
| 38 | (mal-list (list (mal-symbol 'concat) (cadr (mal-value elt)) acc)) |
| 39 | (mal-list (list (mal-symbol 'cons) (QUASIQUOTE elt) acc)))))) |
| 40 | |
| 41 | (define (QUASIQUOTE ast) |
| 42 | (case (and (mal-object? ast) (mal-type ast)) |
| 43 | ((list) (if (starts-with? ast 'unquote) |
| 44 | (cadr (mal-value ast)) |
| 45 | (qq-lst (->list (mal-value ast))))) |
| 46 | ((vector) (mal-list (list (mal-symbol 'vec) (qq-lst (->list (mal-value ast)))))) |
| 47 | ((map symbol) (mal-list (list (mal-symbol 'quote) ast))) |
| 48 | (else ast))) |
| 49 | |
| 50 | (define (EVAL ast env) |
| 51 | (let ((type (and (mal-object? ast) (mal-type ast)))) |
| 52 | (if (not (eq? type 'list)) |
| 53 | (eval-ast ast env) |
| 54 | (let ((items (mal-value ast))) |
| 55 | (if (null? items) |
| 56 | ast |
| 57 | (let ((a0 (car items))) |
| 58 | (case (and (mal-object? a0) (mal-value a0)) |
| 59 | ((def!) |
| 60 | (let ((symbol (mal-value (cadr items))) |
| 61 | (value (EVAL (list-ref items 2) env))) |
| 62 | (env-set env symbol value) |
| 63 | value)) |
| 64 | ((let*) |
| 65 | (let ((env* (make-env env)) |
| 66 | (binds (->list (mal-value (cadr items)))) |
| 67 | (form (list-ref items 2))) |
| 68 | (let loop ((binds binds)) |
| 69 | (when (pair? binds) |
| 70 | (let ((key (mal-value (car binds)))) |
| 71 | (when (null? (cdr binds)) |
| 72 | (error "unbalanced list")) |
| 73 | (let ((value (EVAL (cadr binds) env*))) |
| 74 | (env-set env* key value) |
| 75 | (loop (cddr binds)))))) |
| 76 | (EVAL form env*))) ; TCO |
| 77 | ((do) |
| 78 | (let ((forms (cdr items))) |
| 79 | (if (null? forms) |
| 80 | mal-nil |
| 81 | ;; the evaluation order of map is unspecified |
| 82 | (let loop ((forms forms)) |
| 83 | (let ((form (car forms)) |
| 84 | (tail (cdr forms))) |
| 85 | (if (null? tail) |
| 86 | (EVAL form env) ; TCO |
| 87 | (begin |
| 88 | (EVAL form env) |
| 89 | (loop tail)))))))) |
| 90 | ((if) |
| 91 | (let* ((condition (EVAL (cadr items) env)) |
| 92 | (type (and (mal-object? condition) |
| 93 | (mal-type condition)))) |
| 94 | (if (memq type '(false nil)) |
| 95 | (if (< (length items) 4) |
| 96 | mal-nil |
| 97 | (EVAL (list-ref items 3) env)) ; TCO |
| 98 | (EVAL (list-ref items 2) env)))) ; TCO |
| 99 | ((quote) (cadr items)) |
| 100 | ((quasiquoteexpand) (QUASIQUOTE (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 args (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 args)))) |
| 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) \"\nnil)\")))))") |
| 137 | |
| 138 | (define (main) |
| 139 | (let loop () |
| 140 | (let ((input (readline "user> "))) |
| 141 | (when input |
| 142 | (guard |
| 143 | (ex ((error-object? ex) |
| 144 | (when (not (memv 'empty-input (error-object-irritants ex))) |
| 145 | (display "[error] ") |
| 146 | (display (error-object-message ex)) |
| 147 | (newline))) |
| 148 | ((and (pair? ex) (eq? (car ex) 'user-error)) |
| 149 | (display "[error] ") |
| 150 | (display (pr-str (cdr ex) #t)) |
| 151 | (newline))) |
| 152 | (display (rep input)) |
| 153 | (newline)) |
| 154 | (loop)))) |
| 155 | (newline)) |
| 156 | |
| 157 | (if (null? args) |
| 158 | (main) |
| 159 | (rep (string-append "(load-file \"" (car args) "\")"))) |