/****************************************************************
Copyright 1990, 1991, 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
****************************************************************/
static void p1_addr(), p1_big_addr(), p1_binary(), p1_const(), p1_list(),
p1_literal(), p1_name(), p1_unary(), p1putn();
static void p1putd (/* int, int */);
static void p1putds (/* int, int, char * */);
static void p1putdds (/* int, int, int, char * */);
static void p1putdd (/* int, int, int */);
static void p1putddd (/* int, int, int, int */);
/* p1_comment -- save the text of a Fortran comment in the intermediate
file. Make sure that there are no spurious "/ *" or "* /" characters by
mapping them onto "/+" and "+/". str is assumed to hold no newlines and be
null terminated; it may be modified by this function. */
register unsigned char *pointer
, *ustr
;
/* Get rid of any open or close comment combinations that may be in the
ustr
= (unsigned char *)str
;
for(pointer
= ustr
; *pointer
; pointer
++)
if (*pointer
== '*' && (pointer
[1] == '/'
|| pointer
> ustr
&& pointer
[-1] == '/'))
/* trim trailing white space */
while(--pointer
>= ustr
&& (!isascii(*pointer
) || isspace(*pointer
)));
while(--pointer
>= ustr
&& isspace(*pointer
));
p1puts (P1_COMMENT
, str
);
/* p1_name -- Writes the address of a hash table entry into the
static void p1_name (namep
)
p1putd (P1_NAME_POINTER
, (long) namep
);
/* An opcode of 0 means a null entry */
p1putdd (P1_EXPR
, 0, TYUNKNOWN
); /* Should this be TYERROR? */
} /* if (expr == ENULL) */
p1_const(&expr
->constblock
);
/* Fall through the switch */
p1_addr (&(expr
-> addrblock
));
warn ("p1_expr: got TPRIM");
p1_list (&(expr
->listblock
));
frchain( &(expr
->listblock
.listp
) );
erri ("p1_expr: bad tag '%d'", (int) (expr
-> tag
));
/* Now we know that the tag is TEXPR */
if (is_unary_op (expr
-> exprblock
.opcode
))
p1_unary (&(expr
-> exprblock
));
else if (is_binary_op (expr
-> exprblock
.opcode
))
p1_binary (&(expr
-> exprblock
));
erri ("p1_expr: bad opcode '%d'", (int) expr
-> exprblock
.opcode
);
expptr vleng
= cp
->vleng
;
union Constant
*c
= &cp
->Const
;
char cdsbuf0
[64], cdsbuf1
[64];
fprintf(pass1_file
, "%d: %d %ld\n", P1_CONST
, type
, c
->ci
);
fprintf(pass1_file
, "%d: %d %s\n", P1_CONST
, type
,
cp
->vstg
? c
->cds
[0] : cds(dtos(c
->cd
[0]), cdsbuf0
));
cds0
= cds(dtos(c
->cd
[0]), cdsbuf0
);
cds1
= cds(dtos(c
->cd
[1]), cdsbuf1
);
fprintf(pass1_file
, "%d: %d %s %s\n", P1_CONST
, type
,
if (vleng
&& !ISICON (vleng
))
erri("p1_const: bad vleng '%d'\n", (int) vleng
);
fprintf(pass1_file
, "%d: %d %lx\n", P1_CONST
, type
,
erri ("p1_const: bad constant type '%d'", type
);
p1putd (P1_GOTO
, stateno
);
static void p1_addr (addrp
)
register struct Addrblock
*addrp
;
if (addrp
== (struct Addrblock
*) NULL
)
if (ONEOF(stg
, M(STGINIT
)|M(STGREG
))
|| ONEOF(stg
, M(STGCOMMON
)|M(STGEQUIV
)) &&
(!ISICON(addrp
->memoffset
)
|| (addrp
->uname_tag
== UNAM_NAME
? addrp
->memoffset
->constblock
.Const
.ci
!= addrp
->user
.name
->voffset
: addrp
->memoffset
->constblock
.Const
.ci
))
|| ONEOF(stg
, M(STGBSS
)|M(STGINIT
)|M(STGAUTO
)|M(STGARG
)) &&
(!ISICON(addrp
->memoffset
)
|| addrp
->memoffset
->constblock
.Const
.ci
)
|| addrp
->Field
|| addrp
->isarray
|| addrp
->vstg
== STGLENG
)
/* Write out a level of indirection for non-array arguments, which have
addrp -> memoffset set and are handled by p1_big_addr().
Lengths are passed by value, so don't check STGLENG
28-Jun-89 (dmg) Added the check for != TYCHAR
if (oneof_stg ( addrp
-> uname_tag
== UNAM_NAME
? addrp
-> user
.name
: NULL
,
stg
, M(STGARG
)|M(STGEQUIV
)) && addrp
->vtype
!= TYCHAR
) {
p1putdd (P1_EXPR
, OPWHATSIN
, addrp
-> vtype
);
p1_expr (ENULL
); /* Put dummy vleng */
switch (addrp
-> uname_tag
) {
p1_name (addrp
-> user
.name
);
p1putdds(P1_IDENT
, addrp
->vtype
, addrp
->vstg
,
p1putdds(P1_CHARP
, addrp
->vtype
, addrp
->vstg
,
p1putd (P1_EXTERN
, (long) addrp
-> memno
);
if (addrp
->vclass
== CLPROC
)
extsymtab
[addrp
->memno
].extype
= addrp
->vtype
;
if (addrp
-> memno
!= BAD_MEMNO
)
p1_literal (addrp
-> memno
);
p1_const((struct Constblock
*)addrp
);
erri ("p1_addr: unknown uname_tag '%d'", addrp
-> uname_tag
);
static void p1_list (listp
)
if (listp
== (struct Listblock
*) NULL
)
/* Count the number of parameters in the list */
for (lis
= listp
-> listp
; lis
; lis
= lis
-> nextp
)
p1putddd (P1_LIST
, listp
-> tag
, listp
-> vtype
, count
);
for (lis
= listp
-> listp
; lis
; lis
= lis
-> nextp
)
p1_expr ((expptr
) lis
-> datap
);
earlylabs
= mkchain((char *)lab
, earlylabs
);
static void p1_literal (memno
)
p1putd (P1_LITERAL
, memno
);
static void p1_big_addr (addrp
)
if (addrp
== (Addrp
) NULL
)
p1putn (P1_ADDR
, (int)sizeof(struct Addrblock
), (char *) addrp
);
p1_expr (addrp
-> vleng
);
p1_expr (addrp
-> memoffset
);
if (addrp
->uname_tag
== UNAM_NAME
)
addrp
->user
.name
->visused
= 1;
if (e
== (struct Exprblock
*) NULL
)
p1putdd (P1_EXPR
, (int) e
-> opcode
, e
-> vtype
);
erri ("p1_unary: bad opcode '%d'", (int) e
-> opcode
);
static void p1_binary (e
)
if (e
== (struct Exprblock
*) NULL
)
p1putdd (P1_EXPR
, e
-> opcode
, e
-> vtype
);
void p1_head (class, name
)
p1putds (P1_HEAD
, class, name
? name
: "");
void p1_subr_ret (retexp
)
p1_expr (cpexpr(retexp
));
void p1comp_goto (index
, count
, labels
)
struct Labelblock
*labels
[];
register struct Labelblock
*L
;
/* Write out a P1_LIST directly, to avoid the overhead of allocating a
list before it's needed HACK HACK HACK */
p1putddd (P1_LIST
, TLIST
, TYUNKNOWN
, count
);
for (i
= 0; i
< count
; i
++) {
void p1_for (init
, test
, inc
)
/* ----------------------------------------------------------------------
The intermediate file actually gets written ONLY by the routines below.
To change the format of the file, you need only change these routines.
----------------------------------------------------------------------
/* p1puts -- Put a typed string into the Pass 1 intermediate file. Assumes that
str contains no newlines and is null-terminated. */
fprintf (pass1_file
, "%d: %s\n", type
, str
);
/* p1putd -- Put a typed integer into the Pass 1 intermediate file. */
static void p1putd (type
, value
)
fprintf (pass1_file
, "%d: %ld\n", type
, value
);
/* p1putdd -- Put a typed pair of integers into the intermediate file. */
static void p1putdd (type
, v1
, v2
)
fprintf (pass1_file
, "%d: %d %d\n", type
, v1
, v2
);
/* p1putddd -- Put a typed triple of integers into the intermediate file. */
static void p1putddd (type
, v1
, v2
, v3
)
fprintf (pass1_file
, "%d: %d %d %d\n", type
, v1
, v2
, v3
);
static void p1putn (type
, count
, str
)
fprintf (pass1_file
, "%d: ", type
);
for (i
= 0; i
< count
; i
++)
putc (str
[i
], pass1_file
);
/* p1put -- Put a type marker into the intermediate file. */
fprintf (pass1_file
, "%d:\n", type
);
static void p1putds (type
, i
, str
)
fprintf (pass1_file
, "%d: %d %s\n", type
, i
, str
);
static void p1putdds (token
, type
, stg
, str
)
fprintf (pass1_file
, "%d: %d %d %s\n", token
, type
, stg
, str
);