------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1994 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 NAMEMAP is
   -- Mapping $OB -> STR, with special knowledge about compiler
   -- entities' equality conventions.  In particular, SIGs do not
   -- use object equality.

   include FMAP{$OB,STR};

   key_eq(k1,k2:$OB):BOOL is
      -- See comments in fmap.sa for the subtleties of redefining
      -- this.
      typecase k1 
      when STR then
	 typecase k2
	 when STR then return k1=k2
	 else return false 
	 end;
	 --	when SIG then
	 --	   typecase k2
	 --	   when SIG then return k1=k2
	 --	   else return false 
	 --	   end;
	 --	when $AM_EXPR then
	 --	   typecase k2
	 --	   when $AM_EXPR then return k1 = k2 
	 --	   else return false 
	 --	   end;
      else return SYS::ob_eq(k1,k2);
      end
   end;
end;

class NAMESPACE is
   -- An object which is a C namespace.

   attr map:NAMEMAP;
   attr set:FSET{STR};
   attr counter:INT;
   attr uniques:FMAP{STR,INT};

   create:SAME is
      r::=new;
      r.map:=#;
      r.set:=#;
      r.counter:=0;
      r.uniques:=#;
      return r;
   end;

   is_taken(s:STR):BOOL is
      return set.test(s);
   end;

   insert(ob:$OB,nm:STR) is
      map:=map.insert(ob,nm);
      set:=set.insert(nm);
   end;

   get(ob:$OB):STR is
      return map.get(ob);
   end;

   with_prefix(s:STR):STR is
      -- Starts at '1' each time, to try to minimize the extent
      -- of namespace changes between compiles.
	
      -- A special table is kept to avoid quadratic behavior.
      res:STR;
      i::=uniques.get(s);
      if void(i) then i:=0; end; -- Pretend you don't know it already is
      loop 
	 i:=i+1;
	 res:=s+i;
	 until!(~set.test(res));
      end;
      uniques:=uniques.insert(s,i);
      return res;
   end;

   unique_with_prefix(s:STR):STR is
      -- Generate a unique name.  This one doesn't start trying
      -- suffixes at '1', so it won't be quadratic in finding names.
      -- Use this for names that don't make it into header files,
      -- so that recompilations won't occur.
      res:STR;
      loop
	 counter:=counter+1;
	 res:=s+counter;
	 until!(~set.test(res));
      end;
      set:=set.insert(res);
      return res;
   end;

   next_unique_with_prefix(s:STR):STR is
      -- Gets next unique name.  This one doesn't start trying
      -- suffixes at '1', so it won't be quadratic in finding names.
      -- Note that the returned name is not inserted! In general
      -- use unique_with_prefix instead.
      
      res:STR;
      loop
	 counter:=counter+1;
	 res:=s+counter;
	 until!(~set.test(res));
      end;
      return res;
   end;
   
   forbid(s:STR) is
      set:=set.insert(s);
   end;

end;

class MANGLE is
   include CS_COMPONENT;
   -- An object that manages the C namespace.  All requests for a
   -- C identifier should come through this.

   private attr namespaces:FMAP{$OB,NAMESPACE};
   private attr global_space:NAMESPACE;
   private attr used_by_local:FSET{STR};
   private attr max_identifier_length: INT;
   -- This is set to cgen.max_identifier_length - 8. 
   -- It must allow for some slack in appending integers onto the end.
   private attr append_hash_to_idents:BOOL; -- If true, append a hash
   -- value to global identifiers
   
   attr forbidden:FSET{STR};
   -- Strings which may not be used as identifiers

   create(p:PROG):SAME is
      res::=new;
      res.prog:=p;
      res.namespaces:=#;
      res.forbidden:=#;
      res.used_by_local:=#;
      -- This should be eventually changed to use the config file
      -- To allow for adding on uniquifying ints at the end
      back: $BACK_END := p.back_end;
      typecase back
      when CGEN then 
	 -- This file is meant to be used only with CGEN.
	 res.max_identifier_length := back.max_identifier_length;
	 -- If -pretty is turned on, don't append string hashes.
	 res.append_hash_to_idents := ~back.pretty;
      end;
      res.global_space:=res.space(void);

      -- Insert names which must not be taken.
      l::=#SYSTEM_LEX(p.home+"/System/FORBID");
      loop res.forbid(l.elt!); end;

      -- After bootstrap past 1.0.5, remove
      res.forbid("self");

      return res;
   end;

   forbid(s:STR) is forbidden:=forbidden.insert(s); end;
   -- make sure this identifier never gets used

   space(ns:$OB):NAMESPACE is
      -- The namespace associated with some object.  If it
      -- doesn't exist yet, make one.

      -- void specifies the global namespace... which we key
      -- to self (before, 'self' of some external object was passed in)
      if void(ns) then ns:=self end;

      r::=namespaces.get(ns);
      if void(r) then 
	 r:=#NAMESPACE;
	 namespaces:=namespaces.insert(ns,r);
      end;
      return r;
   end;

   dispose_namespace(ns:$OB) is
      -- The namespace 'ns' isn't going to be used in the future,
      -- so it's okay to get rid of it now.

      namespaces:=namespaces.delete(ns);
   end;

   force_mangle(ob:$OB, s:STR, ns:$OB) pre ~void(ob) is
      -- see to it that a particular object gets a particular name.
      -- if this is not possible, that is an error.  'ns' is the
      -- namespace to use.

      sp::=space(ns);
      x:STR:=sp.get(ob);
      if void(x) then
	 if sp.is_taken(s) then
	    warning("Name "+s+" already in use (same name in more than one external class?)");
	 end;
	 --if forbidden.test(s) then
	 --	warning("Name \""+s+"\" is in System/FORBID");
	 --end;
	 sp.insert(ob,s);
      elsif x/=s then
	 barf("Name "+s+" could not be assigned by the mangler, already had the name: "+x);
      end;
   end;

   genlocal(ns:$OB):STR is
      -- generate a unique identifier used for intermediate results
      name::=space(ns).unique_with_prefix("L");
      used_by_local:=used_by_local.insert(name);
      return name;
   end;

   genother(ns:$OB):STR is
      -- generate a unique identifier for anything
      return space(ns).with_prefix("other");
   end;

   mangle(ob,ns:$OB):STR pre ~void(ob) is
      -- Generate unique id that C will be happy with for each
      -- unique $OB.  Truncates at maxlen chars and then puts in number
      -- in rightmost part to ensure is unique, if necessary.  Also
      -- drops any non-alphanumerics.
      if prog.temp_option_fast_identifiers then
	 -- This should eventually be tied to -output_C when we believe that it works
	 typecase ob
	 when TP_CLASS then
	    if ob.is_c then
	       -- May have to mangle in a special way
	       cname:STR := ob.impl.C_name_val;
	       if ~void(cname) then
		  force_mangle(ob,cname,ns);
		  return cname;
	       end;
	    end;
	    return fast_mangle(ob,ns);
	 when IDENT  then
	    return simple_mangle(ob,ns); -- Attributes are special
	 else
	    return fast_mangle(ob,ns);
	 end;
      else
	 return simple_mangle(ob,ns);
      end;
   end;
   
   fast_mangle(ob,ns:$OB):STR pre ~void(ob) is
      sp ::= space(ns);
      res ::= sp.get(ob);
      if void(res) then
	 res := FAST_IDENTIFIER::next;
	 sp.insert(ob,res);
      end;
      return res;
   end;

   private simple_mangle(ob:$OB,ns:$OB): STR pre ~void(ob) is
      -- Generate unique id that C will be happy with for each
      -- unique $OB.  Truncates at maxlen chars and then puts in number
      -- in rightmost part to ensure is unique, if necessary.  Also
      -- drops any non-alphanumerics.
      -- Prepend the prefix "prefix"
      sp::=space(ns);
      res::=sp.get(ob);
      if void(res) then
	 s:STR;
	 is_local:BOOL:=false;
	 is_attribute:BOOL:=false;
	 typecase ob    
	 when SIG then
	    s:=ob.tp.str.append("_",ob.name.str);
	    if ~void(ob.args) then
	       -- s := s.append(ob.args.size.str); -- ben
	       -- This distinguishes between foo(INT) and foo:INT. 
	       loop s:=s.append("_",ob.args.elt!.str); end;
	    end;
	    if ~void(ob.ret) then s:=s.append("r",ob.ret.str); end;
	    --if ob.name.str="doo" then
	    --    #OUT + "Mangled "+ob.str+" to "+s
	    --         + " ob id = "+SYS::id(s)+" ns = "+SYS::id(ns)+'\n';
	    --end;
	 when INT then		-- used for builtin locals
	    -- Must be careful with locals; they can
	    -- potentially shadow globals, so have to
	    -- check that specially.
	    s:=sp.unique_with_prefix("L");
	    is_local:=true;
	 when AM_LOCAL_EXPR then
	    -- Must be careful with locals; they can
	    -- potentially shadow globals, so have to
	    -- check that specially.
	    if ~void(ob.name) then s:=ob.name.str;
	    else s:=sp.unique_with_prefix("L");
	    end;
	    is_local:=true;
	 when TP_CLASS then 
	    if ob.is_c then
	       -- may have to mangle in a special way if
	       -- an external C type has ``C_name'' attribute
	       cname:STR := ob.impl.C_name_val;
	       if ~void(cname) then
		  force_mangle(ob,cname,ns);
		  return cname;
	       end;
	    end;
	    -- "normal" case
	    s:=ob.str;
	 when TP_ROUT then s:=ob.str;
	 when TP_ITER then s:=ob.str;
	 when AM_BND_CREATE_EXPR then s:="bound";
	 when STR then s:=ob+"_str";
	 when IDENT then 
	    s:=ob.str;
	    is_attribute:=true;
	 when AM_SHARED_EXPR then 
	    s:=ob.class_tp.str+'_'+ob.name.str;
	 when AM_LOOP_STMT then
	    s:="after_loop";
	 when AM_PAR_STMT then
	    s:= "pS_simple_par_ob";
	 when AM_FORK_STMT then
	    s:= "pS_fork_handler";	    
	 when AM_AT_EXPR then
	    s:= "pS_at_handler";
	 when AM_STR_CONST then s:=ob.bval;
	 else			-- pick a default name
	 end;
	 if void(s) then 
	    res:=sp.with_prefix("noname");
	 else
	    if prog.debug_mangle then #ERR+"Staring with:"+s; end;
	    tmp::=#FSTR;	-- Use an FSTR for speed here
	    loop c::=s.elt!;
	       case c
	       when 'a','b','c','d','e','f','g',
			'h','i','j','k','l','m',
			'n','o','p','q','r','s','t',
			'u','v','w','x','y','z',
			'0','1','2','3','4','5','6',
			'7','8','9','_',
			'A','B','C','D','E','F','G',
			'H','I','J','K','L','M',
			'N','O','P','Q','R','S','T',
			'U','V','W','X','Y','Z' then
		  tmp:=tmp+c;
	       when '$' then tmp:=tmp+'d';
	       when '!' then tmp:=tmp+'b'
	       else		-- don't put anything else in
	       end;
	    end;
	    -- make sure there's something left
	    if tmp.length = 0 then tmp := tmp+"name" end;

	    -- make sure it starts with a letter
	    case tmp[0]
	    when '0','1','2','3','4','5','6','7','8','9','_' then
	       tmp:=#FSTR+"S"+tmp;
	    else
	    end;
	    res:=tmp.str;
	    orig_res_len:INT := res.size;
	    max_usable_identifier_length:INT := max_identifier_length - 8;
	    -- Truncate if too long
	    if ~is_attribute 
		     and ~is_local 
	       -- Attributes and locals will usually be unique anyhow.
	       -- and we don't want to mess them up unnecessarily.
		     and append_hash_to_idents 
	       -- Or if -pretty is on, don't mess up names
		     and orig_res_len > max_usable_identifier_length
	       -- and there's no point in adding a hash value to shorter names
	    then
	       -- Add the hash value of the whole string onto the end of the
	       -- truncated string. This should avoid most conflicts, since the
	       -- identifier (as a whole) should be unique
	       reshash:STR := res.hash.abs.str; 
	       maxprehash:INT := max_usable_identifier_length - 10;
	       if orig_res_len>maxprehash then res:=res.head(maxprehash); end;
	       res := res+reshash;
	    else
	       -- Truncate identiers anyway, if needed
	       if orig_res_len>max_usable_identifier_length then 
		  res:=res.head(max_usable_identifier_length);
	       end;
	    end;
	    -- But if the hash wasn't enough.... make sure it's unique anyway
	    loop
	       while!(sp.is_taken(res) or forbidden.test(res)
		      or (is_local and global_space.is_taken(res))
		      or (~is_local and ~is_attribute and 
			  used_by_local.test(res)));
	       -- not unique, better mangle more
	       res:=sp.with_prefix(res.head(max_usable_identifier_length.min(res.length)));
	    end;
	 end;
	 sp.insert(ob,res);
	 if is_local then
	    used_by_local:=used_by_local.insert(res);
	 end;	
      end;
      if prog.debug_mangle then #ERR+" to:"+res+"\n"; end;
      return res;
   end;

   
   Cify(c:CHAR):STR is
      -- return an escaped version of c suitable for C.
      res::="";
      case c
      when 'a','b','c','d','e','f','g',
	       'h','i','j','k','l','m',
	       'n','o','p','q','r','s','t',
	       'u','v','w','x','y','z',
	       '0','1','2','3','4','5','6',
	       '7','8','9',
	       'A','B','C','D','E','F','G',
	       'H','I','J','K','L','M',
	       'N','O','P','Q','R','S','T',
	       'U','V','W','X','Y','Z',
	       '!','@','#','$','%','^','&',
	       '*','(',')','-','=','+',
	       '|',':',';','`','~','_',' ',
	 ',','.','<','>','/','?','[',
				   ']','{','}' then -- an acceptable character
	 res:=res+c;

	 -- Some versions of gcc can't do this so we won't either,
	 -- for now.  Alex Cozzi is the only one who reported a
	 -- problem with this, but don't take chances for now.

	 -- when '\a' then         
	 --    res:=res+"\\a";    

      when '\b' then
	 res:=res+"\\b";
      when '\f' then
	 res:=res+"\\f";
      when '\n' then
	 res:=res+"\\n";
      when '\r' then
	 res:=res+"\\r";
      when '\t' then
	 res:=res+"\\t";
      when '\v' then
	 res:=res+"\\v";
      when '\\' then
	 res:=res+"\\\\";
      when '\'' then
	 res:=res+"\\'";
      when '\"' then
	       res:=res+"\\\"";
      else			-- must give octal
	 oc:STR:=c.int.octal_str;
	 oc:=oc.substring(2,oc.length-2);
	 res:=res+'\\'+oc;
      end; -- case
      return res;
   end;

   Cify(arg:STR):STR is
      -- transform a string into a '\' escaped version suitable for C.

      res::=#FSTR;
      loop res:=res+Cify(arg.elt!);
      end;
      return res.str;
   end;


end; -- MANGLE

class FAST_IDENTIFIER is
   -- Generate unique identifiers for C as fast as possible.
   -- A hopefully unique prepended "U" avoids needing to look things up in
   -- the table of forbidden identifers.

   private shared f:FSTR;

   next:STR is
      if void(f) then
         f:=#(10);
         f:=f.push('Q');
	 f:=f.push('Q');
         f:=f.push('a');
      else
         loop
            d::=2.up!;  -- Assume we'll never overflow 10 characters
            case f[d]
            when 'a','b','c','d','e','f','g','h','i','j','k','l','m',
                 'n','o','p','q','r','s','t','u','v','w','x','y',
                 'A','B','C','D','E','F','G','H','I','J','K','L','M',
                 'N','O','P','Q','R','S','T','U','V','W','X','Y' then
                f[d]:=CHAR::from_ascii_int(f[d].ascii_int+1);
                break!;
            when 'z' then
	       f[d]:='A';
                break!;
            when 'Z' then
                f[d]:='a';
                if d = f.size-1 then 
                   f:=f.push('a');
                   break!;
                end;
            end;
         end;
      end;
      return f.str;
   end;

end;
