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 1060 - (view) (download)

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

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