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

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