###############################################################################
#
#	File:     fixhints.icn
#
#	Subject:  russell language support procedures
#
#	Author:   Dennis J Darland
#
#	Date:     October - Novmber, 2015
#
###############################################################################
#
# Copyright 1986-1989 Hans-Juergen Boehm, Alan J. Demers, Kumar Srikantan,
# Vernon Lee, and Lucy Hederman.
# Copyright Digital Equipment Corporation & INRIA 1988, 1989.
# Copyright (c) 1990-1993 by Xerox Corporation.  All rights reserved.
#
# This material is provided as is, with no warranty expressed or implied.
# Any use is at your own risk.
#
# Permission is hereby granted to copy this compiler for any non-commercial
# purpose, provided the above notices are retained on all copies.  Further
# restrictions apply to the DEC/INRIA BigNum package.  These are stated in
# the file runtime/BigNum/doc/bnbody.tex.
#
# This work uses the BigNum package developed jointly by INRIA and
# Digital PRL.  It has been modified by Hans-J. Boehm in August 1990
# and February 1993 at Xerox PARC.  When you receive this software,
# please send mail to librarian@prl.dec.com to inform them that you
# have a copy of the package.
###############################################################################
#
#   NOTE From Dennis J. Darland (11/2/2015)
#
#   I obtained the "c" language source code for "russell" copyrighted above
#   in the 1990's. I have made efforts to get it to work over the years, but
#   always failed. It has many hardware and OS dependancies. Now (October 2015
#   forward, I am tring to port to the language "Unicon". Practically every
#   line of code will need to be changed, as someing as simple as the
#   assignment operator is different. Also I will not use the BigNum package
#   mentioned above. Also I am doing this not for profit, and am sharing
#   freely. I am not at all confident that I will get it working well, but
#   believe in open source, so am sharing my work as I make progress.
#   Unicon is also much more portable.
#
###############################################################################


$include "defs.icn"
$include "global_vars.icn"



# define DEBUG
# define TRACE
# undef TRACE

# ifdef TRACE
#   define IFTRACE(x) x
# else
#   define IFTRACE(x)
# endif
# include <stdio.h>
# include "parm.h"

# include "stree/ststructs.mh"

# include "pass1/stt/sttdefs.h"

# include "sigs.h"

# include "../pass3/is_local.h"

# extern unsigned stplinks[];

# extern FILE * unparse_file;

#
# fixhints(sig, sig2)
#
#   Returns a structure which is a copy of the first signature except
# that code generation information is adjusted to be consistent with that
# given by the second signature.
#   Code generation info is not meaningful if the two signatures don't match.
#   Inline code is preserved only if it is (pointer-) identical in the
# two signatures.
#   A NIL value for sig2 is treated as an unknown signature.
#

procedure fixhints(sig,sig2)
    local mod_flag := FALSE; # One of the descendants was modified
    local in_line_differs, special_differs, constr_differs
    local slink_known_differs
    local tmpcopy # temporary version of result
    local s;
    local p, r
    local ncopy             # copy to be returned
    local i
    local c
    local j
    local result

#   tmpcopy[MAXFIELDS];# temporary version of result

    tmpcopy := []   # CONFUSED DJD - don't understand copy logic

    if (sig = ERR_SIG | /sig  | /sig2  ) then {
	return(sig)
    }

    case ( sig . kind ) of {
	VALSIGNATURE:
	    return(sig);
	VARSIGNATURE:
	    return(sig);

	TSCOMPONENT:
	    {
		if (sig2 . kind ~= TSCOMPONENT) then return(sig)
		p := fixhints(sig . tsc_signature, sig2 . tsc_signature)
		if (p ~= sig . tsc_signature) then {
		    ncopy := copynode(sig)
		    ncopy . tsc_signature := p
		    return(ncopy)
		} else {
		    return(sig)
		}
	    }
	DEFCHARSIGS:
	    {
		# Delete the exception information.
		# This so unlikely to arise ...
		if (\sig . dcs_exceptions) then {
		    p := copynode(sig)
		    p . dcs_exceptions := nil
		}
		return(p)
	    }
	TYPESIGNATURE:
	    {
		if (/sig2) then {
		    ncopy := copynode(sig)
		    # should be locked ...
		    ncopy . ts_simple_type := FALSE
		    ncopy . ts_const_code := nil
		    ncopy . ts_string_code := nil
		    ncopy . ts_element_code := nil
		    return(ncopy)
		}
		if (sig2 . kind ~= TYPESIGNATURE) then return(sig)
		p := sig . ts_clist
		r := sig2 . ts_clist
		i := 0
		j := length(p)
		# get sufficiently large chunk of memory to temporarily copy
		# the list, thus minimizing number of allocations.
		temp1 := t.lh_first
		temp2 := r.lh_first
		while \temp1 & \temp2 do {
		    q := temp1.cn_hd_field
		    r := temp2.cn_hd_field
		    s[i] := fixhints(q, t)
		    # should be locked but ...
		    if(s[i] ~= q) then {
			mod_flag := TRUE
		    }
		    i+:= 1
		    temp1 := temp1.cn_tl_field
		    temp2 := temp2.cn_tl_ield
		}
		if (mod_flag ~= FALSE) then {
		    # convert the temporary copy in s to a real list structure,
		    # put it into a new type signature node, and return it
		    result := emptylist()
		    every i to j do {
			addright(result,s[i])
		    }
		    if (j > MAXFIELDS) then free(s)
		    ncopy := copynode(sig)
		    # again, should be locked ...
		    ncopy . ts_clist := result
		} else {
		    if (j > MAXFIELDS) then free(s)
		    if (sig . ts_simple_type ~= FALSE &
			(sig2 . ts_simple_type ~= FALSE) |
			sig . ts_const_code ~= sig2 . ts_const_code  |
			sig . ts_string_code ~= sig2 . ts_string_code |
			sig . ts_element_code ~= sig . ts_element_code) then  {
			    ncopy := copynode(sig)  # again ..
			} else {
			    return(sig)
			}
		}
#           define make_consistent(field,val) \
    if (sig . field ~= sig2 . field) then {ncopy . field := val00}
		make_consistent(ts_simple_type, FALSE)
		make_consistent(ts_const_code, nil)
		make_consistent(ts_string_code, nil)
		make_consistent(ts_element_code, nil)
		return(ncopy)
	    }
	FUNCSIGNATURE:
	    {
		if (/sig2) then {
		    ncopy := copynode(sig)  # should be locked ...
		    ncopy . fsig_inline_code := nil
		    return(ncopy)
		}
		if (sig2 . kind ~= FUNCSIGNATURE) then return(sig)
		p = fixhints(sig . fsig_result_sig, sig2 . fsig_result_sig)
		if (sig . fsig_inline_code ~= sig2 . fsig_inline_code)
		then in_line_differs := TRUE
		else in_line_differs := FALSE
		if (sig . fsig_special ~= sig2 . fsig_special)
		then special_differs := TRUE
		else special_differs := FALSE
		if (sig . fsig_construction ~= sig2 . fsig_construction)
		then constr_differs := TRUE
		else constr_differs := FALSE
		if (sig . fsig_slink_known ~= sig2 . fsig_slink_known)
		then slink_known_differs := TRUE
		else slink_known_differs := FALSE

		if (p ~= sig . fsig_result_sig | in_line_differs ~= FALSE |
		    special_differs ~= FALSE |
		    constr_differs ~= FALSE  |
		    slink_known_differs ~= FALSE) then {
			ncopy := copynode(sig)
		    } else {
			ncopy := sig
		    }
		if (p ~= sig . fsig_result_sig) then {
		    ncopy . fsig_result_sig :=  p
		}
		if (in_line_differs ~= FALSE) then {
		    ncopy . fsig_inline_code := nil
		}
		if (special_differs ~= FALSE) then {
		    ncopy . fsig_special := NOT_SPECIAL
		}
		if (constr_differs ~= FALSE) then {
		    ncopy . fsig_construction := nil
		}
		if (slink_known_differs ~= FALSE) then {
		    ncopy . fsig_slink_known := FALSE
		}
		return(ncopy)
	    }
    }
end

#
# Return the integer constant represented by the expression e,
# if it can be easily determined.  Return UNKNOWN otherwise.
# Should be perhaps be replaced by is_int_const.
#
# define UNKNOWN -1

procedure int_value(orig_e)
    local sel_tp, arg1, arg2
    e := fix_p(e)
    case (e . kind) of {
	LETTERID:
	    if (e . id_def_found ~= FALSE & / (e . sel_type) &
		e . id_last_definition . kind = DECLARATION &
		e . id_last_definition . post_num < e . post_num) then {
		    # Dont follow recursive declarations ...
		    return(int_value(e . id_last_definition . decl_denotation))
		} else {
		    return(UNKNOWN)
		}
	UQSTR:
	    {
		sel_tp := e . sel_type
		if (sel_tp . kind ~= LETTERID |
		    (sel_tp . id_def_found = FALSE) |
		    (is_declared_by(sel_tp,id_Integer . id_last_definition)=FALSE )) then {
			return(UNKNOWN)
		    } else {
			# Integer constant
			return(e . str_string)
		    }
	    }
	APPLICATION:
	    {
		if (e . ap_operator . kind ~= OPRID |
		    / (e . ap_operator . sel_type)) then {
			return(UNKNOWN)
		    } else {
			sel_tp := e . ap_operator . sel_type
			if (sel_tp . kind ~= LETTERID |
			    (sel_tp . id_def_found = FALSE) |
			    (is_declared_by(sel_tp,id_Integer . id_last_definition) = FALSE)) then {
				return(UNKNOWN)
			    }
			if (e . ap_operator . id_str_table_index = indx_plus) then {
			    arg1 = int_value(first(e . ap_args))
			    arg2 = int_value(last(e . ap_args))
			    if (arg1 ~= UNKNOWN & arg2 ~= UNKNOWN) then {
				return(arg1 + arg2)
			    } else {
				return(UNKNOWN)
			    }
			} else {
			    # Should check for other operators here
			    return(UNKNOWN)
			}
		    }
	    }

	default:
	    return(UNKNOWN)
    }
end

#
# Set various special fields in the type signature sig to reflect
# the fact that it represents a type returned by the built-in
# Array operation.  The arguments to the Array application are
# size and etype.
# This assumes argument signatures are known.
#
procedure fix_array_sig(sig, size, etype)
    local size_val := int_value(size)
    local e_sig := sig_structure(etype . signature)
    local e_V_sig
    local e_New_sig
    local comp_id
    local std_e_V;        # Element type has standard V function
    local std_e_New;      # Element type has standard New
    local ptr_e_New;      # Element type has pointer New
    local tp

    if (sig = ERR_SIG | e_sig = ERR_SIG |
	e_sig . kind ~= TYPESIGNATURE) then return
    if (size_val = UNKNOWN | size_val > MAX_SP_VAL) then {
	size_val := 0
    }
    e_V_sig := getcomp(e_sig, id_ValueOf, nil, nil, nil, nil, FALSE)
    if (e_V_sig = ERR_SIG) then return
    e_New_sig := getcomp(e_sig, id_New, nil, nil, nil, nil, FALSE)
    if (e_New_sig = ERR_SIG) then return
    if (/e_V_sig  | /e_New_sig) then {
	return
	# Error may not yet have been caught, but it will be
    }
    if (special_tp(e_V_sig . fsig_special) = STD_VALUEOF &
	special_val(e_V_sig . fsig_special) = 1)
    then std_e_V := TRUE
    else std_e_V := FALSE

    tp := special_tp(e_New_sig . fsig_special);
    if (tp = STD_NEW & special_val(e_New_sig . fsig_special) = 1)
    then std_e_New := TRUE
    else std_e_New := FALSE
    if (tp = UNION_NEW | tp = PROD_NEW | (tp = PTR_NEW &
		   special_val(e_New_sig . fsig_special) = 1))
    then ptr_e_New := TRUE
    else ptr_e_New := FALSE
    temp := sig . ts_clist . lh_first
    while \temp do {
	s := temp.cn_hd_field
	if (s . kind = TSCOMPONENT) then {
	    comp_id := s . tsc_id . id_str_table_index
	    if (comp_id = indx_New) then {
		if (std_e_New ~= FALSE) then {
		    s . tsc_signature . fsig_special :=
			special(ARRAY_STD_NEW, size_val)
		} else if (ptr_e_New ~= FALSE) then {
		    s . tsc_signature . fsig_special :=
			special(ARRAY_PTR_NEW, size_val)
		}
	    } else if (comp_id = indx_ValueOf) then {
		if (std_e_V ~= FALSE) then {
		    s . tsc_signature . fsig_special :=
			special(ARRAY_VALUEOF, size_val)
		}
	    } else if (comp_id = indx_size) then {
		s . tsc_signature . fsig_special :=
		    special(ARRAY_SIZE, size_val)
	    } else if (comp_id = indx_subscr) then {
		if (s . tsc_signature . fsig_result_sig . kind  = VARSIGNATURE) then {
		    s . tsc_signature . fsig_special :=
			special(ARRAY_VAR_SUB, size_val)
		} else {
		    s . tsc_signature . fsig_special :=
			special(ARRAY_VAL_SUB, size_val)
		}
	    }
	}
	temp := temp.cn_tl_field
    }
end

# Clear all slink_known fields in the function signature or
# recursively in the components of the type signature.
procedure clear_slink_known(orig_sig)
    local p, q, sig

    if (orig_sig = ERR_SIG | /orig_sig) then {
	return
    }
    sig := fix_p(orig_sig)

    case ( sig . kind ) of {
	LETTERID:
	    if ( / (p . id_last_definition)) then {
		rpt_info("clear_slink_known: unresolved id reference")
	    }
	OPRID:
	    if ( / (p . id_last_definition)) then {
		rpt_info("clear_slink_known: unresolved id reference\n")
	    }
	# We claim that signatures bound to identifiers cant contain
	# any interesting optimization info.  Thus there's none to be
	# cleared.
	VARSIGNATURE:
	    {}
	VALSIGNATURE:
	    {}
	SIGNATURESIG:
	    {}

	TYPESIGNATURE:
	    {
		p := sig . ts_clist
		temp := p.lh_first
		while \temp do {
		    q := temp.cn_hd_field
		    if (q . kind = TSCOMPONENT) then {
			clear_slink_known(q . tsc_signature);
		    }
		    temp := temp.cn_tl_field
		}
	    }
	 FUNCSIGNATURE:
	    sig . fsig_slink_known := FALSE
    }
end

# Return a copy of sig with all fsig_construction fields in the
# signature cleared.
procedure clear_construction(orig_sig)
    local p
    local q
    local modified := FALSE
    local new_comp_list := emptylist()
    local new_comp

    if (orig_sig = ERR_SIG | /orig_sig ) then {
	return(sig)
    }
    sig := fix_p(orig_sig)
    case ( sig . kind ) of {
	 LETTERID:
	    # We claim that signatures bound to identifiers cant contain
	    # any interesting optimization info.  Thus there's none to be
	    # cleared.
	    return(sig)
	 OPRID:
	    # We claim that signatures bound to identifiers cant contain
	    # any interesting optimization info.  Thus there's none to be
	    # cleared.
	    return(sig)

	 VARSIGNATURE:
	    return(sig)
	 VALSIGNATURE:
	    return(sig)
	 SIGNATURESIG:
	    return(sig)
	 TYPESIGNATURE:
	     {
		 temp := sig . ts_clist .lh_first
		 while \temp do {
		     s := temp.cn_hd_field
		     if (s . kind = TSCOMPONENT) then {
			 p := clear_construction(s . tsc_signature);
			 if (p ~= s . tsc_signature) then {
			modified := TRUE
			new_comp := copynode(s)
			new_comp . tsc_signature := p
			addright(new_comp_list, new_comp)
		    } else {
			addright(new_comp_list, s)
		    }
		} else if (s . kind = DEFCHARSIGS) then {
		    if (\ (s . dcs_exceptions)) then {
			# We punt
			modified := TRUE
			new_comp := copynode(s)
		        new_comp . dcs_exceptions := nil
			addright(new_comp_list, new_comp)
		    } else {
			addright(new_comp_list, s)
		    }
		} else {
		    rpt_info("clear_construction: bad typesignature")
		}
		    temp := temp.cn_tl_field
		}
	      if (modified ~= FALSE) then {
		p := copynode(sig)
		p . ts_clist :=  new_comp_list
		return(p)
	      } else {
		vfree(new_comp_list)
		return(sig)
	      }
	    }

	 FUNCSIGNATURE:
	     {
		 p := clear_construction(sig . fsig_result_sig)
		 if (p ~= sig . fsig_result_sig |
		     \ (sig . fsig_construction)) then {
			 q := copynode(sig)
			 q . fsig_result_sig := p
			 q . fsig_construction := nil
			 return(q)
		     } else {
			 return(sig)
		     }
	     }
     }
end

