Commit | Line | Data |
---|---|---|
98cd78e4 NG |
1 | ;; Copyright (C) 2015 |
2 | ;; "Mu Lei" known as "NalaGinrut" <NalaGinrut@gmail.com> | |
3 | ;; This file is free software: you can redistribute it and/or modify | |
4 | ;; it under the terms of the GNU General Public License as published by | |
5 | ;; the Free Software Foundation, either version 3 of the License, or | |
6 | ;; (at your option) any later version. | |
7 | ||
8 | ;; This file is distributed in the hope that it will be useful, | |
9 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | ;; GNU General Public License for more details. | |
12 | ||
13 | ;; You should have received a copy of the GNU General Public License | |
14 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
15 | ||
16 | (import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43) | |
17 | (srfi srfi-1) (ice-9 receive) (env) (core) (types)) | |
18 | ||
dd7a4f55 JM |
19 | ;; Primitives which doesn't unbox args in default. |
20 | ;; This is a trick to implement meta-info taking advange of the original | |
21 | ;; types of Guile as possible. | |
22 | (define *unbox-exception* '(meta assoc swap!)) | |
23 | ||
98cd78e4 NG |
24 | (define *toplevel* |
25 | (receive (b e) (unzip2 core.ns) | |
dd7a4f55 JM |
26 | (let ((env (make-Env #:binds b #:exprs (map make-func e)))) |
27 | (for-each (lambda (f) | |
28 | (callable-unbox-set! ((env 'get) f) #f)) | |
29 | *unbox-exception*) | |
30 | env))) | |
98cd78e4 | 31 | |
dd7a4f55 JM |
32 | (define (READ str) |
33 | (read_str str)) | |
98cd78e4 NG |
34 | |
35 | (define (eval_ast ast env) | |
36 | (define (_eval x) (EVAL x env)) | |
37 | (match ast | |
38 | ((? _nil? obj) obj) | |
39 | ((? symbol? sym) (env-has sym env)) | |
40 | ((? list? lst) (map _eval lst)) | |
41 | ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) | |
42 | ((? hash-table? ht) | |
dd7a4f55 JM |
43 | ;; NOTE: we must allocate a new hashmap here to avoid any side-effects, or |
44 | ;; there'll be strange bugs!!! | |
45 | (list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht))) | |
98cd78e4 NG |
46 | (else ast))) |
47 | ||
98cd78e4 NG |
48 | |
49 | (define (eval_seq ast env) | |
50 | (cond | |
51 | ((null? ast) nil) | |
52 | ((null? (cdr ast)) (EVAL (car ast) env)) | |
53 | (else | |
54 | (EVAL (car ast) env) | |
55 | (eval_seq (cdr ast) env)))) | |
56 | ||
57 | (define (is_macro_call ast env) | |
58 | (and (list? ast) | |
81eabb99 | 59 | (> (length ast) 0) |
85657c96 | 60 | (and=> (env-check (car ast) env) is-macro))) |
98cd78e4 NG |
61 | |
62 | (define (_macroexpand ast env) | |
63 | (cond | |
64 | ((is_macro_call ast env) | |
65 | => (lambda (c) | |
66 | ;;(format #t "AAA: ~a, ~a~%" ast (_macroexpand (callable-apply c (cdr ast)) env)) | |
67 | ;;(format #t "BBB: ~a~%" (_macroexpand (callable-apply c (cdr ast)) env)) | |
68 | ;; NOTE: Macros are normal-order, so we shouldn't eval args here. | |
69 | ;; Or it's applicable-order. | |
70 | (_macroexpand (callable-apply c (cdr ast)) env))) | |
71 | (else ast))) | |
72 | ||
73 | (define (EVAL ast env) | |
74 | (define (%unzip2 kvs) | |
75 | (let lp((next kvs) (k '()) (v '())) | |
76 | (cond | |
77 | ;; NOTE: reverse is very important here! | |
78 | ((null? next) (values (reverse k) (reverse v))) | |
dd7a4f55 JM |
79 | ((null? (cdr next)) |
80 | (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) | |
98cd78e4 NG |
81 | (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) |
82 | (define (_quasiquote obj) | |
83 | (match obj | |
84 | ((('unquote unq) rest ...) `(cons ,unq ,(_quasiquote rest))) | |
85 | (('unquote unq) unq) | |
86 | ((('splice-unquote unqsp) rest ...) `(concat ,unqsp ,(_quasiquote rest))) | |
87 | ((head rest ...) (list 'cons (_quasiquote head) (_quasiquote rest))) | |
88 | (else `(quote ,obj)))) | |
89 | ;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means | |
90 | ;; it'll bring some trouble in control flow. We have to use continuations to return | |
91 | ;; and use non-standard `break' feature. In a word, not elegant at all. | |
92 | ;; The named let loop is natural for Scheme, but it looks a bit cheating. But NO! | |
93 | ;; Such kind of loop is actually `while loop' in Scheme, I don't take advantage of | |
94 | ;; TCO in Scheme to implement TCO, but it's the same principle with normal loop. | |
95 | ;; If you're Lispy enough, there's no recursive at all while you saw named let loop. | |
96 | (let tco-loop((ast ast) (env env)) ; expand as possible | |
97 | ;;(format #t "CCC: ~a === ~a~%" ast (_macroexpand ast env)) | |
98 | (let ((ast (_macroexpand ast env))) | |
99 | (match ast | |
100 | ((? non-list?) (eval_ast ast env)) | |
81eabb99 | 101 | (() ast) |
98cd78e4 NG |
102 | (('defmacro! k v) |
103 | (let ((c (EVAL v env))) | |
104 | (callable-is_macro-set! c #t) | |
105 | ((env 'set) k c))) | |
106 | (('macroexpand obj) (_macroexpand obj env)) | |
107 | (('quote obj) obj) | |
108 | (('quasiquote obj) (EVAL (_quasiquote (->list obj)) env)) | |
109 | (('def! k v) ((env 'set) k (EVAL v env))) | |
110 | (('let* kvs body) | |
111 | (let* ((new-env (make-Env #:outer env)) | |
112 | (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) | |
113 | (receive (keys vals) (%unzip2 (->list kvs)) | |
114 | (for-each setter keys vals)) | |
115 | (tco-loop body new-env))) | |
116 | (('do rest ...) | |
117 | (cond | |
dd7a4f55 JM |
118 | ((null? rest) |
119 | (throw 'mal-error (format #f "do: Invalid form! '~a'" rest))) | |
98cd78e4 NG |
120 | ((= 1 (length rest)) (tco-loop (car rest) env)) |
121 | (else | |
122 | (let ((mexpr (take rest (1- (length rest)))) | |
123 | (tail-call (car (take-right rest 1)))) | |
124 | (eval_seq mexpr env) | |
125 | (tco-loop tail-call env))))) | |
126 | (('if cnd thn els ...) | |
127 | (cond | |
128 | ((and (not (null? els)) (not (null? (cdr els)))) | |
129 | ;; Invalid `if' form | |
dd7a4f55 JM |
130 | (throw 'mal-error |
131 | (format #f "if: failed to match any pattern in form '~a'" ast))) | |
98cd78e4 NG |
132 | ((cond-true? (EVAL cnd env)) (tco-loop thn env)) |
133 | (else (if (null? els) nil (tco-loop (car els) env))))) | |
134 | (('fn* params body ...) ; function definition | |
dd7a4f55 | 135 | (make-anonymous-func |
98cd78e4 NG |
136 | (lambda args |
137 | (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) | |
138 | (cond | |
dd7a4f55 JM |
139 | ((null? body) |
140 | (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast))) | |
98cd78e4 NG |
141 | ((= 1 (length body)) (tco-loop (car body) nenv)) |
142 | (else | |
143 | (let ((mexpr (take body (1- (length body)))) | |
144 | (tail-call (car (take-right body 1)))) | |
145 | (eval_seq mexpr nenv) | |
146 | (tco-loop tail-call nenv)))))))) | |
dd7a4f55 JM |
147 | (('try* A) |
148 | (EVAL A env)) | |
98cd78e4 NG |
149 | (('try* A ('catch* B C)) |
150 | (catch | |
151 | #t | |
152 | (lambda () (EVAL A env)) | |
153 | (lambda e | |
154 | (let ((nenv (make-Env #:outer env #:binds (list B) #:exprs (cdr e)))) | |
155 | (EVAL C nenv))))) | |
dd7a4f55 JM |
156 | (else |
157 | (let ((el (map (lambda (x) (EVAL x env)) ast))) | |
158 | (callable-apply (car el) (cdr el)))))))) | |
98cd78e4 NG |
159 | |
160 | (define (EVAL-string str) | |
161 | (EVAL (read_str str) *toplevel*)) | |
162 | ||
163 | (define (PRINT exp) | |
164 | (and (not (eof-object? exp)) | |
98cd78e4 NG |
165 | (format #t "~a~%" (pr_str exp #t)))) |
166 | ||
167 | (define (LOOP continue?) | |
168 | (and continue? (REPL))) | |
169 | ||
170 | (define (REPL) | |
171 | (LOOP | |
dd7a4f55 JM |
172 | (let ((line (_readline "user> "))) |
173 | (cond | |
174 | ((eof-object? line) #f) | |
175 | ((string=? line "") #t) | |
176 | (else | |
177 | (catch 'mal-error | |
178 | (lambda () (PRINT (EVAL (READ line) *toplevel*))) | |
179 | (lambda (k . e) | |
180 | (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) | |
98cd78e4 NG |
181 | |
182 | ;; initialization | |
183 | ((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*)))) | |
184 | ((*toplevel* 'set) 'throw (make-func (lambda (val) (throw 'mal-error val)))) | |
185 | ((*toplevel* 'set) '*ARGV* '()) | |
17fc310d | 186 | (EVAL-string "(def! not (fn* (x) (if x false true)))") |
98cd78e4 NG |
187 | (EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") |
188 | (EVAL-string "(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)))))))") | |
1ad90e2b NG |
189 | |
190 | (let ((args (cdr (command-line)))) | |
2f60d14c NG |
191 | (cond |
192 | ((> (length args) 0) | |
4b3eaa74 NG |
193 | ((*toplevel* 'set) '*ARGV* (cdr args)) |
194 | (EVAL-string (string-append "(load-file \"" (car args) "\")"))) | |
195 | (else (REPL)))) |