Commit | Line | Data |
---|---|---|
f040d9fb 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 | ||
19 | (define *toplevel* | |
20 | (receive (b e) (unzip2 core.ns) | |
21 | (make-Env #:binds b #:exprs e))) | |
22 | ||
23 | (define (READ) | |
24 | (read_str (readline "user> "))) | |
25 | ||
26 | (define (eval_ast ast env) | |
27 | (define (_eval x) (EVAL x env)) | |
28 | (match ast | |
29 | ((? _nil? obj) obj) | |
30 | ((? symbol? sym) | |
31 | (or ((env 'get) sym) | |
32 | ;; delay eval is good design here | |
33 | (lambda _ (throw 'mal-error (format #f "procedure '~a' not found" sym))))) | |
34 | ((? list? lst) (map _eval lst)) | |
35 | ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec)) | |
36 | ((? hash-table? ht) | |
37 | (hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht) | |
38 | ht) | |
39 | (else ast))) | |
40 | ||
41 | (define (eval_func ast env) | |
42 | (define expr (eval_ast ast env)) | |
43 | (match expr | |
44 | (((? procedure? proc) args ...) | |
45 | (apply proc args)) | |
46 | (else 'mal-error (format #f "'~a' is not a valid form to apply!" expr)))) | |
47 | ||
48 | (define (eval_seq ast env) | |
49 | (cond | |
50 | ((null? ast) nil) | |
51 | ((null? (cdr ast)) (EVAL (car ast) env)) | |
52 | (else | |
53 | (EVAL (car ast) env) | |
54 | (eval_seq (cdr ast) env)))) | |
55 | ||
56 | (define (EVAL ast env) | |
57 | (define (->list kvs) ((if (vector? kvs) vector->list identity) kvs)) | |
58 | (define (%unzip2 kvs) | |
59 | (let lp((next kvs) (k '()) (v '())) | |
60 | (cond | |
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)) | |
73 | (match ast | |
74 | (('def! k v) ((env 'set) k (EVAL v env))) | |
75 | (('let* kvs body) | |
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))) | |
81 | (('do rest ...) | |
82 | (cond | |
83 | ((null? rest) (throw 'mal-error "do: Invalid form!" rest)) | |
84 | ((= 1 (length rest)) (tco-loop (car rest) env)) | |
85 | (else | |
86 | (let ((mexpr (take rest (1- (length rest)))) | |
87 | (tail-call (car (take-right rest 1)))) | |
88 | (eval_seq mexpr env) | |
89 | (tco-loop tail-call env))))) | |
90 | (('if cnd thn els ...) | |
91 | (cond | |
92 | ((and (not (null? els)) (not (null? (cdr els)))) | |
93 | ;; Invalid `if' form | |
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 | |
98 | (lambda args | |
99 | (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args))) | |
100 | (cond | |
101 | ((null? body) (throw 'mal-error "fn*: bad lambda in form " ast)) | |
102 | ((= 1 (length body)) (tco-loop (car body) nenv)) | |
103 | (else | |
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))))) | |
110 | ||
111 | (define (EVAL-string str) | |
112 | (EVAL (read_str str) *toplevel*)) | |
113 | ||
114 | (define (PRINT exp) | |
115 | (and (not (eof-object? exp)) | |
116 | ;;(add-history str) | |
117 | (format #t "~a~%" (pr_str exp #t)))) | |
118 | ||
119 | (define (LOOP continue?) | |
120 | (and continue? (REPL))) | |
121 | ||
122 | (define (REPL) | |
123 | (LOOP | |
124 | (catch 'mal-error | |
125 | (lambda () (PRINT (EVAL (READ) *toplevel*))) | |
126 | (lambda (k . e) | |
127 | (format #t "Error: ~a~%" (car e)))))) | |
128 | ||
129 | ;; initialization | |
130 | ((*toplevel* 'set) 'eval (lambda (ast) (EVAL ast *toplevel*))) | |
131 | ((*toplevel* 'set) '*ARGV* '()) | |
132 | (EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") | |
133 | ||
134 | (REPL) |