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 976, Wed Nov 14 14:54:03 2001 UTC revision 977, Wed Nov 14 16:53:16 2001 UTC
# Line 26  Line 26 
26                  lambdasplit: string option,                  lambdasplit: string option,
27                  wid: int,                  wid: int,
28                  weightreq: bool option, (* true -> heavy, false -> light *)                  weightreq: bool option, (* true -> heavy, false -> light *)
29                    namedargs: bool,
30                  target : { name  : string,                  target : { name  : string,
31                             sizes : Sizes.sizes,                             sizes : Sizes.sizes,
32                             shift : int * int * word -> word,                             shift : int * int * word -> word,
# Line 68  Line 69 
69      val commentsto = concat ["(* Send comments and suggestions to ",      val commentsto = concat ["(* Send comments and suggestions to ",
70                               email, ". Thanks! *)"]                               email, ". Thanks! *)"]
71    
72        fun arg_id s = "a_" ^ s
73        fun su_id (K, tag) = concat [K, "_", tag]
74        fun isu_id (K, tag) = "I_" ^ su_id (K, tag)
75        fun Styp t = su_id ("S", t) ^ ".typ"
76        fun Utyp t = su_id ("U", t) ^ ".typ"
77        fun fptr_rtti_id n = "fptr_rtti_" ^ n
78        fun fieldtype_id n = "t_f_" ^ n
79        fun fieldrtti_id n = "typ_f_" ^ n
80        fun field_id (n, p) = concat ["f_", n, p]
81        fun typetype_id n = "typ_t_" ^ n
82        fun gvar_id n = "g_" ^ n
83        fun funrtti_id n = "typ_fn_" ^ n
84        fun fptr_id n = "fptr_fn_" ^ n
85        fun fun_id (n, p) = concat ["fn_", n, p]
86        fun enum_id n = "e_" ^ n
87        fun let_id c = "t_" ^ String.str c
88    
89      fun gen args = let      fun gen args = let
90    
91          val { idlfile, idlsource,          val { idlfile, idlsource,
# Line 76  Line 94 
94                allSU, lambdasplit,                allSU, lambdasplit,
95                wid,                wid,
96                weightreq,                weightreq,
97                  namedargs = doargnames,
98                target = { name = archos, sizes, shift, stdcall } } = args                target = { name = archos, sizes, shift, stdcall } } = args
99    
100          val (doheavy, dolight) =          val (doheavy, dolight) =
# Line 84  Line 103 
103                | SOME true => (true, false)                | SOME true => (true, false)
104                | SOME false => (false, true)                | SOME false => (false, true)
105    
         val doargnames = true           (* FIXME: customizable *)  
   
106          val credits = mkCredits (idlfile, archos)          val credits = mkCredits (idlfile, archos)
107    
108          val astbundle = ParseToAst.fileToAst'          val astbundle = ParseToAst.fileToAst'
# Line 186  Line 203 
203    
204          val cgtys = List.filter (not o isSome o incomplete o #spec) gtys          val cgtys = List.filter (not o isSome o incomplete o #spec) gtys
205    
         fun istruct (K, tag) = concat ["I_", K, "_", tag]  
   
206          fun rwro S.RW = Type "rw"          fun rwro S.RW = Type "rw"
207            | rwro S.RO = Type "ro"            | rwro S.RO = Type "ro"
208    
# Line 233  Line 248 
248            | wtn_ty_p p (S.PTR (c, t)) =            | wtn_ty_p p (S.PTR (c, t)) =
249              (case incomplete t of              (case incomplete t of
250                   SOME (K, tag) =>                   SOME (K, tag) =>
251                   Con (concat [istruct (K, tag), ".iptr", p], [rwro c])                   Con (concat [isu_id (K, tag), ".iptr", p], [rwro c])
252                 | NONE => Con ("ptr" ^ p, [wtn_ty t, rwro c]))                 | NONE => Con ("ptr" ^ p, [wtn_ty t, rwro c]))
253            | wtn_ty_p p (S.ARR { t, d, ... }) =            | wtn_ty_p p (S.ARR { t, d, ... }) =
254              Con ("arr", [wtn_ty t, dim_ty d])              Con ("arr", [wtn_ty t, dim_ty d])
# Line 263  Line 278 
278                    | SOME (S.STRUCT t) => let                    | SOME (S.STRUCT t) => let
279                          val ot = Suobj'rw p (St t)                          val ot = Suobj'rw p (St t)
280                      in                      in
281                          (ot, [ot], [writeto])(* hack -- check for nameclash *)                          (ot, [ot], [writeto])(* FIXME -- check for nameclash *)
282                      end                      end
283                    | SOME (S.UNION t) => let                    | SOME (S.UNION t) => let
284                          val ot = Suobj'rw p (Un t)                          val ot = Suobj'rw p (Un t)
285                      in                      in
286                          (ot, [ot], [writeto])(* hack *)                          (ot, [ot], [writeto])(* FIXME *)
287                      end                      end
288                    | SOME t => (topty t, [], [])                    | SOME t => (topty t, [], [])
289              val argtyl = map topty args              val argtyl = map topty args
290              val aggreg_argty =              val aggreg_argty =
291                  case (doargnames, argnames) of                  case (doargnames, argnames) of
292                      (true, SOME nl) =>                      (true, SOME nl) =>
293                      Record (ListPair.zip (extra_argname @ nl,                      Record (ListPair.zip (map arg_id (extra_argname @ nl),
294                                            extra_arg_t @ argtyl))                                            extra_arg_t @ argtyl))
295                    | _ => Tuple (extra_arg_t @ argtyl)                    | _ => Tuple (extra_arg_t @ argtyl)
296          in          in
# Line 304  Line 319 
319                                  S.SSHORT | S.USHORT | S.SLONG | S.ULONG |                                  S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
320                                  S.FLOAT | S.DOUBLE | S.VOIDPTR)) =                                  S.FLOAT | S.DOUBLE | S.VOIDPTR)) =
321                  simple (stem t)                  simple (stem t)
322                | rtti_val (S.STRUCT t) = EVar (concat ["S_", t, ".typ"])                | rtti_val (S.STRUCT t) = EVar (Styp t)
323                | rtti_val (S.UNION t) = EVar (concat ["U_", t, ".typ"])                | rtti_val (S.UNION t) = EVar (Utyp t)
324                | rtti_val (S.FPTR cft) =                | rtti_val (S.FPTR cft) =
325                  (case List.find (fn x => #1 x = cft) fptr_types of                  (case List.find (fn x => #1 x = cft) fptr_types of
326                       SOME (_, i) => EVar ("fptr_rtti_" ^ Int.toString i)                       SOME (_, i) => EVar (fptr_rtti_id (Int.toString i))
327                     | NONE => raise Fail "fptr type missing")                     | NONE => raise Fail "fptr type missing")
328                | rtti_val (S.PTR (S.RW, t)) =                | rtti_val (S.PTR (S.RW, t)) =
329                  (case incomplete t of                  (case incomplete t of
330                       SOME (K, tag) =>                       SOME (K, tag) => EVar (isu_id (K, tag) ^ ".typ'rw")
                      EVar (istruct (K, tag) ^ ".typ'rw")  
331                     | NONE => EApp (EVar "T.pointer", rtti_val t))                     | NONE => EApp (EVar "T.pointer", rtti_val t))
332                | rtti_val (S.PTR (S.RO, t)) =                | rtti_val (S.PTR (S.RO, t)) =
333                  (case incomplete t of                  (case incomplete t of
334                       SOME (K, tag) =>                       SOME (K, tag) => EVar (isu_id (K, tag) ^ ".typ'ro")
                      EVar (istruct (K, tag) ^ ".typ'ro")  
335                     | NONE => EApp (EVar "T.ro",                     | NONE => EApp (EVar "T.ro",
336                                     EApp (EVar "T.pointer", rtti_val t)))                                     EApp (EVar "T.pointer", rtti_val t)))
337                | rtti_val (S.ARR { t, d, ... }) =                | rtti_val (S.ARR { t, d, ... }) =
# Line 361  Line 374 
374                  fun pr_field_typ { name, spec = S.OFIELD { spec = (c, t),                  fun pr_field_typ { name, spec = S.OFIELD { spec = (c, t),
375                                                             synthetic = false,                                                             synthetic = false,
376                                                             offset } } =                                                             offset } } =
377                      pr_tdef ("t_f_" ^ name, wtn_ty t)                      pr_tdef (fieldtype_id name, wtn_ty t)
378                    | pr_field_typ _ = ()                    | pr_field_typ _ = ()
379    
380                  fun pr_field_rtti { name, spec = S.OFIELD { spec = (c, t),                  fun pr_field_rtti { name, spec = S.OFIELD { spec = (c, t),
381                                                              synthetic = false,                                                              synthetic = false,
382                                                              offset } } =                                                              offset } } =
383                      pr_vdecl ("typ_f_" ^ name, rtti_ty t)                      pr_vdecl (fieldrtti_id name, rtti_ty t)
384                    | pr_field_rtti _ = ()                    | pr_field_rtti _ = ()
385    
386                  fun pr_field_acc0 (name, p, t) =                  fun pr_field_acc0 (name, p, t) =
387                      pr_vdecl (concat ["f_", name, p],                      pr_vdecl (field_id (name, p),
388                                Arrow (Con ("su_obj" ^ p, [StUn tag, Type "'c"]),                                Arrow (Con ("su_obj" ^ p, [StUn tag, Type "'c"]),
389                                       t))                                       t))
390    
# Line 389  Line 402 
402                      pr_bf_acc (name, p, "u", #constness bf)                      pr_bf_acc (name, p, "u", #constness bf)
403              in              in
404                  nl ();                  nl ();
405                  nl (); str (concat ["structure ", K, "_", tag,                  nl (); str (concat ["structure ", su_id (K, tag),
406                                      " : sig (* ", su, " ", tag, " *)"]);                                      " : sig (* ", su, " ", tag, " *)"]);
407                  Box 4;                  Box 4;
408                  pr_tdef ("tag", StUn tag);                  pr_tdef ("tag", StUn tag);
# Line 416  Line 429 
429                       app (pr_field_acc "'") fields)                       app (pr_field_acc "'") fields)
430                  else ();                  else ();
431                  endBox ();                  endBox ();
432                  nl (); str (concat ["end (* structure ", K, "_", tag, " *)"])                  nl (); str (concat ["end (* structure ",
433                                        su_id (K, tag), " *)"])
434              end              end
435    
436              fun pr_struct_structure { tag, size, anon, fields } =              fun pr_struct_structure { tag, size, anon, fields } =
# Line 425  Line 439 
439                  pr_su_structure (Un, "U", "union", tag, all)                  pr_su_structure (Un, "U", "union", tag, all)
440    
441              fun pr_gty_rtti { name, spec } =              fun pr_gty_rtti { name, spec } =
442                  pr_vdecl ("typ_t_" ^ name, rtti_ty spec)                  pr_vdecl (typetype_id name, rtti_ty spec)
443    
444              fun pr_gvar_obj { name, spec = (c, t) } =              fun pr_gvar_obj { name, spec = (c, t) } =
445                  pr_vdecl ("g_" ^ name, Arrow (Unit, obj_ty "" (t, rwro c)))                  pr_vdecl (gvar_id name, Arrow (Unit, obj_ty "" (t, rwro c)))
446    
447              fun pr_gfun_rtti { name, spec, argnames } =              fun pr_gfun_rtti { name, spec, argnames } =
448                  pr_vdecl ("typ_fn_" ^ name, rtti_ty (S.FPTR spec))                  pr_vdecl (funrtti_id name, rtti_ty (S.FPTR spec))
449    
450              fun pr_gfun_fptr { name, spec, argnames } =              fun pr_gfun_fptr { name, spec, argnames } =
451                  pr_vdecl ("fptr_fn_" ^ name,                  pr_vdecl (fptr_id name,
452                            Arrow (Unit, wtn_ty (S.FPTR spec)))                            Arrow (Unit, wtn_ty (S.FPTR spec)))
453    
454              fun pr_gfun_func p { name, spec, argnames } =              fun pr_gfun_func p { name, spec, argnames } =
455                  pr_vdecl (concat ["fn_", name, p],                  pr_vdecl (fun_id (name, p),
456                            topfunc_ty p (spec, argnames))                            topfunc_ty p (spec, argnames))
457    
458              fun pr_isu (K, tag) =              fun pr_isu (K, tag) =
459                  (nl ();                  (nl ();
460                   str (concat ["structure ", istruct (K, tag),                   str (concat ["structure ", isu_id (K, tag),
461                                " : POINTER_TO_INCOMPLETE_TYPE"]))                                " : POINTER_TO_INCOMPLETE_TYPE"]))
462              fun pr_istruct tag = pr_isu ("S", tag)              fun pr_istruct tag = pr_isu ("S", tag)
463              fun pr_iunion tag = pr_isu ("U", tag)              fun pr_iunion tag = pr_isu ("U", tag)
464    
465              fun pr_enum_const { name, spec } = pr_vdecl ("e_" ^ name, sint_ty)              fun pr_enum_const { name, spec } = pr_vdecl (enum_id name, sint_ty)
466          in          in
467              (* Generating the signature file... *)              (* Generating the signature file... *)
468              str dontedit;              str dontedit;
# Line 526  Line 540 
540    
541              fun pr_su_tag (su, tag, false) =              fun pr_su_tag (su, tag, false) =
542                  let fun build [] = Type su                  let fun build [] = Type su
543                        | build (h :: tl) = Con ("t_" ^ String.str h, [build tl])                        | build (h :: tl) = Con (let_id h, [build tl])
544                  in                  in
545                      pr_tdef (concat [su, "_", tag],                      pr_tdef (su_id (su, tag), build (rev (String.explode tag)))
                              build (rev (String.explode tag)))  
546                  end                  end
547                | pr_su_tag (su, tag, true) =                | pr_su_tag (su, tag, true) =
548                  (nl (); str "local";                  (nl (); str "local";
# Line 539  Line 552 
552                   endBox ();                   endBox ();
553                   nl (); str "in";                   nl (); str "in";
554                   VBox 4;                   VBox 4;
555                   pr_tdef (concat [su, "_", tag],                   pr_tdef (su_id (su, tag), Type "X.t");
                           Type "X.t");  
556                   endBox ();                   endBox ();
557                   nl (); str "end")                   nl (); str "end")
558    
# Line 550  Line 562 
562                  pr_su_tag ("u", tag, anon)                  pr_su_tag ("u", tag, anon)
563    
564              fun pr_su_tag_copy (k, tag) = let              fun pr_su_tag_copy (k, tag) = let
565                  val tn = concat [k, "_", tag]                  val tn = su_id (k, tag)
566              in              in
567                  pr_tdef (tn, Type tn)                  pr_tdef (tn, Type tn)
568              end              end
# Line 655  Line 667 
667                  fun iwrap (K, tag, e) =                  fun iwrap (K, tag, e) =
668                      EApp (EVar "CMemory.wrap_addr",                      EApp (EVar "CMemory.wrap_addr",
669                            EApp (EVar "reveal",                            EApp (EVar "reveal",
670                                  EApp (EVar (istruct (K, tag) ^ ".inject'"),                                  EApp (EVar (isu_id (K, tag) ^ ".inject'"), e)))
                                       e)))  
671    
672                  fun suwrap e = pwrap (EApp (EVar "Ptr.|&!", e))                  fun suwrap e = pwrap (EApp (EVar "Ptr.|&!", e))
673    
# Line 703  Line 714 
714                                  EApp (EVar cast,                                  EApp (EVar cast,
715                                        EApp (EVar "CMemory.unwrap_addr", r))                                        EApp (EVar "CMemory.unwrap_addr", r))
716                              fun iunwrap (K, tag, t) r =                              fun iunwrap (K, tag, t) r =
717                                  EApp (EApp (EVar (istruct (K, tag) ^                                  EApp (EApp (EVar (isu_id (K, tag) ^ ".cast'"),
                                                   ".cast'"),  
718                                              rtti_val t),                                              rtti_val t),
719                                        punwrap "vcast" r)                                        punwrap "vcast" r)
720                              val res_wrap =                              val res_wrap =
# Line 737  Line 747 
747                  val arg_e = ETuple (extra_arg_e @ args_el)                  val arg_e = ETuple (extra_arg_e @ args_el)
748              in              in
749                  nl ();                  nl ();
750                  str (concat ["val ", "fptr_rtti_", Int.toString i, " = let"]);                  str (concat ["val ", fptr_rtti_id (Int.toString i), " = let"]);
751                  VBox 4;                  VBox 4;
752                  pr_vdef ("callop",                  pr_vdef ("callop",
753                            EConstr (EVar "RawMemInlineT.rawccall",                            EConstr (EVar "RawMemInlineT.rawccall",
# Line 767  Line 777 
777                  fun pr_field_typ { name, spec = S.OFIELD { spec = (c, t),                  fun pr_field_typ { name, spec = S.OFIELD { spec = (c, t),
778                                                             synthetic = false,                                                             synthetic = false,
779                                                             offset } } =                                                             offset } } =
780                      pr_tdef ("t_f_" ^ name, wtn_ty t)                      pr_tdef (fieldtype_id name, wtn_ty t)
781                    | pr_field_typ _ = ()                    | pr_field_typ _ = ()
782                  fun pr_field_rtti { name, spec = S.OFIELD { spec = (c, t),                  fun pr_field_rtti { name, spec = S.OFIELD { spec = (c, t),
783                                                             synthetic = false,                                                             synthetic = false,
784                                                             offset } } =                                                             offset } } =
785                      pr_vdef ("typ_f_" ^ name, rtti_val t)                      pr_vdef (fieldrtti_id name, rtti_val t)
786                    | pr_field_rtti _ = ()                    | pr_field_rtti _ = ()
787    
788                  fun pr_bf_acc (name, p, sign,                  fun pr_bf_acc (name, p, sign,
# Line 780  Line 790 
790                      let val maker =                      let val maker =
791                              concat ["mk_", rwro constness, "_", sign, "bf", p]                              concat ["mk_", rwro constness, "_", sign, "bf", p]
792                      in                      in
793                          pr_fdef (concat ["f_", name, p],                          pr_fdef (field_id (name, p),
794                                   [EVar "x"],                                   [EVar "x"],
795                                   EApp (EApp (EVar maker,                                   EApp (EApp (EVar maker,
796                                               ETuple [EInt offset,                                               ETuple [EInt offset,
# Line 793  Line 803 
803                      let val { synthetic, spec = (c, t), offset, ... } = x                      let val { synthetic, spec = (c, t), offset, ... } = x
804                      in                      in
805                          if synthetic then ()                          if synthetic then ()
806                          else pr_fdef (concat ["f_", name, "'"],                          else pr_fdef (field_id (name, "'"),
807                                        [EConstr (EVar "x",                                        [EConstr (EVar "x",
808                                                  Suobj''c (StUn tag))],                                                  Suobj''c (StUn tag))],
809                                        EConstr (EApp (EApp (EVar "mk_field'",                                        EConstr (EApp (EApp (EVar "mk_field'",
# Line 812  Line 822 
822                      if synthetic then ()                      if synthetic then ()
823                      else let                      else let
824                              val maker = concat ["mk_", rwro c, "_field"]                              val maker = concat ["mk_", rwro c, "_field"]
825                              val rttival = EVar ("typ_f_" ^ name)                              val rttival = EVar (fieldrtti_id name)
826                          in                          in
827                              pr_fdef ("f_" ^ name,                              pr_fdef (field_id (name, ""),
828                                       [EVar "x"],                                       [EVar "x"],
829                                       EApp (EApp (EApp (EVar maker, rttival),                                       EApp (EApp (EApp (EVar maker, rttival),
830                                                   EInt offset),                                                   EInt offset),
# Line 826  Line 836 
836                      pr_bf_acc (name, "", "u", bf)                      pr_bf_acc (name, "", "u", bf)
837              in              in
838                  nl ();                  nl ();
839                  str (concat ["structure ", K, "_", tag, " = struct"]);                  str (concat ["structure ", su_id (K, tag), " = struct"]);
840                  Box 4;                  Box 4;
841                  nl (); str (concat ["open ", K, "_", tag]);                  nl (); str ("open " ^ su_id (K, tag));
842                  app pr_field_typ fields;                  app pr_field_typ fields;
843                  app pr_field_rtti fields;                  app pr_field_rtti fields;
844                  if dolight then app pr_field_acc' fields else ();                  if dolight then app pr_field_acc' fields else ();
# Line 843  Line 853 
853                  pr_su_structure (Un, "u", "U", tag, size, all)                  pr_su_structure (Un, "u", "U", tag, size, all)
854    
855              fun pr_gty_rtti { name, spec } =              fun pr_gty_rtti { name, spec } =
856                  pr_vdef ("typ_t_" ^ name, rtti_val spec)                  pr_vdef (typetype_id name, rtti_val spec)
857    
858              fun pr_addr (prefix, name) =              fun pr_addr (prefix, name) =
859                  pr_vdef (prefix ^ name,                  pr_vdef (prefix ^ name,
# Line 858  Line 868 
868                  val obj = case c of S.RW => rwobj                  val obj = case c of S.RW => rwobj
869                                    | S.RO => EApp (EVar "ro", rwobj)                                    | S.RO => EApp (EVar "ro", rwobj)
870              in              in
871                  pr_fdef ("g_" ^ name, [ETuple []], obj)                  pr_fdef (gvar_id name, [ETuple []], obj)
872              end              end
873    
874              fun pr_gfun_rtti { name, spec, argnames } =              fun pr_gfun_rtti { name, spec, argnames } =
875                  pr_vdef ("typ_fn_" ^ name, rtti_val (S.FPTR spec))                  pr_vdef (funrtti_id name, rtti_val (S.FPTR spec))
876    
877              fun pr_gfun_addr { name, spec, argnames } = pr_addr ("fnh_", name)              fun pr_gfun_addr { name, spec, argnames } = pr_addr ("fnh_", name)
878    
879              fun pr_gfun_fptr { name, spec, argnames } =              fun pr_gfun_fptr { name, spec, argnames } =
880                  pr_fdef ("fptr_fn_" ^ name,                  pr_fdef (fptr_id name,
881                           [ETuple []],                           [ETuple []],
882                           EApp (EApp (EVar "mk_fptr", EVar ("typ_fn_" ^ name)),                           EApp (EApp (EVar "mk_fptr", EVar (funrtti_id name)),
883                                 EApp (EVar "D.addr", EVar ("fnh_" ^ name))))                                 EApp (EVar "D.addr", EVar ("fnh_" ^ name))))
884    
885              fun pr_gfun_func is_light x = let              fun pr_gfun_func is_light x = let
886                  val { name, spec = { args, res }, argnames } = x                  val { name, spec = { args, res }, argnames } = x
                 (* FIXME: use argnames! *)  
887                  val p = if is_light then "'" else ""                  val p = if is_light then "'" else ""
888                  val ml_vars =                  val ml_vars =
889                      rev (#1 (foldl (fn (_, (l, i)) =>                      rev (#1 (foldl (fn (_, (l, i)) =>
# Line 897  Line 906 
906                      EApp (EVar "ro'", light ("obj", e))                      EApp (EVar "ro'", light ("obj", e))
907                    | oneArg (e, S.PTR (_, t)) =                    | oneArg (e, S.PTR (_, t)) =
908                      (case incomplete t of                      (case incomplete t of
909                           SOME (K, tag) =>                           SOME (K, tag) => app0 (isu_id (K, tag) ^ ".light", e)
                          app0 (istruct (K, tag) ^ ".light", e)  
910                         | NONE => light ("ptr", e))                         | NONE => light ("ptr", e))
911                    | oneArg (e, S.FPTR _) = light ("fptr", e)                    | oneArg (e, S.FPTR _) = light ("fptr", e)
912                    | oneArg (e, S.VOIDPTR) = e                    | oneArg (e, S.VOIDPTR) = e
# Line 912  Line 920 
920                           [writeto])                           [writeto])
921                        | _ => (ml_vars, c_exps, [])                        | _ => (ml_vars, c_exps, [])
922                  val call = EApp (EVar "call",                  val call = EApp (EVar "call",
923                                   ETuple [EApp (EVar ("fptr_fn_" ^ name),                                   ETuple [EApp (EVar (fptr_id name),
924                                                 ETuple []),                                                 ETuple []),
925                                           ETuple c_exps])                                           ETuple c_exps])
926                  val ml_res =                  val ml_res =
# Line 926  Line 934 
934                        | SOME (S.PTR (_, t)) =>                        | SOME (S.PTR (_, t)) =>
935                          (case incomplete t of                          (case incomplete t of
936                               SOME (K, tag) =>                               SOME (K, tag) =>
937                               app0 (istruct (K, tag) ^ ".heavy", call)                               app0 (isu_id (K, tag) ^ ".heavy", call)
938                             | NONE => heavy ("ptr", t, call))                             | NONE => heavy ("ptr", t, call))
939                        | SOME (t as S.FPTR _) => heavy ("fptr", t, call)                        | SOME (t as S.FPTR _) => heavy ("fptr", t, call)
940                        | SOME (S.ARR _) => raise Fail "array result type"                        | SOME (S.ARR _) => raise Fail "array result type"
# Line 934  Line 942 
942                  val argspat =                  val argspat =
943                      case (doargnames, argnames) of                      case (doargnames, argnames) of
944                          (true, SOME nl) =>                          (true, SOME nl) =>
945                          ERecord (ListPair.zip (extra_argname @ nl, ml_vars))                          ERecord (ListPair.zip (map arg_id (extra_argname @ nl),
946                                                   ml_vars))
947                        | _ => ETuple ml_vars                        | _ => ETuple ml_vars
948              in              in
949                  pr_fdef (concat ["fn_", name, p], [argspat], ml_res)                  pr_fdef (fun_id (name, p), [argspat], ml_res)
950              end              end
951    
952              fun pr_isu_arg (K, tag) =              fun pr_isu_arg (K, tag) =
953                  (sp (); str (concat ["structure ", istruct (K, tag),                  (sp (); str (concat ["structure ", isu_id (K, tag),
954                                       " : POINTER_TO_INCOMPLETE_TYPE"]))                                       " : POINTER_TO_INCOMPLETE_TYPE"]))
955              fun pr_istruct_arg tag = pr_isu_arg ("S", tag)              fun pr_istruct_arg tag = pr_isu_arg ("S", tag)
956              fun pr_iunion_arg tag = pr_isu_arg ("U", tag)              fun pr_iunion_arg tag = pr_isu_arg ("U", tag)
957    
958              fun pr_isu_def (kw, K, tag) = let              fun pr_isu_def (kw, K, tag) = let
959                  val n = istruct (K, tag)                  val n = isu_id (K, tag)
960              in              in
961                  nl ();                  nl ();
962                  str (concat [kw, " ", n, " = ", n])                  str (concat [kw, " ", n, " = ", n])
# Line 958  Line 967 
967              fun pr_iunion_def tag = pr_isu_def ("structure", "U", tag)              fun pr_iunion_def tag = pr_isu_def ("structure", "U", tag)
968    
969              fun pr_pre_su (K, k, STUN, StUn, tag, size) =              fun pr_pre_su (K, k, STUN, StUn, tag, size) =
970                  (nl (); str (concat ["structure ", K, "_", tag, " = struct"]);                  (nl (); str (concat ["structure ",
971                                         su_id (K, tag), " = struct"]);
972                   VBox 4;                   VBox 4;
973                   pr_tdef ("tag", Type (concat [k, "_", tag]));                   pr_tdef ("tag", Type (su_id (k, tag)));
974                   pr_vdef ("size",                   pr_vdef ("size",
975                            EConstr (EApp (EVar "C_Int.mk_su_size", EWord size),                            EConstr (EApp (EVar "C_Int.mk_su_size", EWord size),
976                                     Con ("C.S.size",                                     Con ("C.S.size",
# Line 975  Line 985 
985                  pr_pre_su ("U", "u", S.UNION, Un, tag, size)                  pr_pre_su ("U", "u", S.UNION, Un, tag, size)
986    
987              fun pr_enum_const { name, spec } =              fun pr_enum_const { name, spec } =
988                  pr_vdef ("e_" ^ name, EConstr (ELInt spec, sint_ty))                  pr_vdef (enum_id name, EConstr (ELInt spec, sint_ty))
989          in          in
990              (* Generating the functor file... *)              (* Generating the functor file... *)
991              str dontedit;              str dontedit;

Legend:
Removed from v.976  
changed lines
  Added in v.977

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