├── .gitignore
├── .replit
├── README.md
├── deps.edn
├── reference
├── guide.txt
├── repl-demo.gif
└── source.bel
├── resources
├── bel.ebnf
└── core.bel
├── src
└── bel_clojure
│ ├── core.clj
│ ├── evaluator.clj
│ ├── model.clj
│ └── reader.clj
└── test
└── bel_clojure
├── core_test.clj
├── evaluator_test.clj
├── model_test.clj
└── reader_test.clj
/.gitignore:
--------------------------------------------------------------------------------
1 | .idea
2 | .lsp
3 | .cpcache
4 | .nrepl-port
5 | .clj-kondo
6 | .DS_Store
--------------------------------------------------------------------------------
/.replit:
--------------------------------------------------------------------------------
1 | language = "bash"
2 | run = "clj -m bel-clojure.core"
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # bel-clojure: super-alpha
2 |
3 |
4 | 
5 |
6 |
7 | This is my hack to run PG’s Bel in Clojure. Want to try it out?
8 |
9 | First, Make sure you have [Clojure](https://clojure.org/guides/getting_started#_clojure_installer_and_cli_tools) installed. After that:
10 |
11 | ```bash
12 | clj -X:repl
13 | ```
14 |
15 | ## Tests
16 |
17 | ```
18 | clj -X:test
19 | ```
20 |
21 | ## Some Examples
22 |
23 | This is PG's `examples`, recreated on this interpreter. You can note what's implemented, and the slight differences.
24 |
25 | ```clojure
26 | >
27 | (cons 'a 'b '(c d e))
28 | > (a b c d e)
29 | (cons \h "ello")
30 | > (h e l l o)
31 | (2 '(a b c))
32 | > b
33 | (set w '(a (b c) d (e f)))
34 | > nil
35 | (find pair w)
36 | > (b c)
37 | (pop (find pair w))
38 | > b
39 | w
40 | > (a (c) d (e f))
41 | (dedup:sort < "abracadabra")
42 | > (a b c d r)
43 | (map (upon 2 3) (list + - * /))
44 | > (5 -1 6 2/3)
45 | (let x 'a
46 | (cons x 'b))
47 | > (a . b)
48 | (with (x 1 y 2)
49 | (+ x y))
50 | > 3
51 | (let ((x y) . z) '((a b) c)
52 | (list x y z))
53 | > (a b (c))
54 | ((fn (x) (cons x 'b)) 'a)
55 | > (a . b)
56 | ((fn (x|symbol) (cons x 'b)) 'a)
57 | > (a . b)
58 | ((fn (x|int) (cons x 'b)) 'a)
59 | > (err (quote mistype))
60 | ((fn (f x|f) (cons x 'b)) sym 'a)
61 | > (a . b)
62 | ((macro (v) `(set ,v 7)) x)
63 | > nil
64 | x
65 | > 7
66 | (apply or '(t nil))
67 | > t
68 | (best (of > len) '((a b) (a b c d) (a) (a b c)))
69 | > (a b c d)
70 | (do (thread (do (join 'a 'b)))
71 | (thread (do (join 'a 'b) (join 'b 'd))))
72 | > (b . d)
73 | (do (thread (do (join 'a 'b)))
74 | (thread
75 | (atomic (do (join 'a 'b) (join 'b 'd)))))
76 | > (a . b)
77 | ```
78 |
79 | ## Notes
80 |
81 | To make the interpreter tolerably fast, **I tweaked the source in a few ways**
82 |
83 | 1. I represent the environment as a map, rather than a list
84 | 2. I leaked java’s numbers, strings, and characters into Bel
85 | 3. I moved some logic out of the source and into the interpreter
86 |
87 | This isn't done yet. **There's a few big todos remaining**
88 |
89 | 1. Streams. I didn’t implement streams yet. I think the best plan would be to leak Java streams, and I wanted to think about it.
90 | 2. Performance tuning. I made some tweaks, but there's a lot of low-hanging fruit still.
91 |
92 | This has been a lot of fun to write. I hope it’s as fun for you to play with it.
93 |
--------------------------------------------------------------------------------
/deps.edn:
--------------------------------------------------------------------------------
1 | {:paths ["src" "resources"]
2 | :deps {org.clojure/clojure {:mvn/version "1.10.3"}
3 | instaparse/instaparse {:mvn/version "1.4.10"}}
4 | :aliases {:repl {:main-opts ["-m" "bel-clojure.core"]
5 | :exec-fn bel-clojure.core/-main}
6 | :test {:extra-deps {io.github.cognitect-labs/test-runner
7 | {:git/url "https://github.com/cognitect-labs/test-runner.git"
8 | :sha "9e35c979860c75555adaff7600070c60004a0f44"}}
9 | :main-opts ["-m" "cognitect.test-runner"]
10 | :exec-fn cognitect.test-runner.api/test
11 | :extra-paths ["test"]}
12 |
13 | :nREPL
14 | {:extra-paths ["test"]
15 | :extra-deps
16 | {nrepl/nrepl {:mvn/version "0.8.3"}}}}}
17 |
--------------------------------------------------------------------------------
/reference/repl-demo.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/stopachka/bel-clojure/2e5ab2e90bb3489de96a16e8cf31c86db6cb03b6/reference/repl-demo.gif
--------------------------------------------------------------------------------
/reference/source.bel:
--------------------------------------------------------------------------------
1 | ; Bel in Bel. 9 October 2019, 9:14 GMT
2 |
3 |
4 | (def no (x)
5 | (id x nil))
6 |
7 | (def atom (x)
8 | (no (id (type x) 'pair)))
9 |
10 | (def all (f xs)
11 | (if (no xs) t
12 | (f (car xs)) (all f (cdr xs))
13 | nil))
14 |
15 | (def some (f xs)
16 | (if (no xs) nil
17 | (f (car xs)) xs
18 | (some f (cdr xs))))
19 |
20 | (def reduce (f xs)
21 | (if (no (cdr xs))
22 | (car xs)
23 | (f (car xs) (reduce f (cdr xs)))))
24 |
25 | (def cons args
26 | (reduce join args))
27 |
28 | (def append args
29 | (if (no (cdr args)) (car args)
30 | (no (car args)) (apply append (cdr args))
31 | (cons (car (car args))
32 | (apply append (cdr (car args))
33 | (cdr args)))))
34 |
35 | (def snoc args
36 | (append (car args) (cdr args)))
37 |
38 | (def list args
39 | (append args nil))
40 |
41 | (def map (f . ls)
42 | (if (no ls) nil
43 | (some no ls) nil
44 | (no (cdr ls)) (cons (f (car (car ls)))
45 | (map f (cdr (car ls))))
46 | (cons (apply f (map car ls))
47 | (apply map f (map cdr ls)))))
48 |
49 | (mac fn (parms . body)
50 | (if (no (cdr body))
51 | `(list 'lit 'clo scope ',parms ',(car body))
52 | `(list 'lit 'clo scope ',parms '(do ,@body))))
53 |
54 | (set vmark (join))
55 |
56 | (def uvar ()
57 | (list vmark))
58 |
59 | (mac do args
60 | (reduce (fn (x y)
61 | (list (list 'fn (uvar) y) x))
62 | args))
63 |
64 | (mac let (parms val . body)
65 | `((fn (,parms) ,@body) ,val))
66 |
67 | (mac macro args
68 | `(list 'lit 'mac (fn ,@args)))
69 |
70 | (mac def (n . rest)
71 | `(set ,n (fn ,@rest)))
72 |
73 | (mac mac (n . rest)
74 | `(set ,n (macro ,@rest)))
75 |
76 | (mac or args
77 | (if (no args)
78 | nil
79 | (let v (uvar)
80 | `(let ,v ,(car args)
81 | (if ,v ,v (or ,@(cdr args)))))))
82 |
83 | (mac and args
84 | (reduce (fn es (cons 'if es))
85 | (or args '(t))))
86 |
87 | (def = args
88 | (if (no (cdr args)) t
89 | (some atom args) (all [id _ (car args)] (cdr args))
90 | (and (apply = (map car args))
91 | (apply = (map cdr args)))))
92 |
93 | (def symbol (x) (= (type x) 'symbol))
94 |
95 | (def pair (x) (= (type x) 'pair))
96 |
97 | (def char (x) (= (type x) 'char))
98 |
99 | (def stream (x) (= (type x) 'stream))
100 |
101 | (def proper (x)
102 | (or (no x)
103 | (and (pair x) (proper (cdr x)))))
104 |
105 | (def string (x)
106 | (and (proper x) (all char x)))
107 |
108 | (def mem (x ys (o f =))
109 | (some [f _ x] ys))
110 |
111 | (def in (x . ys)
112 | (mem x ys))
113 |
114 | (def cadr (x) (car (cdr x)))
115 |
116 | (def cddr (x) (cdr (cdr x)))
117 |
118 | (def caddr (x) (car (cddr x)))
119 |
120 | (mac case (expr . args)
121 | (if (no (cdr args))
122 | (car args)
123 | (let v (uvar)
124 | `(let ,v ,expr
125 | (if (= ,v ',(car args))
126 | ,(cadr args)
127 | (case ,v ,@(cddr args)))))))
128 |
129 | (mac iflet (var . args)
130 | (if (no (cdr args))
131 | (car args)
132 | (let v (uvar)
133 | `(let ,v ,(car args)
134 | (if ,v
135 | (let ,var ,v ,(cadr args))
136 | (iflet ,var ,@(cddr args)))))))
137 |
138 | (mac aif args
139 | `(iflet it ,@args))
140 |
141 | (def find (f xs)
142 | (aif (some f xs) (car it)))
143 |
144 | (def begins (xs pat (o f =))
145 | (if (no pat) t
146 | (atom xs) nil
147 | (f (car xs) (car pat)) (begins (cdr xs) (cdr pat) f)
148 | nil))
149 |
150 | (def caris (x y (o f =))
151 | (begins x (list y) f))
152 |
153 | (def hug (xs (o f list))
154 | (if (no xs) nil
155 | (no (cdr xs)) (list (f (car xs)))
156 | (cons (f (car xs) (cadr xs))
157 | (hug (cddr xs) f))))
158 |
159 | (mac with (parms . body)
160 | (let ps (hug parms)
161 | `((fn ,(map car ps) ,@body)
162 | ,@(map cadr ps))))
163 |
164 | (def keep (f xs)
165 | (if (no xs) nil
166 | (f (car xs)) (cons (car xs) (keep f (cdr xs)))
167 | (keep f (cdr xs))))
168 |
169 | (def rem (x ys (o f =))
170 | (keep [no (f _ x)] ys))
171 |
172 | (def get (k kvs (o f =))
173 | (find [f (car _) k] kvs))
174 |
175 | (def put (k v kvs (o f =))
176 | (cons (cons k v)
177 | (rem k kvs (fn (x y) (f (car x) y)))))
178 |
179 | (def rev (xs)
180 | (if (no xs)
181 | nil
182 | (snoc (rev (cdr xs)) (car xs))))
183 |
184 | (def snap (xs ys (o acc))
185 | (if (no xs)
186 | (list acc ys)
187 | (snap (cdr xs) (cdr ys) (snoc acc (car ys)))))
188 |
189 | (def udrop (xs ys)
190 | (cadr (snap xs ys)))
191 |
192 | (def idfn (x)
193 | x)
194 |
195 | (def is (x)
196 | [= _ x])
197 |
198 | (mac eif (var (o expr) (o fail) (o ok))
199 | (with (v (uvar)
200 | w (uvar)
201 | c (uvar))
202 | `(let ,v (join)
203 | (let ,w (ccc (fn (,c)
204 | (dyn err [,c (cons ,v _)] ,expr)))
205 | (if (caris ,w ,v id)
206 | (let ,var (cdr ,w) ,fail)
207 | (let ,var ,w ,ok))))))
208 |
209 | (mac onerr (e1 e2)
210 | (let v (uvar)
211 | `(eif ,v ,e2 ,e1 ,v)))
212 |
213 | (mac safe (expr)
214 | `(onerr nil ,expr))
215 |
216 | (def literal (e)
217 | (or (in e t nil o apply)
218 | (in (type e) 'char 'stream)
219 | (caris e 'lit)
220 | (string e)))
221 |
222 | (def variable (e)
223 | (if (atom e)
224 | (no (literal e))
225 | (id (car e) vmark)))
226 |
227 | (def isa (name)
228 | [begins _ `(lit ,name) id])
229 |
230 | (def bel (e (o g globe))
231 | (ev (list (list e nil))
232 | nil
233 | (list nil g)))
234 |
235 | (def mev (s r (p g))
236 | (if (no s)
237 | (if p
238 | (sched p g)
239 | (car r))
240 | (sched (if (cdr (binding 'lock s))
241 | (cons (list s r) p)
242 | (snoc p (list s r)))
243 | g)))
244 |
245 | (def sched (((s r) . p) g)
246 | (ev s r (list p g)))
247 |
248 | (def ev (((e a) . s) r m)
249 | (aif (literal e) (mev s (cons e r) m)
250 | (variable e) (vref e a s r m)
251 | (no (proper e)) (sigerr 'malformed s r m)
252 | (get (car e) forms id) ((cdr it) (cdr e) a s r m)
253 | (evcall e a s r m)))
254 |
255 | (def vref (v a s r m)
256 | (let g (cadr m)
257 | (if (inwhere s)
258 | (aif (or (lookup v a s g)
259 | (and (car (inwhere s))
260 | (let cell (cons v nil)
261 | (xdr g (cons cell (cdr g)))
262 | cell)))
263 | (mev (cdr s) (cons (list it 'd) r) m)
264 | (sigerr 'unbound s r m))
265 | (aif (lookup v a s g)
266 | (mev s (cons (cdr it) r) m)
267 | (sigerr (list 'unboundb v) s r m)))))
268 |
269 | (set smark (join))
270 |
271 | (def inwhere (s)
272 | (let e (car (car s))
273 | (and (begins e (list smark 'loc))
274 | (cddr e))))
275 |
276 | (def lookup (e a s g)
277 | (or (binding e s)
278 | (get e a id)
279 | (get e g id)
280 | (case e
281 | scope (cons e a)
282 | globe (cons e g))))
283 |
284 | (def binding (v s)
285 | (get v
286 | (map caddr (keep [begins _ (list smark 'bind) id]
287 | (map car s)))
288 | id))
289 |
290 | (def sigerr (msg s r m)
291 | (aif (binding 'err s)
292 | (applyf (cdr it) (list msg) nil s r m)
293 | (err 'no-err)))
294 |
295 | (mac fu args
296 | `(list (list smark 'fut (fn ,@args)) nil))
297 |
298 | (def evmark (e a s r m)
299 | (case (car e)
300 | fut ((cadr e) s r m)
301 | bind (mev s r m)
302 | loc (sigerr 'unfindable s r m)
303 | prot (mev (cons (list (cadr e) a)
304 | (fu (s r m) (mev s (cdr r) m))
305 | s)
306 | r
307 | m)
308 | (sigerr 'unknown-mark s r m)))
309 |
310 | (set forms (list (cons smark evmark)))
311 |
312 | (mac form (name parms . body)
313 | `(set forms (put ',name ,(formfn parms body) forms)))
314 |
315 | (def formfn (parms body)
316 | (with (v (uvar)
317 | w (uvar)
318 | ps (parameters (car parms)))
319 | `(fn ,v
320 | (eif ,w (apply (fn ,(car parms) (list ,@ps))
321 | (car ,v))
322 | (apply sigerr 'bad-form (cddr ,v))
323 | (let ,ps ,w
324 | (let ,(cdr parms) (cdr ,v) ,@body))))))
325 |
326 | (def parameters (p)
327 | (if (no p) nil
328 | (variable p) (list p)
329 | (atom p) (err 'bad-parm)
330 | (in (car p) t o) (parameters (cadr p))
331 | (append (parameters (car p))
332 | (parameters (cdr p)))))
333 |
334 | (form quote ((e) a s r m)
335 | (mev s (cons e r) m))
336 |
337 | (form if (es a s r m)
338 | (if (no es)
339 | (mev s (cons nil r) m)
340 | (mev (cons (list (car es) a)
341 | (if (cdr es)
342 | (cons (fu (s r m)
343 | (if2 (cdr es) a s r m))
344 | s)
345 | s))
346 | r
347 | m)))
348 |
349 | (def if2 (es a s r m)
350 | (mev (cons (list (if (car r)
351 | (car es)
352 | (cons 'if (cdr es)))
353 | a)
354 | s)
355 | (cdr r)
356 | m))
357 |
358 | (form where ((e (o new)) a s r m)
359 | (mev (cons (list e a)
360 | (list (list smark 'loc new) nil)
361 | s)
362 | r
363 | m))
364 |
365 | (form dyn ((v e1 e2) a s r m)
366 | (if (variable v)
367 | (mev (cons (list e1 a)
368 | (fu (s r m) (dyn2 v e2 a s r m))
369 | s)
370 | r
371 | m)
372 | (sigerr 'cannot-bind s r m)))
373 |
374 | (def dyn2 (v e2 a s r m)
375 | (mev (cons (list e2 a)
376 | (list (list smark 'bind (cons v (car r)))
377 | nil)
378 | s)
379 | (cdr r)
380 | m))
381 |
382 | (form after ((e1 e2) a s r m)
383 | (mev (cons (list e1 a)
384 | (list (list smark 'prot e2) a)
385 | s)
386 | r
387 | m))
388 |
389 | (form ccc ((f) a s r m)
390 | (mev (cons (list (list f (list 'lit 'cont s r))
391 | a)
392 | s)
393 | r
394 | m))
395 |
396 | (form thread ((e) a s r (p g))
397 | (mev s
398 | (cons nil r)
399 | (list (cons (list (list (list e a))
400 | nil)
401 | p)
402 | g)))
403 |
404 | (def evcall (e a s r m)
405 | (mev (cons (list (car e) a)
406 | (fu (s r m)
407 | (evcall2 (cdr e) a s r m))
408 | s)
409 | r
410 | m))
411 |
412 | (def evcall2 (es a s (op . r) m)
413 | (if ((isa 'mac) op)
414 | (applym op es a s r m)
415 | (mev (append (map [list _ a] es)
416 | (cons (fu (s r m)
417 | (let (args r2) (snap es r)
418 | (applyf op (rev args) a s r2 m)))
419 | s))
420 | r
421 | m)))
422 |
423 | (def applym (mac args a s r m)
424 | (applyf (caddr mac)
425 | args
426 | a
427 | (cons (fu (s r m)
428 | (mev (cons (list (car r) a) s)
429 | (cdr r)
430 | m))
431 | s)
432 | r
433 | m))
434 |
435 | (def applyf (f args a s r m)
436 | (if (= f apply) (applyf (car args) (reduce join (cdr args)) a s r m)
437 | (caris f 'lit) (if (proper f)
438 | (applylit f args a s r m)
439 | (sigerr 'bad-lit s r m))
440 | (sigerr 'cannot-apply s r m)))
441 |
442 | (def applylit (f args a s r m)
443 | (aif (and (inwhere s) (find [(car _) f] locfns))
444 | ((cadr it) f args a s r m)
445 | (let (tag . rest) (cdr f)
446 | (case tag
447 | prim (applyprim (car rest) args s r m)
448 | clo (let ((o env) (o parms) (o body) . extra) rest
449 | (if (and (okenv env) (okparms parms))
450 | (applyclo parms args env body s r m)
451 | (sigerr 'bad-clo s r m)))
452 | mac (applym f (map [list 'quote _] args) a s r m)
453 | cont (let ((o s2) (o r2) . extra) rest
454 | (if (and (okstack s2) (proper r2))
455 | (applycont s2 r2 args s r m)
456 | (sigerr 'bad-cont s r m)))
457 | (aif (get tag virfns)
458 | (let e ((cdr it) f (map [list 'quote _] args))
459 | (mev (cons (list e a) s) r m))
460 | (sigerr 'unapplyable s r m))))))
461 |
462 | (set virfns nil)
463 |
464 | (mac vir (tag . rest)
465 | `(set virfns (put ',tag (fn ,@rest) virfns)))
466 |
467 | (set locfns nil)
468 |
469 | (mac loc (test . rest)
470 | `(set locfns (cons (list ,test (fn ,@rest)) locfns)))
471 |
472 | (loc (is car) (f args a s r m)
473 | (mev (cdr s) (cons (list (car args) 'a) r) m))
474 |
475 | (loc (is cdr) (f args a s r m)
476 | (mev (cdr s) (cons (list (car args) 'd) r) m))
477 |
478 | (def okenv (a)
479 | (and (proper a) (all pair a)))
480 |
481 | (def okstack (s)
482 | (and (proper s)
483 | (all [and (proper _) (cdr _) (okenv (cadr _))]
484 | s)))
485 |
486 | (def okparms (p)
487 | (if (no p) t
488 | (variable p) t
489 | (atom p) nil
490 | (caris p t) (oktoparm p)
491 | (and (if (caris (car p) o)
492 | (oktoparm (car p))
493 | (okparms (car p)))
494 | (okparms (cdr p)))))
495 |
496 | (def oktoparm ((tag (o var) (o e) . extra))
497 | (and (okparms var) (or (= tag o) e) (no extra)))
498 |
499 | (set prims '((id join xar xdr wrb ops)
500 | (car cdr type sym nom rdb cls stat sys)
501 | (coin)))
502 |
503 | (def applyprim (f args s r m)
504 | (aif (some [mem f _] prims)
505 | (if (udrop (cdr it) args)
506 | (sigerr 'overargs s r m)
507 | (with (a (car args)
508 | b (cadr args))
509 | (eif v (case f
510 | id (id a b)
511 | join (join a b)
512 | car (car a)
513 | cdr (cdr a)
514 | type (type a)
515 | xar (xar a b)
516 | xdr (xdr a b)
517 | sym (sym a)
518 | nom (nom a)
519 | wrb (wrb a b)
520 | rdb (rdb a)
521 | ops (ops a b)
522 | cls (cls a)
523 | stat (stat a)
524 | coin (coin)
525 | sys (sys a))
526 | (sigerr v s r m)
527 | (mev s (cons v r) m))))
528 | (sigerr 'unknown-prim s r m)))
529 |
530 | (def applyclo (parms args env body s r m)
531 | (mev (cons (fu (s r m)
532 | (pass parms args env s r m))
533 | (fu (s r m)
534 | (mev (cons (list body (car r)) s)
535 | (cdr r)
536 | m))
537 | s)
538 | r
539 | m))
540 |
541 | (def pass (pat arg env s r m)
542 | (let ret [mev s (cons _ r) m]
543 | (if (no pat) (if arg
544 | (sigerr 'overargs s r m)
545 | (ret env))
546 | (literal pat) (sigerr 'literal-parm s r m)
547 | (variable pat) (ret (cons (cons pat arg) env))
548 | (caris pat t) (typecheck (cdr pat) arg env s r m)
549 | (caris pat o) (pass (cadr pat) arg env s r m)
550 | (destructure pat arg env s r m))))
551 |
552 | (def typecheck ((var f) arg env s r m)
553 | (mev (cons (list (list f (list 'quote arg)) env)
554 | (fu (s r m)
555 | (if (car r)
556 | (pass var arg env s (cdr r) m)
557 | (sigerr 'mistype s r m)))
558 | s)
559 | r
560 | m))
561 |
562 | (def destructure ((p . ps) arg env s r m)
563 | (if (no arg) (if (caris p o)
564 | (mev (cons (list (caddr p) env)
565 | (fu (s r m)
566 | (pass (cadr p) (car r) env s (cdr r) m))
567 | (fu (s r m)
568 | (pass ps nil (car r) s (cdr r) m))
569 | s)
570 | r
571 | m)
572 | (sigerr 'underargs s r m))
573 | (atom arg) (sigerr 'atom-arg s r m)
574 | (mev (cons (fu (s r m)
575 | (pass p (car arg) env s r m))
576 | (fu (s r m)
577 | (pass ps (cdr arg) (car r) s (cdr r) m))
578 | s)
579 | r
580 | m)))
581 |
582 | (def applycont (s2 r2 args s r m)
583 | (if (or (no args) (cdr args))
584 | (sigerr 'wrong-no-args s r m)
585 | (mev (append (keep [and (protected _) (no (mem _ s2 id))]
586 | s)
587 | s2)
588 | (cons (car args) r2)
589 | m)))
590 |
591 | (def protected (x)
592 | (some [begins (car x) (list smark _) id]
593 | '(bind prot)))
594 |
595 | (def function (x)
596 | (find [(isa _) x] '(prim clo)))
597 |
598 | (def con (x)
599 | (fn args x))
600 |
601 | (def compose fs
602 | (reduce (fn (f g)
603 | (fn args (f (apply g args))))
604 | (or fs (list idfn))))
605 |
606 | (def combine (op)
607 | (fn fs
608 | (reduce (fn (f g)
609 | (fn args
610 | (op (apply f args) (apply g args))))
611 | (or fs (list (con (op)))))))
612 |
613 | (set cand (combine and)
614 | cor (combine or))
615 |
616 | (def foldl (f base . args)
617 | (if (or (no args) (some no args))
618 | base
619 | (apply foldl f
620 | (apply f (snoc (map car args) base))
621 | (map cdr args))))
622 |
623 | (def foldr (f base . args)
624 | (if (or (no args) (some no args))
625 | base
626 | (apply f (snoc (map car args)
627 | (apply foldr f base (map cdr args))))))
628 |
629 | (def of (f g)
630 | (fn args (apply f (map g args))))
631 |
632 | (def upon args
633 | [apply _ args])
634 |
635 | (def pairwise (f xs)
636 | (or (no (cdr xs))
637 | (and (f (car xs) (cadr xs))
638 | (pairwise f (cdr xs)))))
639 |
640 | (def fuse (f . args)
641 | (apply append (apply map f args)))
642 |
643 | (mac letu (v . body)
644 | (if ((cor variable atom) v)
645 | `(let ,v (uvar) ,@body)
646 | `(with ,(fuse [list _ '(uvar)] v)
647 | ,@body)))
648 |
649 | (mac pcase (expr . args)
650 | (if (no (cdr args))
651 | (car args)
652 | (letu v
653 | `(let ,v ,expr
654 | (if (,(car args) ,v)
655 | ,(cadr args)
656 | (pcase ,v ,@(cddr args)))))))
657 |
658 | (def match (x pat)
659 | (if (= pat t) t
660 | (function pat) (pat x)
661 | (or (atom x) (atom pat)) (= x pat)
662 | (and (match (car x) (car pat))
663 | (match (cdr x) (cdr pat)))))
664 |
665 | (def split (f xs (o acc))
666 | (if ((cor atom f:car) xs)
667 | (list acc xs)
668 | (split f (cdr xs) (snoc acc (car xs)))))
669 |
670 | (mac when (expr . body)
671 | `(if ,expr (do ,@body)))
672 |
673 | (mac unless (expr . body)
674 | `(when (no ,expr) ,@body))
675 |
676 | (set i0 nil
677 | i1 '(t)
678 | i2 '(t t)
679 | i10 '(t t t t t t t t t t)
680 | i16 '(t t t t t t t t t t t t t t t t))
681 |
682 | (set i< udrop)
683 |
684 | (def i+ args
685 | (apply append args))
686 |
687 | (def i- (x y)
688 | (if (no x) (list '- y)
689 | (no y) (list '+ x)
690 | (i- (cdr x) (cdr y))))
691 |
692 | (def i* args
693 | (foldr (fn (x y) (fuse (con x) y))
694 | i1
695 | args))
696 |
697 | (def i/ (x y (o q))
698 | (if (no x) (list q nil)
699 | (i< x y) (list q x)
700 | (i/ (udrop y x) y (i+ q i1))))
701 |
702 | (def i^ (x y)
703 | (foldr i* i1 (map (con x) y)))
704 |
705 | (def r+ ((xn xd) (yn yd))
706 | (list (i+ (i* xn yd) (i* yn xd))
707 | (i* xd yd)))
708 |
709 | (def r- ((xn xd) (yn yd))
710 | (let (s n) (i- (i* xn yd) (i* yn xd))
711 | (list s n (i* xd yd))))
712 |
713 | (def r* ((xn xd) (yn yd))
714 | (list (i* xn yn) (i* xd yd)))
715 |
716 | (def r/ ((xn xd) (yn yd))
717 | (list (i* xn yd) (i* xd yn)))
718 |
719 | (set srzero (list '+ i0 i1)
720 | srone (list '+ i1 i1))
721 |
722 | (def sr+ ((xs . xr) (ys . yr))
723 | (if (= xs '-)
724 | (if (= ys '-)
725 | (cons '- (r+ xr yr))
726 | (r- yr xr))
727 | (if (= ys '-)
728 | (r- xr yr)
729 | (cons '+ (r+ xr yr)))))
730 |
731 | (def sr- (x y)
732 | (sr+ x (srinv y)))
733 |
734 | (def srinv ((s n d))
735 | (list (if (and (= s '+) (~= n i0)) '- '+)
736 | n
737 | d))
738 |
739 | (def sr* ((xs . xr) (ys . yr))
740 | (cons (if (= xs '-)
741 | (case ys - '+ '-)
742 | ys)
743 | (r* xr yr)))
744 |
745 | (def sr/ (x y)
746 | (sr* x (srrecip y)))
747 |
748 | (def srrecip ((s (t n [~= _ i0]) d))
749 | (list s d n))
750 |
751 | (def sr< ((xs xn xd) (ys yn yd))
752 | (if (= xs '+)
753 | (if (= ys '+)
754 | (i< (i* xn yd) (i* yn xd))
755 | nil)
756 | (if (= ys '+)
757 | (~= xn yn i0)
758 | (i< (i* yn xd) (i* xn yd)))))
759 |
760 | (set srnum cadr
761 | srden caddr)
762 |
763 | (def c+ ((xr xi) (yr yi))
764 | (list (sr+ xr yr) (sr+ xi yi)))
765 |
766 | (def c* ((xr xi) (yr yi))
767 | (list (sr- (sr* xr yr) (sr* xi yi))
768 | (sr+ (sr* xi yr) (sr* xr yi))))
769 |
770 | (def litnum (r (o i srzero))
771 | (list 'lit 'num r i))
772 |
773 | (def number (x)
774 | (let r (fn (y)
775 | (match y (list [in _ '+ '-] proper proper)))
776 | (match x `(lit num ,r ,r))))
777 |
778 | (set numr car:cddr
779 | numi cadr:cddr)
780 |
781 | (set rpart litnum:numr
782 | ipart litnum:numi)
783 |
784 | (def real (x)
785 | (and (number x) (= (numi x) srzero)))
786 |
787 | (def inv (x)
788 | (litnum (srinv:numr x) (srinv:numi x)))
789 |
790 | (def abs (x)
791 | (litnum (cons '+ (cdr (numr x)))))
792 |
793 | (def simplify ((s n d))
794 | (if (= n i0) (list '+ n i1)
795 | (= n d) (list s i1 i1)
796 | (let g (apply i* ((of common factor) n d))
797 | (list s (car:i/ n g) (car:i/ d g)))))
798 |
799 | (def factor (x (o d i2))
800 | (if (i< x d)
801 | nil
802 | (let (q r) (i/ x d)
803 | (if (= r i0)
804 | (cons d (factor q d))
805 | (factor x (i+ d i1))))))
806 |
807 | (def common (xs ys)
808 | (if (in nil xs ys)
809 | nil
810 | (let (a b) (split (is (car xs)) ys)
811 | (if b
812 | (cons (car xs)
813 | (common (cdr xs) (append a (cdr b))))
814 | (common (cdr xs) ys)))))
815 |
816 | (set buildnum (of litnum simplify))
817 |
818 | (def recip (x)
819 | (with (r (numr x)
820 | i (numi x))
821 | (let d (sr+ (sr* r r) (sr* i i))
822 | (buildnum (sr/ r d)
823 | (sr/ (srinv i) d)))))
824 |
825 | (def + ns
826 | (foldr (fn (x y)
827 | (apply buildnum ((of c+ cddr) x y)))
828 | 0
829 | ns))
830 |
831 | (def - ns
832 | (if (no ns) 0
833 | (no (cdr ns)) (inv (car ns))
834 | (+ (car ns) (inv (apply + (cdr ns))))))
835 |
836 | (def * ns
837 | (foldr (fn (x y)
838 | (apply buildnum ((of c* cddr) x y)))
839 | 1
840 | ns))
841 |
842 | (def / ns
843 | (if (no ns)
844 | 1
845 | (* (car ns) (recip (apply * (cdr ns))))))
846 |
847 | (def inc (n) (+ n 1))
848 |
849 | (def dec (n) (- n 1))
850 |
851 | (def pos (x ys (o f =))
852 | (if (no ys) nil
853 | (f (car ys) x) 1
854 | (aif (pos x (cdr ys) f) (+ it 1))))
855 |
856 | (def len (xs)
857 | (if (no xs) 0 (inc:len:cdr xs)))
858 |
859 | (def charn (c)
860 | (dec:pos c chars caris))
861 |
862 | (def < args
863 | (pairwise bin< args))
864 |
865 | (def > args
866 | (apply < (rev args)))
867 |
868 | (def list< (x y)
869 | (if (no x) y
870 | (no y) nil
871 | (or (< (car x) (car y))
872 | (and (= (car x) (car y))
873 | (< (cdr x) (cdr y))))))
874 |
875 | (def bin< args
876 | (aif (all no args) nil
877 | (find [all (car _) args] comfns) (apply (cdr it) args)
878 | (err 'incomparable)))
879 |
880 | (set comfns nil)
881 |
882 | (def com (f g)
883 | (set comfns (put f g comfns)))
884 |
885 | (com real (of sr< numr))
886 |
887 | (com char (of < charn))
888 |
889 | (com string list<)
890 |
891 | (com symbol (of list< nom))
892 |
893 | (def int (n)
894 | (and (real n) (= (srden:numr n) i1)))
895 |
896 | (def whole (n)
897 | (and (int n) (~< n 0)))
898 |
899 | (def pint (n)
900 | (and (int n) (> n 0)))
901 |
902 | (def yc (f)
903 | ([_ _] [f (fn a (apply (_ _) a))]))
904 |
905 | (mac rfn (name . rest)
906 | `(yc (fn (,name) (fn ,@rest))))
907 |
908 | (mac afn args
909 | `(rfn self ,@args))
910 |
911 | (def wait (f)
912 | ((afn (v) (if v v (self (f))))
913 | (f)))
914 |
915 | (def runs (f xs (o fon (and xs (f (car xs)))))
916 | (if (no xs)
917 | nil
918 | (let (as bs) (split (if fon ~f f) xs)
919 | (cons as (runs f bs (no fon))))))
920 |
921 | (def whitec (c)
922 | (in c \sp \lf \tab \cr))
923 |
924 | (def tokens (xs (o break whitec))
925 | (let f (if (function break) break (is break))
926 | (keep ~f:car (runs f xs))))
927 |
928 | (def dups (xs (o f =))
929 | (if (no xs) nil
930 | (mem (car xs) (cdr xs) f) (cons (car xs)
931 | (dups (rem (car xs) (cdr xs) f) f))
932 | (dups (cdr xs) f)))
933 |
934 | (set simple (cor atom number))
935 |
936 | (mac do1 args
937 | (letu v
938 | `(let ,v ,(car args)
939 | ,@(cdr args)
940 | ,v)))
941 |
942 | (def gets (v kvs (o f =))
943 | (find [f (cdr _) v] kvs))
944 |
945 | (def consif (x y)
946 | (if x (cons x y) y))
947 |
948 | (mac check (x f (o alt))
949 | (letu v
950 | `(let ,v ,x
951 | (if (,f ,v) ,v ,alt))))
952 |
953 | (mac withs (parms . body)
954 | (if (no parms)
955 | `(do ,@body)
956 | `(let ,(car parms) ,(cadr parms)
957 | (withs ,(cddr parms) ,@body))))
958 |
959 | (mac bind (var expr . body)
960 | `(dyn ,var ,expr (do ,@body)))
961 |
962 | (mac atomic body
963 | `(bind lock t ,@body))
964 |
965 | (def tail (f xs)
966 | (if (no xs) nil
967 | (f xs) xs
968 | (tail f (cdr xs))))
969 |
970 | (set dock rev:cdr:rev)
971 |
972 | (def lastcdr (xs)
973 | (if (no (cdr xs))
974 | xs
975 | (lastcdr (cdr xs))))
976 |
977 | (set last car:lastcdr)
978 |
979 | (def newq ()
980 | (list nil))
981 |
982 | (def enq (x q)
983 | (atomic (xar q (snoc (car q) x)))
984 | q)
985 |
986 | (def deq (q)
987 | (atomic (do1 (car (car q))
988 | (xar q (cdr (car q))))))
989 |
990 | (mac set args
991 | (cons 'do
992 | (map (fn ((p (o e t)))
993 | (letu v
994 | `(atomic (let ,v ,e
995 | (let (cell loc) (where ,p t)
996 | ((case loc a xar d xdr) cell ,v))))))
997 | (hug args))))
998 |
999 | (mac zap (op place . args)
1000 | (letu (vo vc vl va)
1001 | `(atomic (with (,vo ,op
1002 | (,vc ,vl) (where ,place)
1003 | ,va (list ,@args))
1004 | (case ,vl
1005 | a (xar ,vc (apply ,vo (car ,vc) ,va))
1006 | d (xdr ,vc (apply ,vo (cdr ,vc) ,va))
1007 | (err 'bad-place))))))
1008 |
1009 | (mac ++ (place (o n 1))
1010 | `(zap + ,place ,n))
1011 |
1012 | (mac -- (place (o n 1))
1013 | `(zap - ,place ,n))
1014 |
1015 | (mac push (x place)
1016 | (letu v
1017 | `(let ,v ,x
1018 | (zap [cons ,v _] ,place))))
1019 |
1020 | (mac pull (x place . rest)
1021 | (letu v
1022 | `(let ,v ,x
1023 | (zap [rem ,v _ ,@rest] ,place))))
1024 |
1025 | (set cbuf '((nil)))
1026 |
1027 | (def open args
1028 | (let s (apply ops args)
1029 | (push (list s) cbuf)
1030 | s))
1031 |
1032 | (def close (s)
1033 | (pull s cbuf caris)
1034 | (cls s))
1035 |
1036 | (def peek ((o s ins))
1037 | (if ((cor no stream) s)
1038 | (let c (wait (fn ()
1039 | (atomic (let p (get s cbuf)
1040 | (or (cdr p)
1041 | (aif (bitc s) (xdr p it) nil))))))
1042 | (if (= c 'eof) nil c))
1043 | (car (car s))))
1044 |
1045 | (def rdc ((o s ins))
1046 | (if ((cor no stream) s)
1047 | (let c (wait (fn ()
1048 | (atomic (let p (get s cbuf)
1049 | (aif (cdr p)
1050 | (do (xdr p nil) it)
1051 | (bitc s))))))
1052 | (if (= c 'eof) nil c))
1053 | (deq s)))
1054 |
1055 | (set bbuf nil)
1056 |
1057 | (def bitc ((o s ins))
1058 | (let bits (get s bbuf)
1059 | (aif (gets (rev (cdr bits)) chars)
1060 | (do (pull s bbuf caris)
1061 | (car it))
1062 | (let b (rdb s)
1063 | (if (in b nil 'eof)
1064 | b
1065 | (do (if bits
1066 | (push b (cdr bits))
1067 | (push (list s b) bbuf))
1068 | (bitc s)))))))
1069 |
1070 | (def digit (c (o base i10))
1071 | (mem c (udrop (udrop base i16) "fedcba9876543210")))
1072 |
1073 | (set breakc (cor no whitec (is \;) [get _ syntax]))
1074 |
1075 | (def signc (c)
1076 | (in c \+ \-))
1077 |
1078 | (def intrac (c)
1079 | (in c \. \!))
1080 |
1081 | (set source (cor no stream (cand pair string:car)))
1082 |
1083 | (def read ((o s|source ins) (o (t base [<= 2 _ 16]) 10) (o eof))
1084 | (car (rdex s (srnum:numr base) eof)))
1085 |
1086 | (def saferead ((o s ins) (o alt) (o base 10))
1087 | (onerr alt (read s base alt)))
1088 |
1089 | (def rdex ((o s ins) (o base i10) (o eof) (o share))
1090 | (eatwhite s)
1091 | (let c (rdc s)
1092 | (aif (no c) (list eof share)
1093 | (get c syntax) ((cdr it) s base share)
1094 | (list (rdword s c base) share))))
1095 |
1096 | (def eatwhite (s)
1097 | (pcase (peek s)
1098 | whitec (do (rdc s)
1099 | (eatwhite s))
1100 | (is \;) (do (charstil s (is \lf))
1101 | (eatwhite s))))
1102 |
1103 | (def charstil (s f)
1104 | (if ((cor no f) (peek s))
1105 | nil
1106 | (cons (rdc s) (charstil s f))))
1107 |
1108 | (set syntax nil)
1109 |
1110 | (mac syn (c . rest)
1111 | `(set syntax (put ,c (fn ,@rest) syntax)))
1112 |
1113 | (syn \( (s base share)
1114 | (rdlist s \) base share))
1115 |
1116 | (syn \) args
1117 | (err 'unexpected-terminator))
1118 |
1119 | (syn \[ (s base share)
1120 | (let (e newshare) (rdlist s \] base share)
1121 | (list (list 'fn '(_) e) newshare)))
1122 |
1123 | (syn \] args
1124 | (err 'unexpected-terminator))
1125 |
1126 | (def rdlist (s term base share (o acc))
1127 | (eatwhite s)
1128 | (pcase (peek s)
1129 | no (err 'unterminated-list)
1130 | (is \.) (do (rdc s) (rddot s term base share acc))
1131 | (is term) (do (rdc s) (list acc share))
1132 | (let (e newshare) (rdex s base nil share)
1133 | (rdlist s term base newshare (snoc acc e)))))
1134 |
1135 | (def rddot (s term base share acc)
1136 | (pcase (peek s)
1137 | no (err 'unterminated-list)
1138 | breakc (if (no acc)
1139 | (err 'missing-car)
1140 | (let (e newshare) (hard-rdex s base share 'missing-cdr)
1141 | (if (car (rdlist s term base share))
1142 | (err 'duplicate-cdr)
1143 | (list (apply cons (snoc acc e))
1144 | newshare))))
1145 | (rdlist s term base share (snoc acc (rdword s \. base)))))
1146 |
1147 | (def hard-rdex (s base share msg)
1148 | (let eof (join)
1149 | (let v (rdex s base eof share)
1150 | (if (id (car v) eof) (err msg) v))))
1151 |
1152 | (set namecs '((bel . \bel) (tab . \tab) (lf . \lf) (cr . \cr) (sp . \sp)))
1153 |
1154 | (syn \\ (s base share)
1155 | (list (pcase (peek s)
1156 | no (err 'escape-without-char)
1157 | breakc (rdc s)
1158 | (let cs (charstil s breakc)
1159 | (if (cdr cs)
1160 | (aif (get (sym cs) namecs)
1161 | (cdr it)
1162 | (err 'unknown-named-char))
1163 | (car cs))))
1164 | share))
1165 |
1166 | (syn \' (s base share)
1167 | (rdwrap s 'quote base share))
1168 |
1169 | (syn \` (s base share)
1170 | (rdwrap s 'bquote base share))
1171 |
1172 | (syn \, (s base share)
1173 | (case (peek s)
1174 | \@ (do (rdc s)
1175 | (rdwrap s 'comma-at base share))
1176 | (rdwrap s 'comma base share)))
1177 |
1178 | (def rdwrap (s token base share)
1179 | (let (e newshare) (hard-rdex s base share 'missing-expression)
1180 | (list (list token e) newshare)))
1181 |
1182 | (syn \" (s base share)
1183 | (list (rddelim s \") share))
1184 |
1185 | (syn \¦ (s base share)
1186 | (list (sym (rddelim s \¦)) share))
1187 |
1188 | (def rddelim (s d (o esc))
1189 | (let c (rdc s)
1190 | (if (no c) (err 'missing-delimiter)
1191 | esc (cons c (rddelim s d))
1192 | (= c \\) (rddelim s d t)
1193 | (= c d) nil
1194 | (cons c (rddelim s d)))))
1195 |
1196 | (syn \# (s base share)
1197 | (let name (charstil s ~digit)
1198 | (if (= (peek s) \=)
1199 | (do (rdc s)
1200 | (rdtarget s base name (join) share))
1201 | (aif (get name share)
1202 | (list (cdr it) share)
1203 | (err 'unknown-label)))))
1204 |
1205 | (def rdtarget (s base name cell oldshare)
1206 | (withs (share (cons (cons name cell) oldshare)
1207 | (e newshare) (hard-rdex s base share 'missing-target))
1208 | (if (simple e)
1209 | (err 'bad-target)
1210 | (do (xar cell (car e))
1211 | (xdr cell (cdr e))
1212 | (list cell newshare)))))
1213 |
1214 | (def rdword (s c base)
1215 | (parseword (cons c (charstil s breakc)) base))
1216 |
1217 | (def parseword (cs base)
1218 | (or (parsenum cs base)
1219 | (if (= cs ".") (err 'unexpected-dot)
1220 | (mem \| cs) (parset cs base)
1221 | (some intrac cs) (parseslist (runs intrac cs) base)
1222 | (parsecom cs base))))
1223 |
1224 | (def parsenum (cs base)
1225 | (if (validi cs base)
1226 | (buildnum srzero (parsei cs base))
1227 | (let sign (check (car cs) signc)
1228 | (let (ds es) (split signc (if sign (cdr cs) cs))
1229 | (and (validr ds base)
1230 | (or (no es) (validi es base))
1231 | (buildnum (parsesr (consif sign ds) base)
1232 | (if (no es) srzero (parsei es base))))))))
1233 |
1234 | (def validi (cs base)
1235 | (and (signc (car cs))
1236 | (= (last cs) \i)
1237 | (let digs (cdr (dock cs))
1238 | (or (no digs) (validr digs base)))))
1239 |
1240 | (def validr (cs base)
1241 | (or (validd cs base)
1242 | (let (n d) (split (is \/) cs)
1243 | (and (validd n base)
1244 | (validd (cdr d) base)))))
1245 |
1246 | (def validd (cs base)
1247 | (and (all (cor [digit _ base] (is \.)) cs)
1248 | (some [digit _ base] cs)
1249 | (~cdr (keep (is \.) cs))))
1250 |
1251 | (def parsei (cs base)
1252 | (if (cddr cs)
1253 | (parsesr (dock cs) base)
1254 | (if (caris cs \+)
1255 | srone
1256 | (srinv srone))))
1257 |
1258 | (def parsesr (cs base)
1259 | (withs (sign (if (signc (car cs)) (sym (list (car cs))))
1260 | (n d) (split (is \/) (if sign (cdr cs) cs)))
1261 | (simplify (cons (or sign '+)
1262 | (r/ (parsed n base)
1263 | (if d
1264 | (let rd (parsed (cdr d) base)
1265 | (if (caris rd i0)
1266 | (err 'zero-denominator)
1267 | rd))
1268 | (list i1 i1)))))))
1269 |
1270 | (def parsed (cs base)
1271 | (let (i f) (split (is \.) cs)
1272 | (if (cdr f)
1273 | (list (parseint (rev (append i (cdr f))) base)
1274 | (i^ base
1275 | (apply i+ (map (con i1) (cdr f)))))
1276 | (list (parseint (rev i) base) i1))))
1277 |
1278 | (def parseint (ds base)
1279 | (if ds
1280 | (i+ (charint (car ds))
1281 | (i* base (parseint (cdr ds) base)))
1282 | i0))
1283 |
1284 | (def charint (c)
1285 | (map (con t) (mem c "fedcba987654321")))
1286 |
1287 | (def parset (cs base)
1288 | (if (cdr (keep (is \|) cs))
1289 | (err 'multiple-bars)
1290 | (let vt (tokens cs \|)
1291 | (if (= (len vt) 2)
1292 | (cons t (map [parseword _ base] vt))
1293 | (err 'bad-tspec)))))
1294 |
1295 | (def parseslist (rs base)
1296 | (if (intrac (car (last rs)))
1297 | (err 'final-intrasymbol)
1298 | (map (fn ((cs ds))
1299 | (if (cdr cs) (err 'double-intrasymbol)
1300 | (caris cs \!) (list 'quote (parsecom ds base))
1301 | (parsecom ds base)))
1302 | (hug (if (intrac (car (car rs)))
1303 | (cons "." "upon" rs)
1304 | (cons "." rs))))))
1305 |
1306 | (def parsecom (cs base)
1307 | (if (mem \: cs)
1308 | (cons 'compose (map [parseno _ base] (tokens cs \:)))
1309 | (parseno cs base)))
1310 |
1311 | (def parseno (cs base)
1312 | (if (caris cs \~)
1313 | (if (cdr cs)
1314 | (list 'compose 'no (parseno (cdr cs) base))
1315 | 'no)
1316 | (or (parsenum cs base) (sym cs))))
1317 |
1318 | (mac bquote (e)
1319 | (let (sub change) (bqex e nil)
1320 | (if change sub (list 'quote e))))
1321 |
1322 | (def bqex (e n)
1323 | (if (no e) (list nil nil)
1324 | (atom e) (list (list 'quote e) nil)
1325 | (case (car e)
1326 | bquote (bqthru e (list n) 'bquote)
1327 | comma (if (no n)
1328 | (list (cadr e) t)
1329 | (bqthru e (car n) 'comma))
1330 | comma-at (if (no n)
1331 | (list (list 'splice (cadr e)) t)
1332 | (bqthru e (car n) 'comma-at))
1333 | (bqexpair e n))))
1334 |
1335 | (def bqthru (e n op)
1336 | (let (sub change) (bqex (cadr e) n)
1337 | (if change
1338 | (list (if (caris sub 'splice)
1339 | `(cons ',op ,(cadr sub))
1340 | `(list ',op ,sub))
1341 | t)
1342 | (list (list 'quote e) nil))))
1343 |
1344 | (def bqexpair (e n)
1345 | (with ((a achange) (bqex (car e) n)
1346 | (d dchange) (bqex (cdr e) n))
1347 | (if (or achange dchange)
1348 | (list (if (caris d 'splice)
1349 | (if (caris a 'splice)
1350 | `(apply append (spa ,(cadr a)) (spd ,(cadr d)))
1351 | `(apply cons ,a (spd ,(cadr d))))
1352 | (caris a 'splice)
1353 | `(append (spa ,(cadr a)) ,d)
1354 | `(cons ,a ,d))
1355 | t)
1356 | (list (list 'quote e) nil))))
1357 |
1358 | (def spa (x)
1359 | (if (and x (atom x))
1360 | (err 'splice-atom)
1361 | x))
1362 |
1363 | (def spd (x)
1364 | (pcase x
1365 | no (err 'splice-empty-cdr)
1366 | atom (err 'splice-atom)
1367 | cdr (err 'splice-multiple-cdrs)
1368 | x))
1369 |
1370 | (mac comma args
1371 | '(err 'comma-outside-backquote))
1372 |
1373 | (mac comma-at args
1374 | '(err 'comma-at-outside-backquote))
1375 |
1376 | (mac splice args
1377 | '(err 'comma-at-outside-list))
1378 |
1379 | (def print (x (o s outs) (o names (namedups x)) (o hist))
1380 | (aif (simple x) (do (prsimple x s) hist)
1381 | (ustring x names) (prstring x s names hist)
1382 | (get x names id) (do (prc \# s)
1383 | (print (cdr it) s)
1384 | (if (mem x hist id)
1385 | hist
1386 | (do (prc \= s)
1387 | (if (ustring (cdr x) names)
1388 | (prstring x s names (cons x hist))
1389 | (prpair x s names (cons x hist))))))
1390 | (prpair x s names hist)))
1391 |
1392 | (def namedups (x (o n 0))
1393 | (map [cons _ (++ n)] (dups (cells x) id)))
1394 |
1395 | (def cells (x (o seen))
1396 | (if (simple x) seen
1397 | (mem x seen id) (snoc seen x)
1398 | (cells (cdr x)
1399 | (cells (car x) (snoc seen x)))))
1400 |
1401 | (def prc (c (o s outs))
1402 | (if (atom s)
1403 | (aif (get c chars)
1404 | (map [wrb _ s] (cdr it))
1405 | (err 'unknown char))
1406 | (enq c s))
1407 | c)
1408 |
1409 | (def ustring (x names)
1410 | (and x (string x) (~tail [get _ names id] x)))
1411 |
1412 | (def prstring (x s names hist)
1413 | (prc \" s)
1414 | (presc x \" s)
1415 | (prc \" s)
1416 | hist)
1417 |
1418 | (def presc (cs esc s)
1419 | (map (fn (c)
1420 | (if (in c esc \\) (prc \\ s))
1421 | (prc c s))
1422 | cs))
1423 |
1424 | (def prsimple (x s)
1425 | (pcase x
1426 | symbol (prsymbol x s)
1427 | char (do (prc \\ s) (prc x s))
1428 | stream (map [prc _ s] "")
1429 | number (prnum (numr x) (numi x) s)
1430 | (err 'cannot-print)))
1431 |
1432 | (def prsymbol (x s)
1433 | (let cs (nom x)
1434 | (let odd (~= (saferead (list cs)) x)
1435 | (if odd (prc \¦ s))
1436 | (presc cs \¦ s)
1437 | (if odd (prc \¦ s)))))
1438 |
1439 | (def prnum (r i s)
1440 | (unless (and (= r srzero) (~= i srzero))
1441 | (if (caris r '-) (prc \- s))
1442 | (map [prc _ s] (rrep (cdr r))))
1443 | (unless (= i srzero)
1444 | (print (car i) s)
1445 | (unless (apply = (cdr i))
1446 | (map [prc _ s] (rrep (cdr i))))
1447 | (prc \i s)))
1448 |
1449 | (def rrep ((n d) (o base i10))
1450 | (append (irep n base)
1451 | (if (= d i1) nil (cons \/ (irep d base)))))
1452 |
1453 | (def irep (x base)
1454 | (if (i< x base)
1455 | (list (intchar x))
1456 | (let (q r) (i/ x base)
1457 | (snoc (irep q base) (intchar r)))))
1458 |
1459 | (def intchar (x)
1460 | (car (udrop x "0123456789abcdef")))
1461 |
1462 | (def prpair (x s names hist)
1463 | (prc \( s)
1464 | (do1 (prelts x s names hist)
1465 | (prc \) s)))
1466 |
1467 | (def prelts ((x . rest) s names hist)
1468 | (let newhist (print x s names hist)
1469 | (if (or (and rest (simple rest))
1470 | (ustring rest names)
1471 | (get rest names id))
1472 | (do (map [prc _ s] " . ")
1473 | (print rest s names newhist))
1474 | (if rest
1475 | (do (prc \sp s)
1476 | (prelts rest s names newhist))
1477 | newhist))))
1478 |
1479 | (def prn args
1480 | (map [do (print _) (prc \sp)] args)
1481 | (prc \lf)
1482 | (last args))
1483 |
1484 | (def pr args
1485 | (map prnice args))
1486 |
1487 | (def prnice (x (o s outs))
1488 | (pcase x
1489 | char (prc x s)
1490 | string (map [prc _ s] x)
1491 | (print x s nil))
1492 | x)
1493 |
1494 | (def drop (n|whole xs)
1495 | (if (= n 0)
1496 | xs
1497 | (drop (- n 1) (cdr xs))))
1498 |
1499 | (def nth (n|pint xs|pair)
1500 | (if (= n 1)
1501 | (car xs)
1502 | (nth (- n 1) (cdr xs))))
1503 |
1504 | (vir num (f args)
1505 | `(nth ,f ,@args))
1506 |
1507 | (def nchar (n)
1508 | (car ((+ n 1) chars)))
1509 |
1510 | (def first (n|whole xs)
1511 | (if (or (= n 0) (no xs))
1512 | nil
1513 | (cons (car xs)
1514 | (first (- n 1) (cdr xs)))))
1515 |
1516 | (mac catch body
1517 | (letu v
1518 | `(ccc (fn (,v) (bind throw ,v ,@body)))))
1519 |
1520 | (def cut (xs (o start 1) (o end (len xs)))
1521 | (first (- (+ end 1 (if (< end 0) (len xs) 0))
1522 | start)
1523 | (drop (- start 1) xs)))
1524 |
1525 | (mac whenlet (var expr . body)
1526 | `(iflet ,var ,expr (do ,@body)))
1527 |
1528 | (mac awhen args
1529 | `(whenlet it ,@args))
1530 |
1531 | (mac each (var expr . body)
1532 | `(map (fn (,var) ,@body) ,expr))
1533 |
1534 | (def flip (f)
1535 | (fn args (apply f (rev args))))
1536 |
1537 | (def part (f . args)
1538 | (fn rest
1539 | (apply f (append args rest))))
1540 |
1541 | (def trap (f . args)
1542 | (flip (apply part (flip f) (rev args))))
1543 |
1544 | (def only (f)
1545 | (fn args
1546 | (if (car args) (apply f args))))
1547 |
1548 | (def >= args
1549 | (pairwise ~bin< args))
1550 |
1551 | (def <= args
1552 | (apply >= (rev args)))
1553 |
1554 | (def floor (x|real)
1555 | (let (s n d) (numr x)
1556 | (let (f m) (i/ n d)
1557 | (litnum (list s
1558 | (i+ f (if (or (= s '+) (= m i0))
1559 | i0
1560 | i1))
1561 | i1)))))
1562 |
1563 | (set ceil -:floor:-)
1564 |
1565 | (def mod (x y)
1566 | (* (- (/ x y) (floor (/ x y)))
1567 | y))
1568 |
1569 | (mac whilet (var expr . body)
1570 | (letu (vf vp)
1571 | `((rfn ,vf (,vp)
1572 | (whenlet ,var ,vp ,@body (,vf ,expr)))
1573 | ,expr)))
1574 |
1575 | (mac loop (var init update test . body)
1576 | (letu v
1577 | `((rfn ,v (,var)
1578 | (when ,test ,@body (,v ,update)))
1579 | ,init)))
1580 |
1581 | (mac while (expr . body)
1582 | (letu v
1583 | `(loop ,v ,expr ,expr ,v ,@body)))
1584 |
1585 | (mac til (var expr test . body)
1586 | `(loop ,var ,expr ,expr (no ,test)
1587 | ,@body))
1588 |
1589 | (mac for (var init max . body)
1590 | (letu (vi vm)
1591 | `(with (,vi ,init
1592 | ,vm ,max)
1593 | (loop ,var ,vi (+ ,var 1) (<= ,var ,vm)
1594 | ,@body))))
1595 |
1596 | (mac repeat (n . body)
1597 | `(for ,(uvar) 1 ,n ,@body))
1598 |
1599 | (mac poll (expr f)
1600 | (letu (vr ve vf)
1601 | `((rfn ,vr (,ve ,vf)
1602 | (if (,vf ,ve) ,ve (,vr ,expr ,vf)))
1603 | ,expr
1604 | ,f)))
1605 |
1606 | (mac accum (var . body)
1607 | (letu v
1608 | `(withs (,v nil
1609 | ,var [push _ ,v])
1610 | ,@body
1611 | (rev ,v))))
1612 |
1613 | (mac nof (n expr)
1614 | (letu v
1615 | `(accum ,v (repeat ,n (,v ,expr)))))
1616 |
1617 | (mac drain (expr (o f 'no))
1618 | (letu v
1619 | `(accum ,v
1620 | (poll ,expr (cor ,f (compose no ,v))))))
1621 |
1622 | (def ^w (x y|whole)
1623 | (apply * (nof y x)))
1624 |
1625 | (def clog2 (n)
1626 | (if (<= n 2) 1 (inc:clog2 (/ n 2))))
1627 |
1628 | (def randlen (n)
1629 | (read (list (nof n (if (coin) \0 \1)))
1630 | 2))
1631 |
1632 | (def rand (n|pint)
1633 | (poll (randlen (clog2 n)) [< _ n]))
1634 |
1635 | (mac wipe args
1636 | `(set ,@(fuse [list _ nil] args)))
1637 |
1638 | (mac pop (place)
1639 | `(let (cell loc) (where ,place)
1640 | (let xs ((case loc a car d cdr) cell)
1641 | ((case loc a xar d xdr) cell (cdr xs))
1642 | (car xs))))
1643 |
1644 | (mac clean (f place)
1645 | (letu v
1646 | `(let ,v (compose no ,f)
1647 | (zap [keep ,v _] ,place))))
1648 |
1649 | (mac swap places
1650 | (let vs (map [nof 3 (uvar)] places)
1651 | `(atomic (withs ,(fuse (fn (place (cell loc val))
1652 | (list (list cell loc)
1653 | `(where ,place)
1654 | val
1655 | `((case ,loc a car d cdr) ,cell)))
1656 | places
1657 | vs)
1658 | ,@(map (fn ((cellx locx valx) (celly locy valy))
1659 | `((case ,locx a xar d xdr) ,cellx ,valy))
1660 | vs
1661 | (snoc (cdr vs) (car vs)))))))
1662 |
1663 | (def adjoin (x ys (o f =))
1664 | (if (mem x ys f) ys (cons x ys)))
1665 |
1666 | (mac pushnew (x place (o f '=))
1667 | (letu v
1668 | `(let ,v ,x
1669 | (zap [adjoin ,v _ ,f] ,place))))
1670 |
1671 | (def dedup (xs (o f =))
1672 | (rev (foldl (trap adjoin f) nil xs)))
1673 |
1674 | (def insert (f x ys)
1675 | (if (no ys) (list x)
1676 | (f x (car ys)) (cons x ys)
1677 | (cons (car ys) (insert f x (cdr ys)))))
1678 |
1679 | (def sort (f xs)
1680 | (foldr (part insert f) nil (rev xs)))
1681 |
1682 | (set best car:sort)
1683 |
1684 | (def max args
1685 | (best > args))
1686 |
1687 | (def min args
1688 | (best < args))
1689 |
1690 | (def even (n)
1691 | (int (/ n 2)))
1692 |
1693 | (set odd (cand int ~even))
1694 |
1695 | (def round (n)
1696 | (let r (fn (n)
1697 | (withs (f (floor n)
1698 | d (- n f))
1699 | (if (or (> d 1/2) (and (= d 1/2) (odd f)))
1700 | (ceil n)
1701 | f)))
1702 | (if (< n 0) (-:r:- n) (r n))))
1703 |
1704 | (mac withfile (var name dir . body)
1705 | `(let ,var (open ,name ,dir)
1706 | (after (do ,@body) (close ,var))))
1707 |
1708 | (mac from (name . body)
1709 | (letu v
1710 | `(withfile ,v ,name 'in
1711 | (bind ins ,v ,@body))))
1712 |
1713 | (mac to (name . body)
1714 | (letu v
1715 | `(withfile ,v ,name 'out
1716 | (bind outs ,v ,@body))))
1717 |
1718 | (def readall ((o s ins) (o base 10))
1719 | (let eof (join)
1720 | (drain (read s base eof) [id _ eof])))
1721 |
1722 | (def load (name)
1723 | (let eof (join)
1724 | (withfile s name 'in
1725 | (til e (read s 10 eof) (id e eof)
1726 | (bel e)))))
1727 |
1728 | (mac record body
1729 | (letu v
1730 | `(let ,v (newq)
1731 | (bind outs ,v ,@body)
1732 | (car ,v))))
1733 |
1734 | (def prs args
1735 | (record (apply pr args)))
1736 |
1737 | (def array (dims (o default))
1738 | (if (no dims)
1739 | default
1740 | `(lit arr ,@(nof (car dims)
1741 | (array (cdr dims) default)))))
1742 |
1743 | (vir arr (f args)
1744 | `(aref ,f ,@args))
1745 |
1746 | (def aref (a|isa!arr n . ns)
1747 | (if (no ns)
1748 | (n (cddr a))
1749 | (apply aref (n (cddr a)) ns)))
1750 |
1751 | (def table ((o kvs))
1752 | `(lit tab ,@kvs))
1753 |
1754 | (vir tab (f args)
1755 | `(tabref ,f ,@args))
1756 |
1757 | (def tabref (tab key (o default))
1758 | (aif (get key (cddr tab))
1759 | (cdr it)
1760 | default))
1761 |
1762 | (loc isa!tab (f args a s r m)
1763 | (let e `(list (tabloc ,f ,@(map [list 'quote _] args)) 'd)
1764 | (mev (cons (list e a) (cdr s)) r m)))
1765 |
1766 | (def tabloc (tab key)
1767 | (or (get key (cddr tab))
1768 | (let kv (cons key nil)
1769 | (push kv (cddr tab))
1770 | kv)))
1771 |
1772 | (def tabrem (tab key (o f =))
1773 | (clean [caris _ key f] (cddr tab)))
1774 |
1775 | (set templates (table))
1776 |
1777 | (mac tem (name . fields)
1778 | `(set (templates ',name)
1779 | (list ,@(map (fn ((k v)) `(cons ',k (fn () ,v)))
1780 | (hug fields)))))
1781 |
1782 | (mac make (name . args)
1783 | `(inst ',name
1784 | (list ,@(map (fn ((k v)) `(cons ',k ,v))
1785 | (hug args)))))
1786 |
1787 | (def inst (name kvs)
1788 | (aif templates.name
1789 | (table (map (fn ((k . f))
1790 | (cons k
1791 | (aif (get k kvs) (cdr it) (f))))
1792 | it))
1793 | (err 'no-template)))
1794 |
1795 | (def readas (name (o s ins))
1796 | (withs (eof (join)
1797 | v (read s 10 eof))
1798 | (if (id v eof) nil
1799 | (isa!tab v) (inst name (cddr v))
1800 | (err 'inst-nontable))))
1801 |
--------------------------------------------------------------------------------
/resources/bel.ebnf:
--------------------------------------------------------------------------------
1 | sexp = string | list | abbrev_fn | quote | backquote | comma | splice | char | symbol | dot | number | comp_sym
2 | list = lparen sexp? ( sexp)* rparen
3 | abbrev_fn = <'['> sexp? ( sexp)* <']'>
4 | comp_sym = symbol (comp_id* symbol)* | (comp_id* symbol) (comp_id* symbol)*
5 | comp_id = (':' | '!' | '.' | '~' | ':' | '|')
6 | = <'('>
7 | = <')'>
8 | string = <'"'> any_char* <'"'>
9 | char = <'\\'> name
10 | symbol = name
11 | dot = #'\.'
12 | quote = <'\''> sexp
13 | backquote = <'`'> sexp
14 | comma = <','> sexp
15 | splice = <',@'> sexp
16 | name = #'[a-zA-Z\-*+_=>\/<\^][a-zA-Z0-9\-*+_=>\/<\^\?]*'
17 | number = #'[+-]?[0-9][0-9]*[.]?[0-9]*'
18 | any_char = #'.' | space
19 | space = #'\s'
20 | whitespace = #'\s+'
21 |
--------------------------------------------------------------------------------
/resources/core.bel:
--------------------------------------------------------------------------------
1 | ; Bel in Bel. 9 October 2019, 9:14 GMT
2 |
3 | ; stopa-edit
4 | ; Writing a poor man's def, to let PG's code run,
5 | ; before he defines it
6 |
7 | (set
8 | def
9 | (lit
10 | mac
11 | (lit
12 | clo nil (n p e)
13 | (join 'set
14 | (join
15 | n
16 | (join
17 | (join
18 | 'lit (join 'clo (join nil (join p (join e nil)))))
19 | nil))))))
20 |
21 | ; /stopa-edit
22 |
23 | (def no (x)
24 | (id x nil))
25 |
26 | ; stopa-edit
27 | ; string is a separate type in this implementation
28 |
29 | (def atom (x)
30 | (if (no (id (type x) 'pair))
31 | (if (no (id (type x) 'string)) t)))
32 |
33 | ; /stopa-edit
34 |
35 | (def all (f xs)
36 | (if (no xs) t
37 | (f (car xs)) (all f (cdr xs))
38 | nil))
39 |
40 | (def some (f xs)
41 | (if (no xs) nil
42 | (f (car xs)) xs
43 | (some f (cdr xs))))
44 |
45 | (def reduce (f xs)
46 | (if (no (cdr xs))
47 | (car xs)
48 | (f (car xs) (reduce f (cdr xs)))))
49 |
50 | (def cons args
51 | (reduce join args))
52 |
53 | (def append args
54 | (if (no (cdr args)) (car args)
55 | (no (car args)) (apply append (cdr args))
56 | (cons (car (car args))
57 | (apply append (cdr (car args))
58 | (cdr args)))))
59 |
60 |
61 |
62 | (def snoc args
63 | (append (car args) (cdr args)))
64 |
65 | (def list args
66 | (append args nil))
67 |
68 | (def map (f . ls)
69 | (if (no ls) nil
70 | (some no ls) nil
71 | (no (cdr ls)) (cons (f (car (car ls)))
72 | (map f (cdr (car ls))))
73 | (cons (apply f (map car ls))
74 | (apply map f (map cdr ls)))))
75 |
76 | ; stopa-edit
77 | ; poor man's mac, to support mac until PG defines it
78 |
79 | (set
80 | mac
81 | (lit
82 | mac
83 | (lit
84 | clo nil (n p e)
85 | (join 'set
86 | (join
87 | n
88 | (join
89 | (join
90 | 'lit
91 | (join
92 | 'mac
93 | (join
94 | (join
95 | 'lit (join 'clo (join nil (join p (join e nil)))))
96 | nil)))
97 | nil))))))
98 |
99 | ; /stopa-edit
100 |
101 | (mac fn (parms . body)
102 | (if (no (cdr body))
103 | `(list 'lit 'clo scope ',parms ',(car body))
104 | `(list 'lit 'clo scope ',parms '(do ,@body))))
105 |
106 | (mac do args
107 | (reduce (fn (x y)
108 | (list (list 'fn (uvar) y) x))
109 | args))
110 |
111 | (mac let (parms val . body)
112 | `((fn (,parms) ,@body) ,val))
113 |
114 | (mac macro args
115 | `(list 'lit 'mac (fn ,@args)))
116 |
117 | (mac def (n . rest)
118 | `(set ,n (fn ,@rest)))
119 |
120 | (mac mac (n . rest)
121 | `(set ,n (macro ,@rest)))
122 |
123 | (mac or args
124 | (if (no args)
125 | nil
126 | (let v (uvar)
127 | `(let ,v ,(car args)
128 | (if ,v ,v (or ,@(cdr args)))))))
129 |
130 | (mac and args
131 | (reduce (fn es (cons 'if es))
132 | (or args '(t))))
133 |
134 | (def = args
135 | (if (no (cdr args)) t
136 | (some atom args) (all [id _ (car args)] (cdr args))
137 | (and (apply = (map car args))
138 | (apply = (map cdr args)))))
139 |
140 | ; stopa-edit
141 | ; Added number + string as primitive types. Letting
142 | ; these seep in from Clojure
143 |
144 | (def symbol (x) (= (type x) 'symbol))
145 |
146 | (def pair (x) (= (type x) 'pair))
147 |
148 | (def char (x) (= (type x) 'char))
149 |
150 | (def number (x) (= (type x) 'number))
151 |
152 | (def string (x) (= (type x) 'string))
153 |
154 | ; /stopa-edit
155 |
156 | (def proper (x)
157 | (or (no x)
158 | (and (pair x) (proper (cdr x)))))
159 |
160 | (def mem (x ys (o f =))
161 | (some [f _ x] ys))
162 |
163 | (def in (x . ys)
164 | (mem x ys))
165 |
166 | (def cadr (x) (car (cdr x)))
167 |
168 | (def cddr (x) (cdr (cdr x)))
169 |
170 | (def caddr (x) (car (cddr x)))
171 |
172 | (mac case (expr . args)
173 | (if (no (cdr args))
174 | (car args)
175 | (let v (uvar)
176 | `(let ,v ,expr
177 | (if (= ,v ',(car args))
178 | ,(cadr args)
179 | (case ,v ,@(cddr args)))))))
180 |
181 | (mac iflet (var . args)
182 | (if (no (cdr args))
183 | (car args)
184 | (let v (uvar)
185 | `(let ,v ,(car args)
186 | (if ,v
187 | (let ,var ,v ,(cadr args))
188 | (iflet ,var ,@(cddr args)))))))
189 |
190 | (mac aif args
191 | `(iflet it ,@args))
192 |
193 | (def find (f xs)
194 | (aif (some f xs) (car it)))
195 |
196 | (def begins (xs pat (o f =))
197 | (if (no pat) t
198 | (atom xs) nil
199 | (f (car xs) (car pat)) (begins (cdr xs) (cdr pat) f)
200 | nil))
201 |
202 | (def caris (x y (o f =))
203 | (begins x (list y) f))
204 |
205 | (def hug (xs (o f list))
206 | (if (no xs) nil
207 | (no (cdr xs)) (list (f (car xs)))
208 | (cons (f (car xs) (cadr xs))
209 | (hug (cddr xs) f))))
210 |
211 | (mac with (parms . body)
212 | (let ps (hug parms)
213 | `((fn ,(map car ps) ,@body)
214 | ,@(map cadr ps))))
215 |
216 | (def keep (f xs)
217 | (if (no xs) nil
218 | (f (car xs)) (cons (car xs) (keep f (cdr xs)))
219 | (keep f (cdr xs))))
220 |
221 | (def rem (x ys (o f =))
222 | (keep [no (f _ x)] ys))
223 |
224 | (def get (k kvs (o f =))
225 | (find [f (car _) k] kvs))
226 |
227 | (def put (k v kvs (o f =))
228 | (cons (cons k v)
229 | (rem k kvs (fn (x y) (f (car x) y)))))
230 |
231 | (def rev (xs)
232 | (if (no xs)
233 | nil
234 | (snoc (rev (cdr xs)) (car xs))))
235 |
236 | (def snap (xs ys (o acc))
237 | (if (no xs)
238 | (list acc ys)
239 | (snap (cdr xs) (cdr ys) (snoc acc (car ys)))))
240 |
241 | (def udrop (xs ys)
242 | (cadr (snap xs ys)))
243 |
244 | (def idfn (x)
245 | x)
246 |
247 | (def is (x)
248 | [= _ x])
249 |
250 | (mac eif (var (o expr) (o fail) (o ok))
251 | (with (v (uvar)
252 | w (uvar)
253 | c (uvar))
254 | `(let ,v (join)
255 | (let ,w (ccc (fn (,c)
256 | (dyn err [,c (cons ,v _)] ,expr)))
257 | (if (caris ,w ,v id)
258 | (let ,var (cdr ,w) ,fail)
259 | (let ,var ,w ,ok))))))
260 |
261 |
262 | (mac onerr (e1 e2)
263 | (let v (uvar)
264 | `(eif ,v ,e2 ,e1 ,v)))
265 |
266 | (mac safe (expr)
267 | `(onerr nil ,expr))
268 |
269 | (def literal (e)
270 | (or (in e t nil o apply)
271 | (in (type e) 'char 'stream)
272 | (caris e 'lit)
273 | (string e)))
274 |
275 | (def variable (e)
276 | (and (atom e) (no (literal e))))
277 |
278 | (def isa (name)
279 | [begins _ `(lit ,name) id])
280 |
281 | (def function (x)
282 | (find [(isa _) x] '(prim clo)))
283 |
284 | (def con (x)
285 | (fn args x))
286 |
287 | (def compose fs
288 | (reduce (fn (f g)
289 | (fn args (f (apply g args))))
290 | (or fs (list idfn))))
291 |
292 | (def combine (op)
293 | (fn fs
294 | (reduce (fn (f g)
295 | (fn args
296 | (op (apply f args) (apply g args))))
297 | (or fs (list (con (op)))))))
298 |
299 | (set cand (combine and)
300 | cor (combine or))
301 |
302 | (def foldl (f base . args)
303 | (if (or (no args) (some no args))
304 | base
305 | (apply foldl f
306 | (apply f (snoc (map car args) base))
307 | (map cdr args))))
308 |
309 | (def foldr (f base . args)
310 | (if (or (no args) (some no args))
311 | base
312 | (apply f (snoc (map car args)
313 | (apply foldr f base (map cdr args))))))
314 |
315 | (def of (f g)
316 | (fn args (apply f (map g args))))
317 |
318 | (def upon args
319 | [apply _ args])
320 |
321 | (def pairwise (f xs)
322 | (or (no (cdr xs))
323 | (and (f (car xs) (cadr xs))
324 | (pairwise f (cdr xs)))))
325 |
326 | (def fuse (f . args)
327 | (apply append (apply map f args)))
328 |
329 | (mac letu (v . body)
330 | (if ((cor variable atom) v)
331 | `(let ,v (uvar) ,@body)
332 | `(with ,(fuse [list _ '(uvar)] v)
333 | ,@body)))
334 |
335 | (mac pcase (expr . args)
336 | (if (no (cdr args))
337 | (car args)
338 | (letu v
339 | `(let ,v ,expr
340 | (if (,(car args) ,v)
341 | ,(cadr args)
342 | (pcase ,v ,@(cddr args)))))))
343 |
344 | (def match (x pat)
345 | (if (= pat t) t
346 | (function pat) (pat x)
347 | (or (atom x) (atom pat)) (= x pat)
348 | (and (match (car x) (car pat))
349 | (match (cdr x) (cdr pat)))))
350 |
351 | (def split (f xs (o acc))
352 | (if ((cor atom f:car) xs)
353 | (list acc xs)
354 | (split f (cdr xs) (snoc acc (car xs)))))
355 |
356 | (mac when (expr . body)
357 | `(if ,expr (do ,@body)))
358 |
359 | (mac unless (expr . body)
360 | `(when (no ,expr) ,@body))
361 |
362 | (def inc (n) (+ n 1))
363 |
364 | (def dec (n) (- n 1))
365 |
366 | (def pos (x ys (o f =))
367 | (if (no ys) nil
368 | (f (car ys) x) 1
369 | (aif (pos x (cdr ys) f) (+ it 1))))
370 |
371 | (def len (xs)
372 | (if (no xs) 0 (inc:len:cdr xs)))
373 |
374 | ; stopa-edit
375 |
376 | (def charn (c)
377 | (hash c))
378 |
379 | ; stopa-edit
380 |
381 | (def < args
382 | (pairwise bin< args))
383 |
384 | (def > args
385 | (apply < (rev args)))
386 |
387 | (def list< (x y)
388 | (if (no x) y
389 | (no y) nil
390 | (or (< (car x) (car y))
391 | (and (= (car x) (car y))
392 | (< (cdr x) (cdr y))))))
393 |
394 | (def pint (n)
395 | (and (int n) (> n 0)))
396 |
397 | (def yc (f)
398 | ([_ _] [f (fn a (apply (_ _) a))]))
399 |
400 | (mac rfn (name . rest)
401 | `(yc (fn (,name) (fn ,@rest))))
402 |
403 | (mac afn args
404 | `(rfn self ,@args))
405 |
406 | (def wait (f)
407 | ((afn (v) (if v v (self (f))))
408 | (f)))
409 |
410 | (def runs (f xs (o fon (and xs (f (car xs)))))
411 | (if (no xs)
412 | nil
413 | (let (as bs) (split (if fon ~f f) xs)
414 | (cons as (runs f bs (no fon))))))
415 |
416 | (def whitec (c)
417 | (in c \space \n \tab \r))
418 |
419 | (def tokens (xs (o break whitec))
420 | (let f (if (function break) break (is break))
421 | (keep ~f:car (runs f xs))))
422 |
423 | (def dups (xs (o f =))
424 | (if (no xs) nil
425 | (mem (car xs) (cdr xs) f) (cons (car xs)
426 | (dups (rem (car xs) (cdr xs) f) f))
427 | (dups (cdr xs) f)))
428 |
429 | (set simple (cor atom number))
430 |
431 | (mac do1 args
432 | (letu v
433 | `(let ,v ,(car args)
434 | ,@(cdr args)
435 | ,v)))
436 |
437 | (def gets (v kvs (o f =))
438 | (find [f (cdr _) v] kvs))
439 |
440 | (def consif (x y)
441 | (if x (cons x y) y))
442 |
443 | (mac check (x f (o alt))
444 | (letu v
445 | `(let ,v ,x
446 | (if (,f ,v) ,v ,alt))))
447 |
448 | (mac withs (parms . body)
449 | (if (no parms)
450 | `(do ,@body)
451 | `(let ,(car parms) ,(cadr parms)
452 | (withs ,(cddr parms) ,@body))))
453 |
454 | (mac bind (var expr . body)
455 | `(dyn ,var ,expr (do ,@body)))
456 |
457 | (mac atomic body
458 | `(bind lock t ,@body))
459 |
460 | (def tail (f xs)
461 | (if (no xs) nil
462 | (f xs) xs
463 | (tail f (cdr xs))))
464 |
465 | (set dock rev:cdr:rev)
466 |
467 | (def lastcdr (xs)
468 | (if (no (cdr xs))
469 | xs
470 | (lastcdr (cdr xs))))
471 |
472 | (set last car:lastcdr)
473 |
474 | (def newq ()
475 | (list nil))
476 |
477 | (def enq (x q)
478 | (atomic (xar q (snoc (car q) x)))
479 | q)
480 |
481 | (def deq (q)
482 | (atomic (do1 (car (car q))
483 | (xar q (cdr (car q))))))
484 |
485 | (mac zap (op place . args)
486 | (letu (vo vc vl va)
487 | `(atomic (with (,vo ,op
488 | (,vc ,vl) (where ,place)
489 | ,va (list ,@args))
490 | (case ,vl
491 | a (xar ,vc (apply ,vo (car ,vc) ,va))
492 | d (xdr ,vc (apply ,vo (cdr ,vc) ,va))
493 | (err 'bad-place))))))
494 |
495 | (mac ++ (place (o n 1))
496 | `(zap + ,place ,n))
497 |
498 | (mac -- (place (o n 1))
499 | `(zap - ,place ,n))
500 |
501 | (mac push (x place)
502 | (letu v
503 | `(let ,v ,x
504 | (zap [cons ,v _] ,place))))
505 |
506 | (mac pull (x place . rest)
507 | (letu v
508 | `(let ,v ,x
509 | (zap [rem ,v _ ,@rest] ,place))))
510 |
511 | (def drop (n xs)
512 | (if (= n 0)
513 | xs
514 | (drop (- n 1) (cdr xs))))
515 |
516 | (def nth (n|pint xs|pair)
517 | (if (= n 1)
518 | (car xs)
519 | (nth (- n 1) (cdr xs))))
520 |
521 |
522 | (def first (n xs)
523 | (if (or (= n 0) (no xs))
524 | nil
525 | (cons (car xs)
526 | (first (- n 1) (cdr xs)))))
527 |
528 | (mac catch body
529 | (letu v
530 | `(ccc (fn (,v) (bind throw ,v ,@body)))))
531 |
532 | (def cut (xs (o start 1) (o end (len xs)))
533 | (first (- (+ end 1 (if (< end 0) (len xs) 0))
534 | start)
535 | (drop (- start 1) xs)))
536 |
537 | (mac whenlet (var expr . body)
538 | `(iflet ,var ,expr (do ,@body)))
539 |
540 | (mac awhen args
541 | `(whenlet it ,@args))
542 |
543 | (mac each (var expr . body)
544 | `(map (fn (,var) ,@body) ,expr))
545 |
546 | (def flip (f)
547 | (fn args (apply f (rev args))))
548 |
549 | (def part (f . args)
550 | (fn rest
551 | (apply f (append args rest))))
552 |
553 | (def trap (f . args)
554 | (flip (apply part (flip f) (rev args))))
555 |
556 | (def only (f)
557 | (fn args
558 | (if (car args) (apply f args))))
559 |
560 | (def >= args
561 | (pairwise ~bin< args))
562 |
563 | (def <= args
564 | (apply >= (rev args)))
565 |
566 | (mac whilet (var expr . body)
567 | (letu (vf vp)
568 | `((rfn ,vf (,vp)
569 | (whenlet ,var ,vp ,@body (,vf ,expr)))
570 | ,expr)))
571 |
572 | (mac loop (var init update test . body)
573 | (letu v
574 | `((rfn ,v (,var)
575 | (when ,test ,@body (,v ,update)))
576 | ,init)))
577 |
578 | (mac while (expr . body)
579 | (letu v
580 | `(loop ,v ,expr ,expr ,v ,@body)))
581 |
582 | (mac til (var expr test . body)
583 | `(loop ,var ,expr ,expr (no ,test)
584 | ,@body))
585 |
586 | (mac for (var init max . body)
587 | (letu (vi vm)
588 | `(with (,vi ,init
589 | ,vm ,max)
590 | (loop ,var ,vi (+ ,var 1) (<= ,var ,vm)
591 | ,@body))))
592 |
593 | (mac repeat (n . body)
594 | `(for ,(uvar) 1 ,n ,@body))
595 |
596 | (mac poll (expr f)
597 | (letu (vr ve vf)
598 | `((rfn ,vr (,ve ,vf)
599 | (if (,vf ,ve) ,ve (,vr ,expr ,vf)))
600 | ,expr
601 | ,f)))
602 |
603 | (mac accum (var . body)
604 | (letu v
605 | `(withs (,v nil
606 | ,var [push _ ,v])
607 | ,@body
608 | (rev ,v))))
609 |
610 | (mac nof (n expr)
611 | (letu v
612 | `(accum ,v (repeat ,n (,v ,expr)))))
613 |
614 | (mac drain (expr (o f 'no))
615 | (letu v
616 | `(accum ,v
617 | (poll ,expr (cor ,f (compose no ,v))))))
618 |
619 | (mac wipe args
620 | `(set ,@(fuse [list _ nil] args)))
621 |
622 | (mac pop (place)
623 | `(let (cell loc) (where ,place)
624 | (let xs ((case loc a car d cdr) cell)
625 | ((case loc a xar d xdr) cell (cdr xs))
626 | (car xs))))
627 |
628 | (mac clean (f place)
629 | (letu v
630 | `(let ,v (compose no ,f)
631 | (zap [keep ,v _] ,place))))
632 |
633 | (mac swap places
634 | (let vs (map [nof 3 (uvar)] places)
635 | `(atomic (withs ,(fuse (fn (place (cell loc val))
636 | (list (list cell loc)
637 | `(where ,place)
638 | val
639 | `((case ,loc a car d cdr) ,cell)))
640 | places
641 | vs)
642 | ,@(map (fn ((cellx locx valx) (celly locy valy))
643 | `((case ,locx a xar d xdr) ,cellx ,valy))
644 | vs
645 | (snoc (cdr vs) (car vs)))))))
646 |
647 | (def adjoin (x ys (o f =))
648 | (if (mem x ys f) ys (cons x ys)))
649 |
650 | (mac pushnew (x place (o f '=))
651 | (letu v
652 | `(let ,v ,x
653 | (zap [adjoin ,v _ ,f] ,place))))
654 |
655 | (def dedup (xs (o f =))
656 | (rev (foldl (trap adjoin f) nil xs)))
657 |
658 | (def insert (f x ys)
659 | (if (no ys) (list x)
660 | (f x (car ys)) (cons x ys)
661 | (cons (car ys) (insert f x (cdr ys)))))
662 |
663 | (def sort (f xs)
664 | (foldr (part insert f) nil (rev xs)))
665 |
666 | (set best car:sort)
667 |
668 | (def max args
669 | (best > args))
670 |
671 | (def min args
672 | (best < args))
673 |
674 |
--------------------------------------------------------------------------------
/src/bel_clojure/core.clj:
--------------------------------------------------------------------------------
1 | (ns bel-clojure.core
2 | (:require
3 | [clojure.java.io :as io]
4 | [clojure.string :as cstring]
5 | [bel-clojure.evaluator :as e]
6 | [bel-clojure.reader :as r]))
7 |
8 | ;; ---------
9 | ;; Bootstrap
10 |
11 | (defn source-str->parts [source-str]
12 | (->> (cstring/split source-str #"\n")
13 | (partition-by cstring/blank?)
14 | (map (fn [xs] (cstring/join "\n" xs)))
15 | (remove (fn [s] (cstring/starts-with? s ";")))
16 | (remove cstring/blank?)))
17 |
18 | (defn bootstrap-env []
19 | (let [env (e/env)]
20 | (e/eval-all env (source-str->parts (slurp (io/resource "core.bel"))))
21 | env))
22 |
23 | ;; ----
24 | ;; REPL
25 |
26 | (defn read-form
27 | ([] (read-form []))
28 | ([ret]
29 | (let [x (read-line)
30 | new-ret (conj ret x)]
31 | (try
32 | (let [v (r/parse (cstring/join "\n" new-ret))]
33 | (assert (not (:index v)))
34 | v)
35 | (catch Throwable _e
36 | (read-form new-ret))))))
37 |
38 | (defn repl [env]
39 | (println
40 | (str "🦁 Welcome to Bel\n"
41 | " Write some code, and press enter\n"
42 | " (id t t)\n"
43 | " (cons 'a 'b '(c d e))\n"
44 | ">"))
45 | (loop []
46 | (let [form (read-form)]
47 | (println "> "
48 | (r/bel->pretty
49 | (e/eval-single
50 | env form)))
51 | (recur))))
52 |
53 | (defn -main [& _args]
54 | (println " Loading core.bel...")
55 | (repl (bootstrap-env)))
56 |
--------------------------------------------------------------------------------
/src/bel_clojure/evaluator.clj:
--------------------------------------------------------------------------------
1 | (ns bel-clojure.evaluator
2 | (:refer-clojure :exclude [eval])
3 | (:require
4 | [bel-clojure.model :as m]
5 | [bel-clojure.reader :as r]))
6 |
7 | ;; ----
8 | ;; Misc
9 |
10 | (defn stack-pop [x] (list (peek x) (pop x)))
11 |
12 | (defn stack-pop-2 [x]
13 | (list (list (peek (pop x)) (peek x))
14 | (pop (pop x))))
15 |
16 | (defn stack-pop-until-breakpoint [breakpoint x]
17 | (loop [peeks ()
18 | pops x]
19 | (cond
20 | (empty? pops) (list peeks pops)
21 | (= (peek pops) breakpoint) (list peeks (pop pops))
22 | :else
23 | (recur
24 | (conj peeks (peek pops))
25 | (pop pops)))))
26 |
27 | ;; ------
28 | ;; where
29 |
30 | (defn in-where? [es]
31 | (= (second (peek es)) [:where]))
32 |
33 | (defn b-where [es rs env x]
34 | [(conj es
35 | [env [:where]]
36 | [env x])
37 | rs])
38 |
39 | ;; --------
40 | ;; variable
41 |
42 | (defn env-pair [sym v]
43 | (assert (m/bel-variable? sym)
44 | (format "expected left-side to be a variable= %s" sym))
45 | (m/p sym v))
46 |
47 | (defn not-bel-nil [x]
48 | (when-not (= x m/bel-nil) x))
49 |
50 | (defn v-pair [{:keys [dyn scope globe]} form]
51 | (let [v (->> [dyn scope globe]
52 | (some (fn [x]
53 | (not-bel-nil (m/map-get x form)))))]
54 | (assert v
55 | (format "expected value for variable = %s" form))
56 | v))
57 |
58 | (defn eval-variable [es rs env form]
59 | (cond
60 | (= m/bel-globe form)
61 | [es (conj rs (:globe env))]
62 |
63 | (= m/bel-scope form)
64 | [es (conj rs (:scope env))]
65 |
66 | :else
67 | (let [vp (v-pair env form)]
68 | (if (in-where? es)
69 | [(pop es)
70 | (conj rs
71 | (m/p vp (m/p m/bel-d m/bel-nil)))]
72 | [es
73 | (conj rs (m/cdr vp))]))))
74 |
75 | ;; ----------
76 | ;; thread
77 |
78 | (declare env)
79 |
80 | (defn b-thread [es rs {:keys [globe] :as env1} form]
81 | [(conj
82 | es
83 | [env1 [:start-thread (assoc (env) :globe globe) form]])
84 | rs])
85 |
86 | ;; ----
87 | ;; dyn
88 |
89 | (defn eval-dyn-2 [es rs env [_ variable after]]
90 | (let [[ev rest-rs] (stack-pop rs)
91 | {:keys [dyn]} env]
92 | [(conj es
93 | [(assoc env
94 | :dyn
95 | (m/map-assoc dyn variable (env-pair variable ev)))
96 | after])
97 | rest-rs]))
98 |
99 | (defn b-dyn [es rs env variable arg after]
100 | [(conj
101 | es
102 | [env [:dyn-2 variable after]]
103 | [env arg])
104 | rs])
105 |
106 | ;; ----
107 | ;; ccc
108 |
109 | (defn eval-cont [_es _rs _env litv args-head]
110 | (let [[f] litv
111 | [es rs] (f)]
112 | [es (conj rs (m/car args-head))]))
113 |
114 | (defn eval-ccc-2 [es rs env _form]
115 | (let [[f-evaled rest-rs] (stack-pop rs)]
116 | [(conj
117 | es
118 | [env
119 | (m/p
120 | f-evaled
121 | (m/p
122 | (m/seq->p [m/bel-lit m/bel-cont (fn [] [es rest-rs])])
123 | m/bel-nil))])
124 | rest-rs]))
125 |
126 | (defn b-ccc [es rs env f]
127 | [(conj
128 | es
129 | [env [:ccc-2]]
130 | [env f])
131 | rs])
132 |
133 | ;; ---
134 | ;; err
135 |
136 | (defn b-err [_es _rs _env e]
137 | [[] [(m/p m/bel-lit (m/p 'error (m/p e m/bel-nil) ))]])
138 |
139 | ;; -----
140 | ;; debug
141 |
142 | (defn b-debug
143 | [x] (println "[DEBUG] " (r/bel->pretty x)))
144 |
145 | ;; ----
146 | ;; uvar
147 |
148 | (def b-uvar gensym)
149 |
150 | ;; ----
151 | ;; bin<
152 |
153 | (declare bel-compare)
154 |
155 | (defn base-compare
156 | [a b] (compare a b))
157 |
158 | (defn list-compare
159 | [a b]
160 | (let [c1 (m/car a)
161 | c2 (m/car b)
162 | v (bel-compare c1 c2)]
163 | (cond
164 | (not= 0 v) v
165 | (not= m/bel-nil (m/cdr a)) (bel-compare (m/cdr a) (m/cdr b))
166 | :else v)))
167 |
168 | (defn bel-compare [a b]
169 | (let [f (condp = (m/type a)
170 | 'pair list-compare
171 | base-compare)]
172 | (f a b)))
173 |
174 | (defn b-bin< [& xs]
175 | (m/clj-bool->bel (neg? (apply bel-compare xs))))
176 |
177 | ;; ----
178 | ;; math
179 |
180 | (defn wrap-math-fn [f]
181 | (fn [& xs]
182 | (let [v (apply f xs)]
183 | (if
184 | (number? v) v
185 | (m/clj-bool->bel v)))))
186 |
187 | (def math-name->fn
188 | {"+" (wrap-math-fn +)
189 | "-" (wrap-math-fn -)
190 | "*" (wrap-math-fn *)
191 | "/" (wrap-math-fn /)
192 | "int" (wrap-math-fn int?)
193 | "num<" (wrap-math-fn <)
194 | "abs" (wrap-math-fn #(Math/abs %))
195 | "hash" (wrap-math-fn #(.hashCode %))})
196 |
197 | ;; ------------
198 | ;; simple-prims
199 |
200 | (def prim-name->fn
201 | (merge
202 | {"id" #'m/id
203 | "car" #'m/car
204 | "cdr" #'m/cdr
205 | "join" #'m/join
206 | "type" #'m/type
207 | "xar" #'m/xar
208 | "xdr" #'m/xdr
209 | "sym" #'m/sym
210 | "nom" #'m/nom
211 | "coin" #'m/coin
212 | "debug" #'b-debug
213 | "uvar" #'b-uvar
214 | "bin<" #'b-bin<
215 | "map-assoc" #'m/map-assoc}
216 | math-name->fn))
217 |
218 | ;; -------------
219 | ;; special-prims
220 |
221 | (def special-prim-name->fn
222 | {"dyn" #'b-dyn
223 | "ccc" #'b-ccc
224 | "where" #'b-where
225 | "err" #'b-err
226 | "thread" #'b-thread})
227 |
228 | ;; ---
229 | ;; Env
230 |
231 | (defn bel-globe []
232 | (let [m (m/mut-map)]
233 | (->> (merge prim-name->fn special-prim-name->fn)
234 | (map (fn [[k]]
235 | (let [sym-k (symbol (name k))]
236 | (m/map-put
237 | m
238 | sym-k
239 | (m/p
240 | sym-k
241 | (m/seq->p [m/bel-lit m/bel-prim sym-k]))))))
242 | doall)
243 | m))
244 |
245 | (defn env
246 | ([] (env (bel-globe)))
247 | ([g]
248 | {:globe g
249 | :scope m/bel-nil
250 | :dyn m/bel-nil}))
251 |
252 | ;; ------------
253 | ;; eval-if
254 |
255 | (defn eval-if-2 [es rs env [_ [consequent-form r]]]
256 | (let [[evaled-test-form rest-rs] (stack-pop rs)]
257 | [(conj es
258 | (cond
259 | (not= m/bel-nil evaled-test-form)
260 | [env consequent-form]
261 |
262 | (= m/bel-nil r)
263 | [env r]
264 |
265 | (= m/bel-nil (m/cdr r))
266 | [env (m/car r)]
267 | :else
268 | [env
269 | (m/p m/bel-if r)]))
270 | rest-rs]))
271 |
272 | (defn eval-if-1 [es rs env [test-form r]]
273 | [(conj es
274 | [env [:if-2 r]]
275 | [env test-form])
276 | rs])
277 |
278 | ;; ------------
279 | ;; eval-set
280 |
281 | (defn eval-set-2 [es rs {:keys [globe] :as _env} form]
282 | (let [[_ sym] form
283 | [evaled-v rest-rs] (stack-pop rs)]
284 | (m/map-put
285 | globe
286 | sym
287 | (env-pair sym evaled-v))
288 | [es rest-rs]))
289 |
290 | (defn eval-set-1 [es rs env form]
291 | (let [[sym after-sym] form
292 | _ (assert (not= m/bel-nil after-sym)
293 | "Set sym needs a value")
294 | [v after-v] after-sym
295 | es' (if (not= after-v m/bel-nil)
296 | (conj es [env (m/p m/bel-set after-v)])
297 | es)]
298 | [(conj es'
299 | [env [:set-2 sym]]
300 | [env v])
301 | rs]))
302 |
303 | ;; eval-application
304 | ;; --------------------
305 |
306 | (defn lit-type [[_lit [t]]] t)
307 |
308 | (defn lit-v [[_lit [_t v]]] v)
309 |
310 | (defn assert-lit [[lit :as form]]
311 | (assert (= m/bel-lit lit)
312 | (format
313 | "expected lit expression got form = %s" form))
314 | form)
315 |
316 | ;; -------------
317 | ;; eval-prim
318 |
319 | (defn bel-nil-args [f args]
320 | (let [arglist (->> f meta :arglists first)
321 | niled-args (if arglist
322 | (map-indexed (fn [i _] (nth args i m/bel-nil)) arglist)
323 | args)]
324 | niled-args))
325 |
326 | (defn eval-prim-simple [es rs env [_ n simple-f]]
327 | (let [[evaled-args rest-rs] (stack-pop rs)
328 | args (m/p->seq evaled-args)]
329 | (try
330 | (if (in-where? es)
331 | [(pop es)
332 | (conj rs
333 | (m/p
334 | (m/car evaled-args)
335 | (m/p
336 | (condp = n
337 | "car" m/bel-a
338 | "cdr" m/bel-d
339 | (throw (Exception. "unexpected use of where")))
340 | m/bel-nil)))]
341 |
342 | [es
343 | (conj rest-rs
344 | (apply simple-f
345 | (bel-nil-args simple-f args)))])
346 | (catch Throwable e
347 | [(conj es [env (m/p
348 | m/bel-err-sym
349 | (m/p e m/bel-nil))])
350 | rest-rs]))))
351 |
352 | (defn eval-prim [es rs env litv args-head]
353 | (let [n (name (m/car litv))
354 | simple-f (prim-name->fn n)
355 | special-f (special-prim-name->fn n)]
356 | (if simple-f
357 | [(conj es
358 | [env [:eval-prim-simple n simple-f]]
359 | [env [:eval-many-1 args-head]])
360 | rs]
361 | (apply special-f
362 | (bel-nil-args
363 | special-f
364 | (concat [es rs env]
365 | (m/p->seq args-head)))))))
366 |
367 | ;; -----------
368 | ;; assign-vars
369 |
370 | (defn assign-vars-typecheck-2 [es rs env [_ variable arg]]
371 | (let [[check rest-rs] (stack-pop rs)]
372 | (if (= m/bel-nil check)
373 | [(conj es
374 | [env (m/p
375 | m/bel-err-sym
376 | (m/p (m/quoted-p 'mistype)
377 | m/bel-nil))])
378 | rs]
379 | [(conj es
380 | [env
381 | [:assign-vars-1
382 | (m/bel-typecheck-var variable)
383 | arg]])
384 | rest-rs])))
385 |
386 | (defn assign-vars-typecheck-1 [es rs env [_ variable arg]]
387 | (let [[evaled-f rest-rs] (stack-pop rs)]
388 | [(conj es
389 | [env [:assign-vars-typecheck-2 variable arg]]
390 | [env (m/p
391 | evaled-f
392 | (m/p (m/quoted-p arg)
393 | m/bel-nil))])
394 | rest-rs]))
395 |
396 | (defn assign-vars-optional-arg [es rs env [_ variable]]
397 | (let [[arg-evaled rest-rs] (stack-pop rs)]
398 | [(conj es
399 | [env [:assign-vars-1 variable arg-evaled]])
400 | rest-rs]))
401 |
402 | (defn assign-vars-rest [es rs env [_ var-head arg-head]]
403 | (let [[scope rest-rs] (stack-pop rs)]
404 | [(conj es
405 | [(assoc env :scope scope)
406 | [:assign-vars-1 var-head arg-head]])
407 | rest-rs]))
408 |
409 | (defn assign-vars-1 [es rs {:keys [scope] :as env} [_ var-head arg-head]]
410 | (cond
411 | (every? (partial = m/bel-nil) [var-head arg-head])
412 | [es (conj rs scope)]
413 |
414 | (m/bel-variable? var-head)
415 | [es (conj rs
416 | (m/map-assoc
417 | scope
418 | var-head
419 | (env-pair
420 | var-head
421 | arg-head)))]
422 |
423 | (m/bel-optional? var-head)
424 | (if (= m/bel-nil arg-head)
425 | [(conj es
426 | [env [:assign-vars-optional-arg
427 | (m/bel-optional-var var-head)]]
428 | [env (m/bel-optional-arg var-head)])
429 |
430 | rs]
431 | [(conj es
432 | [env [:assign-vars-1
433 | (m/bel-optional-var var-head) arg-head]])
434 | rs])
435 | (m/bel-typecheck? var-head)
436 | [(conj es
437 | [env [:assign-vars-typecheck-1 var-head arg-head]]
438 | [env (m/bel-typecheck-f var-head)])
439 | rs]
440 | :else
441 | [(conj es
442 | [env [:assign-vars-rest
443 | (m/cdr var-head) (m/cdr arg-head)]]
444 | [env [:assign-vars-1
445 | (m/car var-head) (m/car arg-head)]])
446 | rs]))
447 |
448 | ;; ------------
449 | ;; eval-clo
450 |
451 | (defn eval-clo-2 [es rs env [_ body-head]]
452 | (let [[scope rest-rs] (stack-pop rs)]
453 | [(conj es
454 | [(assoc env :scope scope) body-head])
455 | rest-rs]))
456 |
457 | (defn clo-expression-stack [env litv args-head]
458 | (let [[scope [args-sym-head [body-head]]] litv]
459 | [[env [:eval-clo-2 body-head]]
460 | [(assoc env :scope scope)
461 | [:assign-vars-1 args-sym-head args-head]]]))
462 |
463 | (defn eval-clo [es rs env litv args-head]
464 | [(apply conj (concat [es] (clo-expression-stack env litv args-head)))
465 | rs])
466 |
467 | ;; ------------
468 | ;; eval-mac
469 |
470 | (defn eval-mac-2 [es rs env _form]
471 | (let [[code rest-rs] (stack-pop rs)]
472 | [(conj es [env code])
473 | rest-rs]))
474 |
475 | (defn eval-mac-1 [es rs env litv args-head]
476 | (let [[[_ [_ clo]]] litv]
477 | [(apply conj
478 | (concat [es
479 | [env [:eval-mac-2]]]
480 | (clo-expression-stack env clo args-head)))
481 | rs]))
482 |
483 | ;; ------------
484 | ;; eval-lit
485 |
486 | (defn eval-lit-1 [es rs env [_ evaled-lit]]
487 | (let [[args-head rest-rs] (stack-pop rs)
488 | litv (lit-v evaled-lit)]
489 | (condp = (lit-type evaled-lit)
490 | m/bel-prim
491 | (eval-prim es rest-rs env litv args-head)
492 | m/bel-clo
493 | (eval-clo es rest-rs env litv args-head)
494 | m/bel-mac
495 | (eval-mac-1 es rest-rs env litv args-head)
496 | m/bel-cont
497 | (eval-cont es rest-rs env litv args-head))))
498 |
499 | ;; --------------
500 | ;; eval-many
501 |
502 | (defn eval-many-2 [es rs _env _form]
503 | (let [[top-ps rest-rs] (stack-pop-until-breakpoint :eval-many-breakpoint rs)
504 | evaled-pairs (m/seq->p (reverse top-ps))]
505 | [es (conj rest-rs evaled-pairs)]))
506 |
507 | (defn eval-many-1 [es rs env [_ args-head]]
508 | (let [pairs-to-eval (m/p->seq args-head)]
509 | [(apply
510 | conj
511 | (concat
512 | [es [env [:eval-many-2]]]
513 | (map (fn [p] [env p]) pairs-to-eval)))
514 | (conj rs :eval-many-breakpoint)]))
515 |
516 | ;; --------------------
517 | ;; eval-application
518 |
519 | (defn eval-application-2 [es rs env [_ args-head]]
520 | (let [[evaled rest-rs] (stack-pop rs)]
521 | (if (m/number? evaled)
522 | [(conj es
523 | [env [:eval-lit-1 (m/cdr (v-pair env 'nth))]]
524 | [env [:eval-many-1 (m/p evaled args-head)]])
525 | rest-rs]
526 | (let [evaled-lit (assert-lit evaled)
527 | es' (conj es [env [:eval-lit-1 evaled-lit]])]
528 | (if (#{m/bel-mac m/bel-prim}
529 | (lit-type evaled-lit))
530 | [es' (conj rest-rs args-head)]
531 | [(conj es'
532 | [env [:eval-many-1 args-head]])
533 | rest-rs])))))
534 |
535 | (defn eval-application-1 [es rs env [f args-head :as _form]]
536 | [(conj es
537 | [env [:application-2 args-head]]
538 | [env f])
539 | rs])
540 |
541 | ;; eval-apply
542 | ;; -------------
543 |
544 | (defn apply-head->args-head [x]
545 | (let [xs (m/p->seq x)
546 | but-last (drop-last xs)
547 | l (last xs)
548 | ls (if (m/pair? l)
549 | (m/p->seq l)
550 | [l])]
551 | (->> (concat but-last ls)
552 | (map m/quoted-p)
553 | m/seq->p)))
554 |
555 | (defn eval-apply-2 [es rs env [_ f]]
556 | (let [[evaled-apply-head rest-rs] (stack-pop rs)]
557 | [(conj
558 | es
559 | [env (m/p
560 | f (apply-head->args-head evaled-apply-head))])
561 | rest-rs]))
562 |
563 | (defn eval-apply-1 [es rs env [f apply-head :as _form]]
564 | [(conj
565 | es
566 | [env [:eval-apply-2 f]]
567 | [env [:eval-many-1 apply-head]])
568 | rs])
569 |
570 | ;; -------------
571 | ;; eval-pair
572 |
573 | (defn eval-pair [es rs env [l r :as form]]
574 | (cond
575 | (= m/bel-quote l) [es (conj rs (m/car r))]
576 | (= m/bel-set l) (eval-set-1 es rs env r)
577 | (= m/bel-if l) (eval-if-1 es rs env r)
578 | (= m/bel-apply l) (eval-apply-1 es rs env r)
579 | :else (eval-application-1 es rs env form)))
580 |
581 | ;; ------------------
582 | ;; eval-backquote
583 |
584 | (defn eval-bq-comma-1 [es rs _env _form]
585 | (let [[[r-evaled h-evaled] rest-rs] (stack-pop-2 rs)]
586 | [es
587 | (conj
588 | rest-rs
589 | (m/p
590 | h-evaled
591 | r-evaled))]))
592 |
593 | (defn eval-bq-splice-1 [es rs _env _form]
594 | (let [[[r-evaled h-evaled] rest-rs] (stack-pop-2 rs)]
595 | [es
596 | (conj
597 | rest-rs
598 | (m/p-append
599 | h-evaled
600 | r-evaled))]))
601 |
602 | (defn eval-bq-pair-1 [es rs _env _form]
603 | (let [[[r-evaled h-evaled] rest-rs] (stack-pop-2 rs)]
604 | [es
605 | (conj
606 | rest-rs
607 | (m/p
608 | h-evaled
609 | r-evaled))]))
610 |
611 | (defn eval-bq-rest-1 [es rs _env [_ h]]
612 | (let [[r-evaled rest-rs] (stack-pop rs)]
613 | [es
614 | (conj
615 | rest-rs
616 | (m/p
617 | h
618 | r-evaled))]))
619 |
620 | (defn eval-backquote [es rs env [_ form]]
621 | (let [t (m/type form)]
622 | (cond
623 | (= t 'comma)
624 | [(conj es [env (second form)])
625 | rs]
626 |
627 | (not= t 'pair)
628 | [es (conj rs form)]
629 |
630 | :else
631 | (let [[h r] form
632 | h-t (m/type h)]
633 | (cond
634 | (= h-t 'comma)
635 | [(conj
636 | es
637 | [env [:eval-bq-comma-1]]
638 | [env (second h)]
639 | [env [:backquote r]])
640 | rs]
641 | (= h-t 'splice)
642 | [(conj
643 | es
644 | [env [:eval-bq-splice-1]]
645 | [env (second h)]
646 | [env [:backquote r]])
647 | rs]
648 | (= h-t 'pair)
649 | [(conj es
650 | [env [:eval-bq-pair-1]]
651 | [env [:backquote h]]
652 | [env [:backquote r]])
653 | rs]
654 | :else
655 | [(conj es
656 | [env [:eval-bq-rest-1 h]]
657 | [env [:backquote r]])
658 | rs])))))
659 |
660 | ;; --------
661 | ;; eval
662 |
663 | (defn literal? [form]
664 | (or (#{'clj-err 'char 'number} (m/type-nilable form))
665 | (#{m/bel-nil m/bel-t m/bel-o m/bel-apply} form)
666 | (and (m/pair? form) (#{m/bel-lit} (m/car form)))
667 | (m/string? form)))
668 |
669 | (def step->fn
670 | {:set-2 eval-set-2
671 | :if-2 eval-if-2
672 | :application-2 eval-application-2
673 | :eval-many-1 eval-many-1
674 | :eval-many-2 eval-many-2
675 | :eval-lit-1 eval-lit-1
676 | :eval-prim-simple eval-prim-simple
677 | :eval-mac-2 eval-mac-2
678 | :assign-vars-1 assign-vars-1
679 | :assign-vars-optional-arg assign-vars-optional-arg
680 | :assign-vars-typecheck-1 assign-vars-typecheck-1
681 | :assign-vars-typecheck-2 assign-vars-typecheck-2
682 | :assign-vars-rest assign-vars-rest
683 | :eval-clo-2 eval-clo-2
684 | :dyn-2 eval-dyn-2
685 | :ccc-2 eval-ccc-2
686 | :backquote eval-backquote
687 | :eval-bq-comma-1 eval-bq-comma-1
688 | :eval-bq-splice-1 eval-bq-splice-1
689 | :eval-bq-pair-1 eval-bq-pair-1
690 | :eval-bq-rest-1 eval-bq-rest-1
691 | :eval-apply-2 eval-apply-2})
692 |
693 | (defn eval-step [es rs]
694 | (let [[top rest-es] (stack-pop es)
695 | [env form] top]
696 | (cond
697 | (literal? form)
698 | [rest-es (conj rs form)]
699 |
700 | (m/bel-variable? form)
701 | (eval-variable rest-es rs env form)
702 |
703 | (m/pair? form)
704 | (eval-pair rest-es rs env form)
705 |
706 | :else
707 | (let [f (step->fn (first form))]
708 | (f rest-es rs env form)))))
709 |
710 | (defn debug-loop [tid es rs]
711 | (println "---start--")
712 | (println "tid:" tid)
713 | (println "in:")
714 | (doall (map (comp println r/bel->pretty second) es))
715 | (println "out:")
716 | (doall (map println rs))
717 | (println "---end---"))
718 |
719 | (defn start-thread-command? [form]
720 | (and (seqable? form) (= :start-thread (first form))))
721 |
722 | (defn start-thread-command->thread [[_ env form]]
723 | [(gensym) (list [env form]) ()])
724 |
725 | (defn locking? [es]
726 | (let [lock (some-> es peek first :dyn (get 'lock))]
727 | (and lock (not= lock m/bel-nil))))
728 |
729 | (defn eval [threads]
730 | (loop [threads threads]
731 | (let [[top-thread & rest-threads] threads
732 | [tid es rs] top-thread
733 | [_ top-form] (peek es)]
734 | (cond
735 | (empty? es)
736 | (if (empty? rest-threads)
737 | (or (peek rs) m/bel-nil)
738 | (recur rest-threads))
739 |
740 | (start-thread-command? top-form)
741 | (recur
742 | (into [(start-thread-command->thread top-form)
743 | [tid (pop es) rs]]
744 | rest-threads))
745 | :else
746 | (let [[es' rs'] (eval-step es rs)
747 | thread' [tid es' rs']]
748 | (recur
749 | (if (locking? es')
750 | (into [thread'] rest-threads)
751 | (into (vec rest-threads) [thread']))))))))
752 |
753 | (defn eval-single [env form]
754 | (eval [[(gensym) (list [env form]) ()]]))
755 |
756 | (defn eval-all
757 | [env strs]
758 | (mapv (fn [s]
759 | (eval-single env (r/parse s))) strs))
760 |
--------------------------------------------------------------------------------
/src/bel_clojure/model.clj:
--------------------------------------------------------------------------------
1 | (ns bel-clojure.model
2 | (:refer-clojure :rename {type clj-type
3 | symbol? clj-symbol?
4 | string? clj-string?
5 | char? clj-char?
6 | number? clj-number?})
7 | (:import
8 | (java.util ArrayList)))
9 |
10 | ;; ----
11 | ;; Misc
12 |
13 | (defn first-and-only [xs msg]
14 | (assert (= (count xs) 1) msg)
15 | (first xs))
16 |
17 | ;; -------------
18 | ;; Primitive Types
19 |
20 | (def string? clj-string?)
21 | (def char? clj-char?)
22 | (def symbol? clj-symbol?)
23 | (def number? clj-number?)
24 | (def pair? (comp (partial = java.util.ArrayList) clj-type))
25 | (def mut-map? (comp (partial = java.util.HashMap) clj-type))
26 | (def imm-map? (comp (partial = clojure.lang.PersistentArrayMap) clj-type))
27 | (def clj-err? (partial instance? Throwable))
28 |
29 | (defn type-nilable [x]
30 | (cond
31 | (symbol? x) 'symbol
32 | (string? x) 'string
33 | (char? x) 'char
34 | (number? x) 'number
35 | (pair? x) 'pair
36 | (mut-map? x) 'mut-map
37 | (imm-map? x) 'imm-map
38 | (clj-err? x) 'clj-err
39 | :else
40 | (let [v (and (seqable? x) (first x))]
41 | (when (#{:splice :comma :backquote} v)
42 | (symbol (name v))))))
43 |
44 | (defn type [x]
45 | (let [v (type-nilable x)]
46 | (assert v (format "Unsupported type for form = %s" x))
47 | v))
48 |
49 | ;; ---------
50 | ;; Pair Cons
51 |
52 | (defn p
53 | ([a b]
54 | (ArrayList. [a b])))
55 |
56 | ;; ---------
57 | ;; Constants
58 |
59 | (def bel-quote 'quote)
60 | (def bel-nil (symbol "nil"))
61 | (def bel-t 't)
62 | (def bel-err-sym 'err)
63 | (def bel-dot [:dot "."])
64 | (def bel-lit 'lit)
65 | (def bel-prim 'prim)
66 | (def bel-o 'o)
67 | (def bel-a 'a)
68 | (def bel-d 'd)
69 | (def bel-apply 'apply)
70 | (def bel-set 'set)
71 | (def bel-clo 'clo)
72 | (def bel-mac 'mac)
73 | (def bel-globe 'globe)
74 | (def bel-scope 'scope)
75 | (def bel-if 'if)
76 | (def bel-cont 'cont)
77 |
78 | ;; -------------
79 | ;; Pair Helpers
80 |
81 | (defn quoted-p [a]
82 | (p bel-quote (p a bel-nil)))
83 |
84 | (defn seq->p
85 | [xs]
86 | (let [[x n & after-n] xs
87 | after-x (rest xs)]
88 | (if (empty? xs)
89 | bel-nil
90 | (p
91 | x
92 | (if (= bel-dot n)
93 | (first-and-only after-n "dotted list _must_ have 1 exp after the dot")
94 | (seq->p after-x))))))
95 |
96 | (defn id [a b]
97 | (let [id-f (if (pair? a) identical? =)]
98 | (if (id-f a b) bel-t bel-nil)))
99 |
100 | (defn join [a b]
101 | (p a
102 | (if (string? b) (seq->p b) b)))
103 |
104 | (defn car [form]
105 | (cond
106 | (= bel-nil form) form
107 |
108 | (string? form) (first form)
109 |
110 | (not (pair? form))
111 | (throw (Exception. (format "expected pair, got = %s" form)))
112 |
113 | :else
114 | (first form)))
115 |
116 | (defn cdr [form]
117 | (cond
118 | (= bel-nil form) form
119 |
120 | (string? form) (seq->p (rest form))
121 |
122 | (not (pair? form))
123 | (throw (Exception. (format "expected pair, got = %s" form)))
124 |
125 | :else
126 | (last form)))
127 |
128 | (defn p->seq [form]
129 | (if (= bel-nil form)
130 | ()
131 | (cons
132 | (car form)
133 | (let [r (cdr form)]
134 | (cond
135 | (pair? r) (p->seq r)
136 | (= bel-nil r) []
137 | :else [r])))))
138 |
139 | (defn xar [form y]
140 | (.set form 0 y)
141 | form)
142 |
143 | (defn xdr [form y]
144 | (.set form 1 y)
145 | form)
146 |
147 | (def sym symbol)
148 |
149 | (def nom name)
150 |
151 | (defn coin [] (rand-nth [bel-t bel-nil]))
152 |
153 | (defn p-append [a b]
154 | (cond
155 | (= bel-nil a) b
156 | (= bel-nil (cdr a)) (p (car a) b)
157 | :else
158 | (p
159 | (car a)
160 | (p-append (cdr a) b))))
161 |
162 | ;; ---------
163 | ;; Variable
164 |
165 | (def bel-variable? symbol?)
166 |
167 | ;; ---------
168 | ;; Optional
169 |
170 | (defn bel-optional? [[h]]
171 | (= bel-o h))
172 |
173 | (defn bel-optional-var [[_h [variable]]] variable)
174 |
175 | (defn bel-optional-arg [[_h [_variable r]]] (car r))
176 |
177 | ;; ---------
178 | ;; Typecheck
179 |
180 | (defn bel-typecheck? [[h]]
181 | (= bel-t h))
182 |
183 | (defn bel-typecheck-var [[_h [variable]]] variable)
184 |
185 | (defn bel-typecheck-f [[_h [_variable r]]] (car r))
186 |
187 | ;; -------
188 | ;; Interop
189 |
190 | (defn clj-bool->bel [x] (if x bel-t bel-nil))
191 |
192 | ;; ----
193 | ;; Maps
194 |
195 | (defn map-get [m k]
196 | (if (= m bel-nil)
197 | bel-nil
198 | (or (.get m k) bel-nil)))
199 |
200 | (defn map-assoc [m k v]
201 | (let [m' (if (= bel-nil m) {} m)]
202 | (assoc m' k v)))
203 |
204 | (defn map-dissoc [m k]
205 | (if (= bel-nil m) bel-nil
206 | (let [m' (dissoc m k)]
207 | (if (empty? m') bel-nil m'))))
208 |
209 | (defn mut-map []
210 | (java.util.HashMap.))
211 |
212 | (defn map-put [m k v]
213 | (.put m k v))
214 |
215 | (defn map-delete [m k]
216 | (.remove m k))
217 |
--------------------------------------------------------------------------------
/src/bel_clojure/reader.clj:
--------------------------------------------------------------------------------
1 | (ns bel-clojure.reader
2 | (:require
3 | [clojure.java.io :as io]
4 | [instaparse.core :as insta]
5 | [clojure.walk :as walk]
6 | [clojure.string :as cstring]
7 | [clojure.edn :as edn]
8 | [bel-clojure.model :as m]))
9 |
10 | (defn form-transform
11 | [k f]
12 | (fn [x]
13 | (if (and
14 | (coll? x)
15 | (= (first x) k))
16 | (f x)
17 | x)))
18 |
19 | ;; -------
20 | ;; unwrap
21 |
22 | (def unwrap-sexp (form-transform :sexp second))
23 |
24 | (def unwrap-space (form-transform :space second))
25 |
26 | (def unwrap-name (form-transform :name second))
27 |
28 | ;; ----
29 | ;; list
30 |
31 | (def list->pair
32 | (form-transform
33 | :list
34 | (fn [[_t & children]]
35 | (m/seq->p children))))
36 |
37 | ;; -------
38 | ;; string
39 |
40 | (def transform-string
41 | (form-transform
42 | :string
43 | (fn [[_t & children]]
44 | (cstring/join (map second children)))))
45 |
46 | ;; -----
47 | ;; quote
48 |
49 | (def quote->pair
50 | (form-transform :quote
51 | (fn [[_ exp]]
52 | (m/quoted-p exp))))
53 |
54 | ;; ----------
55 | ;; abbrev-fn
56 |
57 | (def abbrev-fn->pair
58 | (form-transform :abbrev_fn
59 | (fn [[_ & xs]]
60 | (m/p
61 | 'fn
62 | (m/p
63 | (m/p '_ m/bel-nil)
64 | (m/p
65 | (m/seq->p xs)
66 | m/bel-nil))))))
67 |
68 | ;; ----------
69 | ;; abbrev-sym
70 |
71 | (declare handle-abbrev-sym)
72 |
73 | (defn handle-bar [left-xs right-xs]
74 | (m/p 't (m/p
75 | (handle-abbrev-sym left-xs)
76 | (m/p
77 | (handle-abbrev-sym right-xs)
78 | m/bel-nil))))
79 |
80 | (defn handle-dot [left-xs right-xs]
81 | (m/p (if (seq left-xs)
82 | (handle-abbrev-sym left-xs)
83 | 'upon)
84 | (m/p (handle-abbrev-sym right-xs) m/bel-nil)))
85 |
86 | (defn handle-excl [left-xs right-xs]
87 | (m/p (if (seq left-xs)
88 | (handle-abbrev-sym left-xs)
89 | 'upon)
90 | (m/p (m/quoted-p (handle-abbrev-sym right-xs))
91 | m/bel-nil)))
92 |
93 | (defn handle-no [left-xs [r & right-xs]]
94 | (handle-abbrev-sym
95 | (concat left-xs
96 | [(m/p
97 | 'compose
98 | (m/p
99 | 'no
100 | (m/p r m/bel-nil)))]
101 | right-xs)))
102 |
103 | (defn handle-col [left-xs right-xs]
104 | (m/p
105 | 'compose
106 | (->> (concat left-xs right-xs)
107 | (remove (fn [x] (and (seqable? x) (= (first x) :comp_id))))
108 | m/seq->p)))
109 |
110 | (defn handle-abbrev-sym [x]
111 | (if
112 | (or (m/pair? x) (m/symbol? x))
113 | x
114 | (let [[id f] (->> [["|" handle-bar]
115 | ["." handle-dot]
116 | ["!" handle-excl]
117 | ["~" handle-no]
118 | [":" handle-col]]
119 | (filter (fn [[id]]
120 | (some (partial = [:comp_id id]) x)))
121 | first)
122 | [before-id [_ & after-id]]
123 | (split-with (partial not= [:comp_id id]) x)]
124 | (if f
125 | (f before-id after-id)
126 | (first x)))))
127 |
128 | (def abbrev-sym->pair
129 | (form-transform :comp_sym
130 | (fn [[_ & xs]]
131 | (handle-abbrev-sym xs))))
132 |
133 | ;; ------
134 | ;; number
135 |
136 | (def transform-number
137 | (form-transform :number
138 | (fn [[_ v]] (edn/read-string v))))
139 |
140 | ;; ------
141 | ;; symbol
142 |
143 | (def transform-symbol
144 | (form-transform :symbol (fn [[_ v]] (symbol v))))
145 |
146 | ;; ------
147 | ;; char
148 |
149 | (def transform-char
150 | (form-transform :char (fn [[_ x]]
151 | (edn/read-string (str "\\" x)))))
152 |
153 | ;; -----
154 | ;; bel-parse
155 |
156 | (def parse-string (-> "bel.ebnf" io/resource insta/parser))
157 |
158 | (def unwrap-abbrev-sym-pt (form-transform :abbrev_sym_pt second))
159 |
160 | (def parse-postwalk
161 | (comp
162 | list->pair
163 | transform-string
164 | quote->pair
165 | transform-symbol
166 | unwrap-name
167 | unwrap-sexp
168 | unwrap-abbrev-sym-pt
169 | unwrap-space
170 | abbrev-fn->pair
171 | abbrev-sym->pair
172 | transform-number
173 | transform-char))
174 |
175 | (def parse
176 | (comp (partial walk/postwalk parse-postwalk) parse-string cstring/trim))
177 |
178 | ;; ----------------
179 | ;; bel->pretty
180 |
181 | (defn bel->pretty [form]
182 | (condp = (m/type-nilable form)
183 | 'symbol (if (= m/bel-nil form) nil form)
184 | 'backquote (list 'bq (bel->pretty (second form)))
185 | 'comma (list 'cm (bel->pretty (second form)))
186 | 'splice (list 'spl (bel->pretty (second form)))
187 | 'err (list 'err (bel->pretty (second form)))
188 | 'char form
189 | 'number form
190 | 'string form
191 | 'pair
192 | (let [[a b] form]
193 | (concat [(bel->pretty a)]
194 | (cond
195 | (= m/bel-nil b) nil
196 | (m/pair? b) (bel->pretty b)
197 | :else ['. (bel->pretty b)])))
198 | form))
199 |
--------------------------------------------------------------------------------
/test/bel_clojure/core_test.clj:
--------------------------------------------------------------------------------
1 | (ns bel-clojure.core-test
2 | (:require
3 | [bel-clojure.reader :as r]
4 | [bel-clojure.evaluator :as e]
5 | [bel-clojure.core :refer :all]
6 | [clojure.test :refer :all]))
7 |
8 | (def env (delay (bootstrap-env)))
9 |
10 | (defn ev [& strs]
11 | (println ">" strs)
12 | (r/bel->pretty (last (e/eval-all @env strs))))
13 |
14 | (deftest core-test
15 | (is (= (ev "(no nil)") 't))
16 | (is (= (ev "(atom \\a)") 't))
17 | (is (= (ev "(atom '(a))") nil))
18 | (is (= (ev "(atom \"foo\")") nil))
19 | (is (= (ev "(all atom '(a b))") 't))
20 | (is (= (ev "(all atom '(a (b c) d))") nil))
21 | (is (= (ev "(some atom '((a b) (c d)))") nil))
22 | (is (= (ev "(some atom '((a b) c (d e)))") '(c (d e))))
23 | (is (= (ev "(reduce join '(a b c))") '(a b . c)))
24 | (is (= (ev "(cons 'a 'b 'c '(d e f))")
25 | '(a b c d e f)))
26 | (is (= (ev "(append '(a b c) '(d e f))")
27 | '(a b c d e f)))
28 | (is (= (ev "(append '(a) nil '(b c) '(d e f))")
29 | '(a b c d e f)))
30 | (is (= (ev "(snoc '(a b c) 'd 'e)")
31 | '(a b c d e)))
32 | (is (= (ev "(list 'a 'b)")
33 | '(a b)))
34 | (is (= (ev "(map car '((a b) (c d) (e f)))")
35 | '(a c e)))
36 | (is (= (ev "(map cons '(a b c) '(d e f))")
37 | '((a . d) (b . e) (c . f))))
38 | (is (= (ev "(symbol 'a)")
39 | 't))
40 | (is (= (ev "(let (x . y) '(a b c) y)")
41 | '(b c)))
42 | (is (= (ev "((macro (v) `(set ,v 'a)) x)"
43 | "x")
44 | 'a))
45 | (is (= (ev "(apply or '(nil a nil b))")
46 | 'a))
47 | (is (= (ev "(proper '(a . b))")
48 | nil))
49 | (is (= (ev "(proper '(a b))")
50 | 't))
51 | (is (= (ev "(string \"foo\")")
52 | 't))
53 | (is (= (ev "(mem \\a \"foobar\")")
54 | '(\a \r)))
55 | (is (= (ev "(let (x (o (y . z) '(a . b))) '(f) (list x y z))")
56 | '(f a b)))
57 | (is (= (ev "(begins '(a b c d e) '(a b))")
58 | 't))
59 | (is (= (ev "(= '(a b) '(a b))") 't))
60 | (is (= (ev "(case '+ + 'plus - 'minus 'unknown)") 'plus))
61 | (is (= (ev "(iflet x nil 'foo '(a b c) (car x) 'bar)") 'a))
62 | (is (= (ev "(find [= (car _) \\a] '(\"pear\" \"apple\" \"grape\"))")
63 | "apple"))
64 | (is (= (ev "(caris '(a b) 'a)") 't))
65 | (is (= (ev "(hug '(a b c d e))") '((a b) (c d) (e))))
66 | (is (= (ev "(with (x 'a y 'b) (cons x y))") '(a . b)))
67 | (is (= (ev "(rem \\a \"abracadabra\")")
68 | '(\b \r \c \d \b \r)))
69 | (is (= (ev "(set x '((a . d) (b . e) (c . f)))"
70 | "(get 'a x)")
71 | '(a . d)))
72 | (is (= (ev "(set x '((a . d) (b . e) (c . f)))"
73 | "(put 'z 'y x)")
74 | '((z . y) (a . d) (b . e) (c . f))))
75 | (is (= (ev "(rev \"able\")")
76 | '(\e \l \b \a)))
77 | (is (= (ev "(snap '(a b) '(c d e f g))") '((c d) (e f g))))
78 | (is (= (ev "(udrop '(a b) '(c d e f g))") '(e f g)))
79 | (is (= (ev "(map idfn '(a b c))") '(a b c)))
80 | (is (= (ev "((is 'a) 'a)") 't))
81 | (is (= (ev "(eif x (car 'a) 'oops x)") 'oops))
82 | (is (= (ev "(onerr 'oops (car 'a))") 'oops))
83 | (is (= (ev "(safe (car 'a))") nil))
84 | (is (= (ev "(safe (car '(a b)))") 'a))
85 | (is (= (ev "(map literal (list nil \"foo\" car))") '((nil o apply) t t)))
86 | (is (= (ev "(map variable (list 'x (uvar) t))") '(t t nil)))
87 | (is (= (ev "((isa 'clo) map)") 't))
88 | (is (= (ev "(def consa (xs|pair) (cons 'a xs))"
89 | "(consa 'z)")
90 | '(lit error (quote mistype))))
91 | (is (= (ev "(def consa (xs|pair) (cons 'a xs))"
92 | "(consa '(a b))")
93 | '(a a b)))
94 | (is (= (ev "(def foo ((o (t (x . y) [caris _ 'a]) '(a . b))) x)"
95 | "(foo '(b b))")
96 | '(lit error (quote mistype))))
97 | (is (= (ev "(def foo ((o (t (x . y) [caris _ 'a]) '(a . b))) x)"
98 | "(foo)")
99 | 'a))
100 | (is (= (ev "((fn (x (o y x)) y) 'a)") 'a))
101 | (is (= (ev "((fn (f x|f) x) pair 'a)")
102 | '(lit error (quote mistype))))
103 | (is (= (ev "(map function (list car append 'foo))") '(prim clo nil)))
104 | (is (= (ev "(map (con 'yo) '(a b c))") '(yo yo yo)))
105 | (is (= (ev "(car:cdr '(a b c))") 'b))
106 | (is (= (ev "(map ~cdr '((a) (a b c) (a b)))")
107 | '(t nil nil)))
108 | (is (= (ev "(map ((combine and) car cdr) '((a . nil) (a . b) (nil . b)))")
109 | '(nil b nil)))
110 | (is (= (ev "((cand pair cdr) '(a b))") '(b)))
111 | (is (= (ev "((cor char pair) 'a)") nil))
112 | (is (= (ev "(foldl cons nil '(a b))") '(b a)))
113 | (is (= (ev "(foldr cons nil '(a b))") '(a b)))
114 | (is (= (ev "(map (upon '(a b c)) (list car cadr cdr))")
115 | '(a b (b c))))
116 | (is (= (ev "(fuse [list 'a _] '(b c d))")
117 | '(a b a c a d)))
118 | (is (= (ev "(match '(a (b) c d) (list 'a pair 'c t))") 't))
119 | (is (= (ev "(split (is \\a) \"frantic\")")
120 | '((\f \r) (\a \n \t \i \c))))
121 | (is (= (ev "(inc 2)") 3))
122 | (is (= (ev "(len '(a b c))") 3))
123 | (is (= (ev "(pos \\s \"ask\")") 2))
124 | (is (= (ev "(> 3 2)") 't))
125 | (is (= (ev "(< \"apple\" \"apply\")") 't))
126 | (is (= (ev "((afn (x)
127 | (if (no x) 0 (inc:self:cdr x))) '(a b c))")
128 | 3))
129 | (is (= (ev "(pint 1)") 't))
130 | (is (= (ev "(runs pint '(1 1 0 0 0 1 1 1 0))")
131 | '((1 1) (0 0 0) (1 1 1) (0))))
132 | (is (= (ev "(tokens \"the age of the essay\")")
133 | '((\t \h \e) (\a \g \e) (\o \f) (\t \h \e) (\e \s \s \a \y))))
134 | (is (= (ev "(dups \"abracadabra\")")
135 | '(\a \b \r)))
136 | (is (= (ev "(consif (cadr '(a)) '(x y))") '(x y)))
137 | (is (= (ev "(let x 'a (withs (x 'b y x) y))") 'b))
138 | (is (= (ev "(tail [caris _ \\-] \"non-nil\")") '(\- \n \i \l)))
139 | (is (= (ev "(dock '(a b c))") '(a b)))
140 | (is (= (ev "(lastcdr '(a b c))") '(c)))
141 | (is (= (ev "(last '(a b c))") 'c))
142 | (is (= (ev "(set x (newq))" "(enq 'a x)" "(enq 'b x)")
143 | '((a b))))
144 | (is (= (ev "(set x (newq))" "(enq 'a x)" "(enq 'b x)" "(deq x)")
145 | 'a))
146 | (is (= (ev "(set x (newq))" "(enq 'a x)" "(enq 'b x)" "(deq x)" "x")
147 | '((b))))
148 | (is (= (ev "(let x '(a b c) (zap cdr x) x)") '(b c)))
149 | (is (= (ev "(let x '(a b c) (push 'z x) (pull 'c x) x)") '(z a b)))
150 | (is (= (ev "(let x 'nil (push 'a x) (push 'b x) x)") '(b a)))
151 | (is (= (ev "(drop 2 '(a b c d e))") '(c d e)))
152 | (is (= (ev "(nth 2 '(a b c d e))") 'b))
153 | (is (= (ev "(first 2 '(a b c de))") '(a b)))
154 | (is (= (ev "(catch (throw 'a) (/ 1 0))") 'a))
155 | (is (= (ev "(cut \"foobar\" 2 4)") '(\o \o \b)))
156 | (is (= (ev "(cut \"foobar\" 2 -1)") '(\o \o \b \a)))
157 | (is (= (ev "((flip -) 1 10)") 9))
158 | (is (= (ev "((part cons 'a) 'b)") '(a . b)))
159 | (is (= (ev "((trap cons 'a) 'b)") '(b . a)))
160 | (is (= (ev "(let x nil
161 | (set find only.car:some)
162 | (find [= (car _) \\a] '(\"pear\" \"apple\" \"grape\")))")
163 | "apple"))
164 | (is (= (ev "(let z nil
165 | (let x '(a b c) (whilet y (pop x) (push y z)) x) z)")
166 | '(c b a)))
167 | (is (= (ev "(let z nil
168 | (loop x 1 (+ x 1) (< x 5) (push x z))
169 | z)")
170 | '(4 3 2 1)))
171 | (is (= (ev "(let z nil
172 | (for x 1 5 (push x z))
173 | z)")
174 | '(5 4 3 2 1)))
175 | (is (= (ev "(let x '(a b c d e) (poll (pop x) is!c) x)") '(d e)))
176 | (is (= (ev "(let x '(a b c) (pop (cdr x)) x)") '(a c)))
177 | (is (= (ev "(let (x y z) '(a b c) (swap x y z) (list x y z))") '(b c a)))
178 | (is (= (ev "(adjoin 'a '(a b c))") '(a b c)))
179 | (is (= (ev "(adjoin 'z '(a b c))") '(z a b c)))
180 | (is (= (ev "(dedup \"abracadabra\")")
181 | '(\a \b \r \c \d)))
182 | (is (= (ev "(insert < 3 '(1 2 4 5))") '(1 2 3 4 5)))
183 | (is (= (ev "(sort < '(5 1 3 2 4))") '(1 2 3 4 5)))
184 | (is (= (ev "(best > '(1 2 4 5))") 5))
185 | (is (= (ev "(best (of > len) '((a) (b c) (d e) (f)))") '(b c)))
186 | (is (= (ev "(do (thread (do (join 'a 'b)))
187 | (thread (do (join 'a 'b) (join 'b 'd))))")
188 | '(b . d)))
189 | (is (= (ev "(do (thread (do (join 'a 'b)))
190 | (thread
191 | (atomic (do (join 'a 'b) (join 'b 'd)))))")
192 | '(a . b)))
193 | (is (= (ev "(2 '(a b c))") 'b)))
194 |
--------------------------------------------------------------------------------
/test/bel_clojure/evaluator_test.clj:
--------------------------------------------------------------------------------
1 | (ns bel-clojure.evaluator-test
2 | (:refer-clojure :exclude [eval])
3 | (:require
4 | [bel-clojure.reader :as r]
5 | [clojure.test :refer :all]
6 | [bel-clojure.evaluator :refer :all]))
7 |
8 | (defn ev-all [env strs]
9 | (mapv r/bel->pretty (eval-all env strs)))
10 |
11 | (defn ev [& strs]
12 | (last (ev-all (env) strs)))
13 |
14 | (deftest test-evaluator
15 | (is (= (ev "nil") nil))
16 | (is (= (ev "\\b") \b))
17 | (is (= (ev "\"foo\"") "foo"))
18 | (is (= (ev "'foo") 'foo))
19 | (is (= (ev "(type globe)") 'mut-map))
20 | (is (= (ev "(type scope)") 'symbol))
21 | (is (= (ev "(lit (foo bar baz))") '(lit (foo bar baz))))
22 | (is (= (ev "car") '(lit prim car)))
23 | (is (= (ev "(set a 'b c 'd)" "c") 'd))
24 | (is (= (ev "(if t 'a 'b)") 'a))
25 | (is (= (ev "(if nil 'a 'b)") 'b))
26 | (is (= (ev "(if nil 'a nil 'b 'c)") 'c))
27 | (is (= (ev "(car '(a b))") 'a))
28 | (is (= (ev "(id t nil)") nil))
29 | (is (= (ev "(id t t)") 't))
30 | (is (= (ev "(id t)") nil))
31 | (is (= (ev "(id)") 't))
32 | (is (= (ev "((lit clo nil (x) (id x t)) t)")
33 | 't))
34 | (is (= (ev "((lit clo nil (x) (id x t)) nil)")
35 | nil))
36 | (is (= (ev "(apply join '(a b))")
37 | '(a . b)))
38 | (is (= (ev "(apply join 'a '(b))")
39 | '(a . b)))
40 | (is (= (ev "((lit clo nil (x (o y)) y) 'a)")
41 | nil))
42 | (is (= (ev "((lit clo nil (x (o y 'b)) y) 'a)")
43 | 'b))
44 | (is (= (ev
45 | ;; see source.bel
46 | "(set def (lit mac (lit clo nil (n p e) (join 'set (join n (join (join 'lit (join 'clo (join nil (join p (join e nil))))) nil))))))"
47 | "(def no (x) (id x nil))"
48 | "(no nil)")
49 | 't))
50 | (is (= (ev "(set a 'foo b '(bar baz))" "`(foo ',a ,@b)")
51 | '(foo (quote foo) bar baz)))
52 | (is (= (ev "(set x 'a)" "`(x ,x y)")
53 | '(x a y)))
54 | (is (= (ev "(set x 'a)" "`(x ,x y ,(id 'a 'a))")
55 | '(x a y t)))
56 | (is (= (ev "(set y '(c d))" "`(a b ,@y e f)")
57 | '(a b c d e f)))
58 | (is (= (take-last 2 (ev-all (env)
59 | ["(set x 'a)"
60 | "x"
61 | "(dyn x 'z (join x 'b))"
62 | "x"]))
63 | '((z . b) a)))
64 | (is (= (take-last 2 (ev-all (env)
65 | ["(join 'a (ccc (lit clo nil (c) (set cont c))))"
66 | "(cont 'b)"
67 | "(cont 'c)"]))
68 | '((a . b) (a . c))))
69 | (is (= (ev "(err \"something\")")
70 | '(lit error "something")))
71 | (is (= (take 2 (ev "(car 'a)")) '(lit error)))
72 | (is (= (ev
73 | "(dyn err (lit clo nil (x) 'hello) (car 'a))")
74 | 'hello))
75 | (is (= (ev "((lit clo nil ((t x (lit clo nil (x) (id t x)))) 'hello) t)")
76 | 'hello))
77 | (is (= (ev
78 | "((lit clo nil ((t x (lit clo nil (x) (id t x)))) 'hello) nil)")
79 | '(lit error (quote mistype))))
80 | (is (= (ev "1") 1))
81 | (is (= (ev "(+ 1 2.0)") 3.0))
82 | (is (= (ev "(num< 2 3)") 't))
83 | (is (= (ev "(abs -4)") 4))
84 | (is (= (ev "(+ 0.05 (/ 19 20))") 1.0))
85 | (is (= (ev "(int 1)") 't))
86 | (is (number? (ev "(hash \\b)")))
87 | (is (= (ev "(set x 'a)" "(where x)")
88 | '((x . a) d)))
89 | (is (= (ev "(where (car '(a b)))")
90 | '((a b) a)))
91 | (is (= (ev "(where (cdr '(a b)))")
92 | '((a b) d))))
93 |
--------------------------------------------------------------------------------
/test/bel_clojure/model_test.clj:
--------------------------------------------------------------------------------
1 | (ns bel-clojure.model-test
2 | (:refer-clojure :exclude [eval char? string? number? symbol? type])
3 | (:require
4 | [bel-clojure.reader :as r]
5 | [clojure.test :refer :all]
6 | [bel-clojure.model :refer :all]))
7 |
8 | (defn pretty-f [f & args]
9 | (r/bel->pretty (apply f (map r/parse args))))
10 |
11 | (deftest test-model
12 | (is (= (pretty-f id "a" "a") 't))
13 | (is (= (pretty-f id "a" "b") nil))
14 | (is (= (pretty-f id "(a)" "(a)") nil))
15 | (is (= (pretty-f join "a" "b") '(a . b)))
16 | (is (= (pretty-f car "(a b c)") 'a))
17 | (is (= (pretty-f car "nil") nil))
18 | (is (= (pretty-f car "\"foo\"") \f))
19 | (is (= (pretty-f cdr "(a . b)") 'b))
20 | (is (= (pretty-f cdr "(a b)") '(b)))
21 | (is (= (pretty-f cdr "nil") nil))
22 | (is (= (pretty-f cdr "\"foo\"") '(\o \o)))
23 | (is (= (pretty-f type "a") 'symbol))
24 | (is (= (pretty-f type "(a b)") 'pair))
25 | (is (= (pretty-f type "\\a") 'char))
26 | (is (= (pretty-f type "\"a\"") 'string))
27 | (let [p (r/parse "(a . b)")
28 | c (r/parse "c")]
29 | (xar p c)
30 | (is (= (car p) c)))
31 | (let [p (r/parse "(a . b)")
32 | c (r/parse "c")]
33 | (xdr p c)
34 | (is (= (cdr p) c)))
35 | (is (= (pretty-f sym "\"foo\"") 'foo))
36 | (is (= (pretty-f nom "foo") "foo"))
37 | (is (= (map-assoc bel-nil 'foo 1) {'foo 1}))
38 | (is (= (map-dissoc bel-nil {'foo 1}) bel-nil)))
39 |
--------------------------------------------------------------------------------
/test/bel_clojure/reader_test.clj:
--------------------------------------------------------------------------------
1 | (ns bel-clojure.reader-test
2 | (:require
3 | [clojure.test :refer :all]
4 | [bel-clojure.reader :refer :all]))
5 |
6 | (defn pretty-parse [x] (bel->pretty (parse x)))
7 |
8 | (deftest test-reader
9 | (is (= (pretty-parse "\"str\"") "str"))
10 | (is (= (pretty-parse "\"hello world\"") "hello world"))
11 | (is (= (pretty-parse "(a b c)") '(a b c)))
12 | (is (= (pretty-parse "_") '_))
13 | (is (= (pretty-parse "'+") '(quote +)))
14 | (is (= (pretty-parse "\\b") \b))
15 | (is (= (pretty-parse "(a . b)")
16 | '(a . b)))
17 | (is (= (pretty-parse "(a b . c)")
18 | '(a b . c)))
19 | (is (= (pretty-parse "()") nil))
20 | (is (= (pretty-parse "`(foo ,a ,@b)")
21 | '(bq (foo (cm a) (spl b)))))
22 | (is (= (pretty-parse "=") '=))
23 | (is (= (pretty-parse ">=") '>=))
24 | (is (= (pretty-parse "[id _ (car args)]")
25 | '(fn (_) (id _ (car args)))))
26 | (is (= (pretty-parse "(mac e1)")
27 | '(mac e1)))
28 | (is (= (pretty-parse "e1")
29 | 'e1))
30 | (is (= (pretty-parse "~cdr")
31 | '(compose no cdr)))
32 | (is (= (pretty-parse "car:cdr")
33 | '(compose car cdr)))
34 | (is (= (pretty-parse "car:cdr:cdr")
35 | '(compose car cdr cdr)))
36 | (is (= (pretty-parse "c|isa!cont")
37 | '(t c (isa (quote cont)))))
38 | (is (= (pretty-parse "!a")
39 | '(upon (quote a))))
40 | (is (= '(compose no f)
41 | (pretty-parse "~f")))
42 | (is (= (pretty-parse "x|~f:g!a")
43 | '(t x ((compose (compose no f) g) (quote a)))))
44 | (is (= (pretty-parse "~f:car")
45 | '(compose (compose no f) car)))
46 | (is (= (pretty-parse "car:i/")
47 | (list 'compose 'car (symbol "i/"))))
48 | (is (= (pretty-parse "i*") 'i*))
49 | (is (= (pretty-parse "i<") 'i<))
50 | (is (= (pretty-parse "i^") (symbol "i^")))
51 | (is (= (pretty-parse "a|b") '(t a b)))
52 | (is (= (pretty-parse "1") 1))
53 | (is (= (pretty-parse "1.05") 1.05))
54 | (is (= (pretty-parse "-1.05") -1.05))
55 | (is (= (pretty-parse "+0.05") 0.05))
56 | (is (= (pretty-parse "int?") 'int?)))
57 |
--------------------------------------------------------------------------------