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

# Fix up references to identifiers within signatures.  Note          
# that by our specially contrived restrictions this can be done      
# before the signature deduction phase.                              

# This pass also fixes up the def_found                              
# of identifiers explicitly selected from a type.                    

# String expansions are added inside signatures.                     

# fc_code_label fields are filled in.                                

# Ap_void_decl fields are filled in.                                 

# fsig_slink_known fields are set for signature of function 
# constructions.  They are then propagated by pass4.        

# NO_SURR_LOOPS flags are filled in for BLOCKDENOTATIONs.   
# no_surr_loop fields in MODPRIMARY's are set appropriately 


# include <stdio.h>
# include <ctype.h>
# include "parm.h"

# include "stree/ststructs.mh"

# include "../pass4/sigs.h"

# include "is_local.h"
#DJDSTOP
char * getname()

extern FILE * unparse_file
extern int stplinks[]
extern int yynerrs
extern char * entry_name

static int fn_count = 0

static boolean insig = FALSE     # currently looking at signature         

static NODE * curr_void_decl = NIL

static NODE * curr_sig_transp = NIL
# Innermost signature transparent       
# declaration, whose r.h.s is currently 
# being processed.                      

static boolean in_loop = FALSE

extern NODE * var_Void

extern NODE * sig_Signature

void check_sig()       # Checks that an expression has the form of a 
# signature.                                  

#DJDSTART
# Fix up the subtree headed by p 
procedure sigids(p)
    local q,v, old_insig, old_in_loop,  old_void_decl,old_sig_transp
    local def, imid, id_def, usl, sig, fixed_it, goto_dflt,temp,s,goto_str_fixed_it
    static in_loop
    initial in_loop := FALSE
#    register int * q   # pointer to next field of p to be recursively     
    # examined.                                        
#    register int v     # bit vector specifying primary link fields of *p  
    # shifted so that the most significant bit         
    # corresponds to q.                                
    old_insig := insig
    old_in_loop := in_loop
    old_void_decl := curr_void_decl
    old_sig_transp := curr_sig_transp

    if (/p) then return TRUE
    goto_dflt := FALSE
    case ( p . kind ) of {
	OPRID: {
	    $include "pass3/sigids_opr_let.inc.icn"
	}
	LETTERID: {
	    $include "pass3/sigids_opr_let.inc.icn"
	}
	QSTR: {
	    $include "pass3/sigids_str.inc.icn"
	}
	UQSTR: {
	    $include "pass3/sigids_str.inc.icn"
	}
	RECORDCONSTRUCTION:
	    {
		temp := p.rec_component_list.lh_first
		while \temp do {
		    s := temp.cn_hd_field
		    sigids(s . re_denotation)
		    temp := temp.cn_tl_field
		}
	    }
	FUNCCONSTR: {
	    # give it a reasonable name 
	    if (/ p. fc_code_label) then {
		findvl(p . vlineno)
		fn_count +:= 1
		fn_name :=  entry_name || getrl() || fn_count
		p . fc_code_label := fn_name
	    }
	    in_loop := FALSE
	    # look for var Void parameters, check that par. sigs are legit.
	    temp := p . signature . fsig_param_list.lh_first
	    while \temp do { 
		s := temp.cn_hd_field
		check_sig(s . par_signature)
		if (comp_st(s . par_signature,
			    var_Void, nil, nil) = 0) then {
				curr_void_decl := s
			    }
		temp := temp.cn_tl_field
	    }
	    insig := TRUE
	    temp :=  p . signature . fsig_param_list.lh_first
	    while \temp do {
		s := temp.cn_hd_field
		sigids(s . par_signature)
		temp := temp.cn_tl_field
	    }
	    check_sig(p . signature . fsig_result_sig)
	    sigids(p . signature . fsig_result_sig)
	    insig := old_insig
	    sigids(p . fc_body)
	    p . signature . fsig_slink_known := TRUE
	    # static link is available in this context  
	    # will be cleared if function is used in    
	    # a context in which it's not available.  
	}  
	APPLICATION:
		{
		    sigids(p . ap_operator)
		    sigids(p . ap_args)
		    p . ap_void_decl := curr_void_decl
		}
	BLOCKDENOTATION: {
	    if (in_loop = FALSE) then {
		p. bld_flags := ior(p . bld_flags, NO_SURR_LOOP)
	    }
	    sigids(p. bld_declaration_list)
	    sigids(p. bld_den_seq)
	}
	
	DECLARATION: {
	    if (p . decl_denotation . kind = FUNCCONSTR &
		p . decl_id . kind = LETTERID &
		/ (p . decl_denotation . fc_code_label)) then {
		    # try to give it a reasonable name 
		    if (id_name[1] ~== "\'") then {
			fn_count +:= 1
			fn_name := entry_name || id_name || fn_count
			p . decl_denotation . fc_code_label := fn_name
		    }
		}
	    insig := TRUE
	    check_sig(p . decl_signature)
	    sigids(p . decl_signature)
	    if (/ (p . decl_sig_transp)) then {
		insig := old_insig
	    } else {
		# Otherwise treat the denotation as a signature 
		curr_sig_transp := p
	    }
	    sigids(p . decl_denotation)
	}
	TSCOMPONENT: {
	    check_sig(p . tsc_signature)
	    sigids(p . tsc_signature)
	    # skip tsc_id 
	}
	EXPORTELEMENT: {
	    sigids(p . ee_export_list)
	    insig := TRUE
	    check_sig(p . ee_signature)
	    sigids(p . ee_signature)
	}
	REXTERNDEF: {
}
	# Don't bother with the signature 
	PARAMETER: {
	    insig := TRUE
	    check_sig(p . par_signature)
	    sigids(p . par_signature)
	    # skip par_id 
	}
	LOOPDENOTATION: {
	    in_loop := TRUE
	    goto_dflt := TRUE
	}
	
	MODPRIMARY: {
	    if  in_loop = FALSE then
		p . mp_no_surr_loop := TRUE 
	    else
		p . mp_no_surr_loop := FALSE
	    
	    goto_dflt := TRUE
	}
	TYPESIGNATURE:
	    {
		insig := TRUE
		# and now fix up subtrees 
	    }
	FUNCSIGNATURE:
	    {
		insig := TRUE
		# and now fix up subtrees 
	    }
	VALSIGNATURE:
	    {
		insig := TRUE
		# and now fix up subtrees 
	    }
	VARSIGNATURE:
	    {
		insig := TRUE
		# and now fix up subtrees 
	    }
	default: {
	    $include "pass3/sigids_dflt.inc.icn"
	    # recursively examine subtrees 
	}
    }
    if goto_dflt := TRUE then {
	$include "pass3/sigids_dflt.inc.icn"
    }

    insig := old_insig
    curr_void_decl := old_void_decl
    curr_sig_transp := old_sig_transp
    
end    
# Check whether q is an explicit signature node, or an identifier bound, 
# via signature transparent declarations, to a signature.                
procedure check_sig(q)
    local p
    p := q

    if (/p) then return TRUE
    while (   (p . kind = LETTERID | p . kind = OPRID) &
	   / (p . sel_type) &
	   \ id_last_definition &
	   p . id_last_definition . kind = DECLARATION &
	   \ (p . id_last_definition . decl_sig_transp) &
	   (p . id_last_definition . post_num < p . post_num)) do {
	       p := p . id_last_definition . decl_denotation
	   }

    if (p . kind ~= SIGNATURESIG &
	p.kind ~= VALSIGNATURE &
	p.kind ~= VARSIGNATURE &
	p.kind ~= FUNCSIGNATURE &
	p.kind ~= TYPESIGNATURE) then
        {
	    if (p . kind = LETTERID | p . kind = OPRID) then {
		if (/ (p . id_last_definition) |
		    p . id_last_definition . kind ~= PARAMETER |
		    comp_st(p . id_last_definition . par_signature,
			    sig_Signature, nil, nil) ~= 0) then {
				rpt_err("Identifier not meaningfully bound to a signature " || getname(q . id_str_table_index))
			    }
	    } else {
		rpt_err("Signature expected")
	    }
	}

end
