2 * 2005 Matthew
Fluet (mfluet@acm
.org
)
4 (* Copyright (C
) 2005-2009 Henry Cejtin
, Matthew Fluet
, Suresh
5 * Jagannathan
, and Stephen Weeks
.
7 * MLton is released under a BSD
-style license
.
8 * See the file MLton
-LICENSE for details
.
13 * gen
.sml
- Generating
and pretty
-printing ML code implementing a
14 * typed interface to a C program
.
16 * (C
) 2004 The Fellowship
of SML
/NJ
18 * author
: Matthias
Blume (blume@tti
-c
.org
)
22 val gen
: {cfiles
: string list
} -> unit
26 structure Linkage
= Control
.Linkage
28 structure P
= PrettyPrint
33 structure LIS
= LargeIntSet
34 structure SM
= StringMap
35 structure SS
= StringSet
40 fun Record
[] = P
.Unit
41 | Record l
= P
.RECORD l
48 fun ERecord
[] = P
.ETUPLE
[]
49 | ERecord l
= P
.ERECORD l
52 val EConstr
= P
.ECONSTR
56 fun EWord w
= EVar ("0wx" ^
Word.toString w
)
57 fun EInt i
= EVar (Int.toString i
)
58 fun ELInt i
= EVar (LargeInt
.toString i
)
59 fun EString s
= EVar (concat
["\"", String.toString s
, "\""])
61 fun warn m
= Out
.output (Out
.error
, "warning: " ^ m
)
62 fun err m
= raise Fail (concat ("gen: " :: m
))
64 fun unimp what
= raise Fail ("unimplemented type: " ^ what
)
65 fun unimp_arg what
= raise Fail ("unimplemented argument type: " ^ what
)
66 fun unimp_res what
= raise Fail ("unimplemented result type: " ^ what
)
68 val writeto
= "write'to"
74 val allSU
= !Control
.allSU
75 val collect_enums
= !Control
.collect_enums
76 val dir
= !Control
.dir
77 val enum_cons
= !Control
.enum_cons
78 val extramembers
= !Control
.extramembers
79 val gensym
= !Control
.gensym
80 val libhandle
= !Control
.libhandle
81 val linkage
= !Control
.linkage
82 val match
= !Control
.match
83 val mlbfile
= !Control
.mlbfile
84 val namedargs
= !Control
.namedargs
85 val prefix
= !Control
.prefix
86 val target
= valOf (!Control
.target
)
87 val weight
= !Control
.weight
88 val width
= !Control
.width
91 if gensym
= "" then "" else "_" ^ gensym
92 val {name
= targetName
,
94 endianShift
= targetEndianShift
} = target
95 val targetName
= String.toLower targetName
96 val {heavy
= doheavy
, light
= dolight
} = weight
98 val hash_cft
= Hash
.mkFHasher ()
99 val hash_mltype
= Hash
.mkTHasher ()
105 val program
= "ml-nlffigen"
106 val version
= "0.9.1"
107 val author
= "Matthias Blume"
108 val email
= "blume@tti-c.org"
110 val modifications
= [{author
= "Matthew Fluet",
111 email
= "mfluet@acm.org",
112 note
= "Adapted for MLton."}]
116 (["(* [by ", author
, "'s ",
117 program
, " (version ", version
, ") for ", targetName
, "] *)"] @
118 (map (fn {author
, email
, note
} =>
119 concat
["\n(* [modified by ", author
,
120 " (", email
, ") <", note
, ">] *)"]))
123 concat
["(* Send comments and suggestions to ", email
, ". Thanks! *)"]
124 val dontedit
= "(* This file has been generated automatically. DO NOT EDIT! *)"
126 fun openPP (f
, src
) =
128 val device
= CPIFDev
.openOut (f
, width
)
129 val stream
= PP
.openStream device
131 fun nl () = PP
.newline stream
132 fun str s
= PP
.string stream s
133 fun sp () = PP
.space stream
1
134 fun nsp () = PP
.nbSpace stream
1
135 fun Box a
= PP
.openBox
stream (PP
.Abs a
)
136 fun HBox () = PP
.openHBox stream
137 fun HVBox x
= PP
.openHVBox stream x
138 fun HOVBox a
= PP
.openHOVBox
stream (PP
.Abs a
)
139 fun VBox a
= PP
.openVBox
stream (PP
.Abs a
)
140 fun endBox () = PP
.closeBox stream
141 fun ppty t
= P
.ppType stream t
142 fun ppExp e
= P
.ppExp stream e
143 fun ppFun x
= P
.ppFun stream x
144 fun line s
= (nl (); str s
)
147 ; str
"val"; nsp (); str v
; nsp (); str
"=" ; sp (); ppExp e
149 fun pr_fdef (f
, args
, res
) = (nl (); ppFun (f
, args
, res
))
150 fun pr_decl (keyword
, connector
) (v
, t
) =
152 ; str keyword
; nsp (); str v
; nsp (); str connector
; sp (); ppty t
154 val pr_tdef
= pr_decl ("type", "=")
155 val pr_vdecl
= pr_decl ("val", ":")
156 fun closePP () = (PP
.closeStream stream
; CPIFDev
.closeOut device
)
162 (nl (); str (concat
["(* [from code at ", s
, "] *)"]));
167 line
= line
, nl
= nl
, str
= str
, sp
= sp
, nsp
= nsp
,
168 Box
= Box
, endBox
= endBox
,
169 HVBox
= HVBox
, HBox
= HBox
, HOVBox
= HOVBox
, VBox
= VBox
,
170 ppty
= ppty
, ppExp
= ppExp
, ppFun
= ppFun
,
171 pr_vdef
= pr_vdef
, pr_fdef
= pr_fdef
,
172 pr_tdef
= pr_tdef
, pr_vdecl
= pr_vdecl
,
180 (Process
.getEnv
"FFIGEN_CPP",
182 fn (cpp_tmpl
,_
) => cpp_tmpl
)
184 String.substituteFirst
187 replacement
= String.concatWith (List.rev (!Control
.cppopts
), " ")})
189 fun mkidlsource (cfile
,ifile
) =
193 ([{substring
= "%s", replacement
= cfile
},
194 {substring
= "%t", replacement
= ifile
}],
196 fn (s
, subst
) => String.substituteFirst (subst
, s
))
201 fun getSpec (cfile
, s
) =
205 val () = mkidlsource (cfile
, ifile
)
207 ParseToAst
.fileToAst
'
209 (targetSizes
, State
.INITIAL
)
215 collect_enums
= collect_enums
,
219 eshift
= targetEndianShift
,
220 gensym_suffix
= gensym_suffix
}
225 val spec
= List.fold (cfiles
, S
.empty
, getSpec
)
227 val {structs
, unions
, gvars
, gfuns
, gtys
, enums
} = spec
229 val (structs
, unions
, enums
) =
232 List.fold (structs
, SM
.empty
, fn (s
, m
) => SM
.insert (m
, #tag s
, s
))
234 List.fold (unions
, SM
.empty
, fn (s
, m
) => SM
.insert (m
, #tag s
, s
))
236 List.fold (enums
, SM
.empty
, fn (s
, m
) => SM
.insert (m
, #tag s
, s
))
238 val sdone
= ref SS
.empty
239 val udone
= ref SS
.empty
240 val edone
= ref SS
.empty
241 val smap
= ref SM
.empty
242 val umap
= ref SM
.empty
243 val emap
= ref SM
.empty
244 val ty_queue
= ref
[]
245 fun ty_sched ty
= List.push (ty_queue
, ty
)
246 fun fs_sched (S
.OFIELD
{ spec
= (_
, ty
), ... }) = ty_sched ty
248 fun f_sched
{ name
, spec
} = fs_sched spec
250 fun xenter (xdone
, xall
, xmap
, xfields
) t
=
251 if SS
.member (!xdone
, t
) then ()
252 else (xdone
:= SS
.add (!xdone
, t
);
254 SOME x
=> (xmap
:= SM
.insert (!xmap
, t
, x
);
255 app
f_sched (xfields x
))
258 val senter
= xenter (sdone
, structs
, smap
, #fields
)
259 val uenter
= xenter (udone
, unions
, umap
, #all
)
260 val eenter
= xenter (edone
, enums
, emap
, fn _
=> [])
262 fun sinclude (s
: S
.s
) = if #exclude s
then () else senter (#tag s
)
263 fun uinclude (u
: S
.u
) = if #exclude u
then () else uenter (#tag u
)
264 fun einclude (e
: S
.enum
) = if #exclude e
then () else eenter (#tag e
)
266 fun gty
{src
, name
, spec
} = ty_sched spec
267 fun gvar
{src
, name
, spec
= (_
, t
)} = ty_sched t
268 fun gfun
{src
, name
, spec
, argnames
} = ty_sched (S
.FPTR spec
)
274 | S
.STRUCT t
=> senter t
275 | S
.UNION t
=> uenter t
276 | S
.ENUM (t
, anon
) =>
277 if collect_enums
andalso anon
281 | S
.FPTR
{args
, res
} =>
282 (List.foreach (args
, do_ty
); Option
.app (res
, do_ty
))
283 | S
.PTR (_
, S
.STRUCT t
) => ()
284 | S
.PTR (_
, S
.UNION t
) => ()
285 | S
.PTR (_
, t
) => do_ty t
286 | S
.ARR
{t
, ... } => do_ty t
287 | S
.UNIMPLEMENTED _
=> ()
291 | ty
:: tys
=> (do_ty ty
; ty_loop tys
)
295 | _
=> (ty_queue
:= []; ty_loop tys
)
297 and nextround () = loop (!ty_queue
)
299 SM
.app sinclude structs
;
300 SM
.app uinclude unions
;
301 SM
.app einclude enums
;
306 (!smap
, !umap
, !emap
)
308 val (fptr_types
,incomplete_structs
, incomplete_unions
, incomplete_enums
) =
310 fun taginsert (t
, ss
) =
311 if SS
.member (ss
, t
) then ss
else SS
.add (ss
, t
)
312 fun sinsert (t
, (f
, s
, u
, e
)) =
313 (f
, taginsert (t
, s
), u
, e
)
314 fun uinsert (t
, (f
, s
, u
, e
)) =
315 (f
, s
, taginsert (t
, u
), e
)
316 fun einsert (t
, (f
, s
, u
, e
)) =
317 (f
, s
, u
, taginsert (t
, e
))
318 fun maybe_insert (t
, ss
, acc
, insert
) =
321 | NONE
=> insert (t
, acc
)
323 fun do_ty (ty
, acc
) =
326 | S
.STRUCT t
=> maybe_insert (t
, structs
, acc
, sinsert
)
327 | S
.UNION t
=> maybe_insert (t
, unions
, acc
, uinsert
)
328 | S
.ENUM (t
, anon
) =>
329 if collect_enums
andalso anon
331 else maybe_insert (t
, enums
, acc
, einsert
)
333 | S
.FPTR (cft
as {args
, res
}) =>
335 val acc
as (f
, s
, u
, e
) =
336 Option
.fold (res
, List.fold (args
, acc
, do_ty
), do_ty
)
337 val cfth
= hash_cft cft
338 val i
= IM
.numItems f
340 if IM
.inDomain (f
, cfth
)
342 else (IM
.insert (f
, cfth
, (cft
, i
)), s
, u
, e
)
344 | S
.PTR (_
, ty
) => do_ty (ty
, acc
)
345 | S
.ARR
{t
= ty
, ...} => do_ty (ty
, acc
)
346 | S
.UNIMPLEMENTED _
=> acc
348 fun fs (S
.OFIELD
{spec
= (_
, ty
), ...}, acc
) = do_ty (ty
, acc
)
350 fun f ({name
, spec
}, acc
) = fs (spec
, acc
)
351 fun s ({src
, tag
, size
, anon
, fields
, exclude
}, acc
) =
352 List.fold (fields
, acc
, f
)
353 fun u ({src
, tag
, size
, anon
, all
, exclude
}, acc
) =
354 List.fold (all
, acc
, f
)
356 fun gvar ({src
, name
, spec
= (_
, ty
)}, acc
) = do_ty (ty
, acc
)
357 fun gfun ({src
, name
, spec
, argnames
}, acc
) = do_ty (S
.FPTR spec
, acc
)
358 fun gty ({src
, name
, spec
}, acc
) = do_ty (spec
, acc
)
360 fun lfold (l
, f
, b
) = List.fold (l
, b
, f
)
361 fun mfold (m
, f
, b
) = SM
.foldl f b m
368 (IM
.empty
, SS
.empty
, SS
.empty
, SS
.empty
))))))
370 fun s_inc t
= SS
.member (incomplete_structs
, t
)
371 fun u_inc t
= SS
.member (incomplete_unions
, t
)
373 fun Gstruct n
= concat
[prefix
, "G_", n
]
374 fun Fstruct n
= concat
[prefix
, "F_", n
]
375 fun fptr_rtti_struct_id i
= "FPtrRTTI_" ^
Int.toString i
376 fun Tstruct n
= concat
[prefix
, "T_", n
]
378 fun SUETstruct K t
= concat
[K
, "T_", t
]
379 val STstruct
= SUETstruct
"S"
380 val UTstruct
= SUETstruct
"U"
381 fun Suobj
'rw p sut
= Con ("su_obj" ^ p
, [sut
, Type
"rw"])
382 fun Suobj
'ro sut
= Con ("su_obj'", [sut
, Type
"ro"])
384 fun SUEstruct K t
= concat
[prefix
, K
, "_", t
]
385 val Sstruct
= SUEstruct
"S"
386 val Ustruct
= SUEstruct
"U"
387 val Estruct
= SUEstruct
"E"
388 fun Estruct
' (n
, anon
) =
389 Estruct (if anon
andalso collect_enums
then "'" else n
)
391 fun fieldtype_id n
= "t_f_" ^ n
392 fun fieldrtti_id n
= "typ_f_" ^ n
393 fun field_id (n
, p
) = concat
["f_", n
, p
]
395 fun enum_id n
= "e_" ^ n
402 val dir_exists
= ref
false
403 val checkDir
= fn () =>
406 else (dir_exists
:= true;
407 if OS
.FileSys
.isDir dir
handle _
=> false
409 else OS
.FileSys
.mkDir dir
)
411 fun smlFileAndExport (file
,export
,do_export
) =
413 (* We don
't want apostrophes
in file names
-> turn them into minuses
.
414 * We also want to use only lowercase characters
as some file systems
415 * are
case insensitive
.
417 val base
= Vector.map (file
, fn #
"'" => #
"-" | c
=> Char.toLower c
)
419 val file
= OS
.Path
.joinBaseExt
420 {base
= if i
=0 then base
421 else concat
[base
, "-", Int.toString i
],
424 if List.exists (!files
, fn f
=> f
= file
) then pick (i
+1)
428 val result
= OS
.Path
.joinDirFile
{dir
= dir
, file
= file
}
431 ; List.push (pending
, export
)
432 ; (result
, fn () => (List.push (files
, file
)
434 then List.push (exports
, export
)
436 ; ignore (List.pop pending
)))
440 val result
= OS
.Path
.joinDirFile
{dir
= dir
, file
= file
}
447 fun rwro_str S
.RW
= "rw"
448 | rwro_str S
.RO
= "ro"
449 fun rwro_type c
= Type (rwro_str c
)
450 fun rwro_c_type S
.RW
= Type
"'c"
451 | rwro_c_type S
.RO
= Type
"ro"
453 fun dim_ty
0 = Type
"dec"
454 | dim_ty n
= Con ("dg" ^
Int.toString (n
mod 10),
458 then raise Fail
"negative dimension"
463 fun build
0 = EVar
"dec"
464 | build n
= EApp (build (n
div 10),
465 EVar ("dg" ^
Int.toString (n
mod 10)))
467 EApp (build n
, EVar
"dim")
474 | S
.SSHORT
=> "sshort"
475 | S
.USHORT
=> "ushort"
480 | S
.SLONGLONG
=> "slonglong"
481 | S
.ULONGLONG
=> "ulonglong"
483 | S
.DOUBLE
=> "double"
485 val bytebits
= #
bits (#char targetSizes
)
486 fun sizeof_basic basic_t
=
488 S
.SCHAR
=> #
bits (#char targetSizes
)
489 | S
.UCHAR
=> #
bits (#char targetSizes
)
490 | S
.SSHORT
=> #
bits (#short targetSizes
)
491 | S
.USHORT
=> #
bits (#short targetSizes
)
492 | S
.SINT
=> #
bits (#
int targetSizes
)
493 | S
.UINT
=> #
bits (#
int targetSizes
)
494 | S
.SLONG
=> #
bits (#long targetSizes
)
495 | S
.ULONG
=> #
bits (#long targetSizes
)
496 | S
.SLONGLONG
=> #
bits (#longlong targetSizes
)
497 | S
.ULONGLONG
=> #
bits (#longlong targetSizes
)
498 | S
.FLOAT
=> #
bits (#float targetSizes
)
499 | S
.DOUBLE
=> #
bits (#double targetSizes
)
502 S
.BASIC basic_t
=> Word.fromInt ((sizeof_basic basic_t
) div bytebits
)
504 (case $?
(structs
, t
) of
505 SOME
{size
, ...} => size
506 | NONE
=> err
["incomplete struct argument: struct ", t
])
508 (case $?
(unions
, t
) of
509 SOME
{size
, ...} => size
510 | NONE
=> err
["incomplete union argument: union ", t
])
511 | S
.ENUM _
=> Word.fromInt ((#
bits (#
int targetSizes
)) div bytebits
)
512 | S
.VOIDPTR
=> Word.fromInt ((#
bits (#pointer targetSizes
)) div bytebits
)
513 | S
.FPTR _
=> Word.fromInt ((#
bits (#pointer targetSizes
)) div bytebits
)
514 | S
.PTR _
=> Word.fromInt ((#
bits (#pointer targetSizes
)) div bytebits
)
515 | S
.ARR
{d
, esz
, ...} => Word.fromInt (d
* esz
)
516 | S
.UNIMPLEMENTED what
=> unimp what
518 val genStructTable
: (String.t
* unit Promise
.t
) HashSet
.t
=
519 HashSet
.new
{hash
= fn (structname
, _
) => String.hash structname
}
520 fun fillGenStructTable (app
, coll
, pr_promise
) =
521 app (coll
, fn elem
=>
522 let val (structname
, promise
) = pr_promise elem
524 (ignore
o HashSet
.lookupOrInsert
)
525 (genStructTable
, String.hash structname
,
526 fn (s
,_
) => String.equals (structname
, s
),
527 fn () => (structname
, promise
))
529 fun fillGenStructTable
' (app
, coll
, pr_promise
) =
530 fillGenStructTable (fn (c
, f
) => app f c
, coll
, pr_promise
)
531 fun forceGenStruct structname
=
532 case HashSet
.peek (genStructTable
, String.hash structname
,
533 fn (s
,_
) => String.equals (structname
, s
)) of
534 SOME (_
,promise
) => (Promise
.force promise
; structname
)
535 | NONE
=> err
["missing structure: ", structname
]
538 Type ((forceGenStruct (SUETstruct K tag
)) ^
".tag")
539 val Stag
= SUEtag
"S"
540 val Utag
= SUEtag
"U"
541 fun Etag (tag
, anon
) =
542 SUEtag
"E" (if collect_enums
andalso anon
then "'" else tag
)
544 EVar ((forceGenStruct (SUETstruct K tag
)) ^
".typ")
545 val Styp
= SUEtyp
"S"
546 val Utyp
= SUEtyp
"U"
548 fun fptr_rtti_qid i
=
549 (forceGenStruct (fptr_rtti_struct_id i
)) ^
".typ"
550 fun fptr_mkcall_qid i
=
551 (forceGenStruct (fptr_rtti_struct_id i
)) ^
".mkcall"
553 fun witness_fptr_type_p prime
{args
, res
} =
557 S
.STRUCT t
=> Suobj
'ro (Stag t
)
558 | S
.UNION t
=> Suobj
'ro (Utag t
)
559 | ty
=> witness_type
' ty
560 val (res_t
, extra_arg_t
) =
563 |
SOME (S
.STRUCT t
) =>
564 let val ot
= Suobj
'rw
"'" (Stag t
)
567 |
SOME (S
.UNION t
) =>
568 let val ot
= Suobj
'rw
"'" (Utag t
)
571 | SOME ty
=> (top_type ty
, [])
572 val arg_tl
= extra_arg_t @
(List.map (args
, top_type
))
573 val dom_t
= Tuple arg_tl
574 val fct_t
= Arrow (dom_t
, res_t
)
576 Con ("fptr" ^ prime
, [fct_t
])
578 and witness_type_p prime ty
=
580 S
.BASIC basic_t
=> Type (stem basic_t
)
581 | S
.STRUCT t
=> Con ("su", [Stag t
])
582 | S
.UNION t
=> Con ("su", [Utag t
])
583 | S
.ENUM t
=> Con ("enum", [Etag t
])
584 | S
.VOIDPTR
=> Type
"voidptr"
585 | S
.FPTR spec
=> witness_fptr_type_p prime spec
588 [Con ("obj", [witness_type ty
, rwro_type c
])])
589 | S
.ARR
{t
= ty
, d
, ...} =>
590 Con ("arr", [witness_type ty
, dim_ty d
])
591 | S
.UNIMPLEMENTED what
=> unimp what
)
592 and witness_type ty
=
594 and witness_type
' ty
=
595 witness_type_p
"'" ty
597 fun topfunc_type
prime ({args
, res
}, argnames
) =
601 S
.BASIC S
.SCHAR
=> Type
"MLRep.Char.Signed.int"
602 | S
.BASIC S
.UCHAR
=> Type
"MLRep.Char.Unsigned.word"
603 | S
.BASIC S
.SSHORT
=> Type
"MLRep.Short.Signed.int"
604 | S
.BASIC S
.USHORT
=> Type
"MLRep.Short.Unsigned.word"
605 | S
.BASIC S
.SINT
=> Type
"MLRep.Int.Signed.int"
606 | S
.BASIC S
.UINT
=> Type
"MLRep.Int.Unsigned.word"
607 | S
.BASIC S
.SLONG
=> Type
"MLRep.Long.Signed.int"
608 | S
.BASIC S
.ULONG
=> Type
"MLRep.Long.Unsigned.word"
609 | S
.BASIC S
.SLONGLONG
=> Type
"MLRep.LongLong.Signed.int"
610 | S
.BASIC S
.ULONGLONG
=> Type
"MLRep.LongLong.Unsigned.word"
611 | S
.BASIC S
.FLOAT
=> Type
"MLRep.Float.real"
612 | S
.BASIC S
.DOUBLE
=> Type
"MLRep.Double.real"
613 | S
.STRUCT t
=> Con ("su_obj" ^ prime
, [Stag t
, Type
"'c"])
614 | S
.UNION t
=> Con ("su_obj" ^ prime
, [Utag t
, Type
"'c"])
615 | S
.ENUM _
=> Type
"MLRep.Int.Signed.int"
616 | ty
=> witness_type_p prime ty
617 val (res_t
, extra_arg_t
, extra_argname
) =
619 NONE
=> (Unit
, [], [])
620 |
SOME (S
.STRUCT t
) =>
621 let val ot
= Suobj
'rw
prime (Stag t
)
622 in (ot
, [ot
], [writeto
])
624 |
SOME (S
.UNION t
) =>
625 let val ot
= Suobj
'rw
prime (Utag t
)
626 in (ot
, [ot
], [writeto
])
628 | SOME ty
=> (top_type ty
, [], [])
629 val arg_tl
= List.map (args
, top_type
)
631 case (namedargs
, argnames
) of
635 extra_arg_t @ arg_tl
)
636 | _
=> Tuple (extra_arg_t @ arg_tl
)
642 Con ("T.typ", [witness_type ty
])
645 fun simple v
= EVar ("T." ^ v
)
649 S
.BASIC basic_t
=> simple (stem basic_t
)
651 if s_inc t
then raise Incomplete
else Styp t
653 if u_inc t
then raise Incomplete
else Utyp t
655 EConstr (EVar
"T.enum", Con ("T.typ", [Con ("enum", [Etag t
])]))
656 | S
.VOIDPTR
=> simple
"voidptr"
659 val cfth
= hash_cft cft
661 case %?
(fptr_types
, cfth
) of
662 SOME (_
, i
) => EVar (fptr_rtti_qid i
)
663 | NONE
=> raise Fail
"fptr type missing"
665 | S
.PTR (S
.RW
, ty
) =>
666 EApp (EVar
"T.pointer", rtti_val ty
)
667 | S
.PTR (S
.RO
, ty
) =>
668 EApp (EVar
"T.ro", EApp (EVar
"T.pointer", rtti_val ty
))
669 | S
.ARR
{t
= ty
, d
, ...} =>
670 EApp (EVar
"T.arr", ETuple
[rtti_val ty
, dim_val d
])
671 | S
.UNIMPLEMENTED what
=> raise Incomplete
674 fun fptr_mkcall spec
=
676 val h
= hash_cft spec
678 case %?
(fptr_types
, h
) of
679 SOME (_
, i
) => fptr_mkcall_qid i
680 | NONE
=> raise Fail
"missing fptr_type (mkcall)"
683 fun pr_addr_import (pr_fdef
, name
, attrs
) =
684 pr_fdef ("h", [EUnit
],
685 EPrim ("_address \"" ^ name ^
"\" " ^ attrs
,
686 Type
"CMemory.addr"))
688 fun pr_gvar_promise x
=
690 val {src
, name
, spec
= (c
, t
)} = x
691 val gstruct
= Gstruct name
692 val gstruct_export
= "structure " ^ gstruct
699 smlFileAndExport ("g-" ^ name
, gstruct_export
, true)
700 val {closePP
, str
, nl
, Box
, VBox
, endBox
,
701 pr_fdef
, pr_vdef
, pr_tdef
, ...} =
702 openPP (file
, SOME src
)
705 val () = pr_tdef ("t", witness_type t
)
709 Con ("T.typ", [Type
"t"])))
711 handle Incomplee
=> true
713 EConstr (EApp (EVar
"mk_obj'", EApp (EVar
"h", EUnit
)),
714 Con ("obj'", [Type
"t", rwro_type c
]))
715 val dolight
= dolight
orelse incomplete
717 if dolight
then pr_fdef ("obj'", [EUnit
], obj
') else ();
718 if doheavy
andalso not incomplete
719 then pr_fdef ("obj", [EUnit
],
720 EApp (EApp (EVar
"Heavy.obj", EVar
"typ"),
722 then EApp (EVar
"obj'", EUnit
)
729 nl (); str
"open C.Dim C_Int";
731 Control
.Linkage
.Archive
=>
732 pr_addr_import (pr_fdef
, name
, "public")
733 | Control
.Linkage
.Dynamic
=>
734 pr_vdef ("h", EApp (EVar libhandle
, EString name
))
735 | Control
.Linkage
.Shared
=>
736 pr_addr_import (pr_fdef
, name
, "external");
740 nl (); str (gstruct_export ^
" = struct");
746 nl (); str
"end"; nl ();
751 val () = fillGenStructTable (List.foreach
, gvars
, pr_gvar_promise
)
753 fun pr_gfun_promise x
=
755 val {src
, name
, spec
as {args
, res
}, argnames
} = x
756 val fstruct
= Fstruct name
757 val fstruct_export
= "structure " ^ fstruct
764 smlFileAndExport ("f-" ^ name
, fstruct_export
, true)
765 val {closePP
, str
, nl
, Box
, VBox
, endBox
,
766 pr_fdef
, pr_vdef
, pr_vdecl
, ...} =
767 openPP (file
, SOME src
)
773 EVar ("x" ^
Int.toString (i
+ 1)))
775 if is_light
then e
else EApp (EVar what
, e
)
776 fun light (what
, e
) = app0 ("Light." ^ what
, e
)
777 fun heavy (what
, t
, e
) =
780 else EApp (EApp (EVar ("Heavy." ^ what
), rtti_val t
), e
)
784 EApp (EVar ("Cvt.c_" ^ stem basic_t
), e
)
785 | S
.STRUCT _
=> EApp (EVar
"ro'", light ("obj", e
))
786 | S
.UNION _
=> EApp (EVar
"ro'", light ("obj", e
))
787 | S
.ENUM _
=> EApp (EVar
"Cvt.i2c_enum", e
)
788 | S
.PTR _
=> light ("ptr", e
)
789 | S
.FPTR _
=> light ("fptr", e
)
791 | S
.UNIMPLEMENTED what
=> unimp_arg what
792 | S
.ARR _
=> raise Fail
"array argument type"
793 val c_exps
= List.map2 (ml_vars
, args
, oneArg
)
794 val (ml_vars
, c_exps
, extra_argname
) =
797 let val x0
= EVar
"x0"
800 light ("obj", x0
) :: c_exps
,
805 SOME (S
.STRUCT _
) => do_su ()
806 |
SOME (S
.UNION _
) => do_su ()
807 | _
=> (ml_vars
, c_exps
, [])
809 val call
= EApp (EVar
"call",
810 ETuple
[EApp (EVar
"fptr", EUnit
),
818 EApp (EVar ("Cvt.ml_" ^ stem basic_t
), call
)
819 | S
.STRUCT _
=> heavy ("obj", t
, call
)
820 | S
.UNION _
=> heavy ("obj", t
, call
)
821 | S
.ENUM _
=> EApp (EVar
"Cvt.c2i_enum", call
)
822 | S
.PTR _
=> heavy ("ptr", t
, call
)
823 | S
.FPTR _
=> heavy ("fptr", t
, call
)
825 | S
.UNIMPLEMENTED what
=> unimp_res what
826 | S
.ARR _
=> raise Fail
"array result type")
829 pr_fdef (if is_light
then "f'" else "f", [ETuple ml_vars
], ml_res
)
831 fun do_fsig is_light
=
832 let val prime
= if is_light
then "'" else ""
833 in pr_vdecl ("f" ^ prime
, topfunc_type
prime (spec
, argnames
))
835 val (do_f_heavy
, incomplete
) =
836 (if doheavy
then doit
false else (fn () => ()), false)
837 handle Incomplete
=> (fn () => (), true)
839 if dolight
orelse incomplete
then doit
true else (fn () => ())
843 nl (); str
"open C.Dim C_Int";
845 Control
.Linkage
.Archive
=>
846 pr_addr_import (pr_fdef
, name
, "public")
847 | Control
.Linkage
.Dynamic
=>
848 pr_vdef ("h", EApp (EVar libhandle
, EString name
))
849 | Control
.Linkage
.Shared
=>
850 pr_addr_import (pr_fdef
, name
, "external");
854 nl (); str (fstruct_export ^
" : sig");
856 pr_vdecl ("typ", rtti_type (S
.FPTR spec
));
857 pr_vdecl ("fptr", Arrow (Unit
, witness_type (S
.FPTR spec
)));
858 if doheavy
andalso not incomplete
then do_fsig
false else ();
859 if dolight
orelse incomplete
then do_fsig
true else ();
861 nl (); str
"end = struct";
863 pr_vdef ("typ", rtti_val (S
.FPTR spec
));
866 EApp (EVar
"mk_fptr",
867 ETuple
[EVar (fptr_mkcall spec
),
868 EApp (EVar
"h", EUnit
)]));
874 nl (); str
"end"; nl ();
879 val () = fillGenStructTable (List.foreach
, gfuns
, pr_gfun_promise
)
884 val callops
= ref IM
.empty
885 fun callop_sid i
= "Callop_" ^
Int.toString i
886 fun callop_qid i
= callop_sid i ^
".callop"
887 fun get (ml_args_t
, ml_res_t
) =
889 val e_proto_hash
= hash_mltype (Arrow (ml_args_t
, ml_res_t
))
891 case %?
(!callops
, e_proto_hash
) of
892 SOME i
=> callop_qid i
896 val sn
= callop_sid i
897 val sn_export
= "structure " ^ sn
900 ("callop-" ^
Int.toString i
, sn_export
, false)
901 val {closePP
, str
, nl
, Box
, VBox
, endBox
,
902 pr_fdef
, pr_vdef
, pr_tdef
, ...} =
906 callops
:= IM
.insert (!callops
, e_proto_hash
, i
);
907 str (sn_export ^
" = struct");
911 Arrow (Type
"CMemory.addr",
915 nl (); str
"end"; nl ();
925 fun pr_fptr_rtti_promise x
=
927 val ({args
, res
}, i
) = x
928 val fstruct
= fptr_rtti_struct_id i
929 val fstruct_export
= "structure " ^ fstruct
936 smlFileAndExport ("fptr-rtti-" ^
(Int.toString i
), fstruct_export
, false)
937 val {closePP
, str
, nl
, Box
, VBox
, endBox
,
938 pr_fdef
, pr_vdef
, pr_tdef
, ...} =
943 S
.BASIC basic_t
=> Type ("CMemory.cc_" ^ stem basic_t
)
944 | S
.STRUCT _
=> Type
"CMemory.cc_addr"
945 | S
.UNION _
=> Type
"CMemory.cc_addr"
946 | S
.ENUM _
=> Type
"CMemory.cc_sint"
947 | S
.VOIDPTR
=> Type
"CMemory.cc_addr"
948 | S
.FPTR _
=> Type
"CMemory.cc_addr"
949 | S
.PTR _
=> Type
"CMemory.cc_addr"
950 | S
.ARR _
=> raise Fail
"unexpected type"
951 | S
.UNIMPLEMENTED what
=> unimp what
953 EApp (EVar ("CMemory.wrap_" ^ n
),
954 EApp (EVar ("Cvt.ml_" ^ n
), e
))
955 fun fldwrap (e
, n
, alt
) =
956 EApp (EVar ("CMemory.wrap_" ^ n
),
957 EApp (EVar ("Get." ^ n ^ alt
), e
))
959 EApp (EVar
"CMemory.wrap_addr",
960 EApp (EVar
"reveal", e
))
962 EApp (EVar
"CMemory.wrap_addr",
963 EApp (EVar
"freveal", e
))
965 EApp (EVar
"CMemory.wrap_addr",
967 EApp (EVar
"Ptr.inject'", e
)))
968 fun fldvwrap (e
, alt
) =
969 EApp (EVar
"CMemory.wrap_addr",
971 EApp (EVar ("Get.voidptr" ^ alt
), e
)))
972 fun fldfwrap (e
, alt
) =
973 EApp (EVar
"CMemory.wrap_addr",
974 EApp (EVar
"freveal",
976 then EApp (EVar
"Get.fptr'", e
)
977 else EApp (EVar
"Light.fptr",
978 EApp (EVar
"Get.fptr", e
))))
979 fun fldpwrap (e
, alt
) =
980 EApp (EVar
"CMemory.wrap_addr",
982 EApp (EVar ("Ptr.inject" ^ alt
),
983 EApp (EVar ("Get.ptr" ^ alt
), e
))))
985 pwrap (EApp (EVar
"Ptr.|&!", e
))
987 EApp (EVar
"CMemory.wrap_sint",
988 EApp (EVar
"Cvt.c2i_enum", e
))
989 fun fldewrap (e
, alt
) =
990 EApp (EVar
"CMemory.wrap_sint",
991 EApp (EVar ("Get.enum" ^ alt
), e
))
994 extra_arg_v
, extra_arg_e
, extra_ml_arg_t
,
998 (Unit
, [], [], [], fn r
=> r
)
999 |
SOME (S
.STRUCT _
) =>
1002 [suwrap (EVar
"x0")],
1003 [Type
"CMemory.cc_addr"],
1004 fn r
=> ESeq (r
, EVar
"x0"))
1005 |
SOME (S
.UNION _
) =>
1008 [suwrap (EVar
"x0")],
1009 [Type
"CMemory.cc_addr"],
1010 fn r
=> ESeq (r
, EVar
"x0"))
1014 EApp (EVar ("Cvt.c_" ^ n
),
1015 EApp (EVar ("CMemory.unwrap_" ^ n
), r
))
1016 fun punwrap cast r
=
1018 EApp (EVar
"CMemory.unwrap_addr", r
))
1020 EApp (EVar
"Cvt.i2c_enum",
1021 EApp (EVar
"CMemory.unwrap_sint", r
))
1024 S
.BASIC basic_t
=> unwrap (stem basic_t
)
1026 raise Fail
"unexpected result type"
1028 raise Fail
"unexpected result type"
1029 | S
.ENUM _
=> eunwrap
1030 | S
.VOIDPTR
=> punwrap
"vcast"
1031 | S
.FPTR _
=> punwrap
"fcast"
1032 | S
.PTR _
=> punwrap
"pcast"
1034 raise Fail
"unexpected result type"
1035 | S
.UNIMPLEMENTED what
=> unimp_res what
1037 (mlty t
, [], [], [], res_wrap
)
1042 fun sel e
= ([mlty h
], [e
], [])
1045 S
.BASIC basic_t
=> sel (wrap (p
, stem basic_t
))
1046 | S
.STRUCT t
=> (* sel (suwrap p
) *)
1047 raise Fail
"struct argument not (yet) supported"
1048 | S
.UNION t
=> (* sel (suwrap p
) *)
1049 raise Fail
"union argument not (yet) supported"
1050 | S
.ENUM _
=> sel (ewrap p
)
1051 | S
.VOIDPTR
=> sel (vwrap p
)
1052 | S
.FPTR _
=> sel (fwrap p
)
1053 | S
.PTR _
=> sel (pwrap p
)
1054 | S
.ARR _
=> raise Fail
"unexpected array argument"
1055 | S
.UNIMPLEMENTED what
=> unimp_arg what
1057 and arglist ([], _
) = ([], [], [])
1058 |
arglist (h
:: tl
, i
) =
1060 val p
= EVar ("x" ^
Int.toString i
)
1061 val (ta
, ea
, bnds
) = arglist (tl
, i
+ 1)
1062 val (ta
', ea
', bnds
') = doarg (h
, p
)
1064 (ta
' @ ta
, ea
' @ ea
, bnds
' @ bnds
)
1067 val (ml_args_tl
, args_el
, bnds
) = arglist (args
, 1)
1069 val ml_args_t
= Tuple (extra_ml_arg_t @ ml_args_tl
)
1074 EVar ("x" ^
Int.toString (i
+ 1)))
1076 val arg_e
= ETuple (extra_arg_e @ args_el
)
1077 val callop_n
= get_callop (ml_args_t
, ml_res_t
)
1081 nl (); str
"open C.Dim C_Int";
1085 nl (); str (fstruct_export ^
" = struct");
1088 [EVar
"a", ETuple (extra_arg_v @ arg_vl
)],
1089 res_wrap (ELet (bnds
,
1090 EApp (EApp (EVar callop_n
,
1094 EConstr (EApp (EVar
"mk_fptr_typ", EVar
"mkcall"),
1095 rtti_type (S
.FPTR
{args
= args
, res
= res
})));
1099 nl (); str
"end"; nl ();
1104 val () = fillGenStructTable
' (IM
.app
, fptr_types
, pr_fptr_rtti_promise
)
1106 fun pr_gty_promise x
=
1108 val {src
, name
, spec
} = x
1109 val tstruct
= Tstruct name
1110 val tstruct_export
= "structure " ^ tstruct
1117 smlFileAndExport ("t-" ^ name
, tstruct_export
, true)
1118 val {closePP
, str
, nl
, Box
, VBox
, endBox
,
1119 pr_vdef
, pr_tdef
, ...} =
1120 openPP (file
, SOME src
)
1122 (SOME (rtti_val spec
))
1123 handle Incomplete
=> NONE
1127 nl (); str
"open C.Dim C_Int";
1131 nl (); str (tstruct_export ^
" = struct");
1133 pr_tdef ("t", witness_type spec
);
1135 (rtti_val_opt
, fn rtti_val
=>
1136 pr_vdef ("typ", EConstr (rtti_val
, Con ("T.typ", [Type
"t"]))));
1140 nl (); str
"end"; nl ();
1145 val () = fillGenStructTable (List.foreach
, gtys
, pr_gty_promise
)
1147 datatype sue_szinfo
=
1148 T_INC (* generate no RTTI
*)
1149 | T_SU
of word (* generate
struct/union RTTI
*)
1150 |
T_E (* generate enum RTTI
*)
1152 fun pr_suet_promise x
=
1154 val (src
, tag
, anon
, tinfo
, k
, K
) = x
1155 val suetstruct
= SUETstruct K tag
1156 val suetstruct_export
= "structure " ^ suetstruct
1163 smlFileAndExport (k ^
"t-" ^ tag
, suetstruct_export
, tinfo
= T_INC
)
1164 val {closePP
, str
, nl
, Box
, VBox
, endBox
,
1165 pr_vdef
, pr_tdef
, ...} =
1167 val (utildef
, tag_t
) =
1170 ("structure X :> sig type t end \
1171 \= struct type t = unit end",
1176 (tag
, Type k
, fn (c
, tag_t
) =>
1177 Con ("t_" ^
String.fromChar c
, [tag_t
])))
1178 fun do_susize size
=
1181 EConstr (EApp (EVar
"mk_su_size", EWord size
),
1182 Con ("S.size", [Con ("su", [Type
"tag"])])));
1184 EApp (EVar
"mk_su_typ", EVar
"size"))
1189 nl (); str
"open C.Dim C_Int";
1190 nl (); str (concat
["structure ", SUEstruct K tag
, " = struct"]);
1198 pr_tdef ("tag", tag_t
);
1203 | T_SU size
=> do_susize size
1210 nl (); str (concat
[suetstruct_export
, " = ", SUEstruct K tag
]);
1212 nl (); str
"end"; nl ();
1218 fun pr_st_promise
{src
, tag
, anon
, size
, fields
, exclude
} =
1219 pr_suet_promise (SOME src
, tag
, anon
, T_SU size
, "s", "S")
1220 fun pr_ut_promise
{src
, tag
, anon
, size
, all
, exclude
} =
1221 pr_suet_promise (SOME src
, tag
, anon
, T_SU size
, "u", "U")
1222 fun pr_et_promise
{src
, tag
, anon
, descr
, spec
, exclude
} =
1223 pr_suet_promise (SOME src
, tag
, anon
, T_E
, "e", "E")
1225 val () = fillGenStructTable
' (SM
.app
, structs
, pr_st_promise
)
1226 val () = fillGenStructTable
' (SM
.app
, unions
, pr_ut_promise
)
1227 val () = fillGenStructTable
' (SM
.app
, enums
, pr_et_promise
)
1230 fun pr_i_suet_promise (tag
, k
, K
) =
1231 pr_suet_promise (NONE
, tag
, false, T_INC
, k
, K
)
1232 fun pr_i_st_promise tag
= pr_i_suet_promise (tag
, "s", "S")
1233 fun pr_i_ut_promise tag
= pr_i_suet_promise (tag
, "u", "U")
1234 fun pr_i_et_promise tag
= pr_i_suet_promise (tag
, "e", "E")
1236 val () = fillGenStructTable
' (SS
.app
, incomplete_structs
, pr_i_st_promise
)
1237 val () = fillGenStructTable
' (SS
.app
, incomplete_unions
, pr_i_ut_promise
)
1238 val () = fillGenStructTable
' (SS
.app
, incomplete_enums
, pr_i_et_promise
)
1241 fun pr_su_promise x
=
1243 val (src
, tag
, fields
, k
, K
) = x
1244 val sustruct
= SUEstruct K tag
1245 val sustruct_export
= "structure " ^ sustruct
1252 smlFileAndExport (k ^
"-" ^ tag
, sustruct_export
, true)
1253 val {closePP
, str
, nl
, Box
, VBox
, endBox
,
1254 pr_fdef
, pr_vdef
, pr_tdef
, ...} =
1255 openPP (file
, SOME src
)
1256 fun pr_field_type
{name
, spec
} =
1258 S
.OFIELD
{spec
= (c
, ty
), synthetic
= false, offset
} =>
1259 pr_tdef (fieldtype_id name
,
1262 fun pr_field_rtti
{name
, spec
} =
1264 S
.OFIELD
{spec
= (c
, ty
), synthetic
= false, offset
} =>
1265 pr_vdef (fieldrtti_id name
,
1266 EConstr (rtti_val ty
,
1267 Con ("T.typ", [Type (fieldtype_id name
)])))
1271 Con ("su_obj" ^ prime
,
1272 [Type
"tag", Type
"'c"]))
1273 fun pr_bf_acc (name
, prime
, sign
,
1274 {offset
, constness
, bits
, shift
}) =
1277 concat
["mk_", rwro_str constness
, "_", sign
, "bf", prime
]
1279 pr_fdef (field_id (name
, prime
),
1281 EApp (EApp (EVar maker
,
1282 ETuple
[EInt offset
,
1287 fun pr_field_acc
' {name
, spec
} =
1289 S
.OFIELD
{spec
= (c
, ty
), synthetic
, offset
} =>
1292 else pr_fdef (field_id (name
, "'"),
1294 EConstr (EApp (EVar
"mk_field'",
1295 ETuple
[EInt offset
,
1298 [Type (fieldtype_id name
),
1301 pr_bf_acc (name
, "'", "s", bf
)
1303 pr_bf_acc (name
, "'", "u", bf
)
1304 fun pr_field_acc
{name
, spec
} =
1306 S
.OFIELD
{spec
= (c
, ty
), synthetic
, offset
} =>
1311 concat
["mk_", rwro_str c
, "_field"]
1313 pr_fdef (field_id (name
, ""),
1316 ETuple
[EVar (fieldrtti_id name
),
1321 pr_bf_acc (name
, "", "s", bf
)
1323 pr_bf_acc (name
, "", "u", bf
)
1324 fun pr_one_field f
=
1326 val _
= pr_field_type f
1328 (pr_field_rtti f
; false)
1329 handle Incomplete
=> true
1331 if dolight
orelse incomplete
then pr_field_acc
' f
else ();
1332 if doheavy
andalso not incomplete
then pr_field_acc f
else ()
1337 nl (); str
"open C.Dim C_Int";
1341 nl (); str (sustruct_export ^
" = struct");
1343 nl (); str ("open " ^
(forceGenStruct (SUETstruct K tag
)));
1344 List.foreach (fields
, pr_one_field
);
1348 nl (); str
"end"; nl ();
1354 fun pr_s_promise
{ src
, tag
, anon
, size
, fields
, exclude
} =
1355 pr_su_promise (src
, tag
, fields
, "s", "S")
1356 fun pr_u_promise
{ src
, tag
, anon
, size
, all
, exclude
} =
1357 pr_su_promise (src
, tag
, all
, "u", "U")
1359 val () = fillGenStructTable
' (SM
.app
, structs
, pr_s_promise
)
1360 val () = fillGenStructTable
' (SM
.app
, unions
, pr_u_promise
)
1363 fun pr_e_promise x
=
1365 val {src
, tag
, anon
, descr
, spec
, exclude
} = x
1366 val estruct
= Estruct
' (tag
, anon
)
1367 val estruct_export
= "structure " ^ estruct
1374 smlFileAndExport ("e-" ^ tag
, estruct_export
, true)
1375 val {closePP
, str
, line
, nl
, sp
, Box
, VBox
, endBox
,
1376 pr_fdef
, pr_vdef
, pr_tdef
, ...} =
1377 openPP (file
, SOME src
)
1378 fun no_duplicate_values () =
1383 |
{name
, spec
} :: l
=>
1384 if LIS
.member (s
, spec
)
1385 then (warn (concat
["enum ", descr
,
1386 " has duplicate values;\
1388 \ not generating constructors\n"]);
1390 else loop (l
, LIS
.add (s
, spec
))
1392 loop (spec
, LIS
.empty
)
1394 val dodt
= enum_cons
andalso no_duplicate_values ()
1402 |
{name
, spec
} :: l
=>
1403 (str (c ^ enum_id name
); nextround l
)
1404 and nextround
[] = ()
1405 | nextround l
= (sp (); loop ("| ", l
))
1411 fun pfl (fname
, arg
, res
, fini
: unit
-> unit
) =
1417 (line (concat
[pfx
, " ", arg v
, " => ", res v
]);
1420 line (concat
["fun ", fname
, " x ="]);
1427 fun cstr
{name
, spec
} = enum_id name
1428 fun vstr
{name
, spec
} =
1429 LargeInt
.toString spec ^
" : MLRep.Int.Signed.int"
1431 line
"datatype mlrep =";
1433 pfl ("m2i", cstr
, vstr
, fn () => ());
1434 pfl ("i2m", vstr
, cstr
,
1435 fn () => line
" | _ => raise General.Domain")
1439 fun v
{name
, spec
} =
1440 pr_vdef (enum_id name
, EConstr (ELInt spec
, Type
"mlrep"))
1441 val mlx
= EConstr (EVar
"x", Type
"mlrep")
1442 val ty
= Type
"MLRep.Int.Signed.int"
1443 val ix
= EConstr (EVar
"x", ty
)
1445 pr_tdef ("mlrep", ty
);
1446 List.foreach (spec
, v
);
1447 pr_fdef ("m2i", [mlx
], ix
);
1448 pr_fdef ("i2m", [ix
], mlx
)
1452 fun constr c
= Con ("enum_obj" ^ p
, [Type
"tag", Type c
])
1455 [EConstr (EVar
"x", constr
"'c")],
1457 EApp (EVar ("Get.enum" ^ p
), EVar
"x")));
1459 [ETuple
[EConstr (EVar
"x", constr
"rw"), EVar
"v"]],
1460 EApp (EVar ("Set.enum" ^ p
),
1461 ETuple
[EVar
"x", EApp (EVar
"m2i", EVar
"v")]))
1466 nl (); str
"open C.Dim C_Int";
1470 nl (); str (estruct_export ^
" = struct");
1472 nl (); str ("open " ^
(forceGenStruct (SUETstruct
"E" tag
)));
1473 if dodt
then dt_mlrep () else int_mlrep ();
1478 nl (); str
"end"; nl ();
1483 val () = fillGenStructTable
' (SM
.app
, enums
, pr_e_promise
)
1487 val file
= descrFile mlbfile
1488 val () = File
.remove file
1489 val {closePP
, line
, str
, nl
, VBox
, endBox
, ... } =
1492 line
"local ann \"allowFFI true\" in";
1494 app line
["$(SML_LIB)/basis/basis.mlb",
1495 "$(SML_LIB)/mlnlffi-lib/internals/c-int.mlb"];
1496 app
line (rev extramembers
);
1497 app
line (rev (!files
));
1499 nl (); str
"end in";
1501 app
line (rev (!exports
));
1503 nl (); str
"end"; nl ();
1507 (HashSet
.foreach (genStructTable
, fn (_
, promise
) => Promise
.force promise
)
1509 handle Promise
.Force
=>
1510 warn ("cyclic dependency: " ^
1511 (String.concatWith (!pending
, " ")))