###############################################################################
#
#	File:     allocate.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"
class blocks (bl_next, bl_block)
end

#DJDSTOP
# 
# #define DEBUG
# #
# Static Storage Allocator.
# 
# This routine walks the tree, associating with declarations and
# parameters a level and displacement.  It also calculates the size of
#     the activation record needed for a procedure.
# Allocate expects a node of kind FUNCCONSTR.
# Note that static nesting levels are reset here, to reflect the
# fact that some blocks actually require activation records.
# 
# 
# # ifdef VERBOSE
# #   define IFVERBOSE(x) x
# # else
# #   define IFVERBOSE(x)
# # endif
# 
# # include "parm.h"
# # include <stdio.h>
# # include "stree/ststructs.mh"
# # include "codeutil.h"
# # include "../pass4/sigs.h"
# 
# # define MAXOBJSZ 512 # Should agree with runtime
# 
# extern FILE * unparse_file
# 
# NODE * Vcurrent_func       # Immediately surrounding function construction
# NODE * Vcurrent_ar         # Immediately surrounding construct (block
# # or function) requiring an act. record.
# 
# int Vstatic_level = -1
# int Vnext_free             # Next location in activation record to be
# # allocated.
# int Vhigh_water            # max(Vnext_free, Vhigh_water) = highest
# # numbered location allocated so far.  At
# # the end of a fn this is the required a.r.
# # size.
# 
# boolean Vextent_limited     # Variables can't outlive current function
# # activation & current block is executed
# # only once in current fn activation.
# boolean Vallocate_on_stack  # It is safe to allocate variables directly
# # in the activation record in the current
# # context.
# # This implies Vextent_limited and callcc
# # can't be called.
# # On the VAX it also means that a.r. must
# # always be stack allocated, since pointers
# # to the middle of objects may o.w. result
# # Even if this is false, individual vars
# # may be allocated directly in a.r. if no
# # references to that particular
# # variable can be created.
# boolean Vcallcc             # Current function may save a continuation
# 
# extern boolean Nflag # No Callcc calls
# extern boolean Vflag
# extern boolean Gflag
# extern boolean Rflag # Use registers as much as possible.
# extern boolean hflag # Dont stack allocate variables.
# 
# extern long max_addr_regs # Try to allocate this many non-parameter
# # represented by pointers to registers
# extern long max_int_regs  # Number of non-pointers to allocate to regs
# long n_addr_regs = 0      # Number of virtual registers allocated to
#     long n_int_regs = 0       # variables so far.
# # Note that the distinction between int and
# # addr is very approximate.  All initialized
# # variables, as well as all non-variables
# # count as ints.
# 
# extern int yynerrs
# 
# int n_decls        # Number of declarations in current block
# 
# # List of blocks in current function
# struct blocks {
# struct blocks * bl_next
# NODE * bl_block
# } * Vcurrent_blocks = NIL
# 
# # Free nodes on current block list
# void Vfree_blocks()
# {
# struct blocks *p
# 
# while (Vcurrent_blocks != NIL) {
# p = Vcurrent_blocks
# Vcurrent_blocks = Vcurrent_blocks . bl_next
# free(p)
# }
# }
# #DJDSTART
# Make sure variables declared in blocks parallel to block
# are not allocated directly in a.r., since their locations
# are no longer guaranteed to be retained until function exit.
procedure realloc_blocks(block)
    local p

    # Process preceding parallel blocks.
    p := Vcurrent_blocks
    while \p do {
	# Blocks are added in preorder.
	# Thus p . bl_block . pre_num < block . pre_num
	if (p . bl_block . post_num < block . post_num) then { # not ancestor
	    case (p . bl_block . kind) of {
		BLOCKDENOTATION:
		    {
			temp :=  p . bl_block . bld_declaration_list.lh_first
			while \temp do {
			    s := temp.cn_hd_field

			    if (iand (s . decl_special , VAR_NONTR_REF) ~= 0) then {
				if (Vflag != FALSE  & iand(s . decl_special , VAR_ON_STACK) ~= 0) then {
				    rpt_info("Parallel blocks: Undoing stack allocation of " || Vcurrent_func . fc_code_label || getname(s . decl_id . id_str_table_index))
				}
				s.decl_special := iand(s.decl_special,icomp(VAR_ON_STACK))
			    }

			    temp := temp.cn_tl_field
			}
		    }
		default:
		    rpt_info("realloc_blocks: bad list entry")
	    }
	}
	p = p . bl_next
    }
end
# Add a block to block list
procedure add_block(block)
    local p
    if (block . kind = MODPRIMARY)  then {
	rpt_info("add_block: MODPRIMARY in block list")
	return TRUE
    }
    if (block . kind = BLOCKDENOTATION &
	(/ (block . bld_declaration_list) |
	 is_empty(block . bld_declaration_list) ~= FALSE)) then {
	     # No local declarations - ignore
	     return TRUE
	 }
    # Add block to list
    p := blocks(nil,nl)
    p . bl_block := block
    p . bl_next := Vcurrent_blocks
    Vcurrent_blocks := p
end


procedure Vallocwalk(p)
    local v, tp, den, no_ref, allocate_in_ar
    local old_int_regs,	old_addr_regs, old_n_decls, escaping_env_ptrs
    local needs_ar, old_ccc, old_aos, old_el, old_Vcurrent_blocks
    local old_ar, old_Vnext_free, old_Vhigh_water

    if (/p ) then return TRUE
    # Take care of nonexpression nodes first:
	case (p . kind) of {
	    DECLARATION:
		{
		    # level field has been set by import to be function
		    # nesting level.  It has been used by "accessible".
		    # It is reset here to a.r. nesting depth.
		    den := p . decl_denotation
		    if (p . decl_signature . kind = VARSIGNATURE &
			iand(p . decl_special , VAR_NONTR_REF) = FALSE  )
		    then no_ref := TRUE
		    else no_ref := FALSE
		    if (Vallocate_on_stack != FALSE |
			(no_ref ~= FALSE & Vcallcc = FALSE)) &
			den . kind = APPLICATION &
			((tp := special_tp(den.ap_operator.signature.fsig_special)) = STD_NEW  | tp = PROD_NEW | tp = UNION_NEW | tp == PTR_NEW  | tp == INIT_NEW  )
		    then   allocate_in_ar :=  TRUE
		    else   allocate_in_ar  := FALSE
		    if (tp = STD_NEW | tp = INIT_NEW)
		    then if (n_int_regs < max_int_regs)
		    then tmp := TRUE
		    else tmp:= FALSE
		    else if (n_addr_regs < max_addr_regs)
		    then tmp := TRUE
		    else tmp:= FALSE
		    if (alloc_in_ar ~= FALSE &
			(Rflag ~= FALSE |
			 tmp ~= FALSE  ) &
			iand(p . decl_special , ior(ID_IMPORTED,VAR_NONTR_REF)) ~= FALSE & (special_val(den.ap_operator.signature.fsig_special = 1 |
													tp = PROD_NEW | tp = UNION_NEW)))
		    then allocate_in_reg := TRUE
		    else allocate_in_reg := FALSE
		    if (hflag ~= FALSE | allocate_in_reg ~= FALSE) then {
			allocate_in_ar := FALSE
		    }

		    p . level := Vstatic_level
		    if (allocate_in_reg ~= FALSE) then {
			# Note: Both Gflag and !Vcallcc hold at this
			# point. Store variable value in register.
			if (Vflag ~= FALSE) then {
			    rpt_info("Allocating value of %s:%s to v. register" || Vcurrent_func . fc_code_label || getname(p . decl_id . id_str_table_index))
			}
			avail_loc +:= 1
			p . displacement := avail_loc
			if (tp = STD_NEW) then {
			    p.decl_special := ior(p.decl_special,SIMPLE_VAR_IN_REG)
			    n_int_regs +:= 1
			} else if (tp = INIT_NEW) then {
			    p.decl_special := ior(p.decl_special, INIT_VAR_IN_REG)
			    n_int_regs +:= 1
			} else {
			    p.decl_special := ior(p.decl_special, PTR_VAR_IN_REG)
			    n_addr_regs +:= 1
			}
		    } else if (allocate_in_ar != FALSE) then {
			# Allocate variable directly in activation record
			    if (Vflag!= FALSE) then {
				rpt_info("Allocating %s:%s directly in act. record" || Vcurrent_func . fc_code_label || getname(p . decl_id . id_str_table_index))
			    }
			    p . displacement := Vnext_free
			    Vnext_free +:= special_val(den . ap_operator . signature . fsig_special)
			    if (tp = STD_NEW) then {
				p . decl_special := ior(p . decl_special, SIMPLE_VAR_ON_STACK)
			    } else if (tp = INIT_NEW) then {
				p . decl_special := ior(p . decl_special, INIT_VAR_ON_STACK)
			    } else {
				p . decl_special := ior(p . decl_special, PTR_VAR_ON_STACK)
			    }
			}
		    else
			    {
				if (Vextent_limited ~= FALSE &
				    den . kind = APPLICATION &
				    ((tp := special_tp(den . ap_operator . signature . fsig_special)) = ARRAY_STD_NEW |  tp = ARRAY_PTR_NEW)) then {
					# Allocate array contiguously
					if (Vflag ~= FALE & Gflag ~= FALSE) then {
					    rpt_info("Allocating %s:%s contiguously" ||
						     Vcurrent_func . fc_code_label ||
						     getname(p . decl_id . id_str_table_index))
					}
					p . decl_special |= ior(p . decl_special, ARRAY_CONTIG)
				    }
				if (p . decl_needed ~= FALSE) then {
				    # If ((Rflag || messy, ad hoc heuristic) && ...
				    if ((Rflag != FALSE | (n_int_regs < max_int_regs) &
					 n_decls < max_int_regs + max_addr_regs &
					 is_int_const(p . decl_denotation) = FALSE) &
					iand(p . decl_special , ID_IMPORTED) = FALSE ) then {
					    if (Vflag ~= FALSE) then {
						rpt_info("Binding of %s:%s stored in v. register" || Vcurrent_func . fc_code_label || getname(p . decl_id . id_str_table_index))
					    }
					    p . decl_special := ior(p . decl_special, ID_IN_REG)
					    avail_loc +:= 1
					    p . displacement = avail_loc
					    n_int_regs +:= 1
					}
				    else
					    {
						Vnext_free +:= 1
						p . displacement = Vnext_free
					    }
				}
			    }

		    if (p . decl_denotation . kind = FUNCCONSTR &
			(p . decl_needed = FALSE)) then {
			    Vallocate(p . decl_denotation, TRUE)
			}
		    else
			    {
				Vallocwalk(p . decl_denotation)
			    }
		    return TRUE
		}
	    PARAMETER:
		{
		    if (Vflag ~= FALSE & / ( p . par_id ) &
			is_real_def(p . par_only_def) ~= FALSE) then {
			    rpt_info( "Parameter %s:%s is known to be bound to: " ||
				     Vcurrent_func . fc_code_label ||
				     getname(p . par_id . id_str_table_index))
			}
		    Vnext_free +:= 1
		    p . displacement := Vnext_free
		    p . level := Vstatic_level
		    return TRUE
		}
	    GUARDEDELEMENT:
		{
		    Vallocwalk(p.ge_guard)
		    Vallocwalk(p.ge_element)
		    return TRUE
		}
	    EXTERNDEF:
		return TRUE
	}

    if (p . signature . kind = SIGNATURESIG) then {
	# signatures don't require storage for evaluation
	return TRUE
    }

    case ( p . kind ) of {
	BLOCKDENOTATION:
	    {
		old_int_regs := n_int_regs
		old_addr_regs := n_addr_regs
		old_n_decls := n_decls
		if iand(p.bld_flags,ior(CONTAINS_CLOSURE,CALLCC_CALL)) ~= 0
		then
		    escaping_env_ptrs := TRUE
		else
		    escaping_env_ptrs := FALSE
		if iand(p . bld_flags , REQUIRES_AR) ~= 0
		then
		    needs_ar := TRUE
		else
		    needs_ar := FALSE
		old_ccc := Vcallcc
		old_Vnext_free := Vnext_free
		old_Vhigh_water := Vhigh_water
		if \ (p . bld_declaration_list) then {
		    n_decls := length(p . bld_declaration_list)
		} else {
		    n_decls := 0
		}
		if iand(p . bld_flags , CALLCC_CALL) ~= 0
		then
		    Vcallcc := TRUE
		else
		    Vcallcc := FALSE

		if (needs_ar ~= 0) then {
		    old_aos := Vallocate_on_stack
		    old_el := Vextent_limited
		    old_Vcurrent_blocks := Vcurrent_blocks
		    old_ar := Vcurrent_ar
		    Vcurrent_ar := p
		    Vcurrent_func . fc_complexity := ior(Vcurrent_func . fc_complexity, NESTED_AR_BLOCK)
		    if (p . signature . kind = TYPESIGNATURE)
		    then
			Vextent_limited := TRUE
		    else
			Vextent_limited := FALSE
		    # In this case, the import rule guarantees the
		    # desired property.
		    if Vextent_limited ~= FALSE & Vcallcc ~= FALSE
		    then
			Vallocate_on_stack := TRUE
		    else
			Vallocate_on_stack := FALSE

		    Vcurrent_blocks := nil
		    Vhigh_water := Vnext_free := AR_FIRST_PARM
		    Vstatic_level +:= 1
		}
		else
		    {
			# If there is no potential for a pointer to the
			# environment surviving block exit, we recycle
			# locations at the end of the block.  This
			# requires that potentially surviving variables
			# (references) may not be allocated directly
			# in the activation record if there is a
			# subsequent parallel block.  Here we undo such
			# allocations for preceding blocks.
			realloc_blocks(p)
			if (escaping_env_ptrs = FALSE) then
			    add_block(p)
			# Remember this block for possible future fix-up
		    }
		temp := p.bld_declaration_list.lh_first
		while \temp do {
		    v := temp.cn_hd_field
		    Vallocwalk(v)
		    temp := temp.cn_tl_field
		}

		temp := p.bld_den_seq.lh_first
		while \temp do {
		    v := temp.cn_hd_field
		    Vallocwalk(v)
		    temp := temp.cn_tl_field
		}
		if (needs_ar ~= FALSE) then {
		    Vallocate_on_stack := old_aos
		    Vextent_limited := old_el
		    Vcurrent_blocks := old_Vcurrent_blocks
		    Vcallcc := old_ccc
		    if (Vnext_free >= Vhigh_water) then {
			p . ar_size := Vnext_free
		    } else {
			p . ar_size := Vhigh_water
		    }
		    if (p . ar_size > MAXOBJSZ) then {
			rep_info_node("Too many local variables",p)
		    }
		    p . ar_static_level := Vstatic_level
		    p . ar_static_link := old_ar
		    Vnext_free := old_Vnext_free
		    Vhigh_water := old_Vhigh_water
		    Vcurrent_ar := old_ar
		    Vstatic_level -:= 1
		} else if (escaping_env_ptrs = FALSE) then {
		    if (Vnext_free > Vhigh_water) then {
			Vhigh_water := Vnext_free
		    }
		    Vnext_free := old_Vnext_free
		}
		n_int_regs := old_int_regs
		n_addr_regs := old_addr_regs
		n_decls := old_n_decls
	    }
	APPLICATION:
	    {
		Vallocwalk(p.ap_operator)
		temp := p.ap_args.lh_hd_first
		while \temo do {
		    v := temp.cn_hd_field
		    Vallocwalk(v)
		    temp := temp.cn_tl_field
		}
	    }
	LOOPDENOTATION:
	    {
		old_aos := Vallocate_on_stack
		old_el := Vextent_limited

		Vallocate_on_stack := FALSE
		Vextent_limited := FALSE
		temp := p.gl_list.lh_first
		while \temp do {
		    v := temp.cn_hd_field
		    Vallocwalk(v)
		    temp := temp.cn_tl_field
		}
		Vallocate_on_stack := old_aos
		Vextent_limited := old_el
	    }

	QSTR:
	    {
		# Selection type is handled as though it were
		# in a loop, since it may be evaluated more
		# than once.
		old_aos := Vallocate_on_stack
		old_el := Vextent_limited

		Vallocate_on_stack := FALSE
		Vextent_limited := FALSE
		Vallocwalk(p . sel_type)
		Vallocate_on_stack := old_aos
		Vextent_limited := old_el
	    }
	UQSTR:
	    {
		# Selection type is handled as though it were
		# in a loop, since it may be evaluated more
		# than once.
		old_aos := Vallocate_on_stack
		old_el := Vextent_limited

		Vallocate_on_stack := FALSE
		Vextent_limited := FALSE
		Vallocwalk(p . sel_type)
		Vallocate_on_stack := old_aos
		Vextent_limited := old_el
	    }
	GUARDEDLIST:
	    {
		temp := p.gl_list.lh_first
		while \temp do {
		    v := temp.cn_hd_field
		    Vallocwalk(v)
		    temp := temp.cn_tl_field
		}
	    }

	OPRID:
	    if \ (p . sel_type)  then {
		Vallocwalk(p.sel_type)
	    }
	LETTERID:
	    if \ (p . sel_type)  then {
		Vallocwalk(p.sel_type)
	    }
	FUNCCONSTR:
	    {
		Vallocate (p, FALSE)
	    }

	REXTERNDEF:
	    {
	    }
	USELIST:
	    {
		temp := p . usl_den_seq.lh_first
		while \temp do {
		    q := temp.cn_hd_field
		    Vallocwalk(q)
		    temp := temp.cn_tl_field
		}
	    }
	MODPRIMARY:
	    {
		if  \ ( (p . mp_type_modifier) &
		       p . mp_type_modifier . kind = WITHLIST) then {
			   # Treat it as a block since it can overlay
			   # previously allocated locations
			   realloc_blocks(p)
		       }
		Vallocwalk(p . mp_primary)
		if (\ (p . mp_type_modifier) &
		    p . mp_type_modifier . kind = WITHLIST) then  {
			# reserve space for local type identifier
			Vnext_free +:= 1
			p . displacement := Vnext_free
			p . level := Vstatic_level
			temp := p . mp_type_modifier . wl_component_list.lh_first
			while \temp do {
			    q := temp.cn_hd_field
			    Vallocwalk(q . decl_denotation)
			    temp := temp.cn_tl_field
			}
		    }
	    }
	ENUMERATION:
	    # Subexpressions are not evaluated, thus
	# no storage needs to be allocated.
	{
	}
	PRODCONSTRUCTION:
	    # Subexpressions are not evaluated, thus
	# no storage needs to be allocated.
	{
	}
	UNIONCONSTRUCTION:
	    # Subexpressions are not evaluated, thus
	# no storage needs to be allocated.
	{
	}

	EXTENSION:
	    Vallocwalk(p . ext_denotation)
	RECORDCONSTRUCTION:
	    {
		temp := p . rec_component_list.lh_first
		while \temp do {
		    s := temp.cn_hd_field
		    Vallocwalk(s . re_denotation)
		    temp := temp.cn_tl_field
		}
	    }
	WORDELSE:
	    {
	    }
	WORDCAND:
	    rpt_info("Vallocate: cand or cor\n")
	WORDCOR:
	    rpt_info("Vallocate: cand or cor\n")
	RECORDELEMENT:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	FUNCSIGNATURE:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	LISTHEADER: # should never get here
	rpt_info("Vallocwalk: bad kind" || p.kind )
	VARSIGNATURE:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	VALSIGNATURE:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	TYPESIGNATURE:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	TSCOMPONENT:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	DEFCHARSIGS:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	WITHLIST:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	EXPORTLIST:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	EXPORTELEMENT:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	ALLCONSTANTS:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	HIDELIST:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	PARAMETER:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	DECLARATION:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	GUARDEDELEMENT:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
	default:
	    rpt_info("Vallocwalk: bad kind" || p.kind )
    }
    return TRUE
end
#DJDSTOP
# # Compute the number of known vacuous parameters appearing at the
# # end of a a parameter list.
# static boolean found_non_vacuous # Saw a real argument
# static n_vacuous                 # Number of vacuous arguments found so far
# #DJDSTART
procedure check_vacuous(p)
    if (found_non_vacuous = FALSE) then {
	if (vacuous_arg(p . par_signature) ~= FALSE) then {
	    n_vacuous +:= 1
	} else {
	    found_non_vacuous := TRUE
	}
    }
end

procedure n_vacuous_params(p)
    if (Gflag = FALSE) then return(0)
    # Vax implementation passes everything explicitly
    found_non_vacuous := FALSE
    n_vacuous := 0
    maprlist(p, check_vacuous)
    return(n_vacuous)
end

procedure Vallocate (p, unused_decl)
    local v, old_aos, old_el, old_ccc, old_addr_regs, old_int_regs
    local old_Vcurrent_blocks, old_func, old_ar, old_Vnext_free
    local old_Vhigh_water, op_sig, result_sig, sig
    local params, n_params, i



    old_aos := Vallocate_on_stack
    old_el := Vextent_limited
    old_ccc := Vcallcc
    old_addr_regs := n_addr_regs
    old_int_regs := n_int_regs
    old_Vcurrent_blocks := Vcurrent_blocks
    old_func := Vcurrent_func
    old_ar := Vcurrent_ar
    old_Vnext_free := Vnext_free
    old_Vhigh_water := Vhigh_water
    op_sig := p . signature


    if not(has_field(op_sig,"fsig_result_sig")) then # ADDED DJD
	op_sig := op_sig.cn_hd_field
    if \ op_sig then
	result_sig := op_sig . fsig_result_sig

#    ASSERT (p.kind == FUNCCONSTR,"Vallocate.c: arg not FUNCCONSTR\n")
    if (p.kind ~= FUNCCONSTR) then {rpt_info_node ("p is ",p)}
    Vstatic_level +:= 1
    Vcurrent_func := Vcurrent_ar := p
    Vcurrent_blocks := nil
    Vhigh_water := Vnext_free := AR_FIRST_PARM
    n_int_regs := n_addr_regs := 0
    # Determine whether stack allocation of variables is safe
    {
	if \ op_sig then
	if (impure(op_sig) ~= FALSE) then {
	    # Who knows what it does?
		Vextent_limited := FALSE
	    } else if (result_sig . kind = VARSIGNATURE) then {
		# Can obviously return a variable
		Vextent_limited := FALSE
	    } else if (result_sig . kind = VALSIGNATURE &
		       (result_sig.val_denotation.signature.ts_simple_type = FALSE))
	then
		{
		    Vextent_limited := FALSE
		}
	    else if (result_sig . kind = FUNCSIGNATURE &
		     impure(result_sig)) then {
			 Vextent_limited := FALSE
		     } else {
			 # Can only return a variable through arguments
			 Vextent_limited := TRUE
			 if (p . ar_static_level ~= 0) then {

			     temp := op_sig . fsig_param_list.lh_first
			     while \temp do {
				 q := temp.cn_hd_field
				 sig := q . par_signature
				 if (sig.kind = VARSIGNATURE) then {
#						  ASSERT (has_sig(sig . var_denotation),
#							  "Missing parameter type signature")
				     if (sig . var_denotation . signature.ts_simple_type = FALSE) then {
					 Vextent_limited := FALSE
#							  IFVERBOSE(
#								    printf("Vallocate: bad parameter\n")
					 #					    )
				     }
				 }

				 temp := temp.cn_tl_field
			     }
			 }
		     }
    }
    Vcallcc := FALSE
    Vallocate_on_stack := Vextent_limited
    if (Gflag = FALSE) &
	(result_sig . kind = FUNCSIGNATURE | unused_decl = FALSE) then {
	    # VAX runtime system & a.r. may be heap allocated
	    # Could result in bad pointers
	    Vallocate_on_stack = FALSE
	}
    if has_field(p,"fc_complexity") then
    if (Nflag = FALSE & iand(p . fc_complexity , NO_CALLCC) == 0) then {
	# Must be able to copy environment w/o getting
	# part of the state
	Vallocate_on_stack := FALSE
	Vcallcc := TRUE
    }
    if has_field(p.signature, "fsig_param_list") then {
	params := p . signature . fsig_param_list
    n_params := length(params) - n_vacuous_params(params)
    }
    else
	n_params := 0
    i := 0

    if has_field(p.signature,"fsig_param_list") then {
	temp := p.signature.fsig_param_list.lh_first
	while \temp do {
	    v := temp.cn_hd_field
	    if (i < n_params | Vstatic_level = 0) then {
		# May be passed explicitly, reserve space
		Vallocwalk(v)
	    } else {
		# Map it onto the last real parameter
		v . displacement := Vnext_free - 1
		v . level := Vstatic_level
	    }
	    i +:= 1
	    temp := temp.cn_tl_field
	}
    }
    if has_field(p,"fc_body") then
	Vallocwalk (p.fc_body)
    p . ar_static_level := Vstatic_level
    if (Vnext_free >= Vhigh_water) then {
	p . ar_size := Vnext_free
    } else {
	p . ar_size := Vhigh_water
    }
    if (p . ar_size > MAXOBJSZ) then {
	rpt_err_node("Too many local variables",p)
    }
    p . ar_static_link := old_ar
    Vcurrent_func := old_func
    Vcurrent_ar := old_ar
    Vstatic_level -:= 1
    Vnext_free := old_Vnext_free
    Vhigh_water := old_Vhigh_water
    Vallocate_on_stack := old_aos
    Vextent_limited := old_el
    Vcallcc := old_ccc
#    Vfree_blocks()
    Vcurrent_blocks := old_Vcurrent_blocks
    n_int_regs := old_int_regs
    n_addr_regs := old_addr_regs
end
