diff options
| author | Joel Martin <github@martintribe.org> | 2015-02-28 11:09:54 -0600 |
|---|---|---|
| committer | Joel Martin <github@martintribe.org> | 2015-02-28 11:09:54 -0600 |
| commit | 90f618cbe7ac7740accf501a75be6972bd95be1a (patch) | |
| tree | 33a2a221e09f012a25e9ad8317a95bae6ffe1b08 /racket/stepA_interop.rkt | |
| parent | 699f0ad23aca21076edb6a51838d879ca580ffd5 (diff) | |
| download | mal-90f618cbe7ac7740accf501a75be6972bd95be1a.tar.gz mal-90f618cbe7ac7740accf501a75be6972bd95be1a.zip | |
All: rename stepA_interop to stepA_mal
Also, add missed postscript interop tests.
Diffstat (limited to 'racket/stepA_interop.rkt')
| -rwxr-xr-x | racket/stepA_interop.rkt | 163 |
1 files changed, 0 insertions, 163 deletions
diff --git a/racket/stepA_interop.rkt b/racket/stepA_interop.rkt deleted file mode 100755 index 9b816cb..0000000 --- a/racket/stepA_interop.rkt +++ /dev/null @@ -1,163 +0,0 @@ -#!/usr/bin/env racket -#lang racket - -(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" - "env.rkt" "core.rkt") - -;; read -(define (READ str) - (read_str str)) - -;; eval -(define (is-pair x) - (and (_sequential? x) (> (_count x) 0))) - -(define (quasiquote ast) - (cond - [(not (is-pair ast)) - (list 'quote ast)] - - [(equal? 'unquote (_nth ast 0)) - (_nth ast 1)] - - [(and (is-pair (_nth ast 0)) - (equal? 'splice-unquote (_nth (_nth ast 0) 0))) - (list 'concat (_nth (_nth ast 0) 1) (quasiquote (_rest ast)))] - - [else - (list 'cons (quasiquote (_nth ast 0)) (quasiquote (_rest ast)))])) - -(define (macro? ast env) - (and (list? ast) - (symbol? (first ast)) - (not (equal? null (send env find (first ast)))) - (let ([fn (send env get (first ast))]) - (and (malfunc? fn) (malfunc-macro? fn))))) - -(define (macroexpand ast env) - (if (macro? ast env) - (let ([mac (malfunc-fn (send env get (first ast)))]) - (macroexpand (apply mac (rest ast)) env)) - ast)) - -(define (eval-ast ast env) - (cond - [(symbol? ast) (send env get ast)] - [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] - [(hash? ast) (make-hash - (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] - [else ast])) - -(define (EVAL ast env) - ;(printf "~a~n" (pr_str ast true)) - (if (not (list? ast)) - (eval-ast ast env) - - (let ([ast (macroexpand ast env)]) - (if (not (list? ast)) - ast - (let ([a0 (_nth ast 0)]) - (cond - [(eq? 'def! a0) - (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] - [(eq? 'let* a0) - (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) - (_map (lambda (b_e) - (send let-env set (_first b_e) - (EVAL (_nth b_e 1) let-env))) - (_partition 2 (_to_list (_nth ast 1)))) - (EVAL (_nth ast 2) let-env))] - [(eq? 'quote a0) - (_nth ast 1)] - [(eq? 'quasiquote a0) - (EVAL (quasiquote (_nth ast 1)) env)] - [(eq? 'defmacro! a0) - (let* ([func (EVAL (_nth ast 2) env)] - [mac (struct-copy malfunc func [macro? #t])]) - (send env set (_nth ast 1) mac))] - [(eq? 'macroexpand a0) - (macroexpand (_nth ast 1) env)] - [(eq? 'try* a0) - (if (eq? 'catch* (_nth (_nth ast 2) 0)) - (let ([efn (lambda (exc) - (EVAL (_nth (_nth ast 2) 2) - (new Env% - [outer env] - [binds (list (_nth (_nth ast 2) 1))] - [exprs (list exc)])))]) - (with-handlers - ([mal-exn? (lambda (exc) (efn (mal-exn-val exc)))] - [string? (lambda (exc) (efn exc))] - [exn:fail? (lambda (exc) (efn (format "~a" exc)))]) - (EVAL (_nth ast 1) env))) - (EVAL (_nth ast 1)))] - [(eq? 'do a0) - (eval-ast (drop (drop-right ast 1) 1) env) - (EVAL (last ast) env)] - [(eq? 'if a0) - (let ([cnd (EVAL (_nth ast 1) env)]) - (if (or (eq? cnd nil) (eq? cnd #f)) - (if (> (length ast) 3) - (EVAL (_nth ast 3) env) - nil) - (EVAL (_nth ast 2) env)))] - [(eq? 'fn* a0) - (malfunc - (lambda args (EVAL (_nth ast 2) - (new Env% [outer env] - [binds (_nth ast 1)] - [exprs args]))) - (_nth ast 2) env (_nth ast 1) #f nil)] - [else (let* ([el (eval-ast ast env)] - [f (first el)] - [args (rest el)]) - (if (malfunc? f) - (EVAL (malfunc-ast f) - (new Env% - [outer (malfunc-env f)] - [binds (malfunc-params f)] - [exprs args])) - (apply f args)))])))))) - -;; print -(define (PRINT exp) - (pr_str exp true)) - -;; repl -(define repl-env - (new Env% [outer null] [binds null] [exprs null])) -(define (rep str) - (PRINT (EVAL (READ str) repl-env))) - -(for () ;; ignore return values - -;; core.rkt: defined using Racket -(hash-for-each core_ns (lambda (k v) (send repl-env set k v))) -(send repl-env set 'eval (lambda [ast] (EVAL ast repl-env))) -(send repl-env set '*ARGV* (list)) - -;; core.mal: defined using the language itself -(rep "(def! *host-language* \"racket\")") -(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 (repl-loop) - (let ([line (readline "user> ")]) - (when (not (eq? nil line)) - (with-handlers - ([string? (lambda (exc) (printf "Error: ~a~n" exc))] - [mal-exn? (lambda (exc) (printf "Error: ~a~n" - (pr_str (mal-exn-val exc) true)))] - [blank-exn? (lambda (exc) null)]) - (printf "~a~n" (rep line))) - (repl-loop)))) -(let ([args (current-command-line-arguments)]) - (if (> (vector-length args) 0) - (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")"))) - (begin - (rep "(println (str \"Mal [\" *host-language* \"]\"))") - (repl-loop)))) |
