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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
(defun expand-pic-num (fmt val)
(let* ((zero (or (starts-with "0" fmt)
(starts-with "+0" fmt)
(starts-with "-0" fmt)))
(plus (eql [fmt 0] #\+))
(minus (eql [fmt 0] #\-))
(exc (pos #\! fmt))
(dot (or exc (pos #\. fmt)))
(fmt (if (and exc (eq #\! [fmt -1])) [fmt 0..-1] fmt))
(int (if dot [fmt 0..dot] fmt))
(fra (if dot [fmt (succ dot)..:] "")))
(let ((code (if (or minus plus (not zero))
^(fmt ,`~@(len fmt),@(if plus "+")@(if zero "0")@(len fra)f`
,val)
^(fmt ,`~@(len fmt),-0@(len fra)f`
,val))))
(if exc
(with-gensyms (str)
^(let ((,str ,code))
(if (> (len ,str) ,(len fmt))
,(mkstring (len fmt) #\#)
,str)))
code))))
(defun expand-pic-align (chr fmt val)
^(fmt ,`~@(if chr chr)@(len fmt)a` ,val))
(defun pic-join-opt (join-form)
(labels ((et (str) (regsub #/\~/ "~~" str)))
(match-case join-form
((join @(stringp @s) (fmt `@fmt` . @args) . @rest)
(pic-join-opt ^(join (fmt ,`@(et s)@fmt` ,*args) ,*rest)))
((join (fmt `@fmt` . @args) @(stringp @s) . @rest)
(pic-join-opt ^(join (fmt ,`@fmt@(et s)` ,*args) ,*rest)))
((join (fmt `@fmt1` . @args1) (fmt `@fmt2` . @args2) . @rest)
(pic-join-opt ^(join (fmt ,`@fmt1@fmt2` ,*args1 ,*args2) ,*rest)))
((join @(stringp @s1) @(stringp @s2) . @rest)
(pic-join-opt ^(join ,`@s1@s2` ,*rest)))
((join "" @item . @rest)
(pic-join-opt ^(join ,item ,*rest)))
((join @item "" . @rest)
(pic-join-opt ^(join ,item ,*rest)))
((join @item) item)
(@else else))))
(defun expand-pic (f fmt val)
(unless (stringp fmt)
(compile-error f "~s is required to be a format string" fmt))
(cond
([m^$ #/\~[~#<>\|\-+0.!]/ fmt] [fmt 1..2])
([m^$ #/\~./ fmt] (compile-error f "unrecognized escape sequence ~a" fmt))
([m^$ #/\~/ fmt] (compile-error f "incomplete ~~ escape"))
([m^$ #/[+\-]?0?#+([.!]#+|!)?/ fmt] (expand-pic-num fmt val))
([m^$ #/<+/ fmt] (expand-pic-align "<" fmt val))
([m^$ #/>+/ fmt] (expand-pic-align nil fmt val))
([m^$ #/\|+/ fmt] (expand-pic-align "^" fmt val))
(t (compile-error f "unrecognized format string ~s" fmt))))
(defmacro pic (:form f :env e bigfmt . args)
(let* ((regex #/[+\-]?0?#+([.!]#+|!)?| \
<+| \
>+| \
\|+| \
\~.|\~/))
(labels ((pic-compile-string (fmtstr)
(let ((items (collect-each ((piece (tok regex t fmtstr)))
(cond
((m^$ regex piece)
(cond
((starts-with "~" piece)
(expand-pic f piece nil))
(args
(expand-pic f piece (pop args)))
(t (compile-error
f "insufficient arguments for format"))))
(t piece)))))
(pic-join-opt ^(join ,*items)))))
(match-case bigfmt
(@(stringp @s)
(let ((out (pic-compile-string s)))
(if args
(compile-warning f "excess arguments"))
out))
((@(or sys:quasi) . @qargs)
(let ((nqargs (build (each ((q qargs))
(if (stringp q)
(add (pic-compile-string q))
(add q))))))
(if args
(compile-warning f "excess arguments"))
^(sys:quasi ,*nqargs)))
(@else (compile-error
f "~s is required to be a string or quasiliteral" else))))))
|