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 1061, Tue Feb 12 22:21:13 2002 UTC revision 1062, Wed Feb 13 21:15:14 2002 UTC
# Line 7  Line 7 
7   * author: Matthias Blume (blume@research.bell-labs.com)   * author: Matthias Blume (blume@research.bell-labs.com)
8   *)   *)
9  local  local
10      val program = "ml-ffigen"      val program = "ml-nlffigen"
11      val version = "0.7"      val version = "0.8"
12      val author = "Matthias Blume"      val author = "Matthias Blume"
13      val email = "blume@research.bell-labs.com"      val email = "blume@research.bell-labs.com"
14      structure S = Spec      structure S = Spec
# Line 40  Line 40 
40    
41      val version = version      val version = version
42    
43        structure SS = StringSet
44        structure SM = StringMap
45        structure IM = IntRedBlackMap
46    
47      structure P = PrettyPrint      structure P = PrettyPrint
48      structure PP = P.PP      structure PP = P.PP
49      val Tuple = P.TUPLE      val Tuple = P.TUPLE
# Line 96  Line 100 
100      fun arg_id s = "a_" ^ s      fun arg_id s = "a_" ^ s
101      fun enum_id n = "e_" ^ n      fun enum_id n = "e_" ^ n
102    
103        val $! = SS.exists
104        val $? = SM.find
105    
106        val %? = IM.find
107    
108        fun thetag (t: S.tag) t' = t = t'
109    
110      fun gen args = let      fun gen args = let
111          val { cfiles, match, mkidlsource, gensym_stem,          val { cfiles, match, mkidlsource, gensym_stem,
112                dirname, cmfile, prefix, extramembers, libraryhandle, complete,                dirname, cmfile, prefix, extramembers, libraryhandle, complete,
# Line 105  Line 116 
116                namedargs = doargnames,                namedargs = doargnames,
117                target = { name = archos, sizes, shift, stdcall } } = args                target = { name = archos, sizes, shift, stdcall } } = args
118    
119            val hash_cft = Hash.mkFHasher ()
120            val hash_mltype = Hash.mkTHasher ()
121    
122          val (gensym_prefix, gensym_suffix) =          val (gensym_prefix, gensym_suffix) =
123              if gensym_stem = "" then ("", "")              if gensym_stem = "" then ("", "")
124              else (gensym_stem ^ "_", "_" ^ gensym_stem)              else (gensym_stem ^ "_", "_" ^ gensym_stem)
# Line 182  Line 196 
196              result              result
197          end          end
198    
199            val structs =
200                foldl (fn (s, m) => SM.insert (m, #tag s, s)) SM.empty structs
201    
202            val unions =
203                foldl (fn (u, m) => SM.insert (m, #tag u, u)) SM.empty unions
204    
205          val (structs, unions) = let          val (structs, unions) = let
206              val sdone = ref []              val sdone = ref SS.empty
207              val udone = ref []              val udone = ref SS.empty
208              val slist = ref []              val smap = ref SM.empty
209              val ulist = ref []              val umap = ref SM.empty
210              val tq = ref []              val tq = ref []
             fun tag (t: S.tag) t' = t = t'  
             fun s_tag t (s: S.s) = t = #tag s  
             fun u_tag t (u: S.u) = t = #tag u  
211              fun ty_sched t = tq := t :: !tq              fun ty_sched t = tq := t :: !tq
212              fun fs_sched (S.OFIELD { spec = (_, t), ... }) = ty_sched t              fun fs_sched (S.OFIELD { spec = (_, t), ... }) = ty_sched t
213                | fs_sched _ = ()                | fs_sched _ = ()
214              fun f_sched { name, spec } = fs_sched spec              fun f_sched { name, spec } = fs_sched spec
215              fun senter takeit t =  
216                  if List.exists (tag t) (!sdone) then ()              fun senter t =
217                  else (sdone := t :: !sdone;                  if $! (thetag t) (!sdone) then ()
218                        case List.find (s_tag t) structs of                  else (sdone := SS.add (!sdone, t);
219                            SOME x => (if takeit then slist := x :: !slist                        case $? (structs, t) of
220                                       else ();                            SOME x => (smap := SM.insert (!smap, t, x);
221                                       app f_sched (#fields x))                                       app f_sched (#fields x))
222                          | NONE => ())                          | NONE => ())
223              fun uenter takeit t =  
224                  if List.exists (tag t) (!udone) then ()              fun uenter t =
225                  else (udone := t :: !udone;                  if $! (thetag t) (!udone) then ()
226                        case List.find (u_tag t) unions of                  else (udone := SS.add (!udone, t);
227                            SOME x => (if takeit then ulist := x :: !ulist                        case $? (unions, t) of
228                                       else ();                            SOME x => (umap := SM.insert (!umap, t, x);
229                                       app f_sched (#largest x :: #all x))                                       app f_sched (#largest x :: #all x))
230                          | NONE => ())                          | NONE => ())
231    
232              fun sinclude (s: S.s) =              fun sinclude (s: S.s) =
233                  if #exclude s then () else senter true (#tag s)                  if #exclude s then () else senter (#tag s)
234              fun uinclude (u: S.u) =              fun uinclude (u: S.u) =
235                  if #exclude u then () else uenter true (#tag u)                  if #exclude u then () else uenter (#tag u)
236              fun gty { src, name, spec } = ty_sched spec              fun gty { src, name, spec } = ty_sched spec
237              fun gvar { src, name, spec = (_, t) } = ty_sched t              fun gvar { src, name, spec = (_, t) } = ty_sched t
238              fun gfun { src, name, spec, argnames } = ty_sched (S.FPTR spec)              fun gfun { src, name, spec, argnames } = ty_sched (S.FPTR spec)
239              fun loop [] = ()              fun loop [] = ()
240                | loop tl = let                | loop tl = let
241                      fun ty (S.STRUCT t) = senter true t                      fun ty (S.STRUCT t) = senter t
242                        | ty (S.UNION t) = uenter true t                        | ty (S.UNION t) = uenter t
243                        | ty (S.PTR (_, S.STRUCT t)) = senter false t                        | ty (S.PTR (_, S.STRUCT t)) = ()
244                        | ty (S.PTR (_, S.UNION t)) = uenter false t                        | ty (S.PTR (_, S.UNION t)) = ()
245                        | ty (S.PTR (_, t)) = ty t                        | ty (S.PTR (_, t)) = ty t
246                        | ty (S.FPTR { args, res }) =                        | ty (S.FPTR { args, res }) =
247                          (app ty args;                          (app ty args; Option.app ty res)
                          case res of SOME x => ty x | NONE => ())  
248                        | ty (S.ARR { t, ... }) = ty t                        | ty (S.ARR { t, ... }) = ty t
249                        | ty (S.SCHAR | S.UCHAR | S.SINT | S.UINT |                        | ty (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
250                              S.SSHORT | S.USHORT | S.SLONG | S.ULONG |                              S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
# Line 240  Line 257 
257                  end                  end
258              and nextround () = loop (!tq)              and nextround () = loop (!tq)
259          in          in
260              app sinclude structs;              SM.app sinclude structs;
261              app uinclude unions;              SM.app uinclude unions;
262              app gty gtys;              app gty gtys;
263              app gvar gvars;              app gvar gvars;
264              app gfun gfuns;              app gfun gfuns;
265              nextround ();              nextround ();
266              (!slist, !ulist)              (!smap, !umap)
267          end          end
268    
269          exception Incomplete          exception Incomplete
270    
271          fun get_struct t =          fun get_struct t =
272              case List.find (fn s => #tag s = t) structs of              case $? (structs, t) of
273                  SOME x => x                  SOME x => x
274                | NONE => raise Incomplete                | NONE => raise Incomplete
275          fun get_union t =          fun get_union t =
276              case List.find (fn u => #tag u = t) unions of              case $? (unions, t) of
277                  SOME x => x                  SOME x => x
278                | NONE => raise Incomplete                | NONE => raise Incomplete
279    
# Line 273  Line 290 
290            | stem S.VOIDPTR = "voidptr"            | stem S.VOIDPTR = "voidptr"
291            | stem _ = raise Fail "bad stem"            | stem _ = raise Fail "bad stem"
292    
293          fun sinsert (s: string, l) =          fun taginsert (t, ss) =
294              case List.find (fn s' => s = s') l of              if $! (thetag t) ss then ss else SS.add (ss, t)
                 SOME _ => l  
               | NONE => s :: l  
295    
296          (* We don't expect many different function pointer types or          (* We don't expect many different function pointer types or
297           * incomplete types in any given C interface, so using linear           * incomplete types in any given C interface, so using linear
# Line 288  Line 303 
303                       S.VOIDPTR), a) = a                       S.VOIDPTR), a) = a
304                | ty (S.STRUCT t, a as (f, s, u)) =                | ty (S.STRUCT t, a as (f, s, u)) =
305                  ((ignore (get_struct t); a)                  ((ignore (get_struct t); a)
306                   handle Incomplete => (f, sinsert (t, s), u))                   handle Incomplete => (f, taginsert (t, s), u))
307                | ty (S.UNION t, a as (f, s, u)) =                | ty (S.UNION t, a as (f, s, u)) =
308                  ((ignore (get_union t); a)                  ((ignore (get_union t); a)
309                   handle Incomplete => (f, s, sinsert (t, u)))                   handle Incomplete => (f, s, taginsert (t, u)))
310                | ty ((S.PTR (_, t) | S.ARR { t, ... }), a) = ty (t, a)                | ty ((S.PTR (_, t) | S.ARR { t, ... }), a) = ty (t, a)
311                | ty (S.FPTR (cft as { args, res }), a) = let                | ty (S.FPTR (cft as { args, res }), a) = let
312                      val a' = foldl ty a args                      val a' = foldl ty a args
313                      val a'' = case res of NONE => a'                      val a'' = case res of NONE => a'
314                                          | SOME t => ty (t, a')                                          | SOME t => ty (t, a')
315                      val (f, s, u) = a''                      val (f, s, u) = a''
316                        val cfth = hash_cft cft
317                  in                  in
318                      if List.exists (fn (cft', _) => cft = cft') f then a                      (IM.insert (f, cfth, (cft, IM.numItems f)), s, u)
                     else ((cft, length f) :: f, s, u)  
319                  end                  end
320              fun fs (S.OFIELD { spec = (_, t), ... }, a) = ty (t, a)              fun fs (S.OFIELD { spec = (_, t), ... }, a) = ty (t, a)
321                | fs (_, a) = a                | fs (_, a) = a
# Line 313  Line 328 
328              fun gvar ({ src, name, spec = (_, t) }, a) = ty (t, a)              fun gvar ({ src, name, spec = (_, t) }, a) = ty (t, a)
329              fun gfun ({ src, name, spec, argnames }, a) = ty (S.FPTR spec, a)              fun gfun ({ src, name, spec, argnames }, a) = ty (S.FPTR spec, a)
330          in          in
331              foldl gfun (foldl gvar              foldl gfun
332                           (foldl gty (foldl u (foldl s ([], [], []) structs)                    (foldl gvar
333                             (foldl gty
334                                    (SM.foldl
335                                         u (SM.foldl
336                                                s (IM.empty, SS.empty, SS.empty)
337                                                structs)
338                                             unions)                                             unions)
339                                  gtys)                                  gtys)
340                           gvars)                           gvars)
# Line 322  Line 342 
342          end          end
343    
344          fun incomplete t = let          fun incomplete t = let
345              fun decide (K, tag: Spec.tag, l) =              fun decide (K, tag: Spec.tag, ss) =
346                  if List.exists (fn tag' => tag = tag') l then                  if $! (thetag tag) ss then SOME (K, tag) else NONE
                     SOME (K, tag)  
                 else NONE  
347          in          in
348              case t of              case t of
349                  S.STRUCT tag => decide ("S", tag, incomplete_structs)                  S.STRUCT tag => decide ("S", tag, incomplete_structs)
# Line 451  Line 469 
469                  simple (stem t)                  simple (stem t)
470                | rtti_val (S.STRUCT t) = EVar (Styp t)                | rtti_val (S.STRUCT t) = EVar (Styp t)
471                | rtti_val (S.UNION t) = EVar (Utyp t)                | rtti_val (S.UNION t) = EVar (Utyp t)
472                | rtti_val (S.FPTR cft) =                | rtti_val (S.FPTR cft) = let
473                  (case List.find (fn x => #1 x = cft) fptr_types of                      val cfth = hash_cft cft
474                    in
475                        case %? (fptr_types, cfth) of
476                       SOME (_, i) => EVar (fptr_rtti_qid i)                       SOME (_, i) => EVar (fptr_rtti_qid i)
477                     | NONE => raise Fail "fptr type missing")                        | NONE => raise Fail "fptr type missing"
478                    end
479                | rtti_val (S.PTR (S.RW, t)) =                | rtti_val (S.PTR (S.RW, t)) =
480                  (case incomplete t of                  (case incomplete t of
481                       SOME (K, tag) => EVar (isu_id (K, tag) ^ ".typ'rw")                       SOME (K, tag) => EVar (isu_id (K, tag) ^ ".typ'rw")
# Line 468  Line 489 
489                  EApp (EVar "T.arr", ETuple [rtti_val t, dim_val d])                  EApp (EVar "T.arr", ETuple [rtti_val t, dim_val d])
490          end          end
491    
492          fun fptr_mkcall spec =          fun fptr_mkcall spec = let
493              case List.find (fn x => #1 x = spec) fptr_types of              val h = hash_cft spec
494            in
495                case %? (fptr_types, h) of
496                  SOME (_, i) => fptr_mkcall_qid i                  SOME (_, i) => fptr_mkcall_qid i
497                | NONE => raise Fail "missing fptr_type (mkcall)"                | NONE => raise Fail "missing fptr_type (mkcall)"
498            end
499    
500          fun openPP0 nocredits (f, src) = let          fun openPP0 nocredits (f, src) = let
501              val dst = TextIO.openOut f              val dst = TextIO.openOut f
# Line 526  Line 550 
550    
551          val get_callop = let          val get_callop = let
552              val ncallops = ref 0              val ncallops = ref 0
553              val callops = ref []              val callops = ref IM.empty
554              fun callop_sid i = "Callop_" ^ Int.toString i              fun callop_sid i = "Callop_" ^ Int.toString i
555              fun callop_qid i = callop_sid i ^ ".callop"              fun callop_qid i = callop_sid i ^ ".callop"
556              fun get (ml_args_t, e_proto, ml_res_t) =              fun get (ml_args_t, e_proto, ml_res_t) = let
557                  case List.find (fn (ep, _) => ep = e_proto) (!callops) of                  val e_proto_hash = hash_mltype e_proto
558                      SOME (_, i) => callop_qid i              in
559                    case %? (!callops, e_proto_hash) of
560                        SOME i => callop_qid i
561                    | NONE => let                    | NONE => let
562                          val i = !ncallops                          val i = !ncallops
563                          val sn = callop_sid i                          val sn = callop_sid i
# Line 540  Line 566 
566                              openPP (file, NONE)                              openPP (file, NONE)
567                      in                      in
568                          ncallops := i + 1;                          ncallops := i + 1;
569                          callops := (e_proto, i) :: !callops;                          callops := IM.insert (!callops, e_proto_hash, i);
570                          str (concat ["structure ", sn, " = struct"]);                          str (concat ["structure ", sn, " = struct"]);
571                          Box 4;                          Box 4;
572                          pr_vdef ("callop",                          pr_vdef ("callop",
# Line 553  Line 579 
579                          nl (); str "end"; nl (); closePP ();                          nl (); str "end"; nl (); closePP ();
580                          callop_qid i                          callop_qid i
581                      end                      end
582                end
583          in          in
584              get              get
585          end          end
# Line 1101  Line 1128 
1128                  nl ()                  nl ()
1129              end              end
1130          in          in
1131              app (pr_isu_def "S") incomplete_structs;              SS.app (pr_isu_def "S") incomplete_structs;
1132              app (pr_isu_def "U") incomplete_unions;              SS.app (pr_isu_def "U") incomplete_unions;
1133              closePP ()              closePP ()
1134          end          end
1135    
# Line 1125  Line 1152 
1152              closePP ()              closePP ()
1153          end          end
1154          val needs_iptr =          val needs_iptr =
1155              case (incomplete_structs, incomplete_unions) of              not (SS.isEmpty incomplete_structs andalso
1156                  ([], []) => false                   SS.isEmpty incomplete_unions)
               | _ => true  
1157      in      in
1158    
1159          app pr_fptr_rtti fptr_types;          IM.app pr_fptr_rtti fptr_types;
1160          app pr_st_structure structs;          SM.app pr_st_structure structs;
1161          app pr_ut_structure unions;          SM.app pr_ut_structure unions;
1162          app pr_s_structure structs;          SM.app pr_s_structure structs;
1163          app pr_u_structure unions;          SM.app pr_u_structure unions;
1164          app pr_t_structure gtys;          app pr_t_structure gtys;
1165          app pr_gvar gvars;          app pr_gvar gvars;
1166          app pr_gfun gfuns;          app pr_gfun gfuns;

Legend:
Removed from v.1061  
changed lines
  Added in v.1062

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