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 1066, Thu Feb 14 16:50:02 2002 UTC revision 1067, Fri Feb 15 17:08:17 2002 UTC
# Line 19  Line 19 
19                  match: string -> bool,                  match: string -> bool,
20                  mkidlsource: string -> string,                  mkidlsource: string -> string,
21                  dirname: string,                  dirname: string,
22                    iptr_repository: (string * string) option,
23                  cmfile: string,                  cmfile: string,
24                  prefix: string,                  prefix: string,
25                  gensym_stem: string,                  gensym_stem: string,
# Line 109  Line 110 
110    
111      fun gen args = let      fun gen args = let
112          val { cfiles, match, mkidlsource, gensym_stem,          val { cfiles, match, mkidlsource, gensym_stem,
113                dirname, cmfile, prefix, extramembers, libraryhandle, complete,                dirname, iptr_repository,
114                  cmfile, prefix, extramembers, libraryhandle, complete,
115                allSU, lambdasplit,                allSU, lambdasplit,
116                wid,                wid,
117                weightreq,                weightreq,
# Line 119  Line 121 
121          val hash_cft = Hash.mkFHasher ()          val hash_cft = Hash.mkFHasher ()
122          val hash_mltype = Hash.mkTHasher ()          val hash_mltype = Hash.mkTHasher ()
123    
124          val (gensym_prefix, gensym_suffix) =          val (iptrdir, iptranchor) =
125              if gensym_stem = "" then ("", "")              case iptr_repository of
126              else (gensym_stem ^ "_", "_" ^ gensym_stem)                  NONE => (dirname, NONE)
127          val isu_prefix = if complete then gensym_prefix else ""                | SOME (d, a) => (d, SOME a)
128          fun isu_id (K, tag) = concat [isu_prefix, prefix, "I", K, "_", tag]  
129            val gensym_suffix = if gensym_stem = "" then "" else "_" ^ gensym_stem
130            fun isu_id (K, tag) = concat [prefix, "I", K, "_", tag]
131    
132          fun SUstruct K t = concat [prefix, K, "_", t]          fun SUstruct K t = concat [prefix, K, "_", t]
133          val Sstruct = SUstruct "S"          val Sstruct = SUstruct "S"
# Line 162  Line 166 
166    
167          val { structs, unions, gvars, gfuns, gtys, enums } = spec          val { structs, unions, gvars, gfuns, gtys, enums } = spec
168    
169          val do_dir = let          fun do_dir dir = let
170              val done = ref false              val done = ref false
171              fun doit () =              fun doit () =
172                  if !done then ()                  if !done then ()
173                  else (done := true;                  else (done := true;
174                        if OS.FileSys.isDir dirname handle _ => false then ()                        if OS.FileSys.isDir dir handle _ => false then ()
175                        else OS.FileSys.mkDir dirname)                        else OS.FileSys.mkDir dir)
176          in          in
177              doit              doit
178          end          end
179    
180            val do_main_dir = do_dir dirname
181            val do_iptr_dir = do_dir iptrdir
182    
183          val files = ref extramembers    (* all files that should go          val files = ref extramembers    (* all files that should go
184                                           * into the .cm description *)                                           * into the .cm description *)
185          val exports = ref []          val exports = ref []
186    
187            (* we don't want apostrophes in file names -> turn them into minuses *)
188            fun noquotes x = String.translate(fn #"'" => "-" | c => String.str c) x
189    
190          fun smlfile x = let          fun smlfile x = let
191              (* we don't want apostrophes in file names -> turn them into              val nqx = noquotes x
192               * minuses... *)              val file = OS.Path.joinBaseExt { base = nqx, ext = SOME "sml" }
             val x = String.translate (fn #"'" => "-" | c => String.str c) x  
             val file = OS.Path.joinBaseExt { base = x, ext = SOME "sml" }  
193              val result = OS.Path.joinDirFile { dir = dirname, file = file }              val result = OS.Path.joinDirFile { dir = dirname, file = file }
194          in          in
195              files := file :: !files;              files := file :: !files;
196              do_dir ();              do_main_dir ();
197              result              result
198          end          end
199    
200          fun descrfile file = let          fun descrfile file = let
201              val result = OS.Path.joinDirFile { dir = dirname, file = file }              val result = OS.Path.joinDirFile { dir = dirname, file = file }
202          in          in
203              do_dir ();              do_main_dir ();
204              result              result
205          end          end
206    
207            fun iptrdescrfile nqx = let
208                val file = OS.Path.joinBaseExt { base = nqx, ext = SOME "cm" }
209                val path = OS.Path.joinDirFile { dir = iptrdir, file = file }
210                val apath = case iptranchor of
211                                SOME a => concat [a, "/", file]
212                              | NONE => file
213            in
214                (path, apath)
215            end
216    
217            fun iptrfiles (x, report_only) = let
218                val nqx = noquotes x
219                val (d, da) = iptrdescrfile nqx
220                val f = OS.Path.joinBaseExt { base = nqx, ext = SOME "sml" }
221                val p = OS.Path.joinDirFile { dir = iptrdir, file = f }
222            in
223                if report_only then () else files := da :: !files;
224                do_iptr_dir ();
225                (f, p, d)
226            end
227    
228          val structs =          val structs =
229              foldl (fn (s, m) => SM.insert (m, #tag s, s)) SM.empty structs              foldl (fn (s, m) => SM.insert (m, #tag s, s)) SM.empty structs
230    
# Line 499  Line 528 
528                | NONE => raise Fail "missing fptr_type (mkcall)"                | NONE => raise Fail "missing fptr_type (mkcall)"
529          end          end
530    
531          fun openPP0 nocredits (f, src) = let          fun openPP (f, src) = let
532              val dst = TextIO.openOut f              val device = CPIFDev.openOut (f, wid)
533              val stream = PP.openStream (SimpleTextIODev.openDev              val stream = PP.openStream device
534                                              { dst = dst, wid = wid })  
535              fun nl () = PP.newline stream              fun nl () = PP.newline stream
536              fun str s = PP.string stream s              fun str s = PP.string stream s
537              fun sp () = PP.space stream 1              fun sp () = PP.space stream 1
# Line 527  Line 556 
556                   str connector; sp (); ppty t; endBox ())                   str connector; sp (); ppty t; endBox ())
557              val pr_tdef = pr_decl ("type", "=")              val pr_tdef = pr_decl ("type", "=")
558              val pr_vdecl = pr_decl ("val", ":")              val pr_vdecl = pr_decl ("val", ":")
559              fun closePP () = (PP.closeStream stream; TextIO.closeOut dst)              fun closePP () = (PP.closeStream stream; CPIFDev.closeOut device)
560          in          in
561              if nocredits then ()              str dontedit;
             else (str dontedit;  
562                    case src of                    case src of
563                        NONE => ()                        NONE => ()
564                      | SOME s =>                      | SOME s =>
565                        (nl (); str (concat ["(* [from code at ", s, "] *)"]));                        (nl (); str (concat ["(* [from code at ", s, "] *)"]));
566                    line credits;                    line credits;
567                    line commentsto;                    line commentsto;
568                    nl ());              nl ();
569              { stream = stream,              { stream = stream,
570                nl = nl, str = str, sp = sp, nsp = nsp, Box = Box, HVBox = HVBox,                nl = nl, str = str, sp = sp, nsp = nsp, Box = Box, HVBox = HVBox,
571                HBox = HBox, HOVBox = HOVBox, VBox = VBox, endBox = endBox,                HBox = HBox, HOVBox = HOVBox, VBox = VBox, endBox = endBox,
# Line 548  Line 576 
576                }                }
577          end          end
578    
         fun openPP x = openPP0 false x  
   
579          val get_callop = let          val get_callop = let
580              val ncallops = ref 0              val ncallops = ref 0
581              val callops = ref IM.empty              val callops = ref IM.empty
# Line 1118  Line 1144 
1144          end          end
1145    
1146          fun do_iptrs report_only = let          fun do_iptrs report_only = let
1147              val file = smlfile "iptrs"              fun pr_isu_def (K, k) tag = let
1148              val { closePP, str, nl, ... } = openPP0 report_only (file, NONE)                  val (sfile, spath, dpath) =
1149              fun pr_isu_def K tag = let                      iptrfiles (concat ["i", k, "-", tag], report_only)
1150                    val spp = openPP (spath, NONE)
1151                    val dpp = openPP (dpath, NONE)
1152                  val istruct = "structure " ^ isu_id (K, tag)                  val istruct = "structure " ^ isu_id (K, tag)
1153              in              in
1154                  if report_only then str "(* "                  #str spp (istruct ^ " = PointerToIncompleteType ()");
1155                  else exports := istruct :: !exports;                  #nl spp ();
1156                  str (istruct ^ " = PointerToIncompleteType ()");                  #closePP spp ();
1157                  if report_only then str " *)" else ();                  if report_only then () else exports := istruct :: !exports;
1158                  nl ()                  #str dpp "library";
1159                    #VBox dpp 4;
1160                    #line dpp istruct;
1161                    #endBox dpp ();
1162                    #nl dpp ();
1163                    #str dpp "is";
1164                    #VBox dpp 4;
1165                    app (#line dpp) ["$/c.cm", sfile];
1166                    #endBox dpp ();
1167                    #nl dpp ();
1168                    #closePP dpp ()
1169              end              end
1170          in          in
1171              SS.app (pr_isu_def "S") incomplete_structs;              SS.app (pr_isu_def ("S", "s")) incomplete_structs;
1172              SS.app (pr_isu_def "U") incomplete_unions;              SS.app (pr_isu_def ("U", "u")) incomplete_unions
             closePP ()  
1173          end          end
1174    
1175          fun do_cmfile () = let          fun do_cmfile () = let

Legend:
Removed from v.1066  
changed lines
  Added in v.1067

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