mirror of
https://github.com/kanaka/mal.git
synced 2024-09-21 02:27:10 +03:00
dd7a4f55f3
Fixes made to: ada, c, chuck, clojure, coffee, common-lisp, cpp, crystal, d, dart, elm, erlang, es6, factor, fsharp, gnu-smalltalk, groovy, guile, haxe, hy, js, livescript, matlab, miniMAL, nasm, nim, objc, objpascal, ocaml, perl, perl6, php, plsql, ps, python, r, rpython, ruby, scheme, swift3, tcl, ts, vb, vimscript, wasm, yorick. Catchless try* test is an optional test. Not all implementations support catchless try* but a number were fixed so they at least don't crash on catchless try*.
219 lines
8.9 KiB
Scheme
219 lines
8.9 KiB
Scheme
(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))))
|
|
|
|
(rep "(def! not (fn* (a) (if a false true)))")
|
|
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
|
|
|
|
(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)))))))")
|
|
(rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))")
|
|
|
|
|
|
(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)))
|
|
((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) "\")")))
|