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

1 : blume 828 (*
2 :     * gen.sml - Generating and pretty-printing ML code implementing a
3 :     * typed interface to a C program.
4 :     *
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 :     val version = "0.1"
12 :     val author = "Matthias Blume"
13 :     val email = "blume@research.bell-labs.com"
14 :     structure S = Spec
15 :     in
16 :    
17 :     structure Gen :> sig
18 :     val gen : { idlfile: string,
19 :     idlsource: string,
20 :     sigfile: string,
21 :     strfile: string,
22 :     cmfile: string,
23 :     signame: string,
24 :     strname: string,
25 :     allSU: bool,
26 :     lambdasplit: string option,
27 :     wid: int } -> unit
28 :     end = struct
29 :    
30 :     structure P = PrettyPrint
31 :     structure PP = P.PP
32 :     val Tuple = P.TUPLE
33 :     val Con = P.CON
34 :     val Arrow = P.ARROW
35 :     val Type = P.Type
36 :     val St = P.St
37 :     val Un = P.Un
38 :     val Unit = P.Unit
39 :     val ETuple = P.ETUPLE
40 :     val EVar = P.EVAR
41 :     val EApp = P.EAPP
42 :     val EConstr = P.ECONSTR
43 :     val ESeq = P.ESEQ
44 :     fun EWord w = EVar ("0wx" ^ Word.toString w)
45 :     fun EInt i = EVar (Int.toString i)
46 :     fun EString s = EVar (concat ["\"", String.toString s, "\""])
47 :    
48 :     val dontedit = "(* This file has been generated automatically. \
49 :     \DO NOT EDIT! *)"
50 :     fun mkCredits src = concat ["(* [from ", src, " by ", author, "'s ",
51 :     program, " (version ", version, ")] *)"]
52 :     val commentsto = concat ["(* Send comments and suggestions to ",
53 :     email, ". Thanks! *)"]
54 :    
55 :     fun gen args = let
56 :    
57 :     val { idlfile, idlsource,
58 :     sigfile, strfile, cmfile,
59 :     signame, strname,
60 :     allSU, lambdasplit,
61 :     wid } = args
62 :    
63 :     val credits = mkCredits idlfile
64 :    
65 :     val astbundle = ParseToAst.fileToAst'
66 :     TextIO.stdErr
67 :     (GenSizes.sizes, State.INITIAL)
68 :     idlsource
69 :    
70 :     val spec = AstToSpec.build (astbundle, GenSizes.sizes, idlfile, allSU)
71 :    
72 :     val { structs, unions, gvars, gfuns, gtys } = spec
73 :    
74 :     fun openPP f =
75 :     PP.openStream (SimpleTextIODev.openDev { dst = TextIO.openOut f,
76 :     wid = wid })
77 :    
78 :     exception Incomplete
79 :    
80 :     fun get_struct t =
81 :     case List.find (fn s => #tag s = t) structs of
82 :     SOME x => x
83 :     | NONE => raise Incomplete
84 :     fun get_union t =
85 :     case List.find (fn u => #tag u = t) unions of
86 :     SOME x => x
87 :     | NONE => raise Incomplete
88 :    
89 :     fun stem S.SCHAR = "schar"
90 :     | stem S.UCHAR = "uchar"
91 :     | stem S.SINT = "sint"
92 :     | stem S.UINT = "uint"
93 :     | stem S.SSHORT = "sshort"
94 :     | stem S.USHORT = "ushort"
95 :     | stem S.SLONG = "slong"
96 :     | stem S.ULONG = "ulong"
97 :     | stem S.FLOAT = "float"
98 :     | stem S.DOUBLE = "double"
99 :     | stem S.VOIDPTR = "voidptr"
100 :     | stem _ = raise Fail "bad stem"
101 :    
102 :     fun sinsert (s: string, l) =
103 :     case List.find (fn s' => s = s') l of
104 :     SOME _ => l
105 :     | NONE => s :: l
106 :    
107 :     (* We don't expect many different function pointer types or
108 :     * incomplete types in any given C interface, so using linear
109 :     * lists here is probably ok. *)
110 :     val (fptr_types, incomplete_structs, incomplete_unions) = let
111 :     fun ty ((S.SCHAR | S.UCHAR | S.SINT | S.UINT |
112 :     S.SSHORT | S.USHORT |
113 :     S.SLONG | S.ULONG | S.FLOAT | S.DOUBLE |
114 :     S.VOIDPTR), a) = a
115 :     | ty (S.STRUCT t, a as (f, s, u)) =
116 :     ((ignore (get_struct t); a)
117 :     handle Incomplete => (f, sinsert (t, s), u))
118 :     | ty (S.UNION t, a as (f, s, u)) =
119 :     ((ignore (get_union t); a)
120 :     handle Incomplete => (f, s, sinsert (t, u)))
121 :     | ty ((S.PTR (_, t) | S.ARR { t, ... }), a) = ty (t, a)
122 :     | ty (S.FPTR cft, a as (f, s, u)) =
123 :     if List.exists (fn (cft', _) => cft = cft') f then a
124 :     else ((cft, length f) :: f, s, u)
125 :     fun fs (S.OFIELD { spec = (_, t), ... }, a) = ty (t, a)
126 :     | fs (_, a) = a
127 :     fun f ({ name, spec }, a) = fs (spec, a)
128 :     fun s ({ tag, size, anon, fields }, a) = foldl f a fields
129 :     fun u ({ tag, size, anon, largest, all }, a) =
130 :     foldl f a (largest :: all)
131 :     fun gty ({ name, spec }, a) = ty (spec, a)
132 :     fun gvar ({ name, spec = (_, t) }, a) = ty (t, a)
133 :     fun gfun ({ name, spec }, a) = ty (S.FPTR spec, a)
134 :     in
135 :     foldl gfun (foldl gvar
136 :     (foldl gty (foldl u (foldl s ([], [], []) structs)
137 :     unions)
138 :     gtys)
139 :     gvars)
140 :     gfuns
141 :     end
142 :    
143 :     fun incomplete t = let
144 :     fun decide (K, tag: Spec.tag, l) =
145 :     if List.exists (fn tag' => tag = tag') l then
146 :     SOME (K, tag)
147 :     else NONE
148 :     in
149 :     case t of
150 :     S.STRUCT tag => decide ("S", tag, incomplete_structs)
151 :     | S.UNION tag => decide ("U", tag, incomplete_unions)
152 :     | _ => NONE
153 :     end
154 :    
155 : blume 836 val cgtys = List.filter (not o isSome o incomplete o #spec) gtys
156 :    
157 : blume 828 fun istruct (K, tag) = concat ["I_", K, "_", tag]
158 :    
159 :     fun rwro S.RW = Type "rw"
160 :     | rwro S.RO = Type "ro"
161 :    
162 :     fun dim_ty 0 = Type "dec"
163 :     | dim_ty n = Con ("dg" ^ Int.toString (n mod 10),
164 :     [dim_ty (n div 10)])
165 :    
166 : blume 831 fun Suobj'rw p sut = Con ("su_obj" ^ p, [sut, Type "rw"])
167 : blume 828 fun Suobj'ro sut = Con ("su_obj'", [sut, Type "ro"])
168 :     fun Suobj''c sut = Con ("su_obj'", [sut, Type "'c"])
169 :    
170 :     fun wtn_f_fptr_p p { args, res } = let
171 :     fun topty (S.STRUCT t) = Suobj'ro (St t)
172 :     | topty (S.UNION t) = Suobj'ro (Un t)
173 :     | topty t = wtn_ty' t
174 :     val (res_t, extra_arg_t) =
175 :     case res of
176 :     NONE => (Unit, [])
177 :     | SOME (S.STRUCT t) => let
178 : blume 831 val ot = Suobj'rw "'" (St t)
179 : blume 828 in
180 :     (ot, [ot])
181 :     end
182 :     | SOME (S.UNION t) => let
183 : blume 831 val ot = Suobj'rw "'" (Un t)
184 : blume 828 in
185 :     (ot, [ot])
186 :     end
187 :     | SOME t => (topty t, [])
188 :     val arg_tl = extra_arg_t @ map topty args
189 :     val dom_t = Tuple arg_tl
190 :     val fct_t = Arrow (dom_t, res_t)
191 :     in
192 :     (Con ("fptr" ^ p, [fct_t]), fct_t)
193 :     end
194 :    
195 :     and wtn_f_ty_p p (t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
196 :     S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
197 :     S.FLOAT | S.DOUBLE | S.VOIDPTR)) =
198 :     (Type (stem t), Unit)
199 :     | wtn_f_ty_p p (S.STRUCT t) = (Con ("su", [St t]), Unit)
200 :     | wtn_f_ty_p p (S.UNION t) = (Con ("su", [Un t]), Unit)
201 :     | wtn_f_ty_p p (S.PTR (c, t)) =
202 :     (case incomplete t of
203 :     SOME (K, tag) =>
204 :     (Con (concat [istruct (K, tag), ".iptr", p], [rwro c]), Unit)
205 :     | NONE => let
206 :     val (w, f) = wtn_f_ty t
207 :     in
208 :     (Con ("ptr" ^ p, [w, f, rwro c]), f)
209 :     end)
210 :     | wtn_f_ty_p p (S.ARR { t, d, ... }) = let
211 :     val (w, f) = wtn_f_ty t
212 :     in
213 : blume 836 (Con ("arr", [w, dim_ty d]), f)
214 : blume 828 end
215 :     | wtn_f_ty_p p (S.FPTR spec) = wtn_f_fptr_p p spec
216 :    
217 :     and wtn_f_ty t = wtn_f_ty_p "" t
218 :    
219 :     and wtn_ty t = #1 (wtn_f_ty t)
220 :    
221 :     and wtn_ty' t = #1 (wtn_f_ty_p "'" t)
222 :    
223 :     fun topfunc_ty p { args, res } = let
224 :     fun topty S.SCHAR = Type "MLRep.SChar.int"
225 :     | topty S.UCHAR = Type "MLRep.UChar.word"
226 :     | topty S.SINT = Type "MLRep.SInt.int"
227 :     | topty S.UINT = Type "MLRep.UInt.word"
228 :     | topty S.SSHORT = Type "MLRep.SShort.int"
229 :     | topty S.USHORT = Type "MLRep.UShort.word"
230 :     | topty S.SLONG = Type "MLRep.SLong.int"
231 :     | topty S.ULONG = Type "MLRep.ULong.word"
232 :     | topty S.FLOAT = Type "MLRep.Float.real"
233 :     | topty S.DOUBLE = Type "MLRep.Double.real"
234 :     | topty (S.STRUCT t) = Con ("su_obj" ^ p, [St t, Type "'c"])
235 :     | topty (S.UNION t) = Con ("su_obj" ^ p, [Un t, Type "'c"])
236 :     | topty t = #1 (wtn_f_ty_p p t)
237 :     val (res_t, extra_arg_t) =
238 :     case res of
239 :     NONE => (Unit, [])
240 :     | SOME (S.STRUCT t) => let
241 : blume 831 val ot = Suobj'rw p (St t)
242 : blume 828 in
243 :     (ot, [ot])
244 :     end
245 :     | SOME (S.UNION t) => let
246 : blume 831 val ot = Suobj'rw p (Un t)
247 : blume 828 in
248 :     (ot, [ot])
249 :     end
250 :     | SOME t => (topty t, [])
251 :     in
252 :     Arrow (Tuple (extra_arg_t @ map topty args), res_t)
253 :     end
254 :    
255 :     fun rti_ty t = let
256 :     val (w, f) = wtn_f_ty t
257 :     in
258 :     Con ("T.typ", [w, f])
259 :     end
260 :    
261 :     fun obj_ty p (t, c) = let
262 :     val (w, f) = wtn_f_ty t
263 :     in
264 :     Con ("obj" ^ p, [w, f, c])
265 :     end
266 :    
267 :     fun cro S.RW = Type "'c"
268 :     | cro S.RO = Type "ro"
269 :    
270 :     fun dim_val n = let
271 :     fun build 0 = EVar "dec"
272 :     | build n = EApp (build (n div 10),
273 :     EVar ("dg" ^ Int.toString (n mod 10)))
274 :     in
275 :     EApp (build n, EVar "dim")
276 :     end
277 :    
278 :     local
279 :     fun simple v = EVar ("T." ^ v)
280 :     in
281 :     fun rti_val (t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
282 :     S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
283 :     S.FLOAT | S.DOUBLE | S.VOIDPTR)) =
284 :     simple (stem t)
285 :     | rti_val (S.STRUCT t) = EVar (concat ["S_", t, ".typ"])
286 :     | rti_val (S.UNION t) = EVar (concat ["U_", t, ".typ"])
287 :     | rti_val (S.FPTR cft) =
288 :     (case List.find (fn x => #1 x = cft) fptr_types of
289 :     SOME (_, i) => EVar ("fptr_rti_" ^ Int.toString i)
290 :     | NONE => raise Fail "fptr type missing")
291 :     | rti_val (S.PTR (S.RW, t)) =
292 :     (case incomplete t of
293 :     SOME (K, tag) =>
294 :     EVar (istruct (K, tag) ^ ".typ'rw")
295 :     | NONE => EApp (EVar "T.pointer", rti_val t))
296 :     | rti_val (S.PTR (S.RO, t)) =
297 :     (case incomplete t of
298 :     SOME (K, tag) =>
299 :     EVar (istruct (K, tag) ^ ".typ'ro")
300 :     | NONE => EApp (EVar "T.ro",
301 :     EApp (EVar "T.pointer", rti_val t)))
302 :     | rti_val (S.ARR { t, d, ... }) =
303 :     EApp (EVar "T.arr", ETuple [rti_val t, dim_val d])
304 :     end
305 :    
306 :     fun do_sig_file () = let
307 :    
308 :     val sigpp = openPP sigfile
309 :    
310 :     fun nl () = PP.newline sigpp
311 :     fun str s = PP.string sigpp s
312 :     fun sp () = PP.space sigpp 1
313 :     fun nsp () = PP.nbSpace sigpp 1
314 :     fun Box a = PP.openBox sigpp (PP.Abs a)
315 :     fun HBox () = PP.openHBox sigpp
316 :     fun HOVBox a = PP.openHOVBox sigpp (PP.Abs a)
317 :     fun VBox a = PP.openVBox sigpp (PP.Abs a)
318 :     fun endBox () = PP.closeBox sigpp
319 :     fun ppty t = P.ppType sigpp t
320 :    
321 :     fun pr_su_tag t =
322 :     (nl (); HBox (); str "type"; sp (); ppty t; endBox ())
323 :    
324 :     fun pr_struct_tag { tag, size, anon, fields } =
325 :     pr_su_tag (St tag)
326 :    
327 :     fun pr_union_tag { tag, size, anon, largest, all } =
328 :     pr_su_tag (Un tag)
329 :    
330 :     fun pr_decl (keyword, connector) (v, t) =
331 :     (nl (); HOVBox 4; str keyword; nsp (); str v; nsp ();
332 :     str connector; sp (); ppty t; endBox ())
333 :    
334 :     val pr_tdef = pr_decl ("type", "=")
335 :     val pr_vdecl = pr_decl ("val", ":")
336 :    
337 :     fun pr_su_structure (StUn, K, su, tag, fields) = let
338 :    
339 :     fun pr_field_typ { name, spec = S.OFIELD { spec = (c, t),
340 :     synthetic = false,
341 :     offset } } =
342 :     pr_tdef ("t_f_" ^ name, wtn_ty t)
343 :     | pr_field_typ _ = ()
344 :    
345 :     fun pr_field_rti { name, spec = S.OFIELD { spec = (c, t),
346 :     synthetic = false,
347 :     offset } } =
348 :     pr_vdecl ("typ_f_" ^ name, rti_ty t)
349 :     | pr_field_rti _ = ()
350 :    
351 :     fun pr_field_acc0 (name, p, t) =
352 :     pr_vdecl (concat ["f_", name, p],
353 :     Arrow (Con ("su_obj" ^ p, [StUn tag, Type "'c"]),
354 :     t))
355 :    
356 :     fun pr_bf_acc (name, p, sg, c) =
357 :     pr_field_acc0 (name, p, Con (sg ^ "bf", [cro c]))
358 :    
359 :     fun pr_field_acc p { name, spec = S.OFIELD { spec = (c, t),
360 :     synthetic = false,
361 :     offset } } =
362 :     pr_field_acc0 (name, p, obj_ty p (t, cro c))
363 :     | pr_field_acc p { name, spec = S.OFIELD _ } = ()
364 :     | pr_field_acc p { name, spec = S.SBF bf } =
365 :     pr_bf_acc (name, p, "s", #constness bf)
366 :     | pr_field_acc p { name, spec = S.UBF bf } =
367 :     pr_bf_acc (name, p, "u", #constness bf)
368 :     in
369 :     nl ();
370 :     nl (); str (concat ["structure ", K, "_", tag,
371 :     " : sig (* ", su, " ", tag, " *)"]);
372 :     Box 4;
373 :     pr_tdef ("tag", StUn tag);
374 :     nl ();
375 :     nl (); str (concat ["(* size for this ", su, " *)"]);
376 :     pr_vdecl ("size", Con ("S.size", [Con ("su", [StUn tag])]));
377 :     nl ();
378 :     nl (); str (concat ["(* RTI for this ", su, " *)"]);
379 :     pr_vdecl ("typ", Con ("T.su_typ", [StUn tag]));
380 :     nl ();
381 :     nl (); str "(* witness types for fields *)";
382 :     app pr_field_typ fields;
383 :     nl ();
384 :     nl (); str "(* RTI for fields *)";
385 :     app pr_field_rti fields;
386 :     nl ();
387 :     nl (); str "(* field accessors *)";
388 :     app (pr_field_acc "") fields;
389 :     nl ();
390 :     nl (); str "(* field accessors (lightweight variety) *)";
391 :     app (pr_field_acc "'") fields;
392 :     endBox ();
393 :     nl (); str (concat ["end (* structure ", K, "_", tag, " *)"])
394 :     end
395 :    
396 :     fun pr_struct_structure { tag, size, anon, fields } =
397 :     pr_su_structure (St, "S", "struct", tag, fields)
398 :     fun pr_union_structure { tag, size, anon, largest, all } =
399 :     pr_su_structure (Un, "U", "union", tag, all)
400 :    
401 :     fun pr_gty_rti { name, spec } =
402 :     pr_vdecl ("typ_t_" ^ name, rti_ty spec)
403 :    
404 :     fun pr_gvar_obj { name, spec = (c, t) } =
405 :     pr_vdecl ("g_" ^ name, Arrow (Unit, obj_ty "" (t, rwro c)))
406 :    
407 :     fun pr_gfun_rti { name, spec } =
408 :     pr_vdecl ("typ_fn_" ^ name, rti_ty (S.FPTR spec))
409 :    
410 :     fun pr_gfun_fptr { name, spec } =
411 :     pr_vdecl ("fptr_fn_" ^ name,
412 :     Arrow (Unit, wtn_ty (S.FPTR spec)))
413 :    
414 :     fun pr_gfun_func p { name, spec } =
415 :     pr_vdecl (concat ["fn_", name, p], topfunc_ty p spec)
416 :    
417 :     fun pr_isu (K, tag) =
418 :     (nl ();
419 :     str (concat ["structure ", istruct (K, tag),
420 :     " : POINTER_TO_INCOMPLETE_TYPE"]))
421 :     fun pr_istruct tag = pr_isu ("S", tag)
422 :     fun pr_iunion tag = pr_isu ("U", tag)
423 :     in
424 :     (* Generating the signature file... *)
425 :     str dontedit;
426 :     nl (); str credits;
427 :     nl (); str commentsto;
428 :     nl (); str "local open C.Dim C in";
429 :     nl (); str (concat ["signature ", signame, " = sig"]);
430 :     VBox 4;
431 :     app pr_istruct incomplete_structs;
432 :     app pr_iunion incomplete_unions;
433 :     app pr_struct_tag structs;
434 :     app pr_union_tag unions;
435 :     app pr_struct_structure structs;
436 :     app pr_union_structure unions;
437 : blume 836 if not (List.null cgtys) then
438 : blume 828 (nl (); nl (); str "(* RTI for typedefs *)";
439 : blume 836 app pr_gty_rti cgtys)
440 : blume 828 else ();
441 :     if not (List.null gvars) then
442 :     (nl (); nl (); str "(* object handles for global variables *)";
443 :     app pr_gvar_obj gvars)
444 :     else ();
445 :     if not (List.null gfuns) then
446 :     (nl (); nl (); str "(* RTI for global function(-pointer)s *)";
447 :     app pr_gfun_rti gfuns;
448 :     nl (); nl (); str "(* global function pointers *)";
449 :     app pr_gfun_fptr gfuns;
450 :     nl (); nl (); str "(* global functions *)";
451 :     app (pr_gfun_func "'") gfuns;
452 :     app (pr_gfun_func "") gfuns)
453 :     else ();
454 :     endBox ();
455 :     nl (); str (concat ["end (* signature ", signame, " *)"]);
456 :     nl (); str "end (* local *)";
457 :     nl ();
458 :    
459 :     PP.closeStream sigpp
460 :     end
461 :    
462 :     fun do_fct_file () = let
463 :     val strpp = openPP strfile
464 :    
465 :     fun nl () = PP.newline strpp
466 :     fun str s = PP.string strpp s
467 :     fun sp () = PP.space strpp 1
468 :     fun nsp () = PP.nbSpace strpp 1
469 :     fun Box a = PP.openBox strpp (PP.Abs a)
470 :     fun HBox () = PP.openHBox strpp
471 :     fun HOVBox a = PP.openHOVBox strpp (PP.Abs a)
472 :     fun VBox a = PP.openVBox strpp (PP.Abs a)
473 :     fun endBox () = PP.closeBox strpp
474 :     fun ppty t = P.ppType strpp t
475 :     fun ppExp e = P.ppExp strpp e
476 :     fun ppFun x = P.ppFun strpp x
477 :    
478 :     fun pr_fdef (f, args, res) = (nl (); ppFun (f, args, res))
479 :    
480 :     fun pr_def_t (sep, keyword, connector) (v, t) =
481 :     (sep ();
482 :     HOVBox 4; str keyword; nsp (); str v; nsp (); str connector;
483 :     sp (); ppty t; endBox ())
484 :    
485 :     val pr_vdecl = pr_def_t (fn () => (), "val", ":")
486 :    
487 :     val pr_tdef = pr_def_t (nl, "type", "=")
488 :    
489 :     fun pr_vdef (v, e) =
490 :     (nl ();
491 :     HOVBox 4; str "val"; nsp (); str v; nsp (); str "=";
492 :     sp (); ppExp e; endBox ())
493 :    
494 :     fun pr_su_tag (su, tag, false) =
495 :     let fun build [] = Type su
496 :     | build (h :: tl) = Con ("t_" ^ String.str h, [build tl])
497 :     in
498 :     pr_tdef (concat [su, "_", tag],
499 :     build (rev (String.explode tag)))
500 :     end
501 :     | pr_su_tag (su, tag, true) =
502 :     (nl (); str "local";
503 :     VBox 4;
504 :     nl (); str
505 :     "structure X :> sig type t end = struct type t = unit end";
506 :     endBox ();
507 :     nl (); str "in";
508 :     VBox 4;
509 :     pr_tdef (concat [su, "_", tag],
510 :     Type "X.t");
511 :     endBox ();
512 :     nl (); str "end")
513 :    
514 :     fun pr_struct_tag { tag, size, anon, fields } =
515 :     pr_su_tag ("s", tag, anon)
516 :     fun pr_union_tag { tag, size, anon, largest, all } =
517 :     pr_su_tag ("u", tag, anon)
518 :    
519 :     fun pr_su_tag_copy (k, tag) = let
520 :     val tn = concat [k, "_", tag]
521 :     in
522 :     pr_tdef (tn, Type tn)
523 :     end
524 :    
525 :     fun pr_struct_tag_copy { tag, size, anon, fields } =
526 :     pr_su_tag_copy ("s", tag)
527 :     fun pr_union_tag_copy { tag, size, anon, largest, all } =
528 :     pr_su_tag_copy ("u", tag)
529 :    
530 :     fun pr_fptr_rti ({ args, res }, i) = let
531 :    
532 :     (* cproto encoding *)
533 :     fun List t = Con ("list", [t])
534 :     val Real = Type "real"
535 :     val Char = Type "char"
536 :     val Word8 = Type "Word8.word"
537 :     val Int31 = Type "Int31.int"
538 :     val Word31 = Type "Word31.word"
539 :     val Int32 = Type "Int32.int"
540 :     val Word32 = Type "Word32.word"
541 :     val String = Type "string"
542 :     val Exn = Type "exn"
543 :    
544 :     (* see src/compiler/Semant/types/cproto.sml for these... *)
545 :     val E_double = Real
546 :     val E_float = List Real
547 :     val E_schar = Char
548 :     val E_uchar = Word8
549 :     val E_sint = Int31
550 :     val E_uint = Word31
551 :     val E_slong = Int32
552 :     val E_ulong = Word32
553 :     val E_sshort = List Char
554 :     val E_ushort = List Word8
555 :     val E_sllong = List Int32 (* not used yet *)
556 :     val E_ullong = List Word32(* not used yet *)
557 :     val E_ptr = String
558 :     val E_nullstruct = Exn
559 :    
560 :     fun encode S.DOUBLE = E_double
561 :     | encode S.FLOAT = E_float
562 :     | encode S.SCHAR = E_schar
563 :     | encode S.UCHAR = E_uchar
564 :     | encode S.SINT = E_sint
565 :     | encode S.UINT = E_uint
566 :     | encode S.SSHORT = E_sshort
567 :     | encode S.USHORT = E_ushort
568 :     | encode S.SLONG = E_slong
569 :     | encode S.ULONG = E_ulong
570 :     | encode (S.PTR _ | S.VOIDPTR | S.FPTR _) = E_ptr
571 :     | encode (S.ARR _) = raise Fail "unexpected array"
572 :     | encode (S.STRUCT t) =
573 :     encode_fields (#fields (get_struct t))
574 :     | encode (S.UNION t) =
575 :     encode_fields [#largest (get_union t)]
576 :    
577 :     and encode_fields fields = let
578 :     fun f0 (S.ARR { t, d = 0, ... }, a) = a
579 :     | f0 (S.ARR { t, d = 1, ... }, a) = f0 (t, a)
580 :     | f0 (S.ARR { t, d, esz }, a) =
581 :     f0 (t, f0 (S.ARR { t = t, d = d - 1, esz = esz }, a))
582 :     | f0 (t, a) = encode t :: a
583 :     fun f ({ spec = S.OFIELD { spec, ... }, name }, a) =
584 :     f0 (#2 spec, a)
585 :     | f (_, a) = a
586 :     val fel = foldr f [] fields
587 :     in
588 :     case fel of
589 :     [] => E_nullstruct
590 :     | fel => Tuple (Unit :: fel)
591 :     end
592 :    
593 :     val e_arg = Tuple (Unit :: map encode args)
594 :     val e_res = case res of NONE => Unit | SOME t => encode t
595 :     val e_proto = Con ("list", [Arrow (e_arg, e_res)])
596 :    
597 :     (* generating the call operation *)
598 :    
599 :     (* low-level type used to communicate a value to the
600 :     * low-level call operation *)
601 :     fun mlty S.SCHAR = Type "CMemory.cc_schar"
602 :     | mlty S.UCHAR = Type "CMemory.cc_uchar"
603 :     | mlty S.SINT = Type "CMemory.cc_sint"
604 :     | mlty S.UINT = Type "CMemory.cc_uint"
605 :     | mlty S.SSHORT = Type "CMemory.cc_sshort"
606 :     | mlty S.USHORT = Type "CMemory.cc_ushort"
607 :     | mlty S.SLONG = Type "CMemory.cc_slong"
608 :     | mlty S.ULONG = Type "CMemory.cc_ulong"
609 :     | mlty S.FLOAT = Type "CMemory.cc_float"
610 :     | mlty S.DOUBLE = Type "CMemory.cc_double"
611 :     | mlty (S.VOIDPTR | S.PTR _ | S.FPTR _ |
612 :     S.STRUCT _) = Type "CMemory.cc_addr"
613 :     | mlty (S.ARR _ | S.UNION _) = raise Fail "unexpected type"
614 :    
615 :     fun wrap (e, n) =
616 :     EApp (EVar ("CMemory.wrap_" ^ n),
617 :     EApp (EVar ("Cvt.ml_" ^ n), e))
618 :    
619 :     fun vwrap e = EApp (EVar "CMemory.wrap_addr",
620 :     EApp (EVar "reveal", e))
621 :     fun fwrap e = EApp (EVar "CMemory.wrap_addr",
622 :     EApp (EVar "freveal", e))
623 :     fun pwrap e = EApp (EVar "CMemory.wrap_addr",
624 :     EApp (EVar "reveal",
625 :     EApp (EVar "Ptr.inject'", e)))
626 :     fun iwrap (K, tag, e) =
627 :     EApp (EVar "CMemory.wrap_addr",
628 :     EApp (EVar "reveal",
629 :     EApp (EVar (istruct (K, tag) ^ ".inject'"),
630 :     e)))
631 :    
632 :     fun suwrap e = pwrap (EApp (EVar "Ptr.|&!", e))
633 :    
634 :     (* this code is for passing structures in pieces
635 :     * (member-by-member); we don't use this and rather
636 :     * provide a pointer to the beginning of the struct *)
637 :    
638 :     fun arglist ([], _) = ([], [])
639 :     | arglist (h :: tl, i) = let
640 :     val p = EVar ("x" ^ Int.toString i)
641 :     val (ta, ea) = arglist (tl, i + 1)
642 :     fun sel e = (mlty h :: ta, e :: ea)
643 :     in
644 :     case h of
645 :     (S.STRUCT _ | S.UNION _) => sel (suwrap p)
646 :     | (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
647 :     S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
648 :     S.FLOAT | S.DOUBLE) => sel (wrap (p, stem h))
649 :     | S.VOIDPTR => sel (vwrap p)
650 :     | S.PTR (_, t) =>
651 :     (case incomplete t of
652 :     SOME (K, tag) => sel (iwrap (K, tag, p))
653 :     | NONE => sel (pwrap p))
654 :     | S.FPTR _ => sel (fwrap p)
655 :     | S.ARR _ => raise Fail "unexpected array argument"
656 :     end
657 :    
658 :     val (ml_res_t,
659 :     extra_arg_v, extra_arg_e, extra_ml_arg_t,
660 :     res_wrap) =
661 :     case res of
662 :     NONE => (Unit, [], [], [], fn r => r)
663 :     | SOME (S.STRUCT _ | S.UNION _) =>
664 :     (Unit,
665 :     [EVar "x0"],
666 :     [suwrap (EVar "x0")],
667 :     [Type "CMemory.cc_addr"],
668 :     fn r => ESeq (r, EVar "x0"))
669 :     | SOME t => let
670 :     fun unwrap n r =
671 :     EApp (EVar ("Cvt.c_" ^ n),
672 :     EApp (EVar ("CMemory.unwrap_" ^ n), r))
673 :     fun punwrap cast r =
674 :     EApp (EVar cast,
675 :     EApp (EVar "CMemory.unwrap_addr", r))
676 :     fun iunwrap (K, tag, t) r =
677 :     EApp (EApp (EVar (istruct (K, tag) ^
678 :     ".project'"),
679 :     rti_val t),
680 :     punwrap "vcast" r)
681 :     val res_wrap =
682 :     case t of
683 :     (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
684 :     S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
685 :     S.FLOAT | S.DOUBLE) => unwrap (stem t)
686 :     | S.VOIDPTR => punwrap "vcast"
687 :     | S.FPTR _ => punwrap "fcast"
688 :     | t0 as S.PTR (_, t) =>
689 :     (case incomplete t of
690 :     SOME (K, tag) => iunwrap (K, tag, t0)
691 :     | NONE => punwrap "pcast")
692 :     | (S.STRUCT _ | S.UNION _ | S.ARR _) =>
693 :     raise Fail "unexpected result type"
694 :     in
695 :     (mlty t, [], [], [], res_wrap)
696 :     end
697 :    
698 :     val (ml_args_tl, args_el) = arglist (args, 1)
699 :    
700 :     val ml_args_t = Tuple (extra_ml_arg_t @ ml_args_tl)
701 :    
702 :     val arg_vl =
703 :     rev (#1 (foldl (fn (_, (a, i)) =>
704 :     (EVar ("x" ^ Int.toString i) :: a,
705 :     i + 1)) ([], 1)
706 :     args))
707 :    
708 :     val arg_e = ETuple (extra_arg_e @ args_el)
709 :     in
710 :     nl ();
711 :     str (concat ["val ", "fptr_rti_", Int.toString i, " = let"]);
712 :     VBox 4;
713 :     pr_vdef ("callop",
714 :     EConstr (EVar "RawMemInlineT.rawccall",
715 :     Arrow (Tuple [Type "Word32.word",
716 :     ml_args_t,
717 :     e_proto],
718 :     ml_res_t)));
719 :     pr_fdef ("mkcall",
720 :     [EVar "a", ETuple (extra_arg_v @ arg_vl)],
721 :     res_wrap (EApp (EVar "callop",
722 :     ETuple [EVar "a", arg_e,
723 :     EVar "nil"])));
724 :     endBox ();
725 :     nl (); str "in";
726 :     VBox 4;
727 :     nl (); ppExp (EConstr (EApp (EVar "mk_fptr_typ",
728 :     EVar "mkcall"),
729 :     rti_ty (S.FPTR { args = args,
730 :     res = res })));
731 :     endBox ();
732 :     nl (); str "end"
733 :     end
734 :    
735 :     fun pr_su_structure (StUn, k, K, tag, size, fields) = let
736 :     fun rwro S.RW = "rw"
737 :     | rwro S.RO = "ro"
738 :     fun pr_field_typ { name, spec = S.OFIELD { spec = (c, t),
739 :     synthetic = false,
740 :     offset } } =
741 :     pr_tdef ("t_f_" ^ name, wtn_ty t)
742 :     | pr_field_typ _ = ()
743 :     fun pr_field_rti { name, spec = S.OFIELD { spec = (c, t),
744 :     synthetic = false,
745 :     offset } } =
746 :     pr_vdef ("typ_f_" ^ name, rti_val t)
747 :     | pr_field_rti _ = ()
748 :    
749 :     fun pr_bf_acc (name, p, sign,
750 :     { offset, constness, bits, shift }) =
751 :     let val maker =
752 :     concat ["mk_", rwro constness, "_", sign, "bf", p]
753 :     in
754 :     pr_fdef (concat ["f_", name, p],
755 :     [EVar "x"],
756 :     EApp (EApp (EVar maker,
757 :     ETuple [EInt offset,
758 :     EWord bits,
759 :     EWord shift]),
760 :     EVar "x"))
761 :     end
762 :    
763 :     fun pr_field_acc' { name, spec = S.OFIELD x } =
764 :     let val { synthetic, spec = (c, t), offset, ... } = x
765 :     in
766 :     if synthetic then ()
767 :     else pr_fdef (concat ["f_", name, "'"],
768 :     [EConstr (EVar "x",
769 :     Suobj''c (StUn tag))],
770 :     EConstr (EApp (EApp (EVar "mk_field'",
771 :     EInt offset),
772 :     EVar "x"),
773 :     obj_ty "'" (t, cro c)))
774 :     end
775 :     | pr_field_acc' { name, spec = S.SBF bf } =
776 :     pr_bf_acc (name, "'", "s", bf)
777 :     | pr_field_acc' { name, spec = S.UBF bf } =
778 :     pr_bf_acc (name, "'", "u", bf)
779 :    
780 :     fun pr_field_acc { name, spec = S.OFIELD { offset,
781 :     spec = (c, t),
782 :     synthetic } } =
783 :     if synthetic then ()
784 :     else let
785 :     val maker = concat ["mk_", rwro c, "_field"]
786 :     val rtival = EVar ("typ_f_" ^ name)
787 :     in
788 :     pr_fdef ("f_" ^ name,
789 :     [EVar "x"],
790 :     EApp (EApp (EApp (EVar maker, rtival),
791 :     EInt offset),
792 :     EVar "x"))
793 :     end
794 :     | pr_field_acc { name, spec = S.SBF bf } =
795 :     pr_bf_acc (name, "", "s", bf)
796 :     | pr_field_acc { name, spec = S.UBF bf } =
797 :     pr_bf_acc (name, "", "u", bf)
798 :     in
799 :     nl ();
800 :     str (concat ["structure ", K, "_", tag, " = struct"]);
801 :     Box 4;
802 :     nl (); str (concat ["open ", K, "_", tag]);
803 :     app pr_field_typ fields;
804 :     app pr_field_rti fields;
805 :     app pr_field_acc' fields;
806 :     app pr_field_acc fields;
807 :     endBox ();
808 :     nl (); str "end"
809 :     end
810 :    
811 :     fun pr_struct_structure { tag, size, anon, fields } =
812 :     pr_su_structure (St, "s", "S", tag, size, fields)
813 :     fun pr_union_structure { tag, size, anon, largest, all } =
814 :     pr_su_structure (Un, "u", "U", tag, size, all)
815 :    
816 :     fun pr_gty_rti { name, spec } =
817 :     pr_vdef ("typ_t_" ^ name, rti_val spec)
818 :    
819 :     fun pr_addr (prefix, name) =
820 :     pr_vdef (prefix ^ name,
821 :     EApp (EApp (EVar "D.lib_symbol", EVar "so_h"),
822 :     EString name))
823 :    
824 :     fun pr_gvar_addr { name, spec } = pr_addr ("gh_", name)
825 :    
826 :     fun pr_gvar_obj { name, spec = (c, t) } = let
827 :     val rwobj = EApp (EApp (EVar "mk_obj", rti_val t),
828 :     EApp (EVar "D.addr", EVar ("gh_" ^ name)))
829 :     val obj = case c of S.RW => rwobj
830 :     | S.RO => EApp (EVar "ro", rwobj)
831 :     in
832 :     pr_fdef ("g_" ^ name, [ETuple []], obj)
833 :     end
834 :    
835 :     fun pr_gfun_rti { name, spec } =
836 :     pr_vdef ("typ_fn_" ^ name, rti_val (S.FPTR spec))
837 :    
838 :     fun pr_gfun_addr { name, spec } = pr_addr ("fnh_", name)
839 :    
840 :     fun pr_gfun_fptr { name, spec } =
841 :     pr_fdef ("fptr_fn_" ^ name,
842 :     [ETuple []],
843 :     EApp (EApp (EVar "mk_fptr", EVar ("typ_fn_" ^ name)),
844 :     EApp (EVar "D.addr", EVar ("fnh_" ^ name))))
845 :    
846 :     fun pr_gfun_func is_light { name, spec = { args, res } } = let
847 :     val p = if is_light then "'" else ""
848 :     val ml_vars =
849 :     rev (#1 (foldl (fn (_, (l, i)) =>
850 :     (EVar ("x" ^ Int.toString i) :: l,
851 :     i + 1))
852 :     ([], 1)
853 :     args))
854 :     fun app0 (what, e) =
855 :     if is_light then e else EApp (EVar what, e)
856 :     fun light (what, e) = app0 ("Light." ^ what, e)
857 :     fun heavy (what, t, e) =
858 :     if is_light then e
859 :     else EApp (EApp (EVar ("Heavy." ^ what), rti_val t), e)
860 :    
861 :     fun oneArg (e, t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
862 :     S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
863 :     S.FLOAT | S.DOUBLE)) =
864 :     EApp (EVar ("Cvt.c_" ^ stem t), e)
865 :     | oneArg (e, (S.STRUCT _ | S.UNION _)) =
866 :     EApp (EVar "ro'", light ("obj", e))
867 :     | oneArg (e, S.PTR (_, t)) =
868 :     (case incomplete t of
869 :     SOME (K, tag) =>
870 :     app0 (istruct (K, tag) ^ ".light", e)
871 :     | NONE => light ("ptr", e))
872 :     | oneArg (e, S.FPTR _) = light ("fptr", e)
873 :     | oneArg (e, S.VOIDPTR) = e
874 :     | oneArg (e, S.ARR _) = raise Fail "array argument type"
875 :     val c_exps = ListPair.map oneArg (ml_vars, args)
876 : blume 831 val (ml_vars, c_exps) =
877 :     case res of
878 :     SOME (S.STRUCT _ | S.UNION _) =>
879 :     (EVar "x0" :: ml_vars,
880 :     light ("obj", EVar "x0") :: c_exps)
881 :     | _ => (ml_vars, c_exps)
882 : blume 828 val call = EApp (EVar "call",
883 :     ETuple [EApp (EVar ("fptr_fn_" ^ name),
884 :     ETuple []),
885 :     ETuple c_exps])
886 :     val ml_res =
887 :     case res of
888 :     SOME (t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
889 :     S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
890 :     S.FLOAT | S.DOUBLE)) =>
891 :     EApp (EVar ("Cvt.ml_" ^ stem t), call)
892 :     | SOME (t as (S.STRUCT _ | S.UNION _)) =>
893 :     heavy ("obj", t, call)
894 :     | SOME (S.PTR (_, t)) =>
895 :     (case incomplete t of
896 :     SOME (K, tag) =>
897 :     app0 (istruct (K, tag) ^ ".heavy", call)
898 :     | NONE => heavy ("ptr", t, call))
899 :     | SOME (t as S.FPTR _) => heavy ("fptr", t, call)
900 :     | SOME (S.ARR _) => raise Fail "array result type"
901 :     | (NONE | SOME S.VOIDPTR) => call
902 :     in
903 :     pr_fdef (concat ["fn_", name, p], [ETuple ml_vars], ml_res)
904 :     end
905 :    
906 :     fun pr_isu_arg (K, tag) =
907 :     (sp (); str (concat ["structure ", istruct (K, tag),
908 :     " : POINTER_TO_INCOMPLETE_TYPE"]))
909 :     fun pr_istruct_arg tag = pr_isu_arg ("S", tag)
910 :     fun pr_iunion_arg tag = pr_isu_arg ("U", tag)
911 :    
912 :     fun pr_isu_def (kw, K, tag) = let
913 :     val n = istruct (K, tag)
914 :     in
915 :     nl ();
916 :     str (concat [kw, " ", n, " = ", n])
917 :     end
918 :     fun pr_istruct_res tag = pr_isu_def ("where", "S", tag)
919 :     fun pr_iunion_res tag = pr_isu_def ("where", "U", tag)
920 :     fun pr_istruct_def tag = pr_isu_def ("structure", "S", tag)
921 :     fun pr_iunion_def tag = pr_isu_def ("structure", "U", tag)
922 :    
923 :     fun pr_pre_su (K, k, STUN, StUn, tag, size) =
924 :     (nl (); str (concat ["structure ", K, "_", tag, " = struct"]);
925 :     VBox 4;
926 :     pr_tdef ("tag", Type (concat [k, "_", tag]));
927 :     pr_vdef ("size",
928 :     EConstr (EApp (EVar "C_Int.mk_su_size", EWord size),
929 :     Con ("C.S.size",
930 :     [Con ("C.su", [StUn tag])])));
931 :     pr_vdef ("typ", EApp (EVar "C_Int.mk_su_typ", EVar "size"));
932 :     endBox ();
933 :     nl (); str "end")
934 :    
935 :     fun pr_pre_struct { tag, size, anon, fields } =
936 :     pr_pre_su ("S", "s", S.STRUCT, St, tag, size)
937 :     fun pr_pre_union { tag, size, anon, largest, all } =
938 :     pr_pre_su ("U", "u", S.UNION, Un, tag, size)
939 :     in
940 :     (* Generating the functor file... *)
941 :     str dontedit;
942 :     nl (); str credits;
943 :     nl (); str commentsto;
944 :     nl ();
945 :     str (concat ["structure ", strname, " = struct"]);
946 :     VBox 4;
947 :    
948 :     if length structs + length unions <> 0 then
949 :     (nl (); str "local";
950 :     VBox 4;
951 :     nl (); str "open Tag";
952 :     endBox ();
953 :     nl (); str "in";
954 :     VBox 4;
955 :     (* definitions for struct/union tags *)
956 :     app pr_struct_tag structs;
957 :     app pr_union_tag unions;
958 :     endBox ();
959 :     nl (); str "end")
960 :     else ();
961 :    
962 :     (* "pre"-structures for all structures and unions *)
963 :     app pr_pre_struct structs;
964 :     app pr_pre_union unions;
965 :    
966 :     (* the main functor *)
967 :     nl ();
968 :     str "functor"; nsp (); str (strname ^ "Fn");
969 :     HOVBox 4;
970 :     sp ();
971 :     PP.openHVBox strpp (PP.Rel 1);
972 :     str "(";
973 : blume 829 pr_vdecl ("library", Type "DynLinkage.lib_handle");
974 : blume 828 app pr_istruct_arg incomplete_structs;
975 :     app pr_iunion_arg incomplete_unions;
976 :     str ")";
977 :     endBox ();
978 :     sp (); str ":"; sp (); str signame;
979 :     VBox 4;
980 :     app pr_istruct_res incomplete_structs;
981 :     app pr_iunion_res incomplete_unions;
982 :     endBox ();
983 :     nsp (); str "=";
984 :     endBox ();
985 :     nl (); str "struct";
986 :     VBox 4;
987 :    
988 :     (* copy definitions for struct/union tags *)
989 :     app pr_struct_tag_copy structs;
990 :     app pr_union_tag_copy unions;
991 :    
992 :     (* other local stuff (to define RTI for function pointers) *)
993 :     nl (); str "local";
994 :     VBox 4;
995 :     nl (); str "structure D = DynLinkage";
996 :     nl (); str "open C.Dim C_Int";
997 :    
998 :     (* low-level call operations for all function pointers *)
999 :     app pr_fptr_rti fptr_types;
1000 :    
1001 : blume 829 (* the library handle (handle on shared object) *)
1002 :     nl (); str "val so_h = library";
1003 : blume 828 (* addr handles for global variables *)
1004 :     app pr_gvar_addr gvars;
1005 :     (* addr handles for global C functions *)
1006 :     app pr_gfun_addr gfuns;
1007 :    
1008 :     endBox ();
1009 :     nl (); str "in";
1010 :     VBox 4;
1011 :     (* carry-throughs for incomplete types *)
1012 :     app pr_istruct_def incomplete_structs;
1013 :     app pr_iunion_def incomplete_unions;
1014 :     (* ML structures corresponding to C struct declarations *)
1015 :     app pr_struct_structure structs;
1016 :     (* ML structurse corresponding to C union declarations *)
1017 :     app pr_union_structure unions;
1018 :    
1019 :     (* RTI for C typedefs *)
1020 : blume 836 app pr_gty_rti cgtys;
1021 : blume 828 (* (suspended) objects for global variables *)
1022 :     app pr_gvar_obj gvars;
1023 :     (* RTI for function pointers corresponding to global C functions *)
1024 :     app pr_gfun_rti gfuns;
1025 :     (* (suspended) function pointers for global C functions *)
1026 :     app pr_gfun_fptr gfuns;
1027 :     (* ML functions corresponding to global C functions *)
1028 :     app (pr_gfun_func true) gfuns;(* light *)
1029 :     app (pr_gfun_func false) gfuns;(* heavy *)
1030 :     endBox ();
1031 :     nl (); str "end"; (* local *)
1032 :     endBox ();
1033 :     nl (); str "end"; (* functor/struct *)
1034 :     endBox ();
1035 :     nl (); str "end"; (* structure/struct *)
1036 :     nl ();
1037 :    
1038 :     PP.closeStream strpp
1039 :     end
1040 :    
1041 :     fun do_cm_file () = let
1042 :     val cmpp = openPP cmfile
1043 :    
1044 :     fun nl () = PP.newline cmpp
1045 :     fun str s = PP.string cmpp s
1046 :     fun sp () = PP.space cmpp 1
1047 :     fun nsp () = PP.nbSpace cmpp 1
1048 :     fun VBox a = PP.openVBox cmpp (PP.Abs a)
1049 :     fun endBox () = PP.closeBox cmpp
1050 :     fun line s = (nl (); str s)
1051 :     val ls =
1052 :     case lambdasplit of
1053 :     NONE => ""
1054 :     | SOME s => concat ["\t(lambdasplit:", s, ")"]
1055 :     in
1056 :     (* Generating the .cm file... *)
1057 :     str dontedit;
1058 :     line credits;
1059 :     line commentsto;
1060 :     line "(primitive c-int)";
1061 :     line "library";
1062 :     VBox 4;
1063 :     line ("signature " ^ signame);
1064 :     line ("structure " ^ strname);
1065 :     endBox ();
1066 :     line "is";
1067 :     VBox 4;
1068 :     app line ["$/basis.cm","$/c-int.cm", "$smlnj/init/init.cmi : cm"];
1069 :     line (sigfile ^ ls);
1070 :     line (strfile ^ ls);
1071 :     endBox ();
1072 :     nl ();
1073 :    
1074 :     PP.closeStream cmpp
1075 :     end
1076 :     in
1077 :     do_sig_file ();
1078 :     do_fct_file ();
1079 :     do_cm_file ()
1080 :     end
1081 :     end
1082 :     end

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