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 800, Fri Mar 16 17:22:47 2001 UTC revision 801, Mon Mar 19 22:53:00 2001 UTC
# Line 3  Line 3 
3   *   *
4   * Copyright (c) 2000 by Lucent Technologies, Bell Laboratories   * Copyright (c) 2000 by Lucent Technologies, Bell Laboratories
5   *   *
6   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)   * Author: Matthias Blume
7   *)   *)
8  signature SRCPATH = sig  signature SRCPATH = sig
9    
# Line 142  Line 142 
142                    valid: unit -> bool,                    valid: unit -> bool,
143                    reanchor: (anchor -> string) -> prepath option }                    reanchor: (anchor -> string) -> prepath option }
144    
145      type anchorval = unit -> elab      type anchorval = (unit -> elab) * (bool -> string)
   
     type env =  
          { get_free: anchor -> elab,  
            set_free: anchor * prepath option -> unit,  
            is_set: anchor -> bool,  
            reset: unit -> unit,  
            bound: anchorval StringMap.map }  
146    
147      datatype dir =      datatype dir =
148          CWD of { name: string, pp: prepath }          CWD of { name: string, pp: prepath }
149        | ANCHOR of { name: anchor, look: unit -> elab }        | ANCHOR of { name: anchor, look: unit -> elab,
150                        encode : bool -> string option }
151        | ROOT of string        | ROOT of string
152        | DIR of file0        | DIR of file0
153    
# Line 169  Line 163 
163    
164      type rebindings = { anchor: anchor, value: prefile } list      type rebindings = { anchor: anchor, value: prefile } list
165    
166      type ord_key = file      type env =
167             { get_free: anchor -> elab,
168               set_free: anchor * prepath option -> unit,
169               is_set: anchor -> bool,
170               reset: unit -> unit,
171               bound: anchorval StringMap.map }
172    
173      fun mk_look (e: env, a) () =      type ord_key = file
         case StringMap.find (#bound e, a) of  
             SOME f => f ()  
           | NONE => #get_free e a  
174    
175      (* stable comparison *)      (* stable comparison *)
176      fun compare (f1: file, f2: file) = Int.compare (#2 f1, #2 f2)      fun compare (f1: file, f2: file) = Int.compare (#2 f1, #2 f2)
# Line 201  Line 197 
197    
198      fun unintern (f: file) = #1 f      fun unintern (f: file) = #1 f
199    
200      fun encode0 bracket (p: file0) = let      fun pre0 (PATH { arcs, context, ... }) =
201            { arcs = arcs, context = context, err = fn (_: string) => () }
202        val pre = pre0 o unintern
203    
204        fun encode0 bracket (pf: prefile) = let
205          fun needesc c = not (Char.isPrint c) orelse Char.contains "/:\\$%" c          fun needesc c = not (Char.isPrint c) orelse Char.contains "/:\\$%" c
206          fun esc c =          fun esc c =
207              "\\" ^ StringCvt.padLeft #"0" 3 (Int.toString (Char.ord c))              "\\" ^ StringCvt.padLeft #"0" 3 (Int.toString (Char.ord c))
# Line 212  Line 212 
212          in          in
213              (ta' ".", ta' "..")              (ta' ".", ta' "..")
214          end          end
215            infixr 5 ::/::
216            fun arc ::/:: [] = [arc]
217              | arc ::/:: a = arc :: "/" :: a
218          fun arc a =          fun arc a =
219              if a = P.currentArc then "."              if a = P.currentArc then "."
220              else if a = P.parentArc then ".."              else if a = P.parentArc then ".."
221              else if a = "." then dot              else if a = "." then dot
222              else if a = ".." then dotdot              else if a = ".." then dotdot
223              else ta a              else ta a
224          fun e_p (PATH { arcs = [], context, ... }, _, a) =          fun e_ac ([], context, _, a) = e_c (context, a, NONE)
225              e_c (context, a, NONE)            | e_ac (arcs, context, ctxt, a) =
           | e_p (PATH { arcs, context, ... }, ctxt, a) =  
226              let val l = map arc arcs              let val l = map arc arcs
227                  val a0 = List.hd l                  val a0 = List.hd l
228                  val l' = rev l                  val l' = rev l
229                  val l'' = if ctxt andalso bracket then                  val l'' = if ctxt andalso bracket then
230                                concat ["(", List.hd l', ")"] :: List.tl l'                                concat ["(", List.hd l', ")"] :: List.tl l'
231                          else l'                          else l'
232                  val a' = foldl (fn (x, l) => arc x :: "/" :: l)                  val a' = foldl (fn (x, l) => arc x ::/:: l)
233                                (arc (List.hd l'') :: a) (List.tl l'')                                (arc (List.hd l'') :: a) (List.tl l'')
234              in e_c (context, a', SOME a0)              in e_c (context, a', SOME a0)
235              end              end
236          and e_c (ROOT "", a, _) = concat ("/" :: a)          and e_c (ROOT "", a, _) = concat ("/" :: a)
237            | e_c (ROOT vol, a, _) = concat ("%" :: ta vol :: "/" :: a)            | e_c (ROOT vol, a, _) = concat ("%" :: ta vol ::/:: a)
238            | e_c (CWD _, a, _) = concat a            | e_c (CWD _, a, _) = concat a
239            | e_c (ANCHOR x, a, NONE) = concat ("$" :: ta (#name x) :: "/" :: a)            | e_c (ANCHOR x, a, a1opt) =
240            | e_c (ANCHOR x, a, SOME a1) = let              (case (#encode x bracket, a1opt) of
241                     (SOME ad, _) =>
242                     if not bracket then concat (ad ::/:: a)
243                     else concat ("$" :: ta (#name x) :: "(=" :: ad :: ")/" :: a)
244                   | (NONE, NONE) => concat ("$" :: ta (#name x) ::/:: a)
245                   | (NONE, SOME a1) => let
246                  val a0 = ta (#name x)                  val a0 = ta (#name x)
247              in              in
248                  concat (if bracket andalso a0 = a1 then "$/" :: a                  concat (if bracket andalso a0 = a1 then "$/" :: a
249                          else "$" :: a0 :: "/" :: a)                               else "$" :: a0 ::/:: a)
250              end                   end)
251            | e_c (DIR p, a, _) = e_p (p, true, ":" :: a)            | e_c (DIR (PATH { arcs, context, ... }), a, _) =
252                e_ac (arcs, context, true, ":" :: a)
253      in      in
254          e_p (p, false, [])          e_ac (#arcs pf, #context pf, false, [])
255      end      end
256    
257      val encode = encode0 false o unintern      fun mk_anchor (e: env, a) =
258            case StringMap.find (#bound e, a) of
259                SOME (elaborate, encode) =>
260                { name = a , look = elaborate, encode = SOME o encode }
261              | NONE =>
262                { name = a, look = fn () => #get_free e a, encode = fn _ => NONE }
263    
264        val encode_prefile = encode0 false
265        val encode = encode_prefile o pre
266    
267      val clients = ref ([] : (string -> unit) list)      val clients = ref ([] : (string -> unit) list)
268      fun addClientToBeNotified c = clients := c :: !clients      fun addClientToBeNotified c = clients := c :: !clients
# Line 260  Line 276 
276          else (cwd_info := { name = n', pp = pp' };          else (cwd_info := { name = n', pp = pp' };
277                cwd_notify := true);                cwd_notify := true);
278          if !cwd_notify then          if !cwd_notify then
279              let val p = PATH { arcs = rev (#revarcs pp),              let val pf = { arcs = rev (#revarcs pp),
280                                 context = ROOT (#vol pp),                                 context = ROOT (#vol pp),
281                                 elab = ref bogus_elab, id = ref NONE }                             err = fn (_: string) => () }
282                  val ep = encode0 false p                  val ep = encode_prefile pf
283              in              in
284                  app (fn c => c ep) (!clients);                  app (fn c => c ep) (!clients);
285                  cwd_notify := false                  cwd_notify := false
# Line 296  Line 312 
312                                 reanchor = reanchor }                                 reanchor = reanchor }
313              else { pp = pp, valid = fn () => true, reanchor = reanchor }              else { pp = pp, valid = fn () => true, reanchor = reanchor }
314          end          end
315        | elab_dir (ANCHOR { name, look }) = look ()        | elab_dir (ANCHOR { name, look, encode }) = look ()
316        | elab_dir (ROOT vol) = absElab ([], vol)        | elab_dir (ROOT vol) = absElab ([], vol)
317        | elab_dir (DIR p) = dirElab (elab_file p)        | elab_dir (DIR p) = dirElab (elab_file p)
318    
# Line 365  Line 381 
381      fun osstring_prefile { context, arcs, err } =      fun osstring_prefile { context, arcs, err } =
382          pp2name (#pp (augElab arcs (elab_dir context)))          pp2name (#pp (augElab arcs (elab_dir context)))
383    
384      val descr = encode0 true o unintern      val descr = encode0 true o pre
385    
386      fun osstring_dir d =      fun osstring_dir d =
387          case pp2name (#pp (elab_dir d)) of          case pp2name (#pp (elab_dir d)) of
# Line 491  Line 507 
507              else ANCHORED (String.extract (arc1, 1, NONE), arcn)              else ANCHORED (String.extract (arc1, 1, NONE), arcn)
508      end      end
509    
510      fun bind env l = let      fun bind (env: env) l = let
511          fun b ({ anchor, value = { arcs, context, err } }, e: env) =          fun b ({ anchor, value = pf as { arcs, context, err } }, m) =
512              { get_free = #get_free e, set_free = #set_free e,              StringMap.insert (m, anchor,
513                reset = #reset e, is_set = #is_set e,                                (fn () => augElab arcs (elab_dir context),
514                bound = StringMap.insert                                 fn brack => encode0 brack pf))
515                            (#bound e, anchor,  
                            fn () => augElab arcs (elab_dir context)) }  
516      in      in
517          foldl b env l          { get_free = #get_free env, set_free = #set_free env,
518              reset = #reset env, is_set = #is_set env,
519              bound = foldl b (#bound env) l }
520      end      end
521    
522      fun file0 ({ context, arcs, err }: prefile) =      fun file0 ({ context, arcs, err }: prefile) =
# Line 512  Line 529 
529                           | _ => arcs) }                           | _ => arcs) }
530    
531      val file = intern o file0      val file = intern o file0
     fun pre0 (PATH { arcs, context, ... }) =  
         { arcs = arcs, context = context, err = fn (_: string) => () }  
     val pre = pre0 o unintern  
532    
533      fun prefile (c, l, e) = { context = c, arcs = l, err = e }      fun prefile (c, l, e) = { context = c, arcs = l, err = e }
534    
     (* env argument is not used -- it's just there for uniformity *)  
535      fun native { err } { context, spec } =      fun native { err } { context, spec } =
536          case P.fromString spec of          case P.fromString spec of
537              { arcs, vol, isAbs = true } => prefile (ROOT vol, arcs, err)              { arcs, vol, isAbs = true } => prefile (ROOT vol, arcs, err)
# Line 529  Line 542 
542              RELATIVE l => prefile (context, l, err)              RELATIVE l => prefile (context, l, err)
543            | ABSOLUTE l => prefile (ROOT "", l, err)            | ABSOLUTE l => prefile (ROOT "", l, err)
544            | ANCHORED (a, l) =>            | ANCHORED (a, l) =>
545              prefile (ANCHOR { name = a, look = mk_look (env, a) }, l, err)              prefile (ANCHOR (mk_anchor (env, a)), l, err)
546    
547      fun extend { context, arcs, err } morearcs =      fun extend { context, arcs, err } morearcs =
548          { context = context, arcs = arcs @ morearcs, err = err }          { context = context, arcs = arcs @ morearcs, err = err }
# Line 553  Line 566 
566                       (* HACK! We are cheating here, turning the prefile into                       (* HACK! We are cheating here, turning the prefile into
567                        * a file even when there are no arcs.  This is ok                        * a file even when there are no arcs.  This is ok
568                        * because of (bracket = false) for encode0. *)                        * because of (bracket = false) for encode0. *)
569                       encode0 false (PATH { arcs = #arcs f,                       encode_prefile { arcs = #arcs f,
570                                             context = #context f,                                             context = #context f,
571                                             elab = ref bogus_elab,                                        err = fn (_: string) => () })
                                            id = ref NONE }))  
572          fun p_p p = p_pf (pre0 p)          fun p_p p = p_pf (pre0 p)
573          and p_pf { arcs, context, err } =          and p_pf { arcs, context, err } =
574              P.toString { arcs = arcs, vol = "", isAbs = false } :: p_c context              P.toString { arcs = arcs, vol = "", isAbs = false } :: p_c context
# Line 579  Line 591 
591          and u_p l = file0 (u_pf l)          and u_p l = file0 (u_pf l)
592          and u_c [vol, "r"] = ROOT vol          and u_c [vol, "r"] = ROOT vol
593            | u_c ["c"] = dir relativeTo            | u_c ["c"] = dir relativeTo
594            | u_c [n, "a"] = ANCHOR { name = n, look = mk_look (env, n) }            | u_c [n, "a"] = ANCHOR (mk_anchor (env, n))
595            | u_c l = DIR (u_p l)            | u_c l = DIR (u_p l)
596      in      in
597          u_pf pickled          u_pf pickled
# Line 618  Line 630 
630                            | #"$" => let                            | #"$" => let
631                                  val n = xtr ()                                  val n = xtr ()
632                              in                              in
633                                  file (ANCHOR { name = n,                                  file (ANCHOR (mk_anchor (env, n)), arcs)
                                                look = mk_look (env, n) }, arcs)  
634                              end                              end
635                            | _ => file (cwd (), arc arc0 :: arcs)                            | _ => file (cwd (), arc arc0 :: arcs)
636                  end                  end

Legend:
Removed from v.800  
changed lines
  Added in v.801

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