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 1035, Thu Jan 24 19:07:18 2002 UTC revision 1036, Fri Jan 25 22:05:44 2002 UTC
# Line 8  Line 8 
8   *)   *)
9  local  local
10      val program = "ml-ffigen"      val program = "ml-ffigen"
11      val version = "0.6"      val version = "0.7"
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 16  Line 16 
16    
17  structure Gen :> sig  structure Gen :> sig
18      val gen : { cfiles: string list,      val gen : { cfiles: string list,
19                    match: string -> bool,
20                  mkidlsource: string -> string,                  mkidlsource: string -> string,
21                  dirname: string,                  dirname: string,
22                  cmfile: string,                  cmfile: string,
# Line 33  Line 34 
34                             sizes : Sizes.sizes,                             sizes : Sizes.sizes,
35                             shift : int * int * word -> word,                             shift : int * int * word -> word,
36                             stdcall : bool } } -> unit                             stdcall : bool } } -> unit
37        val version : string
38  end = struct  end = struct
39    
40        val version = version
41    
42      structure P = PrettyPrint      structure P = PrettyPrint
43      structure PP = P.PP      structure PP = P.PP
44      val Tuple = P.TUPLE      val Tuple = P.TUPLE
# Line 61  Line 65 
65    
66      val writeto = "write_to"      val writeto = "write_to"
67    
68      val sint_ty = Type "MLRep.SInt.int"      val sint_ty = Type "MLRep.Signed.int"
69    
70      val dontedit = "(* This file has been generated automatically. \      val dontedit = "(* This file has been generated automatically. \
71                     \DO NOT EDIT! *)"                     \DO NOT EDIT! *)"
# Line 93  Line 97 
97      fun enum_id n = "e_" ^ n      fun enum_id n = "e_" ^ n
98    
99      fun gen args = let      fun gen args = let
100          val { cfiles, mkidlsource,          val { cfiles, match, mkidlsource,
101                dirname, cmfile, prefix, extramembers, libraryhandle, complete,                dirname, cmfile, prefix, extramembers, libraryhandle, complete,
102                allSU, lambdasplit,                allSU, lambdasplit,
103                wid,                wid,
# Line 125  Line 129 
129                                       (sizes, State.INITIAL)                                       (sizes, State.INITIAL)
130                                       idlsource                                       idlsource
131                   val s' =                   val s' =
132                       AstToSpec.build (astbundle, sizes, cfiles, allSU, shift)                       AstToSpec.build (astbundle, sizes, cfiles, match,
133                                          allSU, shift)
134               in               in
135                   S.join (s', s)                   S.join (s', s)
136               end handle e => (OS.FileSys.remove idlsource handle _ => ();               end handle e => (OS.FileSys.remove idlsource handle _ => ();
# Line 168  Line 173 
173              result              result
174          end          end
175    
176            val (structs, unions) = let
177                val sdone = ref []
178                val udone = ref []
179                val slist = ref []
180                val ulist = ref []
181                val tq = ref []
182                fun tag (t: S.tag) t' = t = t'
183                fun s_tag t (s: S.s) = t = #tag s
184                fun u_tag t (u: S.u) = t = #tag u
185                fun ty_sched t = tq := t :: !tq
186                fun fs_sched (S.OFIELD { spec = (_, t), ... }) = ty_sched t
187                  | fs_sched _ = ()
188                fun f_sched { name, spec } = fs_sched spec
189                fun senter takeit t =
190                    if List.exists (tag t) (!sdone) then ()
191                    else (sdone := t :: !sdone;
192                          case List.find (s_tag t) structs of
193                              SOME x => (if takeit then slist := x :: !slist
194                                         else ();
195                                         app f_sched (#fields x))
196                            | NONE => ())
197                fun uenter takeit t =
198                    if List.exists (tag t) (!udone) then ()
199                    else (udone := t :: !udone;
200                          case List.find (u_tag t) unions of
201                              SOME x => (if takeit then ulist := x :: !ulist
202                                         else ();
203                                         app f_sched (#largest x :: #all x))
204                            | NONE => ())
205                fun sinclude (s: S.s) =
206                    if #exclude s then () else senter true (#tag s)
207                fun uinclude (u: S.u) =
208                    if #exclude u then () else uenter true (#tag u)
209                fun gty { src, name, spec } = ty_sched spec
210                fun gvar { src, name, spec = (_, t) } = ty_sched t
211                fun gfun { src, name, spec, argnames } = ty_sched (S.FPTR spec)
212                fun loop [] = ()
213                  | loop tl = let
214                        fun ty (S.STRUCT t) = senter true t
215                          | ty (S.UNION t) = uenter true t
216                          | ty (S.PTR (_, S.STRUCT t)) = senter false t
217                          | ty (S.PTR (_, S.UNION t)) = uenter false t
218                          | ty (S.PTR (_, t)) = ty t
219                          | ty (S.FPTR { args, res }) =
220                            (app ty args;
221                             case res of SOME x => ty x | NONE => ())
222                          | ty (S.ARR { t, ... }) = ty t
223                          | ty (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
224                                S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
225                                S.FLOAT | S.DOUBLE | S.VOIDPTR) = ()
226                        fun tloop [] = nextround ()
227                          | tloop (t :: ts) = (ty t; tloop ts)
228                    in
229                        tq := [];
230                        tloop tl
231                    end
232                and nextround () = loop (!tq)
233            in
234                app sinclude structs;
235                app uinclude unions;
236                app gty gtys;
237                app gvar gvars;
238                app gfun gfuns;
239                nextround ();
240                (!slist, !ulist)
241            end
242    
243          exception Incomplete          exception Incomplete
244    
245          fun get_struct t =          fun get_struct t =
# Line 224  Line 296 
296              fun fs (S.OFIELD { spec = (_, t), ... }, a) = ty (t, a)              fun fs (S.OFIELD { spec = (_, t), ... }, a) = ty (t, a)
297                | fs (_, a) = a                | fs (_, a) = a
298              fun f ({ name, spec }, a) = fs (spec, a)              fun f ({ name, spec }, a) = fs (spec, a)
299              fun s ({ src, tag, size, anon, fields }, a) = foldl f a fields              fun s ({ src, tag, size, anon, fields, exclude }, a) =
300              fun u ({ src, tag, size, anon, largest, all }, a) =                  foldl f a fields
301                fun u ({ src, tag, size, anon, largest, all, exclude }, a) =
302                  foldl f a (largest :: all)                  foldl f a (largest :: all)
303              fun gty ({ src, name, spec }, a) = ty (spec, a)              fun gty ({ src, name, spec }, a) = ty (spec, a)
304              fun gvar ({ src, name, spec = (_, t) }, a) = ty (t, a)              fun gvar ({ src, name, spec = (_, t) }, a) = ty (t, a)
# Line 311  Line 384 
384          and wtn_ty' t = wtn_ty_p "'" t          and wtn_ty' t = wtn_ty_p "'" t
385    
386          fun topfunc_ty p ({ args, res }, argnames) = let          fun topfunc_ty p ({ args, res }, argnames) = let
387              fun topty S.SCHAR = Type "MLRep.SChar.int"              fun topty (S.SCHAR | S.SINT | S.SSHORT | S.SLONG) =
388                | topty S.UCHAR = Type "MLRep.UChar.word"                  Type "MLRep.Signed.int"
389                | topty S.SINT = Type "MLRep.SInt.int"                | topty (S.UCHAR | S.UINT | S.USHORT | S.ULONG) =
390                | topty S.UINT = Type "MLRep.UInt.word"                  Type "MLRep.Unsigned.word"
391                | topty S.SSHORT = Type "MLRep.SShort.int"                | topty (S.FLOAT | S.DOUBLE) =
392                | topty S.USHORT = Type "MLRep.UShort.word"                  Type "MLRep.Real.real"
               | topty S.SLONG = Type "MLRep.SLong.int"  
               | topty S.ULONG = Type "MLRep.ULong.word"  
               | topty S.FLOAT = Type "MLRep.Float.real"  
               | topty S.DOUBLE = Type "MLRep.Double.real"  
393                | topty (S.STRUCT t) = Con ("su_obj" ^ p, [St t, Type "'c"])                | topty (S.STRUCT t) = Con ("su_obj" ^ p, [St t, Type "'c"])
394                | topty (S.UNION t) = Con ("su_obj" ^ p, [Un t, Type "'c"])                | topty (S.UNION t) = Con ("su_obj" ^ p, [Un t, Type "'c"])
395                | topty t = wtn_ty_p p t                | topty t = wtn_ty_p p t
# Line 395  Line 464 
464                  SOME (_, i) => fptr_mkcall_qid i                  SOME (_, i) => fptr_mkcall_qid i
465                | NONE => raise Fail "missing fptr_type (mkcall)"                | NONE => raise Fail "missing fptr_type (mkcall)"
466    
467          fun openPP (f, src) = let          fun openPP0 nocredits (f, src) = let
468              val dst = TextIO.openOut f              val dst = TextIO.openOut f
469              val stream = PP.openStream (SimpleTextIODev.openDev              val stream = PP.openStream (SimpleTextIODev.openDev
470                                              { dst = dst, wid = wid })                                              { dst = dst, wid = wid })
# Line 425  Line 494 
494              val pr_vdecl = pr_decl ("val", ":")              val pr_vdecl = pr_decl ("val", ":")
495              fun closePP () = (PP.closeStream stream; TextIO.closeOut dst)              fun closePP () = (PP.closeStream stream; TextIO.closeOut dst)
496          in          in
497              str dontedit;              if nocredits then ()
498                else (str dontedit;
499              case src of              case src of
500                  NONE => ()                  NONE => ()
501                | SOME s =>                | SOME s =>
502                  (nl (); str (concat ["(* [from code at ", s, "] *)"]));                  (nl (); str (concat ["(* [from code at ", s, "] *)"]));
503              line credits;              line credits;
504              line commentsto;              line commentsto;
505              nl ();                    nl ());
506              { stream = stream,              { stream = stream,
507                nl = nl, str = str, sp = sp, nsp = nsp, Box = Box, HVBox = HVBox,                nl = nl, str = str, sp = sp, nsp = nsp, Box = Box, HVBox = HVBox,
508                HBox = HBox, HOVBox = HOVBox, VBox = VBox, endBox = endBox,                HBox = HBox, HOVBox = HOVBox, VBox = VBox, endBox = endBox,
# Line 443  Line 513 
513                }                }
514          end          end
515    
516            fun openPP x = openPP0 false x
517    
518          val get_callop = let          val get_callop = let
519              val ncallops = ref 0              val ncallops = ref 0
520              val callops = ref []              val callops = ref []
# Line 657  Line 729 
729              val arg_e = ETuple (extra_arg_e @ args_el)              val arg_e = ETuple (extra_arg_e @ args_el)
730              val callop_n = get_callop (ml_args_t, e_proto, ml_res_t)              val callop_n = get_callop (ml_args_t, e_proto, ml_res_t)
731          in          in
732              str "local open C_Int in";              str "local open C.Dim C_Int in";
733              nl (); str (concat ["structure ", structname, " = struct"]);              nl (); str (concat ["structure ", structname, " = struct"]);
734              Box 4;              Box 4;
735              pr_fdef ("mkcall",              pr_fdef ("mkcall",
# Line 722  Line 794 
794              closePP ()              closePP ()
795          end          end
796    
797          fun pr_st_structure { src, tag, anon, size, fields } =          fun pr_st_structure { src, tag, anon, size, fields, exclude } =
798              pr_sut_structure (src, tag, anon, size, "s", "S")              pr_sut_structure (src, tag, anon, size, "s", "S")
799          fun pr_ut_structure { src, tag, anon, size, largest, all } =          fun pr_ut_structure { src, tag, anon, size, largest, all, exclude } =
800              pr_sut_structure (src, tag, anon, size, "u", "U")              pr_sut_structure (src, tag, anon, size, "u", "U")
801    
802          fun pr_su_structure (src, tag, fields, k, K) = let          fun pr_su_structure (src, tag, fields, k, K) = let
# Line 824  Line 896 
896              exports := sustruct :: (!exports)              exports := sustruct :: (!exports)
897          end          end
898    
899          fun pr_s_structure { src, tag, anon, size, fields } =          fun pr_s_structure { src, tag, anon, size, fields, exclude } =
900              pr_su_structure (src, tag, fields, "s", "S")              pr_su_structure (src, tag, fields, "s", "S")
901          fun pr_u_structure { src, tag, anon, size, largest, all } =          fun pr_u_structure { src, tag, anon, size, largest, all, exclude } =
902              pr_su_structure (src, tag, all, "u", "U")              pr_su_structure (src, tag, all, "u", "U")
903    
904          fun pr_t_structure { src, name, spec } =          fun pr_t_structure { src, name, spec } =
# Line 839  Line 911 
911                          openPP (file, SOME src)                          openPP (file, SOME src)
912                      val tstruct = "structure " ^ Tstruct name                      val tstruct = "structure " ^ Tstruct name
913                  in                  in
914                      str "local open C in";                      str "local open C.Dim C in";
915                      nl (); str (tstruct ^ " = struct");                      nl (); str (tstruct ^ " = struct");
916                      Box 4;                      Box 4;
917                      pr_tdef ("t", rtti_ty spec);                      pr_tdef ("t", rtti_ty spec);
# Line 867  Line 939 
939              Box 4;              Box 4;
940              nl (); str "local";              nl (); str "local";
941              VBox 4;              VBox 4;
942              nl (); str "open C_Int";              nl (); str "open C.Dim C_Int";
943              pr_vdef ("h", EApp (EVar libraryhandle, EString name));              pr_vdef ("h", EApp (EVar libraryhandle, EString name));
944              endBox ();              endBox ();
945              nl (); str "in";              nl (); str "in";
# Line 963  Line 1035 
1035          in          in
1036              str "local";              str "local";
1037              Box 4;              Box 4;
1038              nl (); str "open C_Int";              nl (); str "open C.Dim C_Int";
1039              pr_vdef ("h", EApp (EVar libraryhandle, EString name));              pr_vdef ("h", EApp (EVar libraryhandle, EString name));
1040              endBox ();              endBox ();
1041              nl (); str "in";              nl (); str "in";
# Line 1007  Line 1079 
1079              exports := estruct :: !exports              exports := estruct :: !exports
1080          end          end
1081    
1082          fun do_iptrs () = let          fun do_iptrs report_only = let
1083              val file = smlfile "iptrs"              val file = smlfile "iptrs"
1084              val { closePP, str, nl, ... } = openPP (file, NONE)              val { closePP, str, nl, ... } = openPP0 report_only (file, NONE)
1085              fun pr_isu_def K tag = let              fun pr_isu_def K tag = let
1086                  val istruct = "structure " ^ isu_id (K, tag)                  val istruct = "structure " ^ isu_id (K, tag)
1087              in              in
1088                    if report_only then str "(* "
1089                    else exports := istruct :: !exports;
1090                  str (istruct ^ " = PointerToIncompleteType ()");                  str (istruct ^ " = PointerToIncompleteType ()");
1091                  nl ();                  if report_only then str " *)" else ();
1092                  exports := istruct :: !exports                  nl ()
1093              end              end
1094          in          in
1095              app (pr_isu_def "S") incomplete_structs;              app (pr_isu_def "S") incomplete_structs;
# Line 1056  Line 1130 
1130          app pr_gvar gvars;          app pr_gvar gvars;
1131          app pr_gfun gfuns;          app pr_gfun gfuns;
1132          app pr_enum enums;          app pr_enum enums;
1133          if complete andalso needs_iptr then do_iptrs () else ();          if complete then
1134                if needs_iptr then do_iptrs false else ()
1135            else do_iptrs true;
1136          do_cmfile ()          do_cmfile ()
1137      end      end
1138  end  end

Legend:
Removed from v.1035  
changed lines
  Added in v.1036

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