Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/ml-nlffigen/gen.sml
ViewVC logotype

Annotation of /sml/trunk/src/ml-nlffigen/gen.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1742 - (view) (download)

1 : blume 828 (*
2 : mblume 1548 * gen.sml - Generating and pretty-printing ML code implementing a
3 :     * typed interface to a C program.
4 : blume 828 *
5 : mblume 1548 * (C) 2004 The Fellowship of SML/NJ
6 : blume 828 *
7 : mblume 1548 * author: Matthias Blume (blume@tti-c.org)
8 : blume 828 *)
9 :     local
10 : blume 1062 val program = "ml-nlffigen"
11 : mblume 1548 val version = "0.9.1"
12 : blume 828 val author = "Matthias Blume"
13 : mblume 1548 val email = "blume@tti-c.org"
14 : blume 828 structure S = Spec
15 :     in
16 :    
17 :     structure Gen :> sig
18 : blume 1011 val gen : { cfiles: string list,
19 : blume 1036 match: string -> bool,
20 : blume 1011 mkidlsource: string -> string,
21 :     dirname: string,
22 :     cmfile: string,
23 :     prefix: string,
24 : blume 1060 gensym_stem: string,
25 : blume 1011 extramembers: string list,
26 :     libraryhandle: string,
27 :    
28 : blume 828 allSU: bool,
29 : blume 1137 smloptions: string list,
30 :     noguid: bool,
31 : blume 840 wid: int,
32 : blume 975 weightreq: bool option, (* true -> heavy, false -> light *)
33 : blume 977 namedargs: bool,
34 : blume 1096 collect_enums: bool,
35 :     enumcons: bool,
36 : blume 840 target : { name : string,
37 :     sizes : Sizes.sizes,
38 : blume 1078 shift : int * int * word -> word } } -> unit
39 : blume 1036 val version : string
40 : blume 828 end = struct
41 :    
42 : blume 1036 val version = version
43 :    
44 : blume 1062 structure SS = StringSet
45 :     structure SM = StringMap
46 :     structure IM = IntRedBlackMap
47 : blume 1096 structure LIS = RedBlackSetFn (type ord_key = LargeInt.int
48 :     val compare = LargeInt.compare)
49 : blume 1062
50 : blume 1096
51 : blume 828 structure P = PrettyPrint
52 :     structure PP = P.PP
53 :     val Tuple = P.TUPLE
54 : blume 975 fun Record [] = P.Unit
55 :     | Record l = P.RECORD l
56 : blume 828 val Con = P.CON
57 :     val Arrow = P.ARROW
58 :     val Type = P.Type
59 :     val Unit = P.Unit
60 :     val ETuple = P.ETUPLE
61 : blume 1011 val EUnit = ETuple []
62 : blume 975 fun ERecord [] = P.ETUPLE []
63 :     | ERecord l = P.ERECORD l
64 : blume 828 val EVar = P.EVAR
65 :     val EApp = P.EAPP
66 :     val EConstr = P.ECONSTR
67 :     val ESeq = P.ESEQ
68 :     fun EWord w = EVar ("0wx" ^ Word.toString w)
69 :     fun EInt i = EVar (Int.toString i)
70 : blume 975 fun ELInt i = EVar (LargeInt.toString i)
71 : blume 828 fun EString s = EVar (concat ["\"", String.toString s, "\""])
72 :    
73 : blume 1096 fun warn m = TextIO.output (TextIO.stdErr, "warning: " ^ m)
74 : mblume 1559 fun err m = raise Fail (concat ("gen: " :: m))
75 : blume 975
76 : blume 1096 fun unimp what = raise Fail ("unimplemented type: " ^ what)
77 :     fun unimp_arg what = raise Fail ("unimplemented argument type: " ^ what)
78 :     fun unimp_res what = raise Fail ("unimplemented result type: " ^ what)
79 : blume 975
80 : blume 1096 val writeto = "write'to"
81 :    
82 : blume 828 val dontedit = "(* This file has been generated automatically. \
83 :     \DO NOT EDIT! *)"
84 : blume 1011
85 :     fun mkCredits archos =
86 :     concat ["(* [by ", author, "'s ",
87 : blume 840 program, " (version ", version, ") for ",
88 :     archos, "] *)"]
89 : blume 828 val commentsto = concat ["(* Send comments and suggestions to ",
90 :     email, ". Thanks! *)"]
91 :    
92 : blume 1011
93 :     fun fptr_rtti_struct_id i = "FPtrRTTI_" ^ Int.toString i
94 :     fun fptr_rtti_qid i = fptr_rtti_struct_id i ^ ".typ"
95 :     fun fptr_mkcall_qid i = fptr_rtti_struct_id i ^ ".mkcall"
96 :    
97 : blume 1096 fun SUE_Tstruct K t = concat [K, "T_", t]
98 :     val STstruct = SUE_Tstruct "S"
99 :     val UTstruct = SUE_Tstruct "U"
100 : blume 1011
101 : blume 1096 fun SUE_tag K tag = Type (SUE_Tstruct K tag ^ ".tag")
102 :    
103 : blume 977 fun fieldtype_id n = "t_f_" ^ n
104 :     fun fieldrtti_id n = "typ_f_" ^ n
105 :     fun field_id (n, p) = concat ["f_", n, p]
106 : blume 1011
107 :     fun arg_id s = "a_" ^ s
108 : blume 977 fun enum_id n = "e_" ^ n
109 :    
110 : blume 1062 val $? = SM.find
111 :    
112 :     val %? = IM.find
113 :    
114 :     fun thetag (t: S.tag) t' = t = t'
115 :    
116 : blume 828 fun gen args = let
117 : blume 1060 val { cfiles, match, mkidlsource, gensym_stem,
118 : blume 1096 dirname,
119 :     cmfile, prefix, extramembers, libraryhandle,
120 : blume 1137 allSU, smloptions, noguid,
121 : blume 840 wid,
122 : blume 975 weightreq,
123 : blume 977 namedargs = doargnames,
124 : blume 1096 collect_enums, enumcons,
125 : blume 1078 target = { name = archos, sizes, shift } } = args
126 : blume 828
127 : blume 1096 val St = SUE_tag "S"
128 :     val Un = SUE_tag "U"
129 :     fun En (tag, anon) =
130 :     if collect_enums andalso anon then SUE_tag "E" "'"
131 :     else SUE_tag "E" tag
132 :    
133 : blume 1062 val hash_cft = Hash.mkFHasher ()
134 :     val hash_mltype = Hash.mkTHasher ()
135 :    
136 : blume 1067 val gensym_suffix = if gensym_stem = "" then "" else "_" ^ gensym_stem
137 :    
138 : blume 1096 fun SUEstruct K t = concat [prefix, K, "_", t]
139 :     val Sstruct = SUEstruct "S"
140 :     val Ustruct = SUEstruct "U"
141 :     val Estruct = SUEstruct "E"
142 : blume 1011 fun Tstruct n = concat [prefix, "T_", n]
143 :     fun Gstruct n = concat [prefix, "G_", n]
144 :     fun Fstruct n = concat [prefix, "F_", n]
145 : blume 1096 fun Estruct' (n, anon) =
146 :     Estruct (if anon andalso collect_enums then "'" else n)
147 : blume 1011
148 : blume 1096 fun Styp t = STstruct t ^ ".typ"
149 :     fun Utyp t = UTstruct t ^ ".typ"
150 :    
151 : blume 975 val (doheavy, dolight) =
152 :     case weightreq of
153 :     NONE => (true, true)
154 :     | SOME true => (true, false)
155 :     | SOME false => (false, true)
156 :    
157 : blume 1011 val credits = mkCredits archos
158 : blume 828
159 : blume 1011 fun getSpec (cfile, s) = let
160 :     val idlsource = mkidlsource cfile
161 :     in
162 :     (let val astbundle = ParseToAst.fileToAst'
163 :     TextIO.stdErr
164 :     (sizes, State.INITIAL)
165 :     idlsource
166 :     val s' =
167 : blume 1096 AstToSpec.build { bundle = astbundle,
168 :     sizes = sizes,
169 :     collect_enums = collect_enums,
170 :     cfiles = cfiles,
171 :     match = match,
172 :     allSU = allSU,
173 :     eshift = shift,
174 :     gensym_suffix = gensym_suffix }
175 : blume 1011 in
176 :     S.join (s', s)
177 :     end handle e => (OS.FileSys.remove idlsource handle _ => ();
178 :     raise e))
179 :     before (OS.FileSys.remove idlsource handle _ => ())
180 :     end
181 : blume 828
182 : blume 1011 val spec = foldl getSpec S.empty cfiles
183 : blume 828
184 : blume 975 val { structs, unions, gvars, gfuns, gtys, enums } = spec
185 : blume 828
186 : blume 1096 val do_dir = let
187 : blume 1011 val done = ref false
188 :     fun doit () =
189 :     if !done then ()
190 :     else (done := true;
191 : blume 1096 if OS.FileSys.isDir dirname handle _ => false then ()
192 :     else OS.FileSys.mkDir dirname)
193 : blume 1011 in
194 :     doit
195 :     end
196 : blume 828
197 : blume 1011 val files = ref extramembers (* all files that should go
198 :     * into the .cm description *)
199 :     val exports = ref []
200 :    
201 : blume 1067 (* we don't want apostrophes in file names -> turn them into minuses *)
202 :     fun noquotes x = String.translate(fn #"'" => "-" | c => String.str c) x
203 :    
204 : blume 1011 fun smlfile x = let
205 : blume 1067 val nqx = noquotes x
206 :     val file = OS.Path.joinBaseExt { base = nqx, ext = SOME "sml" }
207 : blume 1011 val result = OS.Path.joinDirFile { dir = dirname, file = file }
208 : blume 1137 val opts = if noguid then "noguid" :: smloptions else smloptions
209 :     val opt =
210 :     case opts of
211 :     [] => ""
212 :     | h :: t => concat ("(" :: h :: foldr
213 :     (fn (x, l) => " " :: x :: l)
214 :     [")"] t)
215 : blume 1011 in
216 : blume 1137 files := file ^ opt :: !files;
217 : blume 1096 do_dir ();
218 : blume 1011 result
219 :     end
220 :    
221 :     fun descrfile file = let
222 :     val result = OS.Path.joinDirFile { dir = dirname, file = file }
223 :     in
224 : blume 1096 do_dir ();
225 : blume 1011 result
226 :     end
227 :    
228 : blume 1062 val structs =
229 :     foldl (fn (s, m) => SM.insert (m, #tag s, s)) SM.empty structs
230 :    
231 :     val unions =
232 :     foldl (fn (u, m) => SM.insert (m, #tag u, u)) SM.empty unions
233 :    
234 : blume 1096 val enums =
235 :     foldl (fn (e, m) => SM.insert (m, #tag e, e)) SM.empty enums
236 :    
237 :     val (structs, unions, enums) = let
238 : blume 1062 val sdone = ref SS.empty
239 :     val udone = ref SS.empty
240 : blume 1096 val edone = ref SS.empty
241 : blume 1062 val smap = ref SM.empty
242 :     val umap = ref SM.empty
243 : blume 1096 val emap = ref SM.empty
244 : blume 1036 val tq = ref []
245 :     fun ty_sched t = tq := t :: !tq
246 :     fun fs_sched (S.OFIELD { spec = (_, t), ... }) = ty_sched t
247 :     | fs_sched _ = ()
248 :     fun f_sched { name, spec } = fs_sched spec
249 : blume 1062
250 : blume 1096 fun xenter (xdone, xall, xmap, xfields) t =
251 :     if SS.member (!xdone, t) then ()
252 :     else (xdone := SS.add (!xdone, t);
253 :     case $? (xall, t) of
254 :     SOME x => (xmap := SM.insert (!xmap, t, x);
255 :     app f_sched (xfields x))
256 : blume 1036 | NONE => ())
257 : blume 1062
258 : blume 1096 val senter = xenter (sdone, structs, smap, #fields)
259 : mblume 1548 val uenter = xenter (udone, unions, umap, #all)
260 : blume 1096 val eenter = xenter (edone, enums, emap, fn _ => [])
261 : blume 1062
262 : blume 1096 fun sinclude (s: S.s) = if #exclude s then () else senter (#tag s)
263 :     fun uinclude (u: S.u) = if #exclude u then () else uenter (#tag u)
264 :     fun einclude (e: S.enum) =
265 :     if #exclude e then () else eenter (#tag e)
266 :    
267 : blume 1036 fun gty { src, name, spec } = ty_sched spec
268 :     fun gvar { src, name, spec = (_, t) } = ty_sched t
269 :     fun gfun { src, name, spec, argnames } = ty_sched (S.FPTR spec)
270 :     fun loop [] = ()
271 :     | loop tl = let
272 : blume 1062 fun ty (S.STRUCT t) = senter t
273 :     | ty (S.UNION t) = uenter t
274 : blume 1096 | ty (S.ENUM (t, anon)) =
275 :     if collect_enums andalso anon then eenter "'"
276 :     else eenter t
277 : blume 1062 | ty (S.PTR (_, S.STRUCT t)) = ()
278 :     | ty (S.PTR (_, S.UNION t)) = ()
279 : blume 1036 | ty (S.PTR (_, t)) = ty t
280 :     | ty (S.FPTR { args, res }) =
281 : blume 1062 (app ty args; Option.app ty res)
282 : blume 1036 | ty (S.ARR { t, ... }) = ty t
283 : blume 1096 | ty (S.UNIMPLEMENTED _) = ()
284 : blume 1036 | ty (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
285 :     S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
286 : mblume 1742 S.SLONGLONG | S.ULONGLONG |
287 : blume 1036 S.FLOAT | S.DOUBLE | S.VOIDPTR) = ()
288 :     fun tloop [] = nextround ()
289 :     | tloop (t :: ts) = (ty t; tloop ts)
290 :     in
291 :     tq := [];
292 :     tloop tl
293 :     end
294 :     and nextround () = loop (!tq)
295 :     in
296 : blume 1062 SM.app sinclude structs;
297 :     SM.app uinclude unions;
298 : mblume 1570 SM.app einclude enums;
299 : blume 1036 app gty gtys;
300 :     app gvar gvars;
301 :     app gfun gfuns;
302 :     nextround ();
303 : blume 1096 (!smap, !umap, !emap)
304 : blume 1036 end
305 :    
306 : blume 828 fun stem S.SCHAR = "schar"
307 :     | stem S.UCHAR = "uchar"
308 :     | stem S.SINT = "sint"
309 :     | stem S.UINT = "uint"
310 :     | stem S.SSHORT = "sshort"
311 :     | stem S.USHORT = "ushort"
312 :     | stem S.SLONG = "slong"
313 :     | stem S.ULONG = "ulong"
314 : mblume 1742 | stem S.SLONGLONG = "slonglong"
315 :     | stem S.ULONGLONG = "ulonglong"
316 : blume 828 | stem S.FLOAT = "float"
317 :     | stem S.DOUBLE = "double"
318 :     | stem S.VOIDPTR = "voidptr"
319 :     | stem _ = raise Fail "bad stem"
320 :    
321 : blume 1062 fun taginsert (t, ss) =
322 : blume 1096 if SS.member (ss, t) then ss else SS.add (ss, t)
323 : blume 828
324 :     (* We don't expect many different function pointer types or
325 :     * incomplete types in any given C interface, so using linear
326 :     * lists here is probably ok. *)
327 : blume 1096 val (fptr_types,
328 :     incomplete_structs, incomplete_unions, incomplete_enums) = let
329 : blume 828 fun ty ((S.SCHAR | S.UCHAR | S.SINT | S.UINT |
330 : mblume 1742 S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
331 :     S.SLONGLONG | S.ULONGLONG | S.FLOAT | S.DOUBLE |
332 : blume 828 S.VOIDPTR), a) = a
333 : blume 1096 | ty (S.STRUCT t, a as (f, s, u, e)) =
334 :     (case $? (structs, t) of
335 :     SOME _ => a
336 :     | NONE => (f, taginsert (t, s), u, e))
337 :     | ty (S.UNION t, a as (f, s, u, e)) =
338 :     (case $? (unions, t) of
339 :     SOME _ => a
340 :     | NONE => (f, s, taginsert (t, u), e))
341 :     | ty (S.ENUM (t, anon), a as (f, s, u, e)) =
342 :     (if collect_enums andalso anon then a
343 :     else case $? (enums, t) of
344 :     SOME _ => a
345 :     | NONE => (f, s, u, taginsert (t, e)))
346 : blume 828 | ty ((S.PTR (_, t) | S.ARR { t, ... }), a) = ty (t, a)
347 : blume 975 | ty (S.FPTR (cft as { args, res }), a) = let
348 :     val a' = foldl ty a args
349 :     val a'' = case res of NONE => a'
350 :     | SOME t => ty (t, a')
351 : blume 1096 val (f, s, u, e) = a''
352 : blume 1062 val cfth = hash_cft cft
353 : blume 1064 val i = IM.numItems f
354 : blume 975 in
355 : blume 1096 if IM.inDomain (f, cfth) then (f, s, u, e)
356 :     else (IM.insert (f, cfth, (cft, i)), s, u, e)
357 : blume 975 end
358 : blume 1096 | ty (S.UNIMPLEMENTED _, a) = a
359 : blume 828 fun fs (S.OFIELD { spec = (_, t), ... }, a) = ty (t, a)
360 :     | fs (_, a) = a
361 :     fun f ({ name, spec }, a) = fs (spec, a)
362 : blume 1036 fun s ({ src, tag, size, anon, fields, exclude }, a) =
363 :     foldl f a fields
364 : mblume 1548 fun u ({ src, tag, size, anon, all, exclude }, a) =
365 :     foldl f a all
366 : blume 1011 fun gty ({ src, name, spec }, a) = ty (spec, a)
367 :     fun gvar ({ src, name, spec = (_, t) }, a) = ty (t, a)
368 :     fun gfun ({ src, name, spec, argnames }, a) = ty (S.FPTR spec, a)
369 : blume 828 in
370 : blume 1062 foldl gfun
371 :     (foldl gvar
372 :     (foldl gty
373 :     (SM.foldl
374 :     u (SM.foldl
375 : blume 1096 s (IM.empty,
376 :     SS.empty, SS.empty, SS.empty)
377 : blume 1062 structs)
378 :     unions)
379 : blume 828 gtys)
380 :     gvars)
381 :     gfuns
382 :     end
383 :    
384 : blume 1096 fun s_inc t = SS.member (incomplete_structs, t)
385 :     fun u_inc t = SS.member (incomplete_unions, t)
386 : blume 828
387 :     fun rwro S.RW = Type "rw"
388 :     | rwro S.RO = Type "ro"
389 :    
390 :     fun dim_ty 0 = Type "dec"
391 :     | dim_ty n = Con ("dg" ^ Int.toString (n mod 10),
392 :     [dim_ty (n div 10)])
393 :    
394 : blume 1031 val dim_ty =
395 :     fn n =>
396 :     if n < 0 then raise Fail "negative dimension"
397 :     else dim_ty n
398 :    
399 : blume 831 fun Suobj'rw p sut = Con ("su_obj" ^ p, [sut, Type "rw"])
400 : blume 828 fun Suobj'ro sut = Con ("su_obj'", [sut, Type "ro"])
401 :    
402 : blume 837 fun wtn_fptr_p p { args, res } = let
403 : blume 828 fun topty (S.STRUCT t) = Suobj'ro (St t)
404 :     | topty (S.UNION t) = Suobj'ro (Un t)
405 :     | topty t = wtn_ty' t
406 :     val (res_t, extra_arg_t) =
407 :     case res of
408 :     NONE => (Unit, [])
409 :     | SOME (S.STRUCT t) => let
410 : blume 831 val ot = Suobj'rw "'" (St t)
411 : blume 828 in
412 :     (ot, [ot])
413 :     end
414 :     | SOME (S.UNION t) => let
415 : blume 831 val ot = Suobj'rw "'" (Un t)
416 : blume 828 in
417 :     (ot, [ot])
418 :     end
419 :     | SOME t => (topty t, [])
420 :     val arg_tl = extra_arg_t @ map topty args
421 :     val dom_t = Tuple arg_tl
422 :     val fct_t = Arrow (dom_t, res_t)
423 :     in
424 : blume 837 Con ("fptr" ^ p, [fct_t])
425 : blume 828 end
426 :    
427 : blume 837 and wtn_ty_p p (t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
428 : blume 975 S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
429 : mblume 1742 S.SLONGLONG | S.ULONGLONG |
430 : blume 975 S.FLOAT | S.DOUBLE | S.VOIDPTR)) =
431 : blume 837 Type (stem t)
432 :     | wtn_ty_p p (S.STRUCT t) = Con ("su", [St t])
433 :     | wtn_ty_p p (S.UNION t) = Con ("su", [Un t])
434 : blume 1096 | wtn_ty_p p (S.ENUM ta) = Con ("enum", [En ta])
435 : blume 837 | wtn_ty_p p (S.PTR (c, t)) =
436 : blume 1096 Con ("ptr" ^ p, [Con ("obj", [wtn_ty t, rwro c])])
437 : blume 837 | wtn_ty_p p (S.ARR { t, d, ... }) =
438 :     Con ("arr", [wtn_ty t, dim_ty d])
439 :     | wtn_ty_p p (S.FPTR spec) = wtn_fptr_p p spec
440 : blume 1096 | wtn_ty_p _ (S.UNIMPLEMENTED what) = unimp what
441 : blume 828
442 : blume 837 and wtn_ty t = wtn_ty_p "" t
443 : blume 828
444 : blume 837 and wtn_ty' t = wtn_ty_p "'" t
445 : blume 828
446 : blume 975 fun topfunc_ty p ({ args, res }, argnames) = let
447 : blume 1036 fun topty (S.SCHAR | S.SINT | S.SSHORT | S.SLONG) =
448 : mblume 1742 Type "MLRep.Signed.int"
449 :     | topty S.SLONGLONG =
450 :     Type "MLRep.LongLongSigned.int"
451 : blume 1036 | topty (S.UCHAR | S.UINT | S.USHORT | S.ULONG) =
452 : mblume 1742 Type "MLRep.Unsigned.word"
453 :     | topty S.ULONGLONG =
454 :     Type "MLRep.LongLongUnsigned.word"
455 : blume 1036 | topty (S.FLOAT | S.DOUBLE) =
456 : mblume 1742 Type "MLRep.Real.real"
457 : blume 828 | topty (S.STRUCT t) = Con ("su_obj" ^ p, [St t, Type "'c"])
458 :     | topty (S.UNION t) = Con ("su_obj" ^ p, [Un t, Type "'c"])
459 : blume 1096 | topty (S.ENUM _) = Type "MLRep.Signed.int"
460 : blume 837 | topty t = wtn_ty_p p t
461 : blume 975 val (res_t, extra_arg_t, extra_argname) =
462 : blume 828 case res of
463 : blume 975 NONE => (Unit, [], [])
464 : blume 828 | SOME (S.STRUCT t) => let
465 : blume 831 val ot = Suobj'rw p (St t)
466 : blume 828 in
467 : blume 1096 (ot, [ot], [writeto])
468 : blume 828 end
469 :     | SOME (S.UNION t) => let
470 : blume 831 val ot = Suobj'rw p (Un t)
471 : blume 828 in
472 : blume 1096 (ot, [ot], [writeto])
473 : blume 828 end
474 : blume 975 | SOME t => (topty t, [], [])
475 :     val argtyl = map topty args
476 :     val aggreg_argty =
477 :     case (doargnames, argnames) of
478 :     (true, SOME nl) =>
479 : blume 977 Record (ListPair.zip (map arg_id (extra_argname @ nl),
480 : blume 975 extra_arg_t @ argtyl))
481 :     | _ => Tuple (extra_arg_t @ argtyl)
482 : blume 828 in
483 : blume 975 Arrow (aggreg_argty, res_t)
484 : blume 828 end
485 :    
486 : mblume 1564 fun rtti_ty t = Con ("T.typ", [wtn_ty t])
487 : blume 828
488 : mblume 1564 fun obj_ty p (t, c) = Con ("obj" ^ p, [wtn_ty t, c])
489 : blume 828
490 :     fun cro S.RW = Type "'c"
491 :     | cro S.RO = Type "ro"
492 :    
493 :     fun dim_val n = let
494 :     fun build 0 = EVar "dec"
495 :     | build n = EApp (build (n div 10),
496 :     EVar ("dg" ^ Int.toString (n mod 10)))
497 :     in
498 :     EApp (build n, EVar "dim")
499 :     end
500 :    
501 : blume 1096 exception Incomplete
502 :    
503 : blume 828 local
504 :     fun simple v = EVar ("T." ^ v)
505 :     in
506 : blume 975 fun rtti_val (t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
507 :     S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
508 : mblume 1742 S.SLONGLONG | S.ULONGLONG |
509 : blume 975 S.FLOAT | S.DOUBLE | S.VOIDPTR)) =
510 : blume 828 simple (stem t)
511 : blume 1096 | rtti_val (S.STRUCT t) =
512 :     if s_inc t then raise Incomplete else EVar (Styp t)
513 :     | rtti_val (S.UNION t) =
514 :     if u_inc t then raise Incomplete else EVar (Utyp t)
515 :     | rtti_val (S.ENUM ta) =
516 :     EConstr (EVar "T.enum",
517 :     Con ("T.typ", [Con ("enum", [En ta])]))
518 : blume 1062 | rtti_val (S.FPTR cft) = let
519 :     val cfth = hash_cft cft
520 :     in
521 :     case %? (fptr_types, cfth) of
522 :     SOME (_, i) => EVar (fptr_rtti_qid i)
523 :     | NONE => raise Fail "fptr type missing"
524 :     end
525 : blume 975 | rtti_val (S.PTR (S.RW, t)) =
526 : blume 1096 EApp (EVar "T.pointer", rtti_val t)
527 : blume 975 | rtti_val (S.PTR (S.RO, t)) =
528 : blume 1096 EApp (EVar "T.ro", EApp (EVar "T.pointer", rtti_val t))
529 : blume 975 | rtti_val (S.ARR { t, d, ... }) =
530 :     EApp (EVar "T.arr", ETuple [rtti_val t, dim_val d])
531 : blume 1096 | rtti_val (S.UNIMPLEMENTED what) = raise Incomplete
532 : blume 828 end
533 :    
534 : blume 1062 fun fptr_mkcall spec = let
535 :     val h = hash_cft spec
536 :     in
537 :     case %? (fptr_types, h) of
538 : blume 1011 SOME (_, i) => fptr_mkcall_qid i
539 :     | NONE => raise Fail "missing fptr_type (mkcall)"
540 : blume 1062 end
541 : blume 828
542 : blume 1067 fun openPP (f, src) = let
543 :     val device = CPIFDev.openOut (f, wid)
544 :     val stream = PP.openStream device
545 :    
546 : blume 1011 fun nl () = PP.newline stream
547 :     fun str s = PP.string stream s
548 :     fun sp () = PP.space stream 1
549 :     fun nsp () = PP.nbSpace stream 1
550 :     fun Box a = PP.openBox stream (PP.Abs a)
551 :     fun HBox () = PP.openHBox stream
552 :     fun HVBox x = PP.openHVBox stream x
553 :     fun HOVBox a = PP.openHOVBox stream (PP.Abs a)
554 :     fun VBox a = PP.openVBox stream (PP.Abs a)
555 :     fun endBox () = PP.closeBox stream
556 :     fun ppty t = P.ppType stream t
557 :     fun ppExp e = P.ppExp stream e
558 :     fun ppFun x = P.ppFun stream x
559 :     fun line s = (nl (); str s)
560 :     fun pr_vdef (v, e) =
561 :     (nl (); HOVBox 4; str "val"; nsp (); str v; nsp (); str "=";
562 :     sp (); ppExp e; endBox ())
563 :     fun pr_fdef (f, args, res) = (nl (); ppFun (f, args, res))
564 : blume 828
565 :     fun pr_decl (keyword, connector) (v, t) =
566 :     (nl (); HOVBox 4; str keyword; nsp (); str v; nsp ();
567 :     str connector; sp (); ppty t; endBox ())
568 :     val pr_tdef = pr_decl ("type", "=")
569 :     val pr_vdecl = pr_decl ("val", ":")
570 : blume 1067 fun closePP () = (PP.closeStream stream; CPIFDev.closeOut device)
571 : blume 828 in
572 : blume 1067 str dontedit;
573 :     case src of
574 :     NONE => ()
575 :     | SOME s =>
576 :     (nl (); str (concat ["(* [from code at ", s, "] *)"]));
577 :     line credits;
578 :     line commentsto;
579 :     nl ();
580 : blume 1011 { stream = stream,
581 :     nl = nl, str = str, sp = sp, nsp = nsp, Box = Box, HVBox = HVBox,
582 :     HBox = HBox, HOVBox = HOVBox, VBox = VBox, endBox = endBox,
583 :     ppty = ppty, ppExp = ppExp, ppFun = ppFun, line = line,
584 :     pr_vdef = pr_vdef, pr_fdef = pr_fdef, pr_tdef = pr_tdef,
585 :     pr_vdecl = pr_vdecl,
586 :     closePP = closePP
587 :     }
588 :     end
589 : blume 828
590 : blume 1011 val get_callop = let
591 :     val ncallops = ref 0
592 : blume 1062 val callops = ref IM.empty
593 : blume 1011 fun callop_sid i = "Callop_" ^ Int.toString i
594 :     fun callop_qid i = callop_sid i ^ ".callop"
595 : blume 1062 fun get (ml_args_t, e_proto, ml_res_t) = let
596 :     val e_proto_hash = hash_mltype e_proto
597 :     in
598 :     case %? (!callops, e_proto_hash) of
599 :     SOME i => callop_qid i
600 : blume 1011 | NONE => let
601 :     val i = !ncallops
602 :     val sn = callop_sid i
603 :     val file = smlfile ("callop-" ^ Int.toString i)
604 :     val { pr_vdef, closePP, str, nl, Box, endBox, ... } =
605 :     openPP (file, NONE)
606 :     in
607 :     ncallops := i + 1;
608 : blume 1062 callops := IM.insert (!callops, e_proto_hash, i);
609 : blume 1011 str (concat ["structure ", sn, " = struct"]);
610 :     Box 4;
611 :     pr_vdef ("callop",
612 :     EConstr (EVar "RawMemInlineT.rawccall",
613 :     Arrow (Tuple [Type "Word32.word",
614 :     ml_args_t,
615 :     e_proto],
616 :     ml_res_t)));
617 :     endBox ();
618 :     nl (); str "end"; nl (); closePP ();
619 :     callop_qid i
620 :     end
621 : blume 1062 end
622 : blume 1011 in
623 :     get
624 : blume 828 end
625 :    
626 : blume 1011 fun pr_fptr_rtti ({ args, res }, i) = let
627 : blume 828
628 : blume 1011 val structname = fptr_rtti_struct_id i
629 :     val file = smlfile ("fptr-rtti-" ^ Int.toString i)
630 : blume 828
631 : blume 1011 val { closePP, str, Box, endBox, pr_fdef, pr_vdef, nl, ... } =
632 :     openPP (file, NONE)
633 : blume 828
634 : blume 1011 (* cproto encoding *)
635 :     fun List t = Con ("list", [t])
636 :     val Real = Type "real"
637 :     val Char = Type "char"
638 :     val Word8 = Type "Word8.word"
639 :     val Int31 = Type "Int31.int"
640 :     val Word31 = Type "Word31.word"
641 :     val Int32 = Type "Int32.int"
642 :     val Word32 = Type "Word32.word"
643 :     val String = Type "string"
644 :     val Exn = Type "exn"
645 : blume 828
646 : blume 1011 (* see src/compiler/Semant/types/cproto.sml for these... *)
647 :     val E_double = Real
648 :     val E_float = List Real
649 :     val E_schar = Char
650 :     val E_uchar = Word8
651 :     val E_sint = Int31
652 :     val E_uint = Word31
653 :     val E_slong = Int32
654 :     val E_ulong = Word32
655 :     val E_sshort = List Char
656 :     val E_ushort = List Word8
657 : mblume 1742 val E_sllong = List Int32
658 :     val E_ullong = List Word32
659 : blume 1011 val E_ptr = String
660 :     val E_nullstruct = Exn
661 : blume 828
662 : blume 1011 fun encode S.DOUBLE = E_double
663 :     | encode S.FLOAT = E_float
664 :     | encode S.SCHAR = E_schar
665 :     | encode S.UCHAR = E_uchar
666 :     | encode S.SINT = E_sint
667 :     | encode S.UINT = E_uint
668 :     | encode S.SSHORT = E_sshort
669 :     | encode S.USHORT = E_ushort
670 :     | encode S.SLONG = E_slong
671 :     | encode S.ULONG = E_ulong
672 : mblume 1742 | encode S.SLONGLONG = E_sllong
673 :     | encode S.ULONGLONG = E_ullong
674 : blume 1011 | encode (S.PTR _ | S.VOIDPTR | S.FPTR _) = E_ptr
675 : blume 1096 | encode (S.UNIMPLEMENTED what) = unimp what
676 : blume 1011 | encode (S.ARR _) = raise Fail "unexpected array"
677 : blume 1096 | encode (S.ENUM _) = E_sint
678 : blume 1011 | encode (S.STRUCT t) =
679 : mblume 1559 (case $? (structs, t) of
680 :     SOME s => encode_fields Unit (#fields s)
681 :     | NONE => err ["incomplete struct argument: struct ", t])
682 : blume 1011 | encode (S.UNION t) =
683 : mblume 1559 (case $? (unions, t) of
684 :     SOME u => encode_fields E_sint (#all u)
685 :     | NONE => err ["incomplete union argument: union", t])
686 : blume 828
687 : mblume 1548 and encode_fields dummy fields = let
688 : blume 1011 fun f0 (S.ARR { t, d = 0, ... }, a) = a
689 :     | f0 (S.ARR { t, d = 1, ... }, a) = f0 (t, a)
690 :     | f0 (S.ARR { t, d, esz }, a) =
691 : mblume 1548 f0 (t, f0 (S.ARR { t = t, d = d - 1, esz = esz }, a))
692 : blume 1011 | f0 (t, a) = encode t :: a
693 :     fun f ({ spec = S.OFIELD { spec, ... }, name }, a) =
694 : mblume 1548 f0 (#2 spec, a)
695 : blume 1011 | f (_, a) = a
696 :     val fel = foldr f [] fields
697 :     in
698 :     case fel of
699 :     [] => E_nullstruct
700 : mblume 1548 | fel => Tuple (dummy :: fel)
701 : blume 1011 end
702 : blume 828
703 : blume 1011 val e_arg = Tuple (Unit :: map encode args)
704 :     val e_res = case res of NONE => Unit | SOME t => encode t
705 : blume 1078 val e_proto = Con ("list", [Arrow (e_arg, e_res)])
706 : blume 828
707 : blume 1011 (* generating the call operation *)
708 : blume 828
709 : blume 1011 (* low-level type used to communicate a value to the
710 :     * low-level call operation *)
711 :     fun mlty (t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
712 :     S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
713 : mblume 1742 S.SLONGLONG | S.ULONGLONG |
714 : blume 1011 S.FLOAT | S.DOUBLE)) =
715 : mblume 1548 Type ("CMemory.cc_" ^ stem t)
716 :     | mlty (S.VOIDPTR | S.PTR _ | S.FPTR _ | S.STRUCT _ | S.UNION _) =
717 :     Type "CMemory.cc_addr"
718 : blume 1096 | mlty (S.ENUM _) = Type "CMemory.cc_sint"
719 :     | mlty (S.UNIMPLEMENTED what) = unimp what
720 : mblume 1548 | mlty (S.ARR _) = raise Fail "unexpected type"
721 : blume 828
722 : blume 1011 fun wrap (e, n) =
723 :     EApp (EVar ("CMemory.wrap_" ^ n),
724 :     EApp (EVar ("Cvt.ml_" ^ n), e))
725 : blume 828
726 : blume 1011 fun vwrap e = EApp (EVar "CMemory.wrap_addr",
727 :     EApp (EVar "reveal", e))
728 :     fun fwrap e = EApp (EVar "CMemory.wrap_addr",
729 :     EApp (EVar "freveal", e))
730 :     fun pwrap e = EApp (EVar "CMemory.wrap_addr",
731 :     EApp (EVar "reveal",
732 :     EApp (EVar "Ptr.inject'", e)))
733 : blume 828
734 : blume 1011 fun suwrap e = pwrap (EApp (EVar "Ptr.|&!", e))
735 : blume 828
736 : blume 1096 fun ewrap e = EApp (EVar "CMemory.wrap_sint",
737 :     EApp (EVar "Cvt.c2i_enum", e))
738 :    
739 : blume 1011 (* this code is for passing structures in pieces
740 :     * (member-by-member); we don't use this and rather
741 :     * provide a pointer to the beginning of the struct *)
742 : blume 828
743 : blume 1011 fun arglist ([], _) = ([], [])
744 :     | arglist (h :: tl, i) = let
745 :     val p = EVar ("x" ^ Int.toString i)
746 :     val (ta, ea) = arglist (tl, i + 1)
747 :     fun sel e = (mlty h :: ta, e :: ea)
748 : blume 828 in
749 : blume 1011 case h of
750 :     (S.STRUCT _ | S.UNION _) => sel (suwrap p)
751 : blume 1096 | (S.ENUM _) => sel (ewrap p)
752 : blume 1011 | (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
753 :     S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
754 : mblume 1742 S.SLONGLONG | S.ULONGLONG |
755 : blume 1011 S.FLOAT | S.DOUBLE) => sel (wrap (p, stem h))
756 :     | S.VOIDPTR => sel (vwrap p)
757 : blume 1078 | S.PTR _ => sel (pwrap p)
758 : blume 1011 | S.FPTR _ => sel (fwrap p)
759 : blume 1096 | S.UNIMPLEMENTED what => unimp_arg what
760 : blume 1011 | S.ARR _ => raise Fail "unexpected array argument"
761 : blume 828 end
762 :    
763 : blume 1011 val (ml_res_t,
764 :     extra_arg_v, extra_arg_e, extra_ml_arg_t,
765 :     res_wrap) =
766 :     case res of
767 :     NONE => (Unit, [], [], [], fn r => r)
768 :     | SOME (S.STRUCT _ | S.UNION _) =>
769 :     (Unit,
770 :     [EVar "x0"],
771 :     [suwrap (EVar "x0")],
772 :     [Type "CMemory.cc_addr"],
773 :     fn r => ESeq (r, EVar "x0"))
774 :     | SOME t => let
775 :     fun unwrap n r =
776 :     EApp (EVar ("Cvt.c_" ^ n),
777 :     EApp (EVar ("CMemory.unwrap_" ^ n), r))
778 :     fun punwrap cast r =
779 :     EApp (EVar cast,
780 :     EApp (EVar "CMemory.unwrap_addr", r))
781 : blume 1096 fun eunwrap r =
782 :     EApp (EVar "Cvt.i2c_enum",
783 :     EApp (EVar "CMemory.unwrap_sint", r))
784 : blume 1011 val res_wrap =
785 :     case t of
786 :     (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
787 :     S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
788 : mblume 1742 S.SLONGLONG | S.ULONGLONG |
789 : blume 1011 S.FLOAT | S.DOUBLE) => unwrap (stem t)
790 :     | S.VOIDPTR => punwrap "vcast"
791 :     | S.FPTR _ => punwrap "fcast"
792 : blume 1078 | S.PTR _ => punwrap "pcast"
793 : blume 1096 | S.ENUM _ => eunwrap
794 :     | S.UNIMPLEMENTED what => unimp_res what
795 : blume 1011 | (S.STRUCT _ | S.UNION _ | S.ARR _) =>
796 :     raise Fail "unexpected result type"
797 :     in
798 :     (mlty t, [], [], [], res_wrap)
799 :     end
800 : blume 828
801 : blume 1011 val (ml_args_tl, args_el) = arglist (args, 1)
802 : blume 828
803 : blume 1011 val ml_args_t = Tuple (extra_ml_arg_t @ ml_args_tl)
804 : blume 828
805 : blume 1011 val arg_vl =
806 :     rev (#1 (foldl (fn (_, (a, i)) =>
807 :     (EVar ("x" ^ Int.toString i) :: a,
808 :     i + 1)) ([], 1)
809 :     args))
810 : blume 828
811 : blume 1011 val arg_e = ETuple (extra_arg_e @ args_el)
812 :     val callop_n = get_callop (ml_args_t, e_proto, ml_res_t)
813 :     in
814 : blume 1036 str "local open C.Dim C_Int in";
815 : blume 1011 nl (); str (concat ["structure ", structname, " = struct"]);
816 :     Box 4;
817 :     pr_fdef ("mkcall",
818 :     [EVar "a", ETuple (extra_arg_v @ arg_vl)],
819 :     res_wrap (EApp (EVar callop_n,
820 :     ETuple [EVar "a", arg_e,
821 :     EVar "nil"])));
822 :     pr_vdef ("typ",
823 :     EConstr (EApp (EVar "mk_fptr_typ",
824 :     EVar "mkcall"),
825 :     rtti_ty (S.FPTR { args = args,
826 :     res = res })));
827 :     endBox ();
828 :     nl (); str "end"; nl (); str "end"; nl (); closePP ()
829 :     end
830 : blume 828
831 : blume 1096 datatype sue_szinfo =
832 :     T_INC (* generate no RTTI *)
833 :     | T_SU of word (* generate struct/union RTTI *)
834 :     | T_E (* generate enum RTTI *)
835 :    
836 :     fun pr_sue_t_structure (src, tag, anon, tinfo, k, K) = let
837 : blume 1011 val file = smlfile (concat [k, "t-", tag])
838 :     val { str, closePP, nl, Box, endBox, VBox, pr_tdef,
839 :     pr_vdef, ... } =
840 : blume 1096 openPP (file, src)
841 : blume 1011 fun build [] = Type k
842 :     | build (h :: tl) = Con ("t_" ^ String.str h, [build tl])
843 :     val (utildef, tag_t) =
844 :     if anon then
845 :     ("structure X :> sig type t end \
846 :     \= struct type t = unit end",
847 :     Type "X.t")
848 :     else
849 :     ("open Tag",
850 :     build (rev (String.explode tag)))
851 :     in
852 :     str "local";
853 :     Box 4;
854 : blume 1096 nl (); str (concat ["structure ", SUEstruct K tag, " = struct"]);
855 : blume 1011 Box 4;
856 :     nl (); str "local";
857 :     VBox 4;
858 :     nl (); str utildef;
859 :     endBox ();
860 :     nl (); str "in";
861 :     VBox 4;
862 :     pr_tdef ("tag", tag_t);
863 :     endBox ();
864 :     nl (); str "end";
865 : blume 1096 case tinfo of
866 :     T_INC => ()
867 :     | T_SU size =>
868 :     (pr_vdef ("size",
869 :     EConstr (EApp (EVar "C_Int.mk_su_size", EWord size),
870 :     Con ("C.S.size",
871 :     [Con ("C.su", [Type "tag"])])));
872 :     pr_vdef ("typ",
873 :     EApp (EVar "C_Int.mk_su_typ", EVar "size")))
874 :     | T_E => ();
875 : blume 1011 endBox ();
876 :     nl (); str "end";
877 :     endBox ();
878 :     nl (); str "in";
879 :     Box 4;
880 : blume 1096 nl (); str (concat ["structure ", SUE_Tstruct K tag,
881 :     " = ", SUEstruct K tag]);
882 : blume 1011 endBox ();
883 :     nl (); str "end"; nl ();
884 :     closePP ()
885 :     end
886 : blume 828
887 : blume 1036 fun pr_st_structure { src, tag, anon, size, fields, exclude } =
888 : blume 1096 pr_sue_t_structure (SOME src, tag, anon, T_SU size, "s", "S")
889 : mblume 1548 fun pr_ut_structure { src, tag, anon, size, all, exclude } =
890 : blume 1096 pr_sue_t_structure (SOME src, tag, anon, T_SU size, "u", "U")
891 :     fun pr_et_structure { src, tag, anon, descr, spec, exclude } =
892 :     pr_sue_t_structure (SOME src, tag, anon, T_E, "e", "E")
893 : blume 828
894 : blume 1096 fun pr_sue_it_structure (tag, k, K) =
895 : mblume 1342 (pr_sue_t_structure (NONE, tag, false, T_INC, k, K);
896 :     exports := ("structure " ^ SUE_Tstruct K tag) :: !exports)
897 : blume 1096
898 :     fun pr_i_st_structure tag = pr_sue_it_structure (tag, "s", "S")
899 :     fun pr_i_ut_structure tag = pr_sue_it_structure (tag, "u", "U")
900 :     fun pr_i_et_structure tag = pr_sue_it_structure (tag, "e", "E")
901 :    
902 : blume 1011 fun pr_su_structure (src, tag, fields, k, K) = let
903 : blume 828
904 : blume 1011 val file = smlfile (concat [k, "-", tag])
905 : blume 1096 val { closePP, Box, endBox, str, nl, line,
906 : blume 1011 pr_tdef, pr_vdef, pr_fdef, ... } =
907 :     openPP (file, SOME src)
908 : blume 828
909 : blume 1011 fun rwro S.RW = "rw"
910 :     | rwro S.RO = "ro"
911 : blume 828
912 : blume 1011 fun pr_field_typ { name, spec = S.OFIELD { spec = (c, t),
913 :     synthetic = false,
914 :     offset } } =
915 :     pr_tdef (fieldtype_id name, wtn_ty t)
916 :     | pr_field_typ _ = ()
917 : blume 828
918 : blume 1011 fun pr_field_rtti { name, spec = S.OFIELD { spec = (c, t),
919 :     synthetic = false,
920 :     offset } } =
921 :     pr_vdef (fieldrtti_id name,
922 :     EConstr (rtti_val t,
923 :     Con ("T.typ", [Type (fieldtype_id name)])))
924 :     | pr_field_rtti _ = ()
925 : blume 828
926 : blume 1011 fun arg_x p = EConstr (EVar "x",
927 :     Con ("su_obj" ^ p,
928 :     [Type "tag", Type "'c"]))
929 :    
930 : blume 828
931 : blume 1011 fun pr_bf_acc (name, p, sign, { offset, constness, bits, shift }) =
932 :     let val maker =
933 :     concat ["mk_", rwro constness, "_", sign, "bf", p]
934 :     in
935 :     pr_fdef (field_id (name, p),
936 :     [arg_x p],
937 :     EApp (EApp (EVar maker,
938 :     ETuple [EInt offset,
939 :     EWord bits,
940 :     EWord shift]),
941 :     EVar "x"))
942 :     end
943 : blume 828
944 : blume 1011 fun pr_field_acc' { name, spec = S.OFIELD x } =
945 :     let val { synthetic, spec = (c, t), offset, ... } = x
946 :     in
947 :     if synthetic then ()
948 :     else pr_fdef (field_id (name, "'"),
949 :     [arg_x "'"],
950 :     EConstr (EApp (EVar "mk_field'",
951 :     ETuple [EInt offset,
952 :     EVar "x"]),
953 :     Con ("obj'",
954 :     [Type (fieldtype_id name),
955 :     cro c])))
956 :     end
957 :     | pr_field_acc' { name, spec = S.SBF bf } =
958 :     pr_bf_acc (name, "'", "s", bf)
959 :     | pr_field_acc' { name, spec = S.UBF bf } =
960 :     pr_bf_acc (name, "'", "u", bf)
961 : blume 828
962 : blume 1011 fun pr_field_acc { name, spec = S.OFIELD { offset,
963 :     spec = (c, t),
964 :     synthetic } } =
965 :     if synthetic then ()
966 :     else let
967 :     val maker = concat ["mk_", rwro c, "_field"]
968 :     val rttival = EVar (fieldrtti_id name)
969 : blume 828 in
970 : blume 1011 pr_fdef (field_id (name, ""),
971 :     [arg_x ""],
972 :     EApp (EVar maker,
973 :     ETuple [rttival,
974 :     EInt offset,
975 :     EVar "x"]))
976 : blume 828 end
977 : blume 1011 | pr_field_acc { name, spec = S.SBF bf } =
978 :     pr_bf_acc (name, "", "s", bf)
979 :     | pr_field_acc { name, spec = S.UBF bf } =
980 :     pr_bf_acc (name, "", "u", bf)
981 : blume 828
982 : blume 1096 val sustruct = "structure " ^ SUEstruct K tag
983 :    
984 :     fun pr_one_field f = let
985 :     val _ = pr_field_typ f
986 :     val inc = (pr_field_rtti f; false) handle Incomplete => true
987 :     in
988 :     if dolight orelse inc then pr_field_acc' f else ();
989 :     if doheavy andalso not inc then pr_field_acc f else ()
990 :     end
991 : blume 1011 in
992 :     str "local open C.Dim C_Int in";
993 :     nl (); str (sustruct ^ " = struct");
994 :     Box 4;
995 : blume 1096 nl (); str ("open " ^ SUE_Tstruct K tag);
996 :     app pr_one_field fields;
997 : blume 1011 endBox ();
998 :     nl (); str "end";
999 :     nl (); str "end";
1000 :     nl (); closePP ();
1001 :     exports := sustruct :: (!exports)
1002 :     end
1003 : blume 828
1004 : blume 1036 fun pr_s_structure { src, tag, anon, size, fields, exclude } =
1005 : blume 1011 pr_su_structure (src, tag, fields, "s", "S")
1006 : mblume 1548 fun pr_u_structure { src, tag, anon, size, all, exclude } =
1007 : blume 1011 pr_su_structure (src, tag, all, "u", "U")
1008 : blume 828
1009 : blume 1096 fun pr_e_structure { src, tag, anon, descr, spec, exclude } = let
1010 :     val file = smlfile ("e-" ^ tag)
1011 :     val { closePP, str, Box, endBox, nl, line, sp,
1012 :     pr_fdef, pr_vdef, pr_tdef, ... } =
1013 :     openPP (file, SOME src)
1014 :     val estruct = "structure " ^ Estruct' (tag, anon)
1015 :     fun no_duplicate_values () = let
1016 :     fun loop ([], _) = true
1017 :     | loop ({ name, spec } :: l, s) =
1018 :     if LIS.member (s, spec) then
1019 :     (warn (concat ["enum ", descr,
1020 :     " has duplicate values;\
1021 :     \ using sint,\
1022 :     \ not generating constructors\n"]);
1023 :     false)
1024 :     else loop (l, LIS.add (s, spec))
1025 :     in
1026 :     loop (spec, LIS.empty)
1027 :     end
1028 :     val dodt = enumcons andalso no_duplicate_values ()
1029 :    
1030 :     fun dt_mlrep () = let
1031 :     fun pcl () = let
1032 :     fun loop (_, []) = ()
1033 :     | loop (c, { name, spec } :: l) =
1034 :     (str (c ^ enum_id name); nextround l)
1035 :     and nextround [] = ()
1036 :     | nextround l = (sp (); loop ("| ", l))
1037 : blume 1011 in
1038 : blume 1096 Box 2; nl ();
1039 :     loop (" ", spec);
1040 :     endBox ()
1041 :     end
1042 :     fun pfl (fname, arg, res, fini) = let
1043 :     fun loop (_, []) = ()
1044 :     | loop (pfx, v :: l) =
1045 :     (line (concat [pfx, " ", arg v, " => ", res v]);
1046 :     loop (" |", l))
1047 :     in
1048 :     line (concat ["fun ", fname, " x ="]);
1049 : blume 1011 Box 4;
1050 : blume 1096 line ("case x of");
1051 :     loop (" ", spec);
1052 :     fini ();
1053 :     endBox ()
1054 : blume 1011 end
1055 : blume 1096 fun cstr { name, spec } = enum_id name
1056 :     fun vstr { name, spec } =
1057 :     LargeInt.toString spec ^ " : MLRep.Signed.int"
1058 :     in
1059 :     line "datatype mlrep =";
1060 :     pcl ();
1061 :     pfl ("m2i", cstr, vstr, fn () => ());
1062 :     pfl ("i2m", vstr, cstr,
1063 :     fn () => line " | _ => raise General.Domain")
1064 :     end
1065 :     fun int_mlrep () = let
1066 :     fun v { name, spec } =
1067 :     pr_vdef (enum_id name, EConstr (ELInt spec, Type "mlrep"))
1068 :     val mlx = EConstr (EVar "x", Type "mlrep")
1069 :     val ix = EConstr (EVar "x", Type "MLRep.Signed.int")
1070 :     in
1071 :     pr_tdef ("mlrep", Type "MLRep.Signed.int");
1072 :     app v spec;
1073 :     pr_fdef ("m2i", [mlx], ix);
1074 :     pr_fdef ("i2m", [ix], mlx)
1075 :     end
1076 :     fun getset p = let
1077 :     fun constr c = Con ("enum_obj" ^ p, [Type "tag", Type c])
1078 :     in
1079 :     pr_fdef ("get" ^ p,
1080 :     [EConstr (EVar "x", constr "'c")],
1081 :     EApp (EVar "i2m",
1082 :     EApp (EVar ("Get.enum" ^ p), EVar "x")));
1083 :     pr_fdef ("set" ^ p,
1084 :     [ETuple [EConstr (EVar "x", constr "rw"), EVar "v"]],
1085 :     EApp (EVar ("Set.enum" ^ p),
1086 :     ETuple [EVar "x", EApp (EVar "m2i", EVar "v")]))
1087 :     end
1088 : blume 828
1089 : blume 1096 in
1090 :     str "local open C in";
1091 :     line (estruct ^ " = struct");
1092 :     Box 4;
1093 :     line ("open " ^ SUE_Tstruct "E" tag);
1094 :     if dodt then dt_mlrep () else int_mlrep ();
1095 :     pr_fdef ("c", [EVar "x"],
1096 :     EConstr (EApp (EVar "Cvt.i2c_enum",
1097 :     EApp (EVar "m2i", EVar "x")),
1098 :     Con ("enum", [Type "tag"])));
1099 :     pr_fdef ("ml", [EConstr (EVar "x", Con ("enum", [Type "tag"]))],
1100 :     EApp (EVar "i2m",
1101 :     EApp (EVar "Cvt.c2i_enum", EVar "x")));
1102 :     if dolight then getset "'" else ();
1103 :     if doheavy then getset "" else ();
1104 :     endBox ();
1105 :     line "end"; line "end (* local *)";
1106 :     nl ();
1107 :     closePP ();
1108 :     exports := estruct :: !exports
1109 :     end
1110 :    
1111 :     fun pr_t_structure { src, name, spec } = let
1112 : mblume 1557 val rttiv_opt = SOME (rtti_val spec) handle Incomplete => NONE
1113 : blume 1096 val file = smlfile ("t-" ^ name)
1114 :     val { closePP, Box, endBox, str, nl, pr_tdef,
1115 :     pr_vdef, ... } =
1116 :     openPP (file, SOME src)
1117 :     val tstruct = "structure " ^ Tstruct name
1118 :     in
1119 :     str "local open C.Dim C in";
1120 :     nl (); str (tstruct ^ " = struct");
1121 :     Box 4;
1122 : mblume 1564 pr_tdef ("t", wtn_ty spec);
1123 : mblume 1557 Option.app (fn rttiv =>
1124 : mblume 1564 pr_vdef ("typ",
1125 :     EConstr (rttiv,
1126 :     Con ("T.typ", [Type "t"]))))
1127 : mblume 1557 rttiv_opt;
1128 : blume 1096 endBox ();
1129 :     nl (); str "end";
1130 :     nl (); str "end";
1131 :     nl ();
1132 :     closePP ();
1133 :     exports := tstruct :: !exports
1134 : mblume 1557 end
1135 : blume 1096
1136 : blume 1011 fun pr_gvar { src, name, spec = (c, t) } = let
1137 :     val file = smlfile ("g-" ^ name)
1138 :     val { closePP, str, nl, Box, VBox, endBox,
1139 :     pr_fdef, pr_vdef, pr_tdef, ... } =
1140 :     openPP (file, SOME src)
1141 : blume 1096 fun doit () = let
1142 :     val rwo = Type (case c of S.RW => "rw" | S.RO => "ro")
1143 :     val _ = pr_tdef ("t", wtn_ty t)
1144 :     val inc = (pr_vdef ("typ",
1145 :     EConstr (rtti_val t,
1146 :     Con ("T.typ", [Type "t"])));
1147 :     false)
1148 :     handle Incomplete => true
1149 :     val obj' =
1150 :     EConstr (EApp (EVar "mk_obj'", EApp (EVar "h", EUnit)),
1151 :     Con ("obj'", [Type "t", rwo]))
1152 :     val dolight = dolight orelse inc
1153 :     in
1154 :     if dolight then pr_fdef ("obj'", [EUnit], obj') else ();
1155 :     if doheavy andalso not inc then
1156 :     pr_fdef ("obj", [EUnit],
1157 :     EApp (EApp (EVar "Heavy.obj", EVar "typ"),
1158 :     if dolight then
1159 :     EApp (EVar "obj'", EUnit)
1160 :     else obj'))
1161 :     else ()
1162 :     end
1163 :    
1164 : blume 1011 val gstruct = "structure " ^ Gstruct name
1165 :     in
1166 :     str (gstruct ^ " = struct");
1167 :     Box 4;
1168 :     nl (); str "local";
1169 :     VBox 4;
1170 : blume 1036 nl (); str "open C.Dim C_Int";
1171 : blume 1011 pr_vdef ("h", EApp (EVar libraryhandle, EString name));
1172 :     endBox ();
1173 :     nl (); str "in";
1174 :     VBox 4;
1175 : blume 1096 doit ();
1176 : blume 1011 endBox ();
1177 :     nl (); str "end";
1178 :     endBox ();
1179 :     nl (); str "end"; nl ();
1180 :     closePP ();
1181 :     exports := gstruct :: !exports
1182 :     end
1183 : blume 828
1184 : blume 1011 fun pr_gfun x = let
1185 :     val { src, name, spec = spec as { args, res }, argnames } = x
1186 : blume 828
1187 : blume 1011 val file = smlfile ("f-" ^ name)
1188 :     val { closePP, str, nl, pr_fdef, Box, endBox,
1189 :     pr_vdef, pr_vdecl, ... } =
1190 :     openPP (file, SOME src)
1191 : blume 1096 fun mk_do_f is_light = let
1192 : blume 828 val ml_vars =
1193 :     rev (#1 (foldl (fn (_, (l, i)) =>
1194 :     (EVar ("x" ^ Int.toString i) :: l,
1195 :     i + 1))
1196 :     ([], 1)
1197 :     args))
1198 :     fun app0 (what, e) =
1199 :     if is_light then e else EApp (EVar what, e)
1200 :     fun light (what, e) = app0 ("Light." ^ what, e)
1201 :     fun heavy (what, t, e) =
1202 :     if is_light then e
1203 : blume 975 else EApp (EApp (EVar ("Heavy." ^ what), rtti_val t), e)
1204 : blume 1011
1205 : blume 828 fun oneArg (e, t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
1206 :     S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
1207 : mblume 1742 S.SLONGLONG | S.ULONGLONG |
1208 : blume 828 S.FLOAT | S.DOUBLE)) =
1209 : mblume 1742 EApp (EVar ("Cvt.c_" ^ stem t), e)
1210 : blume 828 | oneArg (e, (S.STRUCT _ | S.UNION _)) =
1211 : mblume 1742 EApp (EVar "ro'", light ("obj", e))
1212 : blume 1096 | oneArg (e, S.ENUM ta) = EApp (EVar "Cvt.i2c_enum", e)
1213 : blume 1078 | oneArg (e, S.PTR _) = light ("ptr", e)
1214 : blume 828 | oneArg (e, S.FPTR _) = light ("fptr", e)
1215 :     | oneArg (e, S.VOIDPTR) = e
1216 : blume 1096 | oneArg (e, S.UNIMPLEMENTED what) = unimp_arg what
1217 : blume 828 | oneArg (e, S.ARR _) = raise Fail "array argument type"
1218 :     val c_exps = ListPair.map oneArg (ml_vars, args)
1219 : blume 975 val (ml_vars, c_exps, extra_argname) =
1220 : blume 831 case res of
1221 :     SOME (S.STRUCT _ | S.UNION _) =>
1222 :     (EVar "x0" :: ml_vars,
1223 : blume 975 light ("obj", EVar "x0") :: c_exps,
1224 :     [writeto])
1225 :     | _ => (ml_vars, c_exps, [])
1226 : blume 828 val call = EApp (EVar "call",
1227 : blume 1011 ETuple [EApp (EVar "fptr", EUnit),
1228 : blume 828 ETuple c_exps])
1229 :     val ml_res =
1230 :     case res of
1231 :     SOME (t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
1232 :     S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
1233 : mblume 1742 S.SLONGLONG | S.ULONGLONG |
1234 : blume 828 S.FLOAT | S.DOUBLE)) =>
1235 : mblume 1548 EApp (EVar ("Cvt.ml_" ^ stem t), call)
1236 : blume 828 | SOME (t as (S.STRUCT _ | S.UNION _)) =>
1237 : mblume 1548 heavy ("obj", t, call)
1238 : blume 1096 | SOME (S.ENUM ta) => EApp (EVar "Cvt.c2i_enum", call)
1239 : blume 1078 | SOME (t as S.PTR _) => heavy ("ptr", t, call)
1240 : blume 828 | SOME (t as S.FPTR _) => heavy ("fptr", t, call)
1241 :     | SOME (S.ARR _) => raise Fail "array result type"
1242 : blume 1096 | SOME (S.UNIMPLEMENTED what) => unimp_res what
1243 : blume 828 | (NONE | SOME S.VOIDPTR) => call
1244 : blume 975 val argspat =
1245 :     case (doargnames, argnames) of
1246 :     (true, SOME nl) =>
1247 : blume 977 ERecord (ListPair.zip (map arg_id (extra_argname @ nl),
1248 :     ml_vars))
1249 : blume 975 | _ => ETuple ml_vars
1250 : blume 828 in
1251 : blume 1096 fn () =>
1252 :     pr_fdef (if is_light then "f'" else "f", [argspat], ml_res)
1253 : blume 828 end
1254 : blume 1011 fun do_fsig is_light = let
1255 :     val p = if is_light then "'" else ""
1256 : blume 828 in
1257 : blume 1011 pr_vdecl ("f" ^ p, topfunc_ty p (spec, argnames))
1258 : blume 828 end
1259 : blume 1011 val fstruct = "structure " ^ Fstruct name
1260 : blume 1096 val (do_f_heavy, inc) =
1261 :     (if doheavy then mk_do_f false else (fn () => ()), false)
1262 :     handle Incomplete => (fn () => (), true)
1263 : blume 828 in
1264 : blume 1011 str "local";
1265 :     Box 4;
1266 : blume 1036 nl (); str "open C.Dim C_Int";
1267 : blume 1011 pr_vdef ("h", EApp (EVar libraryhandle, EString name));
1268 : blume 828 endBox ();
1269 : blume 1011 nl (); str "in";
1270 :     nl (); str (fstruct ^ " : sig");
1271 :     Box 4;
1272 :     pr_vdecl ("typ", rtti_ty (S.FPTR spec));
1273 :     pr_vdecl ("fptr", Arrow (Unit, wtn_ty (S.FPTR spec)));
1274 : blume 1096 if doheavy andalso not inc then do_fsig false else ();
1275 :     if dolight orelse inc then do_fsig true else ();
1276 : blume 828 endBox ();
1277 : blume 1011 nl (); str "end = struct";
1278 :     Box 4;
1279 :     pr_vdef ("typ", rtti_val (S.FPTR spec));
1280 :     pr_fdef ("fptr",
1281 :     [EUnit],
1282 :     EApp (EVar "mk_fptr",
1283 :     ETuple [EVar (fptr_mkcall spec),
1284 :     EApp (EVar "h", EUnit)]));
1285 : blume 1096 do_f_heavy ();
1286 :     if dolight orelse inc then mk_do_f true () else ();
1287 : blume 828 endBox ();
1288 : blume 1011 nl (); str "end"; nl (); str "end"; nl ();
1289 :     closePP ();
1290 :     exports := fstruct :: !exports
1291 :     end
1292 : blume 828
1293 : blume 1011 fun do_cmfile () = let
1294 :     val file = descrfile cmfile
1295 :     val { closePP, line, str, nl, VBox, endBox, ... } =
1296 :     openPP (file, NONE)
1297 : blume 828 in
1298 : blume 1011 str "(primitive c-int)";
1299 : blume 828 line "library";
1300 :     VBox 4;
1301 : blume 1011 app line (!exports);
1302 : blume 828 endBox ();
1303 : blume 1011 nl (); str "is";
1304 : blume 828 VBox 4;
1305 : blume 1078 app line ["$/basis.cm",
1306 :     "$c/internals/c-int.cm",
1307 :     "$smlnj/init/init.cmi : cm"];
1308 : blume 1011 app line (!files);
1309 : blume 828 endBox ();
1310 :     nl ();
1311 : blume 1011 closePP ()
1312 : blume 828 end
1313 :     in
1314 : blume 1062 IM.app pr_fptr_rtti fptr_types;
1315 :     SM.app pr_st_structure structs;
1316 :     SM.app pr_ut_structure unions;
1317 : blume 1096 SM.app pr_et_structure enums;
1318 :     SS.app pr_i_st_structure incomplete_structs;
1319 :     SS.app pr_i_ut_structure incomplete_unions;
1320 :     SS.app pr_i_et_structure incomplete_enums;
1321 : blume 1062 SM.app pr_s_structure structs;
1322 :     SM.app pr_u_structure unions;
1323 : blume 1096 SM.app pr_e_structure enums;
1324 : blume 1011 app pr_t_structure gtys;
1325 :     app pr_gvar gvars;
1326 :     app pr_gfun gfuns;
1327 :     do_cmfile ()
1328 : blume 828 end
1329 :     end
1330 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0