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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1095, Tue Feb 26 13:20:40 2002 UTC revision 1096, Tue Feb 26 16:59:02 2002 UTC
# Line 19  Line 19 
19                  match: string -> bool,                  match: string -> bool,
20                  mkidlsource: string -> string,                  mkidlsource: string -> string,
21                  dirname: string,                  dirname: string,
                 iptr_repository: (string * string) option,  
22                  cmfile: string,                  cmfile: string,
23                  prefix: string,                  prefix: string,
24                  gensym_stem: string,                  gensym_stem: string,
25                  extramembers: string list,                  extramembers: string list,
26                  libraryhandle: string,                  libraryhandle: string,
                 complete: bool,  
27    
28                  allSU: bool,                  allSU: bool,
29                  lambdasplit: string option,                  lambdasplit: string option,
30                  wid: int,                  wid: int,
31                  weightreq: bool option, (* true -> heavy, false -> light *)                  weightreq: bool option, (* true -> heavy, false -> light *)
32                  namedargs: bool,                  namedargs: bool,
33                    collect_enums: bool,
34                    enumcons: bool,
35                  target : { name  : string,                  target : { name  : string,
36                             sizes : Sizes.sizes,                             sizes : Sizes.sizes,
37                             shift : int * int * word -> word } } -> unit                             shift : int * int * word -> word } } -> unit
# Line 43  Line 43 
43      structure SS = StringSet      structure SS = StringSet
44      structure SM = StringMap      structure SM = StringMap
45      structure IM = IntRedBlackMap      structure IM = IntRedBlackMap
46        structure LIS = RedBlackSetFn (type ord_key = LargeInt.int
47                                       val compare = LargeInt.compare)
48    
49    
50      structure P = PrettyPrint      structure P = PrettyPrint
51      structure PP = P.PP      structure PP = P.PP
# Line 52  Line 55 
55      val Con = P.CON      val Con = P.CON
56      val Arrow = P.ARROW      val Arrow = P.ARROW
57      val Type = P.Type      val Type = P.Type
     val St = P.St  
     val Un = P.Un  
58      val Unit = P.Unit      val Unit = P.Unit
59      val ETuple = P.ETUPLE      val ETuple = P.ETUPLE
60      val EUnit = ETuple []      val EUnit = ETuple []
# Line 68  Line 69 
69      fun ELInt i = EVar (LargeInt.toString i)      fun ELInt i = EVar (LargeInt.toString i)
70      fun EString s = EVar (concat ["\"", String.toString s, "\""])      fun EString s = EVar (concat ["\"", String.toString s, "\""])
71    
72      val writeto = "write_to"      fun warn m = TextIO.output (TextIO.stdErr, "warning: " ^ m)
73    
74        fun unimp what = raise Fail ("unimplemented type: " ^ what)
75        fun unimp_arg what = raise Fail ("unimplemented argument type: " ^ what)
76        fun unimp_res what = raise Fail ("unimplemented result type: " ^ what)
77    
78      val sint_ty = Type "MLRep.Signed.int"      val writeto = "write'to"
79    
80      val dontedit = "(* This file has been generated automatically. \      val dontedit = "(* This file has been generated automatically. \
81                     \DO NOT EDIT! *)"                     \DO NOT EDIT! *)"
# Line 87  Line 92 
92      fun fptr_rtti_qid i = fptr_rtti_struct_id i ^ ".typ"      fun fptr_rtti_qid i = fptr_rtti_struct_id i ^ ".typ"
93      fun fptr_mkcall_qid i = fptr_rtti_struct_id i ^ ".mkcall"      fun fptr_mkcall_qid i = fptr_rtti_struct_id i ^ ".mkcall"
94    
95      fun SUTstruct K t = concat [K, "T_", t]      fun SUE_Tstruct K t = concat [K, "T_", t]
96      val STstruct = SUTstruct "S"      val STstruct = SUE_Tstruct "S"
97      val UTstruct = SUTstruct "U"      val UTstruct = SUE_Tstruct "U"
98      fun Styp t = STstruct t ^ ".typ"  
99      fun Utyp t = UTstruct t ^ ".typ"      fun SUE_tag K tag = Type (SUE_Tstruct K tag ^ ".tag")
100    
101      fun fieldtype_id n = "t_f_" ^ n      fun fieldtype_id n = "t_f_" ^ n
102      fun fieldrtti_id n = "typ_f_" ^ n      fun fieldrtti_id n = "typ_f_" ^ n
# Line 100  Line 105 
105      fun arg_id s = "a_" ^ s      fun arg_id s = "a_" ^ s
106      fun enum_id n = "e_" ^ n      fun enum_id n = "e_" ^ n
107    
     val $! = SS.exists  
108      val $? = SM.find      val $? = SM.find
109    
110      val %? = IM.find      val %? = IM.find
# Line 109  Line 113 
113    
114      fun gen args = let      fun gen args = let
115          val { cfiles, match, mkidlsource, gensym_stem,          val { cfiles, match, mkidlsource, gensym_stem,
116                dirname, iptr_repository,                dirname,
117                cmfile, prefix, extramembers, libraryhandle, complete,                cmfile, prefix, extramembers, libraryhandle,
118                allSU, lambdasplit,                allSU, lambdasplit,
119                wid,                wid,
120                weightreq,                weightreq,
121                namedargs = doargnames,                namedargs = doargnames,
122                  collect_enums, enumcons,
123                target = { name = archos, sizes, shift } } = args                target = { name = archos, sizes, shift } } = args
124    
125            val St = SUE_tag "S"
126            val Un = SUE_tag "U"
127            fun En (tag, anon) =
128                if collect_enums andalso anon then SUE_tag "E" "'"
129                else SUE_tag "E" tag
130    
131          val hash_cft = Hash.mkFHasher ()          val hash_cft = Hash.mkFHasher ()
132          val hash_mltype = Hash.mkTHasher ()          val hash_mltype = Hash.mkTHasher ()
133    
         val (iptrdir, iptranchor) =  
             case iptr_repository of  
                 NONE => (dirname, NONE)  
               | SOME (d, a) => (d, SOME a)  
   
134          val gensym_suffix = if gensym_stem = "" then "" else "_" ^ gensym_stem          val gensym_suffix = if gensym_stem = "" then "" else "_" ^ gensym_stem
         fun iobj_id (K, tag) = concat [prefix, "I", K, "_", tag]  
135    
136          fun SUstruct K t = concat [prefix, K, "_", t]          fun SUEstruct K t = concat [prefix, K, "_", t]
137          val Sstruct = SUstruct "S"          val Sstruct = SUEstruct "S"
138          val Ustruct = SUstruct "U"          val Ustruct = SUEstruct "U"
139            val Estruct = SUEstruct "E"
140          fun Tstruct n = concat [prefix, "T_", n]          fun Tstruct n = concat [prefix, "T_", n]
141          fun Gstruct n = concat [prefix, "G_", n]          fun Gstruct n = concat [prefix, "G_", n]
142          fun Fstruct n = concat [prefix, "F_", n]          fun Fstruct n = concat [prefix, "F_", n]
143          fun Estruct n = concat [prefix, "E_", n]          fun Estruct' (n, anon) =
144                Estruct (if anon andalso collect_enums then "'" else n)
145    
146            fun Styp t = STstruct t ^ ".typ"
147            fun Utyp t = UTstruct t ^ ".typ"
148    
149          val (doheavy, dolight) =          val (doheavy, dolight) =
150              case weightreq of              case weightreq of
# Line 152  Line 162 
162                                       (sizes, State.INITIAL)                                       (sizes, State.INITIAL)
163                                       idlsource                                       idlsource
164                   val s' =                   val s' =
165                       AstToSpec.build (astbundle, sizes, cfiles, match,                       AstToSpec.build { bundle = astbundle,
166                                        allSU, shift, gensym_suffix)                                         sizes = sizes,
167                                           collect_enums = collect_enums,
168                                           cfiles = cfiles,
169                                           match = match,
170                                           allSU = allSU,
171                                           eshift = shift,
172                                           gensym_suffix = gensym_suffix }
173               in               in
174                   S.join (s', s)                   S.join (s', s)
175               end handle e => (OS.FileSys.remove idlsource handle _ => ();               end handle e => (OS.FileSys.remove idlsource handle _ => ();
# Line 165  Line 181 
181    
182          val { structs, unions, gvars, gfuns, gtys, enums } = spec          val { structs, unions, gvars, gfuns, gtys, enums } = spec
183    
184          fun do_dir dir = let          val do_dir = let
185              val done = ref false              val done = ref false
186              fun doit () =              fun doit () =
187                  if !done then ()                  if !done then ()
188                  else (done := true;                  else (done := true;
189                        if OS.FileSys.isDir dir handle _ => false then ()                        if OS.FileSys.isDir dirname handle _ => false then ()
190                        else OS.FileSys.mkDir dir)                        else OS.FileSys.mkDir dirname)
191          in          in
192              doit              doit
193          end          end
194    
         val do_main_dir = do_dir dirname  
         val do_iptr_dir = do_dir iptrdir  
   
195          val files = ref extramembers    (* all files that should go          val files = ref extramembers    (* all files that should go
196                                           * into the .cm description *)                                           * into the .cm description *)
197          val exports = ref []          val exports = ref []
# Line 192  Line 205 
205              val result = OS.Path.joinDirFile { dir = dirname, file = file }              val result = OS.Path.joinDirFile { dir = dirname, file = file }
206          in          in
207              files := file :: !files;              files := file :: !files;
208              do_main_dir ();              do_dir ();
209              result              result
210          end          end
211    
212          fun descrfile file = let          fun descrfile file = let
213              val result = OS.Path.joinDirFile { dir = dirname, file = file }              val result = OS.Path.joinDirFile { dir = dirname, file = file }
214          in          in
215              do_main_dir ();              do_dir ();
216              result              result
217          end          end
218    
         fun iptrdescrfile nqx = let  
             val file = OS.Path.joinBaseExt { base = nqx, ext = SOME "cm" }  
             val path = OS.Path.joinDirFile { dir = iptrdir, file = file }  
             val apath = case iptranchor of  
                             SOME a => concat [a, "/", file]  
                           | NONE => file  
         in  
             (path, apath)  
         end  
   
         fun iptrfiles (x, report_only) = let  
             val nqx = noquotes x  
             val (d, da) = iptrdescrfile nqx  
             val f = OS.Path.joinBaseExt { base = nqx, ext = SOME "sml" }  
             val p = OS.Path.joinDirFile { dir = iptrdir, file = f }  
         in  
             if report_only then () else files := da :: !files;  
             do_iptr_dir ();  
             (f, p, d)  
         end  
   
219          val structs =          val structs =
220              foldl (fn (s, m) => SM.insert (m, #tag s, s)) SM.empty structs              foldl (fn (s, m) => SM.insert (m, #tag s, s)) SM.empty structs
221    
222          val unions =          val unions =
223              foldl (fn (u, m) => SM.insert (m, #tag u, u)) SM.empty unions              foldl (fn (u, m) => SM.insert (m, #tag u, u)) SM.empty unions
224    
225          val (structs, unions) = let          val enums =
226                foldl (fn (e, m) => SM.insert (m, #tag e, e)) SM.empty enums
227    
228            val (structs, unions, enums) = let
229              val sdone = ref SS.empty              val sdone = ref SS.empty
230              val udone = ref SS.empty              val udone = ref SS.empty
231                val edone = ref SS.empty
232              val smap = ref SM.empty              val smap = ref SM.empty
233              val umap = ref SM.empty              val umap = ref SM.empty
234                val emap = ref SM.empty
235              val tq = ref []              val tq = ref []
236              fun ty_sched t = tq := t :: !tq              fun ty_sched t = tq := t :: !tq
237              fun fs_sched (S.OFIELD { spec = (_, t), ... }) = ty_sched t              fun fs_sched (S.OFIELD { spec = (_, t), ... }) = ty_sched t
238                | fs_sched _ = ()                | fs_sched _ = ()
239              fun f_sched { name, spec } = fs_sched spec              fun f_sched { name, spec } = fs_sched spec
240    
241              fun senter t =              fun xenter (xdone, xall, xmap, xfields) t =
242                  if $! (thetag t) (!sdone) then ()                  if SS.member (!xdone, t) then ()
243                  else (sdone := SS.add (!sdone, t);                  else (xdone := SS.add (!xdone, t);
244                        case $? (structs, t) of                        case $? (xall, t) of
245                            SOME x => (smap := SM.insert (!smap, t, x);                            SOME x => (xmap := SM.insert (!xmap, t, x);
246                                       app f_sched (#fields x))                                       app f_sched (xfields x))
247                          | NONE => ())                          | NONE => ())
248    
249              fun uenter t =              val senter = xenter (sdone, structs, smap, #fields)
250                  if $! (thetag t) (!udone) then ()              val uenter = xenter (udone, unions, umap,
251                  else (udone := SS.add (!udone, t);                                   fn u => (#largest u :: #all u))
252                        case $? (unions, t) of              val eenter = xenter (edone, enums, emap, fn _ => [])
253                            SOME x => (umap := SM.insert (!umap, t, x);  
254                                       app f_sched (#largest x :: #all x))              fun sinclude (s: S.s) = if #exclude s then () else senter (#tag s)
255                          | NONE => ())              fun uinclude (u: S.u) = if #exclude u then () else uenter (#tag u)
256                fun einclude (e: S.enum) =
257                    if #exclude e then () else eenter (#tag e)
258    
             fun sinclude (s: S.s) =  
                 if #exclude s then () else senter (#tag s)  
             fun uinclude (u: S.u) =  
                 if #exclude u then () else uenter (#tag u)  
259              fun gty { src, name, spec } = ty_sched spec              fun gty { src, name, spec } = ty_sched spec
260              fun gvar { src, name, spec = (_, t) } = ty_sched t              fun gvar { src, name, spec = (_, t) } = ty_sched t
261              fun gfun { src, name, spec, argnames } = ty_sched (S.FPTR spec)              fun gfun { src, name, spec, argnames } = ty_sched (S.FPTR spec)
# Line 268  Line 263 
263                | loop tl = let                | loop tl = let
264                      fun ty (S.STRUCT t) = senter t                      fun ty (S.STRUCT t) = senter t
265                        | ty (S.UNION t) = uenter t                        | ty (S.UNION t) = uenter t
266                          | ty (S.ENUM (t, anon)) =
267                            if collect_enums andalso anon then eenter "'"
268                            else eenter t
269                        | ty (S.PTR (_, S.STRUCT t)) = ()                        | ty (S.PTR (_, S.STRUCT t)) = ()
270                        | ty (S.PTR (_, S.UNION t)) = ()                        | ty (S.PTR (_, S.UNION t)) = ()
271                        | ty (S.PTR (_, t)) = ty t                        | ty (S.PTR (_, t)) = ty t
272                        | ty (S.FPTR { args, res }) =                        | ty (S.FPTR { args, res }) =
273                          (app ty args; Option.app ty res)                          (app ty args; Option.app ty res)
274                        | ty (S.ARR { t, ... }) = ty t                        | ty (S.ARR { t, ... }) = ty t
275                          | ty (S.UNIMPLEMENTED _) = ()
276                        | ty (S.SCHAR | S.UCHAR | S.SINT | S.UINT |                        | ty (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
277                              S.SSHORT | S.USHORT | S.SLONG | S.ULONG |                              S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
278                              S.FLOAT | S.DOUBLE | S.VOIDPTR) = ()                              S.FLOAT | S.DOUBLE | S.VOIDPTR) = ()
# Line 291  Line 290 
290              app gvar gvars;              app gvar gvars;
291              app gfun gfuns;              app gfun gfuns;
292              nextround ();              nextround ();
293              (!smap, !umap)              (!smap, !umap, !emap)
294          end          end
295    
         exception Incomplete  
   
         fun get_struct t =  
             case $? (structs, t) of  
                 SOME x => x  
               | NONE => raise Incomplete  
         fun get_union t =  
             case $? (unions, t) of  
                 SOME x => x  
               | NONE => raise Incomplete  
   
296          fun stem S.SCHAR = "schar"          fun stem S.SCHAR = "schar"
297            | stem S.UCHAR = "uchar"            | stem S.UCHAR = "uchar"
298            | stem S.SINT = "sint"            | stem S.SINT = "sint"
# Line 319  Line 307 
307            | stem _ = raise Fail "bad stem"            | stem _ = raise Fail "bad stem"
308    
309          fun taginsert (t, ss) =          fun taginsert (t, ss) =
310              if $! (thetag t) ss then ss else SS.add (ss, t)              if SS.member (ss, t) then ss else SS.add (ss, t)
311    
312          (* We don't expect many different function pointer types or          (* We don't expect many different function pointer types or
313           * incomplete types in any given C interface, so using linear           * incomplete types in any given C interface, so using linear
314           * lists here is probably ok. *)           * lists here is probably ok. *)
315          val (fptr_types, incomplete_structs, incomplete_unions) = let          val (fptr_types,
316                 incomplete_structs, incomplete_unions, incomplete_enums) = let
317              fun ty ((S.SCHAR | S.UCHAR | S.SINT | S.UINT |              fun ty ((S.SCHAR | S.UCHAR | S.SINT | S.UINT |
318                       S.SSHORT | S.USHORT |                       S.SSHORT | S.USHORT |
319                       S.SLONG | S.ULONG | S.FLOAT | S.DOUBLE |                       S.SLONG | S.ULONG | S.FLOAT | S.DOUBLE |
320                       S.VOIDPTR), a) = a                       S.VOIDPTR), a) = a
321                | ty (S.STRUCT t, a as (f, s, u)) =                | ty (S.STRUCT t, a as (f, s, u, e)) =
322                  ((ignore (get_struct t); a)                  (case $? (structs, t) of
323                   handle Incomplete => (f, taginsert (t, s), u))                       SOME _ => a
324                | ty (S.UNION t, a as (f, s, u)) =                     | NONE => (f, taginsert (t, s), u, e))
325                  ((ignore (get_union t); a)                | ty (S.UNION t, a as (f, s, u, e)) =
326                   handle Incomplete => (f, s, taginsert (t, u)))                  (case $? (unions, t) of
327                         SOME _ => a
328                       | NONE => (f, s, taginsert (t, u), e))
329                  | ty (S.ENUM (t, anon), a as (f, s, u, e)) =
330                    (if collect_enums andalso anon then a
331                     else case $? (enums, t) of
332                              SOME _ => a
333                            | NONE => (f, s, u, taginsert (t, e)))
334                | ty ((S.PTR (_, t) | S.ARR { t, ... }), a) = ty (t, a)                | ty ((S.PTR (_, t) | S.ARR { t, ... }), a) = ty (t, a)
335                | ty (S.FPTR (cft as { args, res }), a) = let                | ty (S.FPTR (cft as { args, res }), a) = let
336                      val a' = foldl ty a args                      val a' = foldl ty a args
337                      val a'' = case res of NONE => a'                      val a'' = case res of NONE => a'
338                                          | SOME t => ty (t, a')                                          | SOME t => ty (t, a')
339                      val (f, s, u) = a''                      val (f, s, u, e) = a''
340                      val cfth = hash_cft cft                      val cfth = hash_cft cft
341                      val i = IM.numItems f                      val i = IM.numItems f
342                  in                  in
343                      if IM.inDomain (f, cfth) then (f, s, u)                      if IM.inDomain (f, cfth) then (f, s, u, e)
344                      else (IM.insert (f, cfth, (cft, i)), s, u)                      else (IM.insert (f, cfth, (cft, i)), s, u, e)
345                  end                  end
346                  | ty (S.UNIMPLEMENTED _, a) = a
347              fun fs (S.OFIELD { spec = (_, t), ... }, a) = ty (t, a)              fun fs (S.OFIELD { spec = (_, t), ... }, a) = ty (t, a)
348                | fs (_, a) = a                | fs (_, a) = a
349              fun f ({ name, spec }, a) = fs (spec, a)              fun f ({ name, spec }, a) = fs (spec, a)
# Line 363  Line 360 
360                           (foldl gty                           (foldl gty
361                                  (SM.foldl                                  (SM.foldl
362                                       u (SM.foldl                                       u (SM.foldl
363                                              s (IM.empty, SS.empty, SS.empty)                                              s (IM.empty,
364                                                   SS.empty, SS.empty, SS.empty)
365                                              structs)                                              structs)
366                                       unions)                                       unions)
367                                  gtys)                                  gtys)
# Line 371  Line 369 
369                    gfuns                    gfuns
370          end          end
371    
372          fun incomplete t = let          fun s_inc t = SS.member (incomplete_structs, t)
373              fun decide (K, tag: Spec.tag, ss) =          fun u_inc t = SS.member (incomplete_unions, t)
                 if $! (thetag tag) ss then SOME (K, tag) else NONE  
         in  
             case t of  
                 S.STRUCT tag => decide ("S", tag, incomplete_structs)  
               | S.UNION tag => decide ("U", tag, incomplete_unions)  
               | _ => NONE  
         end  
374    
375          fun rwro S.RW = Type "rw"          fun rwro S.RW = Type "rw"
376            | rwro S.RO = Type "ro"            | rwro S.RO = Type "ro"
# Line 427  Line 418 
418              Type (stem t)              Type (stem t)
419            | wtn_ty_p p (S.STRUCT t) = Con ("su", [St t])            | wtn_ty_p p (S.STRUCT t) = Con ("su", [St t])
420            | wtn_ty_p p (S.UNION t) = Con ("su", [Un t])            | wtn_ty_p p (S.UNION t) = Con ("su", [Un t])
421              | wtn_ty_p p (S.ENUM ta) = Con ("enum", [En ta])
422            | wtn_ty_p p (S.PTR (c, t)) =            | wtn_ty_p p (S.PTR (c, t)) =
423              (case incomplete t of              Con ("ptr" ^ p, [Con ("obj", [wtn_ty t, rwro c])])
                  SOME (K, tag) =>  
                  Con ("ptr" ^ p,  
                       [Con (concat [iobj_id (K, tag), ".iobj"],  
                             [rwro c])])  
                | NONE => Con ("ptr" ^ p, [Con ("obj", [wtn_ty t, rwro c])]))  
424            | wtn_ty_p p (S.ARR { t, d, ... }) =            | wtn_ty_p p (S.ARR { t, d, ... }) =
425              Con ("arr", [wtn_ty t, dim_ty d])              Con ("arr", [wtn_ty t, dim_ty d])
426            | wtn_ty_p p (S.FPTR spec) = wtn_fptr_p p spec            | wtn_ty_p p (S.FPTR spec) = wtn_fptr_p p spec
427              | wtn_ty_p _ (S.UNIMPLEMENTED what) = unimp what
428    
429          and wtn_ty t = wtn_ty_p "" t          and wtn_ty t = wtn_ty_p "" t
430    
# Line 451  Line 439 
439                  Type "MLRep.Real.real"                  Type "MLRep.Real.real"
440                | topty (S.STRUCT t) = Con ("su_obj" ^ p, [St t, Type "'c"])                | topty (S.STRUCT t) = Con ("su_obj" ^ p, [St t, Type "'c"])
441                | topty (S.UNION t) = Con ("su_obj" ^ p, [Un t, Type "'c"])                | topty (S.UNION t) = Con ("su_obj" ^ p, [Un t, Type "'c"])
442                  | topty (S.ENUM _) = Type "MLRep.Signed.int"
443                | topty t = wtn_ty_p p t                | topty t = wtn_ty_p p t
444              val (res_t, extra_arg_t, extra_argname) =              val (res_t, extra_arg_t, extra_argname) =
445                  case res of                  case res of
# Line 458  Line 447 
447                    | SOME (S.STRUCT t) => let                    | SOME (S.STRUCT t) => let
448                          val ot = Suobj'rw p (St t)                          val ot = Suobj'rw p (St t)
449                      in                      in
450                          (ot, [ot], [writeto])(* FIXME -- check for nameclash *)                          (ot, [ot], [writeto])
451                      end                      end
452                    | SOME (S.UNION t) => let                    | SOME (S.UNION t) => let
453                          val ot = Suobj'rw p (Un t)                          val ot = Suobj'rw p (Un t)
454                      in                      in
455                          (ot, [ot], [writeto])(* FIXME *)                          (ot, [ot], [writeto])
456                      end                      end
457                    | SOME t => (topty t, [], [])                    | SOME t => (topty t, [], [])
458              val argtyl = map topty args              val argtyl = map topty args
# Line 492  Line 481 
481              EApp (build n, EVar "dim")              EApp (build n, EVar "dim")
482          end          end
483    
484            exception Incomplete
485    
486          local          local
487              fun simple v = EVar ("T." ^ v)              fun simple v = EVar ("T." ^ v)
488          in          in
# Line 499  Line 490 
490                                  S.SSHORT | S.USHORT | S.SLONG | S.ULONG |                                  S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
491                                  S.FLOAT | S.DOUBLE | S.VOIDPTR)) =                                  S.FLOAT | S.DOUBLE | S.VOIDPTR)) =
492                  simple (stem t)                  simple (stem t)
493                | rtti_val (S.STRUCT t) = EVar (Styp t)                | rtti_val (S.STRUCT t) =
494                | rtti_val (S.UNION t) = EVar (Utyp t)                  if s_inc t then raise Incomplete else EVar (Styp t)
495                  | rtti_val (S.UNION t) =
496                    if u_inc t then raise Incomplete else EVar (Utyp t)
497                  | rtti_val (S.ENUM ta) =
498                    EConstr (EVar "T.enum",
499                             Con ("T.typ", [Con ("enum", [En ta])]))
500                | rtti_val (S.FPTR cft) = let                | rtti_val (S.FPTR cft) = let
501                      val cfth = hash_cft cft                      val cfth = hash_cft cft
502                  in                  in
# Line 509  Line 505 
505                        | NONE => raise Fail "fptr type missing"                        | NONE => raise Fail "fptr type missing"
506                  end                  end
507                | rtti_val (S.PTR (S.RW, t)) =                | rtti_val (S.PTR (S.RW, t)) =
508                  (case incomplete t of                  EApp (EVar "T.pointer", rtti_val t)
                      SOME (K, tag) => EVar (iobj_id (K, tag) ^ ".typ'rw")  
                    | NONE => EApp (EVar "T.pointer", rtti_val t))  
509                | rtti_val (S.PTR (S.RO, t)) =                | rtti_val (S.PTR (S.RO, t)) =
510                  (case incomplete t of                  EApp (EVar "T.ro", EApp (EVar "T.pointer", rtti_val t))
                      SOME (K, tag) => EVar (iobj_id (K, tag) ^ ".typ'ro")  
                    | NONE => EApp (EVar "T.ro",  
                                    EApp (EVar "T.pointer", rtti_val t)))  
511                | rtti_val (S.ARR { t, d, ... }) =                | rtti_val (S.ARR { t, d, ... }) =
512                  EApp (EVar "T.arr", ETuple [rtti_val t, dim_val d])                  EApp (EVar "T.arr", ETuple [rtti_val t, dim_val d])
513                  | rtti_val (S.UNIMPLEMENTED what) = raise Incomplete
514          end          end
515    
516          fun fptr_mkcall spec = let          fun fptr_mkcall spec = let
# Line 660  Line 652 
652                | encode S.SLONG = E_slong                | encode S.SLONG = E_slong
653                | encode S.ULONG = E_ulong                | encode S.ULONG = E_ulong
654                | encode (S.PTR _ | S.VOIDPTR | S.FPTR _) = E_ptr                | encode (S.PTR _ | S.VOIDPTR | S.FPTR _) = E_ptr
655                  | encode (S.UNIMPLEMENTED what) = unimp what
656                | encode (S.ARR _) = raise Fail "unexpected array"                | encode (S.ARR _) = raise Fail "unexpected array"
657                  | encode (S.ENUM _) = E_sint
658                | encode (S.STRUCT t) =                | encode (S.STRUCT t) =
659                  encode_fields (#fields (get_struct t))                  encode_fields (#fields (valOf ($? (structs, t))))
660                | encode (S.UNION t) =                | encode (S.UNION t) =
661                  encode_fields [#largest (get_union t)]                  encode_fields [#largest (valOf ($? (unions, t)))]
662    
663              and encode_fields fields = let              and encode_fields fields = let
664                  fun f0 (S.ARR { t, d = 0, ... }, a) = a                  fun f0 (S.ARR { t, d = 0, ... }, a) = a
# Line 696  Line 690 
690                  Type ("CMemory.cc_" ^ stem t)                  Type ("CMemory.cc_" ^ stem t)
691                | mlty (S.VOIDPTR | S.PTR _ | S.FPTR _ | S.STRUCT _) =                | mlty (S.VOIDPTR | S.PTR _ | S.FPTR _ | S.STRUCT _) =
692                  Type "CMemory.cc_addr"                  Type "CMemory.cc_addr"
693                  | mlty (S.ENUM _) = Type "CMemory.cc_sint"
694                  | mlty (S.UNIMPLEMENTED what) = unimp what
695                | mlty (S.ARR _ | S.UNION _) = raise Fail "unexpected type"                | mlty (S.ARR _ | S.UNION _) = raise Fail "unexpected type"
696    
697              fun wrap (e, n) =              fun wrap (e, n) =
# Line 712  Line 708 
708    
709              fun suwrap e = pwrap (EApp (EVar "Ptr.|&!", e))              fun suwrap e = pwrap (EApp (EVar "Ptr.|&!", e))
710    
711                fun ewrap e = EApp (EVar "CMemory.wrap_sint",
712                                    EApp (EVar "Cvt.c2i_enum", e))
713    
714              (* this code is for passing structures in pieces              (* this code is for passing structures in pieces
715               * (member-by-member); we don't use this and rather               * (member-by-member); we don't use this and rather
716               * provide a pointer to the beginning of the struct *)               * provide a pointer to the beginning of the struct *)
# Line 724  Line 723 
723                  in                  in
724                      case h of                      case h of
725                          (S.STRUCT _ | S.UNION _) => sel (suwrap p)                          (S.STRUCT _ | S.UNION _) => sel (suwrap p)
726                          | (S.ENUM _) => sel (ewrap p)
727                        | (S.SCHAR | S.UCHAR | S.SINT | S.UINT |                        | (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
728                           S.SSHORT | S.USHORT | S.SLONG | S.ULONG |                           S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
729                           S.FLOAT | S.DOUBLE) => sel (wrap (p, stem h))                           S.FLOAT | S.DOUBLE) => sel (wrap (p, stem h))
730                        | S.VOIDPTR => sel (vwrap p)                        | S.VOIDPTR => sel (vwrap p)
731                        | S.PTR _ => sel (pwrap p)                        | S.PTR _ => sel (pwrap p)
732                        | S.FPTR _ => sel (fwrap p)                        | S.FPTR _ => sel (fwrap p)
733                          | S.UNIMPLEMENTED what => unimp_arg what
734                        | S.ARR _ => raise Fail "unexpected array argument"                        | S.ARR _ => raise Fail "unexpected array argument"
735                  end                  end
736    
# Line 751  Line 752 
752                          fun punwrap cast r =                          fun punwrap cast r =
753                              EApp (EVar cast,                              EApp (EVar cast,
754                                    EApp (EVar "CMemory.unwrap_addr", r))                                    EApp (EVar "CMemory.unwrap_addr", r))
755                            fun eunwrap r =
756                                EApp (EVar "Cvt.i2c_enum",
757                                      EApp (EVar "CMemory.unwrap_sint", r))
758                          val res_wrap =                          val res_wrap =
759                              case t of                              case t of
760                                  (S.SCHAR | S.UCHAR | S.SINT | S.UINT |                                  (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
# Line 759  Line 763 
763                                | S.VOIDPTR => punwrap "vcast"                                | S.VOIDPTR => punwrap "vcast"
764                                | S.FPTR _ => punwrap "fcast"                                | S.FPTR _ => punwrap "fcast"
765                                | S.PTR _ => punwrap "pcast"                                | S.PTR _ => punwrap "pcast"
766                                  | S.ENUM _ => eunwrap
767                                  | S.UNIMPLEMENTED what => unimp_res what
768                                | (S.STRUCT _ | S.UNION _ | S.ARR _) =>                                | (S.STRUCT _ | S.UNION _ | S.ARR _) =>
769                                  raise Fail "unexpected result type"                                  raise Fail "unexpected result type"
770                      in                      in
# Line 795  Line 801 
801              nl (); str "end"; nl (); str "end"; nl (); closePP ()              nl (); str "end"; nl (); str "end"; nl (); closePP ()
802          end          end
803    
804          fun pr_sut_structure (src, tag, anon, size, k, K) = let          datatype sue_szinfo =
805                T_INC                       (* generate no RTTI *)
806              | T_SU of word                (* generate struct/union RTTI *)
807              | T_E                         (* generate enum RTTI *)
808    
809            fun pr_sue_t_structure (src, tag, anon, tinfo, k, K) = let
810              val file = smlfile (concat [k, "t-", tag])              val file = smlfile (concat [k, "t-", tag])
811              val { str, closePP, nl, Box, endBox, VBox, pr_tdef,              val { str, closePP, nl, Box, endBox, VBox, pr_tdef,
812                    pr_vdef, ... } =                    pr_vdef, ... } =
813                  openPP (file, SOME src)                  openPP (file, src)
814              fun build [] = Type k              fun build [] = Type k
815                | build (h :: tl) = Con ("t_" ^ String.str h, [build tl])                | build (h :: tl) = Con ("t_" ^ String.str h, [build tl])
816              val (utildef, tag_t) =              val (utildef, tag_t) =
# Line 814  Line 825 
825          in          in
826              str "local";              str "local";
827              Box 4;              Box 4;
828              nl (); str (concat ["structure ", SUstruct K tag, " = struct"]);              nl (); str (concat ["structure ", SUEstruct K tag, " = struct"]);
829              Box 4;              Box 4;
830              nl (); str "local";              nl (); str "local";
831              VBox 4;              VBox 4;
# Line 825  Line 836 
836              pr_tdef ("tag", tag_t);              pr_tdef ("tag", tag_t);
837              endBox ();              endBox ();
838              nl (); str "end";              nl (); str "end";
839              pr_vdef ("size",              case tinfo of
840                    T_INC => ()
841                  | T_SU size =>
842                    (pr_vdef ("size",
843                       EConstr (EApp (EVar "C_Int.mk_su_size", EWord size),                       EConstr (EApp (EVar "C_Int.mk_su_size", EWord size),
844                                Con ("C.S.size",                                Con ("C.S.size",
845                                     [Con ("C.su", [Type "tag"])])));                                     [Con ("C.su", [Type "tag"])])));
846              pr_vdef ("typ",              pr_vdef ("typ",
847                       EApp (EVar "C_Int.mk_su_typ", EVar "size"));                            EApp (EVar "C_Int.mk_su_typ", EVar "size")))
848                  | T_E => ();
849              endBox ();              endBox ();
850              nl (); str "end";              nl (); str "end";
851              endBox ();              endBox ();
852              nl (); str "in";              nl (); str "in";
853              Box 4;              Box 4;
854              nl (); str (concat ["structure ", SUTstruct K tag,              nl (); str (concat ["structure ", SUE_Tstruct K tag,
855                                  " = ", SUstruct K tag]);                                  " = ", SUEstruct K tag]);
856              endBox ();              endBox ();
857              nl (); str "end"; nl ();              nl (); str "end"; nl ();
858              closePP ()              closePP ()
859          end          end
860    
861          fun pr_st_structure { src, tag, anon, size, fields, exclude } =          fun pr_st_structure { src, tag, anon, size, fields, exclude } =
862              pr_sut_structure (src, tag, anon, size, "s", "S")              pr_sue_t_structure (SOME src, tag, anon, T_SU size, "s", "S")
863          fun pr_ut_structure { src, tag, anon, size, largest, all, exclude } =          fun pr_ut_structure { src, tag, anon, size, largest, all, exclude } =
864              pr_sut_structure (src, tag, anon, size, "u", "U")              pr_sue_t_structure (SOME src, tag, anon, T_SU size, "u", "U")
865            fun pr_et_structure { src, tag, anon, descr, spec, exclude } =
866                pr_sue_t_structure (SOME src, tag, anon, T_E, "e", "E")
867    
868            fun pr_sue_it_structure (tag, k, K) =
869                pr_sue_t_structure (NONE, tag, false, T_INC, k, K)
870    
871            fun pr_i_st_structure tag = pr_sue_it_structure (tag, "s", "S")
872            fun pr_i_ut_structure tag = pr_sue_it_structure (tag, "u", "U")
873            fun pr_i_et_structure tag = pr_sue_it_structure (tag, "e", "E")
874    
875          fun pr_su_structure (src, tag, fields, k, K) = let          fun pr_su_structure (src, tag, fields, k, K) = let
876    
877              val file = smlfile (concat [k, "-", tag])              val file = smlfile (concat [k, "-", tag])
878              val { closePP, Box, endBox, str, nl,              val { closePP, Box, endBox, str, nl, line,
879                    pr_tdef, pr_vdef, pr_fdef, ... } =                    pr_tdef, pr_vdef, pr_fdef, ... } =
880                  openPP (file, SOME src)                  openPP (file, SOME src)
881    
# Line 928  Line 952 
952                | pr_field_acc { name, spec = S.UBF bf } =                | pr_field_acc { name, spec = S.UBF bf } =
953                  pr_bf_acc (name, "", "u", bf)                  pr_bf_acc (name, "", "u", bf)
954    
955              val sustruct = "structure " ^ SUstruct K tag              val sustruct = "structure " ^ SUEstruct K tag
956    
957                fun pr_one_field f = let
958                    val _ = pr_field_typ f
959                    val inc = (pr_field_rtti f; false) handle Incomplete => true
960                in
961                    if dolight orelse inc then pr_field_acc' f else ();
962                    if doheavy andalso not inc then pr_field_acc f else ()
963                end
964          in          in
965              str "local open C.Dim C_Int in";              str "local open C.Dim C_Int in";
966              nl (); str (sustruct ^ " = struct");              nl (); str (sustruct ^ " = struct");
967              Box 4;              Box 4;
968              nl (); str ("open " ^ SUTstruct K tag);              nl (); str ("open " ^ SUE_Tstruct K tag);
969              app pr_field_typ fields;              app pr_one_field fields;
             app pr_field_rtti fields;  
             if dolight then app pr_field_acc' fields else ();  
             if doheavy then app pr_field_acc fields else ();  
970              endBox ();              endBox ();
971              nl (); str "end";              nl (); str "end";
972              nl (); str "end";              nl (); str "end";
# Line 950  Line 979 
979          fun pr_u_structure { src, tag, anon, size, largest, all, exclude } =          fun pr_u_structure { src, tag, anon, size, largest, all, exclude } =
980              pr_su_structure (src, tag, all, "u", "U")              pr_su_structure (src, tag, all, "u", "U")
981    
982          fun pr_t_structure { src, name, spec } =          fun pr_e_structure { src, tag, anon, descr, spec, exclude } = let
983              case incomplete spec of              val file = smlfile ("e-" ^ tag)
984                  SOME _ => ()              val { closePP, str, Box, endBox, nl, line, sp,
985                | NONE => let                    pr_fdef, pr_vdef, pr_tdef, ... } =
986                    openPP (file, SOME src)
987                val estruct = "structure " ^ Estruct' (tag, anon)
988                fun no_duplicate_values () = let
989                    fun loop ([], _) = true
990                      | loop ({ name, spec } :: l, s) =
991                        if LIS.member (s, spec) then
992                            (warn (concat ["enum ", descr,
993                                           " has duplicate values;\
994                                           \ using sint,\
995                                           \ not generating constructors\n"]);
996                             false)
997                        else loop (l, LIS.add (s, spec))
998                in
999                    loop (spec, LIS.empty)
1000                end
1001                val dodt = enumcons andalso no_duplicate_values ()
1002    
1003                fun dt_mlrep () = let
1004                    fun pcl () = let
1005                        fun loop (_, []) = ()
1006                          | loop (c, { name, spec } :: l) =
1007                            (str (c ^ enum_id name); nextround l)
1008                        and nextround [] = ()
1009                          | nextround l = (sp (); loop ("| ", l))
1010                    in
1011                        Box 2; nl ();
1012                        loop ("  ", spec);
1013                        endBox ()
1014                    end
1015                    fun pfl (fname, arg, res, fini) = let
1016                        fun loop (_, []) = ()
1017                          | loop (pfx, v :: l) =
1018                            (line (concat [pfx, " ", arg v, " => ", res v]);
1019                             loop ("  |", l))
1020                    in
1021                        line (concat ["fun ", fname, " x ="]);
1022                        Box 4;
1023                        line ("case x of");
1024                        loop ("   ", spec);
1025                        fini ();
1026                        endBox ()
1027                    end
1028                    fun cstr { name, spec } = enum_id name
1029                    fun vstr { name, spec } =
1030                        LargeInt.toString spec ^ " : MLRep.Signed.int"
1031                in
1032                    line "datatype mlrep =";
1033                    pcl ();
1034                    pfl ("m2i", cstr, vstr, fn () => ());
1035                    pfl ("i2m", vstr, cstr,
1036                         fn () => line "  | _ => raise General.Domain")
1037                end
1038                fun int_mlrep () = let
1039                    fun v { name, spec } =
1040                        pr_vdef (enum_id name, EConstr (ELInt spec, Type "mlrep"))
1041                    val mlx = EConstr (EVar "x", Type "mlrep")
1042                    val ix = EConstr (EVar "x", Type "MLRep.Signed.int")
1043                in
1044                    pr_tdef ("mlrep", Type "MLRep.Signed.int");
1045                    app v spec;
1046                    pr_fdef ("m2i", [mlx], ix);
1047                    pr_fdef ("i2m", [ix], mlx)
1048                end
1049                fun getset p = let
1050                    fun constr c = Con ("enum_obj" ^ p, [Type "tag", Type c])
1051                in
1052                    pr_fdef ("get" ^ p,
1053                             [EConstr (EVar "x", constr "'c")],
1054                             EApp (EVar "i2m",
1055                                   EApp (EVar ("Get.enum" ^ p), EVar "x")));
1056                    pr_fdef ("set" ^ p,
1057                             [ETuple [EConstr (EVar "x", constr "rw"), EVar "v"]],
1058                             EApp (EVar ("Set.enum" ^ p),
1059                                   ETuple [EVar "x", EApp (EVar "m2i", EVar "v")]))
1060                end
1061    
1062            in
1063                str "local open C in";
1064                line (estruct ^ " = struct");
1065                Box 4;
1066                line ("open " ^ SUE_Tstruct "E" tag);
1067                if dodt then dt_mlrep () else int_mlrep ();
1068                pr_fdef ("c", [EVar "x"],
1069                         EConstr (EApp (EVar "Cvt.i2c_enum",
1070                                        EApp (EVar "m2i", EVar "x")),
1071                                  Con ("enum", [Type "tag"])));
1072                pr_fdef ("ml", [EConstr (EVar "x", Con ("enum", [Type "tag"]))],
1073                         EApp (EVar "i2m",
1074                               EApp (EVar "Cvt.c2i_enum", EVar "x")));
1075                if dolight then getset "'" else ();
1076                if doheavy then getset "" else ();
1077                endBox ();
1078                line "end"; line "end (* local *)";
1079                nl ();
1080                closePP ();
1081                exports := estruct :: !exports
1082            end
1083    
1084            fun pr_t_structure { src, name, spec } = let
1085                val rttiv = rtti_val spec
1086                      val file = smlfile ("t-" ^ name)                      val file = smlfile ("t-" ^ name)
1087                      val { closePP, Box, endBox, str, nl, pr_tdef,                      val { closePP, Box, endBox, str, nl, pr_tdef,
1088                            pr_vdef, ... } =                            pr_vdef, ... } =
# Line 964  Line 1093 
1093                      nl (); str (tstruct ^ " = struct");                      nl (); str (tstruct ^ " = struct");
1094                      Box 4;                      Box 4;
1095                      pr_tdef ("t", rtti_ty spec);                      pr_tdef ("t", rtti_ty spec);
1096                      pr_vdef ("typ", EConstr (rtti_val spec, Type "t"));              pr_vdef ("typ", EConstr (rttiv, Type "t"))
1097                handle Incomplete => ();
1098                      endBox ();                      endBox ();
1099                      nl (); str "end";                      nl (); str "end";
1100                      nl (); str "end";                      nl (); str "end";
1101                      nl ();                      nl ();
1102                      closePP ();                      closePP ();
1103                      exports := tstruct :: !exports                      exports := tstruct :: !exports
1104                  end          end handle Incomplete => ()
1105    
1106          fun pr_gvar { src, name, spec = (c, t) } = let          fun pr_gvar { src, name, spec = (c, t) } = let
1107              val file = smlfile ("g-" ^ name)              val file = smlfile ("g-" ^ name)
1108              val { closePP, str, nl, Box, VBox, endBox,              val { closePP, str, nl, Box, VBox, endBox,
1109                    pr_fdef, pr_vdef, pr_tdef, ... } =                    pr_fdef, pr_vdef, pr_tdef, ... } =
1110                  openPP (file, SOME src)                  openPP (file, SOME src)
1111              val rwobj = EApp (EVar "mk_obj",              fun doit () = let
1112                                ETuple [rtti_val t, EApp (EVar "h", EUnit)])                  val rwo = Type (case c of S.RW => "rw" | S.RO => "ro")
1113              val obj = case c of S.RW => rwobj                  val _ = pr_tdef ("t", wtn_ty t)
1114                                | S.RO => EApp (EVar "ro", rwobj)                  val inc = (pr_vdef ("typ",
1115                                        EConstr (rtti_val t,
1116                                                 Con ("T.typ", [Type "t"])));
1117                               false)
1118                              handle Incomplete => true
1119                    val obj' =
1120                        EConstr (EApp (EVar "mk_obj'", EApp (EVar "h", EUnit)),
1121                                 Con ("obj'", [Type "t", rwo]))
1122                    val dolight = dolight orelse inc
1123                in
1124                    if dolight then pr_fdef ("obj'", [EUnit], obj') else ();
1125                    if doheavy andalso not inc then
1126                        pr_fdef ("obj", [EUnit],
1127                                 EApp (EApp (EVar "Heavy.obj", EVar "typ"),
1128                                       if dolight then
1129                                           EApp (EVar "obj'", EUnit)
1130                                       else obj'))
1131                    else ()
1132                end
1133    
1134              val gstruct = "structure " ^ Gstruct name              val gstruct = "structure " ^ Gstruct name
1135          in          in
1136              str (gstruct ^ " = struct");              str (gstruct ^ " = struct");
# Line 993  Line 1142 
1142              endBox ();              endBox ();
1143              nl (); str "in";              nl (); str "in";
1144              VBox 4;              VBox 4;
1145              pr_tdef ("t", wtn_ty t);              doit ();
             pr_vdef ("typ", EConstr (rtti_val t, Con ("T.typ", [Type "t"])));  
             pr_fdef ("obj", [EUnit],  
                      EConstr (obj, Con ("obj", [Type "t", rwro c])));  
1146              endBox ();              endBox ();
1147              nl (); str "end";              nl (); str "end";
1148              endBox ();              endBox ();
# Line 1012  Line 1158 
1158              val { closePP, str, nl, pr_fdef, Box, endBox,              val { closePP, str, nl, pr_fdef, Box, endBox,
1159                    pr_vdef, pr_vdecl, ... } =                    pr_vdef, pr_vdecl, ... } =
1160                  openPP (file, SOME src)                  openPP (file, SOME src)
1161              fun do_f is_light = let              fun mk_do_f is_light = let
1162                  val ml_vars =                  val ml_vars =
1163                      rev (#1 (foldl (fn (_, (l, i)) =>                      rev (#1 (foldl (fn (_, (l, i)) =>
1164                                         (EVar ("x" ^ Int.toString i) :: l,                                         (EVar ("x" ^ Int.toString i) :: l,
# Line 1032  Line 1178 
1178                      EApp (EVar ("Cvt.c_" ^ stem t), e)                      EApp (EVar ("Cvt.c_" ^ stem t), e)
1179                    | oneArg (e, (S.STRUCT _ | S.UNION _)) =                    | oneArg (e, (S.STRUCT _ | S.UNION _)) =
1180                      EApp (EVar "ro'", light ("obj", e))                      EApp (EVar "ro'", light ("obj", e))
1181                      | oneArg (e, S.ENUM ta) = EApp (EVar "Cvt.i2c_enum", e)
1182                    | oneArg (e, S.PTR _) = light ("ptr", e)                    | oneArg (e, S.PTR _) = light ("ptr", e)
1183                    | oneArg (e, S.FPTR _) = light ("fptr", e)                    | oneArg (e, S.FPTR _) = light ("fptr", e)
1184                    | oneArg (e, S.VOIDPTR) = e                    | oneArg (e, S.VOIDPTR) = e
1185                      | oneArg (e, S.UNIMPLEMENTED what) = unimp_arg what
1186                    | oneArg (e, S.ARR _) = raise Fail "array argument type"                    | oneArg (e, S.ARR _) = raise Fail "array argument type"
1187                  val c_exps = ListPair.map oneArg (ml_vars, args)                  val c_exps = ListPair.map oneArg (ml_vars, args)
1188                  val (ml_vars, c_exps, extra_argname) =                  val (ml_vars, c_exps, extra_argname) =
# Line 1055  Line 1203 
1203                          EApp (EVar ("Cvt.ml_" ^ stem t), call)                          EApp (EVar ("Cvt.ml_" ^ stem t), call)
1204                        | SOME (t as (S.STRUCT _ | S.UNION _)) =>                        | SOME (t as (S.STRUCT _ | S.UNION _)) =>
1205                          heavy ("obj", t, call)                          heavy ("obj", t, call)
1206                          | SOME (S.ENUM ta) => EApp (EVar "Cvt.c2i_enum", call)
1207                        | SOME (t as S.PTR _) => heavy ("ptr", t, call)                        | SOME (t as S.PTR _) => heavy ("ptr", t, call)
1208                        | SOME (t as S.FPTR _) => heavy ("fptr", t, call)                        | SOME (t as S.FPTR _) => heavy ("fptr", t, call)
1209                        | SOME (S.ARR _) => raise Fail "array result type"                        | SOME (S.ARR _) => raise Fail "array result type"
1210                          | SOME (S.UNIMPLEMENTED what) => unimp_res what
1211                        | (NONE | SOME S.VOIDPTR) => call                        | (NONE | SOME S.VOIDPTR) => call
1212                  val argspat =                  val argspat =
1213                      case (doargnames, argnames) of                      case (doargnames, argnames) of
# Line 1066  Line 1216 
1216                                                 ml_vars))                                                 ml_vars))
1217                        | _ => ETuple ml_vars                        | _ => ETuple ml_vars
1218              in              in
1219                    fn () =>
1220                  pr_fdef (if is_light then "f'" else "f", [argspat], ml_res)                  pr_fdef (if is_light then "f'" else "f", [argspat], ml_res)
1221              end              end
1222              fun do_fsig is_light = let              fun do_fsig is_light = let
# Line 1074  Line 1225 
1225                  pr_vdecl ("f" ^ p, topfunc_ty p (spec, argnames))                  pr_vdecl ("f" ^ p, topfunc_ty p (spec, argnames))
1226              end              end
1227              val fstruct = "structure " ^ Fstruct name              val fstruct = "structure " ^ Fstruct name
1228                val (do_f_heavy, inc) =
1229                    (if doheavy then mk_do_f false else (fn () => ()), false)
1230                    handle Incomplete => (fn () => (), true)
1231          in          in
1232              str "local";              str "local";
1233              Box 4;              Box 4;
# Line 1085  Line 1239 
1239              Box 4;              Box 4;
1240              pr_vdecl ("typ", rtti_ty (S.FPTR spec));              pr_vdecl ("typ", rtti_ty (S.FPTR spec));
1241              pr_vdecl ("fptr", Arrow (Unit, wtn_ty (S.FPTR spec)));              pr_vdecl ("fptr", Arrow (Unit, wtn_ty (S.FPTR spec)));
1242              if doheavy then do_fsig false else ();              if doheavy andalso not inc then do_fsig false else ();
1243              if dolight then do_fsig true else ();              if dolight orelse inc then do_fsig true else ();
1244              endBox ();              endBox ();
1245              nl (); str "end = struct";              nl (); str "end = struct";
1246              Box 4;              Box 4;
# Line 1096  Line 1250 
1250                       EApp (EVar "mk_fptr",                       EApp (EVar "mk_fptr",
1251                             ETuple [EVar (fptr_mkcall spec),                             ETuple [EVar (fptr_mkcall spec),
1252                                     EApp (EVar "h", EUnit)]));                                     EApp (EVar "h", EUnit)]));
1253              if doheavy then do_f false else ();              do_f_heavy ();
1254              if dolight then do_f true else ();              if dolight orelse inc then mk_do_f true () else ();
1255              endBox ();              endBox ();
1256              nl (); str "end"; nl (); str "end"; nl ();              nl (); str "end"; nl (); str "end"; nl ();
1257              closePP ();              closePP ();
1258              exports := fstruct :: !exports              exports := fstruct :: !exports
1259          end          end
1260    
         fun pr_enum { src, tag, spec } = let  
             val file = smlfile ("e-" ^ tag)  
             val { closePP, str, nl, pr_vdef, Box, endBox, ... } =  
                 openPP (file, SOME src)  
             fun v { name, spec } =  
                 pr_vdef (enum_id name, EConstr (ELInt spec, sint_ty))  
             val estruct = "structure " ^ Estruct tag  
         in  
             str (estruct ^ " = struct");  
             Box 4;  
             app v spec;  
             endBox ();  
             nl (); str "end"; nl ();  
             closePP ();  
             exports := estruct :: !exports  
         end  
   
         fun do_iptrs report_only = let  
             fun pr_iobj_def (K, k) tag = let  
                 val (sfile, spath, dpath) =  
                     iptrfiles (concat ["i", k, "-", tag], report_only)  
                 val spp = openPP (spath, NONE)  
                 val dpp = openPP (dpath, NONE)  
                 val istruct = "structure " ^ iobj_id (K, tag)  
             in  
                 #str spp (istruct ^ " = PointerToIncompleteType ()");  
                 #nl spp ();  
                 #closePP spp ();  
                 if report_only then () else exports := istruct :: !exports;  
                 #str dpp "library";  
                 #VBox dpp 4;  
                 #line dpp istruct;  
                 #endBox dpp ();  
                 #nl dpp ();  
                 #str dpp "is";  
                 #VBox dpp 4;  
                 app (#line dpp) ["$c/c.cm", sfile];  
                 #endBox dpp ();  
                 #nl dpp ();  
                 #closePP dpp ()  
             end  
         in  
             SS.app (pr_iobj_def ("S", "s")) incomplete_structs;  
             SS.app (pr_iobj_def ("U", "u")) incomplete_unions  
         end  
   
1261          fun do_cmfile () = let          fun do_cmfile () = let
1262              val file = descrfile cmfile              val file = descrfile cmfile
1263              val { closePP, line, str, nl, VBox, endBox, ... } =              val { closePP, line, str, nl, VBox, endBox, ... } =
# Line 1170  Line 1278 
1278              nl ();              nl ();
1279              closePP ()              closePP ()
1280          end          end
         val needs_iptr =  
             not (SS.isEmpty incomplete_structs andalso  
                  SS.isEmpty incomplete_unions)  
1281      in      in
   
1282          IM.app pr_fptr_rtti fptr_types;          IM.app pr_fptr_rtti fptr_types;
1283          SM.app pr_st_structure structs;          SM.app pr_st_structure structs;
1284          SM.app pr_ut_structure unions;          SM.app pr_ut_structure unions;
1285            SM.app pr_et_structure enums;
1286            SS.app pr_i_st_structure incomplete_structs;
1287            SS.app pr_i_ut_structure incomplete_unions;
1288            SS.app pr_i_et_structure incomplete_enums;
1289          SM.app pr_s_structure structs;          SM.app pr_s_structure structs;
1290          SM.app pr_u_structure unions;          SM.app pr_u_structure unions;
1291            SM.app pr_e_structure enums;
1292          app pr_t_structure gtys;          app pr_t_structure gtys;
1293          app pr_gvar gvars;          app pr_gvar gvars;
1294          app pr_gfun gfuns;          app pr_gfun gfuns;
         app pr_enum enums;  
         if complete then  
             if needs_iptr then do_iptrs false else ()  
         else do_iptrs true;  
1295          do_cmfile ()          do_cmfile ()
1296      end      end
1297  end  end

Legend:
Removed from v.1095  
changed lines
  Added in v.1096

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