home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.cs.arizona.edu
/
ftp.cs.arizona.edu.tar
/
ftp.cs.arizona.edu
/
icon
/
historic
/
v92.tgz
/
v92.tar
/
v92
/
src
/
rtt
/
rttout.c
< prev
next >
Wrap
C/C++ Source or Header
|
1996-03-22
|
121KB
|
3,843 lines
#include "rtt.h"
#define NotId 0 /* declarator is not simple identifier */
#define IsId 1 /* declarator is simple identifier */
#define OrdFunc -1 /* indicates ordinary C function - non-token value */
/*
* VArgAlwnc - allowance for the variable part of an argument list in the
* most general version of an operation. If it is too small, storage must
* be malloced. 3 was chosen because over 90 percent of all writes have
* 3 or fewer arguments. It is possible that 4 would be a better number,
* but 5 is probably overkill.
*/
#define VArgAlwnc 3
/*
* Prototypes for static functions.
*/
hidden novalue cnv_fnc Params((struct token *t, int typcd,
struct node *src, struct node *dflt,
struct node *dest, int indent));
hidden novalue chk_conj Params((struct node *n));
hidden novalue chk_nl Params((int indent));
hidden novalue chk_rsltblk Params((int indent));
hidden novalue comp_def Params((struct node *n));
hidden int does_call Params((struct node *expr));
hidden novalue failure Params((int indent, int brace));
hidden novalue interp_def Params((struct node *n));
hidden int len_sel Params((struct node *sel,
struct parminfo *strt_prms,
struct parminfo *end_prms, int indent));
hidden novalue line_dir Params((int nxt_line, char *new_fname));
hidden int only_proto Params((struct node *n));
hidden novalue parm_locs Params((struct sym_entry *op_params));
hidden novalue parm_tnd Params((struct sym_entry *sym));
hidden novalue prt_runerr Params((struct token *t, struct node *num,
struct node *val, int indent));
hidden novalue prt_tok Params((struct token *t, int indent));
hidden novalue prt_var Params((struct node *n, int indent));
hidden int real_def Params((struct node *n));
hidden int retval_dcltor Params((struct node *dcltor, int indent));
hidden novalue ret_value Params((struct token *t, struct node *n,
int indent));
hidden novalue ret_1_arg Params((struct token *t, struct node *args,
int typcd, char *vwrd_asgn, char *arg_rep,
int indent));
hidden int rt_walk Params((struct node *n, int indent, int brace));
hidden novalue spcl_start Params((struct sym_entry *op_params));
hidden int tdef_or_extr Params((struct node *n));
hidden novalue tend_ary Params((int n));
hidden novalue tend_init Params((noargs));
hidden novalue tnd_var Params((struct sym_entry *sym, char *strct_ptr, char *access, int indent));
hidden novalue tok_line Params((struct token *t, int indent));
hidden novalue typ_asrt Params((int typcd, struct node *desc,
struct token *tok, int indent));
hidden int typ_case Params((struct node *var, struct node *slct_lst,
struct node *dflt,
int (*walk)Params((struct node *n, int xindent,
int brace)), int maybe_var, int indent));
hidden novalue untend Params((int indent));
extern char *progname;
#if MVS
extern char *src_file_nm;
#endif /* MVS */
int op_type = OrdFunc; /* type of operation */
char lc_letter; /* f = function, o = operator, k = keyword */
char uc_letter; /* F = function, O = operator, K = keyword */
char prfx1; /* 1st char of unique prefix for operation */
char prfx2; /* 2nd char of unique prefix for operation */
char *fname = ""; /* current source file name */
int line = 0; /* current source line number */
int nxt_sbuf; /* next string buffer index */
int nxt_cbuf; /* next cset buffer index */
int abs_ret = SomeType; /* type from abstract return(s) */
int nl = 0; /* flag indicating the a new-line should be output */
static int no_nl = 0; /* flag to suppress line directives */
static int ntend; /* number of tended descriptor needed */
static char *tendstrct; /* expression to access struct of tended descriptors */
static char *rslt_loc; /* expression to access result location */
static int varargs = 0; /* flag: operation takes variable number of arguments */
static int no_ret_val; /* function has return statement with no value */
static struct node *fnc_head; /* header of function being "copied" to output */
/*
* chk_nl - if a new-line is required, output it and indent the next line.
*/
static novalue chk_nl(indent)
int indent;
{
int col;
if (nl) {
/*
* new-line required.
*/
putc('\n', out_file);
++line;
for (col = 0; col < indent; ++col)
putc(' ', out_file);
nl = 0;
}
}
/*
* line_dir - Output a line directive.
*/
static novalue line_dir(nxt_line, new_fname)
int nxt_line;
char *new_fname;
{
char *s;
/*
* Make sure line directives are desired in the output. Normally,
* blank lines surround the directive for readability. However,`
* a preceding blank line is suppressed at the beginning of the
* output file. In addition, a blank line is suppressed after
* the directive if it would force the line number on the directive
* to be 0.
*/
if (line_cntrl) {
fprintf(out_file, "\n");
if (line != 0)
fprintf(out_file, "\n");
if (nxt_line == 1)
fprintf(out_file, "#line %d \"", nxt_line);
else
fprintf(out_file, "#line %d \"", nxt_line - 1);
for (s = new_fname; *s != '\0'; ++s) {
if (*s == '"' || *s == '\\')
putc('\\', out_file);
putc(*s, out_file);
}
if (nxt_line == 1)
fprintf(out_file, "\"");
else
fprintf(out_file, "\"\n");
nl = 1;
--nxt_line;
}
else if ((nxt_line > line || fname != new_fname) && line != 0) {
/*
* Line directives are disabled, but we are in a situation where
* one or two new-lines are desirable.
*/
if (nxt_line > line + 1 || fname != new_fname)
fprintf(out_file, "\n");
nl = 1;
--nxt_line;
}
line = nxt_line;
fname = new_fname;
}
/*
* prt_str - print a string to the output file, possibly preceded by
* a new-line and indenting.
*/
novalue prt_str(s, indent)
char *s;
int indent;
{
chk_nl(indent);
fprintf(out_file, "%s", s);
}
/*
* tok_line - determine if a line directive is needed to synchronize the
* output file name and line number with an input token.
*/
static novalue tok_line(t, indent)
struct token *t;
int indent;
{
int nxt_line;
/*
* Line directives may be suppressed at certain points during code
* output. This is done either by rtt itself using the no_nl flag, or
* for macros, by the preprocessor using a flag in the token.
*/
if (no_nl)
return;
if (t->flag & LineChk) {
/*
* If blank lines can be used in place of a line directive and no
* more than 3 are needed, use them. If the line number and file
* name are correct, but we need a new-line, we must output a
* line directive so the line number is reset after the "new-line".
*/
nxt_line = t->line;
if (fname != t->fname || line > nxt_line || line + 2 < nxt_line)
line_dir(nxt_line, t->fname);
else if (nl && line == nxt_line)
line_dir(nxt_line, t->fname);
else if (line != nxt_line) {
nl = 1;
--nxt_line;
while (line < nxt_line) { /* above condition limits # interactions */
putc('\n', out_file);
++line;
}
}
}
chk_nl(indent);
}
/*
* prt_tok - print a token.
*/
static novalue prt_tok(t, indent)
struct token *t;
int indent;
{
char *s;
tok_line(t, indent); /* synchronize file name and line number */
/*
* Most tokens contain a string of their exact image. However, string
* and character literals lack the surrounding quotes.
*/
s = t->image;
switch (t->tok_id) {
case StrLit:
fprintf(out_file, "\"%s\"", s);
break;
case LStrLit:
fprintf(out_file, "L\"%s\"", s);
break;
case CharConst:
fprintf(out_file, "'%s'", s);
break;
case LCharConst:
fprintf(out_file, "L'%s'", s);
break;
default:
fprintf(out_file, "%s", s);
}
}
/*
* untend - output code to removed the tended descriptors in this
* function from the global tended list.
*/
static novalue untend(indent)
int indent;
{
ForceNl();
prt_str("tend = ", indent);
fprintf(out_file, "%s.previous;", tendstrct);
ForceNl();
/*
* For varargs operations, the tended structure might have been
* malloced. If so, it must be freed.
*/
if (varargs) {
prt_str("if (r_tendp != (struct tend_desc *)&r_tend)", indent);
ForceNl();
prt_str("free((pointer)r_tendp);", 2 * indent);
}
}
/*
* tnd_var - output an expression to accessed a tended variable.
*/
static novalue tnd_var(sym, strct_ptr, access, indent)
struct sym_entry *sym;
char *strct_ptr;
char *access;
int indent;
{
/*
* A variable that is a specific block pointer type must be cast
* to that pointer type in such a way that it can be used as either
* an lvalue or an rvalue: *(struct b_??? **)&???.vword.bptr
*/
if (strct_ptr != NULL) {
prt_str("(*(struct ", indent);
prt_str(strct_ptr, indent);
prt_str("**)&", indent);
}
if (sym->id_type & ByRef) {
/*
* The tended variable is being accessed indirectly through
* a pointer (that is, it is accessed as the argument to a body
* function); dereference its identifier.
*/
prt_str("(*", indent);
prt_str(sym->image, indent);
prt_str(")", indent);
}
else {
if (sym->t_indx >= 0) {
/*
* The variable is accessed directly as part of the tended structure.
*/
prt_str(tendstrct, indent);
fprintf(out_file, ".d[%d]", sym->t_indx);
}
else {
/*
* This is a direct access to an operation parameter.
*/
prt_str("r_args[", indent);
fprintf(out_file, "%d]", sym->u.param_info.param_num + 1);
}
}
prt_str(access, indent); /* access the vword for tended pointers */
if (strct_ptr != NULL)
prt_str(")", indent);
}
/*
* prt_var - print a variable.
*/
static novalue prt_var(n, indent)
struct node *n;
int indent;
{
struct token *t;
struct sym_entry *sym;
t = n->tok;
tok_line(t, indent); /* synchronize file name and line nuber */
sym = n->u[0].sym;
switch (sym->id_type & ~ByRef) {
case TndDesc:
/*
* Simple tended descriptor.
*/
tnd_var(sym, NULL, "", indent);
break;
case TndStr:
/*
* Tended character pointer.
*/
tnd_var(sym, NULL, ".vword.sptr", indent);
break;
case TndBlk:
/*
* Tended block pointer.
*/
tnd_var(sym, sym->u.tnd_var.blk_name, ".vword.bptr",
indent);
break;
case RtParm:
case DrfPrm:
switch (sym->u.param_info.cur_loc) {
case PrmTend:
/*
* Simple tended parameter.
*/
tnd_var(sym, NULL, "", indent);
break;
case PrmCStr:
/*
* Parameter converted to a (tended) string.
*/
tnd_var(sym, NULL, ".vword.sptr", indent);
break;
case PrmInt:
/*
* Parameter converted to a C integer.
*/
chk_nl(indent);
fprintf(out_file, "r_i%d", sym->u.param_info.param_num);
break;
case PrmDbl:
/*
* Parameter converted to a C double.
*/
chk_nl(indent);
fprintf(out_file, "r_d%d", sym->u.param_info.param_num);
break;
default:
errt2(t, "Conflicting conversions for: ", t->image);
}
break;
case RtParm | VarPrm:
case DrfPrm | VarPrm:
/*
* Parameter representing variable part of argument list.
*/
prt_str("(&", indent);
if (sym->t_indx >= 0)
fprintf(out_file, "%s.d[%d])", tendstrct, sym->t_indx);
else
fprintf(out_file, "r_args[%d])", sym->u.param_info.param_num + 1);
break;
case VArgLen:
/*
* Length of variable part of argument list.
*/
prt_str("(r_nargs - ", indent);
fprintf(out_file, "%d)", params->u.param_info.param_num);
break;
case RsltLoc:
/*
* "result" the result location of the operation.
*/
prt_str(rslt_loc, indent);
break;
case Label:
/*
* Statement label.
*/
prt_str(sym->image, indent);
break;
case OtherDcl:
/*
* Some other type of variable: accessed by identifier. If this
* is a body function, it may be passed by reference and need
* a level of pointer dereferencing.
*/
if (sym->id_type & ByRef)
prt_str("(*",indent);
prt_str(sym->image, indent);
if (sym->id_type & ByRef)
prt_str(")",indent);
break;
}
}
/*
* does_call - determine if an expression contains a function call by
* walking its syntax tree.
*/
static int does_call(expr)
struct node *expr;
{
int n_subs;
int i;
if (expr == NULL)
return 0;
if (expr->nd_id == BinryNd && expr->tok->tok_id == ')')
return 1; /* found a function call */
switch (expr->nd_id) {
case ExactCnv: case PrimryNd: case SymNd:
n_subs = 0;
break;
case CompNd:
/*
* Check field 0 below, field 1 is not a subtree, check field 2 here.
*/
n_subs = 1;
if (does_call(expr->u[2].child))
return 1;
break;
case IcnTypNd: case PstfxNd: case PreSpcNd: case PrefxNd:
n_subs = 1;
break;
case AbstrNd: case BinryNd: case CommaNd: case ConCatNd: case LstNd:
case StrDclNd:
n_subs = 2;
break;
case TrnryNd:
n_subs = 3;
break;
case QuadNd:
n_subs = 4;
break;
default:
fprintf(stdout, "rtt internal error: unknown node type\n");
exit(ErrorExit);
}
for (i = 0; i < n_subs; ++i)
if (does_call(expr->u[i].child))
return 1;
return 0;
}
/*
* prt_runerr - print code to implement runerr().
*/
static novalue prt_runerr(t, num, val, indent)
struct token *t;
struct node *num;
struct node *val;
int indent;
{
if (op_type == OrdFunc)
errt1(t, "'runerr' may not be used in an ordinary C function");
tok_line(t, indent); /* synchronize file name and line number */
prt_str("{", indent);
ForceNl();
prt_str("err_msg(", indent);
c_walk(num, indent, 0); /* error number */
if (val == NULL)
prt_str(", NULL);", indent); /* no offending value */
else {
prt_str(", &(", indent);
c_walk(val, indent, 0); /* offending value */
prt_str("));", indent);
}
/*
* Handle error conversion. Indicate that operation may fail because
* of error conversion and produce the necessary code.
*/
cur_impl->ret_flag |= DoesEFail;
failure(indent, 1);
prt_str("}", indent);
ForceNl();
}
/*
* typ_name - convert a type code to a string that can be used to
* output "T_" or "D_" type codes.
*/
char *typ_name(typcd, tok)
int typcd;
struct token *tok;
{
if (typcd == Empty_type)
errt1(tok, "it is meaningless to assert a type of empty_type");
else if (typcd == Any_value)
errt1(tok, "it is useless to assert a type of any_value");
else if (typcd < 0 || typcd == str_typ)
return NULL;
else
return icontypes[typcd].cap_id;
}
/*
* Produce a C conditional expression to check a descriptor for a
* particular type.
*/
static novalue typ_asrt(typcd, desc, tok, indent)
int typcd;
struct node *desc;
struct token *tok;
int indent;
{
tok_line(tok, indent);
if (typcd == str_typ) {
/*
* Check dword for the absense of a "not qualifier" flag.
*/
prt_str("(!((", indent);
c_walk(desc, indent, 0);
prt_str(").dword & F_Nqual))", indent);
}
else if (typcd == TypVar) {
/*
* Check dword for the presense of a "variable" flag.
*/
prt_str("(((", indent);
c_walk(desc, indent, 0);
prt_str(").dword & D_Var) == D_Var)", indent);
}
else if (typcd == int_typ) {
/*
* If large integers are supported, an integer can be either
* an ordinary integer or a large integer.
*/
ForceNl();
prt_str("#ifdef LargeInts", 0);
ForceNl();
prt_str("(((", indent);
c_walk(desc, indent, 0);
prt_str(").dword == D_Integer) || ((", indent);
c_walk(desc, indent, 0);
prt_str(").dword == D_Lrgint))", indent);
ForceNl();
prt_str("#else\t\t\t\t\t/* LargeInts */", 0);
ForceNl();
prt_str("((", indent);
c_walk(desc, indent, 0);
prt_str(").dword == D_Integer)", indent);
ForceNl();
prt_str("#endif\t\t\t\t\t/* LargeInts */", 0);
ForceNl();
}
else {
/*
* Check dword for a specific type code.
*/
prt_str("((", indent);
c_walk(desc, indent, 0);
prt_str(").dword == D_", indent);
prt_str(typ_name(typcd, tok), indent);
prt_str(")", indent);
}
}
/*
* retval_dcltor - convert the "declarator" part of function declaration
* into a declarator for the variable "r_retval" of the same type
* as the function result type, outputing the new declarator. This
* variable is a temporary location to store the result of the argument
* to a C return statement.
*/
static int retval_dcltor(dcltor, indent)
struct node *dcltor;
int indent;
{
int flag;
switch (dcltor->nd_id) {
case ConCatNd:
c_walk(dcltor->u[0].child, indent, 0);
retval_dcltor(dcltor->u[1].child, indent);
return NotId;
case PrimryNd:
/*
* We have reached the function name. Replace it with "r_retval"
* and tell caller we have found it.
*/
prt_str("r_retval", indent);
return IsId;
case PrefxNd:
/*
* (...)
*/
prt_str("(", indent);
flag = retval_dcltor(dcltor->u[0].child, indent);
prt_str(")", indent);
return flag;
case BinryNd:
if (dcltor->tok->tok_id == ')') {
/*
* Function declaration. If this is the declarator that actually
* defines the function being processed, discard the paramater
* list including parentheses.
*/
if (retval_dcltor(dcltor->u[0].child, indent) == NotId) {
prt_str("(", indent);
c_walk(dcltor->u[1].child, indent, 0);
prt_str(")", indent);
}
}
else {
/*
* Array.
*/
retval_dcltor(dcltor->u[0].child, indent);
prt_str("[", indent);
c_walk(dcltor->u[1].child, indent, 0);
prt_str("]", indent);
}
return NotId;
}
err1("rtt internal error detected in function retval_dcltor()");
/* NOTREACHED */
}
/*
* cnv_fnc - produce code to handle RTT cnv: and def: constructs.
*/
static novalue cnv_fnc(t, typcd, src, dflt, dest, indent)
struct token *t;
int typcd;
struct node *src;
struct node *dflt;
struct node *dest;
int indent;
{
int dflt_to_ptr;
int loc;
int is_cstr;
if (src->nd_id == SymNd && src->u[0].sym->id_type & VarPrm)
errt1(t, "converting entire variable part of param list not supported");
tok_line(t, indent); /* synchronize file name and line number */
/*
* Initial assumptions: result of conversion is a tended location
* and is not tended C string.
*/
loc = PrmTend;
is_cstr = 0;
/*
* Print the name of the conversion function. If it is a conversion
* with a default value, determine (through dflt_to_prt) if the
* default value is passed by-reference instead of by-value.
*/
prt_str(cnv_name(typcd, dflt, &dflt_to_ptr), indent);
prt_str("(", indent);
/*
* Determine what parameter scope, if any, is established by this
* conversion. If the conversion needs a buffer, allocate it and
* put it in the argument list.
*/
switch (typcd) {
case TypCInt:
case TypECInt:
loc = PrmInt;
break;
case TypCDbl:
loc = PrmDbl;
break;
case TypCStr:
is_cstr = 1;
break;
case TypTStr:
fprintf(out_file, "r_sbuf[%d], ", nxt_sbuf++);
break;
case TypTCset:
fprintf(out_file, "&r_cbuf[%d], ", nxt_cbuf++);
break;
}
/*
* Output source of conversion.
*/
prt_str("&(", indent);
c_walk(src, indent, 0);
prt_str("), ", indent);
/*
* If there is a default value, output it, taking its address if necessary.
*/
if (dflt != NULL) {
if (dflt_to_ptr)
prt_str("&(", indent);
c_walk(dflt, indent, 0);
if (dflt_to_ptr)
prt_str("), ", indent);
else
prt_str(", ", indent);
}
/*
* Output the destination of the conversion. This may or may not be
* the same as the source.
*/
prt_str("&(", indent);
if (dest == NULL) {
/*
* Convert "in place", changing the location of a paramater if needed.
*/
if (src->nd_id == SymNd && src->u[0].sym->id_type & (RtParm | DrfPrm)) {
if (src->u[0].sym->id_type & DrfPrm)
src->u[0].sym->u.param_info.cur_loc = loc;
else
errt1(t, "only dereferenced parameter can be converted in-place");
}
else if ((loc != PrmTend) | is_cstr)
errt1(t,
"only ordinary parameters can be converted in-place to C values");
c_walk(src, indent, 0);
if (is_cstr) {
/*
* The parameter must be accessed as a tended C string, but only
* now, after the "destination" code has been produced as a full
* descriptor.
*/
src->u[0].sym->u.param_info.cur_loc = PrmCStr;
}
}
else {
/*
* Convert to an explicit destination.
*/
if (is_cstr) {
/*
* Access the destination as a full descriptor even though it
* must be declared as a tended C string.
*/
if (dest->nd_id != SymNd || (dest->u[0].sym->id_type != TndStr &&
dest->u[0].sym->id_type != TndDesc))
errt1(t,
"dest. of C_string conv. must be tended descriptor or char *");
tnd_var(dest->u[0].sym, NULL, "", indent);
}
else
c_walk(dest, indent, 0);
}
prt_str("))", indent);
}
/*
* cnv_name - produce name of conversion routine. Warning, name is
* constructed in a static buffer. Also determine if a default
* must be passed "by reference".
*/
char *cnv_name(typcd, dflt, dflt_to_ptr)
int typcd;
struct node *dflt;
int *dflt_to_ptr;
{
static char buf[15];
int by_ref;
/*
* The names of simple conversion and defaulting conversions have
* the same suffixes, but different prefixes.
*/
if (dflt == NULL)
strcpy(buf , "cnv_");
else
strcpy(buf, "def_");
by_ref = 0;
switch (typcd) {
case TypCInt:
strcat(buf, "c_int");
break;
case TypCDbl:
strcat(buf, "c_dbl");
break;
case TypCStr:
strcat(buf, "c_str");
break;
case TypTStr:
strcat(buf, "tstr");
by_ref = 1;
break;
case TypTCset:
strcat(buf, "tcset");
by_ref = 1;
break;
case TypEInt:
strcat(buf, "eint");
break;
case TypECInt:
strcat(buf, "ec_int");
break;
default:
if (typcd == cset_typ) {
strcat(buf, "cset");
by_ref = 1;
}
else if (typcd == int_typ)
strcat(buf, "int");
else if (typcd == real_typ)
strcat(buf, "real");
else if (typcd == str_typ) {
strcat(buf, "str");
by_ref = 1;
}
}
if (dflt_to_ptr != NULL)
*dflt_to_ptr = by_ref;
return buf;
}
/*
* ret_value - produce code to set the result location of an operation
* using the expression on a return or suspend.
*/
static novalue ret_value(t, n, indent)
struct token *t;
struct node *n;
int indent;
{
struct node *caller;
struct node *args;
int typcd;
if (n == NULL)
errt1(t, "there is no default return value for run-time operations");
if (n->nd_id == SymNd && n->u[0].sym->id_type == RsltLoc) {
/*
* return/suspend result;
*
* result already where it needs to be.
*/
return;
}
if (n->nd_id == PrefxNd && n->tok != NULL) {
switch (n->tok->tok_id) {
case C_Integer:
/*
* return/suspend C_integer <expr>;
*/
prt_str(rslt_loc, indent);
prt_str(".vword.integr = ", indent);
c_walk(n->u[0].child, indent + IndentInc, 0);
prt_str(";", indent);
ForceNl();
prt_str(rslt_loc, indent);
prt_str(".dword = D_Integer;", indent);
chkabsret(t, int_typ); /* compare return with abstract return */
return;
case C_Double:
/*
* return/suspend C_double <expr>;
*/
prt_str(rslt_loc, indent);
prt_str(".vword.bptr = (union block *)alcreal(", indent);
c_walk(n->u[0].child, indent + IndentInc, 0);
prt_str(");", indent + IndentInc);
ForceNl();
prt_str(rslt_loc, indent);
prt_str(".dword = D_Real;", indent);
/*
* The allocation of the real block may fail.
*/
chk_rsltblk(indent);
chkabsret(t, real_typ); /* compare return with abstract return */
return;
case C_String:
/*
* return/suspend C_string <expr>;
*/
prt_str(rslt_loc, indent);
prt_str(".vword.sptr = ", indent);
c_walk(n->u[0].child, indent + IndentInc, 0);
prt_str(";", indent);
ForceNl();
prt_str(rslt_loc, indent);
prt_str(".dword = strlen(", indent);
prt_str(rslt_loc, indent);
prt_str(".vword.sptr);", indent);
chkabsret(t, str_typ); /* compare return with abstract return */
return;
}
}
else if (n->nd_id == BinryNd && n->tok->tok_id == ')') {
/*
* Return value is in form of function call, see if it is really
* a descriptor constructor.
*/
caller = n->u[0].child;
args = n->u[1].child;
if (caller->nd_id == SymNd) {
switch (caller->tok->tok_id) {
case IconType:
typcd = caller->u[0].sym->u.typ_indx;
switch (icontypes[typcd].rtl_ret) {
case TRetBlkP:
/*
* return/suspend <type>(<block-pntr>);
*/
ret_1_arg(t, args, typcd, ".vword.bptr = (union block *)",
"(bp)", indent);
break;
case TRetDescP:
/*
* return/suspend <type>(<desc-pntr>);
*/
ret_1_arg(t, args, typcd, ".vword.descptr = (dptr)",
"(dp)", indent);
break;
case TRetCharP:
/*
* return/suspend <type>(<char-pntr>);
*/
ret_1_arg(t, args, typcd, ".vword.sptr = (char *)",
"(s)", indent);
break;
case TRetCInt:
/*
* return/suspend <type>(<integer>);
*/
ret_1_arg(t, args, typcd, ".vword.integr = (word)",
"(i)", indent);
break;
case TRetSpcl:
if (typcd == str_typ) {
/*
* return/suspend string(<len>, <char-pntr>);
*/
if (args == NULL || args->nd_id != CommaNd ||
args->u[0].child->nd_id == CommaNd)
errt1(t, "wrong no. of args for string(n, s)");
prt_str(rslt_loc, indent);
prt_str(".vword.sptr = ", indent);
c_walk(args->u[1].child, indent + IndentInc, 0);
prt_str(";", indent);
ForceNl();
prt_str(rslt_loc, indent);
prt_str(".dword = ", indent);
c_walk(args->u[0].child, indent + IndentInc, 0);
prt_str(";", indent);
}
else if (typcd == stv_typ) {
/*
* return/suspend tvsubs(<desc-pntr>, <start>, <len>);
*/
if (args == NULL || args->nd_id != CommaNd ||
args->u[0].child->nd_id != CommaNd ||
args->u[0].child->u[0].child->nd_id == CommaNd)
errt1(t, "wrong no. of args for tvsubs(dp, i, j)");
no_nl = 1;
prt_str("SubStr(&", indent);
prt_str(rslt_loc, indent);
prt_str(", ", indent);
c_walk(args->u[0].child->u[0].child, indent + IndentInc,
0);
prt_str(", ", indent + IndentInc);
c_walk(args->u[1].child, indent + IndentInc, 0);
prt_str(", ", indent + IndentInc);
c_walk(args->u[0].child->u[1].child, indent + IndentInc,
0);
prt_str(");", indent + IndentInc);
no_nl = 0;
/*
* The allocation of the substring trapped variable
* block may fail.
*/
chk_rsltblk(indent);
chkabsret(t, stv_typ); /* compare to abstract return */
}
break;
}
chkabsret(t, typcd); /* compare return with abstract return */
return;
case Named_var:
/*
* return/suspend named_var(<desc-pntr>);
*/
if (args == NULL || args->nd_id == CommaNd)
errt1(t, "wrong no. of args for named_var(dp)");
prt_str(rslt_loc, indent);
prt_str(".vword.descptr = ", indent);
c_walk(args, indent + IndentInc, 0);
prt_str(";", indent);
ForceNl();
prt_str(rslt_loc, indent);
prt_str(".dword = D_Var;", indent);
chkabsret(t, TypVar); /* compare return with abstract return */
return;
case Struct_var:
/*
* return/suspend struct_var(<desc-pntr>, <block_pntr>);
*/
if (args == NULL || args->nd_id != CommaNd ||
args->u[0].child->nd_id == CommaNd)
errt1(t, "wrong no. of args for struct_var(dp, bp)");
prt_str(rslt_loc, indent);
prt_str(".vword.descptr = (dptr)", indent);
c_walk(args->u[1].child, indent + IndentInc, 0);
prt_str(";", indent);
ForceNl();
prt_str(rslt_loc, indent);
prt_str(".dword = D_Var + ((word *)", indent);
c_walk(args->u[0].child, indent + IndentInc, 0);
prt_str(" - (word *)", indent+IndentInc);
prt_str(rslt_loc, indent);
prt_str(".vword.descptr);", indent+IndentInc);
ForceNl();
chkabsret(t, TypVar); /* compare return with abstract return */
return;
}
}
}
/*
* If it is not one of the special returns, it is just a return of
* a descriptor.
*/
prt_str(rslt_loc, indent);
prt_str(" = ", indent);
c_walk(n, indent + IndentInc, 0);
prt_str(";", indent);
chkabsret(t, SomeType); /* check for preceding abstract return */
}
/*
* ret_1_arg - produce code for a special return/suspend with one argument.
*/
static novalue ret_1_arg(t, args, typcd, vwrd_asgn, arg_rep, indent)
struct token *t;
struct node *args;
int typcd;
char *vwrd_asgn;
char *arg_rep;
int indent;
{
if (args == NULL || args->nd_id == CommaNd)
errt3(t, "wrong no. of args for", icontypes[typcd].id, arg_rep);
/*
* Assignment to vword of result descriptor.
*/
prt_str(rslt_loc, indent);
prt_str(vwrd_asgn, indent);
c_walk(args, indent + IndentInc, 0);
prt_str(";", indent);
ForceNl();
/*
* Assignment to dword of result descriptor.
*/
prt_str(rslt_loc, indent);
prt_str(".dword = D_", indent);
prt_str(icontypes[typcd].cap_id, indent);
prt_str(";", indent);
}
/*
* chk_rsltblk - the result value contains an allocated block, make sure
* the allocation succeeded.
*/
static novalue chk_rsltblk(indent)
int indent;
{
ForceNl();
prt_str("if (", indent);
prt_str(rslt_loc, indent);
prt_str(".vword.bptr == NULL) {", indent);
ForceNl();
prt_str("err_msg(307, NULL);", indent + IndentInc);
ForceNl();
/*
* Handle error conversion. Indicate that operation may fail because
* of error conversion and produce the necessary code.
*/
cur_impl->ret_flag |= DoesEFail;
failure(indent + IndentInc, 1);
prt_str("}", indent + IndentInc);
ForceNl();
}
/*
* failure - produce code for fail or efail.
*/
static novalue failure(indent, brace)
int indent;
int brace;
{
/*
* If there are tended variables, they must be removed from the tended
* list. The C function may or may not return an explicit signal.
*/
ForceNl();
if (ntend != 0) {
if (!brace)
prt_str("{", indent);
untend(indent);
ForceNl();
if (fnc_ret == RetSig)
prt_str("return A_Resume;", indent);
else
prt_str("return;", indent);
if (!brace) {
ForceNl();
prt_str("}", indent);
}
}
else
if (fnc_ret == RetSig)
prt_str("return A_Resume;", indent);
else
prt_str("return;", indent);
ForceNl();
}
/*
* c_walk - walk the syntax tree for extended C code and output the
* corresponding ordinary C. Return and indication of whether execution
* falls through the code.
*/
int c_walk(n, indent, brace)
struct node *n;
int indent;
int brace;
{
struct token *t;
struct node *n1;
struct sym_entry *sym;
int fall_thru;
int save_break;
static int does_break = 0;
static int may_brnchto; /* may reach end of code by branching into middle */
if (n == NULL)
return 1;
t = n->tok;
switch (n->nd_id) {
case PrimryNd:
switch (t->tok_id) {
case Fail:
if (op_type == OrdFunc)
errt1(t, "'fail' may not be used in an ordinary C function");
cur_impl->ret_flag |= DoesFail;
failure(indent, brace);
chkabsret(t, SomeType); /* check preceding abstract return */
return 0;
case Errorfail:
if (op_type == OrdFunc)
errt1(t,
"'errorfail' may not be used in an ordinary C function");
cur_impl->ret_flag |= DoesEFail;
failure(indent, brace);
return 0;
case Break:
prt_tok(t, indent);
prt_str(";", indent);
does_break = 1;
return 0;
default:
/*
* Other "primary" expressions are just their token image,
* possibly followed by a semicolon.
*/
prt_tok(t, indent);
if (t->tok_id == Continue)
prt_str(";", indent);
return 1;
}
case PrefxNd:
switch (t->tok_id) {
case Sizeof:
prt_tok(t, indent); /* sizeof */
prt_str("(", indent);
c_walk(n->u[0].child, indent, 0);
prt_str(")", indent);
return 1;
case '{':
/*
* Initializer list.
*/
prt_tok(t, indent + IndentInc); /* { */
c_walk(n->u[0].child, indent + IndentInc, 0);
prt_str("}", indent + IndentInc);
return 1;
case Default:
prt_tok(t, indent - IndentInc); /* default (un-indented) */
prt_str(": ", indent - IndentInc);
fall_thru = c_walk(n->u[0].child, indent, 0);
may_brnchto = 1;
return fall_thru;
case Goto:
prt_tok(t, indent); /* goto */
prt_str(" ", indent);
c_walk(n->u[0].child, indent, 0);
prt_str(";", indent);
return 0;
case Return:
if (n->u[0].child != NULL)
no_ret_val = 0; /* note that return statement has no value */
if (op_type == OrdFunc || fnc_ret == RetInt ||
fnc_ret == RetDbl) {
/*
* ordinary C return: ignore C_integer, C_double, and
* C_string qualifiers on return expression (the first
* two may legally occur when fnc_ret is RetInt or RetDbl).
*/
n1 = n->u[0].child;
if (n1 != NULL && n1->nd_id == PrefxNd && n1->tok != NULL) {
switch (n1->tok->tok_id) {
case C_Integer:
case C_Double:
case C_String:
n1 = n1->u[0].child;
}
}
if (ntend != 0) {
/*
* There are tended variables that must be removed from
* the tended list.
*/
if (!brace)
prt_str("{", indent);
if (does_call(n1)) {
/*
* The return expression contains a function call;
* the variables must remain tended while it is
* computed, so compute it into a temporary variable
* named r_retval.Output a declaration for r_retval;
* its type must match the return type of the C
* function.
*/
ForceNl();
prt_str("register ", indent);
if (op_type == OrdFunc) {
no_nl = 1;
just_type(fnc_head->u[0].child, indent, 0);
prt_str(" ", indent);
retval_dcltor(fnc_head->u[1].child, indent);
prt_str(";", indent);
no_nl = 0;
}
else if (fnc_ret == RetInt)
prt_str("C_integer r_retval;", indent);
else /* fnc_ret == RetDbl */
prt_str("double r_retval;", indent);
ForceNl();
/*
* Output code to compute the return value, untend
* the variable, then return the value.
*/
prt_str("r_retval = ", indent);
c_walk(n1, indent + IndentInc, 0);
prt_str(";", indent);
untend(indent);
ForceNl();
prt_str("return r_retval;", indent);
}
else {
/*
* It is safe to untend the variables and return
* the result value directly with a return
* statement.
*/
untend(indent);
ForceNl();
prt_tok(t, indent); /* return */
prt_str(" ", indent);
c_walk(n1, indent, 0);
prt_str(";", indent);
}
if (!brace) {
ForceNl();
prt_str("}", indent);
}
ForceNl();
}
else {
/*
* There are no tended variable, just output the
* return expression.
*/
prt_tok(t, indent); /* return */
prt_str(" ", indent);
c_walk(n1, indent, 0);
prt_str(";", indent);
}
/*
* If this is a body function, check the return against
* preceding abstract returns.
*/
if (fnc_ret == RetInt)
chkabsret(n->tok, int_typ);
else if (fnc_ret == RetDbl)
chkabsret(n->tok, real_typ);
}
else {
/*
* Return from Icon operation. Indicate that the operation
* returns, compute the value into the result location,
* untend variables if necessary, and return a signal
* if the function requires one.
*/
cur_impl->ret_flag |= DoesRet;
ForceNl();
if (!brace) {
prt_str("{", indent);
ForceNl();
}
ret_value(t, n->u[0].child, indent);
if (ntend != 0)
untend(indent);
ForceNl();
if (fnc_ret == RetSig)
prt_str("return A_Continue;", indent);
else if (fnc_ret == RetNoVal)
prt_str("return;", indent);
ForceNl();
if (!brace) {
prt_str("}", indent);
ForceNl();
}
}
return 0;
case Suspend:
if (op_type == OrdFunc)
errt1(t, "'suspend' may not be used in an ordinary C function"
);
cur_impl->ret_flag |= DoesSusp; /* note suspension */
ForceNl();
if (!brace) {
prt_str("{", indent);
ForceNl();
}
prt_str("register int signal;", indent + IndentInc);
ForceNl();
ret_value(t, n->u[0].child, indent);
ForceNl();
/*
* The operator suspends by calling the success continuation
* if there is one or just returns if there is none. For
* the interpreter, interp() is the success continuation.
* A non-A_Resume signal from the success continuation must
* returned to the caller. If there are tended variables
* they must be removed from the tended list before a signal
* is returned.
*/
if (iconx_flg) {
#ifdef EventMon
switch (op_type) {
case Function:
prt_str(
"if ((signal = interp(G_Fsusp, r_args)) != A_Resume) {",
indent);
break;
case Operator:
case Keyword:
prt_str(
"if ((signal = interp(G_Osusp, r_args)) != A_Resume) {",
indent);
break;
default:
prt_str(
"if ((signal = interp(G_Csusp, r_args)) != A_Resume) {",
indent);
}
#else /* EventMon */
prt_str(
"if ((signal = interp(G_Csusp, r_args)) != A_Resume) {",
indent);
#endif /* EventMon */
}
else {
prt_str("if (r_s_cont == (continuation)NULL) {", indent);
if (ntend != 0)
untend(indent + IndentInc);
ForceNl();
prt_str("return A_Continue;", indent + IndentInc);
ForceNl();
prt_str("}", indent + IndentInc);
ForceNl();
prt_str("else if ((signal = (*r_s_cont)()) != A_Resume) {",
indent);
}
ForceNl();
if (ntend != 0)
untend(indent + IndentInc);
ForceNl();
prt_str("return signal;", indent + IndentInc);
ForceNl();
prt_str("}", indent + IndentInc);
if (!brace) {
prt_str("}", indent);
ForceNl();
}
return 1;
case '(':
/*
* Parenthesized expression.
*/
prt_tok(t, indent); /* ( */
fall_thru = c_walk(n->u[0].child, indent, 0);
prt_str(")", indent);
return fall_thru;
default:
/*
* All other prefix expressions are printed as the token
* image of the operation followed by the operand.
*/
prt_tok(t, indent);
c_walk(n->u[0].child, indent, 0);
return 1;
}
case PstfxNd:
/*
* All postfix expressions are printed as the operand followed
* by the token image of the operation.
*/
fall_thru = c_walk(n->u[0].child, indent, 0);
prt_tok(t, indent);
return fall_thru;
case PreSpcNd:
/*
* This prefix expression (pointer indication in a declaration) needs
* a space after it.
*/
prt_tok(t, indent);
c_walk(n->u[0].child, indent, 0);
prt_str(" ", indent);
return 1;
case SymNd:
/*
* Identifier.
*/
prt_var(n, indent);
return 1;
case BinryNd:
switch (t->tok_id) {
case '[':
/*
* subscripting expression or declaration: <expr> [ <expr> ]
*/
n1 = n->u[0].child;
c_walk(n->u[0].child, indent, 0);
prt_str("[", indent);
c_walk(n->u[1].child, indent, 0);
prt_str("]", indent);
return 1;
case '(':
/*
* cast: ( <type> ) <expr>
*/
prt_tok(t, indent); /* ) */
c_walk(n->u[0].child, indent, 0);
prt_str(")", indent);
c_walk(n->u[1].child, indent, 0);
return 1;
case ')':
/*
* function call or declaration: <expr> ( <expr-list> )
*/
c_walk(n->u[0].child, indent, 0);
prt_str("(", indent);
c_walk(n->u[1].child, indent, 0);
prt_tok(t, indent); /* ) */
return call_ret(n->u[0].child);
case Struct:
case Union:
/*
* struct/union <ident>
* struct/union <opt-ident> { <field-list> }
*/
prt_tok(t, indent); /* struct or union */
prt_str(" ", indent);
c_walk(n->u[0].child, indent, 0);
if (n->u[1].child != NULL) {
/*
* Field declaration list.
*/
prt_str(" {", indent);
c_walk(n->u[1].child, indent + IndentInc, 0);
ForceNl();
prt_str("}", indent);
}
return 1;
case Enum:
/*
* enum <ident>
* enum <opt-ident> { <enum-list> }
*/
prt_tok(t, indent); /* enum */
prt_str(" ", indent);
c_walk(n->u[0].child, indent, 0);
if (n->u[1].child != NULL) {
/*
* enumerator list.
*/
prt_str(" {", indent);
c_walk(n->u[1].child, indent + IndentInc, 0);
prt_str("}", indent);
}
return 1;
case ';':
/*
* <type-specs> <declarator> ;
*/
c_walk(n->u[0].child, indent, 0);
prt_str(" ", indent);
c_walk(n->u[1].child, indent, 0);
prt_tok(t, indent); /* ; */
return 1;
case ':':
/*
* <label> : <statement>
*/
c_walk(n->u[0].child, indent, 0);
prt_tok(t, indent); /* : */
prt_str(" ", indent);
fall_thru = c_walk(n->u[1].child, indent, 0);
may_brnchto = 1;
return fall_thru;
case Case:
/*
* case <expr> : <statement>
*/
prt_tok(t, indent - IndentInc); /* case (un-indented) */
prt_str(" ", indent);
c_walk(n->u[0].child, indent - IndentInc, 0);
prt_str(": ", indent - IndentInc);
fall_thru = c_walk(n->u[1].child, indent, 0);
may_brnchto = 1;
return fall_thru;
case Switch:
/*
* switch ( <expr> ) <statement>
*
* <statement> is double indented so that case and default
* statements can be un-indented and come out indented 1
* with respect to the switch. Statements that are not
* "labeled" with case or default are indented one more
* than those that are labeled.
*/
prt_tok(t, indent); /* switch */
prt_str(" (", indent);
c_walk(n->u[0].child, indent, 0);
prt_str(")", indent);
prt_str(" ", indent);
save_break = does_break;
fall_thru = c_walk(n->u[1].child, indent + 2 * IndentInc, 0);
fall_thru |= does_break;
does_break = save_break;
return fall_thru;
case While: {
struct node *n0;
/*
* While ( <expr> ) <statement>
*/
n0 = n->u[0].child;
prt_tok(t, indent); /* while */
prt_str(" (", indent);
c_walk(n0, indent, 0);
prt_str(")", indent);
prt_str(" ", indent);
save_break = does_break;
c_walk(n->u[1].child, indent + IndentInc, 0);
/*
* check for an infinite loop, while (1) ... :
* a condition consisting of an IntConst with image=="1"
* and no breaks in the body.
*/
if (n0->nd_id == PrimryNd && n0->tok->tok_id == IntConst &&
!strcmp(n0->tok->image,"1") && !does_break)
fall_thru = 0;
else
fall_thru = 1;
does_break = save_break;
return fall_thru;
}
case Do:
/*
* do <statement> <while> ( <expr> )
*/
prt_tok(t, indent); /* do */
prt_str(" ", indent);
c_walk(n->u[0].child, indent + IndentInc, 0);
ForceNl();
prt_str("while (", indent);
save_break = does_break;
c_walk(n->u[1].child, indent, 0);
does_break = save_break;
prt_str(");", indent);
return 1;
case '.':
case Arrow:
/*
* Field access: <expr> . <expr> and <expr> -> <expr>
*/
c_walk(n->u[0].child, indent, 0);
prt_tok(t, indent); /* . or -> */
c_walk(n->u[1].child, indent, 0);
return 1;
case Runerr:
/*
* runerr ( <error-number> )
* runerr ( <error-number> , <offending-value> )
*/
prt_runerr(t, n->u[0].child, n->u[1].child, indent);
return 0;
case Is:
/*
* is : <type> ( <expr> )
*/
typ_asrt(icn_typ(n->u[0].child), n->u[1].child,
n->u[0].child->tok, indent);
return 1;
default:
/*
* All other binary expressions are infix notation and
* are printed with spaces around the operator.
*/
c_walk(n->u[0].child, indent, 0);
prt_str(" ", indent);
prt_tok(t, indent);
prt_str(" ", indent);
c_walk(n->u[1].child, indent, 0);
return 1;
}
case LstNd:
/*
* <declaration-part> <declaration-part>
*
* Need space between parts
*/
c_walk(n->u[0].child, indent, 0);
prt_str(" ", indent);
c_walk(n->u[1].child, indent, 0);
return 1;
case ConCatNd:
/*
* <some-code> <some-code>
*
* Various lists of code parts that do not need space between them.
*/
if (c_walk(n->u[0].child, indent, 0))
return c_walk(n->u[1].child, indent, 0);
else {
/*
* Cannot directly reach the second piece of code, see if
* it is possible to branch into it.
*/
may_brnchto = 0;
fall_thru = c_walk(n->u[1].child, indent, 0);
return may_brnchto & fall_thru;
}
case CommaNd:
/*
* <expr> , <expr>
*/
c_walk(n->u[0].child, indent, 0);
prt_tok(t, indent);
prt_str(" ", indent);
return c_walk(n->u[1].child, indent, 0);
case StrDclNd:
/*
* Structure field declaration. Bit field declarations have
* a semicolon and a field width.
*/
c_walk(n->u[0].child, indent, 0);
if (n->u[1].child != NULL) {
prt_str(": ", indent);
c_walk(n->u[1].child, indent, 0);
}
return 1;
case CompNd:
/*
* Compound statement.
*/
if (brace)
tok_line(t, indent); /* just synch. file name and line number */
else
prt_tok(t, indent); /* { */
c_walk(n->u[0].child, indent, 0);
/*
* we are in an inner block. tended locations may need to
* be set to values from declaration initializations.
*/
for (sym = n->u[1].sym; sym!= NULL; sym = sym->u.tnd_var.next) {
if (sym->u.tnd_var.init != NULL) {
prt_str(tendstrct, IndentInc);
fprintf(out_file, ".d[%d]", sym->t_indx);
switch (sym->id_type) {
case TndDesc:
prt_str(" = ", IndentInc);
break;
case TndStr:
prt_str(".vword.sptr = ", IndentInc);
break;
case TndBlk:
prt_str(".vword.bptr = (union block *)",
IndentInc);
break;
}
c_walk(sym->u.tnd_var.init, 2 * IndentInc, 0);
prt_str(";", 2 * IndentInc);
ForceNl();
}
}
/*
* If there are no declarations, suppress braces that
* may be required for a one-statement body; we already
* have a set.
*/
if (n->u[0].child == NULL && n->u[1].sym == NULL)
fall_thru = c_walk(n->u[2].child, indent, 1);
else
fall_thru = c_walk(n->u[2].child, indent, 0);
if (!brace) {
ForceNl();
prt_str("}", indent);
}
return fall_thru;
case TrnryNd:
switch (t->tok_id) {
case '?':
/*
* <expr> ? <expr> : <expr>
*/
c_walk(n->u[0].child, indent, 0);
prt_str(" ", indent);
prt_tok(t, indent); /* ? */
prt_str(" ", indent);
c_walk(n->u[1].child, indent, 0);
prt_str(" : ", indent);
c_walk(n->u[2].child, indent, 0);
return 1;
case If:
/*
* if ( <expr> ) <statement>
* if ( <expr> ) <statement> else <statement>
*/
prt_tok(t, indent); /* if */
prt_str(" (", indent);
c_walk(n->u[0].child, indent + IndentInc, 0);
prt_str(") ", indent);
fall_thru = c_walk(n->u[1].child, indent + IndentInc, 0);
n1 = n->u[2].child;
if (n1 == NULL)
fall_thru = 1;
else {
/*
* There is an else statement. Don't indent an
* "else if"
*/
ForceNl();
prt_str("else ", indent);
if (n1->nd_id == TrnryNd && n1->tok->tok_id == If)
fall_thru |= c_walk(n1, indent, 0);
else
fall_thru |= c_walk(n1, indent + IndentInc, 0);
}
return fall_thru;
case Type_case:
/*
* type_case <expr> of { <section-list> }
* type_case <expr> of { <section-list> <default-clause> }
*/
return typ_case(n->u[0].child, n->u[1].child, n->u[2].child,
c_walk, 1, indent);
case Cnv:
/*
* cnv : <type> ( <source> , <destination> )
*/
cnv_fnc(t, icn_typ(n->u[0].child), n->u[1].child, NULL,
n->u[2].child,
indent);
return 1;
}
case QuadNd:
switch (t->tok_id) {
case For:
/*
* for ( <expr> ; <expr> ; <expr> ) <statement>
*/
prt_tok(t, indent); /* for */
prt_str(" (", indent);
c_walk(n->u[0].child, indent, 0);
prt_str("; ", indent);
c_walk(n->u[1].child, indent, 0);
prt_str("; ", indent);
c_walk(n->u[2].child, indent, 0);
prt_str(") ", indent);
save_break = does_break;
c_walk(n->u[3].child, indent + IndentInc, 0);
if (n->u[1].child == NULL && !does_break)
fall_thru = 0;
else
fall_thru = 1;
does_break = save_break;
return fall_thru;
case Def:
/*
* def : <type> ( <source> , <default> , <destination> )
*/
cnv_fnc(t, icn_typ(n->u[0].child), n->u[1].child, n->u[2].child,
n->u[3].child, indent);
return 1;
}
}
}
/*
* call_ret - decide whether a function being called might return.
*/
int call_ret(n)
struct node *n;
{
/*
* Assume functions return except for c_exit(), fatalerr(), and syserr().
*/
if (n->tok != NULL &&
(strcmp("c_exit", n->tok->image) == 0 ||
strcmp("fatalerr", n->tok->image) == 0 ||
strcmp("syserr", n->tok->image) == 0))
return 0;
else
return 1;
}
/*
* new_prmloc - allocate an array large enough to hold a flag for every
* parameter of the current operation. This flag indicates where
* the parameter is in terms of scopes created by conversions.
*/
struct parminfo *new_prmloc()
{
struct parminfo *parminfo;
int nparams;
int i;
if (params == NULL)
return NULL;
nparams = params->u.param_info.param_num + 1;
parminfo = (struct parminfo *)alloc((unsigned)nparams *
sizeof(struct parminfo));
for (i = 0; i < nparams; ++i) {
parminfo[i].cur_loc = 0;
parminfo [i].parm_mod = 0;
}
return parminfo;
}
/*
* ld_prmloc - load parameter location information that has been
* saved in an arrary into the symbol table.
*/
novalue ld_prmloc(parminfo)
struct parminfo *parminfo;
{
struct sym_entry *sym;
int param_num;
for (sym = params; sym != NULL; sym = sym->u.param_info.next) {
param_num = sym->u.param_info.param_num;
if (sym->id_type & DrfPrm) {
sym->u.param_info.cur_loc = parminfo[param_num].cur_loc;
sym->u.param_info.parm_mod = parminfo[param_num].parm_mod;
}
}
}
/*
* sv_prmloc - save parameter location information from the the symbol table
* into an array.
*/
novalue sv_prmloc(parminfo)
struct parminfo *parminfo;
{
struct sym_entry *sym;
int param_num;
for (sym = params; sym != NULL; sym = sym->u.param_info.next) {
param_num = sym->u.param_info.param_num;
if (sym->id_type & DrfPrm) {
parminfo[param_num].cur_loc = sym->u.param_info.cur_loc;
parminfo[param_num].parm_mod = sym->u.param_info.parm_mod;
}
}
}
/*
* mrg_prmloc - merge parameter location information in the symbol table
* with other information already saved in an array. This may result
* in conflicting location information, but conflicts are only detected
* when a parameter is actually used.
*/
novalue mrg_prmloc(parminfo)
struct parminfo *parminfo;
{
struct sym_entry *sym;
int param_num;
for (sym = params; sym != NULL; sym = sym->u.param_info.next) {
param_num = sym->u.param_info.param_num;
if (sym->id_type & DrfPrm) {
parminfo[param_num].cur_loc |= sym->u.param_info.cur_loc;
parminfo[param_num].parm_mod |= sym->u.param_info.parm_mod;
}
}
}
/*
* clr_prmloc - indicate that this execution path contributes nothing
* to the location of parameters.
*/
novalue clr_prmloc()
{
struct sym_entry *sym;
for (sym = params; sym != NULL; sym = sym->u.param_info.next) {
if (sym->id_type & DrfPrm) {
sym->u.param_info.cur_loc = 0;
sym->u.param_info.parm_mod = 0;
}
}
}
/*
* typ_case - translate a type_case statement into C. This is called
* while walking a syntax tree of either RTL code or C code; the parameter
* "walk" is a function used to process the subtrees within the type_case
* statement.
*/
static int typ_case(var, slct_lst, dflt, walk, maybe_var, indent)
struct node *var;
struct node *slct_lst;
struct node *dflt;
int (*walk)Params((struct node *n, int xindent, int brace));
int maybe_var;
int indent;
{
struct node *lst;
struct node *select;
struct node *slctor;
struct parminfo *strt_prms;
struct parminfo *end_prms;
int remaining;
int first;
int fnd_slctrs;
int maybe_str = 1;
int dflt_lbl;
int typcd;
int fall_thru;
char *s;
/*
* This statement involves multiple paths that may establish new
* scopes for parameters. Remember the starting scope information
* and initialize an array in which to compute the final information.
*/
strt_prms = new_prmloc();
sv_prmloc(strt_prms);
end_prms = new_prmloc();
/*
* First look for cases that must be checked with "if" statements.
* These include string qualifiers and variables.
*/
remaining = 0; /* number of cases skipped in first pass */
first = 1; /* next case to be output is the first */
if (dflt == NULL)
fall_thru = 1;
else
fall_thru = 0;
for (lst = slct_lst; lst != NULL; lst = lst->u[0].child) {
select = lst->u[1].child;
fnd_slctrs = 0; /* flag: found type selections for clause for this pass */
/*
* A selection clause may include several types.
*/
for (slctor = select->u[0].child; slctor != NULL; slctor =
slctor->u[0].child) {
typcd = icn_typ(slctor->u[1].child);
if(typ_name(typcd, slctor->u[1].child->tok) == NULL) {
/*
* This type must be checked with the "if". Is this the
* first condition checked for this clause? Is this the
* first clause output?
*/
if (fnd_slctrs)
prt_str(" || ", indent);
else {
if (first)
first = 0;
else {
ForceNl();
prt_str("else ", indent);
}
prt_str("if (", indent);
fnd_slctrs = 1;
}
/*
* Output type check
*/
typ_asrt(typcd, var, slctor->u[1].child->tok, indent + IndentInc);
if (typcd == str_typ)
maybe_str = 0; /* string has been taken care of */
else if (typcd == Variable)
maybe_var = 0; /* variable has been taken care of */
}
else
++remaining;
}
if (fnd_slctrs) {
/*
* We have found and output type selections for this clause;
* output the body of the clause. Remember any changes to
* paramter locations caused by type conversions within the
* clause.
*/
prt_str(") {", indent + IndentInc);
ForceNl();
if ((*walk)(select->u[1].child, indent + IndentInc, 1)) {
fall_thru |= 1;
mrg_prmloc(end_prms);
}
prt_str("}", indent + IndentInc);
ForceNl();
ld_prmloc(strt_prms);
}
}
/*
* The rest of the cases can be checked with a "switch" statement, look
* for them..
*/
if (remaining == 0) {
if (dflt != NULL) {
/*
* There are no cases to handle with a switch statement, but there
* is a default clause; handle it with an "else".
*/
prt_str("else {", indent);
ForceNl();
fall_thru |= (*walk)(dflt, indent + IndentInc, 1);
ForceNl();
prt_str("}", indent + IndentInc);
ForceNl();
}
}
else {
/*
* If an "if" statement was output, the "switch" must be in its "else"
* clause.
*/
if (!first)
prt_str("else ", indent);
/*
* A switch statement cannot handle types that are not simple type
* codes. If these have not taken care of, output code to check them.
* This will either branch around the switch statement or into
* its default clause.
*/
if (maybe_str || maybe_var) {
dflt_lbl = lbl_num++; /* allocate a label number */
prt_str("{", indent);
ForceNl();
prt_str("if (((", indent);
c_walk(var, indent + IndentInc, 0);
prt_str(").dword & D_Typecode) != D_Typecode) ", indent);
ForceNl();
prt_str("goto L", indent + IndentInc);
fprintf(out_file, "%d; /* default */ ", dflt_lbl);
ForceNl();
}
no_nl = 1; /* suppress #line directives */
prt_str("switch (Type(", indent);
c_walk(var, indent + IndentInc, 0);
prt_str(")) {", indent + IndentInc);
no_nl = 0;
ForceNl();
/*
* Loop through the case clauses producing code for them.
*/
for (lst = slct_lst; lst != NULL; lst = lst->u[0].child) {
select = lst->u[1].child;
fnd_slctrs = 0;
/*
* A selection clause may include several types.
*/
for (slctor = select->u[0].child; slctor != NULL; slctor =
slctor->u[0].child) {
typcd = icn_typ(slctor->u[1].child);
s = typ_name(typcd, slctor->u[1].child->tok);
if (s != NULL) {
/*
* A type selection has been found that can be checked
* in the switch statement. Note that large integers
* require special handling.
*/
fnd_slctrs = 1;
if (typcd == int_typ) {
ForceNl();
prt_str("#ifdef LargeInts", 0);
ForceNl();
prt_str("case T_Lrgint: ", indent + IndentInc);
ForceNl();
prt_str("#endif /* LargeInts */", 0);
ForceNl();
}
prt_str("case T_", indent + IndentInc);
prt_str(s, indent + IndentInc);
prt_str(": ", indent + IndentInc);
}
}
if (fnd_slctrs) {
/*
* We have found and output type selections for this clause;
* output the body of the clause. Remember any changes to
* paramter locations caused by type conversions within the
* clause.
*/
ForceNl();
if ((*walk)(select->u[1].child, indent + 2 * IndentInc, 0)) {
fall_thru |= 1;
ForceNl();
prt_str("break;", indent + 2 * IndentInc);
mrg_prmloc(end_prms);
}
ForceNl();
ld_prmloc(strt_prms);
}
}
if (dflt != NULL) {
/*
* This type_case statement has a default clause. If there is
* a branch into this clause, output the label. Remember any
* changes to paramter locations caused by type conversions
* within the clause.
*/
ForceNl();
prt_str("default:", indent + 1 * IndentInc);
ForceNl();
if (maybe_str || maybe_var) {
prt_str("L", 0);
fprintf(out_file, "%d: ; /* default */", dflt_lbl);
ForceNl();
}
if ((*walk)(dflt, indent + 2 * IndentInc, 0)) {
fall_thru |= 1;
mrg_prmloc(end_prms);
}
ForceNl();
ld_prmloc(strt_prms);
}
prt_str("}", indent + IndentInc);
if (maybe_str || maybe_var) {
if (dflt == NULL) {
/*
* There is a branch around the switch statement. Output
* the label.
*/
ForceNl();
prt_str("L", 0);
fprintf(out_file, "%d: ; /* default */", dflt_lbl);
}
ForceNl();
prt_str("}", indent + IndentInc);
}
ForceNl();
}
/*
* Put ending parameter locations into effect.
*/
mrg_prmloc(end_prms);
ld_prmloc(end_prms);
if (strt_prms != NULL)
free(strt_prms);
if (end_prms != NULL)
free(end_prms);
return fall_thru;
}
/*
* chk_conj - see if the left argument of a conjunction is an in-place
* conversion of a parameter other than a conversion to C_integer or
* C_double. If so issue a warning.
*/
static novalue chk_conj(n)
struct node *n;
{
struct node *cnv_type;
struct node *src;
struct node *dest;
int typcd;
if (n->nd_id == BinryNd && n->tok->tok_id == And)
n = n->u[1].child;
switch (n->nd_id) {
case TrnryNd:
/*
* Must be Cnv.
*/
cnv_type = n->u[0].child;
src = n->u[1].child;
dest = n->u[2].child;
break;
case QuadNd:
/*
* Must be Def.
*/
cnv_type = n->u[0].child;
src = n->u[1].child;
dest = n->u[3].child;
break;
default:
return; /* not a conversion */
}
/*
* A conversion has been found. See if it meets the criteria for
* issuing a warning.
*/
if (src->nd_id != SymNd || !(src->u[0].sym->id_type & DrfPrm))
return; /* not a dereferenced parameter */
typcd = icn_typ(cnv_type);
switch (typcd) {
case TypCInt:
case TypCDbl:
case TypECInt:
return;
}
if (dest != NULL)
return; /* not an in-place convertion */
fprintf(stderr,
"%s: file %s, line %d, warning: in-place conversion may or may not be\n",
progname, cnv_type->tok->fname, cnv_type->tok->line);
fprintf(stderr, "\tundone on subsequent failure.\n");
}
/*
* len_sel - translate a clause form a len_case statement into a C case
* clause. Return an indication of whether execution falls through the
* clause.
*/
static int len_sel(sel, strt_prms, end_prms, indent)
struct node *sel;
struct parminfo *strt_prms;
struct parminfo *end_prms;
int indent;
{
int fall_thru;
prt_str("case ", indent);
prt_tok(sel->tok, indent + IndentInc); /* integer selection */
prt_str(":", indent + IndentInc);
fall_thru = rt_walk(sel->u[0].child, indent + IndentInc, 0);/* clause body */
ForceNl();
if (fall_thru) {
prt_str("break;", indent + IndentInc);
ForceNl();
/*
* Remember any changes to paramter locations caused by type conversions
* within the clause.
*/
mrg_prmloc(end_prms);
}
ld_prmloc(strt_prms);
return fall_thru;
}
/*
* rt_walk - walk the part of the syntax tree containing rtt code, producing
* code for the most-general version of the routine.
*/
static int rt_walk(n, indent, brace)
struct node *n;
int indent;
int brace;
{
struct token *t, *t1;
struct node *n1, *errnum;
struct sym_entry *sym;
int fall_thru;
if (n == NULL)
return 1;
t = n->tok;
switch (n->nd_id) {
case PrefxNd:
switch (t->tok_id) {
case '{':
/*
* RTL code: { <actions> }
*/
if (brace)
tok_line(t, indent); /* just synch file name and line num */
else
prt_tok(t, indent); /* { */
fall_thru = rt_walk(n->u[0].child, indent, 1);
if (!brace)
prt_str("}", indent);
return fall_thru;
case '!':
/*
* RTL type-checking and conversions: ! <simple-type-check>
*/
prt_tok(t, indent);
rt_walk(n->u[0].child, indent, 0);
return 1;
case Body:
case Inline:
/*
* RTL code: body { <c-code> }
* inline { <c-code> }
*/
fall_thru = c_walk(n->u[0].child, indent, brace);
if (!fall_thru)
clr_prmloc();
return fall_thru;
}
break;
case BinryNd:
switch (t->tok_id) {
case Runerr:
/*
* RTL code: runerr( <message-number> )
* runerr( <message-number>, <descriptor> )
*/
prt_runerr(t, n->u[0].child, n->u[1].child, indent);
/*
* Execution cannot continue on this execution path.
*/
clr_prmloc();
return 0;
case And:
/*
* RTL type-checking and conversions:
* <type-check> && <type_check>
*/
chk_conj(n->u[0].child); /* is a warning needed? */
rt_walk(n->u[0].child, indent, 0);
prt_str(" ", indent);
prt_tok(t, indent); /* && */
prt_str(" ", indent);
rt_walk(n->u[1].child, indent, 0);
return 1;
case Is:
/*
* RTL type-checking and conversions:
* is: <icon-type> ( <variable> )
*/
typ_asrt(icn_typ(n->u[0].child), n->u[1].child,
n->u[0].child->tok, indent);
return 1;
}
break;
case ConCatNd:
/*
* "Glue" for two constructs.
*/
fall_thru = rt_walk(n->u[0].child, indent, 0);
return fall_thru & rt_walk(n->u[1].child, indent, 0);
case AbstrNd:
/*
* Ignore abstract type computations while producing C code
* for library routines.
*/
return 1;
case TrnryNd:
switch (t->tok_id) {
case If: {
/*
* RTL code for "if" statements:
* if <type-check> then <action>
* if <type-check> then <action> else <action>
*
* <type-check> may include parameter conversions that create
* new scoping. It is necessary to keep track of paramter
* types and locations along success and failure paths of
* these conversions. The "then" and "else" actions may
* also establish new scopes.
*/
struct parminfo *then_prms = NULL;
struct parminfo *else_prms;
/*
* Save the current parameter locations. These are in
* effect on the failure path of any type conversions
* in the condition of the "if".
*/
else_prms = new_prmloc();
sv_prmloc(else_prms);
prt_tok(t, indent); /* if */
prt_str(" (", indent);
n1 = n->u[0].child;
rt_walk(n1, indent + IndentInc, 0); /* type check */
prt_str(") {", indent);
/*
* If the condition is negated, the failure path is to the "then"
* and the success path is to the "else".
*/
if (n1->nd_id == PrefxNd && n1->tok->tok_id == '!') {
then_prms = else_prms;
else_prms = new_prmloc();
sv_prmloc(else_prms);
ld_prmloc(then_prms);
}
/*
* Then Clause.
*/
fall_thru = rt_walk(n->u[1].child, indent + IndentInc, 1);
ForceNl();
prt_str("}", indent + IndentInc);
/*
* Determine if there is an else clause and merge parameter
* location information from the alternate paths through
* the statement.
*/
n1 = n->u[2].child;
if (n1 == NULL) {
if (fall_thru)
mrg_prmloc(else_prms);
ld_prmloc(else_prms);
fall_thru = 1;
}
else {
if (then_prms == NULL)
then_prms = new_prmloc();
if (fall_thru)
sv_prmloc(then_prms);
ld_prmloc(else_prms);
ForceNl();
prt_str("else {", indent);
if (rt_walk(n1, indent + IndentInc, 1)) { /* else clause */
fall_thru = 1;
mrg_prmloc(then_prms);
}
ForceNl();
prt_str("}", indent + IndentInc);
ld_prmloc(then_prms);
}
ForceNl();
if (then_prms != NULL)
free(then_prms);
if (else_prms != NULL)
free(else_prms);
}
return fall_thru;
case Len_case: {
/*
* RTL code:
* len_case <variable> of {
* <integer>: <action>
* ...
* default: <action>
* }
*/
struct parminfo *strt_prms;
struct parminfo *end_prms;
/*
* A case may contain parameter conversions that create new
* scopes. Remember the parameter locations at the start
* of the len_case statement.
*/
strt_prms = new_prmloc();
sv_prmloc(strt_prms);
end_prms = new_prmloc();
n1 = n->u[0].child;
if (!(n1->u[0].sym->id_type & VArgLen))
errt1(t, "len_case must select on length of vararg");
/*
* The len_case statement is implemented as a C switch
* statement.
*/
prt_str("switch (", indent);
prt_var(n1, indent);
prt_str(") {", indent);
ForceNl();
fall_thru = 0;
for (n1 = n->u[1].child; n1->nd_id == ConCatNd;
n1 = n1->u[0].child)
fall_thru |= len_sel(n1->u[1].child, strt_prms, end_prms,
indent + IndentInc);
fall_thru |= len_sel(n1, strt_prms, end_prms,
indent + IndentInc);
/*
* Handle default clause.
*/
prt_str("default:", indent + IndentInc);
ForceNl();
fall_thru |= rt_walk(n->u[2].child, indent + 2 * IndentInc, 0);
ForceNl();
prt_str("}", indent + IndentInc);
ForceNl();
/*
* Put into effect the location of parameters at the end
* of the len_case statement.
*/
mrg_prmloc(end_prms);
ld_prmloc(end_prms);
if (strt_prms != NULL)
free(strt_prms);
if (end_prms != NULL)
free(end_prms);
}
return fall_thru;
case Type_case: {
/*
* RTL code:
* type_case <variable> of {
* <icon_type> : ... <icon_type> : <action>
* ...
* }
*
* last clause may be: default: <action>
*/
int maybe_var;
struct node *var;
struct sym_entry *sym;
/*
* If we can determine that the value being checked is
* not a variable reference, we don't have to produce code
* to check for that possibility.
*/
maybe_var = 1;
var = n->u[0].child;
if (var->nd_id == SymNd) {
sym = var->u[0].sym;
switch(sym->id_type) {
case DrfPrm:
case OtherDcl:
case TndDesc:
case TndStr:
case RsltLoc:
if (sym->nest_lvl > 1) {
/*
* The thing being tested is either a
* dereferenced parameter or a local
* descriptor which could only have been
* set by a conversion which does not
* produce a variable reference.
*/
maybe_var = 0;
}
}
}
return typ_case(var, n->u[1].child, n->u[2].child, rt_walk,
maybe_var, indent);
}
case Cnv:
/*
* RTL code: cnv: <type> ( <source> )
* cnv: <type> ( <source> , <destination> )
*/
cnv_fnc(t, icn_typ(n->u[0].child), n->u[1].child, NULL,
n->u[2].child, indent);
return 1;
case Arith_case: {
/*
* arith_case (<variable>, <variable>) of {
* C_integer: <statement>
* integer: <statement>
* C_double: <statement>
* }
*
* This construct does type conversions and provides
* alternate execution paths. It is necessary to keep
* track of parameter locations.
*/
struct parminfo *strt_prms;
struct parminfo *end_prms;
struct parminfo *tmp_prms;
strt_prms = new_prmloc();
sv_prmloc(strt_prms);
end_prms = new_prmloc();
tmp_prms = new_prmloc();
fall_thru = 0;
n1 = n->u[2].child; /* contains actions for the 3 cases */
/*
* Set up an error number node for use in runerr().
*/
t1 = copy_t(t);
t1->tok_id = IntConst;
t1->image = "102";
errnum = node0(PrimryNd, t1);
/*
* Try converting both arguments to a C_integer.
*/
tok_line(t, indent);
prt_str("if (", indent);
cnv_fnc(t, TypECInt, n->u[0].child, NULL, NULL, indent);
prt_str(" && ", indent);
cnv_fnc(t, TypECInt, n->u[1].child, NULL, NULL, indent);
prt_str(") ", indent);
ForceNl();
if (rt_walk(n1->u[0].child, indent + IndentInc, 0)) {
fall_thru |= 1;
mrg_prmloc(end_prms);
}
ForceNl();
/*
* Try converting both arguments to an integer.
*/
prt_str("#ifdef LargeInts", 0);
ForceNl();
ld_prmloc(strt_prms);
tok_line(t, indent);
prt_str("else if (", indent);
cnv_fnc(t, TypEInt, n->u[0].child, NULL, NULL, indent);
prt_str(" && ", indent);
cnv_fnc(t, TypEInt, n->u[1].child, NULL, NULL, indent);
prt_str(") ", indent);
ForceNl();
if (rt_walk(n1->u[1].child, indent + IndentInc, 0)) {
fall_thru |= 1;
mrg_prmloc(end_prms);
}
ForceNl();
prt_str("#endif\t\t\t\t\t/* LargeInts */", 0);
ForceNl();
/*
* Try converting both arguments to a C_double
*/
ld_prmloc(strt_prms);
prt_str("else {", indent);
ForceNl();
tok_line(t, indent + IndentInc);
prt_str("if (!", indent + IndentInc);
cnv_fnc(t, TypCDbl, n->u[0].child, NULL, NULL,
indent + IndentInc);
prt_str(")", indent + IndentInc);
ForceNl();
sv_prmloc(tmp_prms); /* use original parm locs for error */
ld_prmloc(strt_prms);
prt_runerr(t, errnum, n->u[0].child, indent + 2 * IndentInc);
ld_prmloc(tmp_prms);
tok_line(t, indent + IndentInc);
prt_str("if (!", indent + IndentInc);
cnv_fnc(t, TypCDbl, n->u[1].child, NULL, NULL,
indent + IndentInc);
prt_str(") ", indent + IndentInc);
ForceNl();
sv_prmloc(tmp_prms); /* use original parm locs for error */
ld_prmloc(strt_prms);
prt_runerr(t, errnum, n->u[1].child, indent + 2 * IndentInc);
ld_prmloc(tmp_prms);
if (rt_walk(n1->u[2].child, indent + IndentInc, 0)) {
fall_thru |= 1;
mrg_prmloc(end_prms);
}
ForceNl();
prt_str("}", indent + IndentInc);
ForceNl();
ld_prmloc(end_prms);
free(strt_prms);
free(end_prms);
free(tmp_prms);
free_tree(errnum);
return fall_thru;
}
}
case QuadNd:
/*
* RTL code: def: <type> ( <source> , <default>)
* def: <type> ( <source> , <default> , <destination> )
*/
cnv_fnc(t, icn_typ(n->u[0].child), n->u[1].child, n->u[2].child,
n->u[3].child, indent);
return 1;
}
}
/*
* spcl_dcls - print special declarations for tended variables, parameter
* conversions, and buffers.
*/
novalue spcl_dcls(op_params)
struct sym_entry *op_params; /* operation parameters or NULL */
{
register struct sym_entry *sym;
struct sym_entry *sym1;
/*
* Output declarations for buffers and locations to hold conversions
* to C values.
*/
spcl_start(op_params);
/*
* Determine if this operation takes a variable number of arguments.
* Use that information in deciding how large a tended array to
* declare.
*/
varargs = (op_params != NULL && op_params->id_type & VarPrm);
if (varargs)
tend_ary(ntend + VArgAlwnc - 1);
else
tend_ary(ntend);
if (varargs) {
/*
* This operation takes a variable number of arguments. A declaration
* for a tended array has been made that will usually hold them, but
* sometimes it is necessary to malloc() a tended array at run
* time. Produce code to check for this.
*/
cur_impl->ret_flag |= DoesEFail; /* error conversion from allocation */
prt_str("struct tend_desc *r_tendp;", IndentInc);
ForceNl();
prt_str("int r_n;\n", IndentInc);
++line;
ForceNl();
prt_str("if (r_nargs <= ", IndentInc);
fprintf(out_file, "%d)", op_params->u.param_info.param_num + VArgAlwnc);
ForceNl();
prt_str("r_tendp = (struct tend_desc *)&r_tend;", 2 * IndentInc);
ForceNl();
prt_str("else {", IndentInc);
ForceNl();
prt_str(
"r_tendp = (struct tend_desc *)malloc((msize)(sizeof(struct tend_desc)",
2 * IndentInc);
ForceNl();
prt_str("", 3 * IndentInc);
fprintf(out_file, "+ (r_nargs + %d) * sizeof(struct descrip)));",
ntend - 2 - op_params->u.param_info.param_num);
ForceNl();
prt_str("if (r_tendp == NULL) {", 2 * IndentInc);
ForceNl();
prt_str("err_msg(305, NULL);", 3 * IndentInc);
ForceNl();
prt_str("return A_Resume;", 3 * IndentInc);
ForceNl();
prt_str("}", 3 * IndentInc);
ForceNl();
prt_str("}", 2 * IndentInc);
ForceNl();
tendstrct = "(*r_tendp)";
}
else
tendstrct = "r_tend";
/*
* Produce code to initialize the tended array. These are for tended
* declarations and parameters.
*/
tend_init(); /* initializations for tended declarations. */
if (varargs) {
/*
* This operation takes a variable number of arguments. Produce code
* to dereference or copy this into its portion of the tended
* array.
*/
prt_str("for (r_n = ", IndentInc);
fprintf(out_file, "%d; r_n < r_nargs; ++r_n)",
op_params->u.param_info.param_num);
ForceNl();
if (op_params->id_type & DrfPrm) {
prt_str("deref(&r_args[r_n], &", IndentInc * 2);
fprintf(out_file, "%s.d[r_n + %d]);", tendstrct, ntend - 1 -
op_params->u.param_info.param_num);
}
else {
prt_str(tendstrct, IndentInc * 2);
fprintf(out_file, ".d[r_n + %d] = r_args[r_n];", ntend - 1 -
op_params->u.param_info.param_num);
}
ForceNl();
sym = op_params->u.param_info.next;
}
else
sym = op_params; /* no variable part of arg list */
/*
* Go through the fixed part of the parameter list, producing code
* to copy/dereference parameters into the tended array.
*/
while (sym != NULL) {
/*
* A there may be identifiers for dereferenced and/or undereferenced
* versions of a paramater. If there are both, sym1 references the
* second identifier.
*/
sym1 = sym->u.param_info.next;
if (sym1 != NULL && sym->u.param_info.param_num !=
sym1->u.param_info.param_num)
sym1 = NULL; /* the next entry is not for the same parameter */
/*
* If there are not enough arguments to supply a value for this
* parameter, set it to the null value.
*/
prt_str("if (", IndentInc);
fprintf(out_file, "r_nargs > %d) {", sym->u.param_info.param_num);
ForceNl();
parm_tnd(sym);
if (sym1 != NULL) {
ForceNl();
parm_tnd(sym1);
}
ForceNl();
prt_str("} else {", IndentInc);
ForceNl();
prt_str(tendstrct, IndentInc * 2);
fprintf(out_file, ".d[%d].dword = D_Null;", sym->t_indx);
if (sym1 != NULL) {
ForceNl();
prt_str(tendstrct, IndentInc * 2);
fprintf(out_file, ".d[%d].dword = D_Null;", sym1->t_indx);
}
ForceNl();
prt_str("}", 2 * IndentInc);
ForceNl();
if (sym1 == NULL)
sym = sym->u.param_info.next;
else
sym = sym1->u.param_info.next;
}
/*
* Finish setting up the tended array structure and link it into the tended
* list.
*/
if (ntend != 0) {
prt_str(tendstrct, IndentInc);
if (varargs)
fprintf(out_file, ".num = %d + Max(r_nargs - %d, 0);", ntend - 1,
op_params->u.param_info.param_num);
else
fprintf(out_file, ".num = %d;", ntend);
ForceNl();
prt_str(tendstrct, IndentInc);
prt_str(".previous = tend;", IndentInc);
ForceNl();
prt_str("tend = (struct tend_desc *)&", IndentInc);
fprintf(out_file, "%s;", tendstrct);
ForceNl();
}
}
/*
* spcl_start - do initial work for outputing special declarations. Output
* declarations for buffers and locations to hold conversions to C values.
* Determine what tended locations are needed for parameters.
*/
static novalue spcl_start(op_params)
struct sym_entry *op_params;
{
ForceNl();
if (n_tmp_str > 0) {
prt_str("char r_sbuf[", IndentInc);
fprintf(out_file, "%d][MaxCvtLen];", n_tmp_str);
ForceNl();
}
if (n_tmp_cset > 0) {
prt_str("struct b_cset r_cbuf[", IndentInc);
fprintf(out_file, "%d];", n_tmp_cset);
ForceNl();
}
if (tend_lst == NULL)
ntend = 0;
else
ntend = tend_lst->t_indx + 1;
parm_locs(op_params); /* see what parameter conversion there are */
}
/*
* tend_ary - write struct containing array of tended descriptors.
*/
static novalue tend_ary(n)
int n;
{
if (n == 0)
return;
prt_str("struct {", IndentInc);
ForceNl();
prt_str("struct tend_desc *previous;", 2 * IndentInc);
ForceNl();
prt_str("int num;", 2 * IndentInc);
ForceNl();
prt_str("struct descrip d[", 2 * IndentInc);
fprintf(out_file, "%d];", n);
ForceNl();
prt_str("} r_tend;\n", 2 * IndentInc);
++line;
ForceNl();
}
/*
* tend_init - produce code to initialize entries in the tended array
* corresponding to tended declarations. Default initializations are
* supplied when there is none in the declaration.
*/
static novalue tend_init()
{
register struct init_tend *tnd;
for (tnd = tend_lst; tnd != NULL; tnd = tnd->next) {
switch (tnd->init_typ) {
case TndDesc:
/*
* Simple tended declaration.
*/
prt_str(tendstrct, IndentInc);
if (tnd->init == NULL)
fprintf(out_file, ".d[%d].dword = D_Null;", tnd->t_indx);
else {
fprintf(out_file, ".d[%d] = ", tnd->t_indx);
c_walk(tnd->init, 2 * IndentInc, 0);
prt_str(";", 2 * IndentInc);
}
break;
case TndStr:
/*
* Tended character pointer.
*/
prt_str(tendstrct, IndentInc);
if (tnd->init == NULL)
fprintf(out_file, ".d[%d] = emptystr;", tnd->t_indx);
else {
fprintf(out_file, ".d[%d].dword = 0;", tnd->t_indx);
ForceNl();
prt_str(tendstrct, IndentInc);
fprintf(out_file, ".d[%d].vword.sptr = ", tnd->t_indx);
c_walk(tnd->init, 2 * IndentInc, 0);
prt_str(";", 2 * IndentInc);
}
break;
case TndBlk:
/*
* A tended block pointer of some kind.
*/
prt_str(tendstrct, IndentInc);
if (tnd->init == NULL)
fprintf(out_file, ".d[%d] = nullptr;", tnd->t_indx);
else {
fprintf(out_file, ".d[%d].dword = F_Ptr | F_Nqual;",tnd->t_indx);
ForceNl();
prt_str(tendstrct, IndentInc);
fprintf(out_file, ".d[%d].vword.bptr = (union block *)",
tnd->t_indx);
c_walk(tnd->init, 2 * IndentInc, 0);
prt_str(";", 2 * IndentInc);
}
break;
}
ForceNl();
}
}
/*
* parm_tnd - produce code to put a parameter in its tended location.
*/
static novalue parm_tnd(sym)
struct sym_entry *sym;
{
/*
* A parameter may either be dereferenced into its tended location
* or copied.
*/
if (sym->id_type & DrfPrm) {
prt_str("deref(&r_args[", IndentInc * 2);
fprintf(out_file, "%d], &%s.d[%d]);", sym->u.param_info.param_num,
tendstrct, sym->t_indx);
}
else {
prt_str(tendstrct, IndentInc * 2);
fprintf(out_file, ".d[%d] = r_args[%d];", sym->t_indx,
sym->u.param_info.param_num);
}
}
/*
* parm_locs - determine what locations are needed to hold parameters and
* their conversions. Produce declarations for the C_integer and C_double
* locations.
*/
static novalue parm_locs(op_params)
struct sym_entry *op_params;
{
struct sym_entry *next_parm;
/*
* Parameters are stored in reverse order: Recurse down the list
* and perform processing on the way back.
*/
if (op_params == NULL)
return;
next_parm = op_params->u.param_info.next;
parm_locs(next_parm);
/*
* For interpreter routines, extra tended descriptors are only needed
* when both dereferenced and undereferenced values are requested.
*/
if (iconx_flg && (next_parm == NULL ||
op_params->u.param_info.param_num != next_parm->u.param_info.param_num))
op_params->t_indx = -1;
else
op_params->t_indx = ntend++;
if (op_params->u.param_info.non_tend & PrmInt) {
prt_str("C_integer r_i", IndentInc);
fprintf(out_file, "%d;", op_params->u.param_info.param_num);
ForceNl();
}
if (op_params->u.param_info.non_tend & PrmDbl) {
prt_str("double r_d", IndentInc);
fprintf(out_file, "%d;", op_params->u.param_info.param_num);
ForceNl();
}
}
/*
* real_def - see if a declaration really defines storage.
*/
static int real_def(n)
struct node *n;
{
struct node *dcl_lst;
dcl_lst = n->u[1].child;
/*
* If no variables are being defined this must be a tag declaration.
*/
if (dcl_lst == NULL)
return 0;
if (only_proto(dcl_lst))
return 0;
if (tdef_or_extr(n->u[0].child))
return 0;
return 1;
}
/*
* only_proto - see if this declarator list contains only function prototypes.
*/
static int only_proto(n)
struct node *n;
{
switch (n->nd_id) {
case CommaNd:
return only_proto(n->u[0].child) & only_proto(n->u[1].child);
case ConCatNd:
/*
* Optional pointer.
*/
return only_proto(n->u[1].child);
case BinryNd:
switch (n->tok->tok_id) {
case '=':
return only_proto(n->u[0].child);
case '[':
/*
* At this point, assume array declarator is not part of
* prototype.
*/
return 0;
case ')':
/*
* Prototype (or forward declaration).
*/
return 1;
}
case PrefxNd:
/*
* Parenthesized.
*/
return only_proto(n->u[0].child);
case PrimryNd:
/*
* At this point, assume it is not a prototype.
*/
return 0;
}
err1("rtt internal error detected in function only_proto()");
/* NOTREACHED */
}
/*
* tdef_or_extr - see if this is a typedef or extern.
*/
static int tdef_or_extr(n)
struct node *n;
{
switch (n->nd_id) {
case LstNd:
return tdef_or_extr(n->u[0].child) | tdef_or_extr(n->u[1].child);
case BinryNd:
/*
* struct, union, or enum.
*/
return 0;
case PrimryNd:
if (n->tok->tok_id == Extern || n->tok->tok_id == Typedef)
return 1;
else
return 0;
}
err1("rtt internal error detected in function tdef_or_extr()");
/* NOTREACHED */
}
/*
* dclout - output an ordinary global C declaration.
*/
novalue dclout(n)
struct node *n;
{
if (!enable_out)
return; /* output disabled */
if (real_def(n))
def_fnd = 1; /* this declaration defines a run-time object */
c_walk(n, 0, 0);
free_tree(n);
}
/*
* fncout - output code for a C function.
*/
novalue fncout(head, prm_dcl, block)
struct node *head;
struct node *prm_dcl;
struct node *block;
{
if (!enable_out)
return; /* output disabled */
def_fnd = 1; /* this declaration defines a run-time object */
nxt_sbuf = 0; /* clear number of string buffers */
nxt_cbuf = 0; /* clear number of cset buffers */
/*
* Output the function header and the parameter declarations.
*/
fnc_head = head;
c_walk(head, 0, 0);
prt_str(" ", 0);
c_walk(prm_dcl, 0, 0);
prt_str(" ", 0);
/*
* Handle outer block.
*/
prt_tok(block->tok, IndentInc); /* { */
c_walk(block->u[0].child, IndentInc, 0); /* non-tended declarations */
spcl_dcls(NULL); /* tended declarations */
no_ret_val = 1;
c_walk(block->u[2].child, IndentInc, 0); /* statement list */
if (ntend != 0 && no_ret_val) {
/*
* This function contains no return statements with values, assume
* that the programmer is using the implicit return at the end
* of the function and update the tending of descriptors.
*/
untend(IndentInc);
}
ForceNl();
prt_str("}", IndentInc);
ForceNl();
/*
* free storage.
*/
free_tree(head);
free_tree(prm_dcl);
free_tree(block);
pop_cntxt();
clr_def();
}
/*
* defout - output operation definitions (except for constant keywords)
*/
novalue defout(n)
struct node *n;
{
struct sym_entry *sym, *sym1;
if (!enable_out)
return; /* output disabled */
nxt_sbuf = 0;
nxt_cbuf = 0;
/*
* Somewhat different code is produced for the interpreter and compiler.
*/
if (iconx_flg)
interp_def(n);
else
comp_def(n);
free_tree(n);
/*
* The declarations for the declare statement are not associated with
* any compound statement and must be freed here.
*/
sym = dcl_stk->tended;
while (sym != NULL) {
sym1 = sym;
sym = sym->u.tnd_var.next;
free_sym(sym1);
}
while (decl_lst != NULL) {
sym1 = decl_lst;
decl_lst = decl_lst->u.declare_var.next;
free_sym(sym1);
}
op_type = OrdFunc;
pop_cntxt();
clr_def();
}
/*
* comp_def - output code for the compiler for operation definitions.
*/
static novalue comp_def(n)
struct node *n;
{
#ifdef Rttx
fprintf(stdout, "rtt was compiled to only support the interpreter, use -x\n");
exit(ErrorExit);
#else /* Rttx */
struct sym_entry *sym;
struct node *n1;
FILE *f_save;
#if MVS
char buf1[MaxFileName];
#else /* MVS */
char buf1[5];
#endif /* MVS */
char buf[MaxFileName];
char *cname;
long min_result;
long max_result;
int ret_flag;
int resume;
char *name;
char *s;
f_save = out_file;
/*
* Note if the result location is explicitly referenced and note
* how it is accessed in the generated code.
*/
cur_impl->use_rslt = sym_lkup(str_rslt)->u.referenced;
rslt_loc = "(*r_rslt)";
/*
* In several contexts, letters are used to distinguish kinds of operations.
*/
switch (op_type) {
case Function:
lc_letter = 'f';
uc_letter = 'F';
break;
case Keyword:
lc_letter = 'k';
uc_letter = 'K';
break;
case Operator:
lc_letter = 'o';
uc_letter = 'O';
}
prfx1 = cur_impl->prefix[0];
prfx2 = cur_impl->prefix[1];
if (op_type != Keyword) {
/*
* First pass through the operation: produce most general routine.
*/
fnc_ret = RetSig; /* most general routine always returns a signal */
/*
* Compute the file name in which to output the function.
*/
#if MVS
{
struct fileparts *fp;
fp = fparse(src_file_nm);
if (*fp->member == '\0')
sprintf(buf1, "%c#%c%c", lc_letter, prfx1, prfx2);
else
sprintf(buf1, "%s%s.ro.c(%c#%c%c)", fp->dir, fp->name,
lc_letter, prfx1, prfx2);
}
#else /* MVS */
sprintf(buf1, "%c_%c%c", lc_letter, prfx1, prfx2);
#endif /* MVS */
cname = salloc(makename(buf, SourceDir, buf1, CSuffix));
if ((out_file = fopen(cname, "w")) == NULL)
err2("cannot open output file", cname);
else
addrmlst(cname);
prologue(); /* output standard comments and preprocessor directives */
/*
* Output function header that corresponds to standard calling
* convensions. The function name is constructed from the letter
* for the operation type, the prefix that makes the function
* name unique, and the name of the operation.
*/
fprintf(out_file, "int %c%c%c_%s(r_nargs, r_args, r_rslt, r_s_cont)\n",
uc_letter, prfx1, prfx2, cur_impl->name);
fprintf(out_file, "int r_nargs;\n");
fprintf(out_file, "dptr r_args;\n");
fprintf(out_file, "dptr r_rslt;\n");
fprintf(out_file, "continuation r_s_cont;");
fname = cname;
line = 12;
ForceNl();
prt_str("{", IndentInc);
ForceNl();
/*
* Output ordinary declarations from declare clause.
*/
for (sym = decl_lst; sym != NULL; sym = sym->u.declare_var.next) {
c_walk(sym->u.declare_var.tqual, IndentInc, 0);
prt_str(" ", IndentInc);
c_walk(sym->u.declare_var.dcltor, IndentInc, 0);
if ((n1 = sym->u.declare_var.init) != NULL) {
prt_str(" = ", IndentInc);
c_walk(n1, IndentInc, 0);
}
prt_str(";", IndentInc);
}
/*
* Output code for special declarations along with code to initial
* them. This includes buffers and tended locations for parameters
* and tended variables.
*/
spcl_dcls(params);
if (rt_walk(n, IndentInc, 0)) { /* body of operation */
if (n->nd_id == ConCatNd)
s = n->u[1].child->tok->fname;
else
s = n->tok->fname;
fprintf(stderr, "%s: file %s, warning: ", progname, s);
fprintf(stderr, "execution may fall off end of operation \"%s\"\n",
cur_impl->name);
}
ForceNl();
prt_str("}\n", IndentInc);
if (fclose(out_file) != 0)
err2("cannot close ", cname);
put_c_fl(cname, 1); /* note name of output file for operation */
}
/*
* Second pass through operation: produce in-line code and special purpose
* routines.
*/
for (sym = params; sym != NULL; sym = sym->u.param_info.next)
if (sym->id_type & DrfPrm)
sym->u.param_info.cur_loc = PrmTend; /* reset location of parameter */
in_line(n);
/*
* Insure that the fail/return/suspend statements are consistent
* with the result sequence indicated.
*/
min_result = cur_impl->min_result;
max_result = cur_impl->max_result;
ret_flag = cur_impl->ret_flag;
resume = cur_impl->resume;
name = cur_impl->name;
if (min_result == NoRsltSeq && ret_flag & (DoesFail|DoesRet|DoesSusp))
err2(name,
": result sequence of {}, but fail, return, or suspend present");
if (min_result != NoRsltSeq && ret_flag == 0)
err2(name,
": result sequence indicated, no fail, return, or suspend present");
if (max_result != NoRsltSeq) {
if (max_result == 0 && ret_flag & (DoesRet|DoesSusp))
err2(name,
": result sequence of 0 length, but return or suspend present");
if (max_result != 0 && !(ret_flag & (DoesRet | DoesSusp)))
err2(name,
": result sequence length > 0, but no return or suspend present");
if ((max_result == UnbndSeq || max_result > 1 || resume) &&
!(ret_flag & DoesSusp))
err2(name,
": result sequence indicates suspension, but no suspend present");
if ((max_result != UnbndSeq && max_result <= 1 && !resume) &&
ret_flag & DoesSusp)
err2(name,
": result sequence indicates no suspension, but suspend present");
}
if (min_result != NoRsltSeq && max_result != UnbndSeq &&
min_result > max_result)
err2(name, ": minimum result sequence length greater than maximum");
out_file = f_save;
#endif /* Rttx */
}
/*
* interp_def - output code for the interpreter for operation definitions.
*/
static novalue interp_def(n)
struct node *n;
{
struct sym_entry *sym;
struct node *n1;
int nparms;
int has_underef;
char letter;
char *name;
char *s;
/*
* Note how result location is accessed in generated code.
*/
rslt_loc = "r_args[0]";
/*
* Determine if the operation has any undereferenced parameters.
*/
has_underef = 0;
for (sym = params; sym != NULL; sym = sym->u.param_info.next)
if (sym->id_type & RtParm) {
has_underef = 1;
break;
}
/*
* Determine the nuber of parameters. A negative value is used
* to indicate an operation that takes a variable number of
* arguments.
*/
if (params == NULL)
nparms = 0;
else {
nparms = params->u.param_info.param_num + 1;
if (params->id_type & VarPrm)
nparms = -nparms;
}
fnc_ret = RetSig; /* interpreter routine always returns a signal */
name = cur_impl->name;
/*
* Determine what letter is used to prefix the operation name.
*/
switch (op_type) {
case Function:
#if VMS
letter = 'Y';
#else /* VMS */
letter = 'Z';
#endif /* VMS */
break;
case Keyword:
letter = 'K';
break;
case Operator:
letter = 'O';
}
fprintf(out_file, "\n");
if (op_type != Keyword) {
/*
* Output prototype. Operations taking a variable number of arguments
* have an extra parameter: the number of arguments.
*/
fprintf(out_file, "int %c%s Params((", letter, name);
if (params != NULL && (params->id_type & VarPrm))
fprintf(out_file, "int r_nargs, ");
fprintf(out_file, "dptr r_args));\n");
++line;
/*
* Output procedure block.
*/
switch (op_type) {
case Function:
fprintf(out_file, "FncBlock(%s, %d, %d)\n\n", name, nparms,
(has_underef ? -1 : 0));
++line;
break;
case Operator:
if (strcmp(cur_impl->op,"\\") == 0)
fprintf(out_file, "OpBlock(%s, %d, \"%s\", 0)\n\n", name, nparms,
"\\\\");
else
fprintf(out_file, "OpBlock(%s, %d, \"%s\", 0)\n\n", name, nparms,
cur_impl->op);
++line;
}
}
/*
* Output function header. Operations taking a variable number of arguments
* have an extra parameter: the number of arguments.
*/
fprintf(out_file, "int %c%s(", letter, name);
if (params != NULL && (params->id_type & VarPrm))
fprintf(out_file, "r_nargs, ");
fprintf(out_file, "r_args)\n");
++line;
if (params != NULL && (params->id_type & VarPrm)) {
fprintf(out_file, "int r_nargs;\n");
++line;
}
fprintf(out_file, "dptr r_args;");
++line;
ForceNl();
prt_str("{", IndentInc);
/*
* Output ordinary declarations from the declare clause.
*/
ForceNl();
for (sym = decl_lst; sym != NULL; sym = sym->u.declare_var.next) {
c_walk(sym->u.declare_var.tqual, IndentInc, 0);
prt_str(" ", IndentInc);
c_walk(sym->u.declare_var.dcltor, IndentInc, 0);
if ((n1 = sym->u.declare_var.init) != NULL) {
prt_str(" = ", IndentInc);
c_walk(n1, IndentInc, 0);
}
prt_str(";", IndentInc);
}
/*
* Output special declarations and initial processing.
*/
tendstrct = "r_tend";
spcl_start(params);
tend_ary(ntend);
if (has_underef && params != NULL && params->id_type == (VarPrm | DrfPrm))
prt_str("int r_n;\n", IndentInc);
tend_init();
/*
* See which parameters need to be dereferenced. If all are dereferenced,
* it is done by before the routine is called.
*/
if (has_underef) {
sym = params;
if (sym != NULL && sym->id_type & VarPrm) {
if (sym->id_type & DrfPrm) {
/*
* There is a variable part of the parameter list and it
* must be dereferenced.
*/
prt_str("for (r_n = ", IndentInc);
fprintf(out_file, "%d; r_n <= r_nargs; ++r_n)",
sym->u.param_info.param_num + 1);
ForceNl();
prt_str("Deref(r_args[r_n]);", IndentInc * 2);
ForceNl();
}
sym = sym->u.param_info.next;
}
/*
* Produce code to dereference any fixed parameters that need to be.
*/
while (sym != NULL) {
if (sym->id_type & DrfPrm) {
/*
* Tended index of -1 indicates that the parameter can be
* dereferened in-place (this is the usual case).
*/
if (sym->t_indx == -1) {
prt_str("Deref(r_args[", IndentInc * 2);
fprintf(out_file, "%d]);", sym->u.param_info.param_num + 1);
}
else {
prt_str("deref(&r_args[", IndentInc * 2);
fprintf(out_file, "%d], &r_tend.d[%d]);",
sym->u.param_info.param_num + 1, sym->t_indx);
}
}
ForceNl();
sym = sym->u.param_info.next;
}
}
/*
* Finish setting up the tended array structure and link it into the tended
* list.
*/
if (ntend != 0) {
prt_str("r_tend.num = ", IndentInc);
fprintf(out_file, "%d;", ntend);
ForceNl();
prt_str("r_tend.previous = tend;", IndentInc);
ForceNl();
prt_str("tend = (struct tend_desc *)&r_tend;", IndentInc);
ForceNl();
}
if (rt_walk(n, IndentInc, 0)) { /* body of operation */
if (n->nd_id == ConCatNd)
s = n->u[1].child->tok->fname;
else
s = n->tok->fname;
fprintf(stderr, "%s: file %s, warning: ", progname, s);
fprintf(stderr, "execution may fall off end of operation \"%s\"\n",
cur_impl->name);
}
ForceNl();
prt_str("}\n", IndentInc);
}
/*
* keyconst - produce code for a constant keyword.
*/
novalue keyconst(t)
struct token *t;
{
struct il_code *il;
int n;
if (iconx_flg) {
/*
* For the interpreter, output a C function implementing the keyword.
*/
rslt_loc = "r_args[0]"; /* result location */
fprintf(out_file, "\n");
fprintf(out_file, "int K%s(r_args)\n", cur_impl->name);
fprintf(out_file, "dptr r_args;");
line += 2;
ForceNl();
prt_str("{", IndentInc);
ForceNl();
switch (t->tok_id) {
case StrLit:
prt_str(rslt_loc, IndentInc);
prt_str(".vword.sptr = \"", IndentInc);
n = prt_i_str(out_file, t->image, (int)strlen(t->image));
prt_str("\";", IndentInc);
ForceNl();
prt_str(rslt_loc, IndentInc);
fprintf(out_file, ".dword = %d;", n);
break;
case CharConst:
prt_str("static struct b_cset cset_blk = ", IndentInc);
cset_init(out_file, bitvect(t->image, (int)strlen(t->image)));
ForceNl();
prt_str(rslt_loc, IndentInc);
prt_str(".dword = D_Cset;", IndentInc);
ForceNl();
prt_str(rslt_loc, IndentInc);
prt_str(".vword.bptr = (union block *)&cset_blk;", IndentInc);
break;
case DblConst:
prt_str("static struct b_real real_blk = {T_Real, ", IndentInc);
fprintf(out_file, "%s};", t->image);
ForceNl();
prt_str(rslt_loc, IndentInc);
prt_str(".dword = D_Real;", IndentInc);
ForceNl();
prt_str(rslt_loc, IndentInc);
prt_str(".vword.bptr = (union block *)&real_blk;", IndentInc);
break;
case IntConst:
prt_str(rslt_loc, IndentInc);
prt_str(".dword = D_Integer;", IndentInc);
ForceNl();
prt_str(rslt_loc, IndentInc);
prt_str(".vword.integr = ", IndentInc);
prt_str(t->image, IndentInc);
prt_str(";", IndentInc);
break;
}
ForceNl();
prt_str("return A_Continue;", IndentInc);
ForceNl();
prt_str("}\n", IndentInc);
++line;
ForceNl();
}
else {
/*
* For the compiler, make an entry in the data base for the keyword.
*/
cur_impl->use_rslt = 0;
il = new_il(IL_Const, 2);
switch (t->tok_id) {
case StrLit:
il->u[0].n = str_typ;
il->u[1].s = (char *)alloc((unsigned int)(strlen(t->image) + 3));
sprintf(il->u[1].s, "\"%s\"", t->image);
break;
case CharConst:
il->u[0].n = cset_typ;
il->u[1].s = (char *)alloc((unsigned int)(strlen(t->image) + 3));
sprintf(il->u[1].s, "'%s'", t->image);
break;
case DblConst:
il->u[0].n = real_typ;
il->u[1].s = t->image;
break;
case IntConst:
il->u[0].n = int_typ;
il->u[1].s = t->image;
break;
}
cur_impl->in_line = il;
}
/*
* Reset the translator and free storage.
*/
op_type = OrdFunc;
free_t(t);
pop_cntxt();
clr_def();
}
/*
* keepdir - A preprocessor directive to be kept has been encountered.
* If it is #passthru, print just the body of the directive, otherwise
* print the whole thing.
*/
novalue keepdir(t)
struct token *t;
{
char *s;
tok_line(t, 0);
s = t->image;
if (strncmp(s, "#passthru", 9) == 0)
s = s + 10;
fprintf(out_file, "%s\n", s);
line += 1;
}
/*
* prologue - print standard comments and preprocessor directives at the
* start of an output file.
*/
novalue prologue()
{
id_comment(out_file);
fprintf(out_file, "%s", compiler_def);
fprintf(out_file, "#include \"%s\"\n\n", inclname);
}