1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
@(do
(macro-time
(defun bindable (obj)
(and obj
(symbolp obj)
(not (keywordp obj))
(not (eq t obj)))))
(defmacro txr-if (name args input : then else)
(let ((syms [keep-if bindable args])
(arg-exprs [mapcar [iffi symbolp (ret ^',@1)] args])
(result (gensym "res-"))
(bindings (gensym "bindings-"))
(insym (gensym "input-")))
^(let* ((,insym ,input)
(,result (match-fun ',name (list ,*arg-exprs)
(if (stringp ,insym) (list ,insym) ,insym)
nil)))
(if ,result
(let ((,bindings (car ,result)))
(let (,*[mapcar (ret ^(,@1 (cdr (assoc ',@1 ,bindings))))
syms])
,then))
,else))))
(defmacro txr-when (name args input . body)
^(txr-if ,name ,args ,input (progn ,*body)))
(defmacro txr-case-impl (sym . clauses)
(tree-case clauses
(((name args . body) . other-clauses)
(if (eq name t) :
^(txr-if ,name ,args ,sym
(progn ,*body)
(txr-case-impl ,sym ,*other-clauses))))
(((sym . rest) . other-clauses)
(if (eq sym t)
(if other-clauses
(error "txr-case: clauses after (t ...) clause ignored")
^(progn ,*rest))
(error "txr-case: bad syntax: ~s" (car clauses))))
(atom
(error "txr-case: unexpected atom in syntax: ~s" atom))))
(defmacro txr-case (input-expr . clauses)
(let ((input (gensym "input-")))
^(let ((,input ,input-expr))
(txr-case-impl ,input ,*clauses)))))
|
