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 1077, Tue Feb 19 15:48:50 2002 UTC revision 1078, Tue Feb 19 21:26:48 2002 UTC
# Line 8  Line 8 
8   *)   *)
9  local  local
10      val program = "ml-nlffigen"      val program = "ml-nlffigen"
11      val version = "0.8"      val version = "0.9"
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 34  Line 34 
34                  namedargs: bool,                  namedargs: bool,
35                  target : { name  : string,                  target : { name  : string,
36                             sizes : Sizes.sizes,                             sizes : Sizes.sizes,
37                             shift : int * int * word -> word,                             shift : int * int * word -> word } } -> unit
                            stdcall : bool } } -> unit  
38      val version : string      val version : string
39  end = struct  end = struct
40    
# Line 116  Line 115 
115                wid,                wid,
116                weightreq,                weightreq,
117                namedargs = doargnames,                namedargs = doargnames,
118                target = { name = archos, sizes, shift, stdcall } } = args                target = { name = archos, sizes, shift } } = args
119    
120          val hash_cft = Hash.mkFHasher ()          val hash_cft = Hash.mkFHasher ()
121          val hash_mltype = Hash.mkTHasher ()          val hash_mltype = Hash.mkTHasher ()
# Line 127  Line 126 
126                | SOME (d, a) => (d, SOME a)                | SOME (d, a) => (d, SOME a)
127    
128          val gensym_suffix = if gensym_stem = "" then "" else "_" ^ gensym_stem          val gensym_suffix = if gensym_stem = "" then "" else "_" ^ gensym_stem
129          fun isu_id (K, tag) = concat [prefix, "I", K, "_", tag]          fun iobj_id (K, tag) = concat [prefix, "I", K, "_", tag]
130    
131          fun SUstruct K t = concat [prefix, K, "_", t]          fun SUstruct K t = concat [prefix, K, "_", t]
132          val Sstruct = SUstruct "S"          val Sstruct = SUstruct "S"
# Line 431  Line 430 
430            | wtn_ty_p p (S.PTR (c, t)) =            | wtn_ty_p p (S.PTR (c, t)) =
431              (case incomplete t of              (case incomplete t of
432                   SOME (K, tag) =>                   SOME (K, tag) =>
433                   Con (concat [isu_id (K, tag), ".iptr", p], [rwro c])                   Con ("ptr" ^ p,
434                 | NONE => Con ("ptr" ^ p, [wtn_ty t, rwro c]))                        [Con (concat [iobj_id (K, tag), ".iobj"],
435                                [rwro c])])
436                   | NONE => Con ("ptr" ^ p, [Con ("obj", [wtn_ty t, rwro c])]))
437            | wtn_ty_p p (S.ARR { t, d, ... }) =            | wtn_ty_p p (S.ARR { t, d, ... }) =
438              Con ("arr", [wtn_ty t, dim_ty d])              Con ("arr", [wtn_ty t, dim_ty d])
439            | wtn_ty_p p (S.FPTR spec) = wtn_fptr_p p spec            | wtn_ty_p p (S.FPTR spec) = wtn_fptr_p p spec
# Line 509  Line 510 
510                  end                  end
511                | rtti_val (S.PTR (S.RW, t)) =                | rtti_val (S.PTR (S.RW, t)) =
512                  (case incomplete t of                  (case incomplete t of
513                       SOME (K, tag) => EVar (isu_id (K, tag) ^ ".typ'rw")                       SOME (K, tag) => EVar (iobj_id (K, tag) ^ ".typ'rw")
514                     | NONE => EApp (EVar "T.pointer", rtti_val t))                     | NONE => EApp (EVar "T.pointer", rtti_val t))
515                | rtti_val (S.PTR (S.RO, t)) =                | rtti_val (S.PTR (S.RO, t)) =
516                  (case incomplete t of                  (case incomplete t of
517                       SOME (K, tag) => EVar (isu_id (K, tag) ^ ".typ'ro")                       SOME (K, tag) => EVar (iobj_id (K, tag) ^ ".typ'ro")
518                     | NONE => EApp (EVar "T.ro",                     | NONE => EApp (EVar "T.ro",
519                                     EApp (EVar "T.pointer", rtti_val t)))                                     EApp (EVar "T.pointer", rtti_val t)))
520                | rtti_val (S.ARR { t, d, ... }) =                | rtti_val (S.ARR { t, d, ... }) =
# Line 683  Line 684 
684    
685              val e_arg = Tuple (Unit :: map encode args)              val e_arg = Tuple (Unit :: map encode args)
686              val e_res = case res of NONE => Unit | SOME t => encode t              val e_res = case res of NONE => Unit | SOME t => encode t
687              val e_proto0 = Con ("list", [Arrow (e_arg, e_res)])              val e_proto = Con ("list", [Arrow (e_arg, e_res)])
             val e_proto =  
                 if stdcall then Con ("list", [e_proto0]) else e_proto0  
688    
689              (* generating the call operation *)              (* generating the call operation *)
690    
# Line 710  Line 709 
709              fun pwrap e = EApp (EVar "CMemory.wrap_addr",              fun pwrap e = EApp (EVar "CMemory.wrap_addr",
710                                  EApp (EVar "reveal",                                  EApp (EVar "reveal",
711                                        EApp (EVar "Ptr.inject'", e)))                                        EApp (EVar "Ptr.inject'", e)))
             fun iwrap (K, tag, e) =  
                 EApp (EVar "CMemory.wrap_addr",  
                       EApp (EVar "reveal",  
                             EApp (EVar (isu_id (K, tag) ^ ".inject'"), e)))  
712    
713              fun suwrap e = pwrap (EApp (EVar "Ptr.|&!", e))              fun suwrap e = pwrap (EApp (EVar "Ptr.|&!", e))
714    
# Line 733  Line 728 
728                           S.SSHORT | S.USHORT | S.SLONG | S.ULONG |                           S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
729                           S.FLOAT | S.DOUBLE) => sel (wrap (p, stem h))                           S.FLOAT | S.DOUBLE) => sel (wrap (p, stem h))
730                        | S.VOIDPTR => sel (vwrap p)                        | S.VOIDPTR => sel (vwrap p)
731                        | S.PTR (_, t) =>                        | S.PTR _ => sel (pwrap p)
                         (case incomplete t of  
                              SOME (K, tag) => sel (iwrap (K, tag, p))  
                            | NONE => sel (pwrap p))  
732                        | S.FPTR _ => sel (fwrap p)                        | S.FPTR _ => sel (fwrap p)
733                        | S.ARR _ => raise Fail "unexpected array argument"                        | S.ARR _ => raise Fail "unexpected array argument"
734                  end                  end
# Line 759  Line 751 
751                          fun punwrap cast r =                          fun punwrap cast r =
752                              EApp (EVar cast,                              EApp (EVar cast,
753                                    EApp (EVar "CMemory.unwrap_addr", r))                                    EApp (EVar "CMemory.unwrap_addr", r))
                         fun iunwrap (K, tag, t) r =  
                             EApp (EApp (EVar (isu_id (K, tag) ^ ".cast'"),  
                                         rtti_val t),  
                                   punwrap "vcast" r)  
754                          val res_wrap =                          val res_wrap =
755                              case t of                              case t of
756                                  (S.SCHAR | S.UCHAR | S.SINT | S.UINT |                                  (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
# Line 770  Line 758 
758                                   S.FLOAT | S.DOUBLE) => unwrap (stem t)                                   S.FLOAT | S.DOUBLE) => unwrap (stem t)
759                                | S.VOIDPTR => punwrap "vcast"                                | S.VOIDPTR => punwrap "vcast"
760                                | S.FPTR _ => punwrap "fcast"                                | S.FPTR _ => punwrap "fcast"
761                                | t0 as S.PTR (_, t) =>                                | S.PTR _ => punwrap "pcast"
                                 (case incomplete t of  
                                      SOME (K, tag) => iunwrap (K, tag, t0)  
                                    | NONE => punwrap "pcast")  
762                                | (S.STRUCT _ | S.UNION _ | S.ARR _) =>                                | (S.STRUCT _ | S.UNION _ | S.ARR _) =>
763                                  raise Fail "unexpected result type"                                  raise Fail "unexpected result type"
764                      in                      in
# Line 1047  Line 1032 
1032                      EApp (EVar ("Cvt.c_" ^ stem t), e)                      EApp (EVar ("Cvt.c_" ^ stem t), e)
1033                    | oneArg (e, (S.STRUCT _ | S.UNION _)) =                    | oneArg (e, (S.STRUCT _ | S.UNION _)) =
1034                      EApp (EVar "ro'", light ("obj", e))                      EApp (EVar "ro'", light ("obj", e))
1035                    | oneArg (e, S.PTR (_, t)) =                    | oneArg (e, S.PTR _) = light ("ptr", e)
                     (case incomplete t of  
                          SOME (K, tag) => app0 (isu_id (K, tag) ^ ".light", e)  
                        | NONE => light ("ptr", e))  
1036                    | oneArg (e, S.FPTR _) = light ("fptr", e)                    | oneArg (e, S.FPTR _) = light ("fptr", e)
1037                    | oneArg (e, S.VOIDPTR) = e                    | oneArg (e, S.VOIDPTR) = e
1038                    | oneArg (e, S.ARR _) = raise Fail "array argument type"                    | oneArg (e, S.ARR _) = raise Fail "array argument type"
# Line 1073  Line 1055 
1055                          EApp (EVar ("Cvt.ml_" ^ stem t), call)                          EApp (EVar ("Cvt.ml_" ^ stem t), call)
1056                        | SOME (t as (S.STRUCT _ | S.UNION _)) =>                        | SOME (t as (S.STRUCT _ | S.UNION _)) =>
1057                          heavy ("obj", t, call)                          heavy ("obj", t, call)
1058                        | SOME (S.PTR (_, t)) =>                        | SOME (t as S.PTR _) => heavy ("ptr", t, call)
                         (case incomplete t of  
                              SOME (K, tag) =>  
                              app0 (isu_id (K, tag) ^ ".heavy", call)  
                            | NONE => heavy ("ptr", t, call))  
1059                        | SOME (t as S.FPTR _) => heavy ("fptr", t, call)                        | SOME (t as S.FPTR _) => heavy ("fptr", t, call)
1060                        | SOME (S.ARR _) => raise Fail "array result type"                        | SOME (S.ARR _) => raise Fail "array result type"
1061                        | (NONE | SOME S.VOIDPTR) => call                        | (NONE | SOME S.VOIDPTR) => call
# Line 1144  Line 1122 
1122          end          end
1123    
1124          fun do_iptrs report_only = let          fun do_iptrs report_only = let
1125              fun pr_isu_def (K, k) tag = let              fun pr_iobj_def (K, k) tag = let
1126                  val (sfile, spath, dpath) =                  val (sfile, spath, dpath) =
1127                      iptrfiles (concat ["i", k, "-", tag], report_only)                      iptrfiles (concat ["i", k, "-", tag], report_only)
1128                  val spp = openPP (spath, NONE)                  val spp = openPP (spath, NONE)
1129                  val dpp = openPP (dpath, NONE)                  val dpp = openPP (dpath, NONE)
1130                  val istruct = "structure " ^ isu_id (K, tag)                  val istruct = "structure " ^ iobj_id (K, tag)
1131              in              in
1132                  #str spp (istruct ^ " = PointerToIncompleteType ()");                  #str spp (istruct ^ " = PointerToIncompleteType ()");
1133                  #nl spp ();                  #nl spp ();
# Line 1162  Line 1140 
1140                  #nl dpp ();                  #nl dpp ();
1141                  #str dpp "is";                  #str dpp "is";
1142                  #VBox dpp 4;                  #VBox dpp 4;
1143                  app (#line dpp) ["$/c.cm", sfile];                  app (#line dpp) ["$c/c.cm", sfile];
1144                  #endBox dpp ();                  #endBox dpp ();
1145                  #nl dpp ();                  #nl dpp ();
1146                  #closePP dpp ()                  #closePP dpp ()
1147              end              end
1148          in          in
1149              SS.app (pr_isu_def ("S", "s")) incomplete_structs;              SS.app (pr_iobj_def ("S", "s")) incomplete_structs;
1150              SS.app (pr_isu_def ("U", "u")) incomplete_unions              SS.app (pr_iobj_def ("U", "u")) incomplete_unions
1151          end          end
1152    
1153          fun do_cmfile () = let          fun do_cmfile () = let
# Line 1184  Line 1162 
1162              endBox ();              endBox ();
1163              nl (); str "is";              nl (); str "is";
1164              VBox 4;              VBox 4;
1165              app line ["$/basis.cm", "$/c-int.cm", "$smlnj/init/init.cmi : cm"];              app line ["$/basis.cm",
1166                          "$c/internals/c-int.cm",
1167                          "$smlnj/init/init.cmi : cm"];
1168              app line (!files);              app line (!files);
1169              endBox ();              endBox ();
1170              nl ();              nl ();

Legend:
Removed from v.1077  
changed lines
  Added in v.1078

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