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

# ifdef DEBUG
#   define IFDEBUG(x) x
# else
#   define IFDEBUG(x)
# endif

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

# include "stree/ststructs.mh"

# include "sigs.h"

# include "stree/is_ptr.h"

NODE * curr_tsig = NIL  /* signature of anonymous local type ids 

boolean in_sig  /* checking inside a signature 

# define ERR_NODE_DEFINED
NODE * err_node = NIL  /* node to be used for error message in lieu 
/* of current node.  Used by errmsg macros   
char * err_msg         /* message to be used in lieu of usual one   

extern NODE * val_Boolean,
* val_Void,
* var_Void

extern NODE * sig_Signature

extern int yynerrs

extern FILE * unparse_file
#DJDSTART
#
#  checksigs(p,dont_coerce)
#
#  Do signature checking on the expression subtree headed by p
#  Dont_coerce indicates that that the expression occurs in a context
# in which the result will be discarded anyway.
#  It is also insured that all signature and optimization info
# needed to generate code for p will be attached to the nodes in the
# subtree.
#


procedure checksigs(p_orig,dont_coerce)
    local knd, op, sig, maxlen, temp, q, num_ars, num_params, temp1, temp2,s, r, p
    # operator in application
    if /p_orig then return TRUE
    p := fix_p(p_orig)
    if (/p ) then return TRUE
    knd := p. kind
    
    case (knd) of {
	OPRID:
	    {
		$include "pass4/checksigs.let1.inc.icn"
	    }
	LETTERID: 
	    {
		$include "pass4/checksigs.let1.inc.icn"
	    }
	QSTR:
	    {
		$include "pass4/checksigs.str1.inc.icn"
	    }
	
	UQSTR:
	    {
		$include "pass4/checksigs.str1.inc.icn"
	    }
	
	FUNCCONSTR:
	    {
		is_val_Void := (comp_st(val_Void, p. signature . fsig_result_sig, nil, nil) = 0)
		checksigs(p . fc_body, is_val_Void)
		tl_findsig(p,dont_coerce)
		if (in_sig = FALSE &
		    p . signature . fsig_result_sig ~= ERR_SIG) then {
			# find signatures of var parameter types     
			# and of result type for code generator      
			# code generator                             
			in_sig := TRUE
			if (p . signature . fsig_result_sig . kind = VALSIGNATURE) then
			    {
				tl_findsig(p . signature . fsig_result_sig . val_denotation, FALSE)
			    }
			temp :=  p. signature . fsig_param_list.lh_first
			while \temp do {
			    q := temp.cn_hd_field
			    sig := q . par_signature
			    if (sig . kind = VARSIGNATURE)  then {
				tl_findsig(sig . var_denotation, FALSE)
				
			    }
			    temp := temp.cn_tl_field
			}
			in_sig := FALSE
		    }
		if (p . fc_body . kind = EXTERNDEF) then {
		    # check that last parameter has var void sig 
		    if (is_empty(p . signature . fsig_param_list)) then {
			psig := nil
		    } else {
			psig := last(p . signature . fsig_param_list) . par_signature
		    }
		    if (comp_st(psig, var_Void, NIL, NIL) ~= 0) then {
			errmsg0(p, "Warning - last parameter of extern should be var Void")
			yynerrs -:= 1 # Only a warning 
		    }
		} else {
		    # check that result sig matches body 
		    if (is_val_Void = FALSE &
			/amatch(p . fc_body . signature, 
				p . signature . fsig_result_sig)) then {
				    errmsg0(p, "Function result signature mismatch")
				}
		}
	    }

	REXTERNDEF: {}
	APPLICATION: {
            # insert coercions first 
	    tl_findsig(p, dont_coerce)
	    temp := p . ap_args.lh_first
	    while \temp do {
		q := temp.cn_hd_field
		checksigs(q,FALSE)
		temp := temp.cn_tl_field
	    }
	    op := p . ap_operator
	    if (op . kind = OPRID || op . kind = LETTERID) then {
		# use argument list to find right decl. 
		op . id_appl := p
	    }
	    checksigs(op, FALSE)
	    tl_findsig(p,dont_coerce)
	    if (p . signature ~= ERR_SIG & 
		op . signature ~= ERR_SIG ) then { # not implied by prec cond
		    op_sig := op . signature
		    # This guarantees operator has func signature 
		    
		    #  printf("Checksigs looking at application(%X):",p)
#		unparse_file := stdout
#		unparse(p)
#		printf("\n")
		    
		    if (in_sig = FALSE) then {
			# Try to fill in in-line code, if not already there 
			if (\ (op . signature . fsig_inline_code)) &
			    ( \ ( op . signature . fsig_construction)) then {
				op . signature . fsig_inline_code :=op . signature . fsig_construction . signature . fsig_inline_code
			    }
			# compute signature of result type (for code generator) 
			in_sig := TRUE
			err_node := p
			err_msg := "signature of result type is bad"
			case (p . signature . kind) of {
			    VALSIGNATURE:
				tl_findsig(p . signature . val_denotation, TRUE)
			    VARSIGNATURE:
				tl_findsig(p . signature . var_denotation, TRUE)
			}
			in_sig := FALSE
			err_node := nil
		    }
		    
		    # check argument parameter matching, and compute signature 
		    # of any var parameter types     (for code generator)      
		    
		    num_args := length(p . ap_args)
		    num_params := length(op_sig . fsig_param_list)
		    if (num_args ~= num_params)  then {
			errmsg0(p, "wrong number of arguments")
		    } else {
			temp1 := p.lh_first
			temp2 :=  op_sig . fsig_param_list.lh_first
			while \temp1 & \temp2 do {
			    s := temp1.cn_hd_field
			    r := temp2.cn_hd_field
			    {
				sig := s . signature
				if (has_sig(s) &
				    (sig . kind = VARSIGNATURE) &
				    in_sig = FALSE) then {
					# find1 signature for code generator 
					in_sig := TRUE
					err_node := s
					err_msg := "bad argument type signature"
					if (sig . kind = VALSIGNATURE) then {
					    den = sig . val_denotation
					} else {
					    den = sig . var_denotation
					}
					tl_findsig(den, TRUE)
					err_node := NIL
					in_sig := FALSE
				    }
				par_sig := subst(r . par_signature,
						 op_sig . fsig_param_list,
						 p . ap_args)
				lock(par_sig)
				if (!amatch(s . signature, par_sig)) then {
				    #    extern NODE * failed_comp # set by amatch 
				    
				    rpt_err("Argument parameter mismatch")
#					     unparse_file = stderr
#					     fprintf(stderr, "\tArgument:\n\t")
#					     unparse(s)
#					     fprintf(stderr,
#						     "\n\tParameter signature after substitution:\n\t")
#					     unparse(par_sig)
				    if (\failed_comp) then {
					if (failed_comp . kind = DEFCHARSIGS) then {
#						     fprintf(stderr, "\n\tMissing Constant")
					} else {
					    # TSCOMPONENT 
#						     fprintf(stderr,
#							     "\n\tOffending parameter component: ")
#						     unparse(failed_comp . tsc_id)
#						     fprintf(stderr, ":")
#						     unparse(failed_comp . tsc_signature)
					}
				    }
#					     fprintf(stderr,
#						     "\n\tArgument signature:\n\t")
#					     unparse(s . signature)
#					     fprintf(stderr, "\n")
				}
				vfree(unlock(par_sig))
			    } # end_map2lists
			    temp1 := temp1.cn_tl_field
			    temp2 := temp2.cn_tl_field
			}
		    }
		}
	}
	GUARDEDLIST:
	    {
		$include "pass4/checksigs.den1.inc.icn"
	    }
	LOOPDENOTATION:
	    
	    {
		$include "pass4/checksigs.den1.inc.icn"
	    }
	BLOCKDENOTATION:
	    { 
		 temp := p. bld_declaration_list.lh_first
		while \temp do {
		    q := temp.cn_hd_field
		    checksigs(q . decl_denotation,FALSE)
		    if (\ (q . decl_signature) &
			q . decl_denotation . signature ~= ERR_SIG &
			comp_st(q . decl_signature,q. decl_denotation . signature, NIL, NIL) ~= 0) then {
			    errmsg0(q, "Signature does not match declaration")
#				    unparse_file = stderr
#				    fprintf(stderr, "\texplicit signature:\n\t")
#				    unparse(q . decl_signature)
#				    fprintf(stderr, "\n\texpression signature:\n\t")
#				    unparse(q . decl_denotation . signature)
#				    fprintf(stderr, "\n")
			    
			    if (/ (q . decl_signature)) then {
				q . decl_signature := q . decl_denotation . signature
				q . decl_sig_done := SIG_DONE
			    }
			}
		    temp := temp.cn_tl_field
		}
		
		temp := p.bld_den_seq.lh_first
		while \temp do {
		    q := temp.cn_hd_field
		    {
#a			if (q === last(p . bld_den_seq)) then {
			if (q === p . bld_den_seq . lh_last) then {
			    checksigs(q,dont_coerce)
			} else {
			    checksigs(q,TRUE)
			}
		    }
		    temp:= temp.cn_tl_field
		}
		tl_findsig(p,dont_coerce)
	    }
	USELIST:
	    {
	    temp := p.usl_type_list.lh_first
	    while \temp do 
		{
		    q := temp.cn_hd_field
		    checksigs(q,FALSE)
		    if (q . signature ~= ERR_SIG) then {
			if (q . signature . kind ~= TYPESIGNATURE) then 
			    {
				q . signature := sig_structure(q . signature)
			    }
			if (q . signature . kind ~= TYPESIGNATURE) then {
			    rpt_err("Non-type appears in use type list")
			}
		    }
		    temp := temp.cn_tl_field
		}
	    temp := p.usl_den_seq.lh_first
	    while \temp do
		{
		    q := temp.cn_hd_field
		    {
			if (q = last(p . usl_den_seq)) then {
			    checksigs(q,dont_coerce)
			} else {
			    checksigs(q,TRUE)
			}
		    }
		    temp := temp.cn_tl_field
		}
	    tl_findsig(p,dont_coerce)
	}		
    WORDELSE:
	    {
		tl_findsig(p,dont_coerce)
	    }

    MODPRIMARY:
	{
	    {
		checksigs(p . mp_primary, FALSE)
		# Make sure with list components are traversed in their 
		# final order, so that they don't get reordered in the  
		# middle of this.                                       
		
		if((q = findsig(p, dont_coerce)) ~= SUCCESS) then {
		    rpt_err("Can't find signature of with list")
#		   unparse_file = stderr
#		   unparse(q)
#		   fprintf(stderr, "\n")
		    p. sig_done := SIG_DONE
		    p . signature := ERR_SIG
		}
	    }
	    if (in_sig = FALSE & has_sig(p . mp_primary)) then {
		# check for ambiguous selections etc. in orig. type 
		err_node := p
		err_msg := "bad type signature before modification"
		checksigs(p . mp_primary . signature, FALSE)
		err_node := nil
	    }
	    if ( \ (p . mp_type_modifier) &
		p . mp_type_modifier . kind = WITHLIST) then {

		    temp := p. mp_type_modifier . wl_component_list .lh_first
		    while \temp do {
			q := temp.lh_firs
			{
			    IFDEBUG(
				    if (q . kind ~= DECLARATION) then {
					dbgmsg("checksigs: bad with list\n")
				    }
				    )
			    checksigs(q . decl_denotation, dont_coerce)
			    if (\ (q . decl_signature) &
				( q . decl_denotation . signature ~= ERR_SIG &
				 comp_st(q . decl_signature, q . decl_denotation . signature, nil, nil) ~= 0)) then {
				     rpt_err("Signature does not match WITH declaration")
				 }
			}
			temp := temp.cn_tl_field
		    }
		    tl_findsig(p, dont_coerce)
		    if (in_sig = FALSE & has_sig(p)) then {
			# check for export rule violations after hiding 
			# but before adding new components.             
			sig_after_hiding := lock(delcomp(p . mp_primary . signature,   p . mp_delete_v))
			
			err_node := p
			err_msg := "bad signature after hiding"
			checksigs(sig_after_hiding, FALSE)
			vfree(unlock(sig_after_hiding))
			
			# Check for ambiguous selections after component addition 
			err_msg := "bad signature after adding components"
			checksigs(p. signature, FALSE)
			err_node := nil
		    }
		} else {
		    tl_findsig(p, dont_coerce)
		    # check for export rule violations 
		    if (in_sig = FALSE & has_sig(p)) then {
			err_node := p
			err_msg := "bad signature after hiding"
			checksigs(p . signature, FALSE)
			err_node := nil
		    }
		}
	}
    RECORDCONSTRUCTION:
	{
	    tl_findsig(p,dont_coerce)
	    temp := p.rec_component_list . lh_first
	    while \temp do {
		q := temp.cn_hd_field
		tl_findsig(q . re_denotation)
		if (q . re_denotation . signature ~= ERR_SIG &
		    q . re_denotation . signature . kind	~= TYPESIGNATURE) then {
			rpt_err("Non-type expression in record")
		    }
		temp := temp.cn_tail_field
	    }
	}
    
    UNIONCONSTRUCTION: 
	{
	    $include "pass4/chksigs.unpd1.inc.icn"
	}
    PRODCONSTRUCTION:
	{
	    $include "pass4/chksigs.unpd1.inc.icn"
	}
    ENUMERATION: 
	{
	    tl_findsig(p, dont_coerce)
	}
    EXTENSION:
	{
	    checksigs(p . ext_denotation)
	    tl_findsig(p, dont_coerce)
	}
    TYPESIGNATURE:
	{
	    old_in_sig := in_sig
	    old_curr_tsig := curr_tsig
	    
	    if ( / (p . signature)) then {
		p . signature := sig_Signature
	    }
	    p . sig_done := SIG_DONE
	    in_sig := TRUE
	    curr_tsig := p
	    # check nested signatures 
	    temp :=  p . ts_clist.lh_first 
	    while \temp do {
		s := temp.cn_hd_field
		{
		    if (s . kind = TSCOMPONENT) then {
			checksigs(s . tsc_signature, FALSE)
		    }
		}
		temp := temp.cn_tl_field
	    }
	    in_sig := old_in_sig
	    curr_tsig := old_curr_tsig
	}
    
    FUNCSIGNATURE:
	{
	    # should occur only when checking signatures of type     
	    # modifications and when signatures occur as expressions 
	    if (/ (p. signature)) then {
		p . signature := sig_Signature
	    }
	    p.cn_hd_field . sig_done := SIG_DONE
	    temp :=  p . fsig_param_list.lh_first
	    while \temp do {
		s := temp.cn_hd_field

		IFDEBUG(
			if (s . kind ~= PARAMETER || !is_ptr(s . par_signature)) then {
			    rpt_err("checksigs: bad parameter\n")
			}
			)
		checksigs(s . par_signature, FALSE)
		temp := temp.cn_tl_field
	    }
	    checksigs(p . fsig_result_sig)
	}
    VALSIGNATURE: {
	if (/ (p. signature)) then {
	    p . signature := sig_Signature
	}
	p . sig_done := SIG_DONE
	checksigs(p .cn_hd_field. val_denotation, FALSE)
    }
    VARSIGNATURE: {
	if ( / (p . signature)) then {
	    p . signature := sig_Signature
	}
	p . sig_done := SIG_DONE
	checksigs(p . var_denotation, FALSE)
    }
    
    SIGNATURESIG: {
	if (/ (p. signature)) then {
	    p . signature := sig_Signature
	}
	p . sig_done := SIG_DONE
    }
    EXTERNDEF: {}
    default: {
	rpt_err("checksigs: bad kind:")
    }
}
return TRUE
end

#
# Top level driver routine for the above.  Also calls import to check 
# for import and export rule violations.
#

procedure tl_checksigs(p)
    checksigs(p, FALSE)
#    import(p, nil)  # SKIP FOR NOW DJD
return TRUE
end

