------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1995 by International Computer Science Institute            --
-- This file is part of the GNU Sather package. It is free software; you may --
-- redistribute  and/or modify it under the terms of the  GNU General Public --
-- License (GPL)  as  published  by the  Free  Software  Foundation;  either --
-- version 2 of the license, or (at your option) any later version.          --
-- This  program  is distributed  in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/GPL for more details.        --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------

class BROWSER is
   -- Sather browser based on the compiler's front and middle sections
   -- There should probably be a separate main class that runs all the
   -- segments and sets the shareds,
   -- but the complexity is not that great anyhow...
   -- See the file Help/tcl-sather-interface for documentation on the
   -- callbacks 
   -- Set before the class is actually created...
   private shared is_color: BOOL;	-- False by default?
   private shared sather_home: STR;
   private shared app: TK_APP;
   
   readonly attr info: UNIFIED_INFO;

   readonly attr current_graph: DIGRAPH{STR};
   -- One of either info.full_graph, info.include_graph or info.subtype_graph
   -- Used to test for nodes of various kinds
   
   private attr cache_layouts: FMAP{STR,STR};
   -- Classes that are currently being displayed
   -- Filters may be applied to this list to eliminate various classes
   readonly attr active_classes: FSET{STR};
   shared non_interactive: BOOL; -- No X windows
   shared non_interactive_file: STR; -- Name of non-interactive file
   shared test_mode: BOOL;

   shared debug: BOOL := false;	-- So that it can be set from tcl
   
-- For routines
   readonly attr show_public,
	 show_private,
	 show_attr,
	 show_iters,
	 show_shared,
	 show_const,
	 show_abstract_edges,
	 show_concrete_edges,
	 show_module_edges,
	 show_abstract,
	 show_concrete,
	 show_module,
	 show_singletons: BOOL; 
   
   readonly attr cur_class_name: STR; -- The currently selected class

   main(a:ARRAY{STR}) is
      sather_home := UNIX::sather_home;
      if a.size < 2 then
	 raise "BROWSER::main No arguments supplied to the browser!\n";
      end;
      non_interactive := false;
      test_mode := false;
      if a[1] = "-non_interactive" then
	 -- Shift the remaining arguments down by one and reassign a
	 non_interactive := true;
	 if a[2] = "self_test" then   test_mode := true;
	 else    non_interactive_file := a[2];  end;
	 new_args: ARRAY{STR} := #(a.size-2);
	 loop i ::= new_args.size.times!;  new_args[i] := a[i+2]; end;
	 a := new_args;
      end;
      protect 
	 browser_dir: STR := sather_home+"/Browser/Tcl/";
	 debug_msg("Creating application");
	 if non_interactive then
	    app := TK_APP::create_no_window("BrowserStartupWindow",
					    "browserStartupWindow");
	 else 
	    app := #TK_APP("BrowserStartupWindow",
			   "browserStartupWindow");
	 end;
	 debug_msg("Setting callbacks");
	 app.cb_res("getHome",         bind(get_home_cb)); 
	 app.cb_res("debugOn",             bind(debug_on_cb));
	 if ~non_interactive then
	    debug_msg("Evaluating statuptWindow.tcl");
	    discard ::= 
		  app.tcl_tk.eval_file(browser_dir+"browserStartupWindow.tcl");
	 end;
	 debug_msg("Starting up front end");
	 front_end ::= #FRONT_END(a); -- Runs the front end on the args

	 debug_msg("Constructing info");
	 -- TIME::start;
	 -- if front_end.prog.verbose then
	 --   #OUT+"Constructing browser info...(";
	 --end;
	 info ::= #UNIFIED_INFO(front_end.prog,front_end.exec_name);      
	 --if front_end.prog.verbose then #OUT+TIME::elapsed+")\n"; end;
	 debug_msg("Running Browser");
	 if ~test_mode then
	    browser ::= #BROWSER(info);
	 else UNIX::exit(0); return end;
	 -- if ~non_interactive then   else UNIX::exit(0);  return; end;
      when $STR then #ERR+exception.str+"\n"; end;
   end;
   
   create_startup_window is
   end;      
      
   create(for: UNIFIED_INFO): SAME is
      res: SAME := new;
      res.build(for);
      return(res);
   end;
      
   initial_msg(msg: STR) is
      if ~non_interactive then 
	discard ::= app.tcl_tk.eval(msg); 
      end;
   end;

   private build(class_info: UNIFIED_INFO) is
      -- See Help/tcl-sather-interface for documentation on the callbacks
      show_public := true; show_private := true; show_attr := true;
      show_iters := true; show_shared := true; show_const := true;
      show_abstract := true; show_concrete := true; show_module := true;
      show_abstract_edges := true; 
      show_module_edges := true;
      show_concrete_edges := true;
      show_singletons := true;
      info := class_info;
      cur_class_name := "";
      current_graph := info.full_graph;
      activate_all_cb;
      debug_msg("Starting application");
      -- The third argument is the directory where startup.tcl is located
    --   app := #TK_APP("Browser","browser",info.home+"/Browser/");
      debug_msg("Binding callbacks");
      app.cb_args("setCurClassName",         bind(set_cur_class_name_cb(_)));
      app.cb_res("getHome",                  bind(get_home_cb));
      app.cb_args_res("getFullLayout",       bind(get_full_layout_cb(_)));
      app.cb_args_res("getRestrictedLayout", 
		                        bind(get_restricted_layout_cb(_)));
      app.cb_args("setBoolVar",         bind(set_bool_var_cb(_)));
      app.cb_args("deactivateClasses",  bind(deactivate_classes_cb(_)));
      app.cb_args("activateClasses",    bind(activate_classes_cb(_)));
      app.cb_res("allClasses",          bind(all_classes_cb));
      app.cb_res("flushGraph",          bind(flush_graph_cb));
      app.cb_res("getRelatives",        bind(get_relatives_cb));
      -- Information about a particular class
      app.cb_args_res("getClassInfo",   bind(get_class_info_cb(_)));
      --      cb_res("activeClasses",        bind(active_classes_cb));
      --      cb("activateAll",              bind(activate_all_cb));
      
      debug_msg("Evaluating browser.tcl");
      if ~non_interactive then
	 discard ::= app.tcl_tk.eval_file(info.home+"/Browser/Tcl/browser.tcl");
	 debug_msg("Entering tcl loop");
	 app.tcl_tk.main_loop;
	 debug_msg("Done tcl loop");
      else
	 f ::= non_interactive_file;
	 #OUT+"Eval file:"+f+"\n";
	 discard ::= app.tcl_tk.eval_file(f);
      end;
   end;
   
   
   flush_graph_cb: TUP{INT,STR} is
      cache_layouts := #;
      return(#TUP{INT,STR}(0,""));
   end;
   
   debug_on_cb: TUP{INT,STR} is
      debug := true;
      return(#TUP{INT,STR}(0,""));
   end;
      
   all_classes_cb: TUP{INT,STR} is
      -- Return a list of the form of
      -- {
      -- { nodename filename loc modulename }
      -- { nodename filename loc modulename }
      -- }
      res ::= #FSTR("{ ");
      loop c ::= info.classes!;
	 as: AS_CLASS_DEF := info.as(c);
	 src: SFILE_ID := as.source;
	 fname: STR := src.file_in;
	 floc: INT := src.line_num_in;
	 mod: STR := info.class_to_module.get(c);
	 res := res + " { "+c+" "+fname+" "+floc+" "+mod+"  } ";	 
      end;
      res := res+ " }";
      return(#TUP{INT,STR}(0,res.str));
   end;
   
   get_home_cb: TUP{INT,STR} is
      return(#TUP{INT,STR}(0,sather_home));
   end;

   set_bool_var_cb(args: ARRAY{STR}) is
      if args.size < 2 then
	 #ERR+"\n Sather error:set_bool_var expected 2 arguments!\n";
      end;
      varname ::= args[0];
      val ::= args[1];
      satherval: BOOL;
      if (val = "0" or val = "false") then satherval := false;
      else satherval := true; end;
      debug_msg("Setting:"+varname+" to:"+satherval+" from:"+val);
      case (varname)
      when "gShowConcrete" then show_concrete := satherval;cache_layouts := #;
      when "gShowAbstract" then show_abstract := satherval; cache_layouts := #;
      when "gShowModule" then   show_module := satherval; cache_layouts := #;
      when "gShowConcreteEdges" then
	 show_concrete_edges := satherval;
	 cache_layouts := #;
      when "gShowModuleEdges" then
	 show_module_edges := satherval;
	 cache_layouts := #;
      when "gShowAbstractEdges" then
	 show_abstract_edges := satherval;
	 cache_layouts := #;
      when "gShowSingletons" then
	 show_singletons := satherval;
	 cache_layouts := #;
      when "gShowPublic" then show_public := satherval;
      when "gShowPrivate" then show_private := satherval;
      when "gShowAttr" then show_attr := satherval;
      when "gShowShared" then show_shared := satherval;
      when "gShowConst" then show_const := satherval;
      when "gShowIters" then show_iters := satherval;
      else #ERR+"Browser.sa INTERNAL ERROR: No such variable:"+varname+"\n";
      end;
   end;
   
   active_classes_cb: TUP{INT,STR} is
      -- Return the list of currently active classes
      res ::= #FSTR("");
      loop res := res+" "+active_classes.elt!; end;
      return(#TUP{INT,STR}(0,"{ "+res.str+" }"));
   end;
   
   activate_all_cb is
      -- Add all nodes in the current graph to the active set
      active_classes := #;
      loop n ::= info.full_graph.nodes.elt!;
	 active_classes := active_classes.insert(n) 
      end;
   end;
   
   deactivate_classes_cb(args: ARRAY{STR}) is
      -- Eliminate the classes named in args from the active list
      arglist ::= split_into_set(args[0]);
      active_classes := active_classes.difference(arglist);
   end;

   activate_classes_cb(args: ARRAY{STR}) is
      -- Add the classes in the arg list to the current active list
      arglist ::= split_into_set(args[0]);
      active_classes := active_classes.union(arglist);
   end;

   get_relatives_cb: TUP{INT,STR} is
      -- List returned is of the form
      -- { 
      --  { classname { ancestor1 ancestor2 ....} { descend1 descend2 ... } }
      --  }
      res ::= " { ";
      classes ::= current_graph.nodes;
      loop cl ::= classes.elt!;
	 res := res+" { "+cl+" ";
	 ancestors ::= current_graph.dfs_ancestors(cl);	 
	 descendants ::= current_graph.dfs(cl);
	 res := res + " { ";
	 loop res := res+" "+ancestors.elt!+" "; end;
	 res := res + " } { ";
	 loop res := res+" "+descendants.elt!+" "; end;
	 res := res + " } }";
      end;
      res := res + "}";
      return #TUP{INT,STR}(0,res);
   end;
   
   get_restricted_layout_cb(args:ARRAY{STR}): TUP{INT,STR} is
      -- Get edges of the graph restricted to the ancestors and descandants
      -- of the currently chosen node
      res ::= #FSTR("");
      display_graph ::= #DIGRAPH{STR};
      if (cur_class_name = "") then return(make_layout(display_graph)); end;
      debug_msg("Restricted layout");
      if (cache_layouts.test(cur_class_name)) then
	 return(#TUP{INT,STR}(0,cache_layouts.get(cur_class_name)));
      end;
      nodes ::= current_graph.nodes;
      ancestors: FLIST{STR} := current_graph.dfs_ancestors(cur_class_name);
      descendants: FLIST{STR} :=current_graph.dfs(cur_class_name); 
      display_graph.add_node(cur_class_name);
      -- All connected nodes in the graph
      relations: FLIST{STR} := ancestors.union(descendants);
      loop 
	 add: BOOL := false;
	 e ::= relations.elt!;
	 if (active_classes.test(e)) then 
	    if ((info.modules.test(e)) and show_module)  then
	       debug_msg("Adding module node:"+e+"\n");
	       add := true;
	    elsif ((info.concrete.test(e)) and show_concrete) then
	       debug_msg("Adding concrete node:"+e+"\n");
	       add := true;
	    elsif ((info.abstract_class.test(e)) and show_abstract) then
	       debug_msg("Adding abstract node:"+e+"\n");
	       add := true;
	    end;
	    if add then
	       display_graph.add_node(e);
	       out_nodes ::= current_graph.children(e);
	       loop out_ ::= out_nodes.elt!;
		  if ~(display_graph.has_node(out_)) then
		     display_graph.add_node(e);
		  end;
	       end;
	    end;  
	 end;
      end;
      -- Add the active edges
      loop
	 n ::= display_graph.nodes.elt!;
	 show_edge: BOOL := false;
	 if info.modules.test(n) and show_module_edges then
	    show_edge := true;
	 elsif info.concrete.test(n) and show_concrete_edges then
	    show_edge := true;
	 elsif info.abstract_class.test(n) and show_abstract_edges then
	    show_edge := true;
	 end;
	 if show_edge then
	    out_nodes ::= current_graph.children(n);
	    loop out_ ::= out_nodes.elt!;
	       if display_graph.has_node(out_) then
		  display_graph.connect(n,out_); 
	       end;
	    end;
	 end;
	 in_nodes ::= current_graph.parents(n);
	 loop in ::= in_nodes.elt!;
	    show_edge := false;
	    if info.modules.test(in) and show_module_edges then
	       show_edge := true;
	    elsif info.concrete.test(in) and show_concrete_edges then
	       show_edge := true;
	    elsif info.abstract_class.test(in) and show_abstract_edges then
	       show_edge := true;
	    end;
	    if show_edge then
	       if display_graph.has_node(in) then 
		  display_graph.connect(in,n);
	       end;
	    end;
	 end;
      end;
      if ~show_singletons then
	 loop n ::= display_graph.nodes.elt!;
	    if display_graph.degree(n) = 0 and ~(cur_class_name = n) then
	       discard ::= display_graph.delete_node(n);  
	    end;
	 end;
      end;
      if (debug) then #OUT+"Display graph:\n"+display_graph.str+"\n"; end;
      layout ::= make_layout(display_graph);
      cache_layouts := cache_layouts.insert(cur_class_name,layout.t2);
      return(layout);
   end;

   get_full_layout_cb(args:ARRAY{STR}): TUP{INT,STR} is   
      -- Return the list of all classes, and positions 
      -- return the layout information for the full graph
      -- Get active nodes in a subgraph
      active_graph ::= current_graph.subgraph(bind(is_active(_)));
      display_graph::=active_graph.subgraph(bind(has_edges(active_graph,_)));
      return(make_layout(display_graph));
   end;
      
   private 
   make_layout(layout_graph: DIGRAPH{STR}):TUP{INT,STR} is
      -- Resulting list has 3 sublists
      -- { layout.depth layout.width }
      -- { {clasname1 xpos ypos } {classname2 xpos ypos} ... }
      -- { { source1 dest1} { source2 dest2} ....} 
      if (debug) then debug_msg("Graph to Layout:\n"+layout_graph.str); end;
      debug_msg("Constructing layout...");
      layout: LAYOUT{STR} := layout_graph.layout;
      res ::= #FSTR("");
      classes ::= layout.nodes;
      xpos: FLIST{FLT} := layout.xlocs;
      ypos: FLIST{FLT} := layout.ylocs;
      loop ind: INT := classes.size.times!;
	 class_name: STR := classes[ind];
	 x: INT := (xpos[ind]*100.0).round.int;
	 y: INT := (ypos[ind]*100.0).round.int;
	 res := res+" { "+class_name+" "+ x.str+" "+y.str+"  } ";
      end;
      size_str: STR := " "+layout.depth.str+" "+layout.width.str+" ";
      if (debug) then #OUT+"Getting edges all..\n"; end;
      
      -- Getting edges
      edges ::= #FSTR("");
      loop child: STR := layout_graph.nodes.elt!;
	 loop
	    parent: STR := layout_graph.parents(child).elt!;
	    edges := edges +" { "+ parent +" "+ child+ " } ";
	 end;
      end;
      full ::= "{ "+size_str+" } { "+res.str+" } { "+edges +" } ";
      return(#TUP{INT,STR}(0,full));
   end;
   
   
   private has_edges(g: DIGRAPH{STR}, n: STR): BOOL is
      -- Lambda function locat to layout_graph_for_browser
      -- used to derive subgraph of nodes with > 0 edges
      return(g.degree(n)>0);
   end;
   
   set_cur_class_name_cb(args: ARRAY{STR}) is
      -- Set the selected class to args[0]
      cur_class_name := args[0];
   end;
    
   get_class_info_cb(args: ARRAY{STR}): TUP{INT,STR} is
      -- args[0] = class_name
      -- See Help/tcl-sather-interface for documentation on the callbacks
      -- Returrns the source location of this class along with the
      -- information about the routines and their locations
      -- The return string has the following format
      -- 
      
      if (args.size < 1) then #ERR+"Internal Error: Wrong number args\n"; end;
      class_name::= args[0];
      res ::= #FSTR("");
      res := res+ " "+source_str(info.get_class_source(class_name))+" { ";
      impl: IMPL := info.impl(class_name);
      if (~void(impl)) then
	 elts: ELT_TBL := impl.elts;
	 loop
	    -- If this element should be displayed according to *ALL*
	    -- of the flags, it will be. eg. a private iter will not
	    -- be displayed even if iters are to be displayed so
	    -- long as private features are not displayed.
	    -- Access string has the following fields
	    -- iter private attr_writer att_reader, sh_writer sh_reader const
	    -- The fields, when these exist, are
	    -- i    p       w           r           w         r         c
	    -- And when they don't:
	    -- n    n       n           n           n         n         n
	    acc_str: FSTR := #("nnnnnnn"); -- Initial values will be overridden
	    -- if the feature is of the right type
	    elt: ELT := elts.elt!;
	    sig: SIG := elt.sig;
	    r: BOOL := true;
	    if elt.is_iter then acc_str[0] := 'i';  
	       if (~show_iters) then r := false end;
	    end;
	    if elt.is_private then 
	       acc_str[1] := 'p'; 
	       if ~show_private then r := false end;
	    else		-- Public feature
	       if ~show_public then r := false; end;
	    end;
    	    if elt.is_attr_writer then 
	       acc_str[2]:='w';
	       if ~show_attr then r := false; end;
	    end;
    	    if elt.is_attr_reader then
	       acc_str[3] := 'r';
	       if ~show_attr then r := false; end;
	    end;
	    if elt.is_shared_reader then
	       acc_str[4] := 'r';
	       if ~show_shared then r := false; end;
	    end;
	    if elt.is_shared_writer then
	       acc_str[5] := 'w';
	       if ~show_shared then r := false; end;
	    end;
	    if (elt.is_const_reader) then
	       acc_str[6] := 'c';
	       if ~show_const then r := false; end;
	    end;
	    -- Cumulative result of all tests
	    if r then
	       res :=res+"{ "+sig_str(elt.sig)+" "
		     +source_str(elt.as.source)+ " "+acc_str+" } ";
	    end;
	 end;
      else
	 -- Abstract types: Get the information from the type ifc
	 --	 class_ifc: IFC := info.ifc(class_name);
	 --	 sig_tbl: SIG_TBL := class_ifc.sig_tbl;
	 --	 loop
	 --	    sig ::= sig_tbl.elt!;
	 --	    if r then
	 --	       res :=
	 --           res+"{"+sig_str(sig)+" "+source_str(elt.as.source)+" } ";
	 --	    end;
	 --	 end;
	 -- Get the routine information from the AS def
	 -- For abstract types we only have the interface defined by that
	 -- particular class, not all it inherits
	 as: AS_CLASS_DEF := info.as(class_name);
	 class_element: $AS_CLASS_ELT := as.body; 
	 loop until!(void(class_element));
	    typecase class_element
	    when AS_ROUT_DEF then 
	       rout: AS_ROUT_DEF := class_element;
	       res:=res+"{"+rout.name.str+" "+source_str(rout.source)
		     +" nnnnnnn } ";
	       -- Iter? We don't yet have dispatched iters...
	    else  end;
	    class_element := class_element.next;
	 end;
      end;	 
      res := res+"}  ";		-- End of a class def
      return(#TUP{INT,STR}(0,res.str));
   end;
   
   source_str(s: SFILE_ID): STR is  return(s.file_in+" "+s.line_num_in);  end;
   
   private is_active(c: STR): BOOL pre ~void(active_classes) is
      return(active_classes.test(c));
   end;
   
   private sig_str(sig: SIG): STR is
      -- The string representation of self. Uses no whitespace,
      -- Taken from the compiler,  but does not specify the 
      -- class name eg. "foo!(A!,B{C}):D". If self is void, returns "void".
      if void(sig) then return "voidsig" end;
      --if ~void(sig.string) then return sig.string; end;
      if void(sig.name) then return "void sig.name" end;
      if void(sig.name.str) then return "void sig.name.str" end;
      -- if void(sig.tp) then return "void sig.tp" end;
      -- if void(sig.tp.as) then return "void sig.tp.as" end;
      -- if void(sig.tp.as.name) then return "void sig.tp.as.name" end;
      -- if void(sig.tp.as.name.str) then return "void sig.tp.as.name.str" end;
      -- class_name: STR := sig.tp.as.name.str;
      s::=#FSTR  + sig.name.str;
      if ~void(sig.args) then
	 s:=s + '(';
	 loop 
	    sigelt ::= sig.args.elt!;
	    if void(sigelt) then
	       #ERR+" INTERNAL ERROR!. Void sigelt!";
	       s := s+",voidsigelt";
	    else
	       s:=s+",".separate!(sigelt.str);
	       if ~void(sig.hot) and sig.hot.elt! then s:=s+'!' end 
	    end;
	 end;
	 s:=s + ')' 
      end;
      if ~void(sig.ret) then s:=s + ':' + sig.ret.str end;
      return s.str 
   end;

   private split_into_set(s: STR): FSET{STR} is
      res ::= #FSET{STR};
      sc ::= s.cursor;
      loop  until!(sc.is_done);
	 wrd ::= sc.get_word;
	 res := res.insert(wrd);
      end;
      return(res);
   end;
   
   private print_state is
      pv(show_public,"show_public");
      pv(show_private,"show_private");
      pv(show_attr,"show_attr");
      pv(show_iters,"show_iters");
      pv(show_shared,"show_shared");
      pv(show_const,"show_const");
      pv(show_abstract,"show_abstract");
      pv(show_concrete,"show_concrete");
      pv(show_concrete_edges,"show_concrete_edges");
      pv(show_module_edges,"show_module_edges");
      pv(show_subtype_edges,"show_subtype_edges");
   end;
   
   private pv(val: BOOL,nm: STR) is
      #OUT+nm+"="+val+"\n";
   end;

   private debug_msg(s: STR) is
      if (debug) then #ERR+"SATHER:"+s+"\n";  end;
   end;
   
end;
--------------------------------------------------------------------
class UNIFIED_INFO is
   -- Extracts class information from the compiler tables
   -- for easier accessibility. Constructs a class graph
   -- with subtype and include relationships 
   -- Also constructs a mapping from class names in "cannonical form"
   --  (all parameters replaces by underscores)
   -- to class info objects which hold the relevant compiler information
   -- for a particular class

     -- Shield prog itself to control access
   private attr prog: PROG;
   shared debug: BOOL := false;
   
   readonly attr exec_name: STR;
   readonly attr include_graph: DIGRAPH{STR};
   readonly attr subtype_graph: DIGRAPH{STR};
   readonly attr module_graph: DIGRAPH{STR};
   readonly attr modules,concrete,abstract_class: FSET{STR};
   readonly attr class_to_module: FMAP{STR,STR};
   readonly attr full_graph: DIGRAPH{STR}; -- Contains all nodes,
   -- all include and subtype edges. Used for layout.
   
   private attr class_table: FMAP{STR,CLASS_INFO};
   -- A mapping from class names in "cannonical form" (obtained
   -- by calling tp_class_name(TP_CLASS) or as_class_name(AS_CLASS_DEF)
   -- which currently has {_,_,_} for parameters of a parametrized tyep

   private class_info(c: STR): CLASS_INFO is 
      -- Return information about class "c"
      if class_table.test(c) then
	 return(class_table.get(c));  
      else
	 #ERR+"INTERNAL BROWSER ERROR!\n";
	 #ERR+"Could not find class:"+c+" in the class table!\n";
	 return class_table.get("INT");
      end;
   end;

   classes!: STR is
      loop yield class_table.keys! end;
   end;

      
   home: STR is return(prog.home) end;
   
   impl(class_name: STR): IMPL is
      ci ::= class_info(class_name);
      return(ci.tp.impl);
   end;
   
   ifc(class_name: STR): IFC is
      -- Go from the class name to the TP to the ifc
      ci ::= class_info(class_name);
      ifc: IFC := ci.tp.ifc;
      return(ifc);
   end;

   as(class_name: STR): AS_CLASS_DEF is
      return(class_info(class_name).as);
   end;
   
   tp(class_name: STR): TP_CLASS is
      return(class_info(class_name).tp);
   end;
   
   create(program: PROG,exec_name: STR): SAME is
      res ::= new;
      res.prog := program;
      res.exec_name := exec_name;
      res.init;
      return(res);
   end;
   
   private init is
      -- Create the subtype and include graphs as well ast the class table.
      class_table := #FMAP{STR,CLASS_INFO};
      include_graph := #DIGRAPH{STR};
      subtype_graph := #DIGRAPH{STR};
      full_graph := #DIGRAPH{STR};
      abstract_class :=  #;
      concrete := #;
         -- First get all the classes
      loop
	 -- Go through the tp table, finding all classes
	 tp_class: TP_CLASS := prog.tp_tbl.class_tbl.elt!;
	 -- Convert the class name to standard form
	 tp_class_name ::= tp_class_name(tp_class);
	 -- #ERR+"Dealing with class:"+tp_class_name+"\n";
	 if (~class_table.test(tp_class_name)) then
	    -- If not already inserted, add the class and its class info
	    -- i.e. the syntax definition of the class
	    as_class: AS_CLASS_DEF := 
		  prog.parse.tree_for(tp_class.name,tp_class.params.size);
	    ci ::= #CLASS_INFO(tp_class,as_class);
	    class_table := class_table.insert(tp_class_name,ci);
	    -- All classes are added to the subtype graph and the
	    -- include graph (concrete and abstract classes may 
	    -- belong well belong to both)
	    discard ::= subtype_graph.add_node(tp_class_name);
	    discard := include_graph.add_node(tp_class_name);
	    -- Then add to either the set of abstract classes or the
	    -- set of concrete classes
	    if (tp_class.is_abstract) then
	       abstract_class := abstract_class.insert(tp_class_name);
	    else
	       concrete := concrete.insert(tp_class_name);
	    end;
	 end;
      end;	 
      
      -- Then add all the type and include edges to the subtype and
      -- include graphs
      loop 
	 -- Now go through the class table we created
	 name_info: TUP{STR,CLASS_INFO} := class_table.pairs!;
	 class_name: STR := name_info.t1;
	 class_info: CLASS_INFO := name_info.t2;

	 -- Type edges
	 -- Find all the parents of class "class_name"
	 anc_tbl:FMAP{TP_CLASS,FSET{TP_CLASS}} := prog.tp_graph.par_tbl;
	 parents: FSET{TP_CLASS} := anc_tbl.get(class_info.tp);
	 -- Go through all the parents, and if no edge already exists
	 -- add one to the the type graph
	 loop parent: TP_CLASS := parents.elt!;
	    parent_name ::= tp_class_name(parent);
	    if ~(subtype_graph.has_edge(parent_name,class_name)) then
	       subtype_graph.connect(parent_name,class_name);
	    end;
	 end;

	 -- Include edges
	 as_class: AS_CLASS_DEF := class_info.as;
	 -- Get teh include edges from the syntax definition
	 if void(as_class) then 
	    -- An error occured earlier, but see if we can ignore it.
	    #ERR+"Browser error: Void class. Trying to continue.\n";
	    #ERR+"May crash later:"+ class_name+"\n";
	    break!;
	 end;

	 class_element: $AS_CLASS_ELT := as_class.body;
	 loop until!(void(class_element));
	    -- Traverse the whole syntax definition of the class,
	    -- looking for include clauses
	    typecase class_element
	    when AS_INCLUDE_CLAUSE then 
	       inc_parent: AS_INCLUDE_CLAUSE := class_element;
	       inc_type_spec: AS_TYPE_SPEC := inc_parent.tp;
	       inc_type_name: IDENT := inc_type_spec.name;
	       parent_name: STR := as_class_name(inc_type_spec);
		  -- Emit include edge
	       if ~(include_graph.has_edge(parent_name,class_name)) then
		  include_graph.connect(parent_name,class_name);
	       end;
	    else	     -- do nothing for other clauses
	    end;
	    class_element := class_element.next;
	 end;
      end;
      -- Set up the module graph
      init_module_graph;
      -- The full graph is the union of all three graphs
      full_graph := include_graph.union(subtype_graph).union(module_graph);
      if (debug) then  
	 print_fset("Modules",modules); 
	 print_fset("Concrete",concrete);
	 print_fset("Abstract",abstract_class);
      end;
      if (debug) then #OUT+"Include graph:"+include_graph.str+"\n"; end;
      if (debug) then #OUT+"Type graph:"+subtype_graph.str+"\n"; end;
      if (debug) then #OUT+"Full graph:"+full_graph.str+"\n"; end;
   end;

   private print_fset(msg: STR, f: FSET{STR}) is
      #OUT+msg+"\n";
      loop #OUT+f.elt!+"\n"; end;
   end;
   
   private init_module_graph is
      -- Set the module inclusion graph
      go: $GET_OPTIONS := prog.get_options;
      mi: FMAP{STR,STR};
      -- Not available in $GET_OPTIONS...
      typecase go
      when BROWSER_OPTIONS then mi := go.module_inclusion; end;
      -- Add edges from classes to files
      g: DIGRAPH{STR} := #;
      -- Add edges from modules to classes
      modules := #;
      loop
	 c ::= class_table.keys!;
	 src: SFILE_ID := get_class_source(c);
	 src_filename:STR := src.file_in;
	 g.add_node(c);
	 if (mi.test(src_filename)) then
	    -- Since the file was in a module,connect the module to the class
	    mod ::= mi.get(src_filename);
	    g.add_node(mod);	-- Add the module to the graph
	    modules := modules.insert(mod);
	    g.connect(mod,c);	-- Connect the module to the class directly
	    class_to_module := class_to_module.insert(c,mod);
	 end;
      end;
      -- Form the set of modules, and add module to module
      -- edges to the module graph
      done ::= false;
      loop until!(done);
	 nodes ::= g.nodes;
	 done := true;
	 loop 
	    n ::= nodes.elt!;
	    parents ::= g.parents(n);
	    if (parents.size = 0) then
	       if (mi.test(n)) then
		  -- Add the parent module and connect.
		  parent_mod ::= mi.get(n);
		  g.add_node(parent_mod);
		  g.connect(parent_mod,n);
		  modules := modules.insert(parent_mod);
		  done := false;
	       end; -- If a parent exists in the table
	    end; -- If no parents in graph as yet
	 end; -- Loop through current nodes
      end; -- Iterating until no change in graph
      if (debug) then #OUT+"Full module graph:"+g.str+"\n"; end;
      module_graph := g;
   end;
   
   get_class_source(class_name: STR): SFILE_ID is
      -- Return the location of the source for the class "class_name"
      -- which should be in cannonical form.
      as: AS_CLASS_DEF := class_info(class_name).as;
      return(as.source);
   end;
      
   private source_str(s: SFILE_ID): STR is  
      return(s.file_in+" "+s.line_num_in);  
   end;

   private tp_class_name(tp: TP_CLASS): STR is
      -- Cannonical name for a class "tp". Ignore
      -- parameter names, and replace with underscores
      r::=tp.name.str;
      np ::= tp.params.size;
      if np=0 then return r end;
      r:=r+"{"; loop np.times!; r:=r+",".separate!("_") end;  r:=r+"}"; 
      return r 
   end;

   private as_class_name(as: AS_TYPE_SPEC): STR is
      -- Return the class name in cannonical form for an AS_TYPE_SPEC
      -- with parameter names replaced by underscores. This avoids
      -- a multiplicity of classes for different parameterizations.
      r::=as.name.str;
      p ::= as.params;
      if void(p) then return r end;
      r:=r+"{"; 
      loop until!(void(p)); r:=r+",".separate!("_");p := p.next; end;
      r:=r+"}"; 
      return r 
   end;
   
end;
-----------------------------------------------------------------------
class CLASS_INFO is
   -- Unified representation for information about a class
   
   attr tp: TP_CLASS;
   attr as: AS_CLASS_DEF;
   
   create(tp_class: TP_CLASS, as_def: AS_CLASS_DEF): SAME is 
      res ::= new;
      res.tp := tp_class;
      res.as := as_def;
--      res.impl := res.impl.nil?
      return(res);
   end;
   
end;
------------------- From the compiler ------------------------
class FRONT_END is
   -- Compiler front end to browser
   
   attr prog: PROG;
   attr exec_name: STR;
   
   create(a: ARRAY{STR}): SAME is
	-- Allocate an object and fill it with std. options
      return(new.build(a));
   end;

   create(com_file: STR): SAME is
      -- Not yet tested
      args ::= #ARRAY{STR}(2);
      args[0] := "-com";
      args[1] := com_file;
      return(new.build(args));
   end;
   
   build(a: ARRAY{STR}): SAME is
      TIME::start;
      prog:=#PROG; 
      prog.parse:=#PARSE(prog);
      prog.find_types:=#FIND_TYPES(prog);
      prog.build_type_graph:=#BUILD_TYPE_GRAPH(prog);
      prog.check_ifc_conformance:=#CHECK_IFC_CONFORMANCE(prog);
      prog.get_main_sig:=#GET_MAIN_SIG(prog);
      opt: BROWSER_OPTIONS := #BROWSER_OPTIONS(prog);
      prog.get_options:=opt;
      prog.get_options.read_env;

      common ::= prog.home+"/System/Common/Common.module";
      -- Handle the command line options and SATHER_COMMANDS
      prog.get_options.interpret(|"",common|);
      prog.get_options.interpret(a);
      -- Newly added

      prog.config:=#CONFIG_TBL(prog.home+"/System/Common/CONFIG");
      if void(prog.platforms) then
	 plt::=UNIX::get_env("SATHER_PLATFORM");
	 if void(plt) then
	    plt:=prog.config.get_str("DEFAULT_PLATFORM",0);
	 end;
	 plt:=prog.home+"/System/Platforms/"+plt;
	 prog.platforms:=prog.platforms.push(plt);
         prog.get_options.interpret(|"",plt+"/Platform.module"|); 
	 -- first element of array is ignored
      end;
      loop prog.config.read(prog.platforms.elt!+"/CONFIG"); end;

      prog.tp_tbl:=#(prog);
      prog.tp_graph:=#(prog);
      prog.tp_graph_abs_des:=#(prog);
      prog.as_tbl:=#;

	    
      prog.boot:=prog.config.get_bool("BOOT");
      prog.distributed:=prog.config.get_bool("DISTRIBUTED");
      prog.threads:=prog.config.get_bool("THREADS");
      prog.zones:=prog.config.get_bool("ZONES");
      prog.trace:=prog.config.get_bool("TRACE");
      
      sl::=UNIX::get_env(prog.config.get_str("LIBRARY",0));
      if void(sl) then
         prog.get_options.interpret(|"",prog.home+"/"+prog.config.get_str("LIBRARY",1)|);
      else
         prog.get_options.interpret(|"",sl|);
      end;
      if prog.prolix then #OUT + prog.get_options.str +"\n\n"; end;

      exec_name := opt.exec_name;
      if prog.verbose then out_msg("Preliminary",TIME::elapsed); end;
      TIME::start;

      loop
	  fn::=prog.sather_files.elt!;
	  prog.parse.parse(fn);
      end;
      if prog.verbose then out_msg("Parsing",TIME::elapsed); end;
      TIME::start;
      prog.find_types.find_types;

      prog.build_type_graph.build_graphs;

--      if prog.verbose then #OUT + "Checking conformance...\n"; end;
--      Would like to permit erroneous stuff in the browser
--      prog.check_ifc_conformance.check_ifc_conformance;

 

--      if prog.verbose then #OUT + "Finding main...\n"; end;
      prog.get_main_sig.get_main_sig(prog.main_class);

      if prog.verbose then out_msg("Finding Types etc",TIME::elapsed); end;
      -- At this point, all the tables of interest to a browser (the
      -- types, signatures, etc.) have been computed.  
      return(self);
   end;
   
   out_msg(nm: STR, time: FLTD) is
      BROWSER::initial_msg("outMessage \""+nm+" ("+time+")\"");
   end;

end;
--------------------------------------------------------------------   
class BROWSER_OPTIONS < $GET_OPTIONS is
   -- Ignore everything but the file names essentially.
    include GET_OPTIONS;

   private attr expect_exec_name: BOOL;
   readonly attr exec_name: STR;
   readonly attr use_has: BOOL;
   readonly attr parser: PARSE;

   private shared debug: BOOL := false;
   
   deb(msg: STR) is
      if debug then	 #ERR+msg  +"\n"; end;
   end;
	 
   create(p:PROG):SAME is 
      deb("Creating a browser option handler\n");
      r::=new;
      r.prog:=p;
      p.main_class:="MAIN";
      pr::=p.parse;
      typecase pr when PARSE then r.parser:=pr; end;	
      r.module_inclusion:=#;
      return r;
    end;

   private handle_files(s:STR) is
      deb("In handle_files:"+s);
      use_has := true;
      if is_filename(s) then rewind; get_files;
      else 
	 deb("Not a file name:"+s);
	 if (expect_exec_name) then
	    exec_name := s;
	    expect_exec_name := false;
	    #OUT+"Executable name:"+s+"\n";
	 elsif (s="-all") then
	    use_has := false;	-- Ignore has clauses
	 elsif (s="-debug_browser") then
	    debug := true;	-- Turn on debugging flags
	    BROWSER::debug := true;
	    UNIFIED_INFO::debug := true;
	 elsif (s="-main") then
	    expect_exec_name := true;
	 elsif (s="-external") then
	    -- Just ignore the rest -or it causes malformed errors
	    cl_nm::= next_arg;
	    cl_str ::= next_arg;
	 elsif (s="-V1.0") then
	    #ERR+"Warning! The browser may not work properly in 1.0 mode!\n";
	    parser.version_1_0 := true;
	 elsif (s="-reflect") then
	    insert_here(args_from_file(prog.home
			       +"/System/Reflection/reflection.module"),
			"Manually inserted Reflection module");
	 elsif (s="-debug_graphical") then 
	    insert_here(args_from_file(prog.home+"/System/Debug/POG.module"),
			"Manually inserted POG module");
	 elsif (s="-debug") then
	    insert_here(args_from_file(prog.home+"/System/Debug/PO.module"),
			"Manually inserted PO module");
	 elsif (s="-has" and use_has) then
	    fn::= next_arg;
	    parser.known_files := parser.known_files.insert(fn);
	    get_classes;
	    loop parser.has := parser.has.insert(classes.elt!,fn); end;
	 elsif (s[0]='-') then
	    deb("Trying to read module/platform:"+s);
	    cfs::=prog.home+"/System/Platforms/"+s.tail(s.length-1);
	    platform_module::=cfs+"/Platform.module";
	    f::=FILE::open_for_read(platform_module);
	    if f.error then
	       #OUT + "Browser ignored  option:" + s +"\n";
	    else
	       prog.platforms:=prog.platforms.push(cfs);
	       insert_here(args_from_file(platform_module),"Platform:"+s);
	    end;
	 end;
      end;
    end;
   
   handle_other_file_suffix(arg,suf: STR) is
      deb("Handling other file suffix:"+arg+"suffix:"+suf);
      if ((suf = ".c") or (suf=".o") or (suf=".a")) then 
	 return;
      else rewind; end;
   end;
      
      
end;
--------------------------------------------------------------------

-- FILE REVISION HISTORY
-- browser.sa,v
-- Revision 1.5  1995/09/29 22:40:34  holger
-- Access to IFC_TBL removed.
--
-- Revision 1.4  1995/09/23 00:34:40  holger
-- Updated Browser to 1.0.8.alpha
--
-- Revision 1.3  1995/09/18 08:26:59  gomes
-- Undid Holger's one change - should at least work with older version
-- of compiler
--
-- Revision 1.1  1995/09/13 23:39:15  gomes
-- Added the entire Browser sub-tree for 1.0.8 pre-release.
--
-- Revision 1.5  1995/07/26 22:30:28  gomes
--  * Changed toggleBoolVar to setBoolVar - much cleaner and variables can
--    now be set in sather
--  * Added two new callbacks - debugOn and flushGraph
--
-- Revision 1.4  1995/07/25 19:13:45  gomes
-- Version released with 1.0.7
--
-- Revision 1.3  1995/07/19 01:47:22  gomes
--   Commented quite copiously...
--
-- Revision 1.2  1995/07/08 05:24:54  gomes
--  * Fixed error in logic of get_class_info...
--
-- Revision 1.1  1995/07/08 05:14:07  gomes
-- Initial revision
--
-- Revision 1.2  1995/07/08 05:12:05  gomes
--  * Made get_class_info_cb return all the attributes of each routine
--  * Changed the meaning of show and hide so that hiding something will
--    definitely hide it...
--
-- Revision 1.1  1995/05/06  01:03:55  gomes
-- Initial revision
--
-- Revision 1.2  1995/04/18  19:26:35  gomes
-- Working version before compiler changes
--
-- Revision 1.1  1995/04/14  22:30:18  gomes
-- Initial revision
--
---



--      loop 
--	 mod ::= mi.keys!;
--	 if (is_module(mod)) then  
--	    g.add_node(mod);
--	    modules := modules.insert(mod);
--	    if (mi.test(mod)) then
--	       -- If the module exists in the table, it has a parent module
--	       parent_mod ::= mi.get(mod);
--	       g.add_node(parent_mod);
--	       g.connect(parent_mod,mod);
--	       modules := modules.insert(parent_mod);
--	    else
--	       -- Connect to command line
--	       g.connect(command_line,mod);
--	    end;
--	 end; -- If a module
--      end; -- Loop through potential modules
