Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /sml/trunk/src/compiler/MiscUtil/profile/prof-env.sml
ViewVC logotype

View of /sml/trunk/src/compiler/MiscUtil/profile/prof-env.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 651 - (download) (annotate)
Thu Jun 1 18:34:03 2000 UTC (19 years, 3 months ago) by monnier
File size: 2496 byte(s)
bring revisions from the vendor branch to the trunk
(* prof-env.sml
 *
 * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
 *
 *)

signature PROF_ENV =
  sig
    val prof: TellEnv.env -> string 
    val replace: {
	    get: unit -> Environment.environment,
	    set: Environment.environment -> unit
	  } -> unit
  end

functor ProfEnv (Interact: INTERACT) : PROF_ENV =
struct

  structure T = TellEnv

  fun prof (e0 : T.env) =
   let val accum = ref (nil: string list)
       fun say x = accum := x :: !accum
       val indentlev = ref 0
       val spaces = "                                            "
       fun nl () = (
	      say "\n";
	      say(substring(spaces,0,Int.min(size spaces, !indentlev))))

       fun indent f x = (indentlev := !indentlev + 1;
			 f x;
			 indentlev := !indentlev - 1)
		   
  
       fun any_in_env e = List.exists any_in_binding (T.components e)
       and any_in_binding(_,b) =
            case (T.strBind b, T.valBind b)
             of (SOME str, _) => any_in_env str
              | (_, SOME v) => any_in_ty v
	      | _ => false
       and any_in_ty ty = case T.funTy ty of SOME _ => true | NONE => false

       fun pr_env (e: T.env) = app pr_binding (T.components e)

       and pr_binding(sym: T.symbol, b: T.binding) =
           case (T.strBind b, T.valBind b)
            of (SOME str, _) => pr_str(sym,str)
             | (_, SOME v) => pr_val(sym,v)
             | _ => ()

       and pr_str(sym: T.symbol, e: T.env) =
         if any_in_env e 
	  then 
           (say "structure "; say (T.name sym); 
	    say " ="; nl(); say "struct open "; say (T.name sym);
            indent (fn () => (nl(); pr_env e)) ();
	    say "end;"; nl())
          else ()

       and pr_val(sym: T.symbol, ty: T.ty) =
        let fun curried(funid,argid,ty) =
             case T.funTy ty
              of NONE => (say "op "; say funid; say " "; say argid)
               | SOME(_,ty') => (say "let val op f = op "; say funid;
				 say " "; say argid; 
				 indent (fn()=> (nl(); say "in fn x => ";
						 curried("f","x",ty');
						 nl(); say "end")) ())
         in case T.funTy ty
            of SOME(_,ty') => (say "val op "; say (T.name sym); say " = fn x => ";
			       curried(T.name sym,"x",ty'); nl())
             | _ => ()
        end

    in pr_env e0;
       concat(rev (!accum))
   end

  fun replace {get,set} = 
   let val e0 = get ()
       val s = prof (Environment.staticPart e0)
       val e1 = Interact.evalStream(TextIO.openString s, e0)
    in set (Environment.concatEnv(e1,e0))
   end


end;


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