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