###############################################################################
#
#	File:     bld_analyze.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
# Fill in INSIDE_LOOP and CONTAINS_CLOSURE bits for blocks 
# These are used by allocate to decide whether to promote  
# declarations to surrounding blocks, and whether to reuse 
# activation record slots.                                 
# ASSUMES GC instead of reference counting.                
# include "parm.h"
# include <stdio.h>
# include "stree/ststructs.mh"
# include "../pass3/is_local.h"

extern FILE * unparse_file;

extern boolean Vflag;
extern boolean Oflag;
extern boolean Nflag;

extern NODE * insrtptr;     # Root of user program 

static boolean surr_loop = FALSE;       # There is a surrounding loop, 
					# w/o intervening function or  
                                        # block.                       
            # Note that for our purposes, string selection types are in 
            # a loop, since theyt are represented only once, but may    
            # be repeatedly evaluated.                                  


static boolean callcc_call = FALSE;     # Call to current function may save 
					# continuation.                     

# Fill in the information for tree rooted at *p.  Return true iff a 
# reference to the environment can escape.                          
# We pass a reference to a node pointer, so that we can slightly    
# modify *p to make this easier.  We only replace MODPRIMARY        
# nodes. 
#DJDSTART                                                           
procedure bld_analyze(arg)
    local p, r, Osurr_loop, nontr_decl,  contains_closure
    
    p := fix_p(arg)
    r := FALSE
    
    # We claim that p points to an expression node 
    1
    if has_field(p,"signature") then {
	if /p.signature then return FALSE # added DJD 6/3/2016 ???
	if (p . signature . kind = SIGNATURESIG) then return(FALSE)
    }
    if not(has_field(p,"kind")) then
	   p := p.cn_hd_field # ADDED DJD
    case (p . kind) of {
	 BLOCKDENOTATION:
	    {
		Osurr_loop := surr_loop;
		nontr_decl := FALSE;
		contains_closure := FALSE;
		if \ p . bld_declaration_list then { # ADDED DJD
		    temp := p . bld_declaration_list . lh_first
		    while \temp do {
			s := temp.cn_hd_field
			if (s . decl_needed) then {
			    # Will need either act. record or register space 
			    nontr_decl = TRUE;
			}
			temp := temp.cn_tl_field
		    }
		    if (nontr_decl = FALSE) then {
			# This one's for real ...
			surr_loop := ior(surr_loop, callcc_call) 
			if surr_loop ~= 0  then {
			    p . bld_flags := ior( p.bld_flags, INSIDE_LOOP) 
			}
			surr_loop := FALSE
		    }
		    temp := p . bld_declaration_list.lh_first
		    while \temp do {
			v := temp.cn_hd_field
			contains_closure := ior(contains_closure , bld_analyze(v . decl_denotation))
			temp:= temp.cn_tl_field
		    }
		    temp := p . bld_den_seq.lh_first
		    while \temp do { # was maplistp - not sure
			v := temp.cn_hd_field
			contains_closure := ior (contains_closure, bld_analyze(v))
			temp:= temp.cn_tl_field
		    }
#		maplistp(v, p . bld_den_seq, {
#		    contains_closure |= bld_analyze(v);
#		});
		    if (contains_closure ~= 0) then {
			p . bld_flags := ior (p.bld_flags,  CONTAINS_CLOSURE)
		    }
		    if (callcc_call) then {
			if (Oflag) then {
			    if (calls_callcc(p)) then {
				p . bld_flags := ior(p.bld_flags ,CALLCC_CALL)
			    }
			} else if (Nflag = FALSE) then {
			    p . bld_flags := ior (p.bld_flags, CALLCC_CALL)
			}
		    }
		    if ((iand (p . bld_flags , iand (CONTAINS_CLOSURE , CALLCC_CALL)) ~= 0) & (iand(p . bld_flags , INSIDE_LOOP) ~= 0) & is_descendant(p, insrtptr)) then {
			p . bld_flags := ior(p.bld_flags,  REQUIRES_AR)
			# We claim that NO_SL cannot ever be set for the 
			# surrounding function, since there is either a  
			# nested closure, or we cannot determine that    
			# there is no Call/cc call.
#DJDSTOP                      
			if (Vflag = TRUE) then {
			    findvl(p . vlineno);
			    
			    printf("Block requires a.r. (file: %s, line: %d)\n",
				   getname(getfn()), getrl());
			    if (Osurr_loop) then {
				printf("\t- explicit surrounding loop\n");
			    }
			    if (callcc_call) then {
				printf("\t- possible Callcc call in function may create loop\n");
			    }
			    if (p . bld_flags & CONTAINS_CLOSURE) then {
				printf("\t- embedded closure\n");
			    }
			    if (p . bld_flags & CALLCC_CALL) then {
				printf("\t- possible embedded Callcc call\n");
			    }
			}
#DJDSTART
		    }
		    r := ior (r, contains_closure)
		    surr_loop := Osurr_loop;
		}
	    }
	 MODPRIMARY:
	     
	     {}
#DJDSTOP
	    if (p . mp_type_modifier != NIL
		& p . mp_type_modifier . kind == WITHLIST) then {
		boolean Osurr_loop = surr_loop;
		boolean captures_cont;

		surr_loop = FALSE;
		maplist(v, p . mp_type_modifier . wl_component_list, {
		    r |= bld_analyze(&(v . decl_denotation));
		});
		if (callcc_call) then {
		    if (Oflag) then {
			captures_cont = calls_callcc(p);
		    } else {
			if (Nflag) then {
			    captures_cont = FALSE;
			} else {
			    captures_cont = TRUE;
			}
		    }
		} else {
		    captures_cont = FALSE;
		}
		if (Osurr_loop || callcc_call) then {
		    # Introduce a surrounding block with its own 
		    # activation record to hold the reference    
		    # to the new type.                           
		    NODE * block = mknode(BLOCKDENOTATION,
					  emptylist(), mklist(p, -1));

		    block . vlineno = p . vlineno;
		    block . signature = p . signature;
		    block . sig_done = SIG_DONE;
		    if ((r || captures_cont) & p . mp_needed) then {
			block . bld_flags = INSIDE_LOOP;
			if (is_descendant(p, insrtptr)) then {
			  block . bld_flags |= REQUIRES_AR;
			  if (Vflag) then {
			    findvl(p . vlineno);
			    printf("Introducing block with a.r. for type modification (file: %s, line: %d)\n",
				   getname(getfn()), getrl());
			    printf("\t - type modification: ");
			    unparse_file = stdout;
			    unparse(p);
			    printf("\n");
			    if (Osurr_loop) then {
				printf("\t- explicit surrounding loop\n");
			    }
			    if (callcc_call) then {
				printf("\t- possible Callcc call in function may create loop\n");
			    }
			    if (r) then {
				printf("\t- embedded closure\n");
			    }
			    if (captures_cont) then {
				printf("\t- possible embedded Callcc call\n");
			    }
			  }
			}
			if (r) then {
			    block . bld_flags |= CONTAINS_CLOSURE;
			}
			if (captures_cont) then {
			    block . bld_flags |= CALLCC_CALL;
			}
		    }
		    *arg = block;
		}
		surr_loop = Osurr_loop;
	    }
	    r |= bld_analyze(&(p . mp_primary));
	    break;

	 APPLICATION:
	    r = bld_analyze(&(p . ap_operator));
	    maplistp(v, p . ap_args, r |= bld_analyze(v));
	    break;

	 LOOPDENOTATION:
	    {
		boolean Osurr_loop = surr_loop;

		surr_loop = TRUE;
		maplist(v, p . gl_list, {
		    r |= bld_analyze(&(v . ge_guard));
		    r |= bld_analyze(&(v . ge_element));
		});
		surr_loop = Osurr_loop;
	    }
            break;

         QSTR:
         UQSTR:
            {
                boolean Osurr_loop = surr_loop;

                surr_loop = TRUE;
                bld_analyze(&(p . sel_type));
                surr_loop = Osurr_loop;
            }
            break;

	 GUARDEDLIST:
	    maplist(v, p. gl_list, {
		r |= bld_analyze(&(v . ge_guard));
		r |= bld_analyze(&(v . ge_element));
	    });
	    break;

	 OPRID:
	 LETTERID:
	    if (p . sel_type != NIL) then {
		r |= bld_analyze(&(p . sel_type));
	    }
	    break;

	 FUNCCONSTR:
	    if (p . fc_body . kind == EXTERNDEF) then return TRUE
	    {
		boolean Ocallcc_call = callcc_call;
		boolean Osurr_loop = surr_loop;

		callcc_call = !(p . fc_complexity & NO_CALLCC);
		if (Nflag) then callcc_call = FALSE;
		surr_loop = FALSE;

		r |= (p . fc_complexity & NEED_CL);
		r |= bld_analyze(&(p . fc_body));

		callcc_call = Ocallcc_call;
		surr_loop = Osurr_loop;
	    }
	    break;

	 REXTERNDEF:
	    break;

	 USELIST:
	    maplistp(q, p . usl_den_seq, r |= bld_analyze(q));
	    break;

	 EXTENSION:
	    r = bld_analyze(&(p . ext_denotation));
	    break;

	 RECORDCONSTRUCTION:
	    maplist(s, p . rec_component_list, {
		r |= bld_analyze(&(s . re_denotation));
	    });
	    break;

	 WORDELSE:
	    break;

	 PRODCONSTRUCTION:
	 UNIONCONSTRUCTION:
	 ENUMERATION:
	    # No evaluated subexpressions. 
	    break;

	default:
	    dbgmsg("bld_analyze: Bad kind: %d\n", p . kind);
#DJDSTART
    }
    return(r)
end
#DJDSTOP
# Fill in INSIDE_LOOP and CONTAINS_CLOSURE bits for blocks 
# These are used by allocate to decide whether to promote  
# declarations to surrounding blocks, and whether to reuse 
# activation record slots.                                 
# ASSUMES GC instead of reference counting.                
# include "parm.h"
# include <stdio.h>
# include "stree/ststructs.mh"
# include "../pass3/is_local.h"

extern FILE * unparse_file;

extern boolean Vflag;
extern boolean Oflag;
extern boolean Nflag;

extern NODE * insrtptr;     # Root of user program 

static boolean surr_loop = FALSE;       # There is a surrounding loop, 
					# w/o intervening function or  
                                        # block.                       
            # Note that for our purposes, string selection types are in 
            # a loop, since theyt are represented only once, but may    
            # be repeatedly evaluated.                                  


static boolean callcc_call = FALSE;     # Call to current function may save 
					# continuation.                     

# Fill in the information for tree rooted at *p.  Return true iff a 
# reference to the environment can escape.                          
# We pass a reference to a node pointer, so that we can slightly    
# modify *p to make this easier.  We only replace MODPRIMARY        
# nodes.                                                            
boolean bld_analyze(arg)
NODE **arg;
{
    NODE * p = *arg;
    boolean r = FALSE;

    # We claim that p points to an expression node 
    if (p . signature . kind == SIGNATURESIG) then return(FALSE);

    case (p . kind) of {
	 BLOCKDENOTATION:
	    {
		boolean Osurr_loop = surr_loop;
		boolean nontr_decl = FALSE;
		boolean contains_closure = FALSE;
		extern boolean calls_callcc();

		maplist(s, p . bld_declaration_list, {
		    if (s . decl_needed) then {
			# Will need either act. record or register space 
			nontr_decl = TRUE;
		    }
		});
		if (nontr_decl) then {
		    # This one's for real ... 
		    if (surr_loop || callcc_call) then {
			p . bld_flags |= INSIDE_LOOP;
		    }
		    surr_loop = FALSE;
		}
		maplist(v, p . bld_declaration_list, {
		    contains_closure |= bld_analyze(&(v . decl_denotation));
		});
		maplistp(v, p . bld_den_seq, {
		    contains_closure |= bld_analyze(v);
		});
		if (contains_closure) then {
		    p . bld_flags |= CONTAINS_CLOSURE;
		}
		if (callcc_call) then {
		    if (Oflag) then {
			if (calls_callcc(p)) then {
			    p . bld_flags |= CALLCC_CALL;
			}
		    } else if (!Nflag) then {
			p . bld_flags |= CALLCC_CALL;
		    }
		}
		if ((p . bld_flags & (CONTAINS_CLOSURE | CALLCC_CALL))
		     && (p . bld_flags & INSIDE_LOOP)
		     && is_descendant(p, insrtptr)) then {
		    p . bld_flags |= REQUIRES_AR;
		    # We claim that NO_SL cannot ever be set for the 
		    # surrounding function, since there is either a  
		    # nested closure, or we cannot determine that    
		    # there is no Call/cc call.                      
		    if (Vflag) then {
			findvl(p . vlineno);
			printf("Block requires a.r. (file: %s, line: %d)\n",
			       getname(getfn()), getrl());
			if (Osurr_loop) then {
			    printf("\t- explicit surrounding loop\n");
			}
			if (callcc_call) then {
			    printf("\t- possible Callcc call in function may create loop\n");
			}
			if (p . bld_flags & CONTAINS_CLOSURE) then {
			    printf("\t- embedded closure\n");
			}
			if (p . bld_flags & CALLCC_CALL) then {
			    printf("\t- possible embedded Callcc call\n");
			}
		    }
		}
		r |= contains_closure;
		surr_loop = Osurr_loop;
	    }
	    break;

	 MODPRIMARY:
	    if (p . mp_type_modifier != NIL
		&& p . mp_type_modifier . kind == WITHLIST) then {
		boolean Osurr_loop = surr_loop;
		boolean captures_cont;

		surr_loop = FALSE;
		maplist(v, p . mp_type_modifier . wl_component_list, {
		    r |= bld_analyze(&(v . decl_denotation));
		});
		if (callcc_call) then {
		    if (Oflag) then {
			captures_cont = calls_callcc(p);
		    } else {
			if (Nflag) then {
			    captures_cont = FALSE;
			} else {
			    captures_cont = TRUE;
			}
		    }
		} else {
		    captures_cont = FALSE;
		}
		if (Osurr_loop || callcc_call) then {
		    # Introduce a surrounding block with its own 
		    # activation record to hold the reference    
		    # to the new type.                           
		    NODE * block = mknode(BLOCKDENOTATION,
					  emptylist(), mklist(p, -1));

		    block . vlineno = p . vlineno;
		    block . signature = p . signature;
		    block . sig_done = SIG_DONE;
		    if ((r || captures_cont) && p . mp_needed) then {
			block . bld_flags = INSIDE_LOOP;
			if (is_descendant(p, insrtptr)) then {
			  block . bld_flags |= REQUIRES_AR;
			  if (Vflag) then {
			    findvl(p . vlineno);
			    printf("Introducing block with a.r. for type modification (file: %s, line: %d)\n",
				   getname(getfn()), getrl());
			    printf("\t - type modification: ");
			    unparse_file = stdout;
			    unparse(p);
			    printf("\n");
			    if (Osurr_loop) then {
				printf("\t- explicit surrounding loop\n");
			    }
			    if (callcc_call) then {
				printf("\t- possible Callcc call in function may create loop\n");
			    }
			    if (r) then {
				printf("\t- embedded closure\n");
			    }
			    if (captures_cont) then {
				printf("\t- possible embedded Callcc call\n");
			    }
			  }
			}
			if (r) then {
			    block . bld_flags |= CONTAINS_CLOSURE;
			}
			if (captures_cont) then {
			    block . bld_flags |= CALLCC_CALL;
			}
		    }
		    *arg = block;
		}
		surr_loop = Osurr_loop;
	    }
	    r |= bld_analyze(&(p . mp_primary));
	    break;

	 APPLICATION:
	    r = bld_analyze(&(p . ap_operator));
	    maplistp(v, p . ap_args, r |= bld_analyze(v));
	    break;

	 LOOPDENOTATION:
	    {
		boolean Osurr_loop = surr_loop;

		surr_loop = TRUE;
		maplist(v, p . gl_list, {
		    r |= bld_analyze(&(v . ge_guard));
		    r |= bld_analyze(&(v . ge_element));
		});
		surr_loop = Osurr_loop;
	    }
            break;

         QSTR:
         UQSTR:
            {
                boolean Osurr_loop = surr_loop;

                surr_loop = TRUE;
                bld_analyze(&(p . sel_type));
                surr_loop = Osurr_loop;
            }
            break;

	 GUARDEDLIST:
	    maplist(v, p. gl_list, {
		r |= bld_analyze(&(v . ge_guard));
		r |= bld_analyze(&(v . ge_element));
	    });
	    break;

	 OPRID:
	 LETTERID:
	    if (p . sel_type != NIL) then {
		r |= bld_analyze(&(p . sel_type));
	    }
	    break;

	 FUNCCONSTR:
	    if (p . fc_body . kind == EXTERNDEF) then return;
	    {
		boolean Ocallcc_call = callcc_call;
		boolean Osurr_loop = surr_loop;

		callcc_call = !(p . fc_complexity & NO_CALLCC);
		if (Nflag) then callcc_call = FALSE;
		surr_loop = FALSE;

		r |= (p . fc_complexity & NEED_CL);
		r |= bld_analyze(&(p . fc_body));

		callcc_call = Ocallcc_call;
		surr_loop = Osurr_loop;
	    }
	    break;

	 REXTERNDEF:
	    break;

	 USELIST:
	    maplistp(q, p . usl_den_seq, r |= bld_analyze(q));
	    break;

	 EXTENSION:
	    r = bld_analyze(&(p . ext_denotation));
	    break;

	 RECORDCONSTRUCTION:
	    maplist(s, p . rec_component_list, {
		r |= bld_analyze(&(s . re_denotation));
	    });
	    break;

	 WORDELSE:
	    break;

	 PRODCONSTRUCTION:
	 UNIONCONSTRUCTION:
	 ENUMERATION:
	    # No evaluated subexpressions. 
	    break;

	default:
	    dbgmsg("bld_analyze: Bad kind: %d\n", p . kind);
    }
    return(r);
}
