Commit | Line | Data |
---|---|---|
be17d0a6 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 | (library (core) | |
5835f45b | 17 | (export core.ns ->list) |
9f3c0995 | 18 | (import (guile) (rnrs) (types) (reader) (printer) (ice-9 match) (readline))) |
5835f45b NG |
19 | |
20 | (define (->list o) ((if (vector? o) vector->list identity) o)) | |
be17d0a6 NG |
21 | |
22 | (define (_count obj) | |
23 | (cond | |
24 | ((_nil? obj) 0) | |
25 | ((vector? obj) (vector-length obj)) | |
26 | (else (length obj)))) | |
27 | ||
28 | (define (_empty? obj) (zero? (_count obj))) | |
29 | ||
dc656104 NG |
30 | ;; Well, strange spec... |
31 | (define (_equal? o1 o2) | |
d5995c72 DM |
32 | (define (equal-lists? lst1 lst2) |
33 | (and (= (length lst1) (length lst2)) | |
34 | (for-all _equal? lst1 lst2))) | |
35 | (define (equal-hash-tables? ht1 ht2) | |
36 | (define (equal-values? k) | |
37 | (_equal? (_get ht1 k) (_get ht2 k))) | |
38 | (let ((keys1 (_keys ht1))) | |
39 | (and (= (length keys1) (length (_keys ht2))) | |
40 | (for-all equal-values? keys1)))) | |
41 | (cond | |
42 | ((and (_sequential? o1) (_sequential? o2)) | |
43 | (equal-lists? (->list o1) (->list o2))) | |
44 | ((and (hash-table? o1) (hash-table? o2)) | |
45 | (equal-hash-tables? o1 o2)) | |
46 | (else | |
47 | (equal? o1 o2)))) | |
dc656104 | 48 | |
be17d0a6 NG |
49 | (define (pr-str . args) |
50 | (define (pr x) (pr_str x #t)) | |
51 | (string-join (map pr args) " ")) | |
52 | ||
dc656104 NG |
53 | (define (str . args) |
54 | (define (pr x) (pr_str x #f)) | |
55 | (string-join (map pr args) "")) | |
56 | ||
57 | (define (prn . args) | |
58 | (format #t "~a~%" (apply pr-str args)) | |
98cd78e4 | 59 | nil) |
dc656104 NG |
60 | |
61 | (define (println . args) | |
62 | (define (pr x) (pr_str x #f)) | |
98cd78e4 | 63 | (format #t "~{~a~^ ~}~%" (map pr args)) |
dc656104 NG |
64 | nil) |
65 | ||
f040d9fb NG |
66 | (define (slurp filename) |
67 | (when (not (file-exists? filename)) | |
0d9fb576 | 68 | (throw 'mal-error (format #f "File/dir '~a' doesn't exist" filename))) |
f040d9fb NG |
69 | (call-with-input-file filename get-string-all)) |
70 | ||
5835f45b NG |
71 | (define (_cons x y) |
72 | (cons x (->list y))) | |
73 | ||
74 | (define (concat . args) | |
75 | (apply append (map ->list args))) | |
76 | ||
e658ffd2 NG |
77 | (define (_nth lst n) |
78 | (define ll (->list lst)) | |
79 | (when (>= n (length ll)) | |
80 | (throw 'mal-error "nth: index out of range")) | |
81 | (list-ref ll n)) | |
82 | ||
83 | (define (_first lst) | |
84 | (define ll (->list lst)) | |
85 | (if (null? ll) | |
86 | nil | |
87 | (car ll))) | |
88 | ||
89 | (define (_rest lst) | |
90 | (define ll (->list lst)) | |
91 | (if (null? ll) | |
92 | '() | |
93 | (cdr ll))) | |
94 | ||
98cd78e4 NG |
95 | (define (_map f lst) (map (callable-closure f) (->list lst))) |
96 | ||
97 | (define (_apply f . args) | |
98 | (define ll | |
10bc1bce | 99 | (let lp((next args) (ret '())) |
98cd78e4 NG |
100 | (cond |
101 | ((null? next) (reverse ret)) | |
102 | (else | |
103 | (let ((n (->list (car next)))) | |
104 | (lp (cdr next) (if (list? n) | |
105 | (append (reverse n) ret) | |
106 | (cons n ret)))))))) | |
a6e59cf3 | 107 | (callable-apply f ll)) |
98cd78e4 NG |
108 | |
109 | (define (->symbol x) | |
110 | ((if (symbol? x) identity string->symbol) x)) | |
111 | ||
112 | (define (->keyword x) | |
113 | ((if (_keyword? x) identity string->keyword) x)) | |
114 | ||
98cd78e4 NG |
115 | (define (_hash-map . lst) (list->hash-map lst)) |
116 | ||
117 | (define (_assoc ht . lst) (list->hash-map lst (hash-table-clone ht))) | |
118 | ||
119 | (define (_get ht k) | |
120 | (if (_nil? ht) | |
121 | nil | |
122 | (hash-ref ht k nil))) | |
123 | ||
124 | (define (_dissoc ht . lst) | |
125 | (define ht2 (hash-table-clone ht)) | |
126 | (for-each (lambda (k) (hash-remove! ht2 k)) lst) | |
127 | ht2) | |
128 | ||
129 | (define (_keys ht) (hash-map->list (lambda (k v) k) ht)) | |
130 | ||
131 | (define (_vals ht) (hash-map->list (lambda (k v) v) ht)) | |
132 | ||
1c90c506 NG |
133 | (define (_contains? ht k) |
134 | (let ((v (hash-ref ht k '*mal-null*))) | |
135 | (if (eq? v '*mal-null*) | |
136 | #f | |
137 | #t))) | |
98cd78e4 NG |
138 | |
139 | (define (_sequential? o) (or (list? o) (vector? o))) | |
140 | ||
9f3c0995 NG |
141 | (define (_meta c) |
142 | (if (callable? c) | |
143 | (callable-meta-info c) | |
2a80d367 | 144 | (or (object-property c 'meta) nil))) |
9f3c0995 NG |
145 | |
146 | (define (_with-meta c ht) | |
147 | (cond | |
148 | ((callable? c) | |
149 | (let ((cc (make-callable ht | |
150 | (callable-unbox c) | |
0d9fb576 | 151 | (and (hash-table? ht) (hash-ref ht "ismacro")) |
9f3c0995 NG |
152 | (callable-closure c)))) |
153 | cc)) | |
154 | (else | |
155 | (let ((cc (box c))) | |
2a80d367 | 156 | (set-object-property! cc 'meta ht) |
9f3c0995 NG |
157 | cc)))) |
158 | ||
159 | ;; Apply closure 'c' with atom-val as one of arguments, then | |
160 | ;; set the result as the new val of atom. | |
161 | (define (_swap! atom c . rest) | |
162 | (let* ((args (cons (atom-val atom) rest)) | |
163 | (val (callable-apply c args))) | |
164 | (atom-val-set! atom val) | |
165 | val)) | |
166 | ||
167 | (define (_conj lst . args) | |
168 | (cond | |
169 | ((vector? lst) | |
170 | (list->vector (append (->list lst) args))) | |
171 | ((list? lst) | |
172 | (append (reverse args) (->list lst))) | |
173 | (else (throw 'mal-error (format #f "conj: '~a' is not list/vector" lst))))) | |
174 | ||
0d9fb576 NG |
175 | (define (__readline prompt) |
176 | (let ((str (_readline prompt))) | |
177 | (if (eof-object? str) | |
178 | #f | |
179 | str))) | |
180 | ||
8e9a0b72 NG |
181 | (define (_not o) (or (_nil? o) (not o))) |
182 | ||
2a80d367 NG |
183 | (define (_true? x) (eq? x #t)) |
184 | (define (_false? x) (eq? x #f)) | |
185 | ||
186 | ;; We need regular named procedure for better debug | |
187 | (define (_atom x) (make-atom x)) | |
188 | (define (_atom? x) (atom? x)) | |
189 | (define (_deref x) (atom-val x)) | |
190 | (define (_reset! x v) (atom-val-set! x v)) | |
191 | ||
4b3eaa74 NG |
192 | (define (time-ms) |
193 | (let ((t (gettimeofday))) | |
194 | (round | |
195 | (+ (* (car t) 1000.0) (/ (cdr t) 1000.0) 0.5)))) | |
196 | ||
be17d0a6 | 197 | (define *primitives* |
f040d9fb NG |
198 | `((list ,list) |
199 | (list? ,list?) | |
200 | (empty? ,_empty?) | |
201 | (count ,_count) | |
202 | (= ,_equal?) | |
203 | (< ,<) | |
204 | (<= ,<=) | |
205 | (> ,>) | |
206 | (>= ,>=) | |
207 | (+ ,+) | |
208 | (- ,-) | |
209 | (* ,*) | |
210 | (/ ,/) | |
8e9a0b72 | 211 | (not ,_not) |
f040d9fb NG |
212 | (pr-str ,pr-str) |
213 | (str ,str) | |
214 | (prn ,prn) | |
215 | (println ,println) | |
216 | (read-string ,read_str) | |
217 | (slurp ,slurp) | |
5835f45b NG |
218 | (cons ,_cons) |
219 | (concat ,concat) | |
e658ffd2 NG |
220 | (nth ,_nth) |
221 | (first ,_first) | |
222 | (rest ,_rest) | |
98cd78e4 NG |
223 | (map ,_map) |
224 | (apply ,_apply) | |
225 | (nil? ,_nil?) | |
2a80d367 NG |
226 | (true? ,_true?) |
227 | (false? ,_false?) | |
98cd78e4 NG |
228 | (symbol? ,symbol?) |
229 | (symbol ,->symbol) | |
230 | (keyword ,->keyword) | |
231 | (keyword? ,_keyword?) | |
232 | (vector? ,vector?) | |
233 | (vector ,vector) | |
234 | (hash-map ,_hash-map) | |
235 | (map? ,hash-table?) | |
236 | (assoc ,_assoc) | |
237 | (get ,_get) | |
238 | (dissoc ,_dissoc) | |
239 | (keys ,_keys) | |
240 | (vals ,_vals) | |
241 | (contains? ,_contains?) | |
242 | (sequential? ,_sequential?) | |
0d9fb576 | 243 | (readline ,__readline) |
9f3c0995 NG |
244 | (meta ,_meta) |
245 | (with-meta ,_with-meta) | |
2a80d367 NG |
246 | (atom ,_atom) |
247 | (atom? ,_atom?) | |
248 | (deref ,_deref) | |
249 | (reset! ,_reset!) | |
9f3c0995 | 250 | (swap! ,_swap!) |
2f60d14c | 251 | (conj ,_conj) |
4b3eaa74 | 252 | (time-ms ,time-ms))) |
be17d0a6 NG |
253 | |
254 | ;; Well, we have to rename it to this strange name... | |
255 | (define core.ns *primitives*) |