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

# 
*  This is an attempt at a portable Russell code generator.
*  It is based on the VAX specific version (pass5c).
*
    *      Hans Boehm (started 2 July 1985)
*
    
# include "parm.h"
# include <stdio.h>
# include "stree/ststructs.mh"
# include "codegen.h"
# include "op_codes.h"
# include "pass4/sigs.h"
# include "pass3/is_local.h"

extern int yydebug
extern int yynerrs

extern boolean Pflag  # Generate profiling code 
extern boolean Tflag  # Generate trace code 
extern boolean Vflag  # Optimization info 
extern boolean Oflag  # Optimize for execution speed 
extern boolean Xflag  # Generate externally callable code 
extern boolean xflag  # Generate code for Xerox Portable Common Runtime 
extern boolean Fflag  # Load arguments into temporaries 

extern char * entry_name # "" for main compilation 

boolean sl_available = TRUE  # Static link available in      
# current function construction 

boolean compile_fcs = TRUE   # Also compile nested function constructions 
# as they are encountered.		    

boolean copied_globals     # Current function uses closure with copied 
# non-local identifier bindings             

int n_globals              # Number of non-local identifiers referenced 
# in current function.  Valid only if        
    # copied_globals applies.                    

int avail_loc = FIRST_AVAIL_LOC     # next available location number 

int first_param_loc        # First parameter location for current fn.  
# Applies only if parameters were copied.   
# This is done only if the DIR_REC bit is   
# set for the current function construction 
# Otherwise first_param_loc is 0.           

void type_expr()  # generate code for type in record element 

boolean Gpush_size()  # Push the size of an array onto the stack 

char str_code_buf[MAXSTRCODELEN] # used for strings, "special" fns 
# and by find_inline              
# and for object file names       
# and to assemble labels          
char str_code_buf2[MAXSTRCODELEN] # used for strings 

extern FILE * objfilelist  # List of object files which must be loaded 

extern FILE * unparse_file
NODE * fc_pointer
int fc_level
int fc_fast_only  # Only simplified version needed 
# Not really needed anymore ...  
struct Fc_Entry * fc_next

#DJDSTART
class Fc_Entry(fc_pointer,fc_level,fc_fast_only,fc_next)
end





procedure add_objfile(fn)
    local s
    if (/objfilelist) then {
	if not(objfilelist := open("OBJFILELIST","w")) then stop("cannot open OBJFILELIST")
    }
    write(objfilelist,fn)
return TRUE
end
# Definitions for list of function constructions for whose body
# * we still need to generate code
#
# Add an entry to the front of Gfc_list, provided compile_fcs is TRUE 
procedure Gfc_add(ptr,lvl,fast_only)
# NODE * ptr    # pointer to function construction 
# int lvl       # level of function construction   
# int fast_only # generate only BSF version        
    local  p

    if (compile_fcs = FALSE) then { return TRUE }
    p := Fc_Entry(ptr,lvl,fast_only,Gfc_list)
    Gfc_list := p
return TRUE
end
# remove an entry from the head of Gfc_list 
procedure Gfc_delete()
    local p
    p := Gfc_list
    Gfc_list := Gfc_list . fc_next
#    free(p)
return TRUE
end

# check and static link analysis 

# Compile all function constructions on Gfc_list 
procedure Gcompile_funcs()
    local fc_ptr,fc_lvl,fc_fast_only,first_avail_loc,old_sl_avail

    first_avail_loc := avail_loc
    while (\Gfc_list) do {
	fc_ptr := Gfc_list . fc_pointer
	fc_lvl := Gfc_list . fc_level
        fc_fast_only := Gfc_list . fc_fast_only
        Gfc_delete()
	if(fc_fast_only = FALSE) then {
	    # Reset location counter so numbers don't grow too 
	    # rapidly.                                         
	    avail_loc := first_avail_loc
	    Gfunc_body(fc_ptr, fc_lvl)
	}
	if has_field(fc_ptr,"fc_complexity") then
	if((fc_ptr . fc_complexity & NO_SL) & fc_lvl ~= 0) then {
	    old_sl_avail := sl_available
	    sl_available := FALSE
            if (fc_fast_only = FALSE) then { compile_fcs := FALSE }
	    avail_loc := first_avail_loc
	    Gfunc_body(fc_ptr,fc_lvl)
	    sl_available := old_sl_avail
	    compile_fcs := TRUE
	}
    }
return TRUE
end


# generate code for syntax tree p into file f 
procedure Ggeneratecode ( f , p )
    Goutfile := f
    p . fc_code_label := "_russell_top_level"
    analyze(p)     # Compute fc_complexity fields 
    accessible(p)  # find accessible code                 
    bld_analyze(p)  # Find blocks requiring activation records 
    Gallocate (p,TRUE)   # allocate space in activation records 
    sl_analyze(p)  # Decide which functions reference free ids  
    finished_accessible := TRUE
    if (Oflag) then {
	# Redo fc_complexity analysis to take advantage of new info 
	if (Vflag = TRUE) then {
	    write("Repeating basic analysis:")
	}
	analyze(p)
    }
    cl_analyze(p, TRUE)  # Decide on closure rep.               
    if (yydebug) then prtree(p)
    Gfc_add(p,0,FALSE) # add main function to list of functions that need 
    # compiling.                                       
    Gcompile_funcs()
return TRUE
end

# generate code for syntax tree p embedded in syntax tree q into file f 
# invoked with -c compiler flag                                         
procedure Ggeneratepcode ( f, q , p )
    Goutfile := f
    q . fc_code_label := "_russell_top_level" # CHG DJD
    
    analyze(q)     # Compute fc_complexity fields 
    write(treefile,"begin Ggeneratepcode q.dump after analyze")
    q.dump(treefile)
    write(treefile,"end Ggeneratepcode q.dump")
#    write(treefile,"begin Ggeneratepcode p.dump after analyze")
#    p.dump(treefile)
#    write(treefile,"end Ggeneratepcode p.dump")
    accessible(q)  # find accessible code                 
    bld_analyze(q)  # Find blocks requiring activation records 
    Gallocate (q,FALSE)  # allocate space in activation records 
#    sl_analyze(p)  # Decide which functions reference free ids  
    finished_accessible := TRUE
    if (Oflag) then {
	# Redo fc_complexity analysis to take advantage of new info 
	if (Vflag = TRUE) then {
	    write("Repeating basic analysis:")
	}
	analyze(q)
    }
#    cl_analyze(p, TRUE)  # Decide on closure rep.
    if not(has_field(p,"ar_static_level")) then # ADDED DJD
	p := p.cn_hd_field
    if not(has_field(p,"ar_static_level")) then # ADDED DJD
	p := p.cn_hd_field
               
#    if (p . ar_static_level ~= 1) then {
#        rpt_err("user program must be at level 1")
#    }
    # Compile main function 
    str_code_buf := "m_" ||  entry_name
    genl(EXT,str_code_buf)
    genl(BFN,str_code_buf)
    Glevel := 0
    Gfuncconstructor(p, RL)
    gen0(RTN)

    Gcompile_funcs()
return TRUE
end

# Generate code for syntax tree p embedded in syntax tree q into file f 
# The expression p should have type signature.  Generate an externally  
# callable interface for p.                                             
# Invoked with -X compiler flag                                         
procedure GgenerateXcode ( f, q, p )
    local sig, name_buf, ar_name_buf
    sig = sig_structure(p . signature)
    Goutfile := f
    q . fc_code_label = "_russell_top_level"
    if (sig . kind ~= TYPESIGNATURE) then {
	rpt_err("-X requires expression with type signature")
        return TRUE
    }
    analyze(q)     # Compute fc_complexity fields 
    accessible(q)  # find accessible code                 
    bld_analyze(q)  # Find blocks requiring activation records 
    Gallocate (q,FALSE)  # allocate space in activation records 
    sl_analyze(q)  # Decide which functions reference free ids  
    finished_accessible := TRUE
    if (Oflag = TRUE) then {
	# Redo fc_complexity analysis to take advantage of new info 
	if (Vflag = TRUE) then {
	    write("Repeating basic analysis:")
	}
	analyze(q)
    }
    cl_analyze(q, TRUE)  # Decide on closure rep.               
    # Compile the type expression in the context of a C callable function 
    Gcurrent := q
    Glevel := 0
    copied_globals := FALSE
    sl_available := TRUE

    # Generate prolog 
    if (xflag = TRUE) then { 
	name_buf := "_XR_run"
    } else {
	name_buf := "_" || entry_name || "_"
    }
    genl(EXT, name_buf)
    genl(BSF, name_buf)

    # Generate a call to russell_set_up to set up main act. record 
	gen2(LDN, q . ar_size, T1)    # activation record size 
    if (xflag = TRUE) then {
	gen2(ARG, 1, T1)
    } else {
	gen2(ARG, 3, T1)
	gen2(GAR, 2, T1)     # argv 
	gen2(ARG, 2, T1)
	gen2(GAR, 1, T1)     # argc 
	gen2(ARG, 1, T1)
    }
    genl(EXT, "_russell_set_up")
    genl(LBA, "_russell_set_up")
    if (xflag = TRUE) then {
	gen1(CLC, 1)
    } else {
	gen1(CLC, 3)
    }
    gen1(HINT, GFU)
    gen2(MOV, RL, GF)
    gen2(MOV, GF, AR)

    # Save the result in a named global location 
    ar_name_buf := "_" || entry_name || "_ar_save_loc"
    genl(LBA, ar_name_buf)
    gen1(IDT, 0)
    gen2(DCL, T2, DCL_ADDR)
    genl(LBA, ar_name_buf)
    gen1(LDL, T2)
    gen3(STI, T2, 0, GF)
    gen1(UDC, T2)

    # Also save the result in global_ar, so that the various 
    # call_russell routines will work correctly.             
    # For C code generation, this is needed by every routine 
    # in a nested file that references GF.			  
    gen2(HINT, ET, DCL_INT)
    genl(EXT, "_global_ar")
#	  ifdef GEN_C
    # The C code has to declare global_ar in each file anyway. 
    # Furthermore, there is an initialized declaration in      
    # startup.c.  Skip it here. 				
#	  else
	genl(LBA, "_global_ar")
    gen1(IDT, 0)
#	  endif
    if (xflag) then {
	# Global_ar is set up by the startup code.  Furthermore, it 
	# shouldn't matter which global_ar I get, since nobody      
	# relies on anything in the global frame except initenv.    
	# Separately compiled functions don't see anything else, 	 
	# and functions in this file will lokk in the right place.  
	# If I load things separately, pcr should actually          
	# guarantee that each Russell program sees the right one,   
	# but we don't rely on that.				 
    } else {
	gen2(DCL, T2, DCL_ADDR)
	genl(LBA, "_global_ar")
	gen1(LDL, T2)
	gen3(STI, T2, 0, GF)
	gen1(UDC, T2)
    }

    Gexpression( p, T1, FALSE )

    # Generate an epilog that stores the type value 
    name_buf := "_" || entry_name || "_save_loc"
    genl(LBA, name_buf)
    gen1(IDT, 0)
    gen2(DCL, T2, DCL_ADDR)
    genl(LBA, name_buf)
    gen1(LDL, T2)
    gen3(STI, T2, 0, T1)
    gen1(UDC, T2)
    gen0(RTN)

    # Generate the necessary C callable procedure stubs  
    # These access both the stored type value and stored 
    # global activation record.                          
    compile_stubs(sig, name_buf, ar_name_buf)

    Gcompile_funcs()
return TRUE
end


# generate code for function constructor p.  Return location holding object 
procedure Gfuncconstructor(p, rloc)
#
#  Generate code to put the function object for the function construction
# p into rloc.  Queue the function body for later code generation.
#
    local     n_args, contains_globals, cl_size, fv_len,tloc, cp
    avail_loc +:= 1
    tloc := avail_loc
    
    gen2(DCL, tloc, DCL_INT)
    if has_field(p,"fc_body") then 
    if (p . fc_body . kind = EXTERNDEF) then {
	n_args := length(p . signature . fsig_param_list)
    
	# allocate function object 
	ALLOC_FO(rloc)
#     ifdef UNDEFINED
	# Generate new name for function stub 
	p . fc_code_label := new_global_label("fstub")
#     endif
	# Fill in ip 
	genl(EXT, p . fc_code_label)
	genl(LBA, p . fc_code_label)
	gen1(LDL, tloc)
	gen3(STI, rloc, FO_IP, tloc)
	# fill in arg count + 1 as size 
	gen2(LDN, n_args + 1, tloc)
	gen3(STI, rloc, FO_SIZE, tloc)
	# use arg count as ep 
	gen2(LDN, n_args, tloc)
	gen3(STI, rloc, FO_EP, tloc)
    } else {
	# Compute size of closure 
	contains_globals = ((p . fc_complexity & CP_GLOBALS) ~= 0)
	if (contains_globals = TRUE) then {
	    fv_len := length(p . fc_free_vars)
	    if (fv_len <= 1) then {
		cl_size := 3
	    } else {
		cl_size := 3 + fv_len
	    }
	} else {
	    cl_size := 3
	}
	# Allocate function object 
	gen2(LDN, cl_size, tloc)
	gen2(ALH, tloc, rloc)
	
	# Fill in ip 
	genl(EXT, p . fc_code_label)
	genl(LBA, p . fc_code_label)
	gen1(LDL, tloc)
	gen3(STI, rloc, FO_IP, tloc)
	# fill in size 
	if (p . fc_complexity & NO_AR_REFS) then {
	    # store positive size, indicating stack a.r. is OK 
	    gen2(LDN, p . ar_size, tloc)
	} else {
	    gen2(LDN, -(p . ar_size), tloc)
	}
	gen3(STI, rloc, FO_SIZE, tloc)
	# Fill in a suitable value as environment pointer 
	if (contains_globals) then {
	    
	    if (fv_len = 1) then {
		# tloc := binding of non-local id 
		Gident(first(p . fc_free_vars), tloc)
		# ep := tloc 
		gen3(STI, rloc, FO_EP, tloc)
	    } else if (fv_len > 1) then {
		# ep := closure itself 
		gen3(STI, rloc, FO_EP, rloc)
		# copy non-locals 
		cp := 3
		temp :=  p . fc_free_vars . lh_first
		while \temp do {
		    s := temp.cn_hd_field
		    Gident(s, tloc)
		    gen3(STI, rloc, cp, tloc)
		    cp +:= 1
		    temp := temp.cn_tl_field
		}
	    }
	} else {
	    # Fill in current AR as ep 
	    gen3(STI, rloc, FO_EP, AR)
	}
    }
    gen1(UDC, tloc)
    # Add the function body to the queue 
    Gfc_add(p, Glevel + 1, FALSE)
return TRUE
end


#
#  Generate code for the body of the function construction p at level l.
# The actual function value is computed by Gfuncconstructor above.
#
procedure Gfunc_body(p, l)
    local     is_extern
    if has_field(p,"ar_size") then # KLUDGE DJD 
    p . ar_size := 0  # ar_size = # args + 1 
    if has_field(p, "fc_body") then 
	if (p . fc_body . kind  = EXTERNDEF) then
	    is_extern := TRUE
	else
	    is_extern := FALSE
	else
	    is_extern := FALSE
# 
#	Enter scope of new function construction
#
    Gcurrent := p
    Glevel := l
    if has_field(Gcurrent,"fc_complexity") then
    if ((Gcurrent . fc_complexity & CP_GLOBALS) ~= 0) then
	copied_globals := TRUE
    else
	copied_globals := FALSE
    else
	copied_globals := FALSE

    if (copied_globals) then {
	if has_field(Gcurrent,"fc_free_vars") then
	    n_globals := length(Gcurrent . fc_free_vars)
	else
	    n_globals := 0
    }
    
    if (sl_available = TRUE) then {
	genl(EXT, p . fc_code_label)
	genl(BFN, p . fc_code_label)
    } else {
	# This is "fast" version of routine 
	str_code_buf := "F" || p . fc_code_label
	genl(EXT, str_code_buf)
	genl(BSF, str_code_buf)
    }

    if (Glevel = 0) then {
	# save global frame pointer 
	gen1(HINT, GFU)
	gen2(MOV,AR,GF)
    }
    
    if (Pflag = TRUE) then {
	# generate profiling code
	if (is_extern = TRUE) then genl(PRO,p . fc_body . ext_name)
	else genl(PRO, p . fc_code_label)
    }
    
    if (Tflag) then {
	# generate calls to stack trace routines
	
	if (is_extern = TRUE) then Gentry_trace(p . fc_body . ext_name,FALSE)
	else if has_field(p.signature,"fsig_param_list") then
	    Gentry_trace(p . signature . fsig_param_list, FALSE)
    }
    if has_field(p,"fc_complexity") then 
    if ((Fflag = TRUE | (p . fc_complexity & DIR_REC)) & sl_available = FALSE) then {
	# Copy arguments into temporaries 
	first_param_loc := avail_loc
	n_args := p . ar_size - 1  # ar_size = # args + 1 
	avail_loc +:= n_args
	i := 0
	while i < n_args do {
	    gen2(DCL, first_param_loc + i, DCL_INT)
	    gen2(GAR, i+1, first_param_loc + i)
	}
    } else if ((Fflag = TRUE) & sl_available = FALSE) then {
	# Copy arguments into temporaries 
	first_param_loc := avail_loc
	n_args := p . ar_size - 1  # ar_size = # args + 1 
	avail_loc +:= n_args
	i := 0
	while i < n_args do {
	    gen2(DCL, first_param_loc + i, DCL_INT)
	    gen2(GAR, i+1, first_param_loc + i)
	}

    } else {
	first_param_loc := 0
    }
    if has_field(p,"fc_complexity") then
	if (p . fc_complexity & DIR_REC) then {
	    if (sl_available) then {
		str_code_buf := "R" || p . fc_code_label
	    } else {
		str_code_buf := "RF" || p . fc_code_label
	    }
	    genl(LBL, str_code_buf)
	}
    
    if (is_extern = TRUE) then {
	# Generate stub 
	params := p . signature . fsig_param_list
	n_args := length(params) - n_vacuous_params(params)
	ASSERT(sl_available, "Can't compile stub without activation record\n")
	# Push arguments 
	{
	    avail_loc +:= 1
	    j = avail_loc
	    
	    gen2(DCL, j, DCL_INT)
	    i := n_args
	    while i >= 0 do {
		gen3(LDI, AR, i, j)
		gen2(ARG, i, j)
		i -:= 1
	    }
	    gen1(UDC, j)
	}
	# Call procedure 
	genl(EXT, p . fc_body . ext_name)
	genl(LBA, p . fc_body . ext_name)
	gen1(CLC, n_args)
	
    } else {
	# recursively descend 
	if has_field(p,"fc_body") then
	    Gexpression( p . fc_body, RL, TRUE )
    }

    if ((Fflag | (p . fc_complexity & DIR_REC)) & sl_available = TRUE) then {
	# Undeclare argument temporaries 
	n_args := p . ar_size - 1  # ar_size = # args + 1
	i := 0
	while (i < n_args) do {
	    gen1(UDC, first_param_loc + i)
	    i +:= 1
	}
    }
    # Generate the epilog 
    if (Tflag = TRUE) then {
	# generate call to stack trace routine
	if (is_extern = TRUE) then Gexit_trace (p . fc_body . ext_name)
	else Gexit_trace( p . fc_code_label)
    }
    gen0(RTN)

    if (Glevel = 0) then {
	gen2(HINT, ET, DCL_INT)
	genl(EXT, "_entry_ar_sz")
        genl(LBA, "_entry_ar_sz")
	gen1(IDT, p . ar_size)
    }
return TRUE
end

#
# Generate code for the expression tree headed by p.  The value of the
# expression is left in the location passed as a parameter.
# The location rloc is presumed to have been declared.
# Last_expr is TRUE only if it is known that this is the last subexpression
# to be executed as a part of the current function body.  (This
# is used to improve handling of tail recursion.)
#
procedure Gexpression (p, rloc, last_expr)
    local  i
#    ASSERT( !last_expr || rloc == RL, "Gexpression: bad last_expr value\n")

    if (p . signature . kind = SIGNATURESIG) then {
	# signatures don't evaluate to anything interesting. 
	gen2(MOV, UN, rloc)
	return TRUE
    }

    case ( p . kind ) of {

	OPRID :
	    Gident(p, rloc)
	LETTERID :
	    Gident(p, rloc)
	QSTR:
	    {
		$include "pass5d/codegen_str.inc.icn"
	    }
	UQSTR:
	    {
		$include "pass5d/codegen_str.inc.icn"
	    }
	APPLICATION :
	    Gappl(p, rloc, last_expr)
	BLOCKDENOTATION :
	    {
		if ( iand (p . bld_flags , REQUIRES_AR) ~= 0 ) then {
		    # Allocate activation record on heap.  Stack 
		    # allocation doesn't make any sense, since   
		    # we only allocate a separate a.r. if refs   
		    # to the environment can escape
		    avail_loc +:= 1
		    sz_loc = avail_loc
		    avail_loc +:= 1
		    ar_loc = avail_loc

#			ASSERT(sl_available, "Block a.r. inside simple fn")
		    Glevel +:= 1
		    gen2(DCL, sz_loc, DCL_INT)
		    gen2(DCL, ar_loc, DCL_ADDR)
		    gen2(LDN, p . ar_size, sz_loc)
		    gen2(ALH, sz_loc, ar_loc)
		    gen3(STI, ar_loc, 0, AR)
		    gen2(MOV, ar_loc, AR)
		    gen1(UDC, sz_loc)
		    gen1(UDC, ar_loc)
		}
		# fill in undefined values so that forward refs 
		# can be checked.                               
		# Declare virtual registers used for bindings.
		temp := p . bld_declaration_list.lh_first
		while \temp do {
		    v := temp.cn_hd_field
#			ASSERT (v.kind == DECLARATION,
#                                "codegen.c: decl expected")
		    if (v . decl_needed  = TRUE &
			(v . decl_special & (ID_IN_REG = TRUE | VAR_IN_REG = TRUE))) then {
			    genl(LBR, getname(v . decl_id . id_str_table_index))
			    if (v . decl_special & PTR_VAR_IN_REG) then {
				gen2(DCL, v . displacement, DCL_ADDR)
			    } else {
				gen2(DCL, v . displacement, DCL_INT)
			    }
			}
		    if (v . decl_needed &
			v . decl_can_be_refd <= v . pre_num) then {
			    # possible forward reference to this decl 
			    gen2(HINT, OPT, 1)
			    if (v . decl_special & (ID_IN_REG | VAR_IN_REG)) then {
				gen2(MOV, UN, v . displacement)
			    } else {
				gen3(STI, AR, v . displacement, UN)
			    }
			}
		    temp := temp.cn_tl_field
		}
		temp := p . bld_declaration_list.lh_first
		while \temp do {
		    v := temp.cn_hd_field
		    compile_decl(v)
		    temp := temp.cn_tl_field
		}
		temp := p.bld_den_seq.lh_first
		while \temp do {
		    v := temp.cn_hd_field
		    if (v != last(p . bld_den_seq)) then {
			Gexpression(v, SK, FALSE)
		    } else {
			Gexpression(v, rloc, last_expr)
		    }
		    temp := temp.cn_tl_field
		}
		# Undeclare locations holding id bindings 
		temp := p . bld_declaration_list.lh_first
		while \temp do {
		    v := temp.cn_hd_field
		    if (v . decl_needed &
			(v . decl_special & (ID_IN_REG = TRUE | VAR_IN_REG = TRUE))) then {
			    if (v . decl_special & ARRAY_CONTIG) then {
				# References to the interior of the array 
				# can be live up to this point.  Thus     
				# the pointer to the beggining of the     
				# array should be kept around.            
				gen2(HINT, LIVE, v . displacement)
			    }
			    gen1(UDC, v . displacement)
			}
		    temp := temp.cn_tl_field
		}
		if (iand ( p -> bld_flags , REQUIRES_AR ) ~= 0) then {
		    Glevel -:= 1
		    gen3(LDI, AR, 0, AR)
		}
	    }
	LOOPDENOTATION : {
	    if (length(p . gl_list) = 1) then {
		compile_while_loop(first(p . gl_list), rloc)
	    } # else continue as with GUARDEDLIST: 
	    }
	GUARDEDLIST :
	    {
		saw_else := FALSE
		if (p.kind = LOOPDENOTATION) then {
		    L0 := Gnewlabel("loop")
		    genl(LBL, L0)
		} 
		else {
		    L0 := Gnewlabel("guard_exit")
		}
		temp := p.gl_list.lh_first
		while \temp do {
		    v := temp.cn_hd_field
#                        ASSERT (v.kind == GUARDEDELEMENT,"codegen.c: bad guard list")
		    if (v . ge_guard . kind = WORDELSE) then {
			saw_else := TRUE
		    } else {
			L1 := Gnewlabel ("guard")
			if (Oflag & LAST_ITER &
			    p . kind = GUARDEDLIST) then {
				# No reason to perform the test, since 
				# it better be true.                   
				# Evaluate guard for effect:           
				    Gexpression(v . ge_guard, SK, FALSE)
				} else {
				    Gexpression(v.ge_guard, TL, FALSE)
				    genl(BRF, L1)
				}
		    }
		    if (p . kind = LOOPDENOTATION) then {
			Gexpression(v . ge_element, SK, FALSE)
			genl(BR, L0)
		    } else {
			Gexpression(v . ge_element, rloc, last_expr)
			if (saw_else) then {
			    # Just fall off the end, dropping 
			    # any other else clauses          
			    break
			} else {
			    # Skip over the rest 
			    genl(BR, L0)
			}
		    }
		    genl(LBL, L1)
		    
		    temp := temp.cn_tl_field
		}
		
		if (p . kind = LOOPDENOTATION) then {
		    # return Void value "Null" 
		    gen2(MOV, UN, rloc)
		} else {
		    if (saw_else = TRUE) then {
			# Fell through the end of else-less "if" 
			gen2(HINT, OPT, 1)
			genl(ERR, "_cond_error")
		    }
		    # Exit label for "if" 
		    genl(LBL, L0)
		}
	    }

	WORDELSE :
	    {
		# Use true value 
		gen1(TRU, rloc)
	    }
	

	FUNCCONSTR :
	    {
		Gfuncconstructor (p, rloc)
	    }

	REXTERNDEF :
	    {
		name_length = *(p . r_ext_name)
		if (name_length + 3 > MAXSTRCODELEN) then {
		    rpt_err("File name too long")
		}
		if (Vflag = TRUE) then {
		    write(Gcurrent . fc_code_label || "forces evaluation of externally defined object " || p . r_ext_name)
		}
		str_code_buf := r_ext_name || ".o"
		add_objfile(str_code_buf)
		str_code_buf := "m_" ||  p . r_ext_name
		# Replace slashes with periods 
		map( str_code_buf,"/",".")
		gen2(ARG, 1, GF)
		genl(CLL, str_code_buf)
		gen2(MOV, RL, rloc)
	    }

	USELIST :
	    {
		temp := p.usl_den_seq.lh_head
		while \temp do {
		    v := temp.cn_hd_field
		    if (v != last(p . usl_den_seq)) then {
			Gexpression(v, SK, FALSE)
		    } else {
			Gexpression(v, rloc, last_expr)
		    }
		    temp := temp.cn_tl_field
		}
	    }
	MODPRIMARY :
	    {
		rpt_err("codegen : MODPRIMARY not implemented")
#DJDSTOP
		tm := p . mp_type_modifier
		delv := p . mp_delete_v
		orig := p . mp_orig_length
		final := 0  # size of modified type
		if /tm then is_wl := FALSE
		else if tm.kind = WITHLIST then is_wl := TRUE
		else is_wl := FALSE
		if (is_wl = TRUE) then {
		    wl_length := length(tm . wl_component_list)
		} else {
		    wl_length := 0
		}
		{	    # calculate size of new type 
		    if (orig > 0) then {
			q := delv
			i := 0 
			j := q
			while (i < orig) do {
			    if (j >= 0) then # not deleted  final++
				i++ j <<= 1
			    if (i % WORDLENGTH == 0) then { # go on to next word 
				j = *(++q)
			    }
			}
		    }
		    final += wl_length
                    if (final == 0) then {
                        gen2(LDN, 0, rloc)
                    } else {
                        int sz_loc = avail_loc++
			    # size of new type              
			# also used as temp for copying 
			# and wl components             
			int primary_loc = avail_loc++ # pointer to orig tp 
			int result_loc = avail_loc++

			    # Set up result_loc, in  rloc is SK 
			if (rloc == SK || rloc == RL) then {
			    # RL might interfere with subsidiary 
			    # code generation for WITH list      
			    gen2(DCL, result_loc, DCL_ADDR)
			} else {
			    result_loc = rloc
			}
			# Evaluate original type 
			if (orig > 0) then {
			    gen2(DCL, primary_loc, DCL_ADDR)
			    Gexpression(p . mp_primary, primary_loc, FALSE)
			}

                        # allocate type object, put ptr to it into tp_loc 
                        # and rloc                                        
			gen2(DCL, sz_loc, DCL_INT)
			gen2(LDN, final, sz_loc)
			gen2(ALH, sz_loc, result_loc)
			gen1(UDC, sz_loc)

			# save new type in space reserved for local name 
			if (is_wl) then {
			    int display_entry

                            DISPLAY (display_entry, p . level)
			    gen3(STI, display_entry, p . displacement,
				 result_loc)
                            UNDISPLAY(display_entry)
			}

                        # pointer to new object is in tp_loc      
			# copy selected fields, reserve new ones  
			
			# s := first element of with list, NIL if there 
			# are none.                                     
			if (is_wl && !is_empty(tm.wl_component_list))then  {
			    INIT_ITER(s, tm . wl_component_list)
			} else {
			    s = NIL
			}
			q = (int *)delv i = res_pos = 0
			j = (orig > 0? *q : 0)
			while (s != NIL || i < orig) {
			    # i = position in original type             
			    # sign bit of j = corr. deletion vector bit 
			    # s = next unprocessed entry in with list   
			    ASSERT(res_pos < 5000 && i < 5000,
				   "Gexpression: bad type modification\n")
			    if (s != NIL && s . decl_sel_index == res_pos) then {
				res_pos++
				    NEXT_ITER(s)
				continue
			    } else if (j >= 0) then { # not deleted  
				# Copy this element and increment pointers 
				gen3(LDI, primary_loc, i, T1)
				gen3(STI, result_loc, res_pos, T1)
				res_pos++
				    i++ j <<= 1
			    } else { # deleted  
				i++ j <<= 1
			    }
			    if (i % WORDLENGTH == 0) then  { #go on to next word*/ 
								j = *(++q)
							    }
			}
                        # new type, with with-list components missing, 
			# is in result_loc.                            
			if (orig > 0) then {
			    gen1(UDC, primary_loc)
			}
			if (is_wl) then {
			    NODE * decl_l = (NODE *)
			    decl_sort(p . mp_type_modifier
				      . wl_component_list)
			    # declaration list in original
			    # order, with forward refs    
			    # marked.                     
			    int comp_loc = avail_loc++

				# fill in undefined values so that forward refs 
			    # can be checked.                               
                            maplist (v, decl_l, {
				ASSERT (v . kind == DECLARATION,
					"codegen.c: decl expected")
				if (v . decl_can_be_refd <= v . pre_num) then {
				    # possible forward reference to this decl 
				    gen3(STI, result_loc, v . decl_sel_index, UN)
				}
                            })
			    # Fill in with list components 
			    gen2(DCL, comp_loc, DCL_ADDR)
                            maplist(s, decl_l, {
				Gexpression(s . decl_denotation, comp_loc, FALSE)
				gen3(STI, result_loc,
				     s . decl_sel_index, comp_loc)
			    })
			    gen1(UDC, comp_loc)
                        }
			# result is in result_loc 
			if (rloc == SK) then {
			    gen1(UDC, result_loc)
			} else if (rloc == RL) then {
			    gen2(MOV, result_loc, rloc)
			    gen1(UDC, result_loc)
			}  
		    }
		}
#DJDSTART
	    }
	
	RECORDCONSTRUCTION:
	    {
                type_constr(p, rloc)
	    }
	PRODCONSTRUCTION :
	    {
                type_constr(p, rloc)
	    }
	UNIONCONSTRUCTION :
	    {
                type_constr(p, rloc)
	    }
	ENUMERATION:
	    {
                type_constr(p, rloc)
	    }
	EXTENSION :
	    {
                type_constr(p, rloc)
	    }
        default : {
            findvl( p . vlineno )
	yyinfo( "Gexpression: Unimplemented construct (kind = ) in file  at line" || kindname(p.kind) || getname(getfn()) || getrl() )
	yyinfo( "Gexpression:  p is 0x%x\n")
	write( Goutfile, "?" )
	flush (Goutfile)
	rpt_err("abort")
	}
    }
return TRUE
end

# Compile a loop consisting of a single guarded command efficiently 
# Could probably be generalized ...                                 
procedure compile_while_loop(p, rloc)
    cond_label := Gnewlabel("guard")
    start_label := Gnewlabel("loop")
    Ocompile_fcs := compile_fcs

    if (OOOflag) then {
	# Compile unrolled loop body 
	compile_fcs := FALSE  # ignore nested functions we'll get them 
	# later.                                  
    end_label := Gnewlabel("loop_end")
	Gexpression(p . ge_guard, TL, FALSE)
	genl(BRF, end_label)
	Gexpression(p . ge_element, SK, FALSE)
	compile_fcs := Ocompile_fcs
    }
    genl(BR, cond_label)
    genl(LBL, start_label)
    Gexpression(p . ge_element, SK, FALSE)
    genl(LBL, cond_label)
    Gexpression(p . ge_guard, TL, FALSE)
    genl(BRT, start_label)
    if (OOOflag) then {
	genl(LBL, end_label)
    }
    # Expression value is Null 
    gen2(MOV, UN, rloc)
return TRUE
end
procedure genl(op,l)
    genl_RIC(ofile,op,l)
return TRUE
end
procedure gen2(op,a1,a2)  
    gen_RIC(ofile,op,a1,a2,SK)
return TRUE
end
procedure gen1(op,a1)  
    gen_RIC(ofile,op,a1,SK,SK)
return TRUE
end
procedure gen0(op)  
    gen_RIC(ofile,op,SK,SK,SK)
return TRUE
end
