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.
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.
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/>.
16 (import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43)
17 (srfi srfi-1) (ice-9 receive) (env) (core) (types))
20 (receive (b e) (unzip2 core.ns)
21 (make-Env #:binds b #:exprs e)))
24 (read_str (readline "user> ")))
26 (define (eval_ast ast env)
27 (define (_eval x) (EVAL x env))
32 ;; delay eval is good design here
33 (lambda _ (throw 'mal-error (format #f "'~a' not found" sym)))))
34 ((? list? lst) (map _eval lst))
35 ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
37 (hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht)
41 (define (eval_func ast env)
42 (define expr (eval_ast ast env))
44 (((? procedure? proc) args ...)
46 (else 'mal-error (format #f "'~a' is not a valid form to apply!" expr))))
48 (define (eval_seq ast env)
51 ((null? (cdr ast)) (EVAL (car ast) env))
54 (eval_seq (cdr ast) env))))
56 (define (EVAL ast env)
57 (define (->list kvs) ((if (vector? kvs) vector->list identity) kvs))
59 (let lp((next kvs) (k '()) (v '()))
61 ;; NOTE: reverse is very important here!
62 ((null? next) (values (reverse k) (reverse v)))
63 ((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs))
64 (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
65 ;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means
66 ;; it'll bring some trouble in control flow. We have to use continuations to return
67 ;; and use non-standard `break' feature. In a word, not elegant at all.
68 ;; The named let loop is natural for Scheme, but it looks a bit cheating. But NO!
69 ;; Such kind of loop is actually `while loop' in Scheme, I don't take advantage of
70 ;; TCO in Scheme to implement TCO, but it's the same principle with normal loop.
71 ;; If you're Lispy enough, there's no recursive at all while you saw named let loop.
72 (let tco-loop((ast ast) (env env))
74 (('def! k v) ((env 'set) k (EVAL v env)))
76 (let* ((new-env (make-Env #:outer env))
77 (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
78 (receive (keys vals) (%unzip2 (->list kvs))
79 (for-each setter keys vals))
80 (tco-loop body new-env)))
83 ((null? rest) (throw 'mal-error "do: Invalid form!" rest))
84 ((= 1 (length rest)) (tco-loop (car rest) env))
86 (let ((mexpr (take rest (1- (length rest))))
87 (tail-call (car (take-right rest 1))))
89 (tco-loop tail-call env)))))
90 (('if cnd thn els ...)
92 ((and (not (null? els)) (not (null? (cdr els))))
94 (throw 'mal-error "if: failed to match any pattern in form " ast))
95 ((cond-true? (EVAL cnd env)) (tco-loop thn env))
96 (else (if (null? els) nil (tco-loop (car els) env)))))
97 (('fn* params body ...) ; function definition
99 (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args)))
101 ((null? body) (throw 'mal-error "fn*: bad lambda in form " ast))
102 ((= 1 (length body)) (tco-loop (car body) nenv))
104 (let ((mexpr (take body (1- (length body))))
105 (tail-call (car (take-right body 1))))
106 (eval_seq mexpr nenv)
107 (tco-loop tail-call nenv)))))))
108 ((? list?) (eval_func ast env)) ; function calling
109 (else (eval_ast ast env)))))
112 (and (not (eof-object? exp))
114 (format #t "~a~%" (pr_str exp #t))))
116 (define (LOOP continue?)
117 (and continue? (REPL)))
122 (lambda () (PRINT (EVAL (READ) *toplevel*)))
124 (format #t "Error: ~a~%" (car e))))))
126 ;; NOTE: we have to reduce stack size to pass step5 test
127 ((@ (system vm vm) call-with-stack-overflow-handler)
130 (lambda k (throw 'mal-error "stack overflow")))