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 836, Fri May 25 19:28:51 2001 UTC revision 837, Fri Jun 1 17:27:54 2001 UTC
# Line 8  Line 8 
8   *)   *)
9  local  local
10      val program = "ml-ffigen"      val program = "ml-ffigen"
11      val version = "0.1"      val version = "0.2"
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 167  Line 167 
167          fun Suobj'ro sut = Con ("su_obj'", [sut, Type "ro"])          fun Suobj'ro sut = Con ("su_obj'", [sut, Type "ro"])
168          fun Suobj''c sut = Con ("su_obj'", [sut, Type "'c"])          fun Suobj''c sut = Con ("su_obj'", [sut, Type "'c"])
169    
170          fun wtn_f_fptr_p p { args, res } = let          fun wtn_fptr_p p { args, res } = let
171              fun topty (S.STRUCT t) = Suobj'ro (St t)              fun topty (S.STRUCT t) = Suobj'ro (St t)
172                | topty (S.UNION t) = Suobj'ro (Un t)                | topty (S.UNION t) = Suobj'ro (Un t)
173                | topty t = wtn_ty' t                | topty t = wtn_ty' t
# Line 189  Line 189 
189              val dom_t = Tuple arg_tl              val dom_t = Tuple arg_tl
190              val fct_t = Arrow (dom_t, res_t)              val fct_t = Arrow (dom_t, res_t)
191          in          in
192              (Con ("fptr" ^ p, [fct_t]), fct_t)              Con ("fptr" ^ p, [fct_t])
193          end          end
194    
195          and wtn_f_ty_p p (t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |          and wtn_ty_p p (t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
196                                  S.SSHORT | S.USHORT | S.SLONG | S.ULONG |                                  S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
197                                  S.FLOAT | S.DOUBLE | S.VOIDPTR)) =                                  S.FLOAT | S.DOUBLE | S.VOIDPTR)) =
198              (Type (stem t), Unit)              Type (stem t)
199            | wtn_f_ty_p p (S.STRUCT t) = (Con ("su", [St t]), Unit)            | wtn_ty_p p (S.STRUCT t) = Con ("su", [St t])
200            | wtn_f_ty_p p (S.UNION t) = (Con ("su", [Un t]), Unit)            | wtn_ty_p p (S.UNION t) = Con ("su", [Un t])
201            | wtn_f_ty_p p (S.PTR (c, t)) =            | wtn_ty_p p (S.PTR (c, t)) =
202              (case incomplete t of              (case incomplete t of
203                   SOME (K, tag) =>                   SOME (K, tag) =>
204                   (Con (concat [istruct (K, tag), ".iptr", p], [rwro c]), Unit)                   Con (concat [istruct (K, tag), ".iptr", p], [rwro c])
205                 | NONE => let                 | NONE => Con ("ptr" ^ p, [wtn_ty t, rwro c]))
206                       val (w, f) = wtn_f_ty t            | wtn_ty_p p (S.ARR { t, d, ... }) =
207                   in              Con ("arr", [wtn_ty t, dim_ty d])
208                       (Con ("ptr" ^ p, [w, f, rwro c]), f)            | wtn_ty_p p (S.FPTR spec) = wtn_fptr_p p spec
                  end)  
           | wtn_f_ty_p p (S.ARR { t, d, ... }) = let  
                 val (w, f) = wtn_f_ty t  
             in  
                 (Con ("arr", [w, dim_ty d]), f)  
             end  
           | wtn_f_ty_p p (S.FPTR spec) = wtn_f_fptr_p p spec  
209    
210          and wtn_f_ty t = wtn_f_ty_p "" t          and wtn_ty t = wtn_ty_p "" t
211    
212          and wtn_ty t = #1 (wtn_f_ty t)          and wtn_ty' t = wtn_ty_p "'" t
   
         and wtn_ty' t = #1 (wtn_f_ty_p "'" t)  
213    
214          fun topfunc_ty p { args, res } = let          fun topfunc_ty p { args, res } = let
215              fun topty S.SCHAR = Type "MLRep.SChar.int"              fun topty S.SCHAR = Type "MLRep.SChar.int"
# Line 233  Line 224 
224                | topty S.DOUBLE = Type "MLRep.Double.real"                | topty S.DOUBLE = Type "MLRep.Double.real"
225                | topty (S.STRUCT t) = Con ("su_obj" ^ p, [St t, Type "'c"])                | topty (S.STRUCT t) = Con ("su_obj" ^ p, [St t, Type "'c"])
226                | topty (S.UNION t) = Con ("su_obj" ^ p, [Un t, Type "'c"])                | topty (S.UNION t) = Con ("su_obj" ^ p, [Un t, Type "'c"])
227                | topty t = #1 (wtn_f_ty_p p t)                | topty t = wtn_ty_p p t
228              val (res_t, extra_arg_t) =              val (res_t, extra_arg_t) =
229                  case res of                  case res of
230                      NONE => (Unit, [])                      NONE => (Unit, [])
# Line 252  Line 243 
243              Arrow (Tuple (extra_arg_t @ map topty args), res_t)              Arrow (Tuple (extra_arg_t @ map topty args), res_t)
244          end          end
245    
246          fun  rti_ty t = let          fun  rti_ty t = Con ("T.typ", [wtn_ty t])
             val (w, f) = wtn_f_ty t  
         in  
             Con ("T.typ", [w, f])  
         end  
247    
248          fun  obj_ty p (t, c) = let          fun  obj_ty p (t, c) = Con ("obj" ^ p, [wtn_ty t, c])
             val (w, f) = wtn_f_ty t  
         in  
             Con ("obj" ^ p, [w, f, c])  
         end  
249    
250          fun cro S.RW = Type "'c"          fun cro S.RW = Type "'c"
251            | cro S.RO = Type "ro"            | cro S.RO = Type "ro"
# Line 376  Line 359 
359                  pr_vdecl ("size", Con ("S.size", [Con ("su", [StUn tag])]));                  pr_vdecl ("size", Con ("S.size", [Con ("su", [StUn tag])]));
360                  nl ();                  nl ();
361                  nl (); str (concat ["(* RTI for this ", su, " *)"]);                  nl (); str (concat ["(* RTI for this ", su, " *)"]);
362                  pr_vdecl ("typ", Con ("T.su_typ", [StUn tag]));                  pr_vdecl ("typ", Con ("T.typ", [Con ("su", [StUn tag])]));
363                  nl ();                  nl ();
364                  nl (); str "(* witness types for fields *)";                  nl (); str "(* witness types for fields *)";
365                  app pr_field_typ fields;                  app pr_field_typ fields;
# Line 598  Line 581 
581    
582                  (* low-level type used to communicate a value to the                  (* low-level type used to communicate a value to the
583                   * low-level call operation *)                   * low-level call operation *)
584                  fun mlty S.SCHAR = Type "CMemory.cc_schar"                  fun mlty (t as (S.SCHAR | S.UCHAR | S.SINT | S.UINT |
585                    | mlty S.UCHAR = Type "CMemory.cc_uchar"                                  S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
586                    | mlty S.SINT = Type "CMemory.cc_sint"                                  S.FLOAT | S.DOUBLE)) =
587                    | mlty S.UINT = Type "CMemory.cc_uint"                      Type ("CMemory.cc_" ^ stem t)
                   | mlty S.SSHORT = Type "CMemory.cc_sshort"  
                   | mlty S.USHORT = Type "CMemory.cc_ushort"  
                   | mlty S.SLONG = Type "CMemory.cc_slong"  
                   | mlty S.ULONG = Type "CMemory.cc_ulong"  
                   | mlty S.FLOAT = Type "CMemory.cc_float"  
                   | mlty S.DOUBLE = Type "CMemory.cc_double"  
588                    | mlty (S.VOIDPTR | S.PTR _ | S.FPTR _ |                    | mlty (S.VOIDPTR | S.PTR _ | S.FPTR _ |
589                            S.STRUCT _) = Type "CMemory.cc_addr"                            S.STRUCT _) = Type "CMemory.cc_addr"
590                    | mlty (S.ARR _ | S.UNION _) = raise Fail "unexpected type"                    | mlty (S.ARR _ | S.UNION _) = raise Fail "unexpected type"
# Line 675  Line 652 
652                                        EApp (EVar "CMemory.unwrap_addr", r))                                        EApp (EVar "CMemory.unwrap_addr", r))
653                              fun iunwrap (K, tag, t) r =                              fun iunwrap (K, tag, t) r =
654                                  EApp (EApp (EVar (istruct (K, tag) ^                                  EApp (EApp (EVar (istruct (K, tag) ^
655                                                    ".project'"),                                                    ".cast'"),
656                                              rti_val t),                                              rti_val t),
657                                        punwrap "vcast" r)                                        punwrap "vcast" r)
658                              val res_wrap =                              val res_wrap =

Legend:
Removed from v.836  
changed lines
  Added in v.837

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