###############################################################################
#
#	File:     accessible.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"

#DJDSTOP
#define DEBUG

#define VERBOSE
#undef VERBOSE

#
   Sets the decl_needed, mp_needed, and fc_body_needed fields 
  in subtrees of p which might be executed if control reaches p.
  Adds object files to link list if nested entry points are
  directly referenced.
   Set the ID_IMPORTED and VAR_NONTR_REF of decl_special fields.
   Set id_forward_ref and decl_can_be_refd fields.
   Requires that level fields for DECLARATION and MODPRIMARY nodes,
  as well as ar_static_level fields for function constructions be set
  correctly.
 

# include "parm.h"
# include <stdio.h>
# include "stree/ststructs.mh"
# include "codeutil.h"
# include "../runtime/runtime.h"
# include "pass3/is_local.h"
# include "pass4/sigs.h"

# ifdef VERBOSE
#   define IFVERBOSE(x) x
# else
#   define IFVERBOSE(x) 
# endif

extern FILE * Voutfile;

extern FILE * unparse_file;

extern NODE * insrtptr;     # Pointer to user program 

extern boolean has_externs;  # Program contains REXTERN nodes 

extern boolean Tflag; # generate trace code 

extern boolean Gflag; # generate intermediate code 

extern boolean Vflag; # verbose 

extern boolean Oflag; # optimize 

extern unsigned indx_put; # should be sttrelptr ... 

static int Clevel = -1;      # Current nesting level 

extern void add_objfile();

extern boolean is_int_const();

extern char * rindex();

# Determine whether the rhs of a declaration needs to be evaluated 
# due to potential side effects, or due to possible reference      
# by a separately compiled program.                                
#DJDSTART
procedure eval_decl(p)
local decl_den_kind, decl_sig_kind, decl_sig

    if (has_externs = TRUE & not(is_descendant(p, insrtptr))) then {
	# Outside user program.  May be referenced by -c compilations. 
	return(TRUE)
    }
    decl_sig := p . decl_signature
    if (/decl_sig) then {
	decl_sig := declsig(p)
	if (declerr ~= SUCCESS) then return(TRUE)
    } else if (decl_sig = ERR_SIG) then {
	return(TRUE)
    }
    decl_sig_kind := decl_sig . kind;
    decl_den_kind := p . decl_denotation . kind;
    if (decl_sig_kind = VARSIGNATURE |
	decl_sig_kind = VALSIGNATURE |
	decl_sig_kind = FUNCSIGNATURE &
	 decl_den_kind ~= FUNCCONSTR &
	 (impure(p . decl_signature) |
	 calls_put(p . decl_denotation)) |
	decl_sig_kind = TYPESIGNATURE &
	calls_put(p . decl_denotation)) then {
	    return(TRUE)
    } else {
	    return(FALSE)
    }
end
# Add the object file containing the named entry point 
procedure add_extracted_objfile(entry_name)
    local filename, p,q
    # Copy starting after first underscore char 
    loc1 := find("_",entryname)
    loc2 := find(".",filename)
    q = filename;
    map(filename, "/",".")
    p := filename || p[loc1:loc2] || q || ".o"
    rpt_info("add_extracted_objfile" || filename )
    if filename ~== "" then add_objfie(filename)
end
#DJDSTOP

# Mark the body of the function construction p as evaluable at run-time 
body_accessible(p)
register NODE * p;
{
    int Olevel = Clevel;

    if (p . fc_body_needed) then return TRUE
    Clevel = p . ar_static_level
    p . fc_body_needed = TRUE
    accessible(p . fc_body)
    Clevel = Olevel
return TRUE
}

# Mark an identifier and its declaration as accessible.  Set ID_IMPORTED 
# if appropriate.  VAR_NONTR_REF is not affected.                        
id_accessible(p)
NODE *p;
{
    if (!is_int_const(p)) then {
	if (p . sel_type != NIL) then {
	    accessible(p.sel_type);
	} else {
	    NODE * def = p . id_last_definition;

	    # Clevel will be reset from level fields in DECLARATION 
	    # and MODPRIMARY.                                       
	    accessible(def);
	    if (def . kind == DECLARATION && def . level != Clevel) then {
		def . decl_special |= ID_IMPORTED;
	    }
	}
    }
}

# Mark the expression p as needed at run-time
#DJDSTART 
procedure accessible(p_orig)
    local  v, Olevel, sig, s, temp, temp1, temp2, arg1, argcount, maxlen

    if (/p_orig )  then return TRUE
    if not(has_field(p_orig,"k-ind")) then
	   p := p_orig.cn_hd_field # ADDED DJD
    else
	p := p_orig
    if (/p )  then return TRUE
    if (p.kind = PARAMETER) then return TRUE
    if (p.kind ~= DECLARATION ) then 
	if ( p.signature.kind = SIGNATURESIG) then {
	    # Evaluation of signatures is trivial.  
	    return TRUE
	}

    case ( p . kind ) of {

	DECLARATION:
	    {
		if (p . decl_needed = FALSE) then 
		    {
			Olevel := Clevel
			p . decl_needed := TRUE
			Clevel := p . level
			accessible(p . decl_denotation)
			Clevel := Olevel
		    }
	    }
	BLOCKDENOTATION:
	    {
		# mark forward declarations etc. 
		if \ p . bld_declaration_list then {  # ADDED DJD
		    label_decls(p . bld_declaration_list)
		    temp := p.bld_den_seq.lh_first
		    while \temp do {
			v := temp.cn_hd_field
			accessible(v)
			temp := temp.cn_tl_field
		    }
		    # declarations are likely to not be accessible due 
		    # to inline expansion.
		    temp := p . bld_declaration_list.lh_first
		    while \temp do { 
			v := temp.cn_hd_field
			if (v . decl_needed = TRUE) then {
			    next # already taken care of 
			    }
			sig := v . decl_denotation . signature
			if ((eval_decl(v) & (is_int_const(v . decl_denotation) ~= TRUE )) |
			    Tflag &
			    sig . kind = TYPESIGNATURE &
			    hascomp(sig, indx_put)) then {
				# Either side effects are possible, or 
				# we need put function for tracing.    
				accessible(v)
			    }
			temp := temp.cn_tl_field
		    }
		}
	    }
	APPLICATION: 
	    {
		v := p . ap_operator . signature;
		# Try to fill in in-line code if not already there 
		if (/v . fsig_inline_code &
		    \ (v . fsig_construction)) then {
			v.fsig_inline_code := v.fsig_construction.signature.fsig_inline_code
		    }
		if (impure(v) &
		    is_id(p . ap_operator) = FALSE |
		    calls_put(p . ap_operator) = TRUE) then {
			accessible(p . ap_operator)
		    } else if /(v . fsig_inline_code) then {
			if (Oflag = TRUE) & \ ( v . fsig_construction) then { 
			    temp1 := p.ap_args.lh_first
			    temp2 := v.fsig_construction.signature.fsig_param_list.lh_first
			    while \temp1 & \temp2 do {
				p := temp1.cn_hd_field 
				f := temp2.cn_hd_field 
				if /(f . par_only_def) |
				    is_real_def(f . par_only_def) = TRUE &
				    comp_st(a, f . par_only_def, nil, nil) = 0 then {
					f . par_only_def := a
				    } else {
					f . par_only_def := MULTIPLE_DEFS
					# Could possibly be MULTIPLE_TP_DEFS 
				    }
			    temp1 := temp1.cn_tl_field
			    temp2 := temp2.cn_tl_field
			}
		    }
		if ( \ (v . fsig_construction) &
		    (v . fsig_slink_known = TRUE) |
		     iand(v.fsig_construction.fc_complexity,NO_SL) ~= 0) then {
			 if (v . fsig_construction . fc_body . kind = EXTERNDEF &
			    /( v . fsig_construction . fc_body . ext_name )) then {
				 # Dummy for separately compiled function 
				 add_extracted_objfile(v.fsig_construction.fc_code_label)
			     } else {
				 # Construction is in this compilation unit 
				 v.fsig_construction.fc_complexity := ior (v.fsig_construction.fc_complexity,DIR_CALL)
				 # Don't perform "optimizations" that   
				 # would make the operator accessible.  
				 body_accessible(v . fsig_construction)
			     }
		     } else {
			 if (\ (v . fsig_construction) &
			     v . fsig_construction.fc_body.kind = EXTERNDEF &
			     / (v.fsig_construction.fc_body.ext_name)) then {
				 # Dummy for separately compiled function     
				 # Make sure it gets linked, even if we later 
				 # decide not to compile operator.            
				 add_extracted_objfile(v.fsig_construction.fc_code_label)
			     }
			 accessible(p.ap_operator)
		     }
	    }
	# Arguments are accessible, but V and := and similar 
	# operations have to be treated specially.           
		s := special_tp(v . fsig_special)
	    
		case (s) of {
		    RECORD_VALUEOF:
			s := STD_VALUEOF
		    PROD_VALUEOF:
			s := STD_VALUEOF
		    ENUM_VALUEOF:
			s := STD_VALUEOF
		    RECORD_ASSIGN:
			s = STD_ASSIGN
		    PROD_ASSIGN:
			s = STD_ASSIGN
		    ENUM_ASSIGN:
			s = STD_ASSIGN
		    STD_PASSIGN:
			s = STD_ASSIGN
		    STD_MASSIGN:
			s = STD_ASSIGN
		    STD_TASSIGN:
			s = STD_ASSIGN
		}
		if (s = STD_VALUEOF | s = STD_ASSIGN) then {
		    # Deal with first argument specially 
		    arg1 := first(p . ap_args)
		    if (arg1 . kind = LETTERID |
			arg1 . kind = OPRID) then {
			    id_accessible(arg1)
			} else {
			    accessible(arg1)
			}
		    if (s = STD_ASSIGN) then {
			accessible(second(p . ap_args))
		    }
		} else if (Oflag = TRUE & Gflag = TRUE &
			   \ (v . fsig_inline_code)) then {
			       # Use in-line code to determine whether we 
			       # need addresses correponding to variable  
			       # arguments.                               
			       argcount := 1
			       
			       temp := p . ap_args.lh_first
			       while \temp do {
				   s := temp.cn_hd_field
				   if ((s . kind = LETTERID |
					s . kind = OPRID) &
				       / (s . sel_type) &
				       s . id_last_definition . kind = DECLARATION)  then {
					   sig := sig_structure(s . signature);
					   
					   if (sig . kind = VARSIGNATURE &
					       (iand(s . id_last_definition . decl_special , VAR_NONTR_REF) ~= 0)) then {
						   if (only_indirect_ref(v.fsig_inline_code,argcount)) then {
						       id_accessible(s)
						   } else {
						       accessible(s)
						   }
					       } else {
						   accessible(s)
					       }
				       } else {
					   accessible(s)
				   } 
				   argcount +:= 1
				   temp := temp.cn_tl_field
			       }
			   } else {
			       temp := p.ap_args.lh_first
			       while \temp do {
				   s := temp.cn_hd_field
				   accessible(s)
				   temp := temp.cn_tl_field
			       }
			   }
	    }
	LOOPDENOTATION: 
	    {
		temp := p.gl_list.lh_head
		while \temp do {
		    v := temp.cn_hd_field
		    accessible(v)
		    temp := temp.cn_tl_field
		}
	    }
	    GUARDEDLIST:
		{
		    temp := p.gl_list.lh_head
		    while \temp do {
			v := temp.cn_hd_field
			accessible(v)
			temp := temp.cn_tl_field
		    }
		}
	GUARDEDELEMENT:
	    {
		accessible(p.ge_guard)
		accessible(p.ge_element)
	    }
	OPRID:
	    {
		if (p . signature . kind = VARSIGNATURE &
		    # Can't be selection 
		    p . id_last_definition . kind = DECLARATION) then {
			# Got here without going through V or := 
			    if (Vflag = TRUE) then {
				rpt_info("Direct reference to variable cell ")
#			    unparse_file = stdout;
#			    unparse(p);
				findvl(p . vlineno)
				rpt_info(" from line " || getrl())
			    }
			    p.id_last_definition.decl_special := ior(p.id_last_definition.decl_special,  VAR_NONTR_REF)
			}
		id_accessible(p)
	    }
	LETTERID:
	    {
		if (p . signature . kind = VARSIGNATURE &
		    # Can't be selection 
		    p . id_last_definition . kind = DECLARATION) then {
			# Got here without going through V or := 
			    if (Vflag = TRUE) then {
				rpt_info("Direct reference to variable cell ")
#			    unparse_file = stdout;
#			    unparse(p);
				findvl(p . vlineno)
				rpt_info(" from line " || getrl())
			    }
			    p.id_last_definition.decl_special := ior(p.id_last_definition.decl_special,  VAR_NONTR_REF)
			}
		id_accessible(p)
	    }
	FUNCCONSTR:
	    {
		p.fc_complexity := ior(p.fc_complexity, NEED_CL)
		# Need function value.  Thus we don't know the 
		# identity of parameters.
		temp := p . signature . fsig_param_list . lh_first 
		while \temp do {
		    q := temp.cn_hd_field
		    q . par_only_def := MULTIPLE_DEFS
		    temp := temp.cn_tl_field
		}
		if (p . fc_body_needed = FALSE) then {
		    p . fc_body_needed := TRUE
		    Clevel +:= 1
		    accessible(p . fc_body)
		    Clevel -:= 1
		}
	    }
	USELIST:
	    {
		temp := p . usl_den_seq.lh_first 
		while \temp do 
		    {
		    q := temp.cn_hd_field
		    accessible(q)
		    temp := temp.cn_tl_fild
		}
	    }
	MODPRIMARY:
	    {
		Olevel := Clevel
		if (p . mp_needed = FALSE) then {
		    p . mp_needed := TRUE
		    Clevel := p . level
		    accessible(p . mp_primary)
		    if (\ (p . mp_type_modifier) &
			p . mp_type_modifier . kind = WITHLIST) then {
			    # Mark forward references 
#			(void) label_wl(p);
			    temp := p.mp_type_modifier.wl_component_list.lh_first
			    while \temp do {
				q := temp.cn_hd_field
#			    IFVERBOSE(
#				      printf("Accessible wlc:\n");
#				      unparse_file = stdout;
#				      unparse(q . decl_id);
#				      printf("\n");
#				      )
				accessible(q . decl_denotation)
			    temp := temp.cn_tl_field
			    }
			}
		    Clevel = Olevel
		}
	    }
	QSTR:
	    {
		sig := p . sel_type . signature
		
#		ASSERT(sig . kind == TYPESIGNATURE,
#		       "accessible: bad string type\n");
		if (sig . ts_string_max = -1) then {
		    maxlen := MAXSTRLEN
		} else {
		    maxlen = sig . ts_string_max
		}
		if (\ (sig . ts_string_code) &
		    \ (sig . ts_element_code) &
		    ( strlen(p . str_string) <= maxlen) &
		    (calls_put(p . sel_type) ~= TRUE)) then {
			# Nothing else needed 
		    } else {
			accessible(p . str_expansion)
		    }
	    }
	UQSTR:
	    {
		sig := p . sel_type . signature
		
#		ASSERT(sig . kind == TYPESIGNATURE,
#		       "accessible: bad string type\n");
		if (sig . ts_string_max = -1) then {
		    maxlen := MAXSTRLEN
		} else {
		    maxlen = sig . ts_string_max
		}
		if (\ (sig . ts_string_code) &
		    \ (sig . ts_element_code) &
		    ( strlen(p . str_string) <= maxlen) &
		    (calls_put(p . sel_type) ~= TRUE)) then {
			# Nothing else needed 
		    } else {
			accessible(p . str_expansion)
		    }
	    }
	ENUMERATION:
	    {
	    }
	PRODCONSTRUCTION:
	    {
	    }
	UNIONCONSTRUCTION:
	    {
	    }
	# Subexpressions are not evaluated 
	WORDELSE:
	    {
	    }
	EXTERNDEF:
	    {
	    }
	REXTERNDEF:
	    {
	    }
	RECORDCONSTRUCTION:
	    {
		temp := p . rec_component_list.lh_first
		while \temp do {
		    s := temp.cn_hd_field
		    accessible(s . re_denotation)
		    temp := temp.cn_tl_field
		}
	    }
	EXTENSION:
	    accessible(p . ext_denotation)
	PARAMETER:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	RECORDELEMENT:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	FUNCSIGNATURE:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	LISTHEADER: # should never get here 
	{
	    rpt_err("accessible: bad kind, kind = " || p . kind)
	}
	VARSIGNATURE:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	VALSIGNATURE:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	TYPESIGNATURE:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	TSCOMPONENT:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	DEFCHARSIGS:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	WITHLIST:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	EXPORTLIST:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	EXPORTELEMENT:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	ALLCONSTANTS:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	HIDELIST:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	WORDCAND:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	WORDCOR:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
	default:
	    {
		rpt_err("accessible: bad kind, kind = " || p . kind)
	    }
    }
    return TRUE
end
#DJDSTOP


extern void Vexpression();
extern void fc_add();
extern int Vlevel;  # Current nesting level 

#
#   Traverse the subtree headed by p and generate code for subexpressions
#  which might need to be evaluated.
# 
Vtraverse(p)
register NODE * p;
{
register NODE * v;

    if (p == NIL) then return;

    switch ( p . kind ) {

         BLOCKDENOTATION :
		{
		    if ( p . bld_flags & REQUIRES_AR ) then {
			Vlevel++;
		    }
		    maplist (v, (LIST)decl_sort(p.bld_declaration_list), {
			ASSERT (v.kind == DECLARATION,
				"Vtraverse: decl expected");
			if (v . decl_needed) then {
			    Vexpression (v. decl_denotation);
			    POP_DISP ("ap",v.displacement,
			              "# store declared value");
			} else {
			  # Generate code for nested function       
			  # constructions or modified primary nodes 
			  # that may be evaluated.		     
			    Vtraverse (v . decl_denotation);
			}
		    }
		    );
		    maplist (v,p.bld_den_seq, {
			Vtraverse(v);
		    });
		    if ( p . bld_flags & REQUIRES_AR ) then {
			Vlevel--;
		    }
		    break;
		}
		
         APPLICATION:
		Vtraverse(p . ap_operator);
		maplist(v,p.ap_args,Vtraverse(v));
		break;

         LOOPDENOTATION:
         GUARDEDLIST:
		maplist(v,p.gl_list,Vtraverse(v));
		break;

         GUARDEDELEMENT:
		Vtraverse(p.ge_guard);
		Vtraverse(p.ge_element);
		break;

         OPRID:
         LETTERID:
		if (p . sel_type != NIL) then {
		    Vtraverse(p.sel_type);
		}
		break;

         FUNCCONSTR:
		if (p . fc_body_needed) then {
		  if (p . fc_complexity & NO_SL) then {
		    fc_add(p, Vlevel+1, TRUE # only fast version );
		  } else {
		    fc_add(p, Vlevel+1, FALSE);
		  }
		} else {
		  Vlevel++;  # presumably not necessary, but ... 
		  Vtraverse(p . fc_body);
		  Vlevel--;
                }
		break;

	 USELIST:
		maplist(q, p . usl_den_seq, Vtraverse(q));
		break;

	 MODPRIMARY:
		if (p . mp_needed) then {
		    Vexpression(p);
		    POP("r0", "# type modification value not used");
		} else {
		    Vtraverse(p . mp_primary);
		    if (p . mp_type_modifier != NIL
		        && p . mp_type_modifier . kind == WITHLIST) then {
		      maplist (q, p . mp_type_modifier . wl_component_list, {
			Vtraverse(q . decl_denotation);
		      });
		    }
		}
		break;

	 ENUMERATION:
	 PRODCONSTRUCTION:
	 UNIONCONSTRUCTION:
		# Subexpressions are not evaluated 
		break;

	 QSTR:
	 UQSTR:
		Vtraverse(p . sel_type);
		# There can't be anything of interest in the expansion 
		break;

	 WORDELSE:
         EXTERNDEF:
         REXTERNDEF:
		break;

         RECORDCONSTRUCTION:
                maplist(s, p . rec_component_list, {
                  Vtraverse(s . re_denotation);
                });
                break;

         EXTENSION:
                Vtraverse(p . ext_denotation);
		break;

	 VALSIGNATURE:
	 VARSIGNATURE:
	 FUNCSIGNATURE:
	 TYPESIGNATURE:
	 SIGNATURESIG:
		break;

         RECORDELEMENT:
	 DECLARATION:
	 PARAMETER:
	 LISTHEADER: # should never get here 
	 TSCOMPONENT:
         DEFCHARSIGS:
	 WITHLIST:
         EXPORTLIST:
         EXPORTELEMENT:
         ALLCONSTANTS:
	 HIDELIST:
	 WORDCAND:
	 WORDCOR:
	default:
		dbgmsg("Vtraverse: bad kind, kind = %d\n", p . kind);
		abort();

    };
    return;
}
