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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
exception Unreachable and Unimplemented
fun $ (x, y) = x y
infixr 0 $
fun assert truth = if not truth then raise Unreachable else ()
(* All global values which computations may raise an exception must be
* wrapped in lazy, so that no exception is thrown before custom
* top-level handler is set.
*)
fun lazy thunk =
let
datatype 'a value =
Unevaluated of unit -> 'a |
Evaluated of 'a |
Exn of exn
val value = ref $ Unevaluated thunk
in
fn () =>
case !value of
Unevaluated th =>
let
val x = th () handle e => (value := Exn e; raise e)
in
value := Evaluated x;
x
end
| Evaluated v => v
| Exn e => raise e
end
structure Fold = struct
fun fold (a, f) g = g (a, f)
fun step0 h (a, f) = fold (h a, f)
fun step1 h (a, f) b = fold (h (b, a), f)
fun step2 h (a, f) b c = fold (h (b, c, a), f)
end
structure FRU = struct
fun next g (f, z) x = g (f x, z)
fun f1 (f, z) x = f (z x)
fun f2 z = next f1 z
fun f3 z = next f2 z
fun f4 z = next f3 z
fun f5 z = next f4 z
fun f6 z = next f5 z
fun f7 z = next f6 z
fun f8 z = next f7 z
fun f9 z = next f8 z
fun c0 from = from
fun c1 from = c0 from f1
fun c2 from = c1 from f2
fun c3 from = c2 from f3
fun c4 from = c3 from f4
fun c5 from = c4 from f5
fun c6 from = c5 from f6
fun c7 from = c6 from f7
fun c8 from = c7 from f8
fun c9 from = c8 from f9
fun makeUpdate cX (from, from', to) record =
let
fun ops () = cX from'
fun vars f = to f record
in
Fold.fold ((vars, ops), fn (vars, _) => vars from)
end
fun makeUpdate0 z = makeUpdate c0 z
fun makeUpdate1 z = makeUpdate c1 z
fun makeUpdate2 z = makeUpdate c2 z
fun makeUpdate3 z = makeUpdate c3 z
fun makeUpdate4 z = makeUpdate c4 z
fun makeUpdate5 z = makeUpdate c5 z
fun makeUpdate6 z = makeUpdate c6 z
fun makeUpdate7 z = makeUpdate c7 z
fun makeUpdate8 z = makeUpdate c8 z
fun makeUpdate9 z = makeUpdate c9 z
fun upd z = Fold.step2
(fn (s, f, (vars, ops)) =>
(fn out => vars (s (ops ()) (out, f)), ops)) z
fun set z = Fold.step2
(fn (s, v, (vars, ops)) =>
(fn out => vars (s (ops ()) (out, fn _ => v)), ops)) z
fun set2 s v = Fold.step0
(fn (vars, ops) => (fn out => vars (s (ops ()) (out, fn _ => v)), ops))
fun upd2 s f = Fold.step0
(fn (vars, ops) => (fn out => vars (s (ops ()) (out, f)), ops))
end
fun % (a, f) = f a
val s = FRU.set
val u = FRU.upd
fun sysExit code = Posix.Process.exit $ Word8.fromInt code
fun exit code = (
TextIO.closeOut TextIO.stdOut;
TextIO.closeOut TextIO.stdErr;
sysExit code
)
fun output stream s = TextIO.output (stream, s)
fun fprint stream g = Fold.fold ((false, output stream), fn _ => ()) g
fun printf g = fprint TextIO.stdOut g
fun sprintf g =
let
val buf = ref []
fun output s = (buf := s :: (!buf))
fun finish _ = String.concat (rev (!buf))
in
Fold.fold ((false, output), finish)
end g
fun Printf output g = Fold.fold ((false, output), fn _ => ()) g
local
fun ifF flag cl = if not flag then cl () else ()
in
fun ` z = Fold.step1 (fn (s, (ign, output)) =>
(ifF ign (fn () => output s); (ign, output))) z
fun A0 z = Fold.step1 (fn (f, (ign, output)) =>
(ifF ign (fn () => f output); (ign, output))) z
fun A1 z = Fold.step2 (fn (f, v, (ign, output)) =>
(ifF ign (fn () => f (output, v)); (ign, output))) z
end
fun Ign z = Fold.step0 (fn (_, output) => (true, output)) z
fun bind A f = fn z => Fold.fold z A f
fun bindWith2str to = bind A1 (fn (output, v) => output (to v))
val I = fn z => bindWith2str Int.toString z
val C = fn z => bindWith2str str z
val B = fn z => bindWith2str Bool.toString z
val R = fn z => bind A1 (fn (output, n) => app (fn f => f ())
(List.tabulate (n, fn _ => fn () => output "\t"))) z
type ('t, 'a, 'b) a1printer = (bool * (string -> unit)) * 'a -> 't ->
((bool * (string -> unit)) * 'a -> 'b) -> 'b
fun die code g =
let
fun finish (true, _) = raise Unreachable
| finish (false, output) = (
output "\n";
exit code
)
in
printf `"error: " (fn (a, _) => g (a, finish))
end
|
