/****************************************************************
Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
****************************************************************/
char _assoc_table
[] = { 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 };
/* Opcode table -- This array is indexed by the OP_____ macros defined in
defines.h; these macros are expected to be adjacent integers, so that
this table is as small as possible. */
table_entry opcode_table
[] = {
/* OPPLUS 1 */ { BINARY_OP
, 12, "%l + %r" },
/* OPMINUS 2 */ { BINARY_OP
, 12, "%l - %r" },
/* OPSTAR 3 */ { BINARY_OP
, 13, "%l * %r" },
/* OPSLASH 4 */ { BINARY_OP
, 13, "%l / %r" },
/* OPPOWER 5 */ { BINARY_OP
, 0, "power (%l, %r)" },
/* OPNEG 6 */ { UNARY_OP
, 14, "-%l" },
/* OPOR 7 */ { BINARY_OP
, 4, "%l || %r" },
/* OPAND 8 */ { BINARY_OP
, 5, "%l && %r" },
/* OPEQV 9 */ { BINARY_OP
, 9, "%l == %r" },
/* OPNEQV 10 */ { BINARY_OP
, 9, "%l != %r" },
/* OPNOT 11 */ { UNARY_OP
, 14, "! %l" },
/* OPCONCAT 12 */ { BINARY_OP
, 0, "concat (%l, %r)" },
/* OPLT 13 */ { BINARY_OP
, 10, "%l < %r" },
/* OPEQ 14 */ { BINARY_OP
, 9, "%l == %r" },
/* OPGT 15 */ { BINARY_OP
, 10, "%l > %r" },
/* OPLE 16 */ { BINARY_OP
, 10, "%l <= %r" },
/* OPNE 17 */ { BINARY_OP
, 9, "%l != %r" },
/* OPGE 18 */ { BINARY_OP
, 10, "%l >= %r" },
/* OPCALL 19 */ { BINARY_OP
, 15, SPECIAL_FMT
},
/* OPCCALL 20 */ { BINARY_OP
, 15, SPECIAL_FMT
},
/* Left hand side of an assignment cannot have outermost parens */
/* OPASSIGN 21 */ { BINARY_OP
, 2, "%l = %r" },
/* OPPLUSEQ 22 */ { BINARY_OP
, 2, "%l += %r" },
/* OPSTAREQ 23 */ { BINARY_OP
, 2, "%l *= %r" },
/* OPCONV 24 */ { BINARY_OP
, 14, "%l" },
/* OPLSHIFT 25 */ { BINARY_OP
, 11, "%l << %r" },
/* OPMOD 26 */ { BINARY_OP
, 13, "%l %% %r" },
/* OPCOMMA 27 */ { BINARY_OP
, 1, "%l, %r" },
/* Don't want to nest the colon operator in parens */
/* OPQUEST 28 */ { BINARY_OP
, 3, "%l ? %r" },
/* OPCOLON 29 */ { BINARY_OP
, 3, "%l : %r" },
/* OPABS 30 */ { UNARY_OP
, 0, "abs(%l)" },
/* OPMIN 31 */ { BINARY_OP
, 0, SPECIAL_FMT
},
/* OPMAX 32 */ { BINARY_OP
, 0, SPECIAL_FMT
},
/* OPADDR 33 */ { UNARY_OP
, 14, "&%l" },
/* OPCOMMA_ARG 34 */ { BINARY_OP
, 15, SPECIAL_FMT
},
/* OPBITOR 35 */ { BINARY_OP
, 6, "%l | %r" },
/* OPBITAND 36 */ { BINARY_OP
, 8, "%l & %r" },
/* OPBITXOR 37 */ { BINARY_OP
, 7, "%l ^ %r" },
/* OPBITNOT 38 */ { UNARY_OP
, 14, "~ %l" },
/* OPRSHIFT 39 */ { BINARY_OP
, 11, "%l >> %r" },
/* This isn't quite right -- it doesn't handle arrays, for instance */
/* OPWHATSIN 40 */ { UNARY_OP
, 14, "*%l" },
/* OPMINUSEQ 41 */ { BINARY_OP
, 2, "%l -= %r" },
/* OPSLASHEQ 42 */ { BINARY_OP
, 2, "%l /= %r" },
/* OPMODEQ 43 */ { BINARY_OP
, 2, "%l %%= %r" },
/* OPLSHIFTEQ 44 */ { BINARY_OP
, 2, "%l <<= %r" },
/* OPRSHIFTEQ 45 */ { BINARY_OP
, 2, "%l >>= %r" },
/* OPBITANDEQ 46 */ { BINARY_OP
, 2, "%l &= %r" },
/* OPBITXOREQ 47 */ { BINARY_OP
, 2, "%l ^= %r" },
/* OPBITOREQ 48 */ { BINARY_OP
, 2, "%l |= %r" },
/* OPPREINC 49 */ { UNARY_OP
, 14, "++%l" },
/* OPPREDEC 50 */ { UNARY_OP
, 14, "--%l" },
/* OPDOT 51 */ { BINARY_OP
, 15, "%l.%r" },
/* OPARROW 52 */ { BINARY_OP
, 15, "%l -> %r"},
/* OPNEG1 53 */ { UNARY_OP
, 14, "-%l" },
/* OPDMIN 54 */ { BINARY_OP
, 0, "dmin(%l,%r)" },
/* OPDMAX 55 */ { BINARY_OP
, 0, "dmax(%l,%r)" },
/* OPASSIGNI 56 */ { BINARY_OP
, 2, "%l = &%r" },
/* OPIDENTITY 57 */ { UNARY_OP
, 15, "%l" },
/* OPCHARCAST 58 */ { UNARY_OP
, 14, "(char *)&%l" },
/* OPDABS 59 */ { UNARY_OP
, 0, "dabs(%l)" },
/* OPMIN2 60 */ { BINARY_OP
, 0, "min(%l,%r)" },
/* OPMAX2 61 */ { BINARY_OP
, 0, "max(%l,%r)" },
/* kludge to imitate (under forcedouble) f77's bizarre treatement of OPNEG... */
/* OPNEG KLUDGE */ { UNARY_OP
, 14, "-(doublereal)%l" }
#define OPNEG_KLUDGE (sizeof(opcode_table)/sizeof(table_entry) - 1)
static char opeqable
[sizeof(opcode_table
)/sizeof(table_entry
)];
static void output_prim ();
static void output_unary (), output_binary (), output_arg_list ();
static void output_list (), output_literal ();
case TNAME
: out_name (fp
, (struct Nameblock
*) e
);
case TCONST
: out_const(fp
, &e
->constblock
);
case TADDR
: out_addr (fp
, &(e
-> addrblock
));
case TPRIM
: warn ("expr_out: got TPRIM");
output_prim (fp
, &(e
-> primblock
));
case TLIST
: output_list (fp
, &(e
-> listblock
));
case TIMPLDO
: err ("expr_out: got TIMPLDO");
erri ("expr_out: bad tag '%d'", e
-> tag
);
/* Now we know that the tag is TEXPR */
/* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */
if (e
-> exprblock
.opcode
== OPASSIGN
&& e
-> exprblock
.rightp
&&
e
-> exprblock
.rightp
-> tag
== TEXPR
) {
opcode
= e
-> exprblock
.rightp
-> exprblock
.opcode
;
if ((leftp
= e
-> exprblock
.leftp
) &&
(rightp
= e
-> exprblock
.rightp
-> exprblock
.leftp
)) {
if (same_ident (leftp
, rightp
)) {
expptr temp
= e
-> exprblock
.rightp
;
e
-> exprblock
.opcode
= op_assign(opcode
);
e
-> exprblock
.rightp
= temp
-> exprblock
.rightp
;
temp
->exprblock
.rightp
= 0;
} /* if same_ident (leftp, rightp) */
} /* if leftp && rightp */
} /* if opcode == OPPLUS || */
} /* if e -> exprblock.opcode == OPASSIGN */
/* Optimize on increment or decrement by 1 */
int opcode
= e
-> exprblock
.opcode
;
expptr leftp
= e
-> exprblock
.leftp
;
expptr rightp
= e
-> exprblock
.rightp
;
if (leftp
&& rightp
&& (leftp
-> headblock
.vstg
== STGARG
||
ISINT (leftp
-> headblock
.vtype
)) &&
(opcode
== OPPLUSEQ
|| opcode
== OPMINUSEQ
) &&
ISINT (rightp
-> headblock
.vtype
) &&
ISICON (e
-> exprblock
.rightp
) &&
(ISONE (e
-> exprblock
.rightp
) ||
e
-> exprblock
.rightp
-> constblock
.Const
.ci
== -1)) {
/* Allow for the '-1' constant value */
if (!ISONE (e
-> exprblock
.rightp
))
opcode
= (opcode
== OPPLUSEQ
) ? OPMINUSEQ
: OPPLUSEQ
;
/* replace the existing opcode */
e
-> exprblock
.opcode
= OPPREINC
;
e
-> exprblock
.opcode
= OPPREDEC
;
/* Free up storage used by the right hand side */
frexpr (e
-> exprblock
.rightp
);
} /* if opcode == OPPLUS */
if (is_unary_op (e
-> exprblock
.opcode
))
output_unary (fp
, &(e
-> exprblock
));
else if (is_binary_op (e
-> exprblock
.opcode
))
output_binary (fp
, &(e
-> exprblock
));
erri ("expr_out: bad opcode '%d'", (int) e
-> exprblock
.opcode
);
void out_and_free_statement (outfile
, expr
)
expr_out (outfile
, expr
);
nice_printf (outfile
, ";\n");
} /* out_and_free_statement */
int same_ident (left
, right
)
if (left
-> tag
== TNAME
&& right
-> tag
== TNAME
&& left
== right
)
if (left
-> tag
== TADDR
&& right
-> tag
== TADDR
&&
left
-> addrblock
.uname_tag
== right
-> addrblock
.uname_tag
)
switch (left
-> addrblock
.uname_tag
) {
/* Check for array subscripts */
if (left
-> addrblock
.user
.name
-> vdim
||
right
-> addrblock
.user
.name
-> vdim
)
if (left
-> addrblock
.user
.name
!=
right
-> addrblock
.user
.name
||
!same_expr (left
-> addrblock
.memoffset
,
right
-> addrblock
.memoffset
))
return same_ident ((expptr
) (left
-> addrblock
.user
.name
),
(expptr
) right
-> addrblock
.user
.name
);
return strcmp(left
->addrblock
.user
.ident
,
right
->addrblock
.user
.ident
) == 0;
return strcmp(left
->addrblock
.user
.Charp
,
right
->addrblock
.user
.Charp
) == 0;
if (left
->tag
== TEXPR
&& left
->exprblock
.opcode
== OPWHATSIN
&& right
->tag
== TEXPR
&& right
->exprblock
.opcode
== OPWHATSIN
)
return same_ident(left
->exprblock
.leftp
,
if (!c1
->vstg
&& !c2
->vstg
)
return c1
->Const
.cd
[n
] == c2
->Const
.cd
[n
];
s1
= c1
->vstg
? c1
->Const
.cds
[n
] : dtos(c1
->Const
.cd
[n
]);
s2
= c2
->vstg
? c2
->Const
.cds
[n
] : dtos(c2
->Const
.cd
[n
]);
if (!samefpconst(c1
,c2
,1))
return samefpconst(c1
,c2
,0);
return c1
->Const
.ccp1
.blanks
== c2
->Const
.ccp1
.blanks
&& c1
->vleng
->constblock
.Const
.ci
== c2
->vleng
->constblock
.Const
.ci
&& !memcmp(c1
->Const
.ccp
, c2
->Const
.ccp
,
(int)c1
->vleng
->constblock
.Const
.ci
);
return c1
->Const
.ci
== c2
->Const
.ci
;
err("unexpected type in sameconst");
/* same_expr -- Returns true only if e1 and e2 match. This is
somewhat pessimistic, but can afford to be because it's just used to
optimize on the assignment operators (+=, -=, etc). */
if (e1
-> tag
!= e2
-> tag
|| e1
-> headblock
.vtype
!= e2
-> headblock
.vtype
)
if (e1
-> exprblock
.opcode
!= e2
-> exprblock
.opcode
)
return same_expr (e1
-> exprblock
.leftp
, e2
-> exprblock
.leftp
) &&
same_expr (e1
-> exprblock
.rightp
, e2
-> exprblock
.rightp
);
return same_ident (e1
, e2
);
return sameconst(&e1
->constblock
, &e2
->constblock
);
void out_name (fp
, namep
)
extern int usedefsforcommon
;
/* DON'T want to use oneof_stg() here; need to find the right common name
if (namep
->vstg
== STGCOMMON
&& !namep
->vcommequiv
&& !usedefsforcommon
) {
comm
= &extsymtab
[namep
->vardesc
.varno
];
nice_printf(fp
, "%d.", comm
->curno
);
} /* if namep -> vstg == STGCOMMON */
if (namep
->vprocclass
== PTHISPROC
&& namep
->vtype
!= TYSUBR
)
nice_printf(fp
, xretslot
[namep
->vtype
]->user
.ident
);
nice_printf (fp
, "%s", namep
->cvarname
);
static char *Longfmt
= "%ld";
#define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n])
static char real_buf
[50], imag_buf
[50];
nice_printf (fp
, "%ld", cp
->Const
.ci
); /* don't cast ci! */
nice_printf (fp
, Longfmt
, cp
->Const
.ci
); /* don't cast ci! */
nice_printf(fp
, "%s", flconst(real_buf
, cpd(0)));
nice_printf(fp
, "%s", cpd(0));
nice_printf(fp
, cm_fmt_string
, flconst(real_buf
, cpd(0)),
flconst(imag_buf
, cpd(1)));
nice_printf(fp
, dcm_fmt_string
, cpd(0), cpd(1));
nice_printf (fp
, "%s", cp
->Const
.ci
? "TRUE_" : "FALSE_");
char *c
= cp
->Const
.ccp
, *ce
;
nice_printf (fp
, "\"\"");
ce
= c
+ cp
->vleng
->constblock
.Const
.ci
;
k
= *(unsigned char *)c
++;
nice_printf(fp
, str_fmt
[k
], k
);
for(k
= cp
->Const
.ccp1
.blanks
; k
> 0; k
--)
erri ("out_const: bad type '%d'", (int) type
);
out_args(fp
, ep
) FILE *fp
; expptr ep
;
badtag("out_args", ep
->tag
);
for(arglist
= ep
->listblock
.listp
;;) {
expr_out(fp
, (expptr
)arglist
->datap
);
if (!(arglist
= arglist
->nextp
))
/* out_addr -- this routine isn't local because it is called by the
system-generated identifier printing routines */
void out_addr (fp
, addrp
)
extern Extsym
*extsymtab
;
&& addrp
->vtype
!= TYCHAR
&& ISICON(addrp
->memoffset
)
&& !addrp
->memoffset
->constblock
.Const
.ci
)
switch (addrp
-> uname_tag
) {
nice_printf(fp
, "%s_%s(", addrp
->user
.name
->cvarname
,
addrp
->cmplx_sub
? "subscr" : "ref");
out_args(fp
, addrp
->memoffset
);
out_name (fp
, addrp
-> user
.name
);
if (*(s
= addrp
->user
.ident
) == ' ') {
xretslot
[addrp
->vtype
]->user
.ident
);
nice_printf(fp
, "%s", s
+1);
nice_printf(fp
, "%s", s
);
nice_printf(fp
, "%s", addrp
->user
.Charp
);
extern_out (fp
, &extsymtab
[addrp
-> memno
]);
out_const(fp
, (Constp
)addrp
);
output_literal (fp
, (int)addrp
->memno
,
Fatal("unexpected vstg in out_addr");
nice_printf (fp
, "Unknown Addrp");
/* It's okay to just throw in the brackets here because they have a
precedence level of 15, the highest value. */
if ((addrp
->uname_tag
== UNAM_NAME
&& addrp
->user
.name
->vdim
|| addrp
->ntempelt
> 1 || addrp
->isarray
)
&& addrp
->vtype
!= TYCHAR
) {
offset
= addrp
-> memoffset
;
if (ONEOF(addrp
->vstg
, M(STGCOMMON
)|M(STGEQUIV
))
&& addrp
-> uname_tag
== UNAM_NAME
offset
= mkexpr (OPMINUS
, offset
, mkintcon (
addrp
-> user
.name
-> voffset
));
offset
= mkexpr (OPSLASH
, offset
,
ICON (typesize
[addrp
-> vtype
] * (addrp
-> Field
? 2 : 1)));
/* Check for structure field reference */
if (addrp
-> Field
&& addrp
-> uname_tag
!= UNAM_CONST
&&
addrp
-> uname_tag
!= UNAM_UNKNOWN
) {
if (oneof_stg((addrp
-> uname_tag
== UNAM_NAME
? addrp
-> user
.name
:
(Namep
) NULL
), addrp
-> vstg
, M(STGARG
)|M(STGEQUIV
))
&& !was_array
&& (addrp
->vclass
!= CLPROC
|| !multitype
))
nice_printf (fp
, "->%s", addrp
-> Field
);
nice_printf (fp
, ".%s", addrp
-> Field
);
/* Check for character subscripting */
if (addrp
->vtype
== TYCHAR
&&
(addrp
->vclass
!= CLPROC
|| addrp
->uname_tag
== UNAM_NAME
&& addrp
->user
.name
->vprocclass
== PTHISPROC
) &&
(addrp
-> uname_tag
!= UNAM_NAME
||
addrp
-> user
.name
-> vtype
== TYCHAR
) &&
(!ISICON (addrp
-> memoffset
) ||
(addrp
-> memoffset
-> constblock
.Const
.ci
))) {
expptr e
= addrp
-> memoffset
;
if (ONEOF(addrp
->vstg
, M(STGCOMMON
)|M(STGEQUIV
))
&& addrp
-> uname_tag
== UNAM_NAME
) {
e
= mkexpr (OPMINUS
, e
, mkintcon (addrp
-> user
.name
-> voffset
));
/* mkexpr will simplify it to zero if possible */
if (e
->tag
== TCONST
&& e
->constblock
.Const
.ci
== 0)
} /* if addrp -> vstg == STGCOMMON */
/* In the worst case, parentheses might be needed OUTSIDE the expression,
too. But since I think this subscripting can only appear as a
parameter in a procedure call, I don't think outside parens will ever
be needed. INSIDE parens are handled below */
int arg_prec
= op_precedence (e
-> exprblock
.opcode
);
int prec
= op_precedence (OPPLUS
);
use_paren
= arg_prec
&& (arg_prec
< prec
|| (arg_prec
== prec
&&
is_left_assoc (OPPLUS
)));
} /* if e -> tag == TEXPR */
if (use_paren
) nice_printf (fp
, "(");
if (use_paren
) nice_printf (fp
, ")");
static void output_literal (fp
, memno
, cp
)
struct Literal
*litp
, *lastlit
;
extern char *lit_name ();
lastlit
= litpool
+ nliterals
;
for (litp
= litpool
; litp
< lastlit
; litp
++) {
if (litp
-> litnum
== memno
)
nice_printf (fp
, "%s", lit_name (litp
));
static void output_prim (fp
, primp
)
out_name (fp
, primp
-> namep
);
output_arg_list (fp
, primp
-> argsp
);
if (primp
-> fcharp
!= (expptr
) NULL
|| primp
-> lcharp
!= (expptr
) NULL
)
nice_printf (fp
, "Sorry, no substrings yet");
static void output_arg_list (fp
, listp
)
if (listp
== (struct Listblock
*) NULL
|| listp
-> listp
== (chainp
) NULL
)
for (arg_list
= listp
-> listp
; arg_list
; arg_list
= arg_list
-> nextp
) {
expr_out (fp
, (expptr
) arg_list
-> datap
);
if (arg_list
-> nextp
!= (chainp
) NULL
)
/* Might want to add a hook in here to accomodate the style setting which
wants spaces after commas */
static void output_unary (fp
, e
)
if (e
->vtype
== TYREAL
&& forcedouble
) {
e
->opcode
= OPNEG_KLUDGE
;
nice_printf (fp
, "Sorry, no OPCALL yet");
erri ("output_unary: bad opcode", (int) e
-> opcode
);
register struct Literal
*litp
, *litpe
;
for(litpe
= litp
+ nliterals
; litp
< litpe
; litp
++)
Fatal("findconst failure!");
/* special handling for ichar and character*1 */
register union Expression
*Offset
;
if (!(lp
= e
->leftp
)) /* possible with erroneous Fortran */
lt
= lp
->headblock
.vtype
;
cp
= lp
->constblock
.Const
.ccp
;
k
= *(unsigned char *)cp
;
sprintf(buf
, chr_fmt
[k
], k
);
nice_printf(fp
, "'%s'", buf
);
switch(lp
->addrblock
.vstg
) {
if (halign
&& e
->vtype
!= TYCHAR
) {
nice_printf(fp
, "*(%s *)",
c_type_decl(e
->vtype
,0));
cp
= findconst(lp
->addrblock
.memno
);
lp
->addrblock
.vtype
= tyint
;
Offset
= lp
->addrblock
.memoffset
;
switch(lp
->addrblock
.uname_tag
) {
np
= lp
->addrblock
.user
.name
;
M(STGCOMMON
)|M(STGEQUIV
)))
Offset
= mkexpr(OPMINUS
, Offset
,
lp
->addrblock
.memoffset
= Offset
?
lp
->addrblock
.isarray
= 1;
/* STGCOMMON or STGEQUIV would cause */
/* voffset to be added in a second time */
lp
->addrblock
.vstg
= STGUNKNOWN
;
badtag("opconv_fudge", lp
->tag
);
c_type_decl(e
->vtype
, 0));
static void output_binary (fp
, e
)
extern table_entry opcode_table
[];
if (e
== NULL
|| e
-> tag
!= TEXPR
)
/* Instead of writing a huge switch, I've incorporated the output format
into a table. Things like "%l" and "%r" stand for the left and
right subexpressions. This should allow both prefix and infix
functions to be specified (e.g. "(%l * %r", "z_div (%l, %r"). Of
course, I should REALLY think out the ramifications of writing out
straight text, as opposed to some intermediate format, which could
figure out and optimize on the the number of required blanks (we don't
want "x - (-y)" to become "x --y", for example). Special cases (such as
incomplete implementations) could still be implemented as part of the
switch, they will just have some dummy value instead of the string
pattern. Another difficulty is the fact that the complex functions
will differ from the integer and real ones */
/* Handle a special case. We don't want to output "x + - 4", or "y - - 3"
if ((e
-> opcode
== OPPLUS
|| e
-> opcode
== OPMINUS
) &&
e
-> rightp
&& e
-> rightp
-> tag
== TCONST
&&
isnegative_const (&(e
-> rightp
-> constblock
)) &&
is_negatable (&(e
-> rightp
-> constblock
))) {
e
-> opcode
= (e
-> opcode
== OPPLUS
) ? OPMINUS
: OPPLUS
;
negate_const (&(e
-> rightp
-> constblock
));
} /* if e -> opcode == PLUS or MINUS */
prec
= op_precedence (e
-> opcode
);
format
= op_format (e
-> opcode
);
if (format
!= SPECIAL_FMT
) {
int arg_prec
, use_paren
= 0;
if (lp
&& lp
->tag
== TEXPR
) {
arg_prec
= op_precedence(lp
->exprblock
.opcode
);
(arg_prec
< prec
|| (arg_prec
== prec
&&
if (e
->opcode
== OPCONV
&& opconv_fudge(fp
,e
))
if (rp
&& rp
->tag
== TEXPR
) {
arg_prec
= op_precedence(rp
->exprblock
.opcode
);
(arg_prec
< prec
|| (arg_prec
== prec
&&
(rp
->exprblock
.opcode
== OPNEG
&& prec
>= op_precedence(OPMINUS
));
erri ("output_binary: format err: '%%%c' illegal",
nice_printf (fp
, "%c", *format
++);
/* Handle Special cases of formatting */
out_call (fp
, (int) e
-> opcode
, e
-> vtype
,
e
-> vleng
, e
-> leftp
, e
-> rightp
);
nice_printf (fp
, "Sorry, can't format OPCODE '%d'",
out_call (outfile
, op
, ftype
, len
, name
, args
)
chainp arglist
; /* Pointer to any actual arguments */
chainp cp
; /* Iterator over argument lists */
Addrp ret_val
= (Addrp
) NULL
;
/* Function return value buffer, if any is
int byvalue
; /* True iff we're calling a C library
int done_once
; /* Used for writing commas to outfile */
/* Don't use addresses if we're calling a C function */
arglist
= args
-> listblock
.listp
;
/* If this is a CHARACTER function, the first argument is the result */
ret_val
= (Addrp
) (arglist
-> datap
);
arglist
= arglist
-> nextp
;
err ("adjustable character function");
/* If this is a COMPLEX function, the first argument is the result */
else if (ISCOMPLEX (ftype
)) {
ret_val
= (Addrp
) (arglist
-> datap
);
arglist
= arglist
-> nextp
;
/* Now we can actually start to write out the function invocation */
if (ftype
== TYREAL
&& forcereal
)
nice_printf(outfile
, "(real)");
if (name
-> tag
== TEXPR
&& name
-> exprblock
.opcode
== OPWHATSIN
) {
nice_printf (outfile
, "(");
np
= (Namep
)name
->exprblock
.leftp
; /*expr_out will free name */
expr_out (outfile
, name
);
nice_printf (outfile
, ")");
/* prepare to cast procedure parameters -- set A if we know how */
if (np
->tag
== TNAME
&& (at
= np
->arginfo
)) {
if (Ansi
&& (at
->defined
|| at
->nargs
> 0))
nice_printf(outfile
, "(");
nice_printf (outfile
, "&");
expr_out (outfile
, (expptr
) ret_val
);
/* The length of the result of a character function is the second argument */
/* It should be in place from putcall(), so we won't touch it explicitly */
done_once
= ret_val
? TRUE
: FALSE
;
/* Now run through the named arguments */
for (cp
= arglist
; cp
; cp
= cp
-> nextp
, done_once
= TRUE
) {
nice_printf (outfile
, ", ");
if (!( q
= (expptr
)cp
->datap
) )
if (q
->addrblock
.vtype
> TYERROR
) {
nice_printf(outfile
, "&%s", q
->addrblock
.user
.ident
);
if (!byvalue
&& q
->addrblock
.isarray
&& q
->addrblock
.vtype
!= TYCHAR
&& q
->addrblock
.memoffset
->tag
== TCONST
) {
/* check for 0 offset -- after */
/* correcting for equivalence. */
L
= q
->addrblock
.memoffset
->constblock
.Const
.ci
;
if (ONEOF(q
->addrblock
.vstg
, M(STGCOMMON
)|M(STGEQUIV
))
&& q
->addrblock
.uname_tag
== UNAM_NAME
)
L
-= q
->addrblock
.user
.name
->voffset
;
if (Ac
&& narg
< at
->dnargs
&& q
->headblock
.vtype
!= (t
= Ac
[narg
].type
)
&& t
> TYADDR
&& t
< TYSUBR
)
nice_printf(outfile
, "(%s*)", typename
[t
]);
/* This also prevents &sizeof(doublereal)[0] */
switch(q
->addrblock
.uname_tag
) {
out_name(outfile
, q
->addrblock
.user
.name
);
nice_printf(outfile
, "%s",
q
->addrblock
.user
.ident
);
nice_printf(outfile
, "%s",
q
->addrblock
.user
.Charp
);
&extsymtab
[q
->addrblock
.memno
]);
/* Skip over the dereferencing operator generated only for the
if (q
-> tag
== TEXPR
&& q
-> exprblock
.opcode
== OPWHATSIN
)
q
= q
-> exprblock
.leftp
;
if (q
->headblock
.vclass
== CLPROC
) {
if (Castargs
&& (q
->tag
!= TNAME
|| q
->nameblock
.vprocclass
!= PTHISPROC
)
|| q
->addrblock
.uname_tag
!= UNAM_NAME
|| q
->addrblock
.user
.name
->vprocclass
if (A
&& (t
= A
[narg
].type
) >= 200)
if (q
->tag
== TNAME
&& q
->nameblock
.vimpltype
)
nice_printf(outfile
, "(%s)", usedcasts
[t
] = casttypes
[t
]);
else if (Ac
&& narg
< at
->dnargs
&& q
->headblock
.vtype
!= (t
= Ac
[narg
].type
)
&& t
> TYADDR
&& t
< TYSUBR
)
nice_printf(outfile
, "(%s*)", typename
[t
]);
if ((q
-> tag
== TADDR
|| q
-> tag
== TNAME
) &&
(byvalue
|| q
-> headblock
.vstg
!= STGREG
)) {
if (q
-> headblock
.vtype
!= TYCHAR
)
q
-> addrblock
.uname_tag
== UNAM_NAME
&&
! q
-> addrblock
.user
.name
-> vdim
&&
oneof_stg(q
-> addrblock
.user
.name
, q
-> addrblock
.vstg
,
M(STGARG
)|M(STGEQUIV
)) &&
! ISCOMPLEX(q
->addrblock
.user
.name
->vtype
))
nice_printf (outfile
, "*");
else if (q
-> tag
== TNAME
&& oneof_stg(&q
->nameblock
, q
-> nameblock
.vstg
,
&& !(q
-> nameblock
.vdim
))
nice_printf (outfile
, "*");
!ONEOF (q
-> addrblock
.vstg
, M(STGEXT
)|M(STGLENG
))
M(STGCOMMON
)|M(STGEQUIV
)|M(STGMEMNO
))
|| ((memoffset
= q
->addrblock
.memoffset
)
|| memoffset
->constblock
.Const
.ci
)))
|| ONEOF(q
->addrblock
.vstg
,
M(STGINIT
)|M(STGAUTO
)|M(STGBSS
))
&& !q
->addrblock
.isarray
)
nice_printf (outfile
, "&");
else if (q
-> tag
== TNAME
&& !oneof_stg(&q
->nameblock
, q
-> nameblock
.vstg
,
M(STGARG
)|M(STGEXT
)|M(STGEQUIV
)))
nice_printf (outfile
, "&");
} /* if q -> tag == TADDR || q -> tag == TNAME */
/* Might be a Constant expression, e.g. string length, character constants */
else if (q
-> tag
== TCONST
) {
out_const(outfile
, &q
->constblock
);
/* Must be some other kind of expression, or register var, or constant.
In particular, this is likely to be a temporary variable assignment
which was generated in p1put_call */
else if (!ISCOMPLEX (q
-> headblock
.vtype
) && !ISCHAR (q
)){
int use_paren
= q
-> tag
== TEXPR
&&
op_precedence (q
-> exprblock
.opcode
) <=
if (use_paren
) nice_printf (outfile
, "(");
if (use_paren
) nice_printf (outfile
, ")");
err ("out_call: unknown parameter");
} /* for (cp = arglist */
nice_printf (outfile
, ")");
sprintf(buf
, fl_fmt_string
, x
);
sprintf(buf
, db_fmt_string
, x
);
/* out_init -- Initialize the data structures used by the routines in
output.c. These structures include the output format to be used for
Float, Double, Complex, and Double Complex constants. */
s
= "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-.";
/* Set the output format for both types of floating point constants */
if (fl_fmt_string
== NULL
|| *fl_fmt_string
== '\0')
fl_fmt_string
= Ansi
== 1 ? "%sf" : "(float)%s";
if (db_fmt_string
== NULL
|| *db_fmt_string
== '\0')
/* Set the output format for both types of complex constants. They will
have string parameters rather than float or double so that the decimal
point may be added to the strings generated by the {db,fl}_fmt_string
if (cm_fmt_string
== NULL
|| *cm_fmt_string
== '\0') {
cm_fmt_string
= "{%s,%s}";
} /* if cm_fmt_string == NULL */
if (dcm_fmt_string
== NULL
|| *dcm_fmt_string
== '\0') {
dcm_fmt_string
= "{%s,%s}";
} /* if dcm_fmt_string == NULL */
void extern_out (fp
, extsym
)
if (extsym
== (Extsym
*) NULL
)
nice_printf (fp
, "%s", extsym
->cextname
);
static void output_list (fp
, listp
)
for (elts
= listp
-> listp
; elts
; elts
= elts
-> nextp
) {
expr_out (fp
, (expptr
) elts
-> datap
);
void out_asgoto (outfile
, expr
)
if (expr
== (expptr
) NULL
) {
err ("out_asgoto: NULL variable expr");
nice_printf (outfile
, Ansi
? "switch (" : "switch ((int)"); /*)*/
expr_out (outfile
, expr
);
nice_printf (outfile
, ") {\n");
/* The initial addrp value will be stored as a namep pointer */
namep
= &expr
->nameblock
;
if (expr
->exprblock
.opcode
== OPWHATSIN
&& expr
->exprblock
.leftp
->tag
== TNAME
)
namep
= &expr
->exprblock
.leftp
->nameblock
;
if (expr
->addrblock
.uname_tag
== UNAM_NAME
) {
/* initialized local variable */
namep
= expr
->addrblock
.user
.name
;
err("out_asgoto: bad expr");
for(k
= 0, value
= namep
-> varxptr
.assigned_values
; value
;
value
= value
->nextp
, k
++) {
nice_printf (outfile
, "case %d: goto %s;\n", k
,
user_label((long)value
->datap
));
nice_printf (outfile
, "}\n");
void out_if (outfile
, expr
)
nice_printf (outfile
, "if (");
expr_out (outfile
, expr
);
nice_printf (outfile
, ") {\n");
output_rbrace(outfile
, s
)
extern int last_was_label
;
nice_printf(outfile
, fmt
, s
);
output_rbrace(outfile
, "} else {\n");
void elif_out (outfile
, expr
)
output_rbrace(outfile
, "} else ");
output_rbrace(outfile
, "}\n");
void end_else_out (outfile
)
output_rbrace(outfile
, "}\n");
void compgoto_out (outfile
, index
, labels
)
err ("compgoto_out: null index for computed goto");
else if (labels
&& labels
-> tag
!= TLIST
)
erri ("compgoto_out: expected label list, got tag '%d'",
extern char *user_label ();
s2
= /*(*/ ") {\n"; /*}*/
else if (index
->tag
== TNAME
|| index
->tag
== TEXPR
&& index
->exprblock
.opcode
== OPWHATSIN
)
s1
= "switch ((int)"; /*)*/
nice_printf(outfile
, s1
);
expr_out (outfile
, index
);
nice_printf (outfile
, s2
);
for (elts
= labels
-> listblock
.listp
; elts
; elts
= elts
-> nextp
, i
++) {
if (ISICON(((expptr
) (elts
-> datap
))))
nice_printf (outfile
, "case %d: goto %s;\n", i
,
user_label(((expptr
)(elts
->datap
))->constblock
.Const
.ci
));
err ("compgoto_out: bad label in label list");
} /* if (elts -> datap) */
nice_printf (outfile
, /*{*/ "}\n");
void out_for (outfile
, init
, test
, inc
)
nice_printf (outfile
, "for (");
expr_out (outfile
, init
);
nice_printf (outfile
, "; ");
expr_out (outfile
, test
);
nice_printf (outfile
, "; ");
nice_printf (outfile
, ") {\n");
void out_end_for (outfile
)
nice_printf (outfile
, "}\n");