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

# Perform findsigs task in the case of applications.  We insure that the 
# final operator signature is not an ID node.                            
# define TRACE
# undef TRACE
# define DEBUG

# define TRACE2
# undef TRACE2
# include <stdio.h>
# include "parm.h"
# include "arith.h"

# ifdef TRACE
#   define IFTRACE(x) x
# else
#   define IFTRACE(x)
# endif

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

# include "stree/ststructs.mh"
# ifdef DEBUG
#   include "stree/is_ptr.h"
# endif

# include "sigs.h"

# include "stree/Array.h"

# Needed to construct type signatures for constructions 
# include "pass1/stt/sttdefs.h"

extern FILE * unparse_file;

extern boolean Gflag;

extern int yynerrs;

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

NODE * declerr;     # declsig failure indication 

NODE * substerr;    # subst error indication           
# Set to something other than SUCCESS if       
    # subst is asked to substitute an incompletely 
# expanded expression, as indicated by         
    # dontsubst                                    

extern int match_len;      # length of argument type.  Set by amatch. 
extern unsigned * match_delv;  # bitvector indicating necessary deletions 
# set by amatch.                           

# ifdef VAX
int nargs();
# endif

void find_inline();

void Gfind_inline();

NODE * coerce();

NODE * infer_args();

NODE * declsig();

NODE * fixhints();

char * (* spcl_to_inline)();

boolean may_fail; # current signature deduction may fail 
# without dire consequences.           
#DJDSTART
procedure findapplsig(p_orig)
    local args, op, r,  q, decl, den, op_sig, ext_args, par_sig, nargs, narg, p
    local s_par_sig

    p := fix_p(p_orig)
    args := p . ap_args
    op := p . ap_operator

    
    # find signatures of the arguments
    temp := args . lh_first
    while \ temp do 
	{
	    q := temp.cn_hd_field
	    if ((r := findsig(q,FALSE)) ~= SUCCESS) then 
		{
                    p . sig_done = SIG_UNKNOWN
                    return(r)
                }
	    if (q . signature = ERR_SIG) then {
		p . signature := ERR_SIG
		p . sig_done := SIG_DONE
		return(SUCCESS)
	    }
	    temp := temp.cn_tl_field
	}
    # find signature of the operator 
    if (op . kind = OPRID | op . kind = LETTERID) then {
	# use argument list to find right decl. 
	op . id_appl := p
    }
    if ((r := findsig(op,FALSE)) ~= SUCCESS) then {
	p . sig_done := SIG_UNKNOWN
	return(r)
    }
    if (op . signature = ERR_SIG) then {
	p . signature := ERR_SIG
	p . sig_done := SIG_DONE
	return(SUCCESS)
    }
    # Make sure operator signature is not an identifier. 
    while (op . signature . kind = OPRID |
	   op . signature . kind = LETTERID) do {
	       decl := op . signature . id_last_definition

	       if (decl . kind = DECLARATION &
		   decl . decl_sig_transp) then {
		       den := decl . decl_denotation

		       if (den . kind = LETTERID |
			   den . kind = OPRID |
			   den . kind = FUNCSIGNATURE) then {
			       chgsig(op, den)
			   } else {
			       break
			   }
		   }
	   }
    if (op . signature . kind ~= FUNCSIGNATURE) then {
	rpt_err("findapplsig Error - non-function used as operator")
	p . signature := ERR_SIG
	p . sig_done := SIG_DONE
	return(SUCCESS)  # i.e. this routine already 
	# dealt with the error.     
    }
    # insert Valueof and constant applications, 
    # omitted arguments,
    # and type coercions (forgetting)           
    {
	op_sig := op . signature

	if (length(op_sig . fsig_param_list) >= length(args)) then {
	    nargs := emptylist()  # modifed version  
	    # of argument list 

	    
	    temp1 := args.lh_first
	    temp2 := op_sig . fsig_param_list.lh_first
	    while \temp1 & \ temp2 do {
		s := temp.cn_hd_field
		r := temp.cn_hd_field
		par_sig := r . par_signature
		while (par_sig . kind = LETTERID |
		       par_sig . kind = OPRID) do {
			   par_sig := par_sig.id_last_definition.decl_denotation
		       }
		if (s . signature ~= ERR_SIG &
		    par_sig . kind = VALSIGNATURE &
		    s . signature . kind ~= VALSIGNATURE) then {
                        narg := coerce(s)

                        if((q := findsig(narg,FALSE)) ~= SUCCESS) then {
                            p . signature := nil
                            vfree(nargs)
                            p . sig_done := SIG_UNKNOWN
                            return(q)
                        }
                        addright(nargs, narg)
                    } else {
                        addright(nargs, s)
                    }
		
		temp1 := temp1.cn_tl_field
		temp2 := temp2.cn_tl_field
	    }
	    if (length(op_sig . fsig_param_list) > length(args)) then
	    {
		# Add any missing arguments 
		ext_args := infer_args(nargs,
				       op_sig . fsig_param_list,
				       p . ap_void_decl, op)
		if (/ ext_args) then {
		    p . signature := ERR_SIG
		    p . sig_done := SIG_DONE
		    rpt_err("findapplsig Can't infer missing arguments")
		    return(SUCCESS)
		} else {
		    nargs := ext_args
		}
	    }
	    args := nargs
	    nargs := emptylist()
	    temp1 := args.lh_first
	    temp2 := op_sig . fsig_param_list.lh_first
	    while \temp1 & \temp2 do {
		s := temp1.cn_hd_field
		r := temp2.cn_hd_field

		par_sig := r . par_signature
		if (par_sig . kind = LETTERID |
		    par_sig . kind = OPRID) then {
			par_sig := sig_structure(par_sig)
		    }
		if (par_sig . kind = TYPESIGNATURE) then {
		    substerr := SUCCESS
		    s_par_sig := subst(par_sig,
				       op_sig . fsig_param_list,
				       args)
		    lock(s_par_sig)
		    if (substerr = SUCCESS &
			amatch(s . signature, s_par_sig) &
			\ match_delv ) then {
			    # components need to be forgotten 
			    narg := mknode( [MODPRIMARY,
					     s,
					     NIL,
					     match_delv] )
			    narg . mp_orig_length := match_len
			    narg.signature := delcomp(s . signature,
						      match_delv)
			    # s_par_sig would be OK, exc. 
			    # for opt. info.              
			    narg . sig_done := SIG_DONE
			    addright(nargs, narg)
			} else {
			    if (substerr ~= SUCCESS) then {
				# Cant  decide whether and how to do 
				    # coercion yet.                      
				p . sig_done := SIG_UNKNOWN
				return(substerr)
			    }
			    addright(nargs, s)
			}
		    vfree(unlock(s_par_sig))
		} else {
		    addright(nargs, s)
		}
		

		temp1 := temp1.cn_tl_field
		temp2 := temp2.cn_tl_field
	    }
	    p . ap_args := nargs
	    args := nargs
	}
    }
    # compute result signature 
    substerr := SUCCESS; # reinitialize error indication 
    initsig(p,
	    subst(op . signature . fsig_result_sig,
		  op . signature . fsig_param_list,
		  args
		  )
            )
    # Add special info for arrays 
    if (special_tp(op . signature . fsig_special) = STD_ARRAY) then {
	fix_array_sig(p . signature,first(args), second(args))
    }
    if (substerr ~= SUCCESS) then {
	# clear signature field 
	chgsig(p, NIL)
	p . sig_done := SIG_UNKNOWN
    } else {
	p . sig_done := SIG_DONE
    }
    if (has_sig(p) ~= FALSE  &
	(p . signature . kind = FUNCSIGNATURE |
	 p . signature . kind = TYPESIGNATURE)) then {
	     # leaving environment which might be needed 
	     # to evaluate a function produced by this   
	     # application.                              
	     clear_slink_known(p . signature)
	     # We should really copy the signature  
	     # rather than zapping it in place, but 
	     # this is safe, and it rarely matters. 
	 }
    return(substerr)
end
