Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2004-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * | |
4 | * MLton is released under a BSD-style license. | |
5 | * See the file MLton-LICENSE for details. | |
6 | *) | |
7 | ||
8 | structure List = | |
9 | struct | |
10 | open List | |
11 | ||
12 | fun sort f l = | |
13 | let | |
14 | fun qsort l = | |
15 | case l of | |
16 | [] => [] | |
17 | | hd::tl => | |
18 | let | |
19 | val (lt,eq,gt) = | |
20 | List.foldr | |
21 | (fn (x,(lt,eq,gt)) => | |
22 | case f (x,hd) of | |
23 | LESS => (x::lt,eq,gt) | |
24 | | EQUAL => (lt,x::eq,gt) | |
25 | | GREATER => (lt,eq,x::gt)) | |
26 | ([],[],[]) | |
27 | tl | |
28 | val lt = qsort lt | |
29 | val gt = qsort gt | |
30 | in | |
31 | lt @ (hd :: eq) @ gt | |
32 | end | |
33 | in | |
34 | qsort l | |
35 | end | |
36 | end | |
37 | ||
38 | structure Substring = | |
39 | struct | |
40 | open Substring | |
41 | ||
42 | fun droplSpace ss = | |
43 | dropl Char.isSpace ss | |
44 | fun droprSpace ss = | |
45 | dropr Char.isSpace ss | |
46 | ||
47 | end | |
48 | ||
49 | structure Name = | |
50 | struct | |
51 | datatype t = T of string list | |
52 | ||
53 | fun compare (T ss1, T ss2) = | |
54 | List.collate | |
55 | (fn (s1,s2) => | |
56 | String.compare (CharVector.map Char.toLower s1, | |
57 | CharVector.map Char.toLower s2)) | |
58 | (ss1, ss2) | |
59 | ||
60 | fun last (T ss) = List.last ss | |
61 | fun toC (T ss) = | |
62 | String.concatWith "_" ss | |
63 | fun toML (T ss) = | |
64 | String.concatWith "." ss | |
65 | ||
66 | fun parse ss = | |
67 | let | |
68 | val ss = Substring.droplSpace ss | |
69 | val (names, rest) = | |
70 | Substring.splitl | |
71 | (fn c => Char.isAlphaNum c | |
72 | orelse c = #"." orelse c = #"_") | |
73 | ss | |
74 | val rest = Substring.droplSpace rest | |
75 | in | |
76 | if Substring.isEmpty names | |
77 | then NONE | |
78 | else let | |
79 | val names = Substring.fields (fn c => #"." = c) names | |
80 | val names = List.map Substring.string names | |
81 | in | |
82 | SOME (T names, rest) | |
83 | end | |
84 | end | |
85 | end | |
86 | ||
87 | ||
88 | structure Type = | |
89 | struct | |
90 | datatype t = | |
91 | Array of t | |
92 | | Base of Name.t | |
93 | | Con of Name.t * t | |
94 | | Ref of t | |
95 | | Unit | |
96 | | Vector of t | |
97 | ||
98 | fun toC t = | |
99 | case t of | |
100 | Array t => concat ["Array(", toC t, ")"] | |
101 | | Base name => Name.toC name | |
102 | | Con (name, t) => concat [Name.toC name, "(", toC t, ")"] | |
103 | | Ref t => concat ["Ref(", toC t, ")"] | |
104 | | Unit => "void" | |
105 | | Vector t => concat ["Vector(", toC t, ")"] | |
106 | fun toML t = | |
107 | case t of | |
108 | Array t => concat ["(", toML t, ") array"] | |
109 | | Base name => Name.toML name | |
110 | | Con (name, t) => concat ["(", toML t, ") ", Name.toML name] | |
111 | | Ref t => concat ["(", toML t, ") ref"] | |
112 | | Unit => "unit" | |
113 | | Vector t => concat ["(", toML t, ") vector"] | |
114 | ||
115 | fun parse s = | |
116 | let | |
117 | fun loop (s, t) = | |
118 | case Name.parse s of | |
119 | NONE => (t, s) | |
120 | | SOME (Name.T ["array"], rest) => loop (rest, Array t) | |
121 | | SOME (Name.T ["ref"], rest) => loop (rest, Ref t) | |
122 | | SOME (Name.T ["vector"], rest) => loop (rest, Vector t) | |
123 | | SOME (name, rest) => loop (rest, Con (name, t)) | |
124 | in | |
125 | case Name.parse s of | |
126 | NONE => raise Fail (concat ["Type.parse: \"", Substring.string s, "\""]) | |
127 | | SOME (Name.T ["unit"], rest) => loop (rest, Unit) | |
128 | | SOME (name, rest) => loop (rest, Base name) | |
129 | end | |
130 | ||
131 | fun parseFn s = | |
132 | let | |
133 | fun loop (s, args) = | |
134 | let | |
135 | val (arg, rest) = parse s | |
136 | in | |
137 | if Substring.isPrefix "*" rest | |
138 | then let | |
139 | val rest = #2 (Substring.splitAt (rest, 1)) | |
140 | in | |
141 | loop (rest, arg::args) | |
142 | end | |
143 | else if Substring.isPrefix "->" rest | |
144 | then let | |
145 | val rest = #2 (Substring.splitAt (rest, 2)) | |
146 | val (ret, rest) = parse rest | |
147 | in | |
148 | ({args = List.rev (arg::args), | |
149 | ret = ret}, | |
150 | rest) | |
151 | end | |
152 | else raise Fail (concat ["Type.parseFn: \"", Substring.string s, "\""]) | |
153 | end | |
154 | in | |
155 | loop (s, []) | |
156 | end | |
157 | end | |
158 | ||
159 | structure Entry = | |
160 | struct | |
161 | datatype t = | |
162 | Const of {name: Name.t, | |
163 | ty: Type.t} | |
164 | | Import of {attrs: string, | |
165 | name: Name.t, | |
166 | ty: {args: Type.t list, | |
167 | ret: Type.t}} | |
168 | | Symbol of {name: Name.t, | |
169 | ty: Type.t} | |
170 | ||
171 | fun name entry = | |
172 | case entry of | |
173 | Const {name,...} => name | |
174 | | Import {name,...} => name | |
175 | | Symbol {name,...} => name | |
176 | ||
177 | fun compare (entry1, entry2) = | |
178 | Name.compare (name entry1, name entry2) | |
179 | ||
180 | fun toC entry = | |
181 | case entry of | |
182 | Const {name, ty} => | |
183 | String.concat | |
184 | ["PRIVATE extern const ", | |
185 | Type.toC ty, | |
186 | " ", | |
187 | Name.toC name, | |
188 | ";"] | |
189 | | Import {attrs, name, ty = {args, ret}} => | |
190 | String.concat | |
191 | [attrs, | |
192 | if String.size attrs > 0 then " " else "", | |
193 | Type.toC ret, | |
194 | " ", | |
195 | Name.toC name, | |
196 | "(", | |
197 | String.concatWith "," (List.map Type.toC args), | |
198 | ");"] | |
199 | | Symbol {name, ty} => | |
200 | String.concat | |
201 | ["PRIVATE extern ", | |
202 | Type.toC ty, | |
203 | " ", | |
204 | Name.toC name, | |
205 | ";"] | |
206 | fun toML entry = | |
207 | case entry of | |
208 | Const {name, ty} => | |
209 | String.concat | |
210 | ["val ", | |
211 | Name.last name, | |
212 | " = _const \"", | |
213 | Name.toC name, | |
214 | "\" : ", | |
215 | Type.toML ty, | |
216 | ";"] | |
217 | | Import {attrs, name, ty = {args, ret}} => | |
218 | String.concat | |
219 | ["val ", | |
220 | Name.last name, | |
221 | " = _import \"", | |
222 | Name.toC name, | |
223 | "\" private : ", | |
224 | String.concatWith " * " (List.map Type.toML args), | |
225 | " -> ", | |
226 | Type.toML ret, | |
227 | ";"] | |
228 | | Symbol {name, ty} => | |
229 | String.concat | |
230 | ["val (", | |
231 | Name.last name, | |
232 | "Get, ", | |
233 | Name.last name, | |
234 | "Set) = _symbol \"", | |
235 | Name.toC name, | |
236 | "\" private : (unit -> (", | |
237 | Type.toML ty, | |
238 | ")) * ((", | |
239 | Type.toML ty, | |
240 | ") -> unit);"] | |
241 | ||
242 | fun parseConst (s, name) = | |
243 | let | |
244 | val s = #2 (Substring.splitAt (s, 6)) | |
245 | val s = Substring.droplSpace s | |
246 | val s = if Substring.isPrefix ":" s | |
247 | then #2 (Substring.splitAt (s, 1)) | |
248 | else raise Fail (concat ["Entry.parseConst: \"", Substring.string s, "\""]) | |
249 | val (ret, rest) = Type.parse s | |
250 | val () = if Substring.isEmpty rest | |
251 | then () | |
252 | else raise Fail (concat ["Entry.parseConst: \"", Substring.string s, "\""]) | |
253 | in | |
254 | Const {name = name, | |
255 | ty = ret} | |
256 | end | |
257 | ||
258 | fun parseImport (s, name) = | |
259 | let | |
260 | val s = #2 (Substring.splitAt (s, 7)) | |
261 | val s = Substring.droplSpace s | |
262 | val (attrs, s) = | |
263 | case CharVectorSlice.findi (fn (_, c) => c = #":") s of | |
264 | NONE => raise Fail (concat ["Entry.parseImport: \"", Substring.string s, "\""]) | |
265 | | SOME (i, _) => Substring.splitAt (s, i) | |
266 | val attrs = Substring.droprSpace attrs | |
267 | val s = if Substring.isPrefix ":" s | |
268 | then #2 (Substring.splitAt (s, 1)) | |
269 | else raise Fail (concat ["Entry.parseImport: \"", Substring.string s, "\""]) | |
270 | val ({args, ret}, rest) = Type.parseFn s | |
271 | val () = if Substring.isEmpty rest | |
272 | then () | |
273 | else raise Fail (concat ["Entry.parseImport: \"", Substring.string s, "\""]) | |
274 | in | |
275 | Import {attrs = Substring.string attrs, | |
276 | name = name, | |
277 | ty = {args = args, ret = ret}} | |
278 | end | |
279 | ||
280 | fun parseSymbol (s, name) = | |
281 | let | |
282 | val s = #2 (Substring.splitAt (s, 7)) | |
283 | val s = Substring.droplSpace s | |
284 | val s = if Substring.isPrefix ":" s | |
285 | then #2 (Substring.splitAt (s, 1)) | |
286 | else raise Fail (concat ["Entry.parseSymbol: \"", Substring.string s, "\""]) | |
287 | val (ret, rest) = Type.parse s | |
288 | val () = if Substring.isEmpty rest | |
289 | then () | |
290 | else raise Fail (concat ["Entry.parseSymbol: \"", Substring.string s, "\""]) | |
291 | in | |
292 | Symbol {name = name, | |
293 | ty = ret} | |
294 | end | |
295 | ||
296 | fun parse s = | |
297 | case Name.parse s of | |
298 | NONE => raise Fail "Entry.parse" | |
299 | | SOME (name, rest) => | |
300 | if Substring.isPrefix "=" rest | |
301 | then let | |
302 | val rest = #2 (Substring.splitAt (rest, 1)) | |
303 | val rest = Substring.droplSpace rest | |
304 | in | |
305 | if Substring.isPrefix "_const" rest | |
306 | then parseConst (rest, name) | |
307 | else if Substring.isPrefix "_import" rest | |
308 | then parseImport (rest, name) | |
309 | else if Substring.isPrefix "_symbol" rest | |
310 | then parseSymbol (rest, name) | |
311 | else raise Fail (concat ["Entry.parse: \"", Substring.string s, "\""]) | |
312 | end | |
313 | else raise Fail (concat ["Entry.parse: \"", Substring.string s, "\""]) | |
314 | end | |
315 | ||
316 | val entries = | |
317 | let | |
318 | val f = TextIO.openIn "basis-ffi.def" | |
319 | fun loop entries = | |
320 | case TextIO.inputLine f of | |
321 | NONE => List.rev entries | |
322 | | SOME s => | |
323 | if String.isPrefix "#" s | |
324 | then loop entries | |
325 | else let | |
326 | val entry = Entry.parse (Substring.full s) | |
327 | in | |
328 | loop (entry :: entries) | |
329 | end | |
330 | val entries = loop [] | |
331 | val () = TextIO.closeIn f | |
332 | val entries = List.sort Entry.compare entries | |
333 | in | |
334 | entries | |
335 | end | |
336 | ||
337 | fun outputC entries = | |
338 | let | |
339 | val f = TextIO.openOut "basis-ffi.h" | |
340 | fun print s = TextIO.output (f, s) | |
341 | fun println s = if s <> "" then (print s; print "\n") else () | |
342 | ||
343 | val () = println "/* This file is automatically generated. Do not edit. */\n\n" | |
344 | val () = println "#ifndef _MLTON_BASIS_FFI_H_\n" | |
345 | val () = println "#define _MLTON_BASIS_FFI_H_\n" | |
346 | val () = List.app (fn entry => println (Entry.toC entry)) entries | |
347 | val () = println "#endif /* _MLTON_BASIS_FFI_H_ */" | |
348 | val () = TextIO.closeOut f | |
349 | in | |
350 | () | |
351 | end | |
352 | ||
353 | fun outputML entries = | |
354 | let | |
355 | val f = TextIO.openOut "basis-ffi.sml" | |
356 | fun print s = TextIO.output (f, s) | |
357 | fun println s = if s <> "" then (print s; print "\n") else () | |
358 | ||
359 | val primStrs = | |
360 | (List.map (fn n => "Char" ^ n) ["8", "16", "32"]) @ | |
361 | (List.map (fn n => "Int" ^ n) ["8", "16", "32", "64"]) @ | |
362 | (List.map (fn n => "Real" ^ n) ["32", "64"]) @ | |
363 | (List.map (fn n => "Word" ^ n) ["8", "16", "32", "64"]) | |
364 | ||
365 | val () = println "(* This file is automatically generated. Do not edit. *)\n" | |
366 | val () = println "local open Primitive in " | |
367 | val () = println "structure PrimitiveFFI =" | |
368 | val () = println "struct" | |
369 | val cur = | |
370 | List.foldl | |
371 | (fn (entry, cur) => | |
372 | let | |
373 | val Name.T names = Entry.name entry | |
374 | val str = List.rev (List.tl (List.rev names)) | |
375 | fun loop (cur, str) = | |
376 | case (cur, str) of | |
377 | ([], []) => () | |
378 | | ([], str) => | |
379 | List.app (fn s => | |
380 | (println ("structure " ^ s ^ " = ") | |
381 | ; println "struct" | |
382 | ; if List.exists (fn s' => s = s') primStrs | |
383 | then println ("type t = " ^ s ^ ".t") | |
384 | else ())) | |
385 | str | |
386 | | (cur, []) => | |
387 | List.app (fn _ => println "end") cur | |
388 | | (c::cur,s::str) => | |
389 | if c = s | |
390 | then loop (cur, str) | |
391 | else (println "end" | |
392 | ; loop (cur, s::str)) | |
393 | in | |
394 | loop (cur, str) | |
395 | ; println (Entry.toML entry) | |
396 | ; str | |
397 | end) | |
398 | [] | |
399 | entries | |
400 | val () = List.app (fn _ => println "end") cur | |
401 | val () = println "end" | |
402 | val () = println "end" | |
403 | val () = TextIO.closeOut f | |
404 | in | |
405 | () | |
406 | end | |
407 | ||
408 | val () = outputC entries | |
409 | val () = outputML entries |