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 974, Sun Oct 28 03:29:04 2001 UTC revision 975, Wed Oct 31 20:22:44 2001 UTC
# Line 8  Line 8 
8   *)   *)
9  local  local
10      val program = "ml-ffigen"      val program = "ml-ffigen"
11      val version = "0.3"      val version = "0.4"
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 25  Line 25 
25                  allSU: bool,                  allSU: bool,
26                  lambdasplit: string option,                  lambdasplit: string option,
27                  wid: int,                  wid: int,
28                    weightreq: bool option, (* true -> heavy, false -> light *)
29                  target : { name  : string,                  target : { name  : string,
30                             sizes : Sizes.sizes,                             sizes : Sizes.sizes,
31                             shift : int * int * word -> word,                             shift : int * int * word -> word,
# Line 34  Line 35 
35      structure P = PrettyPrint      structure P = PrettyPrint
36      structure PP = P.PP      structure PP = P.PP
37      val Tuple = P.TUPLE      val Tuple = P.TUPLE
38        fun Record [] = P.Unit
39          | Record l = P.RECORD l
40      val Con = P.CON      val Con = P.CON
41      val Arrow = P.ARROW      val Arrow = P.ARROW
42      val Type = P.Type      val Type = P.Type
# Line 41  Line 44 
44      val Un = P.Un      val Un = P.Un
45      val Unit = P.Unit      val Unit = P.Unit
46      val ETuple = P.ETUPLE      val ETuple = P.ETUPLE
47        fun ERecord [] = P.ETUPLE []
48          | ERecord l = P.ERECORD l
49      val EVar = P.EVAR      val EVar = P.EVAR
50      val EApp = P.EAPP      val EApp = P.EAPP
51      val EConstr = P.ECONSTR      val EConstr = P.ECONSTR
52      val ESeq = P.ESEQ      val ESeq = P.ESEQ
53      fun EWord w = EVar ("0wx" ^ Word.toString w)      fun EWord w = EVar ("0wx" ^ Word.toString w)
54      fun EInt i = EVar (Int.toString i)      fun EInt i = EVar (Int.toString i)
55        fun ELInt i = EVar (LargeInt.toString i)
56      fun EString s = EVar (concat ["\"", String.toString s, "\""])      fun EString s = EVar (concat ["\"", String.toString s, "\""])
57    
58        val writeto = "write_to"
59    
60        val sint_ty = Type "MLRep.SInt.int"
61    
62      val dontedit = "(* This file has been generated automatically. \      val dontedit = "(* This file has been generated automatically. \
63                     \DO NOT EDIT! *)"                     \DO NOT EDIT! *)"
64      fun mkCredits (src, archos) =      fun mkCredits (src, archos) =
# Line 65  Line 75 
75                signame, strname,                signame, strname,
76                allSU, lambdasplit,                allSU, lambdasplit,
77                wid,                wid,
78                  weightreq,
79                target = { name = archos, sizes, shift, stdcall } } = args                target = { name = archos, sizes, shift, stdcall } } = args
80    
81            val (doheavy, dolight) =
82                case weightreq of
83                    NONE => (true, true)
84                  | SOME true => (true, false)
85                  | SOME false => (false, true)
86    
87            val doargnames = true           (* FIXME: customizable *)
88    
89          val credits = mkCredits (idlfile, archos)          val credits = mkCredits (idlfile, archos)
90    
91          val astbundle = ParseToAst.fileToAst'          val astbundle = ParseToAst.fileToAst'
# Line 76  Line 95 
95    
96          val spec = AstToSpec.build (astbundle, sizes, idlfile, allSU, shift)          val spec = AstToSpec.build (astbundle, sizes, idlfile, allSU, shift)
97    
98          val { structs, unions, gvars, gfuns, gtys } = spec          val { structs, unions, gvars, gfuns, gtys, enums } = spec
99    
100          fun openPP f =          fun openPP f =
101              PP.openStream (SimpleTextIODev.openDev { dst = TextIO.openOut f,              PP.openStream (SimpleTextIODev.openDev { dst = TextIO.openOut f,
# Line 126  Line 145 
145                  ((ignore (get_union t); a)                  ((ignore (get_union t); a)
146                   handle Incomplete => (f, s, sinsert (t, u)))                   handle Incomplete => (f, s, sinsert (t, u)))
147                | ty ((S.PTR (_, t) | S.ARR { t, ... }), a) = ty (t, a)                | ty ((S.PTR (_, t) | S.ARR { t, ... }), a) = ty (t, a)
148                | ty (S.FPTR cft, a as (f, s, u)) =                | ty (S.FPTR (cft as { args, res }), a) = let
149                        val a' = foldl ty a args
150                        val a'' = case res of NONE => a'
151                                            | SOME t => ty (t, a')
152                        val (f, s, u) = a''
153                    in
154                  if List.exists (fn (cft', _) => cft = cft') f then a                  if List.exists (fn (cft', _) => cft = cft') f then a
155                  else ((cft, length f) :: f, s, u)                  else ((cft, length f) :: f, s, u)
156                    end
157              fun fs (S.OFIELD { spec = (_, t), ... }, a) = ty (t, a)              fun fs (S.OFIELD { spec = (_, t), ... }, a) = ty (t, a)
158                | fs (_, a) = a                | fs (_, a) = a
159              fun f ({ name, spec }, a) = fs (spec, a)              fun f ({ name, spec }, a) = fs (spec, a)
# Line 137  Line 162 
162                  foldl f a (largest :: all)                  foldl f a (largest :: all)
163              fun gty ({ name, spec }, a) = ty (spec, a)              fun gty ({ name, spec }, a) = ty (spec, a)
164              fun gvar ({ name, spec = (_, t) }, a) = ty (t, a)              fun gvar ({ name, spec = (_, t) }, a) = ty (t, a)
165              fun gfun ({ name, spec }, a) = ty (S.FPTR spec, a)              fun gfun ({ name, spec, argnames }, a) = ty (S.FPTR spec, a)
166          in          in
167              foldl gfun (foldl gvar              foldl gfun (foldl gvar
168                           (foldl gty (foldl u (foldl s ([], [], []) structs)                           (foldl gty (foldl u (foldl s ([], [], []) structs)
# Line 218  Line 243 
243    
244          and wtn_ty' t = wtn_ty_p "'" t          and wtn_ty' t = wtn_ty_p "'" t
245    
246          fun topfunc_ty p { args, res } = let          fun topfunc_ty p ({ args, res }, argnames) = let
247              fun topty S.SCHAR = Type "MLRep.SChar.int"              fun topty S.SCHAR = Type "MLRep.SChar.int"
248                | topty S.UCHAR = Type "MLRep.UChar.word"                | topty S.UCHAR = Type "MLRep.UChar.word"
249                | topty S.SINT = Type "MLRep.SInt.int"                | topty S.SINT = Type "MLRep.SInt.int"
# Line 232  Line 257 
257                | topty (S.STRUCT t) = Con ("su_obj" ^ p, [St t, Type "'c"])                | topty (S.STRUCT t) = Con ("su_obj" ^ p, [St t, Type "'c"])
258                | topty (S.UNION t) = Con ("su_obj" ^ p, [Un t, Type "'c"])                | topty (S.UNION t) = Con ("su_obj" ^ p, [Un t, Type "'c"])
259                | topty t = wtn_ty_p p t                | topty t = wtn_ty_p p t
260              val (res_t, extra_arg_t) =              val (res_t, extra_arg_t, extra_argname) =
261                  case res of                  case res of
262                      NONE => (Unit, [])                      NONE => (Unit, [], [])
263                    | SOME (S.STRUCT t) => let                    | SOME (S.STRUCT t) => let
264                          val ot = Suobj'rw p (St t)                          val ot = Suobj'rw p (St t)
265                      in                      in
266                          (ot, [ot])                          (ot, [ot], [writeto])(* hack -- check for nameclash *)
267                      end                      end
268                    | SOME (S.UNION t) => let                    | SOME (S.UNION t) => let
269                          val ot = Suobj'rw p (Un t)                          val ot = Suobj'rw p (Un t)
270                      in                      in
271                          (ot, [ot])                          (ot, [ot], [writeto])(* hack *)
272                      end                      end
273                    | SOME t => (topty t, [])                    | SOME t => (topty t, [], [])
274                val argtyl = map topty args
275                val aggreg_argty =
276                    case (doargnames, argnames) of
277                        (true, SOME nl) =>
278                        Record (ListPair.zip (extra_argname @ nl,
279                                              extra_arg_t @ argtyl))
280                      | _ => Tuple (extra_arg_t @ argtyl)
281          in          in
282              Arrow (Tuple (extra_arg_t @ map topty args), res_t)              Arrow (aggreg_argty, res_t)
283          end          end
284    
285          fun  rti_ty t = Con ("T.typ", [wtn_ty t])          fun  rtti_ty t = Con ("T.typ", [wtn_ty t])
286    
287          fun  obj_ty p (t, c) = Con ("obj" ^ p, [wtn_ty t, c])          fun  obj_ty p (t, c) = Con ("obj" ^ p, [wtn_ty t, c])
288    
# Line 268  Line 300 
300          local          local
301              fun simple v = EVar ("T." ^ v)              fun simple v = EVar ("T." ^ v)
302          in          in
303              fun rti_val (t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |              fun rtti_val (t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
304                                 S.SSHORT | S.USHORT | S.SLONG | S.ULONG |                                 S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
305                                 S.FLOAT | S.DOUBLE | S.VOIDPTR)) =                                 S.FLOAT | S.DOUBLE | S.VOIDPTR)) =
306                  simple (stem t)                  simple (stem t)
307                | rti_val (S.STRUCT t) = EVar (concat ["S_", t, ".typ"])                | rtti_val (S.STRUCT t) = EVar (concat ["S_", t, ".typ"])
308                | rti_val (S.UNION t) = EVar (concat ["U_", t, ".typ"])                | rtti_val (S.UNION t) = EVar (concat ["U_", t, ".typ"])
309                | rti_val (S.FPTR cft) =                | rtti_val (S.FPTR cft) =
310                  (case List.find (fn x => #1 x = cft) fptr_types of                  (case List.find (fn x => #1 x = cft) fptr_types of
311                       SOME (_, i) => EVar ("fptr_rti_" ^ Int.toString i)                       SOME (_, i) => EVar ("fptr_rtti_" ^ Int.toString i)
312                     | NONE => raise Fail "fptr type missing")                     | NONE => raise Fail "fptr type missing")
313                | rti_val (S.PTR (S.RW, t)) =                | rtti_val (S.PTR (S.RW, t)) =
314                  (case incomplete t of                  (case incomplete t of
315                       SOME (K, tag) =>                       SOME (K, tag) =>
316                       EVar (istruct (K, tag) ^ ".typ'rw")                       EVar (istruct (K, tag) ^ ".typ'rw")
317                     | NONE => EApp (EVar "T.pointer", rti_val t))                     | NONE => EApp (EVar "T.pointer", rtti_val t))
318                | rti_val (S.PTR (S.RO, t)) =                | rtti_val (S.PTR (S.RO, t)) =
319                  (case incomplete t of                  (case incomplete t of
320                       SOME (K, tag) =>                       SOME (K, tag) =>
321                       EVar (istruct (K, tag) ^ ".typ'ro")                       EVar (istruct (K, tag) ^ ".typ'ro")
322                     | NONE => EApp (EVar "T.ro",                     | NONE => EApp (EVar "T.ro",
323                                     EApp (EVar "T.pointer", rti_val t)))                                     EApp (EVar "T.pointer", rtti_val t)))
324                | rti_val (S.ARR { t, d, ... }) =                | rtti_val (S.ARR { t, d, ... }) =
325                  EApp (EVar "T.arr", ETuple [rti_val t, dim_val d])                  EApp (EVar "T.arr", ETuple [rtti_val t, dim_val d])
326          end          end
327    
328          fun do_sig_file () = let          fun do_sig_file () = let
# Line 332  Line 364 
364                      pr_tdef ("t_f_" ^ name, wtn_ty t)                      pr_tdef ("t_f_" ^ name, wtn_ty t)
365                    | pr_field_typ _ = ()                    | pr_field_typ _ = ()
366    
367                  fun pr_field_rti { name, spec = S.OFIELD { spec = (c, t),                  fun pr_field_rtti { name, spec = S.OFIELD { spec = (c, t),
368                                                             synthetic = false,                                                             synthetic = false,
369                                                             offset } } =                                                             offset } } =
370                      pr_vdecl ("typ_f_" ^ name, rti_ty t)                      pr_vdecl ("typ_f_" ^ name, rtti_ty t)
371                    | pr_field_rti _ = ()                    | pr_field_rtti _ = ()
372    
373                  fun pr_field_acc0 (name, p, t) =                  fun pr_field_acc0 (name, p, t) =
374                      pr_vdecl (concat ["f_", name, p],                      pr_vdecl (concat ["f_", name, p],
# Line 365  Line 397 
397                  nl (); str (concat ["(* size for this ", su, " *)"]);                  nl (); str (concat ["(* size for this ", su, " *)"]);
398                  pr_vdecl ("size", Con ("S.size", [Con ("su", [StUn tag])]));                  pr_vdecl ("size", Con ("S.size", [Con ("su", [StUn tag])]));
399                  nl ();                  nl ();
400                  nl (); str (concat ["(* RTI for this ", su, " *)"]);                  nl (); str (concat ["(* RTTI for this ", su, " *)"]);
401                  pr_vdecl ("typ", Con ("T.typ", [Con ("su", [StUn tag])]));                  pr_vdecl ("typ", Con ("T.typ", [Con ("su", [StUn tag])]));
402                  nl ();                  nl ();
403                  nl (); str "(* witness types for fields *)";                  nl (); str "(* witness types for fields *)";
404                  app pr_field_typ fields;                  app pr_field_typ fields;
405                  nl ();                  nl ();
406                  nl (); str "(* RTI for fields *)";                  nl (); str "(* RTTI for fields *)";
407                  app pr_field_rti fields;                  app pr_field_rtti fields;
408                  nl ();                  if doheavy then
409                        (nl ();
410                  nl (); str "(* field accessors *)";                  nl (); str "(* field accessors *)";
411                  app (pr_field_acc "") fields;                       app (pr_field_acc "") fields)
412                  nl ();                  else ();
413                    if dolight then
414                        (nl ();
415                  nl (); str "(* field accessors (lightweight variety) *)";                  nl (); str "(* field accessors (lightweight variety) *)";
416                  app (pr_field_acc "'") fields;                       app (pr_field_acc "'") fields)
417                    else ();
418                  endBox ();                  endBox ();
419                  nl (); str (concat ["end (* structure ", K, "_", tag, " *)"])                  nl (); str (concat ["end (* structure ", K, "_", tag, " *)"])
420              end              end
# Line 388  Line 424 
424              fun pr_union_structure { tag, size, anon, largest, all } =              fun pr_union_structure { tag, size, anon, largest, all } =
425                  pr_su_structure (Un, "U", "union", tag, all)                  pr_su_structure (Un, "U", "union", tag, all)
426    
427              fun pr_gty_rti { name, spec } =              fun pr_gty_rtti { name, spec } =
428                  pr_vdecl ("typ_t_" ^ name, rti_ty spec)                  pr_vdecl ("typ_t_" ^ name, rtti_ty spec)
429    
430              fun pr_gvar_obj { name, spec = (c, t) } =              fun pr_gvar_obj { name, spec = (c, t) } =
431                  pr_vdecl ("g_" ^ name, Arrow (Unit, obj_ty "" (t, rwro c)))                  pr_vdecl ("g_" ^ name, Arrow (Unit, obj_ty "" (t, rwro c)))
432    
433              fun pr_gfun_rti { name, spec } =              fun pr_gfun_rtti { name, spec, argnames } =
434                  pr_vdecl ("typ_fn_" ^ name, rti_ty (S.FPTR spec))                  pr_vdecl ("typ_fn_" ^ name, rtti_ty (S.FPTR spec))
435    
436              fun pr_gfun_fptr { name, spec } =              fun pr_gfun_fptr { name, spec, argnames } =
437                  pr_vdecl ("fptr_fn_" ^ name,                  pr_vdecl ("fptr_fn_" ^ name,
438                            Arrow (Unit, wtn_ty (S.FPTR spec)))                            Arrow (Unit, wtn_ty (S.FPTR spec)))
439    
440              fun pr_gfun_func p { name, spec } =              fun pr_gfun_func p { name, spec, argnames } =
441                  pr_vdecl (concat ["fn_", name, p], topfunc_ty p spec)                  pr_vdecl (concat ["fn_", name, p],
442                              topfunc_ty p (spec, argnames))
443    
444              fun pr_isu (K, tag) =              fun pr_isu (K, tag) =
445                  (nl ();                  (nl ();
# Line 410  Line 447 
447                                " : POINTER_TO_INCOMPLETE_TYPE"]))                                " : POINTER_TO_INCOMPLETE_TYPE"]))
448              fun pr_istruct tag = pr_isu ("S", tag)              fun pr_istruct tag = pr_isu ("S", tag)
449              fun pr_iunion tag = pr_isu ("U", tag)              fun pr_iunion tag = pr_isu ("U", tag)
450    
451                fun pr_enum_const { name, spec } = pr_vdecl ("e_" ^ name, sint_ty)
452          in          in
453              (* Generating the signature file... *)              (* Generating the signature file... *)
454              str dontedit;              str dontedit;
# Line 425  Line 464 
464              app pr_struct_structure structs;              app pr_struct_structure structs;
465              app pr_union_structure unions;              app pr_union_structure unions;
466              if not (List.null cgtys) then              if not (List.null cgtys) then
467                  (nl (); nl (); str "(* RTI for typedefs *)";                  (nl (); nl (); str "(* RTTI for typedefs *)";
468                   app pr_gty_rti cgtys)                   app pr_gty_rtti cgtys)
469              else ();              else ();
470              if not (List.null gvars) then              if not (List.null gvars) then
471                  (nl (); nl (); str "(* object handles for global variables *)";                  (nl (); nl (); str "(* object handles for global variables *)";
472                   app pr_gvar_obj gvars)                   app pr_gvar_obj gvars)
473              else ();              else ();
474              if not (List.null gfuns) then              if not (List.null gfuns) then
475                  (nl (); nl (); str "(* RTI for global function(-pointer)s *)";                  (nl (); nl (); str "(* RTTI for global function(-pointer)s *)";
476                   app pr_gfun_rti gfuns;                   app pr_gfun_rtti gfuns;
477                   nl (); nl (); str "(* global function pointers *)";                   nl (); nl (); str "(* global function pointers *)";
478                   app pr_gfun_fptr gfuns;                   app pr_gfun_fptr gfuns;
479                   nl (); nl (); str "(* global functions *)";                   nl (); nl (); str "(* global functions *)";
480                   app (pr_gfun_func "'") gfuns;                   if dolight then app (pr_gfun_func "'") gfuns else ();
481                   app (pr_gfun_func "") gfuns)                   if doheavy then app (pr_gfun_func "") gfuns else ())
482                else ();
483                if not (List.null enums) then
484                    (nl (); nl (); str "(* enum constants *)";
485                     app pr_enum_const enums)
486              else ();              else ();
487              endBox ();              endBox ();
488              nl (); str (concat ["end (* signature ", signame, " *)"]);              nl (); str (concat ["end (* signature ", signame, " *)"]);
# Line 517  Line 560 
560              fun pr_union_tag_copy { tag, size, anon, largest, all } =              fun pr_union_tag_copy { tag, size, anon, largest, all } =
561                  pr_su_tag_copy ("u", tag)                  pr_su_tag_copy ("u", tag)
562    
563              fun pr_fptr_rti ({ args, res }, i) = let              fun pr_fptr_rtti ({ args, res }, i) = let
564    
565                  (* cproto encoding *)                  (* cproto encoding *)
566                  fun List t = Con ("list", [t])                  fun List t = Con ("list", [t])
# Line 594  Line 637 
637                                  S.SSHORT | S.USHORT | S.SLONG | S.ULONG |                                  S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
638                                  S.FLOAT | S.DOUBLE)) =                                  S.FLOAT | S.DOUBLE)) =
639                      Type ("CMemory.cc_" ^ stem t)                      Type ("CMemory.cc_" ^ stem t)
640                    | mlty (S.VOIDPTR | S.PTR _ | S.FPTR _ |                    | mlty (S.VOIDPTR | S.PTR _ | S.FPTR _ | S.STRUCT _) =
641                            S.STRUCT _) = Type "CMemory.cc_addr"                      Type "CMemory.cc_addr"
642                    | mlty (S.ARR _ | S.UNION _) = raise Fail "unexpected type"                    | mlty (S.ARR _ | S.UNION _) = raise Fail "unexpected type"
643    
644                  fun wrap (e, n) =                  fun wrap (e, n) =
# Line 662  Line 705 
705                              fun iunwrap (K, tag, t) r =                              fun iunwrap (K, tag, t) r =
706                                  EApp (EApp (EVar (istruct (K, tag) ^                                  EApp (EApp (EVar (istruct (K, tag) ^
707                                                    ".cast'"),                                                    ".cast'"),
708                                              rti_val t),                                              rtti_val t),
709                                        punwrap "vcast" r)                                        punwrap "vcast" r)
710                              val res_wrap =                              val res_wrap =
711                                  case t of                                  case t of
# Line 694  Line 737 
737                  val arg_e = ETuple (extra_arg_e @ args_el)                  val arg_e = ETuple (extra_arg_e @ args_el)
738              in              in
739                  nl ();                  nl ();
740                  str (concat ["val ", "fptr_rti_", Int.toString i, " = let"]);                  str (concat ["val ", "fptr_rtti_", Int.toString i, " = let"]);
741                  VBox 4;                  VBox 4;
742                  pr_vdef ("callop",                  pr_vdef ("callop",
743                            EConstr (EVar "RawMemInlineT.rawccall",                            EConstr (EVar "RawMemInlineT.rawccall",
# Line 712  Line 755 
755                  VBox 4;                  VBox 4;
756                  nl (); ppExp (EConstr (EApp (EVar "mk_fptr_typ",                  nl (); ppExp (EConstr (EApp (EVar "mk_fptr_typ",
757                                               EVar "mkcall"),                                               EVar "mkcall"),
758                                         rti_ty (S.FPTR { args = args,                                         rtti_ty (S.FPTR { args = args,
759                                                          res = res })));                                                          res = res })));
760                  endBox ();                  endBox ();
761                  nl (); str "end"                  nl (); str "end"
# Line 726  Line 769 
769                                                             offset } } =                                                             offset } } =
770                      pr_tdef ("t_f_" ^ name, wtn_ty t)                      pr_tdef ("t_f_" ^ name, wtn_ty t)
771                    | pr_field_typ _ = ()                    | pr_field_typ _ = ()
772                  fun pr_field_rti { name, spec = S.OFIELD { spec = (c, t),                  fun pr_field_rtti { name, spec = S.OFIELD { spec = (c, t),
773                                                             synthetic = false,                                                             synthetic = false,
774                                                             offset } } =                                                             offset } } =
775                      pr_vdef ("typ_f_" ^ name, rti_val t)                      pr_vdef ("typ_f_" ^ name, rtti_val t)
776                    | pr_field_rti _ = ()                    | pr_field_rtti _ = ()
777    
778                  fun pr_bf_acc (name, p, sign,                  fun pr_bf_acc (name, p, sign,
779                                 { offset, constness, bits, shift }) =                                 { offset, constness, bits, shift }) =
# Line 769  Line 812 
812                      if synthetic then ()                      if synthetic then ()
813                      else let                      else let
814                              val maker = concat ["mk_", rwro c, "_field"]                              val maker = concat ["mk_", rwro c, "_field"]
815                              val rtival = EVar ("typ_f_" ^ name)                              val rttival = EVar ("typ_f_" ^ name)
816                          in                          in
817                              pr_fdef ("f_" ^ name,                              pr_fdef ("f_" ^ name,
818                                       [EVar "x"],                                       [EVar "x"],
819                                       EApp (EApp (EApp (EVar maker, rtival),                                       EApp (EApp (EApp (EVar maker, rttival),
820                                                   EInt offset),                                                   EInt offset),
821                                             EVar "x"))                                             EVar "x"))
822                          end                          end
# Line 787  Line 830 
830                  Box 4;                  Box 4;
831                  nl (); str (concat ["open ", K, "_", tag]);                  nl (); str (concat ["open ", K, "_", tag]);
832                  app pr_field_typ fields;                  app pr_field_typ fields;
833                  app pr_field_rti fields;                  app pr_field_rtti fields;
834                  app pr_field_acc' fields;                  if dolight then app pr_field_acc' fields else ();
835                  app pr_field_acc fields;                  if doheavy then app pr_field_acc fields else ();
836                  endBox ();                  endBox ();
837                  nl (); str "end"                  nl (); str "end"
838              end              end
# Line 799  Line 842 
842              fun pr_union_structure { tag, size, anon, largest, all } =              fun pr_union_structure { tag, size, anon, largest, all } =
843                  pr_su_structure (Un, "u", "U", tag, size, all)                  pr_su_structure (Un, "u", "U", tag, size, all)
844    
845              fun pr_gty_rti { name, spec } =              fun pr_gty_rtti { name, spec } =
846                  pr_vdef ("typ_t_" ^ name, rti_val spec)                  pr_vdef ("typ_t_" ^ name, rtti_val spec)
847    
848              fun pr_addr (prefix, name) =              fun pr_addr (prefix, name) =
849                  pr_vdef (prefix ^ name,                  pr_vdef (prefix ^ name,
# Line 810  Line 853 
853              fun pr_gvar_addr { name, spec } = pr_addr ("gh_", name)              fun pr_gvar_addr { name, spec } = pr_addr ("gh_", name)
854    
855              fun pr_gvar_obj { name, spec = (c, t) } = let              fun pr_gvar_obj { name, spec = (c, t) } = let
856                  val rwobj = EApp (EApp (EVar "mk_obj", rti_val t),                  val rwobj = EApp (EApp (EVar "mk_obj", rtti_val t),
857                                    EApp (EVar "D.addr", EVar ("gh_" ^ name)))                                    EApp (EVar "D.addr", EVar ("gh_" ^ name)))
858                  val obj = case c of S.RW => rwobj                  val obj = case c of S.RW => rwobj
859                                    | S.RO => EApp (EVar "ro", rwobj)                                    | S.RO => EApp (EVar "ro", rwobj)
# Line 818  Line 861 
861                  pr_fdef ("g_" ^ name, [ETuple []], obj)                  pr_fdef ("g_" ^ name, [ETuple []], obj)
862              end              end
863    
864              fun pr_gfun_rti { name, spec } =              fun pr_gfun_rtti { name, spec, argnames } =
865                  pr_vdef ("typ_fn_" ^ name, rti_val (S.FPTR spec))                  pr_vdef ("typ_fn_" ^ name, rtti_val (S.FPTR spec))
866    
867              fun pr_gfun_addr { name, spec } = pr_addr ("fnh_", name)              fun pr_gfun_addr { name, spec, argnames } = pr_addr ("fnh_", name)
868    
869              fun pr_gfun_fptr { name, spec } =              fun pr_gfun_fptr { name, spec, argnames } =
870                  pr_fdef ("fptr_fn_" ^ name,                  pr_fdef ("fptr_fn_" ^ name,
871                           [ETuple []],                           [ETuple []],
872                           EApp (EApp (EVar "mk_fptr", EVar ("typ_fn_" ^ name)),                           EApp (EApp (EVar "mk_fptr", EVar ("typ_fn_" ^ name)),
873                                 EApp (EVar "D.addr", EVar ("fnh_" ^ name))))                                 EApp (EVar "D.addr", EVar ("fnh_" ^ name))))
874    
875              fun pr_gfun_func is_light { name, spec = { args, res } } = let              fun pr_gfun_func is_light x = let
876                    val { name, spec = { args, res }, argnames } = x
877                    (* FIXME: use argnames! *)
878                  val p = if is_light then "'" else ""                  val p = if is_light then "'" else ""
879                  val ml_vars =                  val ml_vars =
880                      rev (#1 (foldl (fn (_, (l, i)) =>                      rev (#1 (foldl (fn (_, (l, i)) =>
# Line 842  Line 887 
887                  fun light (what, e) = app0 ("Light." ^ what, e)                  fun light (what, e) = app0 ("Light." ^ what, e)
888                  fun heavy (what, t, e) =                  fun heavy (what, t, e) =
889                      if is_light then e                      if is_light then e
890                      else EApp (EApp (EVar ("Heavy." ^ what), rti_val t), e)                      else EApp (EApp (EVar ("Heavy." ^ what), rtti_val t), e)
891    
892                  fun oneArg (e, t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |                  fun oneArg (e, t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
893                                       S.SSHORT | S.USHORT | S.SLONG | S.ULONG |                                       S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
# Line 859  Line 904 
904                    | oneArg (e, S.VOIDPTR) = e                    | oneArg (e, S.VOIDPTR) = e
905                    | oneArg (e, S.ARR _) = raise Fail "array argument type"                    | oneArg (e, S.ARR _) = raise Fail "array argument type"
906                  val c_exps = ListPair.map oneArg (ml_vars, args)                  val c_exps = ListPair.map oneArg (ml_vars, args)
907                  val (ml_vars, c_exps) =                  val (ml_vars, c_exps, extra_argname) =
908                      case res of                      case res of
909                          SOME (S.STRUCT _ | S.UNION _) =>                          SOME (S.STRUCT _ | S.UNION _) =>
910                          (EVar "x0" :: ml_vars,                          (EVar "x0" :: ml_vars,
911                           light ("obj", EVar "x0") :: c_exps)                           light ("obj", EVar "x0") :: c_exps,
912                        | _ => (ml_vars, c_exps)                           [writeto])
913                          | _ => (ml_vars, c_exps, [])
914                  val call = EApp (EVar "call",                  val call = EApp (EVar "call",
915                                   ETuple [EApp (EVar ("fptr_fn_" ^ name),                                   ETuple [EApp (EVar ("fptr_fn_" ^ name),
916                                                 ETuple []),                                                 ETuple []),
# Line 885  Line 931 
931                        | SOME (t as S.FPTR _) => heavy ("fptr", t, call)                        | SOME (t as S.FPTR _) => heavy ("fptr", t, call)
932                        | SOME (S.ARR _) => raise Fail "array result type"                        | SOME (S.ARR _) => raise Fail "array result type"
933                        | (NONE | SOME S.VOIDPTR) => call                        | (NONE | SOME S.VOIDPTR) => call
934                    val argspat =
935                        case (doargnames, argnames) of
936                            (true, SOME nl) =>
937                            ERecord (ListPair.zip (extra_argname @ nl, ml_vars))
938                          | _ => ETuple ml_vars
939              in              in
940                  pr_fdef (concat ["fn_", name, p], [ETuple ml_vars], ml_res)                  pr_fdef (concat ["fn_", name, p], [argspat], ml_res)
941              end              end
942    
943              fun pr_isu_arg (K, tag) =              fun pr_isu_arg (K, tag) =
# Line 922  Line 973 
973                  pr_pre_su ("S", "s", S.STRUCT, St, tag, size)                  pr_pre_su ("S", "s", S.STRUCT, St, tag, size)
974              fun pr_pre_union { tag, size, anon, largest, all } =              fun pr_pre_union { tag, size, anon, largest, all } =
975                  pr_pre_su ("U", "u", S.UNION, Un, tag, size)                  pr_pre_su ("U", "u", S.UNION, Un, tag, size)
976    
977                fun pr_enum_const { name, spec } =
978                    pr_vdef ("e_" ^ name, EConstr (ELInt spec, sint_ty))
979          in          in
980              (* Generating the functor file... *)              (* Generating the functor file... *)
981              str dontedit;              str dontedit;
# Line 975  Line 1029 
1029              app pr_struct_tag_copy structs;              app pr_struct_tag_copy structs;
1030              app pr_union_tag_copy unions;              app pr_union_tag_copy unions;
1031    
1032              (* other local stuff (to define RTI for function pointers) *)              (* other local stuff (to define RTTI for function pointers) *)
1033              nl (); str "local";              nl (); str "local";
1034              VBox 4;              VBox 4;
1035              nl (); str "structure D = DynLinkage";              nl (); str "structure D = DynLinkage";
1036              nl (); str "open C.Dim C_Int";              nl (); str "open C.Dim C_Int";
1037    
1038              (* low-level call operations for all function pointers *)              (* low-level call operations for all function pointers *)
1039              app pr_fptr_rti fptr_types;              app pr_fptr_rtti fptr_types;
1040    
1041              (* the library handle (handle on shared object) *)              (* the library handle (handle on shared object) *)
1042              nl (); str "val so_h = library";              nl (); str "val so_h = library";
# Line 1002  Line 1056 
1056              (* ML structurse corresponding to C union declarations *)              (* ML structurse corresponding to C union declarations *)
1057              app pr_union_structure unions;              app pr_union_structure unions;
1058    
1059              (* RTI for C typedefs *)              (* RTTI for C typedefs *)
1060              app pr_gty_rti cgtys;              app pr_gty_rtti cgtys;
1061              (* (suspended) objects for global variables *)              (* (suspended) objects for global variables *)
1062              app pr_gvar_obj gvars;              app pr_gvar_obj gvars;
1063              (* RTI for function pointers corresponding to global C functions *)              (* RTTI for pointers corresponding to global C functions *)
1064              app pr_gfun_rti gfuns;              app pr_gfun_rtti gfuns;
1065              (* (suspended) function pointers for global C functions *)              (* (suspended) function pointers for global C functions *)
1066              app pr_gfun_fptr gfuns;              app pr_gfun_fptr gfuns;
1067              (* ML functions corresponding to global C functions *)              (* ML functions corresponding to global C functions *)
1068              app (pr_gfun_func true) gfuns;(* light *)              if dolight then app (pr_gfun_func true) gfuns else ();
1069              app (pr_gfun_func false) gfuns;(* heavy *)              if doheavy then app (pr_gfun_func false) gfuns else ();
1070                (* enum constants *)
1071                app pr_enum_const enums;
1072              endBox ();              endBox ();
1073              nl (); str "end";           (* local *)              nl (); str "end";           (* local *)
1074              endBox ();              endBox ();

Legend:
Removed from v.974  
changed lines
  Added in v.975

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