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/cm/paths/srcpath.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/paths/srcpath.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 758, Fri Dec 22 04:12:36 2000 UTC revision 759, Fri Dec 22 12:29:26 2000 UTC
# Line 138  Line 138 
138       * and removing arcs at the end easier. *)       * and removing arcs at the end easier. *)
139      type prepath = { revarcs: string list, vol: string, isAbs: bool }      type prepath = { revarcs: string list, vol: string, isAbs: bool }
140    
141      type elab = { pp: prepath, valid: unit -> bool }      type elab = { pp: prepath,
142                      valid: unit -> bool,
143                      reanchor: (anchor -> string) -> prepath option }
144    
145      type anchorval = unit -> elab      type anchorval = unit -> elab
146    
# Line 148  Line 150 
150             is_set: anchor -> bool,             is_set: anchor -> bool,
151             reset: unit -> unit,             reset: unit -> unit,
152             bound: anchorval StringMap.map }             bound: anchorval StringMap.map }
153    
154      datatype dir =      datatype dir =
155          CWD of { name: string, pp: prepath }          CWD of { name: string, pp: prepath }
156        | ANCHOR of { name: anchor, look: unit -> elab }        | ANCHOR of { name: anchor, look: unit -> elab }
# Line 177  Line 180 
180      fun compare (f1: file, f2: file) = Int.compare (#2 f1, #2 f2)      fun compare (f1: file, f2: file) = Int.compare (#2 f1, #2 f2)
181    
182      val null_pp : prepath = { revarcs = [], vol = "", isAbs = false }      val null_pp : prepath = { revarcs = [], vol = "", isAbs = false }
183      val bogus_elab : elab = { pp = null_pp, valid = fn _ => false }      val bogus_elab : elab =
184            { pp = null_pp, valid = fn _ => false, reanchor = fn _ => NONE }
185    
186      fun string2pp n = let      fun string2pp n = let
187          val { arcs, vol, isAbs } = P.fromString n          val { arcs, vol, isAbs } = P.fromString n
# Line 193  Line 197 
197    
198      fun absElab (arcs, vol) =      fun absElab (arcs, vol) =
199          { pp = { revarcs = rev arcs, vol = vol, isAbs = true },          { pp = { revarcs = rev arcs, vol = vol, isAbs = true },
200            valid = fn () => true }            valid = fn () => true, reanchor = fn _ => NONE }
201    
202      fun unintern (f: file) = #1 f      fun unintern (f: file) = #1 f
203    
# Line 273  Line 277 
277          { revarcs = revarcs, vol = vol, isAbs = isAbs }          { revarcs = revarcs, vol = vol, isAbs = isAbs }
278        | dirPP _ = impossible "dirPP"        | dirPP _ = impossible "dirPP"
279    
280      fun dirElab { pp, valid } = { pp = dirPP pp, valid = valid }      fun dirElab { pp, valid, reanchor } =
281            { pp = dirPP pp, valid = valid,
282              reanchor = Option.map dirPP o reanchor }
283    
284      fun augPP arcs { revarcs, vol, isAbs } =      fun augPP arcs { revarcs, vol, isAbs } =
285          { revarcs = List.revAppend (arcs, revarcs), vol = vol, isAbs = isAbs }          { revarcs = List.revAppend (arcs, revarcs), vol = vol, isAbs = isAbs }
286    
287      fun augElab arcs { pp, valid } = { pp = augPP arcs pp, valid = valid }      fun augElab arcs { pp, valid, reanchor } =
288            { pp = augPP arcs pp, valid = valid,
289              reanchor = Option.map (augPP arcs) o reanchor }
290    
291      fun elab_dir (CWD { name, pp }) =      fun elab_dir (CWD { name, pp }) =
292          let fun valid () = name = #name (!cwd_info)          let fun valid () = name = #name (!cwd_info)
293                fun reanchor (a: anchor -> string) = NONE
294          in          in
295              if valid () then { pp = null_pp, valid = valid }              if valid () then { pp = null_pp, valid = valid,
296              else { pp = pp, valid = fn () => true }                                 reanchor = reanchor }
297                else { pp = pp, valid = fn () => true, reanchor = reanchor }
298          end          end
299        | elab_dir (ANCHOR { name, look }) = look ()        | elab_dir (ANCHOR { name, look }) = look ()
300        | elab_dir (ROOT vol) = absElab ([], vol)        | elab_dir (ROOT vol) = absElab ([], vol)
301        | elab_dir (DIR p) = dirElab (elab_file p)        | elab_dir (DIR p) = dirElab (elab_file p)
302    
303      and elab_file (PATH { context, arcs, elab, id }) =      and elab_file (PATH { context, arcs, elab, id }) =
304          let val e as { pp, valid } = !elab          let val e as { pp, valid, reanchor } = !elab
305          in          in
306              if valid () then e              if valid () then e
307              else let val e' = augElab arcs (elab_dir context)              else let val e' = augElab arcs (elab_dir context)
# Line 390  Line 400 
400                  end                  end
401          fun get_free a = let          fun get_free a = let
402              val (pp, validity) = fetch a              val (pp, validity) = fetch a
403                fun reanchor cvt = SOME (string2pp (cvt a))
404          in          in
405              { pp = pp, valid = fn () => !validity }              { pp = pp, valid = fn () => !validity, reanchor = reanchor }
406          end          end
407          fun set_free (a, ppo) = let          fun set_free (a, ppo) = let
408              val (_, validity) = fetch a              val (_, validity) = fetch a
# Line 523  Line 534 
534      fun extend { context, arcs, err } morearcs =      fun extend { context, arcs, err } morearcs =
535          { context = context, arcs = arcs @ morearcs, err = err }          { context = context, arcs = arcs @ morearcs, err = err }
536    
537      fun osstring_reanchored anchor f = let      fun osstring_reanchored cvt f =
538          fun path (PATH { context, arcs, ... }) =          Option.map pp2name (#reanchor (elab_file (unintern f)) cvt)
             Option.map (augPP arcs) (ctxt context)  
         and ctxt (CWD _) = NONE  
           | ctxt (ROOT _) = NONE  
           | ctxt (DIR p) = Option.map dirPP (path p)  
           | ctxt (ANCHOR { name, ... }) = SOME (string2pp (anchor name))  
     in  
         Option.map pp2name (path (unintern f))  
     end  
539    
540      fun osstring_prefile_relative (p as { arcs, context, ... }) =      fun osstring_prefile_relative (p as { arcs, context, ... }) =
541          case context of          case context of

Legend:
Removed from v.758  
changed lines
  Added in v.759

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