Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed
/*
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
PROTO_N ( (t,e) )
PROTO_T ( procprops t X procprops e )
{
return (t|e);
}
procprops no_procprops_option = 0;
procprops yes_procprops_option
PROTO_N ( (p) )
PROTO_T ( procprops p )
{
return p;
}
void init_procprops_option
PROTO_Z ()
{
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
PROTO_N ( (t, e, i) )
PROTO_T ( error_code_list t X error_code e X int i )
{
UNUSED (i);
return(t | e);
}
error_code_list new_error_code_list
PROTO_N ( (n) )
PROTO_T ( int n )
{
UNUSED (n);
return 0;
}
transfer_mode f_trap_on_nil = 8;
shape containedshape
PROTO_N ( (a, s) )
PROTO_T ( int a X 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
PROTO_N ( (nme, v, g, init, s) )
PROTO_T ( char * nme X int v X int g X exp init X 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
PROTO_N ( (n) )
PROTO_T ( 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
PROTO_N ( (n, s) )
PROTO_T ( char * n X 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
PROTO_N ( (nm, sngd) )
PROTO_T ( int nm X 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
PROTO_N ( (arg1, arg2, n) )
PROTO_T ( exp arg1 X exp arg2 X 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
PROTO_N ( (ov_err, e) )
PROTO_T ( error_treatment ov_err X 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
PROTO_N ( (ov_err,arg1, arg2, n) )
PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 X 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
PROTO_N ( (ov_err,arg1, nm, s) )
PROTO_T ( error_treatment ov_err X exp arg1 X char * nm X 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
PROTO_N ( (ov_err,arg1, n) )
PROTO_T ( error_treatment ov_err X exp arg1 X 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
PROTO_N ( (arg1, n) )
PROTO_T ( exp arg1 X 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
error_treatment f_wrap;
error_treatment f_impossible;
error_treatment f_continue;
#ifdef promote_pars
static void promote_actuals
PROTO_N ( (par) )
PROTO_T ( 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
PROTO_N ( (bdy) )
PROTO_T ( 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
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
PROTO_Z ()
{
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
PROTO_N ( (ec) )
PROTO_T ( error_code_list ec )
{
error_treatment res;
res.err_code = ec;
return res;
}
alignment f_callers_alignment
PROTO_N ( (var) )
PROTO_T ( bool var )
{
return ((var)?var_callers_alignment:nv_callers_alignment);
}
alignment f_callees_alignment
PROTO_N ( (var) )
PROTO_T ( bool var )
{
return ((var)?var_callees_alignment:nv_callees_alignment);
}
otagexp f_make_otagexp
PROTO_N ( (tagopt, e) )
PROTO_T ( tag_option tagopt X 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
PROTO_N ( (n) )
PROTO_T ( 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
PROTO_N ( (list, ote, n) )
PROTO_T ( otagexp_list list X otagexp ote X 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
PROTO_N ( (args) )
PROTO_T ( 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
PROTO_N ( (ptr,sze) )
PROTO_T ( exp ptr X 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
PROTO_N ( (el) )
PROTO_T ( 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
PROTO_N ( (nt, dest, arg1, arg2) )
PROTO_T ( ntest nt X label dest X exp arg1 X 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
PROTO_N ( (sha) )
PROTO_T ( 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
PROTO_N ( (a1) )
PROTO_T ( 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
PROTO_N ( (a1, a2) )
PROTO_T ( alignment a1 X 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
PROTO_Z ()
{
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
PROTO_N ( (a1, a2) )
PROTO_T ( access a1 X 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
PROTO_Z ()
{
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
PROTO_N ( (a, sh_hd, al) )
PROTO_T ( alignment a X int sh_hd X 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
PROTO_N ( (sha) )
PROTO_T ( 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
PROTO_N ( (issigned, bits) )
PROTO_T ( bool issigned X 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
PROTO_Z ()
{
return;
}
bitfield_variety f_dummy_bitfield_variety;
bool f_false = 0;
bool f_true = 1;
void init_bool
PROTO_Z ()
{
return;
}
bool f_dummy_bool;
caselim f_make_caselim
PROTO_N ( (branch, lower, upper) )
PROTO_T ( label branch X signed_nat lower X 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
PROTO_Z ()
{
f_same_callees = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0,
same_callees_tag);
return;
}
void init_caselim
PROTO_Z ()
{
return;
}
error_treatment f_error_jump
PROTO_N ( (lab) )
PROTO_T ( 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
PROTO_Z ()
{
return;
}
void init_error_treatment
PROTO_Z ()
{
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
PROTO_N ( (ov_err, arg1) )
PROTO_T ( error_treatment ov_err X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (result_shape, arg1, arg2, varparam) )
PROTO_T ( shape result_shape X exp arg1 X exp_list arg2 X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (md, arg1, arg2) )
PROTO_T ( transfer_mode md X exp arg1 X 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
PROTO_N ( (p, off, val) )
PROTO_T ( exp p X exp off X 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
PROTO_N ( (md, p, off, val) )
PROTO_T ( transfer_mode md X exp p X exp off X 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
PROTO_N ( (bf, p, off) )
PROTO_T ( bitfield_variety bf X exp p X 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
PROTO_N ( (md, bf, p, off) )
PROTO_T ( transfer_mode md X bitfield_variety bf X exp p X 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
PROTO_N ( (exhaustive, control, branches) )
PROTO_T ( bool exhaustive X exp control X 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
exp f_case
PROTO_N ( (exhaustive, control, branches) )
PROTO_T ( bool exhaustive X exp control X 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
exp f_change_bitfield_to_int
PROTO_N ( (x, arg1) )
PROTO_T ( variety x 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
PROTO_N ( (x, arg1) )
PROTO_T ( bitfield_variety x 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
PROTO_N ( (ov_err, r, arg1) )
PROTO_T ( error_treatment ov_err X variety r X 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
PROTO_N ( (sha, arg1, arg2) )
PROTO_T ( shape sha X exp arg1 X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (alt_label_intro, first, alt) )
PROTO_T ( label alt_label_intro X exp first X 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
PROTO_N ( (alt_label_intro) )
PROTO_T ( 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
PROTO_N ( (s, arg1) )
PROTO_T ( shape s X 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
PROTO_N ( (md, s, arg1) )
PROTO_T ( transfer_mode md X shape s X 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
PROTO_Z ()
{
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
PROTO_N ( (a, b) )
PROTO_T ( error_treatment a X error_treatment b )
{
return ( a.err_code == b.err_code
&& (a.err_code != 4 || a.jmp_dest == b.jmp_dest)
);
}
exp div_rem
PROTO_N ( (div0_err, ov_err, arg1, arg2, f) )
PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X
exp arg2 X exp (*f) PROTO_S ((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
PROTO_N ( (ov_err, arg1, arg2) )
PROTO_T ( error_treatment ov_err X exp arg1 X 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
PROTO_N ( (div0_err, ov_err, arg1, arg2) )
PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X 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
PROTO_N ( (ov_err, arg1, arg2) )
PROTO_T ( error_treatment ov_err X exp arg1 X 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
PROTO_N ( (div0_err, ov_err, arg1, arg2) )
PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X 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
PROTO_N ( (ov_err, arg1, arg2) )
PROTO_T ( error_treatment ov_err X exp arg1 X 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
PROTO_N ( (div0_err, ov_err, arg1, arg2) )
PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X 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
PROTO_N ( (fa, y, t) )
PROTO_T ( alignment fa X alignment y X 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
PROTO_N ( (message) )
PROTO_T ( 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
PROTO_N ( (dest) )
PROTO_T ( 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
PROTO_N ( (arg1) )
PROTO_T ( 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
PROTO_N ( (acc, name_intro, definition, body) )
PROTO_T ( access_option acc X tag name_intro X exp definition X 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
PROTO_N ( (acc, name_intro, definition) )
PROTO_T ( access_option acc X tag name_intro X 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
PROTO_N ( (arg1) )
PROTO_T ( exp arg1 )
{
if (name(sh(arg1)) == bothd)
return arg1;
return me_u2(arg1, ignorable_tag);
}
exp f_integer_test
PROTO_N ( (prob, nt, dest, arg1, arg2) )
PROTO_T ( nat_option prob X ntest nt X label dest X exp arg1 X 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
PROTO_N ( (placelabs_intro, starter, places) )
PROTO_T ( label_list placelabs_intro X exp starter X 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
PROTO_N ( ( placelabs_intro) )
PROTO_T ( 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
PROTO_N ( (x) )
PROTO_T ( exp x )
{
UNUSED(x);
return getexp(f_pointer(f_alloca_alignment), nilexp, 0, nilexp, nilexp,
0, 0, last_local_tag);
}
exp f_local_alloc
PROTO_N ( (arg1) )
PROTO_T ( 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
PROTO_N ( (arg1) )
PROTO_T ( exp arg1 )
{
exp res = f_local_alloc(arg1);
if (name(res)==alloca_tag) {
set_checkalloc(res);
}
return res;
}
exp f_local_free
PROTO_N ( (a, p) )
PROTO_T ( exp a X 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
PROTO_Z ()
{
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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (a, b) )
PROTO_T ( CONST void * a X CONST void * b )
{
return no(*((exp*)a)) - no(*((exp*)b));
}
exp f_make_compound
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (v, value) )
PROTO_T ( variety v X 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
PROTO_N ( (lab) )
PROTO_T ( 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
PROTO_N ( (arg1) )
PROTO_T ( 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
PROTO_N ( (v, s) )
PROTO_T ( variety v X 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
PROTO_Z ()
{
return me_null(f_local_label_value, lv_null, null_tag);
}
exp f_make_null_proc
PROTO_Z ()
{
return me_null(f_proc, proc_null, null_tag);
}
exp f_make_null_ptr
PROTO_N ( (a) )
PROTO_T ( alignment a )
{
return me_null(f_pointer(a), ptr_null, null_tag);
}
exp f_maximum
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_Z ()
{
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
PROTO_Z ()
{
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
PROTO_N ( (result_shape, params_intro, vartag) )
PROTO_T ( shape result_shape X tagshacc_list params_intro X 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
PROTO_N ( (result_shape, params_intro, vartag, body) )
PROTO_T ( shape result_shape X tagshacc_list params_intro X tagacc_option vartag X 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;
IGNORE check_id(param, param); /* apply check_id to the parameters */
} /* 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
PROTO_N ( (result_shape,prcprops,caller_intro,callee_intro) )
PROTO_T ( shape result_shape X procprops prcprops X tagshacc_list caller_intro X 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
PROTO_N ( (result_shape,prcprops,caller_intro,callee_intro,body) )
PROTO_T ( shape result_shape X procprops prcprops X
tagshacc_list caller_intro X tagshacc_list callee_intro X
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;
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 */
/* 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;
IGNORE check_id(param, param); /* apply check_id to the caller parameters */
} /* 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--)
{
IGNORE check_id(param, param); /* apply check_id to the callee parameters */
} /* 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
PROTO_N ( (n, p) )
PROTO_T ( int n X 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
PROTO_N ( (result_shape, prcprops, p, caller_params_intro, callee_params) )
PROTO_T ( shape result_shape X procprops_option prcprops X exp p X
otagexp_list caller_params_intro X callees callee_params )
{
return;
}
exp f_apply_general_proc
PROTO_N ( (result_shape, prcprops, p, caller_pars, callee_pars, postlude) )
PROTO_T ( shape result_shape X procprops prcprops X exp p X
otagexp_list caller_pars X callees callee_pars X 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
PROTO_N ( (prcprops,p,callee_params) )
PROTO_T ( procprops prcprops X exp p X 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
PROTO_N ( (arg) )
PROTO_T ( 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
PROTO_N ( (a) )
PROTO_T ( alignment a )
{
return( f_var_param_alignment);
}
exp f_set_stack_limit
PROTO_N ( (flim) )
PROTO_T ( exp flim )
{
return me_u3(f_top, flim, set_stack_limit_tag);
}
exp f_give_stack_limit
PROTO_N ( (frame_al) )
PROTO_T ( 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
PROTO_N ( (stack_base, frame_size, alloca_size) )
PROTO_T ( exp stack_base X exp frame_size X 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
PROTO_N ( (proctag) )
PROTO_T ( 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
PROTO_N ( (ec) )
PROTO_T ( error_code ec )
{
nat res;
nat_issmall(res) =1;
natint(res) = ec;
return res;
}
exp f_make_top
PROTO_Z ()
{
return getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, top_tag);
}
exp f_make_value
PROTO_N ( (s) )
PROTO_T ( shape s )
{
return me_l1(s, clear_tag);
}
exp f_minus
PROTO_N ( (ov_err, arg1, arg2) )
PROTO_T ( error_treatment ov_err X exp arg1 X 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
PROTO_N ( (md, arg1, arg2, arg3) )
PROTO_T ( transfer_mode md X exp arg1 X exp arg2 X 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
PROTO_N ( (ov_err, arg1, arg2) )
PROTO_T ( error_treatment ov_err X exp arg1 X 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
PROTO_N ( (n, arg1) )
PROTO_T ( nat n X 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
PROTO_N ( (ov_err, arg1) )
PROTO_T ( error_treatment ov_err X 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
PROTO_N ( (arg1) )
PROTO_T ( 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
PROTO_N ( (t) )
PROTO_T ( 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (v, arg1, arg2) )
PROTO_T ( variety v X exp arg1 X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (arg1) )
PROTO_T ( 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
PROTO_N ( (a, arg1) )
PROTO_T ( alignment a X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (prob, nt, dest, arg1, arg2) )
PROTO_T ( nat_option prob X ntest nt X label dest X exp arg1 X 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
PROTO_N ( (a) )
PROTO_T ( alignment a )
{
return getexp(f_offset(a, a), nilexp, 0,
nilexp, nilexp, 0, 0, val_tag);
}
exp f_or
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (ov_err, arg1, arg2) )
PROTO_T ( error_treatment ov_err X exp arg1 X 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
PROTO_N ( (prob, nt, dest, arg1, arg2) )
PROTO_T ( nat_option prob X ntest nt X label dest X exp arg1 X 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
PROTO_N ( (prob, nt, dest, arg1, arg2) )
PROTO_T ( nat_option prob X ntest nt X label dest X exp arg1 X 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
PROTO_N ( (n) )
PROTO_T ( nat n )
{
return getexp(f_top, nilexp, 0, nilexp, nilexp,
0, natint(n), prof_tag);
}
exp rem1_aux
PROTO_N ( (ov_err, arg1, arg2) )
PROTO_T ( error_treatment ov_err X exp arg1 X 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
PROTO_N ( (div0_err, ov_err, arg1, arg2) )
PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X 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
PROTO_N ( (ov_err, arg1, arg2) )
PROTO_T ( error_treatment ov_err X exp arg1 X 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
PROTO_N ( (div0_err, ov_err, arg1, arg2) )
PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X 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
PROTO_N ( (ov_err, arg1, arg2) )
PROTO_T ( error_treatment ov_err X exp arg1 X 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
PROTO_N ( (div0_err, ov_err, arg1, arg2) )
PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X 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
PROTO_N ( (repeat_label_intro, start, body) )
PROTO_T ( label repeat_label_intro X exp start X 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
PROTO_N ( (repeat_label_intro) )
PROTO_T ( 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
PROTO_N ( (arg1) )
PROTO_T ( 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (statements, result) )
PROTO_T ( exp_list statements X 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
PROTO_N ( (s) )
PROTO_T ( 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
PROTO_N ( (ov_err, arg1, arg2) )
PROTO_T ( error_treatment ov_err X exp arg1 X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_N ( (acc, name_intro, init, body) )
PROTO_T ( access_option acc X tag name_intro X exp init X 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
PROTO_N ( (acc, name_intro, init) )
PROTO_T ( access_option acc X tag name_intro X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( exp arg1 X 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
PROTO_Z ()
{
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
PROTO_N ( (e) )
PROTO_T ( exp e )
{
has_lv = 1;
return me_u3(f_bottom, e, return_to_label_tag);
}
nat f_computed_nat
PROTO_N ( (arg) )
PROTO_T ( 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
PROTO_N ( (n) )
PROTO_T ( tdfint n )
{
return n;
}
void init_nat
PROTO_Z ()
{
return;
}
nat f_dummy_nat;
void init_ntest
PROTO_Z ()
{
return;
}
void init_otagexp
PROTO_Z ()
{
return;
}
void init_procprops
PROTO_Z ()
{
return;
}
ntest f_dummy_ntest;
void init_rounding_mode
PROTO_Z ()
{
return;
}
rounding_mode f_dummy_rounding_mode;
shape f_bitfield
PROTO_N ( (bf_var) )
PROTO_T ( bitfield_variety bf_var )
{
return getshape(bf_var.has_sign, const_al1, const_al1,
BF_ALIGN, bf_var.bits, bitfhd);
}
shape f_compound
PROTO_N ( (off) )
PROTO_T ( 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
PROTO_N ( (fv) )
PROTO_T ( 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
PROTO_N ( (var) )
PROTO_T ( variety var )
{
return var;
}
shape f_nof
PROTO_N ( (n, s) )
PROTO_T ( nat n X 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
PROTO_N ( (arg1, arg2) )
PROTO_T ( alignment arg1 X 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
PROTO_N ( (arg) )
PROTO_T ( 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
PROTO_Z ()
{
/* 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
PROTO_N ( (arg) )
PROTO_T ( 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
PROTO_N ( (neg, n) )
PROTO_T ( bool neg X 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
PROTO_N ( (neg, n) )
PROTO_T ( tdfbool neg X tdfint n )
{
return f_snat_from_nat(neg, n);
}
void init_signed_nat
PROTO_Z ()
{
return;
}
signed_nat f_dummy_signed_nat;
string f_dummy_string;
void init_string
PROTO_Z ()
{
return;
}
string f_concat_string
PROTO_N ( (a1, a2) )
PROTO_T ( string a1 X 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
PROTO_N ( (s) )
PROTO_T ( tdfstring s )
{
return s;
}
tagshacc f_make_tagshacc
PROTO_N ( (sha, visible, tg_intro) )
PROTO_T ( shape sha X access_option visible X tag tg_intro )
{
tagshacc res;
res.sha = sha;
res.visible = visible;
res.tg = tg_intro;
return res;
}
void init_tagshacc
PROTO_Z ()
{
return;
}
transfer_mode f_dummy_transfer_mode;
transfer_mode f_add_modes
PROTO_N ( (md1, md2) )
PROTO_T ( transfer_mode md1 X transfer_mode md2 )
{
return md1 | md2;
}
version f_user_info
PROTO_N ( (t) )
PROTO_T ( tdfident t )
{
version res;
UNUSED(t);
res.major_version = MAJOR_VERSION;
res.minor_version = MINOR_VERSION;
return res;
}
variety f_var_limits
PROTO_N ( (lower_bound, upper_bound) )
PROTO_T ( signed_nat lower_bound X 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
PROTO_N ( (sig, bits) )
PROTO_T ( bool sig X 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
PROTO_Z ()
{
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
PROTO_N ( (major_version, minor_version) )
PROTO_T ( tdfint major_version X 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
PROTO_N ( (version_info) )
PROTO_T ( version_props version_info )
{
UNUSED(version_info);
return 0;
}
exp_list new_exp_list
PROTO_N ( (n) )
PROTO_T ( int n )
{
exp_list res;
UNUSED(n);
res.number = 0;;
res.start = nilexp;
res.end = nilexp;
return res;
}
exp_list add_exp_list
PROTO_N ( (list, elem, index) )
PROTO_T ( exp_list list X exp elem X 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
PROTO_N ( (n) )
PROTO_T ( int n )
{
UNUSED(n);
/* bro(global_case) = nilexp;
return 0;
*/
return nilexp;
}
caselim_list add_caselim_list
PROTO_N ( (list, elem, index) )
PROTO_T ( caselim_list list X caselim elem X 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
PROTO_N ( (n) )
PROTO_T ( int n )
{
label_list res;
res.elems = (label *)xcalloc(n, sizeof(label));
res.number = n;
return res;
}
label_list add_label_list
PROTO_N ( (list, elem, index) )
PROTO_T ( label_list list X label elem X 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
PROTO_N ( (n) )
PROTO_T ( 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
PROTO_N ( (list, elem, index) )
PROTO_T ( tagshacc_list list X tagshacc elem X 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
PROTO_N ( (n) )
PROTO_T ( int n )
{
UNUSED(n);
return 0;
}
static int version_printed = 0;
version_list add_version_list
PROTO_N ( (list, elem, index) )
PROTO_T ( version_list list X version elem X 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
PROTO_N ( (acc) )
PROTO_T ( access acc )
{
return acc;
}
string_option no_string_option;
string_option yes_string_option
PROTO_N ( (s) )
PROTO_T ( string s )
{
string_option res;
res.val = s;
res.present = 1;
return res;
}
void init_string_option
PROTO_Z ()
{
no_string_option.present = 0;
}
tagacc_option no_tagacc_option;
tagacc_option yes_tagacc_option
PROTO_N ( (elem) )
PROTO_T ( tagacc elem )
{
tagacc_option res;
res.val = elem;
res.present = 1;
return res;
}
void init_tagacc_option
PROTO_Z ()
{
no_tagacc_option.present = 0;
return;
}
nat_option no_nat_option;
nat_option yes_nat_option
PROTO_N ( (n) )
PROTO_T ( nat n )
{
nat_option res;
res.val = n;
res.present = 1;
return res;
}
void init_nat_option
PROTO_Z ()
{
no_nat_option.present = 0;
return;
}
void init_tagacc
PROTO_Z ()
{
return;
}
tagacc f_make_tagacc
PROTO_N ( (tg, acc) )
PROTO_T ( tag tg X access_option acc )
{
tagacc res;
res.tg = tg;
res.visible = acc;
return res;
}
void init_transfer_mode
PROTO_Z ()
{
return;
}
void init_version_props
PROTO_Z ()
{
global_version.major_version = 0;
global_version.minor_version = 0;
return;
}
void init_version
PROTO_Z ()
{
return;
}
void init_access_option
PROTO_Z ()
{
return;
}
static int seq_n = 0;
char * init_NAME
PROTO_N ( (good_name) )
PROTO_T ( 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
PROTO_Z ()
{
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
PROTO_N ( (e) )
PROTO_T ( 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
PROTO_Z ()
{
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);
}
}