blob: 7016a12b098b4b3426c39e76ccee282079cfcf21 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
#!/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)
(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? '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! 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))]
[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) "\")")))
(repl-loop)))
|
