Blame | 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.
*/
/* $Id: spec_tok.c,v 1.1.1.1 1998/01/17 15:56:01 release Exp $ */
#ifndef lint
static char vcid[] = "$Id: spec_tok.c,v 1.1.1.1 1998/01/17 15:56:01 release Exp $";
#endif /* lint */
/*
$Log: spec_tok.c,v $
* Revision 1.1.1.1 1998/01/17 15:56:01 release
* First version to be checked into rolling release.
*
* Revision 1.5 1995/09/15 16:23:48 john
* New exception handling
*
* Revision 1.4 1995/09/13 11:03:49 john
* Fix
*
* Revision 1.3 1995/09/13 08:23:16 john
* Addition for exception handling
*
* Revision 1.2 1995/05/16 10:55:42 john
* Removed unused code.
*
* Revision 1.1.1.1 1995/03/23 10:39:36 john
* Entered into CVS
*
* Revision 1.8 1995/01/26 13:49:51 john
* Removed unused variable
*
*/
#include "config.h"
#include "common_types.h"
#include "basicread.h"
#include "tags.h"
#include "exp.h"
#include "expmacs.h"
#include "diag_fns.h"
#include "flags.h"
#include "check.h"
#include "me_fns.h"
#include "externs.h"
#include "installglob.h"
#include "messages_r.h"
#include "main_reads.h"
#include "install_fns.h"
#include "c_arith_type.h"
#include "natmacs.h"
#include "spec_tok.h"
#include "shapemacs.h"
#include "szs_als.h"
#include "new_tags.h"
/* intercepts specially defined tokens */
#define MAX_INT 2147483647
#define MIN_INT (-MAX_INT-1)
#define UMAX_INT 4294967295U
extern shape f_off64_64;
extern shape f_off32_32;
/*
This function returns a component at offset 'align' from the
compound given in e.
*/
exp get_component
PROTO_N ( ( e,shc,align,size,nm,offshape,offset ) )
PROTO_T ( exp e X alignment shc X alignment align X int size X int nm X shape offshape X int offset )
{
exp offsetexp /* offset in compound for required component */
= getexp(offshape,nilexp,0,nilexp,nilexp,0,offset,val_tag);
shape resshape /* shape of component */
= getshape(1,shc,shc,align,size,nm);
return hold_check(f_component(resshape,hold_check(me_u3(sh(son(son(e))),e,cont_tag)),offsetexp));
}
tokval special_token
PROTO_N ( ( t, pars, sortcode, done ) )
PROTO_T ( token t X bitstream pars X int sortcode X int *done )
{
tokval tkv;
UNUSED(sortcode);
if (t -> tok_name == (char*)0) {
SET(tkv); /* call looks at done to see if result is meaningful */
return tkv;
}
if (!strcmp(t -> tok_name, "~alloca")) {
exp arg1;
place old_place;
old_place = keep_place();
set_place(pars);
arg1 = hold_check(d_exp());
set_place(old_place);
tkv.tk_exp = hold_check(me_u3(f_pointer(long_to_al(8)),
arg1, alloca_tag));
*done = 1;
has_alloca = 1;
return tkv;
}
if(!strcmp(t->tok_name,"__builtin_isfloat")){
/* builtin function taking a TYPE argument and returning
TRUE if the argument is float,double or long double and FALSE
otherwise */
place old_place;
shape arg;
signed_nat lower,upper,resval;
old_place=keep_place();
set_place(pars);
arg = d_shape();
resval.issmall=lower.issmall=upper.issmall=1;
resval.negative=lower.negative=upper.negative=0;
lower.signed_nat_val.small_s_nat=MIN_INT;
upper.signed_nat_val.small_s_nat=MAX_INT;
if(is_floating(name(arg))){
resval.signed_nat_val.small_s_nat=1;
}
else{
resval.signed_nat_val.small_s_nat=0;
}
tkv.tk_exp = f_make_int(slongsh,resval);
set_place(old_place);
*done=1;
return tkv;
}
if(!strcmp(t->tok_name, "__builtin_va_token")){
tkv.tk_exp = getexp(f_off32_32,nilexp,0,nilexp,nilexp,0,0,val_tag);
set_vararg(tkv.tk_exp);
*done = 1;
return tkv;
}
if(!strcmp(t->tok_name, "~Sync_handler")){
tkv.tk_exp = getexp(f_top,nilexp,0,nilexp,nilexp,0,0,special_tag);
*done = 1;
return tkv;
}
if(!strcmp(t->tok_name, "__alpha_special")){
/* This is a means of invoking alpha assembler instructions from a
TDF file */
exp arg;
place old_place = keep_place();
set_place(pars);
arg = d_exp();
Assert(name(arg) == val_tag);
if(no(arg) == 0){
/* trapb : used to ensure that all pending execptions have been raised
before continuing */
tkv.tk_exp = getexp(f_top,nilexp,0,nilexp,nilexp,0,0,special_tag);
*done = 1;
}
else{
failer("Unsupported argument to token __alpha_special");
tkv.tk_exp = getexp(f_top,nilexp,0,nilexp,nilexp,0,0,null_tag);
*done = 1;
}
set_place(old_place);
return tkv;
}
if(!strcmp(t->tok_name, "__builtin_va_start")){
/* builtin function taking 3 arguments: a va_list, a va_alist,
and an integer i.e a compound(ptrhd,slonghd),
an integer(s64shd) and an integer(slonghd).
The pointer field of the compound is set equal to the 64
bit integer, and the integer field is set to 8.
*/
place old_place;
exp arg1,arg2,arg3; /* parameters of the token */
exp_list list; /* list of exps used to construct the
result sequence */
exp res = f_make_top(); /* the result part of the sequence */
exp assignment1,assignment2; /* the two assignment operations */
exp component1;
exp component2; /* the components of the exp */
exp copy_of_compound;
old_place = keep_place();
set_place(pars);
arg1 = d_exp();
arg2 = d_exp();
arg3 = d_exp(); /* don't care */
/* here we start to perform the transformation. We must obtain
the compound variable of arg1 and apply the component
operation to separate out the pointer and integer for use
in subsequent assignments.
*/
set_vararg(arg1);
copy_of_compound = copyexp(arg1);
component1 = get_component(arg1,const_al64,PTR_ALIGN,PTR_SZ,
ptrhd,f_off64_64,0);
component2 = get_component(copy_of_compound,const_al32,SLONG_ALIGN,
SLONG_SZ,slonghd,f_off32_32,64);
assignment1 = f_assign(component1,arg2);
assignment2 = f_assign(component2,getexp(f_off32_32,nilexp,0,nilexp,nilexp,
0,0,val_tag));
bro(assignment1)=assignment2;
list.start = assignment1;
list.end = assignment2;
list.number = 2;
tkv.tk_exp = f_sequence(list,res);
kill_exp(arg3,arg3);
set_place(old_place);
*done=1;
return tkv;
}
if (!strcmp(t -> tok_name, "~exp_to_source") ||
!strcmp(t -> tok_name, "~diag_id_scope") ||
!strcmp(t -> tok_name, "~diag_type_scope") ||
!strcmp(t -> tok_name, "~diag_tag_scope")) {
place old_place;
old_place = keep_place();
set_place(pars);
tkv.tk_exp = hold_check(d_exp());
*done = 1;
if (!diagnose){
set_place(old_place);
return tkv;
}
if (!strcmp(t -> tok_name, "~exp_to_source")){
exp r;
diag_info * di = read_exp_to_source();
crt_lno = natint(di -> data.source.end.line_no);
crt_charno = natint(di -> data.source.end.char_off);
crt_flnm = di -> data.source.beg.file->file.ints.chars;
r = getexp(sh(tkv.tk_exp), nilexp, 0, tkv.tk_exp, nilexp,
1, 0, diagnose_tag);
setfather(r, tkv.tk_exp);
dno(r) = di;
tkv.tk_exp = r;
set_place(old_place);
return tkv;
}
if (!strcmp(t -> tok_name, "~diag_id_scope")){
exp r;
diag_info * di = read_diag_id_scope();
r = getexp(sh(tkv.tk_exp), nilexp, 0, tkv.tk_exp, nilexp,
2, 0, diagnose_tag);
setfather(r, tkv.tk_exp);
dno(r) = di;
tkv.tk_exp = r;
set_place(old_place);
return tkv;
}
if (!strcmp(t -> tok_name, "~diag_type_scope")){
exp r;
diag_info * di = read_diag_type_scope();
r = getexp(sh(tkv.tk_exp), nilexp, 0, tkv.tk_exp, nilexp,
3, 0, diagnose_tag);
setfather(r, tkv.tk_exp);
dno(r) = di;
tkv.tk_exp = r;
set_place(old_place);
return tkv;
}
if (!strcmp(t -> tok_name, "~diag_tag_scope")){
exp r;
diag_info * di = read_diag_tag_scope();
r = getexp(sh(tkv.tk_exp), nilexp, 0, tkv.tk_exp, nilexp,
4, 0, diagnose_tag);
setfather(r, tkv.tk_exp);
dno(r) = di;
tkv.tk_exp = r;
set_place(old_place);
return tkv;
}
}
SET(tkv); /* call looks at done to see if result is meaningful */
return tkv;
}