
$include "defs.icn"
$include "global_vars.icn"

#DJDSTOP
# 
# 
# # define TRACE
# # undef TRACE
# # define DEBUG
# 
# # define TRACE2
# # undef TRACE2
# 
# # ifdef DEBUG
# #   define IFDEBUG(x) x
# # else
# #   define IFDEBUG(x)
# # endif
# 
# # include <stdio.h>
# # include "parm.h"
# # include "arith.h"
# 
# # 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 boolean Nflag;  # No Call/cc calls
# 
# # define UNDEFNAME ((sttrelptr) 0)   # the name of an anonymous identifier
# 
# extern sttrelptr indx_New,
# indx_ValueOf,
# indx_assign,
# indx_equals,
# indx_ne,
# indx_Mk,
# indx_First,
# indx_Last,
# indx_Pred,
# indx_Succ,
# indx_Ord,
# indx_OrdInv,
# indx_Card,
# indx_In,
# indx_Out;
# 
# extern NODE * sig_New,
# * sig_ValueOf,
# * sig_assign,
# * sig_equals,
# * sig_const,
# * val_Boolean,
# * val_Integer,
# * val_Void,
# * sig_Signature;
# 
# # Given a type sig comp corr to a function, set the inline code to match
# # the special field
# # define init_inline(r) \
#     (r) . tsc_signature . fsig_inline_code = \
# (*spcl_to_inline)((r) . tsc_signature . fsig_special);
# 
# extern int yynerrs;
# 
# extern int next_pre; # needed so that comparison for declarations will
# # continue to work.
# 
# # 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
# 
# extern NODE * curr_tsig;
# # type signature corresponding to local type identifier
# 
# 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.
# 
# extern NODE * failed_asig;  # Set by amatch to indicate last failure
# extern NODE * failed_psig;  # Used as a hint in error message
# extern NODE * failed_comp;
# 
# struct cn * dontsubst = nil; # list of incompletely expanded nodes
# # which should not be substituted into
# # signatures.
# 
# extern int comp_index;
# 
# # ifdef VAX
# int nargs();
# # endif
# 
# void find_inline();
# 
# void Gfind_inline();
# 
# boolean may_fail = FALSE; # current signature deduction may fail
# # without dire consequences.
# 
# #
# *    findsig(p,dont_coerce) finds the signature corresponding to the expression
# * tree rooted at p and of all its subexpressions.
# *    If the sig_done field of p is already SIG_IN_PROGRESS it fails by
#     * returning the pointer p.
# *    If it is SIG_DONE findsig immediately returns SUCCESS.
# *    If sig_done is originally nil it is set to SIG_IN_PROGRESS
# * and begins the (usually recursive) signature computation.
# * If any of the subsidiary computations fail by running into a computation
# * which is already IN_PROGRESS the offending
# * node pointer is returned.
# *    If findsig succeeds in determining the signature it stores it in the
# * signature field and returns SUCCESS.
# *    IN_PROGRESS is thus used to detect and abort non-terminating
# * signature calculations.
# *    The special value ERR_SIG is used to avoid avalanche errors.  It is
# * treated as an acceptable signature in all contexts.
# *    Note that it is not acceptable to immediately set signatures
# * to ERR_SIG once a cycle is encountered.  It is quite possible
# * that the cycle is encountered as a result of using one particular
# * branch of a conditional to evaluate its signature, and that
# * backtracking and using another branch will still result in success.
# *    Dont_coerce indicates that the expression is used in a context
# * in which the result signature doesnt matter.  Thus no attempt
# * need be made to coerce the branches of a conditional to match.
# * Note that the value of this argument only matters the first time
# * findsig is called on a given node.
# *    The sig_done field is set to SIG_DONE whenever signature computation
# * for that node is completed.  The one exception are anonymous local
#     * type identifiers.  In their case the signature must be recomputed
# * each time the node is encountered.
# 
# 
# # Finish up after recognizing a separately reported
# # error.
# # define err_return \
#     p . signature = ERR_SIG; \
# p . sig_done = SIG_DONE; \
# return(SUCCESS);            # dealt with it here
# 
# # ifdef DEBUG
# NODE * return_val;
# #   define return(p) { return_val = p; goto findsig_out; }
# # endif
# #DJDSTART

procedure findsig(p_orig, dont_coerce)
    local  knd, status , q, r ,all_ok
    local nresult, old_may_fail, is_void
    local good_element, kinds_differ, coerce_guards, prev_kind,curr_kind
    local nelement, nguard, last_den, den_sig

    local par_list, arg_list, comp_list, local_id, self_it, simple_type, len, i
    local temp, par, arg, t, s, vac

    local field_list, id_list, self_param,self_plist
    local Int_param , Int_plist

    local In_sig, Out_sig, sig, orig_sig, new_sig, id_In, id_Out, Osig

    local  Mk_param_list
    local  id_New, id_ValueOf, id_assign, re_den_sig
    local vl_field_sig,  vr_field_sig
    local sel_sig, maxlen

    if /p_orig then rpt_err("findsig: p_orig nil")
    p := fix_p(p_orig)
    if /p then rpt_err("findsig: p  nil")

    status := p . sig_done
    # signature evaluation for all subexpressions
    # was successful.

    if (status === SIG_DONE) then
	return(SUCCESS)
    if (status === SIG_IN_PROGRESS) then { # infinite signature computation
	return(p)
    }
    knd := p . kind
    # compute new signature
    p . sig_done := SIG_IN_PROGRESS
    case (knd) of {
	OPRID:
	    return(findidsig(p))
	LETTERID:
	    return(findidsig(p))
	VALSIGNATURE:
	    {
		initsig(p, sig_Signature)
		p . sig_done := SIG_DONE
		return(SUCCESS)
	    }
	VARSIGNATURE:
	    {
		initsig(p, sig_Signature)
		p . sig_done := SIG_DONE
		return(SUCCESS)
	    }
	FUNCSIGNATURE:
	    {
		initsig(p, sig_Signature)
		p . sig_done := SIG_DONE
		return(SUCCESS)
	    }
	TYPESIGNATURE:
	    {
		initsig(p, sig_Signature)
		p . sig_done := SIG_DONE
		return(SUCCESS)
	    }
	SIGNATURESIG:
	    {
		initsig(p, sig_Signature)
		p . sig_done := SIG_DONE
		return(SUCCESS)
	    }
	FUNCCONSTR:
	    {
		q := p . signature . fsig_result_sig;
		if (/q) then { # need to fill in result signature
		    if ((r := findsig(p . fc_body,FALSE)) ~= SUCCESS) then {
			p . sig_done = SIG_UNKNOWN
                        return(r)
		    }
		    if(p . fc_body . signature ~= ERR_SIG) then {
			p.signature.fsig_result_sig := p.fc_body.signature
			if (Gflag ~= FALSE) then {
			    Gfind_inline(p)
			} else {
			    find_inline(p)
			}
		    } else {
			p . signature . fsig_result_sig := ERR_SIG
		    }
		    p . sig_done := SIG_DONE
                    return(SUCCESS)
		} else {
		    # find signature of body if possible
		    old_may_fail := may_fail
		    if comp_st(val_Void, q, nil, nil) = 0
		    then is_void := TRUE
		    else is_void := FALSE

		    if (p . fc_body . kind = EXTERNDEF) then {
			p . sig_done := SIG_DONE
			if (Gflag ~= FALSE) then {
			    Gfind_inline(p)
			} else {
			    find_inline(p)
			}
			return(SUCCESS)
		    }
		    may_fail := TRUE    # This has low priority
		    r := findsig(p . fc_body, is_void)
		    may_fail := old_may_fail
		    if (r ~= SUCCESS) then {
			dontsubst := cn_cons(p, dontsubst)
			p . sig_done := SIG_DONE
			return(SUCCESS)
		    }
                    # q is still the result signature
		    if (q = ERR_SIG |
			p . fc_body . signature = ERR_SIG) then {
			    p . sig_done := SIG_DONE
			    return(SUCCESS)
			}
		    if (q . kind = VALSIGNATURE & is_void = FALSE &
			p . fc_body . signature . kind ~= VALSIGNATURE) then {
			    # attempt coercion
			    nresult := coerce(p . fc_body)
			    if ((r := findsig(nresult,FALSE)) ~= SUCCESS) then {
				p . sig_done := SIG_UNKNOWN
				vfree(nresult)
				return(r)
			    }
			    p . fc_body := nresult
			}
                    if (q . kind = TYPESIGNATURE &
                        amatch(p . fc_body . signature,q) &
                        \match_delv) then  {  # forget components
			    nresult := mknode([MODPRIMARY,
					       p . fc_body,
					       nil,
					       match_delv])
			    nresult . mp_orig_length := match_len
			    nresult . signature := q
			    nresult . sig_done := SIG_DONE
			    p . fc_body := nresult
			}
		    # replace result signature to take advantage of
			# optimization information
                    if (comp_st(p . fc_body . signature,
                                p . signature . fsig_result_sig,
                                nil, nil) = 0) then {
				    p.signature.fsig_result_sig := p.fc_body.signature
				}
		    if (Gflag ~= FALSE) then {
			Gfind_inline(p)
		    } else {
			find_inline(p)
		    }
		    p . sig_done := SIG_DONE
		    return(SUCCESS)
		}
	    }
	APPLICATION:
	    return(findapplsig(p))
	GUARDEDLIST:
	    {
		prev_kind := -1
		old_may_fail := may_fail;

		good_element := nil
		all_ok := TRUE
		kinds_differ := FALSE
		coerce_guards := FALSE
		# find signatures of guarded expressions where possible
		temp := p . gl_list.lh_first
		while \temp do {
		    q := temp.cn_hd_field
		    if(findsig(q . ge_element,dont_coerce) = SUCCESS) then {
			good_element := q
			if (q . ge_element . signature ~= ERR_SIG) then {
			    curr_kind := q . ge_element . signature . kind;
			    if (prev_kind ~= -1 &
				curr_kind ~= prev_kind) then {
				    kinds_differ := TRUE
				}
			    prev_kind := curr_kind
			}
		    } else {
			all_ok := FALSE
		    }
		    temp := temp.cn_tl_field
		}
		may_fail := TRUE
		# Now find signatures of guards
		temp :=  p . gl_list.lh_first
		while \temp do {
		    s := cn_hd_field
		    if ((q := findsig(s . ge_guard,FALSE)) ~= SUCCESS) then {
			all_ok := FALSE
		    } else if (s . ge_guard . signature ~= ERR_SIG &
			       s . ge_guard . signature . kind ~= VALSIGNATURE) then {
				   coerce_guards := TRUE
			       }
		    temp := cn_tl_field
		}
		may_fail := old_may_fail
		if ( /good_element  | (may_fail ~= FALSE & all_ok = FALSE)) then {
		    # cant determine signature of any subexpression
		    # or its not worth going on partial info
		    p . sig_done := SIG_UNKNOWN
		    return(p);
		}
		if ( (kinds_differ ~= FALSE) | coerce_guards ~= FALSE) then
		    # && (all_ok || !may_fail) ) {
		# add omitted V and constant application coercions
		# where possible
		if ((dont_coerce = FALSE) & kinds_differ ~= FALSE) then {
		    # May be impossible to find result sig
		    # after coercion
		    good_element := nil
		}
		temp :=  p . gl_list.lh_first
		while \temp do {
		    s := temp.cn_hd_field
		    if (dont_coerce = FALSE & kinds_differ ~= FALSE & \ (s . ge_element . signature)) then  {
			nelement := coerce(s . ge_element)
			if (nelement . sig_done = SIG_UNKNOWN) then {
			    if ((q := findsig(nelement, FALSE)) = SUCCESS) then {
				good_element := s
				s . ge_element := nelement
			    } else {
				all_ok := FALSE
				vfree(nelement)
				if (may_fail ~= FALSE) then {
				    p . sig_done := SIG_UNKNOWN
				    return(s)
				}
			    }
			} else {
			    good_element := s
			}
		    }
		    if (coerce_guards ~= FALSE & \ ( s . ge_guard . signature)) then {
			nguard := lock(coerce(s . ge_guard))
			if (nguard . sig_done = SIG_UNKNOWN) then {
			    if ((q := findsig(nguard, FALSE)) = SUCCESS) then {
				s . ge_guard := nguard
				unlock(nguard)
			    } else {
				vfree(unlock(nguard))
				p . sig_done := SIG_UNKNOWN
				return(s)
			    }    }    }
		    temp := temp.cn_tl_field }
		# At least one element had val or func signature
		# It must have been possible to determine its
		# signature after coercion. Thus good_element
		# != nil
		if(all_ok = FALSE) then {
		    # signature is known, but subexpressions havent
		    # been completely expanded.
		    dontsubst := cn_cons(p, dontsubst)
		}
		initsig(p, good_element . ge_element . signature)
		if (dont_coerce = FALSE) then # value matters
		# Fix up code generator information
		temp :=  p . gl_list . lh_first
		while \temp do {
		    q := temp.cn_hd_field
		    r := fixhints(p . signature,q . ge_element . signature)
		    if (r != p . signature) then {
			chgsig(p, r)
		    }
		    temp := temp.cn_tl_field
		}
		p . sig_done := SIG_DONE
		return(SUCCESS)
	    }
	BLOCKDENOTATION:
	    {
		last_den := last(p . bld_den_seq)
		old_may_fail := may_fail
		if((q := findsig(last_den,FALSE)) ~= SUCCESS) then {
		    p . sig_done := SIG_UNKNOWN
		    return(q)
		}
		all_ok := TRUE
		may_fail := TRUE
		# Now find signatures of all subexpressions
		temp := p . bld_declaration_list.lf_first
		while \temp do {
		    s := temp.cn_hd_field
		    if((q := findsig(s . decl_denotation,FALSE)) ~= SUCCESS)then {
			all_ok := FALSE
		    }
		    temp := temp.cn_tl_field
		}
		temp :=  p . bld_den_seq.lh_first
		while \temp do {
		    s := temp.cn_hd_field
		    if((q := findsig(s,TRUE)) ~= SUCCESS) then {
			all_ok := FALSE;
		    }
		    temp := temp.cn_tl_field
		}
		may_fail := old_may_fail;
		initsig(p, last_den . signature)
		if (Nflag = FALSE | iand(p . bld_flags , NO_SURR_LOOP) = FALSE ) then {
		    # May need a.r. for this block
		    clear_slink_known(p . signature)
		}
		if (all_ok = FALSE) then
		    dontsubst := cn_cons(p, dontsubst)
		p . sig_done := SIG_DONE
		return(SUCCESS)
	    }
	USELIST:
	    {
		last_den := last(p . usl_den_seq)
		old_may_fail := may_fail

		# find signatures of types
		temp :=  p . usl_type_list.lh_first
		while \temp do {
		    s := temp.cn_hd_field
		    if ((q := findsig(s,FALSE)) ~= SUCCESS) then {
			p . sig_done := SIG_UNKNOWN
			return(q)
		    } else {
			if (s . signature ~= ERR_SIG &
			    (s . signature . kind = LETTERID |
			     s . signature . kind = OPRID)) then {
				 s . signature := sig_structure(s . signature)
			     }
		    }
		    temp := temp.cn_tl_field
		}
		if((q := findsig(last_den,FALSE)) ~= SUCCESS)  then {
		    p . sig_done := SIG_UNKNOWN
		    return(q)
		}
		# Now find signatures of all subexpressions
		may_fail := TRUE
		all_ok := TRUE
		temp :=  p . usl_den_seq
		while \temp do {
		    s := temp.cn_hd_field
		    if((q := findsig(s,TRUE)) ~= SUCCESS) then {
			all_ok := FALSE
		    }
		    temp := temp.cn_tl_field
		}
		may_fail := old_may_fail
		initsig(p, last_den . signature)
		if (all_ok = FALSE) then
		    dontsubst := cn_cons(p, dontsubst)
		p . sig_done := SIG_DONE
		return(SUCCESS)
	    }
	WORDELSE:
	    {
		p . signature := val_Boolean
		p . sig_done := SIG_DONE
		return(SUCCESS)
	    }
	LOOPDENOTATION:
	    {
		# Find signatures of all subexpressions
		old_may_fail := may_fail
		all_ok := TRUE
		may_fail := TRUE
		temp :=  p . gl_list.lh_first
		while \temp do {
		    s := temp.cn_hd_field
		    if ((q := findsig(s . ge_guard,FALSE)) ~= SUCCESS) then {
			all_ok := FALSE
		    } else {
			# coerce if necessary
			nguard := coerce(s . ge_guard)
			if (nguard . sig_done = SIG_UNKNOWN) then {
			    if ((q := findsig(nguard, FALSE)) = SUCCESS) then {
				s . ge_guard := nguard
			    } else {
				vfree(nguard)
				p . sig_done := SIG_UNKNOWN
				may_fail := old_may_fail
				return(s)
			    }
			}
		    }
		    if((q := findsig(s . ge_element,TRUE)) ~= SUCCESS) then {
			all_ok := FALSE
		    }
		    temp := temp.cn_tl_field
		}
		may_fail := old_may_fail
		p . signature := val_Void
		if (all_ok = FALSE) then
		    dontsubst := cn_cons(p, dontsubst)
		p . sig_done := SIG_DONE
		return(SUCCESS)
	    }

	WORDCAND:
	    {
		rpt_dbg("findsig: cand  in syntax tree")
                return(SUCCESS)
	    }
	WORDCOR:
	    {
                dbgmsg("findsig:  cor in syntax tree\n")
                return(SUCCESS)
	    }
	QSTR:
	    {
		$include "pass4/findsig_str.inc.icn"
	    }
	UQSTR:
	    {
		$include "pass4/findsig_str.inc.icn"
	    }
	MODPRIMARY:
	    {
		return(findmpsig(p))
	    }
	PRODCONSTRUCTION:
	    {
		par_list := p . prod_components
		comp_list := lock(emptylist())
		if / (p . prod_local_type_id) then
		    local_id := mknode([LETTERID, UNDEFNAME])
		else local_id := copynode(p . prod_local_type_id)
		self_it := mknode([VALSIGNATURE, local_id])
		simple_type := TRUE
		len := length(par_list)
		# Compute product size
		if (Gflag ~= FALSE) then {
		    len := 0
		    temp := par_list.lh_first
		    while \temp do {
			s := temp.cn_hd_field
			if (vacuous_arg(s . par_signature) = FALSE) then {
			    len +:= 1
			}
			temp := temp.cn_tl_field
		    }
		} else {
		    len := length(par_list)
		}
		# Put New, ValueOf and := in component list
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_New),
			     copynode(sig_New)])
		r.tsc_signature . fsig_special :=  special(PROD_NEW, len);
		init_inline(r)
		addright(comp_list, r)
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_ValueOf),
			     copynode(sig_ValueOf)])
		r . tsc_signature . fsig_special := special(PROD_VALUEOF, len)
		init_inline(r)
		addright(comp_list, r)
		r = mknode([TSCOMPONENT,
			    mkcompnm(indx_assign),
			    copynode(sig_assign)])
		r . tsc_signature . fsig_special :=  special(PROD_ASSIGN, len)
		init_inline(r)
		addright(comp_list, r)
		# add Mk function
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_Mk),
			     mknode([FUNCSIGNATURE, nil,
				     par_list,
				     self_it
				     ])
			     ])
		r . tsc_signature . fsig_special :=  special(PROD_MK, len)
		init_inline(r)
		addright(comp_list, r)
		{# add projection functions
		    par := emptylist() # parameter list for
		    # func signature
		    arg := emptylist()  # list containing
		    # argument in function
		    # applications
		    # fix up par and arg
		    addright(par, t := mknode([PARAMETER, nil, self_it]))
		    t . pre_num := next_pre
		    next_pre +:= 1
		    # so copies can be recognized
		    addright(arg, t := mknode([LETTERID, UNDEFNAME]))
		    t . id_last_definition := first(par)
		    t . id_def_found := TRUE

		    # build arg_list
		    arg_list := lock(emptylist())
		    temp := par_list.lh_first
		    while \temp do {
			s := temp.cn_hd_field
			r := copynode(s . par_id)
			r . sel_type := local_id
			r . id_last_definition := nil
			r . id_def_found := TRUE;
			r := mknode([APPLICATION, r, arg])
			addright(arg_list,r)
			temp := temp.cn_tl_field
		    }
		    i := 0
		    temp := par_list.lh_first
		    while \temp do {
			s := temp.cn_hd_field
			if Gflag ~= FALSE & vacuous_arg(s . par_signature)
			then   vac := TRUE
			else   vac := FALSE
			# Not represented in product
			r := mknode([FUNCSIGNATURE,
				     nil, # SHOULD BE INLINE CODE
				     par,
				     subst(s . par_signature,
					   par_list,
					   arg_list)
				     ])
			if (vac = FALSE)then {
			    r . fsig_special := special(PROD_PROJ, i)
			} else {
			    r . fsig_special := special(UNDEF_CONST, 0)
			}
			if ( / (s . par_id)) then {
			    rpt_err_node( "Product component not named",s)
			}
			r := mknode([TSCOMPONENT, s . par_id, r])
			init_inline(r)
			addright(comp_list, r)
			if (vac = FALSE) then {
			    i +:= 1
			}
			temp := temp.cn_tl_field
		    }
		}
		initsig(p, mknode([TYPESIGNATURE,
				   local_id,
				   comp_list,
				   nil, nil, nil]))
		p . signature . pre_num := next_pre
		next_pre +:= 1
		# so copies can be recognized
		tsig_order(p . signature)
		# Make references to product local type id point to
		    # signature instead
		# Make sure tsubst doesn't get confused
		local_id . id_def_found := TRUE
		local_id . id_last_definition := p . signature
		p . signature := tsubst(p . signature,
					p,
					local_id,
					FALSE)
		# Fix up local_id
		local_id . id_def_found := TRUE
		local_id . id_last_definition := p . signature
		p . sig_done := SIG_DONE
		# Compute whether resulting type is "simple"
		temp := par_list. lh_first
		while \temp do {
		    s := temp.cn_hd_field
		    case (s . par_signature . kind) of {
			FUNCSIGNATURE:
			    simple_type := FALSE
			TYPESIGNATURE:
			    simple_type := FALSE
			VALSIGNATURE:
			    {
				if (findsig(s.par_signature.val_denotation, FALSE) ~= SUCCESS) then {
				    simple_type := FALSE
				} else {
				    den_sig := s.par_signature.val_denotation.signature
				    if (den_sig ~= ERR_SIG & den_sig.kind = TYPESIGNATURE) then {
					if simple_type ~= FALSE & den_sig . ts_simple_type ~= FALSE then
					    simple_type := TRUE
					else simple_type := FALSE
				    }
				}
			    }
			# checksigs will complain about VARSIGNATUREs
		    }
		    temp := temp . cn_tl_field
		}
		p . signature . ts_simple_type := simple_type
		unlock(comp_list)
		unlock(arg_list)
		vfree(arg_list)
		return(SUCCESS)
	    }
	UNIONCONSTRUCTION:
	    {
		{
		    field_list := p . prod_components
		    comp_list := lock(emptylist())
		    if / (p . prod_local_type_id) then
			local_id := mknode([LETTERID, UNDEFNAME])
		    else local_id := copynode(p . prod_local_type_id)
		    self_it = mknode([VALSIGNATURE, local_id])
		    len := length(field_list)
		    # Put New, ValueOf and := in component list
		    r := mknode([TSCOMPONENT,
				 mkcompnm(indx_New),
				 copynode(sig_New)])
		    r . tsc_signature . fsig_special := special(UNION_NEW, len)
		    init_inline(r)
		    addright(comp_list, r)
		    r := mknode([TSCOMPONENT,
				 mkcompnm(indx_ValueOf),
				 copynode(sig_ValueOf)])
		    r . tsc_signature . fsig_special := special(UNION_VALUEOF, len)
		    init_inline(r)
		    addright(comp_list, r)
		    r = mknode([TSCOMPONENT,
				mkcompnm(indx_assign),
				copynode(sig_assign)])
		    r . tsc_signature . fsig_special := special(UNION_ASSIGN, len);
		    init_inline(r)
		    addright(comp_list, r)
		    {# add projection, injection and inquiry functions
			par = emptylist(); # parameter list for
			# func signature
			# fix up par
			addright(par, t := mknode([PARAMETER, nil, self]))
			t . pre_num = next_pre
			next_pre +:= 1

			i := 0
			temp := field_list.lh_first
			while \temp do {
			    s := temp.cn_hd_field
			    #  begin_maplist(s, ) {
			    if Gflag = FALSE & vacuous_arg(s . par_signature)
			    then 	vac := TRUE
			    else vac := FALSE
			    # This field is not really represented
			    if (s . par_id . kind ~= LETTERID) then {
				rpt_err("Bad union field name: " ||
					getname(s . par_id . id_str_table_index))
			    }
			    # Projection
			    r = mknode([FUNCSIGNATURE,
					nil, # SHOULD BE INLINE CODE
					par,
					s . par_signature
					])
			    if (vac = FALSE) then {
				r . fsig_special := special(UNION_PROJ, i);
			    } else {
				r . fsig_special := special(UNDEF_CONST, 0);
			    }
			    r . fsig_inline_code :=
				(spcl_to_inline)(r . fsig_special)
			    addright(comp_list,
				     mknode([TSCOMPONENT,
					     prefix ("to_", s . par_id),
					     r])
				     )
			    # Inquiry
			    r := mknode([FUNCSIGNATURE,
					 nil, # SHOULD BE INLINE CODE
					 par,
					 val_Boolean
					 ])
			    r . fsig_special := special(UNION_INQ, i)
			    r . fsig_inline_code := (spcl_to_inline)(r . fsig_special)
			    addright(comp_list,
				     mknode([TSCOMPONENT,
					     prefix ("is_", s . par_id),
					     r])
				     )
			    # Injection
			    r := mknode([FUNCSIGNATURE,
					 nil,
					 mklist([ mknode(PARAMETER,
							 nil,
							 s . par_signature),

						 ]),
					 self_it
					 ])
			    if (vac = FALSE) then {
				r . fsig_special = special(UNION_INJ, i)
			    } else {
				r . fsig_special = special(UNION_INJ0, i)
			    }
			    r . fsig_inline_code :=
				(spcl_to_inline)(r . fsig_special)
			    addright(comp_list,
				     mknode([TSCOMPONENT,
					     prefix ("from_", s . par_id),
					     r])
				     )
			    i +:= 1
			}
			temp := temp.cn_tl_field # end_maplist;
		    }
		}
		initsig(p, mknode([TYPESIGNATURE, nil,comp_list,nil, nil, nil]))
		p . signature . pre_num := next_pre
		next_pre +:= 1
		# so copies can be recognized
		tsig_order(p . signature)
		# Make references to union local type id point to
		    # signature instead
		# Make sure tsubst doesn't get confused
		local_id . id_def_found := TRUE
		local_id . id_last_definition := p . signature
		p . signature := tsubst(p . signature,
					p,
					local_id,
					FALSE)
		# Fix up local_id
		local_id . id_last_definition := p . signature
		p . sig_done := SIG_DONE
		# Compute whether resulting type is "simple"
		temp := field_list.lh_first
		while \temp do {
		    s := temp.cn_hd_field

		    case (s . par_signature . kind) of {
			FUNCSIGNATURE:
			    simple_type := FALSE
			TYPESIGNATURE:
			    simple_type := FALSE
			VALSIGNATURE:
			    {
				if(findsig(s . par_signature . val_denotation, FALSE)  ~= SUCCESS) then {
				    simple_type := FALSE
				} else {
				    den_sig := s . par_signature . val_denotation. signature;
				    if (den_sig ~= ERR_SIG &
					den_sig . kind = TYPESIGNATURE) then {
					    if  simple_type ~= FALSE &
						den_sig . ts_simple_type ~= FALSE then
						simple_type := TRUE
					    else
						simple_type := FALSE1
					}
				}
			    }
			# checksigs will complain about VARSIGNATUREs
		    }
		    temp := temp.cn_tl_field
		}
		p . signature . ts_simple_type := simple_type
		vfree(comp_list)
		return(SUCCESS)
	    }

	ENUMERATION:
	    {
		id_list := p . enum_id_list
		comp_list := lock(emptylist())
		local_id := mknode([LETTERID, -1])
		self_it = mknode([VALSIGNATURE, local_id])
		self_param := mknode([PARAMETER, nil, self_it])
		self_plist := mklist([self_param])
		Int_param := mknode([PARAMETER, nil, val_Integer])
		Int_plist := mklist([Int_param])
		len := length(id_list)
		# Put New, ValueOf and := in component list
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_New),
			     copynode(sig_New)])
		r . tsc_signature . fsig_special :=	special(ENUM_NEW, len)
		init_inline(r)
		addright(comp_list, r)
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_ValueOf),
			     copynode(sig_ValueOf)])
		r . tsc_signature . fsig_special :=	special(ENUM_VALUEOF, len)
		init_inline(r)
		addright(comp_list, r)
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_assign),
			     copynode(sig_assign)])
		r . tsc_signature . fsig_special :=	special(ENUM_ASSIGN, len)
		init_inline(r)
		addright(comp_list, r)
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_equals),
			     copynode(sig_equals)])
		r . tsc_signature . fsig_special :=	special(ENUM_EQ, len)
		init_inline(r)
		addright(comp_list, r)
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_ne),
			     copynode(sig_equals)])
		r . tsc_signature . fsig_special := special(ENUM_NE, len)
		init_inline(r)
		addright(comp_list, r)
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_First),
			     copynode(sig_const)])
		r . tsc_signature . fsig_special := special(ENUM_ELEMENT, 0)
		init_inline(r)
		addright(comp_list, r)
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_Last),
			     copynode(sig_const)])
		r . tsc_signature . fsig_special := special(ENUM_ELEMENT, len-1)
		init_inline(r)
		addright(comp_list, r)
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_Pred),
			     mknode([FUNCSIGNATURE,
				     nil, self_plist, self])])
		r . tsc_signature . fsig_special := special(ENUM_PRED, len)
		init_inline(r)
		addright(comp_list, r)
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_Succ),
			     mknode([FUNCSIGNATURE,
				     nil, self_plist, self])])
		r . tsc_signature . fsig_special := special(ENUM_SUCC, len)
		init_inline(r)
		addright(comp_list, r)
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_Ord),
			     mknode([FUNCSIGNATURE,
				     nil, self_plist, val_Integer])])
		r . tsc_signature . fsig_special := special(IDENTITY, len)
		init_inline(r)
		addright(comp_list, r)
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_OrdInv),
			     mknode([FUNCSIGNATURE,
				     nil, Int_plist, self])])
		r . tsc_signature . fsig_special := special(IDENTITY, len)
		init_inline(r)
		addright(comp_list, r)
		r := mknode([TSCOMPONENT,
			     mkcompnm(indx_Card),
			     mknode([FUNCSIGNATURE,
				     nil, emptylist(), val_Integer])])
		r . tsc_signature . fsig_special := special(ENUM_CARD, len)
		init_inline(r)
		addright(comp_list, r)

		{# add constant functions

		    i := 0
		    temp := id_list.lh_first
		    while \temp do {
			s := temp.cn_hd_field
			r := copynode(sig_const)
			r . fsig_special := special(ENUM_ELEMENT, i)
			r . fsig_inline_code :=
			    (spcl_to_inline)(r . fsig_special)
			addright(comp_list, mknode([TSCOMPONENT, s, r]))
			i +:= 1
			temp := temp.cn_tl_field
		    }
		}
		initsig(p, mknode([TYPESIGNATURE, nil,
				   comp_list,
				   nil, nil, nil]))
		unlock(comp_list)
		p . signature . pre_num := next_pre
		next_pre +:= 1
		p . sig_done := SIG_DONE
		# so copies can be recognized
		tsig_order(p . signature)
		p . signature . ts_simple_type := TRUE
		return(SUCCESS)
	    }
	EXTENSION:
	    {
		if ((q := findsig(p . ext_denotation, FALSE)) ~= SUCCESS) then {
		    p . sig_done := SIG_UNKNOWN
		    return(q)
		}
		if (p . ext_denotation . signature = ERR_SIG) then {
		    p . signature := ERR_SIG
		    p . sig_done := SIG_DONE
		    return(SUCCESS)
		}
		# sig := copy of argument signature
		sig := lock(copynode(p . ext_denotation . signature))
		if (sig . kind ~= TYPESIGNATURE) then {
		    rpt_err("findsig: Extension argument not a type")
		    p . signature := ERR_SIG
		    p . sig_done := SIG_DONE
		    return(SUCCESS)
		}
		if \ (sig . ts_local_type_id) then {
		    local_id := lock(copynode(sig . ts_local_type_id))
		} else {
		    local_id := mknode([LETTERID, UNDEFNAME])
		}
		sig . pre_num := next_pre
		next_pre +:= 1
		# Make sure we recognize it as different from

		# the old one.
		sig . ts_clist := copylist(sig . ts_clist)
		# Fix up references to local type id of sig
		{
		    Osig := sig;

		    local_id . id_last_definition := sig
		    local_id . id_def_found := TRUE
		    sig := lock(tsubst(sig,
				       p . ext_denotation . signature,
				       local_id,
				       TRUE))
		    local_id . id_last_definition := sig
		    vfree(unlock(Osig))
		}
		# Build id nodes for In and Out
		id_In = mknode([LETTERID, indx_In])
		id_Out = mknode([LETTERID, indx_Out])
		# Build signatures of In and Out
		# check that it's safe to put arg into signature
		if \ (on_dontsubst(p . ext_denotation)) then {
		    p . sig_done := SIG_UNKNOWN
		    return(on_dontsubst(p . ext_denotation))
		}
		orig_sig := mknode([VALSIGNATURE, p . ext_denotation])
		new_sig := mknode([VALSIGNATURE, mknode([LETTERID, -1])])
		par_list := mklist([mknode([PARAMETER, nil, orig_sig])])
		In_sig := mknode([FUNCSIGNATURE,
				  nil,
				  par_list,
				  new_sig])
		par_list := mklist([mknode([PARAMETER, nil, new_sig])]);
		Out_sig := mknode([FUNCSIGNATURE,
				   nil,
				   par_list,
				   orig_sig])
		In_sig . fsig_special := special(IDENTITY, 0)
		In_sig . fsig_inline_code := (spcl_to_inline)(In_sig . fsig_special)
		Out_sig . fsig_special := special(IDENTITY, 0)
		Out_sig . fsig_inline_code := (spcl_to_inline)(Out_sig . fsig_special)
		# Check that In and Out are not already present
		# It's not clear that they can be, but rather
		# than trying to prove that, ...
		if \ (getcomp(sig, id_In, nil, In_sig, sig, nil, TRUE)) then
		    {
			rpt_err_node("findsig In occurs in extend argument sig",p);
		    }
		if \ (getcomp(sig, id_Out, nil, Out_sig, sig, nil, TRUE)) then
		    {
			rpt_err_node("Out occurs in extend argument sig",p)
		    }
		# Add In and Out, initialize indicees
		inscomp(sig, id_In, In_sig, nil)
		p . In_index := comp_index
		inscomp(sig, id_Out, Out_sig, nil)
		p . Out_index := comp_index
		initsig(p, sig)
		p . sig_done := SIG_DONE
		# No identifier references to sig, thus pre_num is
		# irrelevant.  OK to use old optimization info
		return(SUCCESS)
	    }
#				     HEREHERE
	RECORDCONSTRUCTION:
	    {
		field_list := p . enum_id_list
		comp_list := lock(emptylist())
		local_id := mknode([LETTERID, -1])
		self := mknode([VALSIGNATURE, local_id])
		self_param := mknode([PARAMETER, nil, self_it])
		self_plist := mklist([self_param])
		Mk_param_list := emptylist()
		id_New := mkcompnm(indx_New)
		id_ValueOf := mkcompnm(indx_ValueOf)
		id_assign := mkcompnm(indx_assign)
		len := length(field_list)
		# Find signatures of type expressions,  make sure
		# they can be incorporated into signatures, and
		# that they have the right components
		temp := p . rec_component_list.lh_first
		while \temp do {
		    s := temp.cn_hd_field
#	    begin_maplist(s, ) {
		    if ((q := findsig(s . re_denotation, FALSE)) ~= SUCCESS) then {
			p . sig_done := SIG_UNKNOWN
			return(q)
		    }
		    re_den_sig := s . re_denotation . signature
		    if (re_den_sig = ERR_SIG) then {
#		    err_return
			fail
		    }
		    if (re_den_sig . kind ~= TYPESIGNATURE) then {
			rpt_err_node("Non-type expression in record construction",s);
#		    err_return;
		    }
		    if \ (on_dontsubst(s . re_denotation)) then {
			p . sig_done := SIG_UNKNOWN
			return(on_dontsubst(s . re_denotation))
		    }
		    if / (getcomp(re_den_sig,
				  id_ValueOf, nil, sig_ValueOf, re_den_sig,
				  nil, TRUE)) then {
				      rpt_err_node("No V operation in record component",s)
				  }
		    s . re_ValueOf_index := comp_index
		    if / (getcomp(re_den_sig,
				  id_New, nil, sig_New, re_den_sig,
				  nil, TRUE)) then {
				      rpt_err_node("No New operation in record component",s)
				  }
		    s . re_New_index := comp_index
		    if / (getcomp(re_den_sig,
				  id_assign, nil, sig_assign, re_den_sig,
				  nil, TRUE)) then {
				      rpt_err_noe("No := operation in record component",s)
				  }
		    s . re_assign_index := comp_index
#		} # end_maplist;
		    temp:= temp.cn_tl_field
		}
		# Put New, ValueOf and := in component list
		r := mknode([TSCOMPONENT,
			     id_New,
			     copynode(sig_New)])
		r . tsc_signature . fsig_special := special(RECORD_NEW, len)
		init_inline(r)
		addright(comp_list, r)
		r := mknode([TSCOMPONENT,
			     id_ValueOf,
			     copynode(sig_ValueOf)])
		r . tsc_signature . fsig_special := special(RECORD_VALUEOF, len)
		init_inline(r)
		addright(comp_list, r)
		r = mknode([TSCOMPONENT,
			    id_assign,
			    copynode(sig_assign)])
		r . tsc_signature . fsig_special := special(RECORD_ASSIGN, len)
		init_inline(r)
		addright(comp_list, r)
		# Put Mk in comp_list
		temp := p . rec_component_list.lh_first
		while \temp do {
		    s := temp.cn_hd_field
		    r := mknode([VALSIGNATURE, s . re_denotation])
		    r = mknode([PARAMETER, nil, r])
		    addright(Mk_param_list, r)
		    temp := temp.cn_tl_field
		}
		r = mknode([FUNCSIGNATURE, nil,
			    Mk_param_list, self_it])
		r . fsig_special := special(RECORD_MK, len)
		r = mknode([TSCOMPONENT,
			    mkcompnm(indx_Mk),
			    r])
		init_inline(r)
		addright(comp_list, r)
		# Add fields
		i = 0;   # component number
		temp := p . rec_component_list.lh_first
		while \temp do {

#	    begin_maplist(s, p . rec_component_list) {
		    vl_field_sig := mknode([FUNCSIGNATURE,
					    nil,  # in-line code
					    self_plist,
					    mknode([VALSIGNATURE,
						    s . re_denotation])])
		    r := mklist([mknode([PARAMETER,
					 nil,
					 mknode([VARSIGNATURE,local_id])])])
		    vr_field_sig :=  mknode([FUNCSIGNATURE,
					     nil,
					     r,
					     mknode([VARSIGNATURE,
						     s . re_denotation])])
		    vl_field_sig . fsig_special := special(RECORD_VAL_FIELD, i)
		    vr_field_sig . fsig_special := special(RECORD_VAR_FIELD, i)
		    r := mknode([TSCOMPONENT,
				 s . re_id,
				 vl_field_sig])
		    init_inline(r)
		    addright(comp_list, r)
		    r = mknode([TSCOMPONENT,
				s . re_id,
				vr_field_sig])
		    init_inline(r)
		    addright(comp_list, r)
		    i +:= 1
#	} # end_maplist;
		    temp := temp.cn_tl_field
		}
		initsig(p, mknode([TYPESIGNATURE, nil,
				   comp_list,
				   nil, nil, nil]))
		unlock(comp_list)
		p . signature . pre_num = next_pre
		next_pre +:= 1

		p . sig_done := SIG_DONE
		# so copies can be recognized
		tsig_order(p . signature)
		# fill in ts_simple type
		p . signature . ts_simple_type := TRUE
		temp := p . rec_component_list.lh_first
		while \temp do {
		    s := temp.cn_hd_field
		    if (s . re_denotation . signature. ts_simple_type = FALSE) then {
			p . signature . ts_simple_type := FALSE
		    }
		    temp := temp.cn_tl_field
		}
		return(SUCCESS);
	    }

	REXTERNDEF:
	    rpt_err("findsig: REXTERNDEF without signature\n")
	default:
	    {
		rpt_err("findsig: unknown expression kind" || knd)
	    }
    }
end
#DJDSTOP
# 
# #
# * NODE * declsig(p)
# *  Returns the signature of the identifier declared by the declaration p
# * Sets declerr to either SUCCESS or a pointer to the offending node.
# 
# NODE *
#     declsig(p)
# NODE * p;
# {
# boolean old_may_fail;
# NODE * q;
# switch (p . kind) {
# DECLARATION:
#     if (p . decl_sig_done == SIG_DONE) {
# declerr = SUCCESS;
# return(p . decl_signature);
# }
# old_may_fail = may_fail;
# may_fail = (may_fail || p . decl_signature != nil);
# # Signature of right side should be found if at all possible
# # It's useful for optimization info, if nothing else.
# declerr = findsig(p . decl_denotation,FALSE);
# #           ifdef TRACE
# printf("declsig: p = %X, declerr = %X\n", p, declerr);
# #           endif
# if (declerr != SUCCESS) {
# if (p . decl_signature != nil) {
# declerr = SUCCESS;
# may_fail = old_may_fail;
# return(p . decl_signature);
# }
# # try to get declerr to point to an identifier
# if(declerr . kind != LETTERID && declerr . kind != OPRID) {
# declerr = p . decl_id;
# #                   ifdef TRACE
# printf("Changing decl_err to %X\n", declerr);
# #                   endif
# }
# } else {
# p . decl_sig_done = SIG_DONE;
# if (p . decl_denotation . signature == ERR_SIG) {
# p . decl_signature = ERR_SIG;
# } else {
# chgfld(&(p . decl_signature),
#        p . decl_denotation . signature);
# }
# }
# may_fail = old_may_fail;
# return(p . decl_signature);
# PARAMETER:
#     declerr = SUCCESS;
# return(p . par_signature);
# TYPESIGNATURE:
#     declerr = SUCCESS;
# return(p);
# PRODCONSTRUCTION:
#     RECORDCONSTRUCTION:
#     UNIONCONSTRUCTION:
#     MODPRIMARY:
#     declerr = findsig(p,FALSE);
# return(p . signature);
# #       ifdef DEBUG
# default:
#     dbgmsg("declsig: Bad declaration pointer: %x, kind=%s\n",
# 	   p, kindname(p.kind));
# abort();
# #       endif
# }
# }
# 
# #DJDSTART
# top level version of findsig. Reports errors
procedure tl_findsig(p_orig,dont_coerce)
    local q
    if /p_orig then
	rpt_err("tl_findsig: p_orig nil")
    else
	p := fix_p(p_orig)
    if /p then
	rpt_err("tl_findsig: p nil")

    # Redo any node which may still require coercion
    case (p . kind) of {
	GUARDEDLIST:
	    {
		chgsig(p, nil)
		p . sig_done := SIG_UNKNOWN
	    }
	LOOPDENOTATION:
	    {
		chgsig(p, nil)
		p . sig_done := SIG_UNKNOWN
		# and clear sig_done
	    }
	FUNCCONSTR:
		{
		    p . sig_done := SIG_UNKNOWN
		}
    }
    q := findsig(p,dont_coerce)
    if (q ~= SUCCESS) then
	{
	    if (q . kind = LETTERID | q . kind = OPRID)
	    then
		{
		    rpt_err_node("circular signature dependency involving " ||  getname(q . id_str_table_index), q)
		}
	    else
		    {
			rpt_err_node("Circular signature dependency",q)
		    }
	    if (p . kind = FUNCCONSTR)
	    then
		{
		    p . signature . fsig_result_sig := ERR_SIG
		}
	    else
		    {
			p . signature := ERR_SIG
		    }
	    p . sig_done := SIG_DONE
	}

    # clear dontsubst list
    while ( \ dontsubst) do
	{
	    dontsubst := cn_del_hd(dontsubst)
	}

end
