Rev 2 | 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: release $
$Date: 1998/01/17 15:55:47 $
$Revision: 1.1.1.1 $
$Log: me_fns.c,v $
* Revision 1.1.1.1 1998/01/17 15:55:47 release
* First version to be checked into rolling release.
*
* Revision 1.4 1996/10/29 10:10:51 currie
* 512 bit alignment for hppa
*
* Revision 1.3 1995/07/05 09:26:35 currie
* continue wrong
*
* Revision 1.2 1995/05/05 08:10:56 currie
* initial_value + signtures
*
* Revision 1.1 1995/04/06 10:44:05 currie
* Initial revision
*
***********************************************************************/
#include "config.h"
#include "common_types.h"
#include "exp.h"
#include "expmacs.h"
#include "table_fns.h"
#include "externs.h"
#include "installglob.h"
#include "tags.h"
#include "install_fns.h"
#include "check.h"
#include "messages_c.h"
#include "shapemacs.h"
#include "basicread.h"
#include "natmacs.h"
#include "me_fns.h"
/* a collection of useful procedures for makeing up exps */
/* PROCEDURES */
exp me_obtain
PROTO_N ( (id) )
PROTO_T ( exp id )
{
shape sha = (son(id)==nilexp)?sh(id):sh(son(id));
exp n;
n = getexp((isvar(id)) ? f_pointer(align_of(sha)) : sha,
nilexp, 0, id, pt(id), 0, 0, name_tag);
++no(id);
pt(id) = n;
return n;
}
exp me_startid
PROTO_N ( (sha, def, isv) )
PROTO_T ( shape sha X exp def X int isv )
{
exp r = getexp(sha, nilexp, 0, def, nilexp, 0, 0, ident_tag);
if (isv)
setvar(r);
return r;
}
exp me_start_clearvar
PROTO_N ( (sha, shb) )
PROTO_T ( shape sha X shape shb )
{
exp init = getexp(shb, nilexp, 0, nilexp, nilexp, 0, 0, clear_tag);
exp var = getexp(sha, nilexp, 0, init, nilexp, 0, 0, ident_tag);
setvar(var);
return var;
}
exp me_complete_id
PROTO_N ( (id, body) )
PROTO_T ( exp id X exp body )
{
clearlast(son(id));
bro(son(id)) = body;
setlast(body);
bro(body) = id;
sh(id) = sh(body);
return hold_check(id);
}
exp me_u1
PROTO_N ( (ov_err, arg1, nm) )
PROTO_T ( error_treatment ov_err X exp arg1 X unsigned char nm )
{
exp r = getexp (sh (arg1), nilexp, 0, arg1, nilexp,
0, 0, nm);
seterrhandle(r, ov_err.err_code);
if (isov(r))
setjmp_dest(r, get_lab(ov_err.jmp_dest));
setfather (r, arg1);
return r;
}
exp me_u2
PROTO_N ( (arg1, nm) )
PROTO_T ( exp arg1 X unsigned char nm )
{
exp r = getexp (sh (arg1), nilexp, 0, arg1, nilexp, 0, 0, nm);
setfather (r, arg1);
return r;
}
exp me_u3
PROTO_N ( (sha, arg1, nm) )
PROTO_T ( shape sha X exp arg1 X unsigned char nm )
{
exp r = getexp (sha, nilexp, 0, arg1, nilexp, 0, 0, nm);
setfather (r, arg1);
return r;
}
exp me_b1
PROTO_N ( (ov_err, arg1, arg2, nm) )
PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 X unsigned char nm )
{
exp r = getexp (sh (arg1), nilexp, 0, arg1, nilexp,
0, 0, nm);
seterrhandle(r, ov_err.err_code);
setbro(arg1, arg2);
clearlast(arg1);
if (isov(r))
setjmp_dest(r, get_lab(ov_err.jmp_dest));
setfather (r, arg2);
return r;
}
exp me_b2
PROTO_N ( (arg1, arg2, nm) )
PROTO_T ( exp arg1 X exp arg2 X unsigned char nm )
{
exp r = getexp (sh (arg1), nilexp, 0, arg1, nilexp, 0, 0, nm);
setbro(arg1, arg2);
clearlast(arg1);
setfather (r, arg2);
return r;
}
exp me_b3
PROTO_N ( (sha, arg1, arg2, nm) )
PROTO_T ( shape sha X exp arg1 X exp arg2 X unsigned char nm )
{
exp r = getexp (sha, nilexp, 0, arg1, nilexp, 0, 0, nm);
setbro(arg1, arg2);
clearlast(arg1);
setfather (r, arg2);
return r;
}
exp me_c1
PROTO_N ( (sha, ov_err, arg1, nm) )
PROTO_T ( shape sha X error_treatment ov_err X exp arg1 X unsigned char nm )
{
exp r = getexp (sha, nilexp, 0, arg1, nilexp,
0, 0, nm);
seterrhandle(r, ov_err.err_code);
if (isov(r))
setjmp_dest(r, get_lab(ov_err.jmp_dest));
setfather (r, arg1);
return r;
}
exp me_c2
PROTO_N ( (sha, arg1, nm) )
PROTO_T ( shape sha X exp arg1 X unsigned char nm )
{
exp r = getexp (sha, nilexp, 0, arg1, nilexp, 0, 0, nm);
setfather (r, arg1);
return r;
}
exp me_l1
PROTO_N ( (s, nm) )
PROTO_T ( shape s X unsigned char nm )
{
exp r = getexp (s, nilexp, 0, nilexp, nilexp, 0, 0, nm);
return r;
}
exp me_q1_aux
PROTO_N ( (prob, nt, lab, arg1, arg2, nm) )
PROTO_T ( nat_option prob X ntest nt X exp lab X exp arg1 X exp arg2 X unsigned char nm )
{
exp r;
r = getexp (f_top, nilexp, 0, arg1, lab, 0, 0, nm);
no(r) = (prob.present) ? natint(prob.val) : 1000;
settest_number(r, nt);
setbro(arg1, arg2);
clearlast(arg1);
++no(son(lab));
setfather (r, arg2);
return r;
}
exp me_q1
PROTO_N ( (prob, nt, dest, arg1, arg2, nm) )
PROTO_T ( nat_option prob X ntest nt X label dest X exp arg1 X exp arg2 X unsigned char nm )
{
return me_q1_aux(prob, nt, get_lab(dest), arg1, arg2, nm);
}
exp me_q2_aux
PROTO_N ( (prob, err, nt, lab, arg1, arg2, nm) )
PROTO_T ( nat_option prob X error_treatment err X ntest nt X exp lab X exp arg1 X exp arg2 X unsigned char nm )
{
exp r;
UNUSED(err);
r = getexp (f_top, nilexp, 0, arg1, lab, 0, 0, nm);
no(r) = (prob.present) ? natint(prob.val) : 1000;
settest_number(r, nt);
setbro(arg1, arg2);
clearlast(arg1);
++no(son(lab));
setfather (r, arg2);
return r;
}
exp me_q2
PROTO_N ( (prob, err, nt, dest, arg1, arg2, nm) )
PROTO_T ( nat_option prob X error_treatment err X ntest nt X label dest X exp arg1 X exp arg2 X unsigned char nm )
{
return me_q2_aux(prob, err, nt, get_lab(dest), arg1, arg2, nm);
}
exp me_shint
PROTO_N ( (sha, i) )
PROTO_T ( shape sha X int i )
{
return getexp(sha, nilexp, 0, nilexp, nilexp, 0, i, val_tag);
}
exp me_null
PROTO_N ( (sha, i, nm) )
PROTO_T ( shape sha X int i X unsigned char nm )
{
return getexp(sha, nilexp, 0, nilexp, nilexp, 0, i, nm);
}
exp me_b4
PROTO_N ( (div0_err, ov_err, arg1, arg2, nm) )
PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X exp arg2 X unsigned char nm )
{
exp id, tst, divexp, seq;
if (div0_err.err_code != 4)
return me_b1(ov_err, arg1, arg2, nm);
id = me_startid(sh(arg1), arg2, 0);
divexp = me_b1(ov_err, arg1, me_obtain(id), nm);
tst = me_q1(no_nat_option, f_not_equal, div0_err.jmp_dest,
me_obtain(id), me_shint(sh(arg1), 0), test_tag);
seq = me_b2(me_u2(tst, 0), divexp, seq_tag);
return me_complete_id(id, seq);
}
void note_repeat
PROTO_N ( (r) )
PROTO_T ( exp r )
{
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;
pt(r) = crt_repeat;
son (crt_repeat) = r;
crt_repeat = bro(crt_repeat);
return;
}
/* the result is an alignment for something of which the
addresses must be divisible by n bits */
alignment long_to_al
PROTO_N ( (n) )
PROTO_T ( int n )
{
switch (n) {
case 0:
case 1: return const_al1;
case 8: return const_al8;
case 16: return const_al16;
case 32: return const_al32;
case 64: return const_al64;
case 512: return const_al512;
default: failer(BAD_LONG_AL);
return const_al32;
};
}
/* the shape describes an integer */
int is_integer
PROTO_N ( (s) )
PROTO_T ( shape s )
{
return name(s) >= scharhd && name(s) <= u64hd;
}
/* the shape describes a floating point number */
int is_float
PROTO_N ( (s) )
PROTO_T ( shape s )
{
return name(s) >= shrealhd && name(s) <= doublehd;
}
int is_complex
PROTO_N ( (s) )
PROTO_T ( shape s )
{
#if substitute_complex
return (name(s) == cpdhd);
#else
return name(s) >= shcomplexhd && name(s) <= complexdoublehd;
#endif
}
floating_variety float_to_complex_var
PROTO_N ( (f) )
PROTO_T ( floating_variety f )
{
return f+3;
}
floating_variety complex_to_float_var
PROTO_N ( (f) )
PROTO_T ( floating_variety f )
{
return f-3;
}