Rev 5 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed
/*
* Copyright (c) 2002-2006 The TenDRA Project <http://www.tendra.org/>.
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
* 3. Neither the name of The TenDRA Project nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific, prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
* IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
* THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* $Id$
*/
/*
Crown Copyright (c) 1997
This TenDRA(r) Computer Program is subject to Copyright
owned by the United Kingdom Secretary of State for Defence
acting through the Defence Evaluation and Research Agency
(DERA). It is made available to Recipients with a
royalty-free licence for its use, reproduction, transfer
to other parties and amendment for any purpose not excluding
product development provided that any such use et cetera
shall be deemed to be acceptance of the following conditions:-
(1) Its Recipients shall ensure that this Notice is
reproduced upon any copies or amended versions of it;
(2) Any amended version of it shall be clearly marked to
show both the nature of and the organisation responsible
for the relevant amendment or amendments;
(3) Its onward transfer from a recipient to another
party shall be deemed to be that party's acceptance of
these conditions;
(4) DERA gives no warranty or assurance as to its
quality or suitability for any purpose and DERA accepts
no liability whatsoever in relation to any use to which
it may be put.
*/
/**********************************************************************
$Author: pwe $
$Date: 1998/03/17 16:34:56 $
$Revision: 1.3 $
$Log: install_fns.c,v $
* Revision 1.3 1998/03/17 16:34:56 pwe
* correction for non-NEWDIAGS
*
* Revision 1.2 1998/03/11 11:03:26 pwe
* DWARF optimisation info
*
* Revision 1.1.1.1 1998/01/17 15:55:47 release
* First version to be checked into rolling release.
*
* Revision 1.89 1998/01/09 09:28:51 pwe
* prep restructure
*
* Revision 1.88 1997/12/04 19:39:04 pwe
* ANDF-DE V1.9
*
* Revision 1.87 1997/11/04 18:23:50 pwe
* split install_fns with new flpt_fns
*
* Revision 1.86 1997/10/23 09:24:32 pwe
* extra diags
*
* Revision 1.85 1997/10/10 18:15:34 pwe
* prep ANDF-DE revision
*
* Revision 1.84 1997/08/23 13:24:16 pwe
* no invert order, and NEWDIAGS inlining
*
* Revision 1.83 1997/08/06 10:58:25 currie
* Catch overflowed constants, PlumHall requirement
*
* Revision 1.82 1997/02/18 12:56:28 currie
* NEW DIAG STRUCTURE
*
* Revision 1.81 1996/11/18 14:36:51 currie
* case_opt fixes
*
* Revision 1.80 1996/11/12 10:42:20 currie
* unsigned cases
*
* Revision 1.78 1996/11/11 10:05:39 currie
* current_env on hppa
*
* Revision 1.77 1996/10/29 10:10:46 currie
* 512 bit alignment for hppa
*
* Revision 1.76 1996/10/21 08:53:55 currie
* long_jump_access
*
* Revision 1.75 1996/10/01 08:59:22 currie
* correct chvar exceptions ADA
*
* Revision 1.74 1996/09/04 14:44:40 currie
* mis-spelling
*
* Revision 1.73 1996/09/04 14:19:55 currie
* mis-spelling
*
* Revision 1.71 1996/07/05 15:45:09 currie
* initial values
*
* Revision 1.70 1996/06/19 11:50:36 currie
* Parameter alignments in make_coumpound
*
* Revision 1.69 1996/06/18 09:20:55 currie
* C torture long nats
*
* Revision 1.68 1996/06/05 15:29:54 currie
* parameter alignment in make_cmpd
*
* Revision 1.67 1996/05/14 10:39:14 currie
* Long unsigned div2
*
* Revision 1.66 1996/05/02 09:34:44 currie
* Empty caselim list
*
* Revision 1.65 1996/04/02 10:34:16 currie
* volatile & trap_on_nil
*
* Revision 1.63 1996/03/28 11:33:48 currie
* Hppa struct params + outpar+init names
*
* Revision 1.62 1996/03/12 09:45:20 currie
* promote pars
*
* Revision 1.60 1996/02/28 11:36:20 currie
* assign to promoted pars
*
* Revision 1.59 1996/02/26 11:54:22 currie
* Various odds and ends
*
* Revision 1.58 1996/02/21 09:39:02 currie
* hppa var_callers + inlined bug
*
* Revision 1.57 1996/01/25 17:02:53 currie
* Struct params in sparc + postludes
*
* Revision 1.56 1996/01/22 14:25:33 currie
* char parameters on bigendian
*
* Revision 1.55 1996/01/19 14:49:54 currie
* sparc parameter alignments
*
* Revision 1.54 1996/01/17 10:28:07 currie
* param alignment + case bigval
*
* Revision 1.53 1996/01/12 10:10:03 currie
* AVS - promote pars with struct result
*
* Revision 1.51 1996/01/08 09:36:05 currie
* trap_on_nil + hppa change
*
* Revision 1.49 1995/12/15 15:32:46 currie
* Char par + string concat
*
* Revision 1.48 1995/12/12 09:00:43 currie
* Non-var out_pars
*
* Revision 1.47 1995/12/07 11:43:26 currie
* Identity dyn initialisation + mod for hppa error treatments
*
* Revision 1.46 1995/12/04 13:48:23 currie
* postlude with struct result
*
* Revision 1.45 1995/12/04 10:11:54 currie
* power wrap
*
* Revision 1.44 1995/11/29 15:30:11 currie
* computed signed nat
*
* Revision 1.43 1995/11/23 11:31:06 currie
* MIN_PAR_ALIGNMENT + odd & ends
*
* Revision 1.42 1995/10/31 12:00:15 currie
* frame alignments & power
*
* Revision 1.42 1995/10/31 12:00:15 currie
* frame alignments & power
*
* Revision 1.41 1995/10/24 14:33:40 currie
* variety not shape
*
* Revision 1.40 1995/10/17 12:59:33 currie
* Power tests + case + diags
*
* Revision 1.39 1995/10/13 15:15:07 currie
* case + long ints on alpha
*
* Revision 1.38 1995/10/12 15:52:52 currie
* inlining bug
*
* Revision 1.37 1995/10/11 17:10:03 currie
* avs errors
*
* Revision 1.36 1995/10/10 14:46:15 currie
* 223 - non-ansi call
*
* Revision 1.35 1995/10/06 14:41:57 currie
* Env-offset alignments + new div with ET
*
* Revision 1.34 1995/10/02 10:55:56 currie
* Alpha varpars + errhandle
*
* Revision 1.33 1995/09/27 12:39:25 currie
* Peters PIC code
*
* Revision 1.32 1995/09/25 09:17:56 currie
* assign with mode
*
* Revision 1.31 1995/09/22 15:47:10 currie
* added setoutpar; tidied some non-strict ansi
*
* Revision 1.30 1995/09/20 12:10:18 currie
* 64-bit shl arg2 widened
*
* Revision 1.29 1995/09/19 16:06:46 currie
* isAlpha!!
*
* Revision 1.28 1995/09/19 11:51:46 currie
* Changed name of init fn +gcc static bug
*
* Revision 1.27 1995/09/15 13:29:03 currie
* hppa + add_prefix + r_w_m complex
*
* Revision 1.26 1995/09/11 15:35:34 currie
* caller params -ve
*
* Revision 1.24 1995/08/31 14:18:59 currie
* mjg mods
*
* Revision 1.23 1995/08/21 09:38:35 currie
* no_trap_on_nill_contents
*
* Revision 1.23 1995/08/21 09:38:35 currie
* no_trap_on_nill_contents
*
* Revision 1.22 1995/08/18 09:03:28 currie
* Float variety adjusted
*
* Revision 1.21 1995/08/15 08:25:31 currie
* Shift left + trap_tag
*
* Revision 1.20 1995/08/09 10:33:06 currie
* otagexp list reorganised
*
* Revision 1.19 1995/08/09 08:59:58 currie
* round bug
*
* Revision 1.18 1995/08/02 13:18:00 currie
* Various bugs reported
*
* Revision 1.17 1995/07/04 10:41:22 currie
* round with mode shape
*
* Revision 1.16 1995/07/03 13:42:41 currie
* Tail call needs fp
*
* Revision 1.15 1995/07/03 09:15:10 currie
* Round again
*
* Revision 1.14 1995/06/30 13:47:24 currie
* shift_left unsigned
*
* Revision 1.13 1995/06/29 13:49:37 currie
* place -> plce
*
* Revision 1.12 1995/06/28 12:12:16 currie
* offset subtract alignments
*
* Revision 1.11 1995/06/28 11:53:38 currie
* Stack limits etc
*
* Revision 1.10 1995/06/26 13:04:37 currie
* make_stack_limit, env_size etc
*
* Revision 1.9 1995/06/22 09:19:30 currie
* Complex power improvement
*
* Revision 1.7 1995/06/15 09:00:25 currie
* No protos in sunos!
*
* Revision 1.6 1995/06/15 08:42:09 currie
* make_label + check repbtseq
*
* Revision 1.4 1995/06/14 08:35:36 currie
* 64 bit int<->bits
*
* Revision 1.3 1995/06/08 14:49:16 currie
* changes derived from ver 3
*
* Revision 1.2 1995/05/05 08:10:50 currie
* initial_value + signtures
*
* Revision 1.1 1995/04/06 10:44:05 currie
* Initial revision
*
***********************************************************************/
/* This file defines procedures called from decoder which make up
the internal representations of the various sorts of value.
In most cases the construction of these is evident from the
specification and the document describing the in-store
representation: the function merely creates the corresponding value.
In some cases processing is performed: it is only these which are
commented.
Many constructions have the shape of their arguments checked by
check_shape. These checks are implied by the specification and are
not commented.
*/
#include "config.h"
#include <ctype.h>
#include <time.h>
#include "common_types.h"
#include "basicread.h"
#include "exp.h"
#include "expmacs.h"
#include "main_reads.h"
#include "tags.h"
#include "flags.h"
#include "me_fns.h"
#include "installglob.h"
#include "readglob.h"
#include "table_fns.h"
#include "flpttypes.h"
#include "flpt.h"
#include "xalloc.h"
#include "shapemacs.h"
#include "read_fns.h"
#include "sortmacs.h"
#include "machine.h"
#include "spec.h"
#include "check_id.h"
#include "check.h"
#include "szs_als.h"
#include "messages_c.h"
#include "natmacs.h"
#include "f64.h"
#include "readglob.h"
#include "case_opt.h"
#include "install_fns.h"
#include "externs.h"
#ifdef NEWDIAGS
#include "dg_fns.h"
#include "mark_scope.h"
#endif
#define NOTYETDONE(x) failer(x)
#define MAX_ST_LENGTH 25
/* All variables initialised */
shape f_ptr1;
shape f_ptr8;
shape f_ptr16;
shape f_ptr32;
shape f_ptr64;
shape f_off0_0;
shape f_off1_1;
shape f_off8_8;
shape f_off8_1;
shape f_off16_16;
shape f_off16_8;
shape f_off16_1;
shape f_off32_32;
shape f_off32_16;
shape f_off32_8;
shape f_off32_1;
shape f_off64_64;
shape f_off64_32;
shape f_off64_16;
shape f_off64_8;
shape f_off64_1;
shape f_off512_512;
shape f_off512_64;
shape f_off512_32;
shape f_off512_16;
shape f_off512_8;
shape f_off512_1;
shape ucharsh;
shape scharsh;
shape uwordsh;
shape swordsh;
shape ulongsh;
shape slongsh;
shape u64sh;
shape s64sh;
shape shrealsh;
shape realsh;
shape doublesh;
shape shcomplexsh;
shape complexsh;
shape complexdoublesh;
shape f_bottom;
shape f_top;
shape f_local_label_value;
procprops f_dummy_procprops;
procprops f_var_callers = 1;
procprops f_var_callees = 2;
procprops f_untidy = 4;
procprops f_check_stack = 8;
procprops f_no_long_jump_dest = 16;
procprops f_inline = 32;
static proc_props initial_value_pp;
procprops
f_add_procprops(procprops t, procprops e)
{
return (t | e);
}
procprops no_procprops_option = 0;
procprops
yes_procprops_option(procprops p)
{
return p;
}
void
init_procprops_option(void)
{
return;
}
error_code f_overflow = 7;
error_code f_nil_access = 19;
error_code f_stack_overflow = 35;
error_code_list
add_error_code_list(error_code_list t, error_code e, int i)
{
UNUSED(i);
return (t | e);
}
error_code_list
new_error_code_list(int n)
{
UNUSED(n);
return 0;
}
transfer_mode f_trap_on_nil = 8;
shape
containedshape(int a, int s)
{
switch ((a + 7) & ~7) {
case 8:
case 0:
return ((s) ? scharsh : ucharsh);
case 16:
return ((s) ? swordsh : uwordsh);
case 32:
case 24:
return ((s) ? slongsh : ulongsh);
case 64:
case 40:
case 48:
case 56:
return ((s) ? s64sh : u64sh);
default:
failer("Illegal pointer for bitfield operations");
return scharsh;
}
}
dec *
make_extra_dec(char *nme, int v, int g, exp init, shape s)
{
dec *extra_dec = (dec *)calloc(1, sizeof(dec));
exp e = getexp(s, nilexp, 0, init, nilexp, 0, 0, ident_tag);
setglob(e);
if (v) {
setvar(e);
}
brog(e) = extra_dec;
extra_dec->def_next = (dec *)0;
*deflist_end = extra_dec;
deflist_end = &((*deflist_end)->def_next);
extra_dec->dec_u.dec_val.dec_id = nme;
extra_dec->dec_u.dec_val.dec_shape = s;
extra_dec->dec_u.dec_val.dec_exp = e;
extra_dec->dec_u.dec_val.unit_number = crt_tagdef_unit_no;
extra_dec->dec_u.dec_val.diag_info = (diag_global *)0;
extra_dec->dec_u.dec_val.extnamed = (unsigned int)g;
extra_dec->dec_u.dec_val.dec_var = (unsigned int)v;
extra_dec->dec_u.dec_val.dec_outermost = 0;
extra_dec->dec_u.dec_val.have_def = init != nilexp;
extra_dec->dec_u.dec_val.processed = 0;
extra_dec->dec_u.dec_val.isweak = 0;
extra_dec->dec_u.dec_val.is_common = 0;
if (init != nilexp) {
setfather(e, init);
}
return extra_dec;
}
dec *
find_named_dec(char *n)
{
/* find a global with name n */
dec *my_def = top_def;
while (my_def != (dec *)0) {
char *id = my_def->dec_u.dec_val.dec_id;
if (strcmp(id + strlen(name_prefix), n) == 0) {
return my_def;
}
my_def = my_def->def_next;
}
return (dec *)0;
}
exp
find_named_tg(char *n, shape s)
{
/* find a global with name n */
dec *my_def = find_named_dec(n);
if (my_def != (dec*)0) {
return my_def->dec_u.dec_val.dec_exp;
}
my_def = make_extra_dec(add_prefix(n), 0, 1, nilexp, s);
return my_def->dec_u.dec_val.dec_exp;
}
#if !has64bits
char *
fn_of_op(int nm, int sngd)
{
/* Find a run-time library fn corresponding to nm */
#define CSU(x, y) return (sngd) ? x : y
switch (nm) {
case plus_tag:
CSU("__TDFUs_plus", "__TDFUu_plus");
case minus_tag:
CSU("__TDFUs_minus", "__TDFUu_minus");
case mult_tag:
CSU("__TDFUs_mult", "__TDFUu_mult");
case div0_tag:
case div2_tag:
CSU("__TDFUs_div2", "__TDFUu_div2");
case div1_tag:
CSU("__TDFUs_div1", "__TDFUu_div2");
case rem0_tag:
case rem2_tag:
CSU("__TDFUs_rem2", "__TDFUu_rem2");
case mod_tag:
CSU("__TDFUs_rem1", "__TDFUu_rem2");
case shl_tag:
CSU("__TDFUs_shl", "__TDFUu_shl");
case shr_tag:
CSU("__TDFUs_shr", "__TDFUu_shr");
case neg_tag:
return "__TDFUneg";
case abs_tag:
return "__TDFUabs";
case chvar_tag:
CSU("__TDFUs_chvar", "__TDFUu_chvar");
case max_tag:
CSU("__TDFUs_max", "__TDFUu_max");
case min_tag:
CSU("__TDFUs_min", "__TDFUu_min");
case test_tag:
CSU("__TDFUs_test", "__TDFUu_test");
case float_tag:
CSU("__TDFUs_float", "__TDFUu_float");
case and_tag:
return "__TDFUand";
case or_tag:
return "__TDFUor";
case xor_tag:
return "__TDFUxor";
case not_tag:
return "__TDFUnot";
default:
failer("No fn for long op");
}
return "__TDFerror";
}
exp
TDFcallop3(exp arg1, exp arg2, int n)
{
/* construct proc call for binary op corresponding to n */
char *nm = fn_of_op(n, is_signed(sh(arg1)));
exp dc;
exp ob;
exp_list pars;
exp_option novar;
exp res;
novar.present = 0;
dc = find_named_tg(nm, f_proc);
ob = me_obtain(dc);
pars.number = 2;
pars.start = arg1;
pars.end = arg2;
bro(arg1) = arg2;
clearlast(arg1);
res = f_apply_proc(sh(arg1), ob, pars, novar);
res = hold_check(res);
return res;
}
exp
TDFwithet(error_treatment ov_err, exp e)
{
exp id;
exp c;
exp_list el;
exp Te;
if (ov_err.err_code <= 2) {
return e;
}
Te = find_named_tg("__TDFerror", slongsh);
brog(Te)->dec_u.dec_val.dec_var = 1;
#if keep_PIC_vars
setvar(Te);
#else
if (PIC_code) {
sh(Te) = f_pointer(f_alignment(slongsh));
} else {
setvar(Te);
}
#endif
id = me_startid(sh(e), e, 0);
c = f_contents(slongsh, me_obtain(Te));
el = new_exp_list(1);
el = add_exp_list(el, f_plus(ov_err, me_shint(slongsh, (int)0x80000000),
c), 0);
return me_complete_id(id, f_sequence(el, me_obtain(id)));
}
exp
TDFcallop2(error_treatment ov_err, exp arg1, exp arg2, int n)
{
/* construct proc call for binary op corresponding to n */
/* ignore error treatment for the moment */
char *nm = fn_of_op(n, is_signed(sh(arg1)));
exp dc;
exp ob;
exp_list pars;
exp_option novar;
exp res;
novar.present = 0;
dc = find_named_tg(nm, f_proc);
ob = me_obtain(dc);
pars.number = 2;
pars.start = arg1;
pars.end = arg2;
bro(arg1) = arg2;
clearlast(arg1);
res = f_apply_proc((n==test_tag)?slongsh:sh(arg1), ob, pars, novar);
return TDFwithet(ov_err, res);
}
exp
TDFcallaux(error_treatment ov_err, exp arg1, char *nm, shape s)
{
exp dc;
exp ob;
exp_list pars;
exp_option novar;
exp res;
novar.present = 0;
dc = find_named_tg(nm, f_proc);
ob = me_obtain(dc);
pars.number = 1;
pars.start = arg1;
pars.end = arg1;
res = f_apply_proc(s, ob, pars, novar);
res = hold_check(res);
return TDFwithet(ov_err, res);
}
exp TDFcallop1
(error_treatment ov_err, exp arg1, int n)
{
/* construct proc call for unary op corresponding to n */
/* ignore error treatment for the moment */
char *nm = fn_of_op(n, is_signed(sh(arg1)));
return TDFcallaux(ov_err, arg1, nm, sh(arg1));
}
exp
TDFcallop4(exp arg1, int n)
{
/* construct proc call for unary op corresponding to n */
char *nm = fn_of_op(n, is_signed(sh(arg1)));
exp dc;
exp ob;
exp_list pars;
exp_option novar;
exp res;
novar.present = 0;
dc = find_named_tg(nm, f_proc);
ob = me_obtain(dc);
pars.number = 1;
pars.start = arg1;
pars.end = arg1;
res = f_apply_proc(sh(arg1), ob, pars, novar);
return res;
}
#endif /* !has64bits */
error_treatment f_wrap;
error_treatment f_impossible;
error_treatment f_continue;
#ifdef promote_pars
static void
promote_actuals(exp par)
{
for (;;) {
shape s = sh(par);
if (name(s) >= scharhd && name(s) <= uwordhd) {
shape ns = (is_signed(s)) ? slongsh : ulongsh;
exp w = hold_check(f_change_variety(f_wrap, ns,
copy(par)));
replace(par, w, nilexp);
kill_exp(par, nilexp);
par = w;
}
if (last(par)) {
break;
}
par = bro(par);
}
}
static void
promote_formals(exp bdy)
{
while ((name(bdy) == ident_tag && isparam(bdy))
#ifndef NEWDIAGS
|| name(bdy) == diagnose_tag
#endif
) {
shape spar = sh(son(bdy));
if (name(bdy) != ident_tag) {
bdy = son(bdy);
continue;
}
if (name(spar) >= scharhd && name(spar) <= uwordhd) {
shape ns = (is_signed(spar)) ? slongsh : ulongsh;
exp u = pt(bdy);
exp w;
sh(son(bdy)) = ns;
if (!isvar(bdy)) {
while (u != nilexp) {
exp nextu = pt(u);
sh(u) = ns;
w = f_change_variety(f_wrap, spar,
copy(u));
replace(u, w, nilexp);
kill_exp(u, nilexp);
u = nextu;
}
} else {
shape ps = f_pointer(f_alignment(ns));
while (u != nilexp) {
exp nextu = pt(u);
if (last(u) && name(bro(u)) == cont_tag) {
if (little_end) {
exp con = bro(u);
sh(u) = ps;
sh(con) = ns;
w = f_change_variety(
f_wrap, spar,
copy(con));
replace(con, w, nilexp);
kill_exp(con, nilexp);
}
} else {
setvis(bdy);
if (!little_end) {
sh(u) = ps;
no(u) = shape_size(ns) -
shape_size(spar);
}
}
u = nextu;
}
}
}
bdy = bro(son(bdy));
}
}
#endif /* promote_pars */
aldef frame_als[32];
alignment f_locals_alignment = &frame_als[0];
alignment nv_callers_alignment = &frame_als[1];
alignment var_callers_alignment = &frame_als[3];
alignment nv_callees_alignment = &frame_als[7];
alignment var_callees_alignment = &frame_als[15];
void
init_frame_als(void)
{
int i;
for (i = 0; i < 32; i++) {
frame_als[i].al.sh_hd = 0;
frame_als[i].al.al_n = 1;
frame_als[i].al.al_val.al = 64;
frame_als[i].al.al_val.al_frame = i + 1;
}
}
error_treatment
f_trap(error_code_list ec)
{
error_treatment res;
res.err_code = ec;
return res;
}
alignment
f_callers_alignment(bool var)
{
return ((var) ? var_callers_alignment : nv_callers_alignment);
}
alignment
f_callees_alignment(bool var)
{
return ((var) ? var_callees_alignment : nv_callees_alignment);
}
otagexp
f_make_otagexp(tag_option tagopt, exp e)
{
exp init;
if (!tagopt.present) {
return e;
}
e = getexp(sh(e), nilexp, 0, e, nilexp, 0, 0, caller_tag);
init = getexp(sh(e), nilexp, 0, nilexp , nilexp, 0, 0, caller_name_tag);
pt(e) = getexp(f_top, nilexp, 0, init, nilexp, 0, 0, ident_tag);
/* setvar(pt(e)); - NOT ACCORDING TO SPEC */
setfather(e, son(e));
set_tag(tagopt.val, pt(e));
return e;
}
otagexp_list
new_otagexp_list(int n)
{
otagexp_list res;
res.number =0;
res.start = nilexp;
res.end = nilexp;
res.id = nilexp;
UNUSED(n);
return res;
}
otagexp_list
add_otagexp_list(otagexp_list list, otagexp ote, int n)
{
if (list.number++ == 0) {
list.start = list.end = ote;
} else {
bro(list.end) = ote;
clearlast(list.end);
list.end = ote;
}
setlast(ote);
if (name(ote) == caller_tag) {
exp id = pt(ote);
exp lid = list.id;
bro(son(id)) = lid;
if (lid != nilexp) {
bro(lid) = id;
setlast(lid);
}
no(son(id)) = n;
list.id = id;
pt(ote) = nilexp; /* this pt is a temp link */
}
return list;
}
callees
f_make_callee_list(exp_list args)
{
exp e = getexp(f_top, nilexp, 0, args.start, nilexp, 0, args.number,
make_callee_list_tag);
if (args.number != 0) {
setfather(e, args.end);
#ifdef promote_pars
promote_actuals(args.start);
#endif
}
return e;
}
callees
f_make_dynamic_callees(exp ptr, exp sze)
{
exp e = getexp(f_top, nilexp, 0, ptr, nilexp, 0, 0,
make_dynamic_callee_tag);
bro(ptr) = sze;
clearlast(ptr);
setfather(e, sze);
return e;
}
/* exps waiting to be used have the parked flag set in props,
so that used_in need not look at their context.
This procedure removes the parked flag from each member of an
exp list, in preparation for putting them into their
proper context.
*/
void
clear_exp_list(exp_list el)
{
exp t = el.start;
if (t == nilexp) {
return;
}
while (1) {
parked(t) = 0;
if (t == el.end) {
return;
}
t = bro(t);
}
}
alignment frame_alignment;
/* ntest codes */
ntest f_equal = 5;
ntest f_greater_than = 1;
ntest f_greater_than_or_equal = 2;
ntest f_less_than = 3;
ntest f_less_than_or_equal = 4;
ntest f_not_equal = 6;
ntest f_not_greater_than = 10;
ntest f_not_greater_than_or_equal = 9;
ntest f_not_less_than = 8;
ntest f_not_less_than_or_equal = 7;
ntest f_less_than_or_greater_than = 11;
ntest f_not_less_than_and_not_greater_than = 12;
ntest f_comparable = 13;
ntest f_not_comparable = 14;
static ntest convert_ntest[] = {0, 1, 2, 3, 4, 5, 6,
1, 2, 3, 4, 6, 5, 13, 14};
static exp
replace_ntest(ntest nt, label dest, exp arg1, exp arg2)
{
exp res;
exp_list el;
el = new_exp_list(2);
el = add_exp_list(el, arg1, 0);
el = add_exp_list(el, arg2, 1);
if (nt == f_comparable) {
res = f_make_top();
} else {
res = f_goto(dest);
}
return f_sequence(el, res);
}
/* rounding mode codes */
rounding_mode f_to_nearest = R2NEAR;
rounding_mode f_toward_larger = R2PINF;
rounding_mode f_toward_smaller = R2NINF;
rounding_mode f_toward_zero = R2ZERO;
rounding_mode f_round_as_state = 4;
transfer_mode f_standard_transfer_mode = 0;
transfer_mode f_volatile = 1;
transfer_mode f_overlap = 2;
transfer_mode f_complete = 4;
#define max(x, y) ((x) > (y)) ? (x) : (y)
/* careful: use simple arguments! */
alignment
f_alignment(shape sha)
{
return align_of(sha);
}
/* we may not yet know the actual values for the alignments,
merely that they are computed from other alignments by unite.
So we have to set up equations which are solved at the end of aldefs
*/
alignment
f_obtain_al_tag(al_tag a1)
{
alignment j;
if (a1->al.al_n == 1) {
return long_to_al(a1->al.al_val.al);
}
j = (alignment)calloc(1, sizeof(aldef));
j->al.al_n = 3;
j->al.al_val.al_join.a = a1;
j->next_aldef = top_aldef;
top_aldef = j;
return j;
}
alignment
f_unite_alignments(alignment a1, alignment a2)
{
alignment j;
if (a1->al.al_n == 1 && a2->al.al_n == 1) {
if (a1->al.al_val.al_frame == a2->al.al_val.al_frame) {
if (a1->al.al_val.al > a2->al.al_val.al) {
return a1;
} else {
return a2;
}
} else if (a1->al.al_val.al_frame ==0) {
return a2;
} else if (a2->al.al_val.al_frame == 0) {
return a1;
} else {
return (&frame_als[(a1->al.al_val.al_frame |
a2->al.al_val.al_frame) -1]);
}
}
j = (alignment)calloc(1, sizeof(aldef));
j->al.al_n = 2;
j->al.al_val.al_join.a = a1;
j->al.al_val.al_join.b = a2;
j->next_aldef = top_aldef;
top_aldef = j;
return j;
}
void
init_access(void)
{
return;
}
access f_dummy_access;
access f_visible = 1;
access f_standard_access = 0;
access f_long_jump_access = 2;
access f_constant = 4;
access f_no_other_read = 8;
access f_no_other_write = 16;
access f_register = 32;
access f_out_par = 64;
access f_used_as_volatile = 128;
access f_preserve = 256;
access
f_add_accesses(access a1, access a2)
{
return a1 | a2;
}
alignment f_alloca_alignment;
alignment f_var_param_alignment;
alignment f_code_alignment;
static struct CAL {
short sh_hd;
short al;
alignment res;
struct CAL *rest;
} *cache_pals;
void
init_alignment(void)
{
const_al1->al.al_n = 1;
const_al1->al.al_val.al = 1;
const_al1->al.al_val.al_frame = 0;
const_al1->al.sh_hd = 0;
const_al8->al.al_n = 1;
const_al8->al.al_val.al = 8;
const_al8->al.al_val.al_frame = 0;
const_al8->al.sh_hd = 0;
const_al16->al.al_n = 1;
const_al16->al.al_val.al = 16;
const_al16->al.al_val.al_frame = 0;
const_al16->al.sh_hd = 0;
const_al32->al.al_n = 1;
const_al32->al.al_val.al = 32;
const_al32->al.al_val.al_frame = 0;
const_al32->al.sh_hd = 0;
const_al64->al.al_n = 1;
const_al64->al.al_val.al = 64;
const_al64->al.al_val.al_frame = 0;
const_al64->al.sh_hd = 0;
const_al512->al.al_n = 1;
const_al512->al.al_val.al = 512;
const_al512->al.al_val.al_frame = 0;
const_al512->al.sh_hd = 0;
cache_pals = (struct CAL *)0;
init_frame_als();
f_alloca_alignment = ALLOCA_ALIGN;
f_var_param_alignment = VAR_PARAM_ALIGN;
f_code_alignment = CODE_ALIGN;
stack_align = max(param_align, double_align);
return;
}
alignment f_dummy_alignment;
static alignment
get_pal(alignment a, int sh_hd, int al)
{
struct CAL *c = cache_pals;
alignment res;
while (c != (struct CAL *)0) {
if (c->sh_hd == sh_hd && c->al == al) {
return c->res;
}
c = c->rest;
}
res = (alignment)xmalloc(sizeof(aldef));
*res = *a;
res->al.sh_hd = sh_hd;
c = (struct CAL *)xmalloc(sizeof(struct CAL));
c->sh_hd = sh_hd;
c->al = al;
c->res = res;
c->rest = cache_pals;
cache_pals = c;
return res;
}
alignment
f_parameter_alignment(shape sha)
{
int n = name(sha);
alignment t =
#if issparc
MIN_PAR_ALIGNMENT;
#else
f_unite_alignments(MIN_PAR_ALIGNMENT, f_alignment(sha));
#endif
#if ishppa
if (shape_size(sha) > 64) {
n = nofhd + 1;
}
#endif
#if issparc
if (sparccpd(sha)) {
n = nofhd + 1;
}
#endif
return get_pal(t, n, shape_align(sha));
}
bitfield_variety
f_bfvar_bits(bool issigned, nat bits)
{
bitfield_variety res;
if (!nat_issmall(bits)) {
failer(TOO_MANY_BITS);
}
res.has_sign = issigned;
res.bits = natint(bits);
if (extra_checks && res.bits > SLONG_SZ) {
failer(TOO_MANY_BITS);
}
return res;
}
void
init_bitfield_variety(void)
{
return;
}
bitfield_variety f_dummy_bitfield_variety;
bool f_false = 0;
bool f_true = 1;
void
init_bool(void)
{
return;
}
bool f_dummy_bool;
caselim
f_make_caselim(label branch, signed_nat lower, signed_nat upper)
{
caselim c;
c.lab = branch;
c.low = lower;
c.high = upper;
return c;
}
callees f_dummy_callees;
callees f_same_callees;
void
init_callees(void)
{
f_same_callees = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0,
same_callees_tag);
return;
}
void
init_caselim(void)
{
return;
}
error_treatment
f_error_jump(label lab)
{
error_treatment e;
e.err_code = 4;
e.jmp_dest = lab;
return e;
}
error_code f_dummy_error_code;
void
init_error_code(void)
{
return;
}
void
init_error_treatment(void)
{
f_wrap.err_code = 1;
f_impossible.err_code = 0;
f_continue.err_code = 2;
return;
}
error_treatment f_dummy_error_treatment;
exp
f_abs(error_treatment ov_err, exp arg1)
{
if (name(sh(arg1)) == bothd || !is_signed(sh(arg1))) {
return arg1;
}
#if check_shape
if (!is_integer(sh(arg1))) {
failer(CHSH_ABS);
}
#endif
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || ov_err.err_code > 2)) {
return TDFcallop1(ov_err, arg1, abs_tag);
}
#endif
return me_u1(ov_err, arg1, abs_tag);
}
exp
f_add_to_ptr(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!doing_aldefs && (name(sh(arg1)) != ptrhd ||
name(sh(arg2)) != offsethd ||
(al1(sh(arg1)) < al1(sh(arg2))
#if issparc
&& al1_of(sh(arg2)) != REAL_ALIGN
#endif
))) {
failer(CHSH_ADDPTR);
}
#endif
#if issparc || ishppa
if ((al1_of(sh(arg2))->al.al_val.al_frame & 6) != 0 &&
#else
if ((al1_of(sh(arg2))->al.al_val.al_frame & 4) != 0 &&
#endif
al2_of(sh(arg2))->al.sh_hd > nofhd) {
/* indirect varargs param */
exp z = me_b3(f_pointer(f_alignment(sh(arg1))), arg1, arg2,
addptr_tag);
return f_contents(sh(arg1), z);
}
return (me_b3(f_pointer(al2_of(sh(arg2))), arg1, arg2, addptr_tag));
}
exp
f_and(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_AND);
}
#endif
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag)) {
return TDFcallop3(arg1, arg2, and_tag);
}
#endif
return me_b2(arg1, arg2, and_tag);
}
exp
f_apply_proc(shape result_shape, exp arg1, exp_list arg2, exp_option varparam)
{
exp res = getexp(result_shape, nilexp, 0, arg1, nilexp, 0, 0,
apply_tag);
int varhack = 0;
if (name(sh(arg1)) == bothd) {
return arg1;
}
#if check_shape
if (name(sh(arg1)) != prokhd) {
failer(CHSH_APPLY);
}
#endif
if (varparam.present) {
/* add a declaration for variable parameters */
arg2 = add_exp_list(arg2, varparam.val, arg2.number + 1);
varhack =1;
}
clear_exp_list(arg2);
if (name(arg1) == name_tag && isglob(son(arg1)) && !isvar(son(arg1))) {
speci sp;
/* check for substitutions for certain global procedures */
sp = special_fn(arg1, arg2.start, result_shape);
if (sp.is_special) {
return sp.special_exp;
}
}
if (arg2.number==0) {
setfather(res, arg1);
} else {
clearlast(arg1);
bro(arg1) = arg2.start;
setfather(res, arg2.end);
#ifdef promote_pars
promote_actuals(bro(son(res)));
#endif
}
/* rewrite struct/union value parameters as pointer-to-copy */
if (redo_structparams && arg2.number > 0) {
/* has >0 params */
exp param, prev;
prev = arg1;
param = bro(arg1);
while (1 /*"break" below*/) {
if ((varhack && last(param)) ||
#if ishppa
((name(sh(param)) == cpdhd ||
name(sh(param)) == nofhd ||
name(sh(param)) == doublehd) &&
(shape_size(sh(param)) > 64)))
#else
#if issparc
sparccpd(sh(param)))
#else
name(sh(param)) == cpdhd ||
name(sh(param)) == nofhd ||
name(sh(param)) == doublehd)
#endif
#endif
{
/*
* param IS struct/union-by-value,
* pass indirectly: make a local
* copy of param and in the
* parameter list replacce param by
* pointer to the copy.
*
* From:(apply_tag arg1 ...param...)
*
* Make:(new_ident param(apply_tag
* arg1 .... new_par ...))
* Where new_par =
* pointer-to-new_ident
*/
exp new_par, new_ident;
shape ptr_s =
f_pointer(f_alignment(sh(param)));
/* new_ident: (ident_tag sh=sh(res)
no=1 pt=new_par param res) */
new_ident = getexp(sh(res),
bro(res),
(int)last(res),
param, nilexp, 0,
1, ident_tag);
setvar(new_ident);
/* taking its address below*/
/* new_par: (name_tag sh=ptr_s pt=0
new_ident) */
new_par = getexp(ptr_s, bro(param),
(bool)last(param),
new_ident, nilexp,
0, 0, name_tag);
pt(new_ident) = new_par;
/* use of new new_ident by new_par*/
setlastuse(new_par);
/* ... is last-and-only use of
new_ident */
/* install res as body of
new_ident */
clearlast(param);
bro(param) = res;
setlast(res);
bro(res) = new_ident;
bro(prev) = new_par;
res = new_ident;
/* all done */
/* iteration */
if (last(new_par)) {
break;
}
param = bro(new_par);
prev = new_par;
} else {
/* iteration */
if (last(param)) {
break;
}
prev = param;
param = bro(param);
}
}
}
/* apply this transformation if the procedure has a structure-like
result and we want to make a new first parameter which is
a reference to where the result is to go. */
if (redo_structfns && !reg_result(result_shape)) {
/* replace f(x) by {var r; f(r, x); cont(r)} */
exp init, vardec, cont, contname, seq, app, appname, t;
exp_list list;
shape ptr_res_shape = f_pointer(f_alignment(result_shape));
init = getexp(result_shape, nilexp, 0, nilexp, nilexp, 0, 0,
clear_tag);
vardec = getexp(result_shape, nilexp, 0, init, nilexp, 0, 1,
ident_tag);
setvar(vardec);
contname = getexp(ptr_res_shape, nilexp, 0, vardec, nilexp, 0,
0, name_tag);
pt(vardec) = contname;
cont = f_contents(result_shape, contname);
appname = getexp(ptr_res_shape, bro(son(res)), 0, vardec,
contname, 0, 0, name_tag);
++no(vardec);
pt(vardec) = appname;
app = getexp(f_top, nilexp, 0, son(res), nilexp, 0, 32,
apply_tag);
if (last(son(res))) {
clearlast(son(res));
setlast(appname);
bro(appname) = app;
}
bro(son(res)) = appname;
t = son(app);
list.number = 1;
while (!last(t)) {
t = bro(t);
}
bro(t) = app;
list.start = app;
list.end = app;
seq = f_sequence(list, cont);
bro(init) = seq;
setfather(vardec, seq);
retcell(res);
return vardec;
}
return res;
}
exp
f_assign(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
return me_b3(f_top, arg1, arg2, ass_tag);
}
exp
f_assign_with_mode(transfer_mode md, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
if (md & f_complete) {
exp d = me_startid(f_top, arg2, 0);
return me_complete_id(d, f_assign_with_mode(md & ~f_complete,
arg1,
me_obtain(d)));
}
#ifdef no_trap_on_nil_contents
if ((md & f_trap_on_nil) != 0) {
exp d = me_startid(f_top, arg1, 0);
exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);
exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0,
labst_tag);
exp_list el;
exp test = me_q1(no_nat_option, f_equal, &lb, me_obtain(d),
f_make_null_ptr(al1_of(sh(arg1))), test_tag);
exp trp = getexp(f_bottom, nilexp, 0, nilexp, nilexp, 0,
f_nil_access, trap_tag);
md &= ~f_trap_on_nil;
el = new_exp_list(1);
el = add_exp_list(el, test, 1);
return me_complete_id(d, f_conditional(&lb, f_sequence(el, trp),
f_assign_with_mode(md,
me_obtain(d), arg2)));
}
#endif
if ((md & f_volatile) != 0) {
return me_b3(f_top, arg1, arg2, assvol_tag);
} else if ((md & f_overlap) &&
(name(arg2) == cont_tag || name(arg2) == contvol_tag) &&
!reg_result(sh(arg2))) {
return f_move_some(md, son(arg2), arg1,
f_shape_offset(sh(arg2)));
} else {
return me_b3(f_top, arg1, arg2, ass_tag);
}
}
exp
f_bitfield_assign(exp p, exp off, exp val)
{
exp res;
if (name(sh(p)) == bothd) {
return p;
}
if (name(sh(val)) == bothd) {
return val;
}
#if check_shape
if (name(sh(p)) != ptrhd || name(sh(off)) != offsethd) {
failer(CHSH_BFASS);
}
#endif
if (name(off) == val_tag) {
res = me_b3(f_top, p, val, bfass_tag);
no(res) = no(off);
return res;
} else {
int alofptr = al1(sh(p));
shape s = containedshape(alofptr, 0);
shape bfs = sh(val);
int nbits = shape_size(sh(val));
alignment als = f_alignment(s);
alignment alb = long_to_al(1);
shape os = f_offset(als, als);
shape bos = f_offset(alb, alb);
exp mask0 = getexp(s, nilexp, 0, nilexp, nilexp, 0,
((1 << nbits) -1), val_tag);
exp noff1 = getexp(sh(off), nilexp, 0, nilexp, nilexp, 0, 0,
name_tag);
exp noff2 = getexp(sh(off), nilexp, 0, nilexp, noff1, 0, 0,
name_tag);
exp idoff = getexp(f_top, nilexp, 0, off, noff2, 0, 2,
ident_tag);
son(noff1) = idoff; son(noff2) = idoff;
{
exp addbf = f_offset_add(noff1, f_shape_offset(bfs));
exp byteoffinit = f_offset_subtract(hold_check(
f_offset_pad(als, addbf)),
hold_check(f_offset_pad(als,
f_shape_offset(s))));
exp v1bit = getexp(bos, nilexp, 0, nilexp, nilexp, 0, 1,
val_tag);
exp nby1 = getexp(os, nilexp, 0, nilexp, nilexp, 0, 0,
name_tag);
exp nby2 = getexp(os, nilexp, 0, nilexp, nby1, 0, 0,
name_tag);
exp nby3 = getexp(os, nilexp, 0, nilexp, nby2, 0, 0,
name_tag);
exp idby = getexp(f_top, idoff, 1, byteoffinit, nby3, 0,
3, ident_tag);
exp bitoffinit = f_offset_div(ulongsh,
f_offset_subtract(noff2,
f_offset_pad(f_alignment(bfs), nby2)),
v1bit);
exp bnt1 = getexp(ulongsh, nilexp, 0, nilexp, nilexp, 0,
0, name_tag);
exp bnt2 = getexp(ulongsh, nilexp, 0, nilexp, bnt1, 0,
0, name_tag);
#if little_end
exp idbnt = getexp(f_top, idby, 1, bitoffinit, bnt2, 0,
2, ident_tag);
#else
exp v = getexp(ulongsh, nilexp, 0, nilexp, nilexp, 0,
shape_size(s) - nbits, val_tag);
exp idbnt = getexp(f_top, idby, 1, f_minus(f_wrap, v,
bitoffinit),
bnt2, 0, 2, ident_tag);
#endif
exp pn1 = getexp(sh(p), nilexp, 0, nilexp, nilexp, 0, 0,
name_tag);
exp pn2 = getexp(sh(p), nilexp, 0, nilexp, pn1, 0, 0,
name_tag);
exp idpn = getexp(f_top, idbnt, 1,
f_add_to_ptr(p, nby1), pn2, 0, 2,
ident_tag);
exp cnt; exp mask1; exp orit; exp asit;
son(nby1) = idby; son(nby2) = idby; son(nby3) = idby;
son(bnt1) = idbnt; son(bnt2) = idbnt;
son(pn1) = idpn; son(pn2) = idpn;
bro(son(idby)) = idbnt; clearlast(son(idby));
bro(son(idbnt)) = idpn; clearlast(son(idbnt));
bro(son(idoff)) = idby; clearlast(son(idoff));
mask1 = f_not(f_shift_left(f_wrap, mask0, bnt1));
cnt = f_and(f_contents(s, pn1), mask1);
orit = f_or(cnt, f_shift_left(f_wrap,
f_change_bitfield_to_int(s, val), bnt2));
asit = f_assign(pn2, orit);
bro(son(idpn)) = asit; clearlast(son(idpn));
bro(asit) = idpn; setlast(asit);
return idoff;
}
}
}
exp
f_bitfield_assign_with_mode(transfer_mode md, exp p, exp off, exp val)
{
exp res;
if (name(sh(p)) == bothd) {
return p;
}
if (name(sh(val)) == bothd) {
return val;
}
if (md == f_standard_transfer_mode) {
return f_bitfield_assign(p, off, val);
}
#if check_shape
if (name(sh(p)) != ptrhd || name(sh(off)) != offsethd ||
name(off) != val_tag) {
failer(CHSH_BFASS);
}
#endif
#ifdef no_trap_on_nil_contents
if ((md & f_trap_on_nil) != 0) {
exp d = me_startid(f_top, p, 0);
exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);
exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0,
labst_tag);
exp_list el;
exp test = me_q1(no_nat_option, f_equal, &lb, me_obtain(d),
f_make_null_ptr(al1_of(sh(p))), test_tag);
exp trp = getexp(f_bottom, nilexp, 0, nilexp, nilexp, 0,
f_nil_access, trap_tag);
md &= ~f_trap_on_nil;
el = new_exp_list(1);
el = add_exp_list(el, test, 1);
return me_complete_id(d, f_conditional(&lb, f_sequence(el, trp),
f_bitfield_assign_with_mode(md, me_obtain(d), off, val)));
}
#endif
if (md & f_volatile) {
res = me_b3(f_top, p, val, bfassvol_tag);
} else {
res = me_b3(f_top, p, val, bfass_tag);
}
no(res) = no(off);
return res;
}
exp
f_bitfield_contents(bitfield_variety bf, exp p, exp off)
{
exp res;
if (name(sh(p)) == bothd) {
return off;
}
if (name(sh(off)) == bothd) {
return p;
}
#if check_shape
if (name(sh(p)) != ptrhd || name(sh(off)) != offsethd)
failer(CHSH_BFCONT);
#endif
if (name(off) == val_tag) {
res = me_u3(f_bitfield(bf), p, bfcont_tag);
no(res) = no(off);
return res;
} else {
int alofptr = al1(sh(p));
shape s = containedshape(alofptr, bf.has_sign);
shape bfs = f_bitfield(bf);
alignment als = f_alignment(s);
alignment alb = long_to_al(1);
shape ob = f_offset(alb, alb);
shape os = f_offset(als, als);
exp noff1 = getexp(sh(off), nilexp, 0, nilexp, nilexp, 0, 0,
name_tag);
exp noff2 = getexp(sh(off), nilexp, 0, nilexp, noff1, 0, 0,
name_tag);
exp idoff = getexp(s, nilexp, 0, off, noff2, 0, 2, ident_tag);
son(noff1) = idoff; son(noff2) = idoff;
{
exp addbf = f_offset_add(noff1, f_shape_offset(bfs));
exp byteoffinit =
f_offset_subtract(hold_check(f_offset_pad(als,
addbf)), hold_check(f_offset_pad(als,
f_shape_offset(s))));
exp nby1 = getexp(os, nilexp, 0, nilexp, nilexp, 0, 0,
name_tag);
exp nby2 = getexp(os, nilexp, 0, nilexp, nby1, 0, 0,
name_tag);
exp idby = getexp(s, nilexp, 0, byteoffinit, nby2, 0, 2,
ident_tag);
exp cnt; exp sh1; exp sh2; exp bitoff; exp shl;
exp v = getexp(ulongsh, nilexp, 0, nilexp, nilexp, 0,
shape_size(s) - bf.bits, val_tag);
exp v1bit = getexp(ob, nilexp, 0, nilexp, nilexp, 0, 1,
val_tag);
son(nby1) = idby; son(nby2) = idby;
cnt = f_contents(s, f_add_to_ptr(p, nby1));
bitoff =
f_offset_div(ulongsh, f_offset_subtract(noff2,
f_offset_pad(f_alignment(bfs), nby2)), v1bit);
#if (little_end)
shl = f_minus(f_wrap, copy(v), bitoff);
#else
shl = bitoff;
#endif
sh1 = f_shift_left(f_wrap, cnt, shl);
sh2 = f_shift_right(sh1, v);
bro(byteoffinit) = sh2; clearlast(byteoffinit);
bro(sh2) = idby; setlast(sh2);
bro(off) = idby; clearlast(off);
bro(idby) = idoff; setlast(idby);
return (f_change_int_to_bitfield(bf, idoff));
}
}
}
exp
f_bitfield_contents_with_mode(transfer_mode md, bitfield_variety bf, exp p,
exp off)
{
exp res;
if (name(sh(p)) == bothd) {
return p;
}
#if check_shape
if (name(sh(p)) != ptrhd || name(sh(off)) != offsethd ||
name(off) != val_tag) {
failer(CHSH_BFCONT);
}
#endif
#ifdef no_trap_on_nil_contents
if ((md & f_trap_on_nil) != 0) {
exp d = me_startid(f_bitfield(bf), p, 0);
exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);
exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0,
labst_tag);
exp_list el;
exp test = me_q1(no_nat_option, f_equal, &lb, me_obtain(d),
f_make_null_ptr(al1_of(sh(p))), test_tag);
exp trp = getexp(f_bottom, nilexp, 0, nilexp, nilexp, 0,
f_nil_access, trap_tag);
md &= ~f_trap_on_nil;
el = new_exp_list(1);
el = add_exp_list(el, test, 1);
return me_complete_id(d, f_conditional(&lb, f_sequence(el, trp),
f_bitfield_contents_with_mode(md, bf, me_obtain(d), off)));
}
#endif
if (md == f_volatile) {
res = me_u3(f_bitfield(bf), p, bfcontvol_tag);
} else {
res = me_u3(f_bitfield(bf), p, bfcont_tag);
}
no(res) = no(off);
return res;
}
#if do_case_transforms
exp
f_case(bool exhaustive, exp control, caselim_list branches)
{
exp r, ht;
shape case_shape;
exp changer;
exp body_of_ident;
exp control_expression;
exp body_of_case;
exp id;
exp copy_ce;
shape changer_shape = (shape_size(sh(control)) >= SLONG_SZ) ?
sh(control) : is_signed(sh(control)) ? slongsh : ulongsh;
/* UNUSED(branches);
*/
if (name(sh(control)) == bothd) {
return control;
}
bro(global_case) = nilexp;
while (branches != nilexp) {
exp hd = branches;
branches = bro(branches);
bro(hd) = nilexp;
sh(hd) = sh(control);
if (son(hd) != nilexp) {
sh(son(hd)) = sh(control);
}
if (son(hd) != nilexp &&
docmp_f((int)f_less_than, son(hd), hd)) {
--no(son(pt(hd)));
retcell(son(hd));
retcell(hd);
} else {
case_item(hd);
}
}
if (bro(global_case) == nilexp) {
return control;
}
case_shape = (exhaustive)? f_bottom : f_top;
if (PIC_code) {
proc_externs = 1;
}
#if check_shape
if (!is_integer(sh(control))) {
failer(CHSH_CASE);
}
#endif
r = getexp(case_shape, nilexp, 0, control, nilexp, 0, 0, case_tag);
clearlast(control);
bro(control) = bro(global_case);
ht = control;
while (bro(ht) != nilexp) {
ht = bro(ht);
sh(ht) = changer_shape;
if (son(ht) != nilexp) {
sh(son(ht)) = changer_shape;
}
}
setlast(ht);
bro(ht) = r;
control_expression = son(r);
body_of_case = bro(son(r));
copy_ce = copy(control_expression);
changer = hold_check(me_u3(changer_shape, control_expression,
chvar_tag));
id = me_startid(sh(changer), changer, 1);
/* the shape of the ident will be overwritten by me_complete_id */
body_of_ident = case_optimisation(body_of_case, id, sh(r), copy_ce);
id = me_complete_id(id, body_of_ident);
#ifdef NEWDIAGS
if (extra_diags) {
id = f_dg_exp(id, f_branch_dg(f_dg_null_sourcepos));
}
#endif
return (hold_check(id));
}
#else /* do_case_transforms */
exp
f_case(bool exhaustive, exp control, caselim_list branches)
{
exp r, ht;
shape case_shape;
/* UNUSED(branches);
if (name(sh(control)) == bothd || bro(global_case) == nilexp)
return control;
*/
if (name(sh(control)) == bothd) {
return control;
}
bro(global_case) = nilexp;
while (branches != nilexp) {
exp hd = branches;
branches = bro(branches);
bro(hd) = nilexp;
sh(hd) = sh(control);
if (son(hd) != nilexp) {
sh(son(hd)) = sh(control);
}
if (son(hd) != nilexp &&
docmp_f((int)f_less_than, son(hd), hd)) {
--no(son(pt(hd)));
retcell(son(hd));
retcell(hd);
} else {
case_item(hd);
}
}
if (bro(global_case) == nilexp) {
return control;
}
case_shape = (exhaustive) ? f_bottom : f_top;
if (PIC_code) {
proc_externs = 1;
}
#if check_shape
if (!is_integer(sh(control))) {
failer(CHSH_CASE);
}
#endif
r = getexp(case_shape, nilexp, 0, control, nilexp, 0, 0, case_tag);
clearlast(control);
bro(control) = bro(global_case);
ht = control;
while (bro(ht) != nilexp) {
ht = bro(ht);
sh(ht) = sh(control);
if (son(ht) != nilexp) {
sh(son(ht)) = sh(control);
}
}
setlast(ht);
bro(ht) = r;
#ifdef NEWDIAGS
if (extra_diags) {
r = f_dg_exp(r, f_branch_dg(f_dg_null_sourcepos));
}
#endif
return (r);
}
#endif /* do_case_transforms */
exp
f_change_bitfield_to_int(variety x, exp arg1)
{
if (name(sh(arg1)) == bothd) {
return arg1;
}
#if check_shape
if (name(sh(arg1)) != bitfhd) {
failer(CHSH_CHBITFIELD);
}
#endif
#if !has64bits
if (shape_size(x) >32) {
shape n32 = (is_signed(x)) ? slongsh : ulongsh;
exp z = hold_check(me_c2(n32, arg1, bitf_to_int_tag));
return f_change_variety(f_impossible, x, z);
}
#endif
return me_c2(f_integer(x), arg1, bitf_to_int_tag);
}
exp
f_change_int_to_bitfield(bitfield_variety x, exp arg1)
{
if (name(sh(arg1)) == bothd) {
return arg1;
}
#if check_shape
if (!is_integer(sh(arg1))) {
failer(CHSH_CHINTBF);
}
#endif
#if !has64bits
if (shape_size(sh(arg1)) >32) {
shape n32 = (is_signed(sh(arg1))) ? slongsh : ulongsh;
arg1 = hold_check(f_change_variety(f_wrap, n32, arg1));
}
#endif
return me_c2(f_bitfield(x), arg1, int_to_bitf_tag);
}
exp
f_change_variety(error_treatment ov_err, variety r, exp arg1)
{
if (name(sh(arg1)) == bothd) {
return arg1;
}
#if check_shape
if (!is_integer(sh(arg1))) {
failer(CHSH_CHVAR);
}
#endif
#if !has64bits
if ((name(arg1) != val_tag || ov_err.err_code > 2) &&
(shape_size(sh(arg1)) > 32 || name(r) >=s64hd) &&
name(sh(arg1)) != name(r)) {
exp e = arg1;
int ss = is_signed(sh(arg1));
int sd = is_signed(r);
shape x = (ss)?slongsh:ulongsh;
if (shape_size(sh(arg1)) <= 32) {
exp e = hold_check(me_c1(x, ov_err, arg1, chvar_tag));
exp z = TDFcallaux(ov_err, e, (sd) ? ((ss) ?
"__TDFUsswiden" : "__TDFUuswiden") : (ss) ?
"__TDFUsuwiden" : "__TDFUuuwiden", r);
return z;
} else if (name(r) >= s64hd) {
return TDFcallaux(ov_err, e, (sd) ? "__TDFUu642s64" :
"__TDFUs642u64", r);
} else {
exp e = TDFcallaux(ov_err, arg1, (sd) ?
((ss) ? "__TDFUssshorten" : "__TDFUusshorten") :
(ss) ? "__TDFUsushorten" : "__TDFUuushorten",
(sd) ? slongsh : ulongsh);
return hold_check(me_c1(f_integer(r), ov_err, e,
chvar_tag));
}
}
#endif
return me_c1(f_integer(r), ov_err, arg1, chvar_tag);
}
exp
f_component(shape sha, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!doing_aldefs &&
(name(sh(arg2)) != offsethd || name(sh(arg1)) != cpdhd ||
shape_align(sh(arg1)) < al1(sh(arg2)) ||
shape_align(sha) > al2(sh(arg2)))) {
failer(CHSH_COMPONENT);
}
#endif
return me_b3(sha, arg1, arg2, component_tag);
}
exp
f_concat_nof(exp arg1, exp arg2)
{
shape sha = getshape(0, const_al1, al2_of(sh(arg1)), align_of(sh(arg1)),
shape_size(sh(arg1)) + shape_size(sh(arg2)),
nofhd);
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
/* al2_of(sh(arg1)) is the shapemacs.h hd of the nof shape */
#if check_shape
if (!doing_aldefs && (shape_align(sh(arg1)) != shape_align(sh(arg2)))) {
failer(CHSH_CONCATNOF);
}
#endif
return me_b3(sha, arg1, arg2, concatnof_tag);
}
exp
f_conditional(label alt_label_intro, exp first, exp alt)
{
shape res_shape;
exp r, labst, def;
labst = get_lab(alt_label_intro);
res_shape = lub_shape(sh(first), sh(alt));
r = getexp(res_shape, nilexp, 0, first, nilexp, 0, 0, cond_tag);
def = son(labst);
setbro(first, labst);
clearlast(first);
setbro(def, alt);
clearlast(def);
setbro(alt, labst);
setlast(alt);
setsh(labst, sh(alt));
setfather(r, labst);
default_freq = (float)(2.0 * default_freq);
return r;
}
void
start_conditional(label alt_label_intro)
{
exp tg;
exp labst;
tg = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, clear_tag);
labst = getexp(f_bottom, nilexp, 0, tg, nilexp, 0, 0, labst_tag);
default_freq = (float)(default_freq / 2.0);
fno(labst) = default_freq;
++proc_label_count;
set_lab(alt_label_intro, labst);
return;
}
exp
f_contents(shape s, exp arg1)
{
if (name(sh(arg1)) == bothd) {
return arg1;
}
#if check_shape
if (!doing_aldefs &&
(name(sh(arg1)) != ptrhd ||
(al1(sh(arg1)) < shape_align(s)
#if issparc
&& align_of(s) != REAL_ALIGN
#endif
))) {
failer(CHSH_CONTENTS);
}
#endif
return me_c2(s, arg1, cont_tag);
}
exp
f_contents_with_mode(transfer_mode md, shape s, exp arg1)
{
if (name(sh(arg1)) == bothd) {
return arg1;
}
#if check_shape
if (!doing_aldefs &&
(name(sh(arg1)) != ptrhd ||
(al1(sh(arg1)) < shape_align(s) &&
al1_of(sh(arg1))->al.sh_hd != doublehd))) {
failer(CHSH_CONTENTS_VOL);
}
#endif
#ifdef no_trap_on_nil_contents
if ((md & f_trap_on_nil) != 0) {
exp d = me_startid(s, arg1, 0);
exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);
exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0,
labst_tag);
exp_list el;
exp test = me_q1(no_nat_option, f_equal, &lb, me_obtain(d),
f_make_null_ptr(f_alignment(s)), test_tag);
exp trp = getexp(f_bottom, nilexp, 0, nilexp, nilexp, 0,
f_nil_access, trap_tag);
md &= ~f_trap_on_nil;
el = new_exp_list(1);
el = add_exp_list(el, test, 1);
return me_complete_id(d, f_conditional(&lb, f_sequence(el, trp),
f_contents_with_mode(md, s, me_obtain(d))));
}
#endif
if (md & f_volatile) {
return me_c2(s, arg1, contvol_tag);
} else {
return me_c2(s, arg1, cont_tag);
}
}
exp
f_current_env(void)
{
if (!in_proc_def) {
failer("current_env must be in proc definition");
}
uses_crt_env = 1;
uses_loc_address = 1;
return getexp(f_pointer(frame_alignment), nilexp, 0, nilexp, nilexp, 0,
0, current_env_tag);
}
int
eq_et(error_treatment a, error_treatment b)
{
return (a.err_code == b.err_code &&
(a.err_code != 4 || a.jmp_dest == b.jmp_dest));
}
exp
div_rem(error_treatment div0_err, error_treatment ov_err, exp arg1, exp arg2,
exp(*f)(error_treatment, exp, exp))
{
if (eq_et(div0_err, ov_err) || eq_et(ov_err, f_impossible)) {
return f(div0_err, arg1, arg2);
} else if (eq_et(div0_err, f_impossible)) {
return f(ov_err, arg1, arg2);
} else {
exp da2 = me_startid(sh(arg1), arg2, 0);
exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);
exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0,
labst_tag);
exp tst = f_integer_test(no_nat_option, f_equal, &lb,
me_obtain(da2), me_shint(sh(arg2), 0));
exp_list st;
exp wrong;
st = new_exp_list(1);
st = add_exp_list(st, tst, 0);
if (div0_err.err_code == 4) {
wrong = f_goto(div0_err.jmp_dest);
} else if (div0_err.err_code > 4) {
wrong = getexp(f_bottom, nilexp, 0, nilexp, nilexp, 0,
f_overflow, trap_tag);
} else {
wrong = me_shint(sh(arg1), 0);
}
return me_complete_id(da2, f_conditional(&lb, f_sequence(st,
wrong), f(ov_err, arg1, me_obtain(da2))));
}
}
exp
div0_aux(error_treatment ov_err, exp arg1, exp arg2)
{
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag ||
ov_err.err_code > 2)) {
return TDFcallop2(ov_err, arg1, arg2, div0_tag);
}
#endif
#if div0_implemented
return me_b1(ov_err, arg1, arg2, div0_tag);
#else
if (name(arg2) == val_tag && !isbigval(arg2)) {
int n = no(arg2);
if ((n & (n - 1)) == 0) {
return me_b1(ov_err, arg1, arg2, div1_tag);
}
}
return me_b1(ov_err, arg1, arg2, div2_tag);
#endif
}
exp
f_div0(error_treatment div0_err, error_treatment ov_err, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_DIV0);
}
#endif
return div_rem(div0_err, ov_err, arg1, arg2, div0_aux);
}
exp
div1_aux(error_treatment ov_err, exp arg1, exp arg2)
{
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag ||
ov_err.err_code > 2)) {
return TDFcallop2(ov_err, arg1, arg2, div1_tag);
}
#endif
return me_b1(ov_err, arg1, arg2, div1_tag);
}
exp
f_div1(error_treatment div0_err, error_treatment ov_err, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_DIV1);
}
#endif
return div_rem(div0_err, ov_err, arg1, arg2, div1_aux);
}
exp
div2_aux(error_treatment ov_err, exp arg1, exp arg2)
{
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag ||
ov_err.err_code > 2)) {
return TDFcallop2(ov_err, arg1, arg2, div2_tag);
}
#endif
return me_b1(ov_err, arg1, arg2, div2_tag);
}
exp
f_div2(error_treatment div0_err, error_treatment ov_err, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_DIV2);
}
#endif
return div_rem(div0_err, ov_err, arg1, arg2, div2_aux);
}
exp
f_env_offset(alignment fa, alignment y, tag t)
{
exp e = get_tag(t);
shape s = f_offset(fa, y);
exp res;
if (e == nilexp) {
e = getexp(f_bottom, nilexp, 0, nilexp, nilexp, 0, 0,
ident_tag);
son(e) = e; /* used to indicate that tag is not yet defined!?*/
set_tag(t, e);
}
res = getexp(s, nilexp, 0, e, nilexp, 0, 0, env_offset_tag);
setvis(e);
setenvoff(e);
return res;
}
exp
f_fail_installer(string message)
{
char *m = (char *)xcalloc(message.number + 1, sizeof(char));
int i;
for (i=0; i<message.number; ++i) {
m[i] = message.ints.chars[i];
}
m[message.number] = 0;
failer(m);
exit(EXIT_FAILURE);
return (nilexp);
}
exp
f_goto(label dest)
{
exp lab = get_lab(dest);
exp r = getexp(f_bottom, nilexp, 0, nilexp, lab, 0, 0, goto_tag);
++no(son(lab));
return r;
}
exp
f_goto_local_lv(exp arg1)
{
if (name(sh(arg1)) == bothd) {
return arg1;
}
#if check_shape
if (name(sh(arg1)) != ptrhd) {
failer(CHSH_GOLOCALLV);
}
#endif
return me_u3(f_bottom, arg1, goto_lv_tag);
}
exp
f_identify(access_option acc, tag name_intro, exp definition, exp body)
{
exp i = get_tag(name_intro);
exp d = son(i);
UNUSED(acc);
if (name(sh(definition)) == bothd) {
kill_exp(body, body);
return definition;
}
setsh(i, sh(body));
setbro(d, body);
clearlast(d);
setfather(i, body);
return i;
}
void
start_identify(access_option acc, tag name_intro, exp definition)
{
exp i = get_tag(name_intro);
if (i == nilexp || son(i) != i) {
i = getexp(f_bottom, nilexp, 0, definition, nilexp, 0, 0,
ident_tag);
} else {
/* could have been already used in env_offset */
son(i) = definition;
}
clearvar(i);
if ((acc & (f_visible | f_long_jump_access)) != 0) {
setvis(i);
}
set_tag(name_intro, i);
return;
}
exp
f_ignorable(exp arg1)
{
if (name(sh(arg1)) == bothd) {
return arg1;
}
return me_u2(arg1, ignorable_tag);
}
exp
f_integer_test(nat_option prob, ntest nt, label dest, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!is_integer(sh(arg1)) || !eq_shape(sh(arg1), sh(arg2))) {
failer(CHSH_INTTEST);
}
#endif
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag)) {
error_treatment ov_err;
ov_err = f_wrap;
arg1 = TDFcallop2(ov_err, arg1, arg2, test_tag);
arg2 = getexp(slongsh, nilexp, 0, nilexp, nilexp, 0, 0,
val_tag);
}
#endif
if (nt == f_comparable || nt == f_not_comparable) {
return replace_ntest(nt, dest, arg1, arg2);
} else {
return me_q1(prob, convert_ntest[nt], dest, arg1, arg2,
test_tag);
}
}
exp
f_labelled(label_list placelabs_intro, exp starter, exp_list places)
{
exp f = places.start;
exp b;
int i;
clear_exp_list(places);
for (i = 0; i < places.number; ++i) {
exp labst = get_lab(placelabs_intro.elems[i]);
b = bro(f);
setbro(son(labst), f);
setbro(f, labst);
setlast(f);
setsh(labst, sh(f));
if (name(starter) == case_tag ||
(name(starter) == seq_tag &&
name(son(son(starter))) == case_tag)) {
fno(labst) = (float)(1.0 / places.number);
} else {
fno(labst) = (float)5.0;
}
f = b;
}
return (clean_labelled(starter, placelabs_intro));
}
void
start_labelled(label_list placelabs_intro)
{
UNUSED(placelabs_intro);
if (crt_repeat != nilexp) {
++no(crt_repeat);
}
repeat_list = getexp(f_top, crt_repeat, 0, nilexp, repeat_list, 0, 0,
0);
crt_repeat = repeat_list;
return;
}
exp
f_last_local(exp x)
{
UNUSED(x);
return getexp(f_pointer(f_alloca_alignment), nilexp, 0, nilexp, nilexp,
0, 0, last_local_tag);
}
exp
f_local_alloc(exp arg1)
{
alignment a;
if (name(sh(arg1)) == bothd) {
return arg1;
}
#if check_shape
if (name(sh(arg1)) != offsethd) {
failer(CHSH_LOCALLOC);
}
#endif
if (al2(sh(arg1)) < 8) {
arg1 = hold_check(f_offset_pad(f_alignment(ucharsh), arg1));
}
a = long_to_al(al1(sh(arg1)));
has_alloca = 1;
return me_u3(f_pointer(a), arg1, alloca_tag);
}
exp
f_local_alloc_check(exp arg1)
{
exp res = f_local_alloc(arg1);
if (name(res) ==alloca_tag) {
set_checkalloc(res);
}
return res;
}
exp
f_local_free(exp a, exp p)
{
if (name(sh(a)) == bothd) {
kill_exp(p, p);
return a;
}
if (name(sh(p)) == bothd) {
kill_exp(a, a);
return p;
}
#if check_shape
if (name(sh(a)) != offsethd || name(sh(p)) != ptrhd) {
failer(CHSH_LOCFREE);
}
#endif
if (al2(sh(a)) <8) {
a = hold_check(f_offset_pad(f_alignment(ucharsh), a));
}
return me_b3(f_top, p, a, local_free_tag);
}
exp
f_local_free_all(void)
{
has_setjmp = 1; /* this really means dont inline
and use a stack frame */
return getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0,
local_free_all_tag);
}
exp
f_long_jump(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (name(sh(arg1)) != ptrhd || name(sh(arg2)) != ptrhd) {
failer(CHSH_LONGJUMP);
}
#endif
has_setjmp = 1; /* this really means dont inline
and use a stack frame */
return me_b3(f_bottom, arg1, arg2, long_jump_tag);
}
static int
comp_compare(CONST void *a, CONST void *b)
{
return no(*((exp *)a)) - no(*((exp *)b));
}
exp
f_make_compound(exp arg1, exp_list arg2)
{
exp first = arg2.start;
exp r = getexp(f_compound(arg1), nilexp, 0, first, nilexp, 0, 0,
compound_tag);
clear_exp_list(arg2);
if (arg2.number == 0) {
setname(r, clear_tag);
return r;
}
#if check_shape
{
exp t = first;
while (1) {
if (t != arg2.end && name(sh(bro(t))) == bothd) {
return bro(t);
}
if (t == arg2.end || name(sh(t)) != offsethd ||
(!doing_aldefs &&
al2(sh(t)) < shape_align(sh(bro(t))))) {
failer(CHSH_MAKECPD);
}
if (bro(t) == arg2.end) {
break;
}
t = bro(bro(t));
}
}
#endif
setfather(r, arg2.end);
if (!doing_aldefs && arg2.number > 2) {
exp *arr = (exp *)xcalloc(arg2.number, sizeof(exp));
int i;
exp t = son(r);
for (i = 0; i < arg2.number; ++i) {
if (!(i & 1) && (no(t) + shape_size(sh(bro(t))) >
shape_size(sh(r)))) {
failer("make_compound size exceeded");
}
arr[i] = t;
t = bro(t);
}
#ifdef promote_pars
for (i = 0; i < arg2.number; i += 2) {
alignment a = al2_of(sh(arr[i]));
if (a->al.sh_hd != 0) {
shape s = sh(arr[i + 1]);
if (name(s) >= scharhd && name(s) <= uwordhd) {
shape ns = (is_signed(s)) ? slongsh :
ulongsh;
exp w = hold_check(f_change_variety(
f_wrap, ns, arr[i + 1]));
arr[i+1] = w;
}
}
}
#endif
qsort(arr, (size_t)(arg2.number / 2), (size_t)(2 * sizeof(exp)),
comp_compare);
son(r) = arr[0];
for (i = 1; i < arg2.number; ++i) {
bro(arr[i - 1]) = arr[i];
clearlast(arr[i - 1]);
}
bro(arr[arg2.number - 1]) = r;
setlast(arr[arg2.number - 1]);
xfree((void *)arr);
}
return r;
}
exp
f_make_int(variety v, signed_nat value)
{
int n;
if (!snat_issmall(value) ||
(n = snatint(value), shape_size(v) > 32 &&
(n & (int)0x80000000) != 0)) {
flpt b;
exp res;
if (shape_size(v) <= 32) {
if (!extra_checks) {
flt64 temp;
int ov;
temp = flt_to_f64(
value.signed_nat_val.big_s_nat, 0, &ov);
n = temp.small;
res = getexp(f_integer(v), nilexp, 0, nilexp,
nilexp, 0, n, val_tag);
return res;
} else {
failer(BIG_32);
exit(EXIT_FAILURE);
}
}
if (snat_issmall(value)) {
flt64 temp;
temp.big = 0;
temp.small = (unsigned int)n;
b = f64_to_flt(temp, 0);
} else {
/* copy required since exp may be killed & value may be
token res */
b = new_flpt();
flt_copy(flptnos[value.signed_nat_val.big_s_nat],
&flptnos[b]);
}
if (snatneg(value)) {
flptnos[b].sign = -1;
}
if (flptnos[b].exp > 3) {
failer(BIG_32);
exit(EXIT_FAILURE);
}
res = getexp(f_integer(v), nilexp, 0, nilexp, nilexp, 0, b,
val_tag);
setbigval(res);
return res;
} else {
if (snatneg(value)) {
n = -n;
}
return getexp(f_integer(v), nilexp, 0, nilexp, nilexp, 0, n,
val_tag);
}
}
exp
f_make_local_lv(label lab)
{
exp l = get_lab(lab);
exp res = getexp(f_local_label_value, nilexp, 0, nilexp, l, 0, 0,
make_lv_tag);
++no(son(l));
set_loaded_lv(l);
has_lv = 1;
return res;
}
exp
f_make_nof(exp_list arg1)
{
exp first = arg1.start;
nat t;
exp r;
clear_exp_list(arg1);
nat_issmall(t) = 1;
natint(t) = arg1.number;
if (arg1.number == 0) {
return getexp(f_nof(t, f_top), nilexp, 0, nilexp, nilexp, 0, 0,
nof_tag);
}
r = getexp(f_nof(t, sh(first)), nilexp, 0, first, nilexp, 0, 0,
nof_tag);
#if check_shape
{
exp temp = first;
while (1) {
if (!eq_shape(sh(temp), sh(first))) {
failer(CHSH_MAKENOF);
}
if (temp == arg1.end) {
break;
}
temp = bro(temp);
}
}
#endif
if (name(sh(first)) == bitfhd) {
/* make make_nof bitbields into make-compound */
int sf = shape_size(sh(first));
int snof = shape_size(sh(r));
exp *a = &arg1.start;
int scs = (((sf - 1) &sf) == 0) ? sf : snof;
shape cs = containedshape(scs, 1);
int i;
shape cpds = f_compound(hold_check(f_offset_pad(f_alignment(cs),
f_shape_offset(sh(r)))));
exp soff = getexp(f_offset(f_alignment(cpds),
f_alignment(sh(first))),
nilexp, 0, nilexp, nilexp, 0, 0, val_tag);
for (i = 0; i < arg1.number; i++) {
bro(soff) = *a;
*a = copyexp(soff);
a = &bro(bro(*a));
no(soff) += sf;
}
arg1.number *= 2;
return f_make_compound(hold_check(f_shape_offset(cpds)), arg1);
}
setfather(r, arg1.end);
return r;
}
exp
f_make_nof_int(variety v, string s)
{
shape sha;
exp res;
nat t;
int i;
shape elem_sh = f_integer(v);
int elem_sz = shape_size(elem_sh);
if (PIC_code) {
proc_externs = 1;
}
nat_issmall(t) = 1;
natint(t) = s.number;
sha = f_nof(t, elem_sh);
res = getexp(sha, nilexp, 0, nilexp, nilexp, (prop)elem_sz, 0,
string_tag);
if (elem_sz == 64) {
int *ss = (int *)xcalloc(s.number, sizeof(int));
for (i = 0; i < s.number; ++i) {
flt64 x;
flpt f;
int ov;
int sg = is_signed(elem_sh);
x.big = 0;
switch (s.size) {
case 8:
x.small = (unsigned int)s.ints.chars[i];
break;
case 16:
x.small = (unsigned int)s.ints.shorts[i];
break;
case 32:
x.small = (unsigned int)s.ints.longs[i];
break;
default:
f = (flpt)s.ints.longs[i];
x = flt_to_f64(f, 0, &ov);
flpt_ret(f);
if (s.size < 64 && sg) {
x.big = (x.big << (64 - s.size)) >>
(64 - s.size);
}
}
ss[i] = f64_to_flt(x, sg);
}
nostr(res) = (char *)(void *)ss;
return res;
}
switch (s.size) {
case 8:
switch (elem_sz) {
case 8:
nostr(res) = (char *)s.ints.chars;
return res;
case 16: {
short *ss = (short *)xcalloc(s.number, sizeof(short));
for (i = 0; i < s.number; ++i) {
ss[i] = (short)(unsigned char)s.ints.chars[i];
}
nostr(res) = (char *)(void *)ss;
return res;
}
case 32: {
int *ss = (int *)xcalloc(s.number, sizeof(int));
for (i = 0; i < s.number; ++i) {
ss[i] = (int)(unsigned char)s.ints.chars[i];
}
nostr(res) = (char *)(void *)ss;
return res;
}
}
case 16:
switch (elem_sz) {
case 8: {
char *ss = (char *)xcalloc(s.number, sizeof(char));
for (i = 0; i < s.number; ++i) {
ss[i] = (char)(unsigned short)s.ints.shorts[i];
}
nostr(res) = (char *)(void *)ss;
return res;
}
case 16:
nostr(res) = (char *)(void *)s.ints.shorts;
return res;
case 32: {
int *ss = (int *)xcalloc(s.number, sizeof(int));
for (i = 0; i < s.number; ++i) {
ss[i] = (int)(unsigned short)s.ints.shorts[i];
}
nostr(res) = (char *)(void *)ss;
return res;
}
}
case 32:
switch (elem_sz) {
case 8: {
char *ss = (char *)xcalloc(s.number, sizeof(char));
for (i = 0; i < s.number; ++i) {
ss[i] = (char)(unsigned long)s.ints.longs[i];
}
nostr(res) = (char *)(void *)ss;
return res;
}
case 16: {
short *ss = (short *)xcalloc(s.number, sizeof(short));
for (i = 0; i < s.number; ++i) {
ss[i] = (short)(unsigned long)s.ints.longs[i];
}
nostr(res) = (char *)(void *)ss;
return res;
}
case 32:
nostr(res) = (char *)(void *)s.ints.longs;
return res;
}
}
return res;
}
exp
f_make_null_local_lv(void)
{
return me_null(f_local_label_value, lv_null, null_tag);
}
exp
f_make_null_proc(void)
{
return me_null(f_proc, proc_null, null_tag);
}
exp
f_make_null_ptr(alignment a)
{
return me_null(f_pointer(a), ptr_null, null_tag);
}
exp
f_maximum(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_MAX);
}
#endif
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag)) {
return TDFcallop3(arg1, arg2, max_tag);
}
#endif
return me_b2(arg1, arg2, max_tag);
}
exp
f_minimum(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_MIN);
}
#endif
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag)) {
error_treatment ov_err;
ov_err = f_wrap;
return TDFcallop2(ov_err, arg1, arg2, min_tag);
}
#endif
return me_b2(arg1, arg2, min_tag);
}
static int in_initial_value;
static void
push_proc_props(void)
{
proc_props *temp = (proc_props *)xcalloc(1, sizeof(proc_props));
temp->proc_struct_result = proc_struct_result;
temp->has_alloca = has_alloca;
temp->proc_is_recursive = proc_is_recursive;
temp->uses_crt_env = uses_crt_env;
temp->has_setjmp = has_setjmp;
temp->uses_loc_address = uses_loc_address;
temp->proc_label_count = proc_label_count;
temp->proc_struct_res = proc_struct_res;
temp->default_freq = default_freq;
temp->proc_externs = proc_externs;
temp->in_proc_def = in_proc_def;
temp->pushed = old_proc_props;
temp->rep_make_proc = rep_make_proc;
temp->frame_alignment = frame_alignment;
temp->in_initial_value = in_initial_value;
old_proc_props = temp;
return;
}
static void
pop_proc_props(void)
{
proc_props *temp = old_proc_props;
proc_struct_result = temp->proc_struct_result;
has_alloca = temp->has_alloca;
proc_is_recursive =temp->proc_is_recursive;
uses_crt_env = temp->uses_crt_env;
has_setjmp = temp->has_setjmp;
uses_loc_address = temp->uses_loc_address;
proc_label_count = temp->proc_label_count;
proc_struct_res = temp->proc_struct_res;
default_freq = temp->default_freq;
proc_externs = temp->proc_externs;
in_proc_def = temp->in_proc_def;
old_proc_props = temp->pushed;
rep_make_proc = temp->rep_make_proc;
frame_alignment = temp->frame_alignment;
in_initial_value = temp->in_initial_value;
if (temp != &initial_value_pp) {
xfree((void *)temp);
}
return;
}
void
start_make_proc(shape result_shape, tagshacc_list params_intro,
tagacc_option vartag)
{
/* initialise global flags which are used at the end of the
reading process in f_make_proc */
UNUSED(result_shape); UNUSED(params_intro);
push_proc_props();
proc_struct_result = nilexp;
has_alloca = 0;
proc_is_recursive = 0;
uses_crt_env = 0;
has_setjmp = 0;
uses_loc_address = 0;
proc_label_count = 0;
proc_struct_res = 0;
default_freq = 1.0;
proc_externs = 0;
in_initial_value = 0;
frame_alignment = f_unite_alignments(f_locals_alignment,
var_callers_alignment);
if (vartag.present) {
shape sha = getshape(0, const_al1, const_al1, VAR_PARAM_ALIGN,
0, cpdhd);
exp d = getexp(sha, nilexp, 0, nilexp, nilexp, 0, 0, clear_tag);
exp i = getexp(f_bottom, nilexp, 1, d, nilexp, 0, 0, ident_tag);
setvis(i);
setvar(i);
setparam(i);
set_tag(vartag.val.tg, i);
}
/* set this flag to distinguish values created during procedure
reading. */
in_proc_def = 1;
return;
}
exp
f_make_proc(shape result_shape, tagshacc_list params_intro,
tagacc_option vartag, exp body)
{
exp res;
int varhack = 0;
#if ishppa
exp t, id, ptr;
#endif
#if check_shape
if (name(sh(body)) != bothd) {
failer(CHSH_MAKE_PROC);
}
#endif
if (vartag.present) {
exp i = get_tag(vartag.val.tg);
if (params_intro.id == nilexp) {
params_intro.id = i;
} else {
bro(params_intro.last_def) = i;
}
bro(i) = params_intro.last_id;
params_intro.last_def = son(i);
params_intro.last_id = i;
setvis(i);
++params_intro.number;
varhack = 1;
}
res = getexp(f_proc, nilexp, 0, params_intro.id, result_shape, 0, 0,
proc_tag);
if (params_intro.number == 0) {
son(res) = body;
setlast(body);
bro(body) = res;
} else {
bro(son(res)) = res;
bro(params_intro.last_def) = body;
setlast(body);
bro(body) = params_intro.last_id;
#ifdef promote_pars
promote_formals(son(res));
#endif
}
/* set the properties of the procedure construction from the
global values accumulated during reading.
WE OUGHT TO POP THE OLD VALUES.
*/
if (has_alloca) {
set_proc_has_alloca(res);
}
if (proc_is_recursive) {
setrecursive(res);
}
if (has_lv) {
set_proc_has_lv(res);
}
if (uses_crt_env) {
set_proc_uses_crt_env(res);
}
if (has_setjmp) {
set_proc_has_setjmp(res);
}
if (uses_loc_address) {
set_loc_address(res);
}
if (proc_struct_res) {
set_struct_res(res);
}
if (proc_externs) {
set_proc_uses_external(res);
}
/* apply check_id to the parameters */
if (params_intro.number != 0) {
exp param;
for (param = params_intro.last_id; param != res;
param = bro(param)) {
if (redo_structparams &&
#if ishppa
(varhack || ((shape_size(sh(son(param))) >64) &&
(name(sh(son(param))) == cpdhd ||
name(sh(son(param))) == nofhd ||
name(sh(son(param))) == doublehd))))
#else
#if issparc
(varhack || sparccpd(sh(son(param)))))
#else
(varhack || name(sh(son(param))) == cpdhd ||
name(sh(son(param))) == nofhd ||
name(sh(son(param))) == doublehd))
#endif
#endif
{
/*
* Param IS struct/union-by-value. Incoming
* acutal parameter will have been changed to
* be ptr-to expected value (see
* f_apply_proc()), so adjust usage in body.
*/
exp use; /* use of ident in pt() chain */
exp prev; /* previous use in pt() chain */
exp eo = nilexp;
shape ptr_s =
f_pointer(f_alignment(sh(son(param))));
#if ishppa
/* modify parameter itself */
if (!varhack) {
exp obtain_param;
exp assign;
shape sha=sh(son(param));
t=me_obtain(param);
if (uses_crt_env) {
eo = f_env_offset(
frame_alignment,
f_parameter_alignment(
ptr_s), brog(param));
obtain_param =
f_add_to_ptr(
f_current_env(), eo);
}
id = me_startid(f_top,
me_u3(sha, t, cont_tag),
1);
ptr = me_startid(f_top, me_obtain(id),
0);
if (uses_crt_env) {
assign =
f_assign(obtain_param,
me_obtain(id));
body = f_sequence(add_exp_list(
new_exp_list(1), assign,
0), body);
}
clearlast(son(ptr));
bro(son(ptr)) = body;
setlast(body);
bro(body) = ptr;
sh(ptr) = sh(body);
body = id;
clearlast(son(id));
bro(son(id)) = ptr;
setlast(ptr);
bro(ptr) = id;
sh(id) = sh(ptr);
bro(params_intro.last_def) = body;
setlast(body);
bro(body) = param;
}
#endif
/* visit each use of the parameter modifying
appropriately*/
for (prev = param, use = pt(prev);
use != nilexp;
prev = use, use = pt(prev)) {
if (!uses_crt_env ||
(uses_crt_env && use != eo)) {
if (!isvar(param)) {
/* add cont */
exp new_use =
getexp(ptr_s, use,
(bool)1,
son(use),
pt(use),
props(use),
0, name_tag);
son(use) = new_use;
pt(prev) = new_use;
pt(use) = nilexp;
props(use) = (prop)0;
setname(use, cont_tag);
/* retain same no and
sh */
use = new_use;
}
if (no(use) > 0) {
/* add reff */
exp new_use =
getexp(ptr_s, use,
(bool)1,
son(use),
pt(use),
props(use),
0, name_tag);
son(use) = new_use;
pt(prev) = new_use;
pt(use) = nilexp;
props(use) = (prop)0;
setname(use, reff_tag);
/* retain same no and
sh */
use = new_use;
}
}
} /* for */
#if ishppa
if (!varhack) {
/* Change all but ptr's references to
param to references to ptr */
for (use = pt(param); use != nilexp;
use = pt(use)) {
if ((son(use) ==param) &&
(use != son(son(id))) &&
(!uses_crt_env ||
(uses_crt_env &&
use != eo))) {
son(use) =ptr;
}
}
pt(ptr) =pt(param);
}
#endif
/* modify parameter itself */
if (isenvoff(param)) {
props(param) = (prop)0;
setvis(param);
} else {
props(param) = (prop)0;
}
setparam(param);
setcaonly(param);
if (varhack) {
setvis(param);
}
setsh(son(param), ptr_s);
} /* if redo... */
varhack = 0;
/* apply check_id to the parameters */
IGNORE check_id(param, param);
} /* for */
}
if (proc_struct_result != nilexp) {
bro(son(proc_struct_result)) = son(res);
setfather(proc_struct_result, son(res));
son(res) = proc_struct_result;
setfather(res, proc_struct_result);
}
/* clear this flag to distinguish values created during procedure
reading. */
in_proc_def = 0;
pop_proc_props();
if (old_proc_props != (proc_props *)0 || rep_make_proc) {
dec *extra_dec = make_extra_dec(make_local_name(), 0, 0, res,
f_proc);
exp e = extra_dec->dec_u.dec_val.dec_exp;
res = getexp(f_proc, nilexp, 0, e, nilexp, 0, 0, name_tag);
pt(e) = res;
no(e) = 1;
}
return res;
}
procprops crt_procprops;
void
start_make_general_proc(shape result_shape, procprops prcprops,
tagshacc_list caller_intro, tagshacc_list callee_intro)
{
/* initialise global flags which are used at the end of the
reading process in f_make_proc */
push_proc_props();
proc_struct_result = nilexp;
has_alloca = 0;
proc_is_recursive = 0;
uses_crt_env = 0;
has_setjmp = 0;
uses_loc_address = 0;
proc_label_count = 0;
proc_struct_res = 0;
default_freq = 1.0;
frame_alignment = f_unite_alignments(f_locals_alignment,
f_callers_alignment((prcprops &
f_var_callers) != 0));
frame_alignment = f_unite_alignments(frame_alignment,
f_callees_alignment((prcprops &
f_var_callees) != 0));
proc_externs = 0;
/* set this flag to distinguish values created during procedure
reading. */
in_proc_def = 1;
crt_procprops = prcprops;
return;
}
exp
f_make_general_proc(shape result_shape, procprops prcprops,
tagshacc_list caller_intro, tagshacc_list callee_intro,
exp body)
{
exp res;
#if check_shape
if (name(sh(body)) != bothd) {
failer(CHSH_MAKE_PROC);
}
#endif
res = getexp(f_proc, nilexp, 0, caller_intro.id, result_shape, 0, 0,
general_proc_tag);
if (caller_intro.number == 0 && callee_intro.number == 0) {
son(res) = body;
setlast(body);
bro(body) = res;
} else if (callee_intro.number == 0) {
bro(son(res)) = res;
bro(caller_intro.last_def) = body;
setlast(body);
bro(body) = caller_intro.last_id;
} else {
int i;
exp z = callee_intro.id;
for (i = 0; i < callee_intro.number; i++) {
set_callee(z);
z = bro(son(z));
}
if (caller_intro.number != 0) {
bro(caller_intro.last_def) = callee_intro.id;
bro(callee_intro.id) = caller_intro.last_id; /*???*/
} else {
son(res) = callee_intro.id;
}
bro(son(res)) = res;
bro(callee_intro.last_def) = body;
setlast(body);
bro(body) = callee_intro.last_id;
}
#ifdef promote_pars
promote_formals(son(res));
#endif
/* set the properties of the procedure construction from the
global values accumulated during reading.
WE OUGHT TO POP THE OLD VALUES.
*/
if (has_alloca) {
set_proc_has_alloca(res);
}
if (proc_is_recursive) {
setrecursive(res);
}
if (has_lv) {
set_proc_has_lv(res);
}
if (uses_crt_env) {
set_proc_uses_crt_env(res);
}
if (has_setjmp) {
set_proc_has_setjmp(res);
}
if (uses_loc_address) {
set_loc_address(res);
}
if (proc_struct_res) {
set_struct_res(res);
}
if (proc_externs) {
set_proc_uses_external(res);
}
if (caller_intro.number != 0) {
bool varhack = 0;
exp param;
for (param = caller_intro.last_id; param != res;
param = bro(param)) {
if (redo_structparams && !varhack &&
#if ishppa
shape_size(sh(son(param))) > 64)
#else
(name(sh(son(param))) == cpdhd ||
name(sh(son(param))) == nofhd ||
#if issparc
sparccpd(sh(son(param))) ||
#endif
name(sh(son(param))) == doublehd))
#endif
{
/*
* Param IS struct/union-by-value. Incoming
* acutal parameter will have been changed to
* be ptr-to expected value (see
* f_apply_proc()), so adjust usage in body.
*/
exp use; /* use of ident in pt() chain */
exp prev; /* previous use in pt() chain */
shape ptr_s =
f_pointer(f_alignment(sh(son(param))));
int mustbevis;
/* visit each use of the parameter modifying
appropriately*/
for (prev = param, use = pt(prev);
use != nilexp;
prev = use, use = pt(prev)) {
if (!isvar(param)) {
/* add cont */
exp new_use =
getexp(ptr_s, use, (bool)1,
son(use), pt(use),
props(use), 0,
name_tag);
son(use) = new_use;
pt(prev) = new_use;
pt(use) = nilexp;
props(use) = (prop)0;
/* retain same no and sh */
setname(use, cont_tag);
use = new_use;
}
if (no(use) > 0) { /* add reff */
exp new_use =
getexp(ptr_s, use, (bool)1,
son(use), pt(use),
props(use), 0,
name_tag);
son(use) = new_use;
pt(prev) = new_use;
pt(use) = nilexp;
props(use) = (prop)0;
/* retain same no and sh */
setname(use, reff_tag);
use = new_use;
}
} /* for */
/* modify parameter itself */
mustbevis = isenvoff(param);
if (isoutpar(param)) {
props(param) = (prop)0;
setoutpar(param);
} else {
props(param) = (prop)0;
}
if (mustbevis) {
setvis(param);
}
setparam(param);
setcaonly(param);
setsh(son(param), ptr_s);
} /* if redo... */
varhack = 0;
/* apply check_id to the caller parameters */
IGNORE check_id(param, param);
} /* for */
}
if (callee_intro.number != 0) {
exp param= callee_intro.last_id;
int i;
for (i=callee_intro.number; i != 0;
param = father(param), i--) {
/* apply check_id to the callee parameters */
IGNORE check_id(param, param);
} /* for */
}
if (redo_structfns && !reg_result(result_shape)) {
if (proc_struct_result==nilexp) {
exp init = getexp(f_pointer(f_alignment(result_shape)),
nilexp, 0, nilexp, nilexp, 0, 0,
clear_tag);
exp iddec = getexp(sh(son(res)), nilexp, 0, init,
nilexp, 0, 0, ident_tag);
setparam(iddec);
proc_struct_result = iddec;
}
bro(son(proc_struct_result)) = son(res);
setfather(proc_struct_result, son(res));
son(res) = proc_struct_result;
setfather(res, proc_struct_result);
}
/* clear this flag to distinguish values created during procedure
reading. */
in_proc_def = 0;
set_make_procprops(res, prcprops);
pop_proc_props();
if (old_proc_props != (proc_props *)0 || rep_make_proc) {
dec *extra_dec = make_extra_dec(make_local_name(), 0, 0, res,
f_proc);
exp e = extra_dec->dec_u.dec_val.dec_exp;
res = getexp(f_proc, nilexp, 0, e, nilexp, 0, 0, name_tag);
pt(e) = res;
no(e) = 1;
}
return res;
}
exp
find_caller_id(int n, exp p)
{
while (name(p) == ident_tag) {
if (name(son(p)) == caller_name_tag && no(son(p)) ==n) {
return p;
}
p = bro(son(p));
}
return nilexp;
}
void
start_apply_general_proc(shape result_shape, procprops_option prcprops, exp p,
otagexp_list caller_params_intro,
callees callee_params)
{
return;
}
exp
f_apply_general_proc(shape result_shape, procprops prcprops, exp p,
otagexp_list caller_pars, callees callee_pars,
exp postlude)
{
exp res = getexp(result_shape, nilexp, 0, p, nilexp, 0, 0,
apply_general_tag);
exp r_p;
exp redos = nilexp;
exp last_redo;
has_alloca = 1;
if (name(callee_pars) == same_callees_tag) {
/* it's a constant */
callee_pars = copy(callee_pars);
}
if (redo_structparams) {
int i;
exp *plce = &caller_pars.start;
for (i = 0; i < caller_pars.number; i++) {
exp ote = *plce;
exp param = (name(ote) == caller_tag) ? son(ote) : ote;
if ((name(sh(param)) == cpdhd ||
name(sh(param)) == nofhd ||
name(sh(param)) == doublehd)
#if issparc
|| sparccpd(sh(param))
#endif
#if ishppa
&& shape_size(sh(param)) >64
#endif
) {
/* make copy of par and use ptr as par */
shape nshape =
f_pointer(f_alignment(sh(param)));
exp rd = me_startid(nshape, param, 1);
exp npar = me_obtain(rd);
exp id;
if (name(ote) ==caller_tag &&
(id = find_caller_id(i, caller_pars.id)) !=
nilexp) {
exp p = pt(id);
son(ote) = npar;
bro(npar) = ote;
setlast(npar);
sh(son(id)) = sh(npar);
while(p != nilexp) {
/* replaces uses in postlude */
exp bp = bro(p);
int l = last(p);
exp np = pt(p);
exp *pos = refto(father(p), p);
exp c;
sh(p) = nshape;
c = f_contents(sh(ote), p);
if (l) {
setlast(c);
} else {
clearlast(c);
}
bro(c) = bp;
*pos = c;
p = np;
}
sh(ote) = nshape;
plce = &bro(ote);
} else {
if (last(ote)) {
setlast(npar);
}
bro(npar) = bro(ote);
if (ote == caller_pars.end) {
caller_pars.end = npar;
}
*plce = npar;
plce = &bro(npar);
}
bro(son(rd)) = redos;
clearlast(son(rd));
if (redos != nilexp) {
bro(redos) = rd;
setlast(redos);
} else {
last_redo = rd;
}
redos = rd;
} else {
plce = &bro(ote);}
}
}
if (caller_pars.id != nilexp) {
exp a = caller_pars.id;
while (bro(son(a)) != nilexp) {
a = bro(son(a));
}
bro(son(a)) = postlude;
setfather(a, postlude);
postlude = caller_pars.id;
}
setfather(res, postlude);
bro(callee_pars) = postlude;
clearlast(callee_pars);
props(callee_pars) = prcprops;
r_p = getexp(f_top, callee_pars, 0, caller_pars.start, nilexp, prcprops,
caller_pars.number, 0);
if (caller_pars.number != 0) {
setfather(r_p, caller_pars.end);
}
bro(p) = r_p; clearlast(p);
#ifdef promote_pars
{ int i;
exp ote = caller_pars.start;
for (i = 0; i < caller_pars.number; i++) {
shape s = sh(ote);
if (name(s) >= scharhd && name(s) <= uwordhd) {
shape ns = (is_signed(s)) ? slongsh : ulongsh;
exp par = (name(ote) == caller_tag) ?
son(ote) : ote;
exp next = bro(ote);
exp id;
int l = last(ote);
exp w = hold_check(f_change_variety(f_wrap, ns,
copy(par)));
if (name(ote) == caller_tag) {
sh(ote) = ns;
}
replace(par, w, nilexp);
kill_exp(par, nilexp);
if (name(ote) == caller_tag &&
(id = find_caller_id(i, postlude)) !=
nilexp) {
exp p = pt(id);
sh(son(id)) = ns;
while(p != nilexp) {
/* replaces uses in postlude */
exp nextp = pt(p);
sh(p) = ns;
w = f_change_variety(f_wrap, s,
copy(p));
replace(p, w, nilexp);
kill_exp(p, nilexp);
p = nextp;
}
}
if (l) {
break;
}
ote = next;
} else ote = bro(ote);
}
}
#endif
if (redo_structfns && !reg_result(result_shape))
{
/* replace f(x) by {var r; f(r, x); cont(r)} */
exp init, vardec, cont, contname, seq, app, appname, tmp;
exp_list list;
shape ptr_res_shape = f_pointer(f_alignment(result_shape));
init = getexp(result_shape, nilexp, 0, nilexp, nilexp, 0, 0,
clear_tag);
vardec = getexp(result_shape, nilexp, 0, init, nilexp, 0, 1,
ident_tag);
setvar(vardec);
contname = getexp(ptr_res_shape, nilexp, 0, vardec, nilexp, 0,
0, name_tag);
pt(vardec) = contname;
cont = f_contents(result_shape, contname);
appname = getexp(ptr_res_shape, son(r_p), 0, vardec, contname,
0, 0, name_tag);
if (no(r_p)++ == 0) {
setfather(r_p, appname);
}
++no(vardec);
pt(vardec) = appname;
app = getexp(f_top, nilexp, 0, son(res), nilexp, 0, 32,
apply_general_tag);
son(r_p) = appname;
tmp = postlude;
while (name(tmp) ==ident_tag &&
name(son(tmp)) == caller_name_tag) {
no(son(tmp))++;
tmp = bro(son(tmp));
}
bro(postlude) = app;
list.number = 1;
list.start = app;
list.end = app;
seq = f_sequence(list, cont);
bro(init) = seq;
setfather(vardec, seq);
retcell(res);
res = vardec;
}
if (redos != nilexp) {
/* put in decs given by redo_structparams */
bro(son(last_redo)) = res;
clearlast(son(last_redo));
bro(res) = last_redo;
setlast(res);
res = redos;
}
return res;
}
exp
f_tail_call(procprops prcprops, exp p, callees callee_params)
{
exp res = getexp(f_bottom, nilexp, 0, p, nilexp, 0, 0, tail_call_tag);
exp e_p;
if (name(callee_params) == same_callees_tag) {
/* it's a constant */
callee_params = copy(callee_params);
}
e_p = getexp(f_top, res, 1, callee_params, nilexp, prcprops, 0, 0);
has_setjmp = 1; /* stop inlining! */
has_alloca = 1; /* make sure has fp */
props(callee_params) = prcprops;
bro(p) = callee_params;
clearlast(p);
setfather(res, callee_params);
return res;
}
exp
f_untidy_return(exp arg)
{
exp res = getexp(f_bottom, nilexp, 0, arg, nilexp, 0, 0,
untidy_return_tag);
setfather(res, arg);
has_setjmp = 1;
return res;
}
alignment
f_parameter_align(alignment a)
{
return (f_var_param_alignment);
}
exp
f_set_stack_limit(exp flim)
{
return me_u3(f_top, flim, set_stack_limit_tag);
}
exp
f_give_stack_limit(alignment frame_al)
{
exp res = getexp(f_pointer(frame_al), nilexp, 0, nilexp, nilexp, 0, 0,
give_stack_limit_tag);
return res;
}
exp
f_make_stack_limit(exp stack_base, exp frame_size, exp alloca_size)
{
exp sz;
frame_size = hold_check(f_offset_pad(al1_of(sh(alloca_size)),
frame_size));
alloca_size = hold_check(f_offset_pad(f_alignment(ucharsh),
alloca_size));
sz = hold_check(f_offset_add(frame_size, alloca_size));
return me_b2(stack_base, sz, make_stack_limit_tag);
}
exp
f_env_size(tag proctag)
{
exp res = getexp(f_offset(f_locals_alignment, f_locals_alignment),
nilexp, 0, f_obtain_tag(proctag), nilexp, 0, 0,
env_size_tag);
bro(son(res)) = res;
setlast(son(res));
return res;
}
nat
f_error_val(error_code ec)
{
nat res;
nat_issmall(res) =1;
natint(res) = ec;
return res;
}
exp
f_make_top(void)
{
return getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, top_tag);
}
exp
f_make_value(shape s)
{
return me_l1(s, clear_tag);
}
exp
f_minus(error_treatment ov_err, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_MINUS);
}
#endif
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag ||
ov_err.err_code > 2)) {
return TDFcallop2(ov_err, arg1, arg2, minus_tag);
}
#endif
return me_b1(ov_err, arg1, arg2, minus_tag);
}
exp
f_move_some(transfer_mode md, exp arg1, exp arg2, exp arg3)
{
exp r = getexp(f_top, nilexp, 0, arg1, nilexp, 0, 0, movecont_tag);
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
kill_exp(arg3, arg3);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
kill_exp(arg3, arg3);
return arg2;
}
if (name(sh(arg3)) == bothd) {
kill_exp(arg1, arg1);
kill_exp(arg2, arg2);
return arg3;
}
#if check_shape
if (name(sh(arg1)) != ptrhd || name(sh(arg2)) != ptrhd ||
name(sh(arg3)) != offsethd || al1(sh(arg1)) < al1(sh(arg3)) ||
al1(sh(arg2)) < al1(sh(arg3))) {
failer(CHSH_MOVESOME);
}
#endif
#ifdef no_trap_on_nil_contents
if ((md & f_trap_on_nil) != 0) {
exp d2 = me_startid(f_top, arg2, 0);
exp d1 = me_startid(f_top, arg1, 0);
exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);
exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0,
labst_tag);
exp_list el;
exp test2 = me_q1(no_nat_option, f_not_equal, &lb,
me_obtain(d2),
f_make_null_ptr(al1_of(sh(arg2))), test_tag);
exp test1 = me_q1(no_nat_option, f_not_equal, &lb,
me_obtain(d1), f_make_null_ptr(al1_of(
sh(arg1))), test_tag);
exp trp = getexp(f_bottom, nilexp, 0, nilexp, nilexp, 0,
f_nil_access, trap_tag);
md &= ~f_trap_on_nil;
el = new_exp_list(2);
el = add_exp_list(el, test1, 1);
el = add_exp_list(el, test2, 2);
return me_complete_id(d2, me_complete_id(d1, f_conditional(&lb,
f_sequence(el, f_move_some(md, me_obtain(d1), me_obtain(d2),
arg3)), trp)));
}
#endif
if (!(md & f_overlap) && name(arg3) == val_tag && al2(sh(arg3)) > 1) {
exp c = f_contents(f_compound(arg3), arg1);
return f_assign(arg2, c);
}
if (al2(sh(arg3)) < 8) {
arg3 = hold_check(f_offset_pad(f_alignment(ucharsh), arg3));
}
if (!(md & f_overlap)) {
setnooverlap(r);
}
clearlast(arg1);
setbro(arg1, arg2);
clearlast(arg2);
setbro(arg2, arg3);
setfather(r, arg3);
return r;
}
exp
f_mult(error_treatment ov_err, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_MULT);
}
#endif
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag ||
ov_err.err_code > 2)) {
return TDFcallop2(ov_err, arg1, arg2, mult_tag);
}
#endif
return me_b1(ov_err, arg1, arg2, mult_tag);
}
exp
f_n_copies(nat n, exp arg1)
{
exp r;
if (name(sh(arg1)) == bothd) {
return arg1;
}
#if !has64bits
if (!nat_issmall(n)) {
failer(TOO_BIG_A_VECTOR);
}
#endif
r = getexp(f_nof(n, sh(arg1)), nilexp, 0, arg1, nilexp, 0, natint(n),
ncopies_tag);
if (name(sh(arg1)) == bitfhd) {
/* make ncopies bitfields into (ncopies) make-compound */
int sf = shape_size(sh(arg1));
int snof = shape_size(sh(r));
int scs = (((sf - 1) &sf) ==0) ? sf : snof;
shape cs = containedshape(scs, 1);
exp_list a;
shape cpds = f_compound(hold_check(f_offset_pad(f_alignment(cs),
f_shape_offset(sh(r)))));
exp soff = getexp(f_offset(f_alignment(cpds),
f_alignment(sh(arg1))), nilexp, 0,
nilexp, nilexp, 0, 0, val_tag);
exp cexp;
a.start = copyexp(soff);
a.end = a.start;
a.number = 2;
bro(a.end) = copyexp(arg1);
a.end = bro(a.end);
for (no(soff) = sf; no(soff) <= shape_size(cs) -sf;
no(soff) +=sf) {
bro(a.end) = copyexp(soff);
clearlast(a.end);
a.end = bro(a.end);
bro(a.end) = copyexp(arg1);
a.end = bro(a.end);
a.number += 2;
}
setlast(a.end);
bro(a.end) = nilexp;
cexp = f_make_compound(hold_check(f_shape_offset(cs)), a);
if (shape_size(cs) >= shape_size(cpds)) {
return cexp;
} else {
natint(n) = shape_size(cpds) / shape_size(cs);
return f_n_copies(n, cexp);
}
}
setfather(r, arg1);
return r;
}
exp
f_negate(error_treatment ov_err, exp arg1)
{
if (name(sh(arg1)) == bothd) {
return arg1;
}
#if check_shape
if (!is_integer(sh(arg1))) {
failer(CHSH_NEGATE);
}
#endif
if (!is_signed(sh(arg1)) && ov_err.err_code > 2) {
return f_minus(ov_err, me_shint(sh(arg1), 0), arg1);
}
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag|| ov_err.err_code > 2)) {
return TDFcallop1(ov_err, arg1, neg_tag);
}
#endif
return me_u1(ov_err, arg1, neg_tag);
}
exp
f_not(exp arg1)
{
if (name(sh(arg1)) == bothd) {
return arg1;
}
#if check_shape
if (!is_integer(sh(arg1))) {
failer(CHSH_NOT);
}
#endif
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
name(arg1) != val_tag) {
return TDFcallop4(arg1, not_tag);
}
#endif
return me_u2(arg1, not_tag);
}
exp
f_obtain_tag(tag t)
{
shape s;
exp r;
exp tg = get_tag(t);
if (tg == nilexp) {
failer(UNDEF_TAG);
}
if (isglob(tg)) {
s = sh(t->dec_u.dec_val.dec_exp);
#ifdef NEWDIAGS
if (!within_diags) {
proc_externs = 1;
}
#else
proc_externs = 1;
#endif
} else {
s = sh(son(tg));
}
if (isvar(tg)) {
if (isparam(tg)) {
s = f_pointer(f_parameter_alignment(s));
} else {
s = f_pointer(f_alignment(s));
}
}
r = getexp(s, nilexp, 0, tg, pt(tg), 0, 0, name_tag);
pt(tg) = r;
no(tg) = no(tg) +1;
return (r);
}
exp
f_offset_add(exp arg1, exp arg2)
{
shape sres;
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!doing_aldefs &&
((name(sh(arg1)) != offsethd || name(sh(arg2)) != offsethd ||
(al1(sh(arg2)) > al2(sh(arg1))
#if issparc
&& al1_of(sh(arg2)) != REAL_ALIGN
#endif
)))) {
failer(CHSH_OFFSETADD);
}
#endif
sres = f_offset(al1_of(sh(arg1)), al2_of(sh(arg2)));
#if 0
if ((al1_of(sh(arg1))->al.al_val.al_frame & 4) != 0 &&
al2_of(sh(arg2))->al.sh_hd != 0) {
exp ne;
if (al2_of(sh(arg2))->al.sh_hd > nofhd) {
shape ps = f_pointer(f_alignment(sh(arg1)));
ne = hold_check(f_offset_pad(f_alignment(ps),
f_shape_offset(ps)));
} else {
ne = arg2;
}
arg2 = hold_check(me_u2(ne, offset_negate_tag));
}
#endif
return me_b3(sres, arg1, arg2, offset_add_tag);
}
exp
f_offset_div(variety v, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (name(sh(arg1)) != offsethd || name(sh(arg2)) != offsethd) {
failer(CHSH_OFFSETDIV);
}
#endif
return me_b3(f_integer(v), arg1, arg2, offset_div_tag);
}
exp
f_offset_div_by_int(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!doing_aldefs &&
(name(sh(arg1)) != offsethd || !is_integer(sh(arg2)) ||
(al1(sh(arg1)) != al2(sh(arg1)) && al2(sh(arg1)) != 1))) {
failer(CHSH_OFFSETDIVINT);
}
#endif
return me_b3(sh(arg1), arg1, arg2, offset_div_by_int_tag);
}
exp
f_offset_max(exp arg1, exp arg2)
{
alignment a1 = al1_of(sh(arg1));
alignment a2 = al1_of(sh(arg2));
alignment a3 = al2_of(sh(arg1));
shape sha;
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!doing_aldefs &&
(name(sh(arg1)) != offsethd || name(sh(arg2)) != offsethd)) {
failer(CHSH_OFFSETMAX);
}
#endif
if (a1->al.al_n != 1 || a2->al.al_n != 1) {
alignment ares = (alignment)calloc(1, sizeof(aldef));
if (!doing_aldefs) {
failer(CHSH_OFFSETMAX);
}
ares->al.al_n = 2;
ares->al.al_val.al_join.a = a1;
ares->al.al_val.al_join.b = a2;
ares->next_aldef = top_aldef;
top_aldef = ares;
sha = f_offset(ares, a3);
} else {
sha = f_offset(long_to_al(max(a1->al.al_val.al,
a2->al.al_val.al)), a3);
}
return me_b3(sha, arg1, arg2, offset_max_tag);
}
exp
f_offset_mult(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!doing_aldefs &&
(name(sh(arg1)) != offsethd || !is_integer(sh(arg2)))) {
failer(CHSH_OFFSETMULT);
}
#endif
if (shape_size(sh(arg2)) != PTR_SZ) {
if (PTR_SZ == 32) {
arg2 = hold_check(f_change_variety(f_impossible,
slongsh, arg2));
} else {
arg2 = hold_check(f_change_variety(f_impossible,
s64sh, arg2));
}
}
return me_b3(sh(arg1), arg2, arg1, offset_mult_tag);
/* the order of arguments is being interchanged */
}
exp
f_offset_negate(exp arg1)
{
if (name(sh(arg1)) == bothd) {
return arg1;
}
#if check_shape
if (!doing_aldefs &&
(name(sh(arg1)) != offsethd ||
(al1(sh(arg1)) != al2(sh(arg1)) && al2(sh(arg1)) != 1
#if issparc
&& al1_of(sh(arg1)) != REAL_ALIGN
#endif
))) {
failer(CHSH_OFFSETNEG);
}
#endif
return me_u2(arg1, offset_negate_tag);
}
exp
f_offset_pad(alignment a, exp arg1)
{
shape sha;
if (name(sh(arg1)) == bothd) {
return arg1;
}
#if check_shape
if (name(sh(arg1)) != offsethd) {
failer(CHSH_OFFSETPAD);
}
#endif
if (a->al.al_n != 1 || al1_of(sh(arg1))->al.al_n != 1) {
alignment ares = (alignment)calloc(1, sizeof(aldef));
if (!doing_aldefs) {
failer(ILL_OFFSETPAD);
}
ares->al.al_n = 2;
ares->al.al_val.al_join.a = a;
ares->al.al_val.al_join.b = al1_of(sh(arg1));
ares->next_aldef = top_aldef;
top_aldef = ares;
sha = f_offset(ares, a);
} else if (al1_of(sh(arg1))->al.al_val.al_frame != 0) {
sha = f_offset(al1_of(sh(arg1)), a);
} else {
sha = f_offset(long_to_al(max(a->al.al_val.al, al1(sh(arg1)))),
a);
}
return (me_u3(sha, arg1, offset_pad_tag));
}
exp
f_offset_subtract(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
return me_b3(f_offset(al2_of(sh(arg2)), al2_of(sh(arg1))), arg1, arg2,
offset_subtract_tag);
}
exp
f_offset_test(nat_option prob, ntest nt, label dest, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!doing_aldefs &&
(name(sh(arg1)) != offsethd || name(sh(arg2)) != offsethd ||
/* al1(sh(arg1)) != al1(sh(arg2)) || */
al2(sh(arg1)) != al2(sh(arg2)))) {
failer(CHSH_OFFSETTEST);
}
#endif
if (nt == f_comparable || nt == f_not_comparable) {
return replace_ntest(nt, dest, arg1, arg2);
} else {
return me_q1(prob, convert_ntest[nt], dest, arg1, arg2,
test_tag);
}
}
exp
f_offset_zero(alignment a)
{
return getexp(f_offset(a, a), nilexp, 0, nilexp, nilexp, 0, 0, val_tag);
}
exp
f_or(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_OR);
}
#endif
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag)) {
return TDFcallop3(arg1, arg2, or_tag);
}
#endif
return me_b2(arg1, arg2, or_tag);
}
exp
f_plus(error_treatment ov_err, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_PLUS);
}
#endif
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag||
ov_err.err_code > 2)) {
return TDFcallop2(ov_err, arg1, arg2, plus_tag);
}
#endif
return me_b1(ov_err, arg1, arg2, plus_tag);
}
exp
f_pointer_test(nat_option prob, ntest nt, label dest, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!doing_aldefs &&
(name(sh(arg1)) != ptrhd || al1(sh(arg1)) != al1(sh(arg2)))) {
failer(CHSH_PTRTEST);
}
#endif
if (nt == f_comparable || nt == f_not_comparable) {
return replace_ntest(nt, dest, arg1, arg2);
} else {
return me_q1(prob, convert_ntest[nt], dest, arg1, arg2,
test_tag);
}
}
exp
f_proc_test(nat_option prob, ntest nt, label dest, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
/*
ONLY REMOVED TEMPORARILY!
if (name(sh(arg1)) != prokhd || name(sh(arg2)) != prokhd)
failer(CHSH_PROCTEST);
*/
#endif
if (nt == f_comparable || nt == f_not_comparable) {
return replace_ntest(nt, dest, arg1, arg2);
} else {
return me_q1(prob, convert_ntest[nt], dest, arg1, arg2,
test_tag);
}
}
exp
f_profile(nat n)
{
return getexp(f_top, nilexp, 0, nilexp, nilexp, 0, natint(n), prof_tag);
}
exp
rem1_aux(error_treatment ov_err, exp arg1, exp arg2)
{
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag ||
ov_err.err_code > 2)) {
return TDFcallop2(ov_err, arg1, arg2, mod_tag);
}
#endif
return me_b1(ov_err, arg1, arg2, mod_tag);
}
exp
f_rem1(error_treatment div0_err, error_treatment ov_err, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_REM1);
}
#endif
return div_rem(div0_err, ov_err, arg1, arg2, rem1_aux);
}
exp
rem0_aux(error_treatment ov_err, exp arg1, exp arg2)
{
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag ||
ov_err.err_code > 2)) {
return TDFcallop2(ov_err, arg1, arg2, rem0_tag);
}
#endif
#if div0_implemented
return me_b1(ov_err, arg1, arg2, rem0_tag);
#else
if (name(arg2) == val_tag && !isbigval(arg2)) {
int n = no(arg2);
if ((n & (n - 1)) == 0) {
return me_b1(ov_err, arg1, arg2, mod_tag);
}
}
return me_b1(ov_err, arg1, arg2, rem2_tag);
#endif
}
exp
f_rem0(error_treatment div0_err, error_treatment ov_err, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_REM0);
}
#endif
return div_rem(div0_err, ov_err, arg1, arg2, rem0_aux);
}
exp
rem2_aux(error_treatment ov_err, exp arg1, exp arg2)
{
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag ||
ov_err.err_code > 2)) {
return TDFcallop2(ov_err, arg1, arg2, rem2_tag);
}
#endif
return me_b1(ov_err, arg1, arg2, rem2_tag);
}
exp
f_rem2(error_treatment div0_err, error_treatment ov_err, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_REM2);
}
#endif
return div_rem(div0_err, ov_err, arg1, arg2, rem2_aux);
}
static int silly_count = 0; /* for pathological numbers of repeats*/
exp
f_repeat(label repeat_label_intro, exp start, exp body)
{
exp r = getexp(sh(body), nilexp, 0, start, crt_repeat, 0, 0, rep_tag);
exp labst = get_lab(repeat_label_intro);
bro(start) = labst;
clearlast(start);
setbro(son(labst), body);
clearlast(son(labst));
setbro(body, labst);
setlast(body);
setsh(labst, sh(body));
son(crt_repeat) = r;
crt_repeat = bro(crt_repeat);
setfather(r, labst);
if (silly_count == 0) {
default_freq = (float)(default_freq / 20.0);
} else {
silly_count--;
}
return r;
}
void
start_repeat(label repeat_label_intro)
{
exp labst;
exp def;
def = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, clear_tag);
/* enter this repeat on crt_repeat and repeat_list - see
documentation */
if (crt_repeat != nilexp) {
++no(crt_repeat);
}
repeat_list = getexp(f_top, crt_repeat, 0, nilexp, repeat_list, 1, 0,
0);
crt_repeat = repeat_list;
labst = getexp(f_bottom, nilexp, 0, def, nilexp, 0, 0, labst_tag);
if (default_freq < (float)10e10) {
default_freq = (float)(20.0 * default_freq);
} else {
silly_count++;
}
fno(labst) = default_freq;
++proc_label_count;
set_lab(repeat_label_intro, labst);
return;
}
exp
f_return(exp arg1)
{
if (name(sh(arg1)) == bothd) {
return arg1;
}
if (!reg_result(sh(arg1))) {
proc_struct_res = 1;
}
/* transformation if we are giving procedures which deliver a struct
result an extra pointer parameter */
if (redo_structfns && !reg_result(sh(arg1))) {
exp ret, obt;
exp assname, ass;
shape ptr_res_shape;
exp_list list;
if (proc_struct_result == nilexp) {
exp init = getexp(f_pointer(f_alignment(sh(arg1))),
nilexp, 0, nilexp, nilexp, 0, 0,
clear_tag);
exp iddec = getexp(sh(arg1), nilexp, 0, init, nilexp,
0, 0, ident_tag);
setparam(iddec);
proc_struct_result = iddec;
}
ptr_res_shape = f_pointer(f_alignment(sh(arg1)));
obt = getexp(ptr_res_shape, nilexp, 0, proc_struct_result,
pt(proc_struct_result), 0, 0, name_tag);
++no(proc_struct_result);
pt(proc_struct_result) = obt;
ret = me_u3(f_bottom, obt, res_tag);
assname = getexp(ptr_res_shape, nilexp, 0, proc_struct_result,
pt(proc_struct_result), 0, 0, name_tag);
++no(proc_struct_result);
pt(proc_struct_result) = assname;
ass = hold_check(f_assign(assname, arg1));
list.number = 1;
list.start = ass;
list.end = ass;
return f_sequence(list, ret);
}
return me_u3(f_bottom, arg1, res_tag);
}
exp
f_rotate_left(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!is_integer(sh(arg1)) || !is_integer(sh(arg2))) {
failer(CHSH_ROTL);
}
#endif
#if !has_rotate
{
shape sa = sh(arg1);
int sz = shape_size(sa);
shape usa = (sz == 8) ? ucharsh : (sz == 16) ?
uwordsh : (sz==32)?ulongsh:u64sh;
exp d1 = me_startid(sa, hold_check(f_change_variety(f_wrap,
usa, arg1)),
0);
exp d2 = me_startid(sa, arg2, 0);
exp d3 = me_startid(sa, hold_check(f_shift_left(f_impossible,
me_obtain(d1),
me_obtain(d2))),
0);
exp d4 = me_startid(sa, hold_check(f_minus(f_impossible,
me_shint(sh(arg2),
sz),
me_obtain(d2))), 0);
exp sr = hold_check(f_shift_right(me_obtain(d1),
me_obtain(d4)));
exp orit = hold_check(f_or(sr, me_obtain(d3)));
exp corit = hold_check(f_change_variety(f_wrap, sa, orit));
return hold_check(me_complete_id(d1,
hold_check(me_complete_id(d2,
hold_check(me_complete_id(d3,
hold_check(me_complete_id(d4,
corit))))))));
}
#endif
return me_b2(arg1, arg2, rotl_tag);
}
exp
f_rotate_right(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!is_integer(sh(arg1)) || !is_integer(sh(arg2))) {
failer(CHSH_ROTR);
}
#endif
#if !has_rotate
return f_rotate_left(arg1, hold_check(f_minus(f_impossible,
me_shint(sh(arg2),
shape_size(sh(arg1))),
arg2)));
#endif
return me_b2(arg1, arg2, rotr_tag);
}
exp
f_sequence(exp_list statements, exp result)
{
exp r;
exp h = getexp(f_bottom, result, 0, statements.start, nilexp, 0,
statements.number, 0);
exp l = statements.end;
clear_exp_list(statements);
/* re-organise so that sequence lists do not get too long.
limit to MAX_ST_LENGTH */
if (statements.number == 0) {
return result;
}
if (statements.number <= MAX_ST_LENGTH) {
setlast(l);
setbro(l, h);
r = getexp(sh(result), nilexp, 0, h, nilexp, 0, 0, seq_tag);
setfather(r, result);
return r;
} else {
int num_bits = statements.number / MAX_ST_LENGTH;
int rest = statements.number - (num_bits * MAX_ST_LENGTH);
exp_list work;
exp_list res;
exp t = statements.start;
int i, j;
res = new_exp_list(num_bits + 1);
if (rest == 0) {
--num_bits;
rest = MAX_ST_LENGTH;
}
for (i = 0; i < num_bits; ++i) {
work.start = t;
work.number = MAX_ST_LENGTH;
for (j = 0; j < (MAX_ST_LENGTH - 1); ++j) {
t = bro(t);
}
work.end = t;
t = bro(t);
res = add_exp_list(res, hold_check(f_sequence(work,
f_make_top())), i);
}
work.start = t;
work.end = l;
work.number = rest;
res = add_exp_list(res, hold_check(f_sequence(work,
f_make_top())),
num_bits);
return f_sequence(res, result);
}
}
exp
f_shape_offset(shape s)
{
return getexp(f_offset(f_alignment(s), long_to_al(1)), nilexp, 0,
nilexp, nilexp, 0, shape_size(s), val_tag);
}
exp
f_shift_left(error_treatment ov_err, exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!is_integer(sh(arg1)) || !is_integer(sh(arg2))) {
failer(CHSH_SHL);
}
#endif
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag ||
ov_err.err_code > 2)) {
arg2 = hold_check(f_change_variety(ov_err, ulongsh, arg2));
return TDFcallop2(ov_err, arg1, arg2, shl_tag);
}
#endif
if (ov_err.err_code == 4) {
exp d1 = me_startid(f_top, arg1, 0);
exp d2 = me_startid(f_top, arg2, 0);
exp d3 = me_startid(f_top, hold_check(f_shift_left(f_impossible,
me_obtain(d1),
me_obtain(d2))),
0);
exp_list el;
exp right = hold_check(f_shift_right(me_obtain(d3),
me_obtain(d2)));
exp test = me_q1(no_nat_option, f_equal, ov_err.jmp_dest, right,
me_obtain(d1), test_tag);
el = new_exp_list(1);
el = add_exp_list(el, test, 1);
return me_complete_id(d1, me_complete_id(d2, me_complete_id(d3,
f_sequence(el, me_obtain(d3)))));
} else if (ov_err.err_code > 4) {
exp d1 = me_startid(f_top, arg1, 0);
exp d2 = me_startid(f_top, arg2, 0);
exp d3 = me_startid(f_top, hold_check(f_shift_left(f_impossible,
me_obtain(d1),
me_obtain(d2))), 0);
exp_list el;
exp right = hold_check(f_shift_right(me_obtain(d3),
me_obtain(d2)));
exp trp = getexp(f_bottom, nilexp, 0, nilexp, nilexp, 0,
f_overflow, trap_tag);
exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);
exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0,
labst_tag);
exp test = me_q1(no_nat_option, f_equal, &lb, right,
me_obtain(d1), test_tag);
el = new_exp_list(1);
el = add_exp_list(el, test, 1);
return me_complete_id(d1, me_complete_id(d2, me_complete_id(d3,
f_conditional(&lb, f_sequence(el,
me_obtain(d3)), trp))));
}
return me_b1(ov_err, arg1, arg2, shl_tag);
}
exp
f_shift_right(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!is_integer(sh(arg1)) || !is_integer(sh(arg2))) {
failer(CHSH_SHR);
}
#endif
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag)) {
error_treatment ov_err;
ov_err = f_wrap;
arg2 = hold_check(f_change_variety(ov_err, ulongsh, arg2));
return TDFcallop2(ov_err, arg1, arg2, shr_tag);
}
#endif
return me_b2(arg1, arg2, shr_tag);
}
exp
f_subtract_ptrs(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
return me_b3(f_offset(al1_of(sh(arg2)), al1_of(sh(arg1))), arg1, arg2,
minptr_tag);
}
exp
f_variable(access_option acc, tag name_intro, exp init, exp body)
{
exp i = get_tag(name_intro);
exp d = son(i);
UNUSED(acc);
UNUSED(init);
setsh(i, sh(body));
setbro(d, body);
clearlast(d);
setfather(i, body);
#ifdef NEWDIAGS
if (doing_mark_scope) {
/* must be reading old diags */
correct_mark_scope(i);
}
#endif
return i;
}
void
start_variable(access_option acc, tag name_intro, exp init)
{
exp i = get_tag(name_intro);
if (i == nilexp || son(i) != i) {
i = getexp(f_bottom, nilexp, 0, init, nilexp, 0, 0, ident_tag);
} else {
/* could have been already used in env_offset */
son(i) = init;
}
setvar(i);
if (acc & (f_visible | f_long_jump_access)) {
setvis(i);
setenvoff(i);
} else if ((acc & f_no_other_read) && (acc & f_no_other_write)) {
setcaonly(i);
}
set_tag(name_intro, i);
return;
}
exp
f_xor(exp arg1, exp arg2)
{
if (name(sh(arg1)) == bothd) {
kill_exp(arg2, arg2);
return arg1;
}
if (name(sh(arg2)) == bothd) {
kill_exp(arg1, arg1);
return arg2;
}
#if check_shape
if (!eq_shape(sh(arg1), sh(arg2)) || !is_integer(sh(arg1))) {
failer(CHSH_XOR);
}
#endif
#if !has64bits
if (name(sh(arg1)) >= s64hd &&
(name(arg1) != val_tag || name(arg2) != val_tag)) {
return TDFcallop3(arg1, arg2, xor_tag);
}
#endif
return me_b2(arg1, arg2, xor_tag);
}
void
init_exp(void)
{
freelist = nilexp;
exps_left = 0;
crt_labno = 0;
global_case = getexp(f_bottom, nilexp, 0, nilexp, nilexp, 0, 0, 0);
in_initial_value = 0;
initial_value_pp.proc_struct_result = nilexp;
initial_value_pp.has_alloca = 0;
initial_value_pp.proc_is_recursive = 0;
initial_value_pp.uses_crt_env = 0;
initial_value_pp.has_setjmp = 0;
initial_value_pp.uses_loc_address = 0;
initial_value_pp.proc_label_count = 0;
initial_value_pp.proc_struct_res = 0;
initial_value_pp.default_freq = default_freq;
initial_value_pp.proc_externs = 0;
initial_value_pp.in_proc_def = 0;
initial_value_pp.pushed = (proc_props*)0;
initial_value_pp.rep_make_proc = 0;
return;
}
exp f_dummy_exp;
exp
f_return_to_label(exp e)
{
has_lv = 1;
return me_u3(f_bottom, e, return_to_label_tag);
}
nat
f_computed_nat(exp arg)
{
nat res;
if (name(arg) == val_tag) {
if (extra_checks && constovf(arg)) {
failer(ILLNAT);
}
if (!isbigval(arg)) {
nat_issmall(res) = 1;
natint(res) = no(arg);
return res;
} else {
nat_issmall(res) = 0;
natbig(res) = no(arg);
return res;
}
}
if (name(arg) == name_tag && !isvar(son(arg))) {
res = f_computed_nat(son(son(arg)));
kill_exp(arg, arg);
return res;
}
failer(ILLCOMPNAT);
nat_issmall(res) = 1;
natint(res) = 1;
return res;
}
nat
f_make_nat(tdfint n)
{
return n;
}
void
init_nat(void)
{
return;
}
nat f_dummy_nat;
void
init_ntest(void)
{
return;
}
void
init_otagexp(void)
{
return;
}
void
init_procprops(void)
{
return;
}
ntest f_dummy_ntest;
void
init_rounding_mode(void)
{
return;
}
rounding_mode f_dummy_rounding_mode;
shape
f_bitfield(bitfield_variety bf_var)
{
return getshape(bf_var.has_sign, const_al1, const_al1, BF_ALIGN,
bf_var.bits, bitfhd);
}
shape
f_compound(exp off)
{
int sz;
if (name(off) ==val_tag) {
sz = no(off);
} else {
failer(ILLCPDOFFSET);
sz = 0;
}
return getshape(0, const_al1, const_al1, al1_of(sh(off)), sz, cpdhd);
}
shape
f_floating(floating_variety fv)
{
switch (fv)
{
case shrealfv:
return shrealsh;
case realfv:
return realsh;
case doublefv:
return doublesh;
case shcomplexfv:
return shcomplexsh;
case complexfv:
return complexsh;
case complexdoublefv:
return complexdoublesh;
}
return realsh;
}
shape
f_integer(variety var)
{
return var;
}
shape
f_nof(nat n, shape s)
{
if (doing_aldefs) {
return s;
} else {
int al = shape_align(s);
int sz = rounder(shape_size(s), al);
int nm = (int)name(s);
int nofsz = natint(n)*sz;
shape res;
if (name(s) == nofhd) {
nm = ptno(s);
}
#if !has64bits
if (!nat_issmall(n)) {
failer(TOO_BIG_A_VECTOR);
}
#endif
if (name(s) == tophd) {
/* pathological - make it nof(0, char) */
res = getshape(0, const_al1, const_al1,
align_of(ucharsh), 0, nofhd);
} else if (al == 1) {
if ((sz & (sz - 1)) != 0 && nofsz > BF_STORE_UNIT) {
IGNORE fprintf(stderr, "Warning: Bitfields of nof cannot all be variety enclosed \n");
}
if ((sz & (sz - 1)) == 0 || nofsz > BF_STORE_UNIT) {
shape news = containedshape(sz, 1);
int nsz = shape_align(news);
int newn = rounder(nofsz, nsz);
res = getshape(0, const_al1, const_al1,
align_of(news), newn, nofhd);
} else {
shape news = containedshape(nofsz, 1);
res = getshape(0, const_al1, const_al1,
align_of(news), shape_size(news),
cpdhd);
}
} else {
res = getshape(0, const_al1, const_al1, align_of(s),
nofsz, nofhd);
}
ptno(res) = nm; /* set the pt field of the shape to the
shapemacs.h hd identifier of the shape */
return res;
}
}
shape
f_offset(alignment arg1, alignment arg2)
{
/* use values pre-computed by init since we never alter shapes */
if (arg1->al.al_n != 1 || arg2->al.al_n != 1 || arg1->al.sh_hd != 0 ||
arg2->al.sh_hd != 0 || arg1->al.al_val.al_frame != 0 ||
arg2->al.al_val.al_frame != 0) {
return getshape(0, arg1, arg2, OFFSET_ALIGN, OFFSET_SZ,
offsethd);
}
/* use values pre-computed by init since we never alter shapes */
switch (arg1->al.al_val.al) {
case 512:
switch (arg2->al.al_val.al) {
case 512:
return f_off512_512;
case 64:
return f_off512_64;
case 32:
return f_off512_32;
case 16:
return f_off512_16;
case 8:
return f_off512_8;
case 1:
return f_off512_1;
default:
failer(ILLOFF2);
return f_off64_8;
}
case 64:
switch (arg2->al.al_val.al) {
case 64:
return f_off64_64;
case 32:
return f_off64_32;
case 16:
return f_off64_16;
case 8:
return f_off64_8;
case 1:
return f_off64_1;
default:
failer(ILLOFF2);
return f_off64_8;
}
case 32:
switch (arg2->al.al_val.al) {
case 32:
return f_off32_32;
case 16:
return f_off32_16;
case 8:
return f_off32_8;
case 1:
return f_off32_1;
default:
failer(ILLOFF2);
return f_off32_8;
}
case 16:
switch (arg2->al.al_val.al) {
case 16:
return f_off16_16;
case 8:
return f_off16_8;
case 1:
return f_off16_1;
default:
failer(ILLOFF2);
return f_off16_8;
}
case 8:
switch (arg2->al.al_val.al) {
case 8:
return f_off8_8;
case 1:
return f_off8_1;
default:
failer(ILLOFF2);
return f_off8_8;
}
case 1:
switch (arg2->al.al_val.al) {
case 1:
return f_off1_1;
default:
failer(ILLOFF2);
return f_off1_1;
}
default:
failer(ILLOFF1);
return f_off8_8;
}
}
static shape frame_ptrs[32];
static struct SAL {
alignment al;
shape ptr_sh;
struct SAL *rest;
} *cache_pashs;
shape
f_pointer(alignment arg)
{
/* use values pre-computed by init since we never alter shapes */
int af = arg->al.al_val.al_frame;
if (arg->al.al_n != 1 && af == 0) {
return getshape(0, arg, const_al1, PTR_ALIGN, PTR_SZ, ptrhd);
}
if (af != 0) {
if (frame_ptrs[af] == (shape)0) {
frame_ptrs[af] = getshape(0, arg, const_al1, PTR_ALIGN,
PTR_SZ, ptrhd);
}
return frame_ptrs[af];
}
if (arg->al.sh_hd != 0) {
struct SAL *c = cache_pashs;
shape res;
while (c != (struct SAL*)0) {
if (arg == c->al) return c->ptr_sh;
c = c->rest;
}
res = getshape(0, arg, const_al1, PTR_ALIGN, PTR_SZ, ptrhd);
c = (struct SAL*)xmalloc(sizeof(struct SAL));
c->al = arg; c->ptr_sh = res; c->rest = cache_pashs;
cache_pashs = c;
return res;
}
switch (arg->al.al_val.al)
{
case 1: return f_ptr1;
case 8: return f_ptr8;
case 16: return f_ptr16;
case 32: return f_ptr32;
case 64: return f_ptr64;
default: failer(ILLALIGN); return f_ptr8;
};
}
shape f_proc;
void
init_shape(void)
{
/* pre-compute values for use in f_pointer and f_offset */
int i;
for (i = 0; i < 32; i++) {
frame_ptrs[i] = (shape)0;
}
cache_pashs = (struct SAL *)0;
f_bottom = getshape(0, const_al1, const_al1, const_al1, 0, bothd);
f_top = getshape(0, const_al1, const_al1, TOP_ALIGN, TOP_SZ, tophd);
f_proc = getshape(0, const_al1, const_al1, PROC_ALIGN, PROC_SZ, prokhd);
f_ptr1 = getshape(0, const_al1, const_al1, PTR_ALIGN, PTRBIT_SZ, ptrhd);
f_ptr8 = getshape(0, const_al8, const_al1, PTR_ALIGN, PTR_SZ, ptrhd);
f_local_label_value = f_ptr8;
f_ptr16 = getshape(0, const_al16, const_al1, PTR_ALIGN, PTR_SZ, ptrhd);
f_ptr32 = getshape(0, const_al32, const_al1, PTR_ALIGN, PTR_SZ, ptrhd);
f_ptr64 = getshape(0, const_al64, const_al1, PTR_ALIGN, PTR_SZ, ptrhd);
f_off1_1 = getshape(1, const_al1, const_al1, OFFSET_ALIGN, OFFSET_SZ,
offsethd);
f_off0_0 = getshape(1, const_al1, const_al1, OFFSET_ALIGN, OFFSET_SZ,
offsethd);
f_off8_8 = getshape(1, const_al8, const_al8, OFFSET_ALIGN, OFFSET_SZ,
offsethd);
f_off8_1 = getshape(1, const_al8, const_al1, OFFSET_ALIGN, OFFSET_SZ,
offsethd);
f_off16_16 = getshape(1, const_al16, const_al16, OFFSET_ALIGN,
OFFSET_SZ, offsethd);
f_off16_8 = getshape(1, const_al16, const_al8, OFFSET_ALIGN, OFFSET_SZ,
offsethd);
f_off16_1 = getshape(1, const_al16, const_al1, OFFSET_ALIGN, OFFSET_SZ,
offsethd);
f_off32_32 = getshape(1, const_al32, const_al32, OFFSET_ALIGN,
OFFSET_SZ, offsethd);
f_off32_16 = getshape(1, const_al32, const_al16, OFFSET_ALIGN,
OFFSET_SZ, offsethd);
f_off32_8 = getshape(1, const_al32, const_al8, OFFSET_ALIGN, OFFSET_SZ,
offsethd);
f_off32_1 = getshape(1, const_al32, const_al1, OFFSET_ALIGN, OFFSET_SZ,
offsethd);
f_off64_64 = getshape(1, const_al64, const_al64, OFFSET_ALIGN,
OFFSET_SZ, offsethd);
f_off64_32 = getshape(1, const_al64, const_al32, OFFSET_ALIGN,
OFFSET_SZ, offsethd);
f_off64_16 = getshape(1, const_al64, const_al16, OFFSET_ALIGN,
OFFSET_SZ, offsethd);
f_off64_8 = getshape(1, const_al64, const_al8, OFFSET_ALIGN, OFFSET_SZ,
offsethd);
f_off64_1 = getshape(1, const_al64, const_al1, OFFSET_ALIGN, OFFSET_SZ,
offsethd);
f_off512_512 = getshape(1, const_al512, const_al512, OFFSET_ALIGN,
OFFSET_SZ, offsethd);
f_off512_64 = getshape(1, const_al512, const_al64, OFFSET_ALIGN,
OFFSET_SZ, offsethd);
f_off512_32 = getshape(1, const_al512, const_al32, OFFSET_ALIGN,
OFFSET_SZ, offsethd);
f_off512_16 = getshape(1, const_al512, const_al16, OFFSET_ALIGN,
OFFSET_SZ, offsethd);
f_off512_8 = getshape(1, const_al512, const_al8, OFFSET_ALIGN,
OFFSET_SZ, offsethd);
f_off512_1 = getshape(1, const_al512, const_al1, OFFSET_ALIGN,
OFFSET_SZ, offsethd);
return;
}
shape f_dummy_shape;
signed_nat
f_computed_signed_nat(exp arg)
{
signed_nat res;
if (name(arg) == val_tag) {
if (extra_checks && constovf(arg)) {
failer(ILLNAT);
}
if (!isbigval(arg)) {
snat_issmall(res) = 1;
if (!is_signed(sh(arg))) {
snatneg(res) = 0;
snatint(res) = no(arg);
} else {
if (no(arg) < 0) {
snatneg(res) = 1;
snatint(res) = -no(arg);
} else {
snatneg(res) = 0;
snatint(res) = no(arg);
}
}
return res;
} else {
snat_issmall(res) = 0;
snatneg(res) = (bool)(flptnos[no(arg)].sign == -1);
flptnos[no(arg)].sign = 1;
snatint(res) = no(arg);
return res;
}
}
if (name(arg) == name_tag && !isvar(son(arg))) {
res = f_computed_signed_nat(son(son(arg)));
kill_exp(arg, arg);
return res;
}
failer(ILLCOMPSNAT);
snat_issmall(res) = 1;
snatneg(res) = 0;
snatint(res) = 1;
return res;
}
signed_nat
f_snat_from_nat(bool neg, nat n)
{
signed_nat res;
if (snat_issmall(n)) {
snatneg(res) = (bool)((natint(n) == 0) ? 0 : neg);
snat_issmall(res) = 1;
snatint(res) = natint(n);
return res;
}
snat_issmall(res) = 0;
snatbig(res) = natbig(n);
snatneg(res) = neg;
return res;
}
signed_nat
f_make_signed_nat(tdfbool neg, tdfint n)
{
return f_snat_from_nat(neg, n);
}
void
init_signed_nat(void)
{
return;
}
signed_nat f_dummy_signed_nat;
string f_dummy_string;
void
init_string(void)
{
return;
}
string
f_concat_string(string a1, string a2)
{
int i;
string res;
if (a1.size != a2.size) {
failer("Concatenated strings have different unit size");
}
res.number = a1.number + a2.number;
res.size = a1.size;
if (res.size <= 8) {
res.ints.chars = (char *)xcalloc(res.number + 1, sizeof(char));
for (i = 0; i < a1.number; i++) {
res.ints.chars[i] = a1.ints.chars[i];
}
for (i = 0; i < a2.number; i++) {
res.ints.chars[i + a1.number] = a2.ints.chars[i];
}
res.ints.chars[res.number] = 0;
} else if (res.size <= 16) {
res.ints.shorts = (short *)xcalloc(res.number + 1,
sizeof(short));
for (i = 0; i < a1.number; i++) {
res.ints.shorts[i] = a1.ints.shorts[i];
}
for (i = 0; i < a2.number; i++) {
res.ints.shorts[i + a1.number] = a2.ints.shorts[i];
}
res.ints.shorts[res.number] =0;
} else {
res.ints.longs = (int *)xcalloc(res.number + 1, sizeof(int));
for (i = 0; i < a1.number; i++) {
res.ints.longs[i] = a1.ints.longs[i];
}
for (i = 0; i < a2.number; i++) {
res.ints.longs[i + a1.number] = a2.ints.longs[i];
}
res.ints.longs[res.number] =0;
}
return res;
}
string
f_make_string(tdfstring s)
{
return s;
}
tagshacc
f_make_tagshacc(shape sha, access_option visible, tag tg_intro)
{
tagshacc res;
res.sha = sha;
res.visible = visible;
res.tg = tg_intro;
return res;
}
void
init_tagshacc(void)
{
return;
}
transfer_mode f_dummy_transfer_mode;
transfer_mode
f_add_modes(transfer_mode md1, transfer_mode md2)
{
return md1 | md2;
}
version
f_user_info(tdfident t)
{
version res;
UNUSED(t);
res.major_version = MAJOR_VERSION;
res.minor_version = MINOR_VERSION;
return res;
}
variety
f_var_limits(signed_nat lower_bound, signed_nat upper_bound)
{
unsigned int h;
unsigned int l;
if (!snat_issmall(lower_bound) || !snat_issmall(upper_bound)) {
if (snatneg(lower_bound)) {
return s64sh;
} else {
return u64sh;
}
}
/* normalise the varieties to use only the six standard ones */
l = (unsigned int)(snatint(lower_bound));
/* these assume the length of unsigned int equals int */
h = (unsigned int)(snatint(upper_bound));
if (!snatneg(lower_bound)) {
if (h <= 255) {
return ucharsh;
}
if (h <= 65535) {
return uwordsh;
}
return ulongsh;
}
if (l <= 128 && h <= 127) {
return scharsh;
}
if (l<= 32768 && h <= 32767) {
return swordsh;
}
return slongsh;
}
variety
f_var_width(bool sig, nat bits)
{
int w = natint(bits);
if (sig) {
if (w <= 8) {
return scharsh;
}
if (w <= 16) {
return swordsh;
}
if (w <= 32) {
return slongsh;
}
if (w <= 64) {
return s64sh;
}
failer(WIDTH_ERROR);
return slongsh;
}
if (w <= 8) {
return ucharsh;
}
if (w <= 16) {
return uwordsh;
}
if (w <= 32) {
return ulongsh;
}
if (w <= 64) {
return u64sh;
}
failer(WIDTH_ERROR);
return ulongsh;
}
void init_variety
(void)
{
ucharsh = getshape(0, const_al1, const_al1, UCHAR_ALIGN, UCHAR_SZ,
ucharhd);
scharsh = getshape(1, const_al1, const_al1, SCHAR_ALIGN, SCHAR_SZ,
scharhd);
uwordsh = getshape(0, const_al1, const_al1, UWORD_ALIGN, UWORD_SZ,
uwordhd);
swordsh = getshape(1, const_al1, const_al1, SWORD_ALIGN, SWORD_SZ,
swordhd);
ulongsh = getshape(0, const_al1, const_al1, ULONG_ALIGN, ULONG_SZ,
ulonghd);
slongsh = getshape(1, const_al1, const_al1, SLONG_ALIGN, SLONG_SZ,
slonghd);
u64sh = getshape(0, const_al1, const_al1, U64_ALIGN, U64_SZ, u64hd);
s64sh = getshape(1, const_al1, const_al1, S64_ALIGN, S64_SZ, s64hd);
return;
}
variety f_dummy_variety;
version
f_make_version(tdfint major_version, tdfint minor_version)
{
version res;
res.major_version = natint(major_version);
res.minor_version = natint(minor_version);
if (res.major_version >= 3) {
newcode = 1;
} else {
newcode = 0;
}
return res;
}
version_props
f_make_versions(version_props version_info)
{
UNUSED(version_info);
return 0;
}
exp_list
new_exp_list(int n)
{
exp_list res;
UNUSED(n);
res.number = 0;;
res.start = nilexp;
res.end = nilexp;
return res;
}
exp_list
add_exp_list(exp_list list, exp elem, int index)
{
UNUSED(index);
++list.number;
parked(elem) = 1;
if (list.start == nilexp) {
list.start = elem;
list.end = elem;
setlast(elem);
bro(elem) = nilexp;
return list;
}
clearlast(list.end);
bro(list.end) = elem;
list.end = elem;
setlast(elem);
bro(elem) = nilexp;
return list;
}
caselim_list
new_caselim_list(int n)
{
UNUSED(n);
/* bro(global_case) = nilexp;
return 0;
*/
return nilexp;
}
caselim_list
add_caselim_list(caselim_list list, caselim elem, int index)
{
/* see the documentation for the representation of cases */
exp ht;
int low;
int high;
exp lowval = getexp(slongsh, nilexp, 0, nilexp, nilexp, 0, 0, 0);
/* UNUSED(list); */
UNUSED(index);
pt(lowval) = get_lab(elem.lab); /* label for this branch */
if (snat_issmall(elem.low)) {
low = snatint(elem.low);
if (snatneg(elem.low)) {
low = - low;
}
} else {
#if !has64bits
SET(low);
failer(TOO_BIG_A_CASE_ELEMENT);
#else
low = snatbig(elem.low);
if (snatneg(elem.low)) {
flpt z = new_flpt();
flt_copy(flptnos[low], &flptnos[z]);
low = z;
flptnos[low].sign = - flptnos[low].sign;
}
setbigval(lowval);
#endif
}
no(lowval) = low;
if (snat_issmall(elem.high)) {
high = snatint(elem.high);
if (snatneg(elem.high)) {
high = - high;
}
if (!isbigval(lowval) && high == low) {
ht = nilexp;
} else {
ht = getexp(slongsh, nilexp, 1, nilexp, nilexp, 0,
high, 0);
}
} else {
#if !has64bits
SET(ht);
failer(TOO_BIG_A_CASE_ELEMENT);
#else
int lh_eq;
high = snatbig(elem.high);
if (snatneg(elem.high)) {
flpt z = new_flpt();
flt_copy(flptnos[high], &flptnos[z]);
high = z;
flptnos[high].sign = - flptnos[high].sign;
}
if (isbigval(lowval)) {
lh_eq = flt_cmp(flptnos[low], flptnos[high]);
} else {
lh_eq = 0;
}
if (!lh_eq) {
ht = getexp(slongsh, nilexp, 1, nilexp, nilexp, 0,
high, 0);
setbigval(ht);
} else {
ht = nilexp;
}
#endif
}
/* if (ht != nilexp && docmp_f((int)f_less_than, ht, lowval)){
retcell(lowval);
retcell(ht);
return 0;
}
*/
++no(son(pt(lowval))); /* record label use */
son(lowval) = ht;
/* case_item (lowval);
*/
bro(lowval) = list;
return lowval;
}
label_list
new_label_list(int n)
{
label_list res;
res.elems = (label *)xcalloc(n, sizeof(label));
res.number = n;
return res;
}
label_list
add_label_list(label_list list, label elem, int index)
{
exp def;
exp labst;
def = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, clear_tag);
labst = getexp(f_bottom, nilexp, 0, def, nilexp, 0, 0, labst_tag);
fno(labst) = default_freq;
++proc_label_count;
set_lab(elem, labst);
list.elems[index] = elem;
return list;
}
tagshacc_list
new_tagshacc_list(int n)
{
tagshacc_list res;
res.size = 0;
res.id = nilexp;
res.last_id = nilexp;
res.last_def = nilexp;
res.number = n;
return res;
}
tagshacc_list
add_tagshacc_list(tagshacc_list list, tagshacc elem, int index)
{
exp d = getexp(elem.sha, nilexp, 0, nilexp, nilexp, 0, 0, clear_tag);
exp i = getexp(f_bottom, list.last_id, 1, d, nilexp, 0, 0, ident_tag);
UNUSED(index);
set_tag(elem.tg, i);
if (list.id == nilexp) {
list.id = i;
} else {
bro(list.last_def) = i;
}
list.last_def = d;
list.last_id = i;
if (elem.visible & (f_visible | f_long_jump_access)) {
setvis(i);
}
if (elem.visible & f_out_par) {
setoutpar(i);
}
setvar(i);
setparam(i);
return list;
}
version_list
new_version_list(int n)
{
UNUSED(n);
return 0;
}
static int version_printed = 0;
version_list
add_version_list(version_list list, version elem, int index)
{
UNUSED(list);
UNUSED(index);
if (global_version.major_version == 0) {
global_version = elem;
}
if (elem.major_version != global_version.major_version) {
failer(WRONG_VERSION);
IGNORE fprintf(stderr, "This TDF has mixed versions\n");
}
if (report_versions) {
if (!version_printed) {
version_printed = 1;
IGNORE fprintf(stderr, "This TDF is composed from Capsules of the following versions:-\n");
}
IGNORE fprintf(stderr, "TDF Version %d.%d\n",
elem.major_version, elem.minor_version);
}
return 0;
}
version f_dummy_version;
access_option no_access_option = 0;
access_option
yes_access_option(access acc)
{
return acc;
}
string_option no_string_option;
string_option
yes_string_option(string s)
{
string_option res;
res.val = s;
res.present = 1;
return res;
}
void
init_string_option(void)
{
no_string_option.present = 0;
}
tagacc_option no_tagacc_option;
tagacc_option
yes_tagacc_option(tagacc elem)
{
tagacc_option res;
res.val = elem;
res.present = 1;
return res;
}
void
init_tagacc_option(void)
{
no_tagacc_option.present = 0;
return;
}
nat_option no_nat_option;
nat_option
yes_nat_option(nat n)
{
nat_option res;
res.val = n;
res.present = 1;
return res;
}
void
init_nat_option(void)
{
no_nat_option.present = 0;
return;
}
void
init_tagacc(void)
{
return;
}
tagacc
f_make_tagacc(tag tg, access_option acc)
{
tagacc res;
res.tg = tg;
res.visible = acc;
return res;
}
void
init_transfer_mode(void)
{
return;
}
void
init_version_props(void)
{
global_version.major_version = 0;
global_version.minor_version = 0;
return;
}
void
init_version(void)
{
return;
}
void
init_access_option(void)
{
return;
}
static int seq_n = 0;
char *
init_NAME(char *good_name)
{
char *prefix = "__I.TDF";
time_t t;
int i, j;
char *c;
char *res;
int sc;
int sp;
int sg;
t = time(NULL) + (time_t)(seq_n++);
c = asctime(localtime(&t));
sc = (int)strlen(c);
sp = (int)strlen(prefix);
sg = (int)strlen(good_name);
res = (char*)xcalloc(sc + sp + sg, sizeof(char));
for (i = 0; i < sp; i++) {
res[i] = prefix[i];
}
for (j = 0; j < sg; i++, j++) {
res[i] = good_name[j];
}
for (j = 0; j < sc; j++) {
if (isalpha(c[j]) || isdigit(c[j])) {
res[i] = c[j]; i++;
}
}
res[i] = 0;
dynamic_init_proc = res;
return (res);
}
void
start_initial_value(void)
{
if (in_initial_value++ == 0) {
proc_props *real_pp = (proc_props *)0;
if (old_proc_props != (proc_props *)0) {
/* initial value in proc */
push_proc_props();
real_pp = old_proc_props;
}
old_proc_props = &initial_value_pp;
pop_proc_props();
old_proc_props = real_pp;
}
}
exp
f_initial_value(exp e)
{
if (--in_initial_value > 0) {
return e;
}
initial_value_pp.proc_struct_result = proc_struct_result;
initial_value_pp.has_alloca = has_alloca;
initial_value_pp.proc_is_recursive = proc_is_recursive;
initial_value_pp.uses_crt_env = uses_crt_env;
initial_value_pp.has_setjmp = has_setjmp;
initial_value_pp.uses_loc_address = uses_loc_address;
initial_value_pp.proc_label_count = proc_label_count;
initial_value_pp.proc_struct_res = proc_struct_res;
initial_value_pp.default_freq = default_freq;
initial_value_pp.proc_externs = proc_externs;
initial_value_pp.in_proc_def = in_proc_def;
initial_value_pp.pushed = old_proc_props;
initial_value_pp.rep_make_proc = rep_make_proc;
if (old_proc_props != (proc_props *)0) {
/* init was in a proc - must make new variable */
dec *my_def = make_extra_dec(make_local_name(), 1, 0, me_u2(e,
initial_value_tag), sh(e));
exp crt_exp = my_def->dec_u.dec_val.dec_exp;
pop_proc_props();
return f_contents(sh(e), me_obtain(crt_exp));
}
return me_u2(e, initial_value_tag);
}
void
tidy_initial_values(void)
{
dec *my_def = top_def;
exp_list initial_as;
exp_list prom_as;
char *good_name = (char *)0;
initial_as = new_exp_list(0);
prom_as = new_exp_list(0);
dynamic_init_proc = (char *)0;
while (my_def != (dec *)0) {
exp crt_exp = my_def->dec_u.dec_val.dec_exp;
if (son(crt_exp) != nilexp && my_def->dec_u.dec_val.extnamed) {
good_name = my_def->dec_u.dec_val.dec_id;
}
if (son(crt_exp) != nilexp &&
name(son(crt_exp)) == initial_value_tag) {
/* accumulate assignments of initial values in one
explist */
if (!(my_def->dec_u.dec_val.dec_var)) {
/* make sure its a variable */
exp p = pt(crt_exp);
setvar(crt_exp);
my_def->dec_u.dec_val.dec_var = 1;
while (p != nilexp) {
exp np = pt(p);
exp c = hold_check(f_contents(sh(p),
me_obtain(crt_exp)));
replace(p, c, nilexp);
p = np;
}
}
{
exp init = son(son(crt_exp));
exp new_init = f_make_value(sh(init));
if (good_name == (char *)0) {
good_name =
my_def->dec_u.dec_val.dec_id;
}
retcell(son(crt_exp));
son(crt_exp) = new_init;
bro(new_init) = crt_exp; setlast(new_init);
initial_as = add_exp_list(initial_as,
hold_check(f_assign(me_obtain(crt_exp),
init)), 0);
}
}
if (do_prom && son(crt_exp) != nilexp &&
my_def->dec_u.dec_val.dec_var && !is_comm(son(crt_exp))) {
/* accumulate assignments of non-zero initialisations
in one explist */
exp init = son(crt_exp);
exp new_init = f_make_value(sh(init));
if (good_name == (char *)0) {
good_name = my_def->dec_u.dec_val.dec_id;
}
if (name(init) == compound_tag ||
name(init) == nof_tag ||
name(init) == concatnof_tag ||
name(init) == ncopies_tag ||
name(init) == string_tag) {
dec *id_dec = make_extra_dec(make_local_name(),
0, 0, init,
sh(init));
init = me_obtain(id_dec->dec_u.dec_val.dec_exp);
}
son(crt_exp) = new_init;
no(new_init) = -1; /* we may need to distinguish for
diags */
bro(new_init) = crt_exp;
setlast(new_init);
prom_as = add_exp_list(prom_as,
hold_check(f_assign(me_obtain(
crt_exp), init)), 0);
}
my_def = my_def->def_next;
}
if (initial_as.number != 0) {
/* ie there are some dynamic initialisations */
exp prc;
dec *extra_dec;
tagshacc_list tsl;
exp ret = f_return(f_make_top());
exp seq = f_sequence(initial_as, ret);
tsl = new_tagshacc_list(0);
old_proc_props = &initial_value_pp; pop_proc_props();
old_proc_props = (proc_props *)0;
rep_make_proc = 0;
push_proc_props();
prc = f_make_proc(f_top, tsl, no_tagacc_option, seq);
/* prc has one visible param - hence looks like varargs */
if (do_prom) {
/* struct (proc, ptr) */
exp off_proc = hold_check(f_offset_zero(PROC_ALIGN));
exp off_ptr = hold_check(f_offset_pad(PTR_ALIGN,
hold_check(f_offset_add(copy(
off_proc), hold_check(
f_shape_offset(f_proc))))));
shape str_sh = f_compound(hold_check(f_offset_add(copy(
off_ptr), hold_check(
f_shape_offset(f_pointer(
PROC_ALIGN))))));
dec *str_dec = make_extra_dec(make_local_name(), 1, 0,
f_make_value(str_sh),
str_sh);
dec *prc_dec = make_extra_dec(make_local_name(), 0, 0,
prc, f_proc);
exp prc_exp = prc_dec->dec_u.dec_val.dec_exp;
exp str_exp = str_dec->dec_u.dec_val.dec_exp;
exp list_exp = find_named_tg("__PROM_init_list",
f_pointer(f_alignment(
str_sh)));
brog(list_exp)->dec_u.dec_val.dec_var = 1;
setvar(list_exp);
prom_as = add_exp_list(prom_as, hold_check(f_assign(
f_add_to_ptr(me_obtain(str_exp),
copy(off_proc)),
me_obtain(prc_exp))), 0);
prom_as = add_exp_list(prom_as, hold_check(f_assign(
f_add_to_ptr(me_obtain(str_exp),
copy(off_ptr)),
f_contents(sh(list_exp),
me_obtain(list_exp)))), 0);
prom_as = add_exp_list(prom_as, hold_check(f_assign(
me_obtain(list_exp),
me_obtain(str_exp))), 0);
} else {
extra_dec = make_extra_dec(add_prefix(init_NAME(
good_name)), 0, 1, prc,
f_proc);
}
}
if (do_prom && prom_as.number != 0) {
/* ie there are some prom initialisations */
exp prc;
dec *extra_dec;
tagshacc_list tsl;
exp ret = f_return(f_make_top());
exp seq = f_sequence(prom_as, ret);
tsl = new_tagshacc_list(0);
rep_make_proc = 0;
start_make_proc(f_top, tsl, no_tagacc_option);
prc = f_make_proc(f_top, tsl, no_tagacc_option, seq);
extra_dec = make_extra_dec(add_prefix(init_NAME(good_name)), 0,
1, prc, f_proc);
}
}