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 1547, Wed Jul 14 19:40:35 2004 UTC revision 1548, Wed Jul 14 21:25:43 2004 UTC
# Line 1  Line 1 
1  (*  (*
2   * gen-new.sml - Generating and pretty-printing ML code implementing a   * gen.sml - Generating and pretty-printing ML code implementing a
3   *               typed interface to a C program.   *               typed interface to a C program.
4   *   *
5   *  (C) 2001, Lucent Technologies, Bell Labs   *  (C) 2004  The Fellowship of SML/NJ
6   *   *
7   * author: Matthias Blume (blume@research.bell-labs.com)   * author: Matthias Blume (blume@tti-c.org)
8   *)   *)
9  local  local
10      val program = "ml-nlffigen"      val program = "ml-nlffigen"
11      val version = "0.9"      val version = "0.9.1"
12      val author = "Matthias Blume"      val author = "Matthias Blume"
13      val email = "blume@research.bell-labs.com"      val email = "blume@tti-c.org"
14      structure S = Spec      structure S = Spec
15  in  in
16    
# Line 255  Line 255 
255                          | NONE => ())                          | NONE => ())
256    
257              val senter = xenter (sdone, structs, smap, #fields)              val senter = xenter (sdone, structs, smap, #fields)
258              val uenter = xenter (udone, unions, umap,              val uenter = xenter (udone, unions, umap, #all)
                                  fn u => (#largest u :: #all u))  
259              val eenter = xenter (edone, enums, emap, fn _ => [])              val eenter = xenter (edone, enums, emap, fn _ => [])
260    
261              fun sinclude (s: S.s) = if #exclude s then () else senter (#tag s)              fun sinclude (s: S.s) = if #exclude s then () else senter (#tag s)
# Line 357  Line 356 
356              fun f ({ name, spec }, a) = fs (spec, a)              fun f ({ name, spec }, a) = fs (spec, a)
357              fun s ({ src, tag, size, anon, fields, exclude }, a) =              fun s ({ src, tag, size, anon, fields, exclude }, a) =
358                  foldl f a fields                  foldl f a fields
359              fun u ({ src, tag, size, anon, largest, all, exclude }, a) =              fun u ({ src, tag, size, anon, all, exclude }, a) =
360                  foldl f a (largest :: all)                  foldl f a all
361              fun gty ({ src, name, spec }, a) = ty (spec, a)              fun gty ({ src, name, spec }, a) = ty (spec, a)
362              fun gvar ({ src, name, spec = (_, t) }, a) = ty (t, a)              fun gvar ({ src, name, spec = (_, t) }, a) = ty (t, a)
363              fun gfun ({ src, name, spec, argnames }, a) = ty (S.FPTR spec, a)              fun gfun ({ src, name, spec, argnames }, a) = ty (S.FPTR spec, a)
# Line 664  Line 663 
663                | encode (S.ARR _) = raise Fail "unexpected array"                | encode (S.ARR _) = raise Fail "unexpected array"
664                | encode (S.ENUM _) = E_sint                | encode (S.ENUM _) = E_sint
665                | encode (S.STRUCT t) =                | encode (S.STRUCT t) =
666                  encode_fields (#fields (valOf ($? (structs, t))))                    encode_fields Unit (#fields (valOf ($? (structs, t))))
667                | encode (S.UNION t) =                | encode (S.UNION t) =
668                  encode_fields [#largest (valOf ($? (unions, t)))]                    encode_fields E_sint (#all (valOf ($? (unions, t))))
669    
670              and encode_fields fields = let              and encode_fields dummy fields = let
671                  fun f0 (S.ARR { t, d = 0, ... }, a) = a                  fun f0 (S.ARR { t, d = 0, ... }, a) = a
672                    | f0 (S.ARR { t, d = 1, ... }, a) = f0 (t, a)                    | f0 (S.ARR { t, d = 1, ... }, a) = f0 (t, a)
673                    | f0 (S.ARR { t, d, esz }, a) =                    | f0 (S.ARR { t, d, esz }, a) =
# Line 681  Line 680 
680              in              in
681                  case fel of                  case fel of
682                      [] => E_nullstruct                      [] => E_nullstruct
683                    | fel => Tuple (Unit :: fel)                    | fel => Tuple (dummy :: fel)
684              end              end
685    
686              val e_arg = Tuple (Unit :: map encode args)              val e_arg = Tuple (Unit :: map encode args)
# Line 696  Line 695 
695                              S.SSHORT | S.USHORT | S.SLONG | S.ULONG |                              S.SSHORT | S.USHORT | S.SLONG | S.ULONG |
696                              S.FLOAT | S.DOUBLE)) =                              S.FLOAT | S.DOUBLE)) =
697                  Type ("CMemory.cc_" ^ stem t)                  Type ("CMemory.cc_" ^ stem t)
698                | mlty (S.VOIDPTR | S.PTR _ | S.FPTR _ | S.STRUCT _) =                | mlty (S.VOIDPTR | S.PTR _ | S.FPTR _ | S.STRUCT _ | S.UNION _) =
699                  Type "CMemory.cc_addr"                  Type "CMemory.cc_addr"
700                | mlty (S.ENUM _) = Type "CMemory.cc_sint"                | mlty (S.ENUM _) = Type "CMemory.cc_sint"
701                | mlty (S.UNIMPLEMENTED what) = unimp what                | mlty (S.UNIMPLEMENTED what) = unimp what
702                | mlty (S.ARR _ | S.UNION _) = raise Fail "unexpected type"                | mlty (S.ARR _) = raise Fail "unexpected type"
703    
704              fun wrap (e, n) =              fun wrap (e, n) =
705                  EApp (EVar ("CMemory.wrap_" ^ n),                  EApp (EVar ("CMemory.wrap_" ^ n),
# Line 867  Line 866 
866    
867          fun pr_st_structure { src, tag, anon, size, fields, exclude } =          fun pr_st_structure { src, tag, anon, size, fields, exclude } =
868              pr_sue_t_structure (SOME src, tag, anon, T_SU size, "s", "S")              pr_sue_t_structure (SOME src, tag, anon, T_SU size, "s", "S")
869          fun pr_ut_structure { src, tag, anon, size, largest, all, exclude } =          fun pr_ut_structure { src, tag, anon, size, all, exclude } =
870              pr_sue_t_structure (SOME src, tag, anon, T_SU size, "u", "U")              pr_sue_t_structure (SOME src, tag, anon, T_SU size, "u", "U")
871          fun pr_et_structure { src, tag, anon, descr, spec, exclude } =          fun pr_et_structure { src, tag, anon, descr, spec, exclude } =
872              pr_sue_t_structure (SOME src, tag, anon, T_E, "e", "E")              pr_sue_t_structure (SOME src, tag, anon, T_E, "e", "E")
# Line 984  Line 983 
983    
984          fun pr_s_structure { src, tag, anon, size, fields, exclude } =          fun pr_s_structure { src, tag, anon, size, fields, exclude } =
985              pr_su_structure (src, tag, fields, "s", "S")              pr_su_structure (src, tag, fields, "s", "S")
986          fun pr_u_structure { src, tag, anon, size, largest, all, exclude } =          fun pr_u_structure { src, tag, anon, size, all, exclude } =
987              pr_su_structure (src, tag, all, "u", "U")              pr_su_structure (src, tag, all, "u", "U")
988    
989          fun pr_e_structure { src, tag, anon, descr, spec, exclude } = let          fun pr_e_structure { src, tag, anon, descr, spec, exclude } = let

Legend:
Removed from v.1547  
changed lines
  Added in v.1548

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