1957 lines
43 KiB
C
1957 lines
43 KiB
C
/*********************************************************************/
|
|
/* pC++/Sage++ Copyright (C) 1993 */
|
|
/* Indiana University University of Oregon University of Rennes */
|
|
/*********************************************************************/
|
|
|
|
|
|
/****************************************************************
|
|
* *
|
|
* db_unp.c -- contains the procedures required to unparse the *
|
|
* bif graph back to source form for Fortran *
|
|
* *
|
|
****************************************************************/
|
|
|
|
#include <stdlib.h>
|
|
#include "db.h"
|
|
#include "f90.h"
|
|
|
|
#include "compatible.h"
|
|
#ifdef SYS5
|
|
#include <string.h>
|
|
#else
|
|
#include <strings.h>
|
|
#endif
|
|
|
|
#define NULLTEST(VAR) (VAR == NULL? -1 : VAR->id)
|
|
#define type_index(X) (X-T_INT)
|
|
#define binop(n) (n >= EQ_OP && n <= NEQV_OP)
|
|
|
|
PTR_SYMB cur_symb_head; /* point to the head of the list of symbols */
|
|
/* used to search type that LIKE the current*/
|
|
|
|
#ifdef __SPF
|
|
extern void addToCollection(const int line, const char *file, void *pointer, int type);
|
|
#endif
|
|
|
|
int figure_tabs();
|
|
//TODO: allocate buffer dynamically
|
|
//used in vpc.c
|
|
#define BUFLEN 500000
|
|
char buffer[BUFLEN], *bp;
|
|
|
|
static int in_param = 0; /* set if unparsing the parameter statement */
|
|
static int in_impli = 0; /* set if unparsing the implicit statement */
|
|
static PTR_CMNT cmnt = NULL; /* point to chain of comment list */
|
|
static int print_comments = 1; /* 0 if no comments */
|
|
static char first = 1; /* used when unparsing LOGGOTO which has two */
|
|
/* ... bif nodes */
|
|
|
|
/*
|
|
* Forward references
|
|
*/
|
|
static void unp_llnd();
|
|
|
|
|
|
/*
|
|
* Ascii names for operators in the language
|
|
*/
|
|
static
|
|
char *fop_name[] = {
|
|
" .eq. ",
|
|
" .lt. ",
|
|
" .gt. ",
|
|
" .ne. ",
|
|
" .le. ",
|
|
" .ge. ",
|
|
"+",
|
|
"-",
|
|
" .or. ",
|
|
"*",
|
|
"/",
|
|
"",
|
|
" .and. ",
|
|
"**",
|
|
"",
|
|
"//",
|
|
" .xor. ",
|
|
" .eqv. ",
|
|
" .neqv. "
|
|
};
|
|
|
|
|
|
/*
|
|
* Precedence table of operators for Fortran
|
|
*/
|
|
static
|
|
char precedence[] = { /* precedence table of the operators */
|
|
5, /* .eq. */
|
|
5, /* .lt. */
|
|
5, /* .gt. */
|
|
5, /* .ne. */
|
|
5, /* .le. */
|
|
5, /* .ge. */
|
|
3, /* + */
|
|
3, /* - */
|
|
8, /* .or. */
|
|
2, /* * */
|
|
2, /* / */
|
|
0, /* none */
|
|
7, /* .and. */
|
|
1, /* ** */
|
|
0, /* none */
|
|
4, /* // */
|
|
8, /* .xor. */
|
|
9, /* .eqv. */
|
|
9 /* .neqv. */
|
|
};
|
|
|
|
|
|
/*
|
|
* Type names in ascii form
|
|
*/
|
|
static
|
|
char *ftype_name[] = {
|
|
"integer",
|
|
"real",
|
|
"double precision",
|
|
"character",
|
|
"logical",
|
|
"character",
|
|
"gate",
|
|
"event",
|
|
"sequence",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"complex",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"",
|
|
"double complex"
|
|
};
|
|
|
|
|
|
/****************************************************************
|
|
* *
|
|
* put_tabs -- indent the statement by putting some blanks *
|
|
* *
|
|
* Input: *
|
|
* n - number of tabs wanted *
|
|
* *
|
|
****************************************************************/
|
|
static void
|
|
put_tabs(n)
|
|
int n;
|
|
{
|
|
int i;
|
|
|
|
for(i = 0; i < n; i++) {
|
|
*bp++ = ' ';
|
|
*bp++ = ' ';
|
|
}
|
|
}
|
|
|
|
|
|
/****************************************************************
|
|
* *
|
|
* figure_tabs -- figure out the indentation level of the *
|
|
* given bif node *
|
|
* *
|
|
* Input: *
|
|
* bf - the bif node pointer *
|
|
* *
|
|
* Output: *
|
|
* an integer indicating the indentation level *
|
|
* *
|
|
****************************************************************/
|
|
int
|
|
figure_tabs(bf)
|
|
PTR_BFND bf;
|
|
{
|
|
int count = 0;
|
|
|
|
while(bf->variant != PROG_HEDR && bf->variant != PROC_HEDR &&
|
|
bf->variant != FUNC_HEDR && bf->variant != GLOBAL){
|
|
if(bf->variant != ELSEIF_NODE) count++;
|
|
bf = bf->control_parent;
|
|
}
|
|
return(count);
|
|
}
|
|
|
|
|
|
/****************************************************************
|
|
* *
|
|
* addstr -- add the string "s" to output buffer *
|
|
* *
|
|
* Input: *
|
|
* s - the string to be appended to the buffer *
|
|
* *
|
|
* Side effect: *
|
|
* bp - points to where next character will go *
|
|
* *
|
|
****************************************************************/
|
|
static void
|
|
addstr(s)
|
|
char *s;
|
|
{
|
|
while( (*bp = *s++) != 0)
|
|
bp++;
|
|
}
|
|
|
|
|
|
/*
|
|
* pr_ftype_name(ptype) -- print out the variable type.
|
|
*/
|
|
static int
|
|
pr_ftype_name(ptype, def)
|
|
PTR_TYPE ptype;
|
|
int def; /* def = 1 means it is a type define,
|
|
print the whole type
|
|
def = 0 : the type has a name. */
|
|
|
|
{ int gen_rec_decl ();
|
|
|
|
|
|
if (ptype == NULL) return(0);
|
|
|
|
if (def == 0 && ptype->name) { /* print the type name */
|
|
addstr (ptype->name->ident);
|
|
return(1);
|
|
}
|
|
|
|
switch (ptype->variant) {
|
|
case T_INT :
|
|
case T_FLOAT :
|
|
case T_DOUBLE:
|
|
case T_CHAR :
|
|
case T_BOOL :
|
|
case T_STRING:
|
|
case T_COMPLEX:
|
|
addstr (ftype_name[ptype->variant - T_INT]);
|
|
break;
|
|
case T_DCOMPLEX:
|
|
addstr (ftype_name[ptype->variant - T_INT]);
|
|
break;
|
|
case T_GATE:
|
|
addstr ("gate");
|
|
break;
|
|
case T_EVENT:
|
|
addstr ("event");
|
|
break;
|
|
case T_SEQUENCE:
|
|
addstr ("sequence");
|
|
break;
|
|
case T_ARRAY :
|
|
pr_ftype_name (ptype->entry.ar_decl.base_type, 0);
|
|
break;
|
|
case T_DERIVED_TYPE:
|
|
addstr("type (");
|
|
addstr(ptype->name->ident);
|
|
addstr(")");
|
|
break;
|
|
case T_POINTER:
|
|
pr_ftype_name(ptype->entry.Template.base_type,0);
|
|
break;
|
|
|
|
default :
|
|
return 0;
|
|
}
|
|
return (1);
|
|
}
|
|
|
|
|
|
static void
|
|
gen_loop_header(looptype, pbf)
|
|
char *looptype;
|
|
PTR_BFND pbf;
|
|
{
|
|
char label[7];
|
|
|
|
addstr(looptype);
|
|
if ((pbf->variant == PARDO_NODE) || (pbf->variant == PDO_NODE))
|
|
if (pbf->entry.for_node.where_cond)
|
|
{
|
|
addstr(" ( ");
|
|
unp_llnd(pbf->entry.for_node.where_cond);
|
|
addstr(" ) ");
|
|
}
|
|
if (pbf->entry.for_node.doend) {
|
|
sprintf(label,"%d ",(int)(pbf->entry.for_node.doend->stateno));
|
|
addstr(label);
|
|
}
|
|
addstr(pbf->entry.for_node.control_var->ident);
|
|
addstr(" = ");
|
|
unp_llnd(pbf->entry.for_node.range->entry.binary_op.l_operand);
|
|
addstr(", ");
|
|
unp_llnd(pbf->entry.for_node.range->entry.binary_op.r_operand);
|
|
if (pbf->entry.for_node.increment) {
|
|
addstr(" , ");
|
|
unp_llnd(pbf->entry.for_node.increment);
|
|
}
|
|
}
|
|
|
|
|
|
/*
|
|
* gen_if_node(pbf) --- generate the if statement pointed to by pbf.
|
|
*/
|
|
static void
|
|
gen_branch(branch_tag, branch_type, pbf)
|
|
int branch_tag;
|
|
char *branch_type;
|
|
PTR_BFND pbf;
|
|
{
|
|
addstr(branch_type);
|
|
*bp++ = '(';
|
|
unp_llnd(pbf->entry.if_node.condition);
|
|
*bp++ = ')';
|
|
if (branch_tag != WHERE_BLOCK_STMT)
|
|
addstr(" then");
|
|
}
|
|
|
|
|
|
/****************************************************************
|
|
* *
|
|
* unp_llnd -- unparse the given low level node to source *
|
|
* string *
|
|
* *
|
|
* Input: *
|
|
* pllnd - low level node to be unparsed *
|
|
* bp (implicitely) - where the output string to be *
|
|
* placed *
|
|
* *
|
|
* Output: *
|
|
* the unparse string where "bp" was pointed to *
|
|
* *
|
|
* Side Effect: *
|
|
* "bp" will be updated to the next character behind *
|
|
* the end of the unparsed string (by "addstr") *
|
|
* *
|
|
****************************************************************/
|
|
static void
|
|
unp_llnd(pllnd)
|
|
PTR_LLND pllnd;
|
|
{
|
|
if (pllnd == NULL) return;
|
|
|
|
switch (pllnd->variant) {
|
|
case INT_VAL :
|
|
{ char sb[64];
|
|
|
|
sprintf(sb, "%d", pllnd->entry.ival);
|
|
addstr(sb);
|
|
break;
|
|
}
|
|
case LABEL_REF:
|
|
{ char sb[64];
|
|
|
|
sprintf(sb, "%d",(int)( pllnd->entry.label_list.lab_ptr->stateno));
|
|
addstr(sb);
|
|
break;
|
|
}
|
|
case FLOAT_VAL :
|
|
case DOUBLE_VAL :
|
|
case STMT_STR :
|
|
addstr(pllnd->entry.string_val);
|
|
break;
|
|
case STRING_VAL :
|
|
*bp++ = '\'';
|
|
addstr(pllnd->entry.string_val);
|
|
*bp++ = '\'';
|
|
break;
|
|
case COMPLEX_VAL :
|
|
*bp++ = '(';
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
*bp++ = ',';
|
|
unp_llnd(pllnd->entry.Template.ll_ptr2);
|
|
*bp++ = ')';
|
|
break;
|
|
case KEYWORD_VAL :
|
|
addstr(pllnd->entry.string_val);
|
|
break;
|
|
case KEYWORD_ARG :
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
addstr("=");
|
|
unp_llnd(pllnd->entry.Template.ll_ptr2);
|
|
break;
|
|
case BOOL_VAL :
|
|
addstr(pllnd->entry.bval ? ".TRUE." : ".FALSE.");
|
|
break;
|
|
case CHAR_VAL :
|
|
if (! in_impli)
|
|
*bp++ = '\'';
|
|
*bp++ = pllnd->entry.cval;
|
|
if (! in_impli)
|
|
*bp++ = '\'';
|
|
break;
|
|
case CONST_REF :
|
|
case VAR_REF :
|
|
case ENUM_REF :
|
|
case TYPE_REF :
|
|
case INTERFACE_REF:
|
|
addstr(pllnd->entry.Template.symbol->ident);
|
|
/* Look out !!!! */
|
|
/* Purpose unknown. Commented out. */
|
|
/*
|
|
if (pllnd->entry.Template.symbol->type->entry.Template.ranges != LLNULL)
|
|
unp_llnd(pllnd->entry.Template.symbol->type->entry.Template.ranges);
|
|
*/
|
|
break;
|
|
case ARRAY_REF :
|
|
addstr(pllnd->entry.array_ref.symbol->ident);
|
|
if (pllnd->entry.array_ref.index) {
|
|
*bp++ = '(';
|
|
unp_llnd(pllnd->entry.array_ref.index);
|
|
*bp++ = ')';
|
|
}
|
|
break;
|
|
case ARRAY_OP :
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
*bp++ = '(';
|
|
unp_llnd(pllnd->entry.Template.ll_ptr2);
|
|
*bp++ = ')';
|
|
break;
|
|
case RECORD_REF :
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
addstr("%");
|
|
unp_llnd(pllnd->entry.Template.ll_ptr2);
|
|
break;
|
|
case STRUCTURE_CONSTRUCTOR :
|
|
addstr(pllnd->entry.Template.symbol->ident);
|
|
*bp++ = '(';
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
*bp++ = ')';
|
|
break;
|
|
case CONSTRUCTOR_REF :
|
|
addstr("(/");
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
addstr("/)");
|
|
break;
|
|
case ACCESS_REF :
|
|
unp_llnd(pllnd->entry.access_ref.access);
|
|
if (pllnd->entry.access_ref.index != NULL) {
|
|
*bp++ = '(';
|
|
unp_llnd(pllnd->entry.access_ref.index);
|
|
*bp++ = ')';
|
|
}
|
|
break;
|
|
case OVERLOADED_CALL:
|
|
break;
|
|
case CONS :
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
addstr(",");
|
|
unp_llnd(pllnd->entry.Template.ll_ptr2);
|
|
break;
|
|
case ACCESS :
|
|
unp_llnd(pllnd->entry.access.array);
|
|
addstr(", FORALL=(");
|
|
addstr(pllnd->entry.access.control_var->ident);
|
|
*bp++ = '=';
|
|
unp_llnd(pllnd->entry.access.range);
|
|
*bp++ = ')';
|
|
break;
|
|
case IOACCESS :
|
|
*bp++ = '(';
|
|
unp_llnd(pllnd->entry.ioaccess.array);
|
|
addstr(", ");
|
|
addstr(pllnd->entry.ioaccess.control_var->ident);
|
|
*bp++ = '=';
|
|
unp_llnd(pllnd->entry.ioaccess.range);
|
|
*bp++ = ')';
|
|
break;
|
|
case PROC_CALL :
|
|
case FUNC_CALL :
|
|
addstr(pllnd->entry.proc.symbol->ident);
|
|
*bp++ = '(';
|
|
unp_llnd(pllnd->entry.proc.param_list);
|
|
*bp++ = ')';
|
|
break;
|
|
case EXPR_LIST :
|
|
unp_llnd(pllnd->entry.list.item);
|
|
if (in_param) {
|
|
addstr("=");
|
|
unp_llnd(pllnd->entry.list.item->entry.const_ref.symbol->entry.const_value);
|
|
}
|
|
if (pllnd->entry.list.next) {
|
|
addstr(", ");
|
|
unp_llnd(pllnd->entry.list.next);
|
|
}
|
|
break;
|
|
case EQUI_LIST :
|
|
*bp++ = '(';
|
|
unp_llnd(pllnd->entry.list.item);
|
|
*bp++ = ')';
|
|
if (pllnd->entry.list.next) {
|
|
addstr(", ");
|
|
unp_llnd(pllnd->entry.list.next);
|
|
}
|
|
break;
|
|
case COMM_LIST :
|
|
case NAMELIST_LIST:
|
|
if (pllnd->entry.Template.symbol) {
|
|
*bp++ = '/';
|
|
addstr(pllnd->entry.Template.symbol->ident);
|
|
*bp++ = '/';
|
|
}
|
|
unp_llnd(pllnd->entry.list.item);
|
|
if (pllnd->entry.list.next) {
|
|
addstr(", ");
|
|
unp_llnd(pllnd->entry.list.next);
|
|
}
|
|
break;
|
|
case VAR_LIST :
|
|
case RANGE_LIST :
|
|
case CONTROL_LIST:
|
|
unp_llnd(pllnd->entry.list.item);
|
|
if (pllnd->entry.list.next) {
|
|
addstr(",");
|
|
unp_llnd(pllnd->entry.list.next);
|
|
}
|
|
break;
|
|
case DDOT :
|
|
if (pllnd->entry.binary_op.l_operand)
|
|
unp_llnd(pllnd->entry.binary_op.l_operand);
|
|
*bp++ = in_impli? '-' : ':';
|
|
if (pllnd->entry.binary_op.r_operand)
|
|
unp_llnd(pllnd->entry.binary_op.r_operand);
|
|
break;
|
|
case DEFAULT:
|
|
addstr("default");
|
|
break;
|
|
case DEF_CHOICE :
|
|
case SEQ :
|
|
unp_llnd(pllnd->entry.seq.ddot);
|
|
if (pllnd->entry.seq.stride) {
|
|
*bp++ = ':';
|
|
unp_llnd(pllnd->entry.seq.stride);
|
|
}
|
|
break;
|
|
case SPEC_PAIR :
|
|
unp_llnd(pllnd->entry.spec_pair.sp_label);
|
|
*bp++ = '=';
|
|
unp_llnd(pllnd->entry.spec_pair.sp_value);
|
|
break;
|
|
case EQ_OP :
|
|
case LT_OP :
|
|
case GT_OP :
|
|
case NOTEQL_OP :
|
|
case LTEQL_OP :
|
|
case GTEQL_OP :
|
|
case ADD_OP :
|
|
case SUBT_OP :
|
|
case OR_OP :
|
|
case MULT_OP :
|
|
case DIV_OP :
|
|
case MOD_OP :
|
|
case AND_OP :
|
|
case EXP_OP :
|
|
case CONCAT_OP :
|
|
{
|
|
int i = pllnd->variant - EQ_OP, j;
|
|
PTR_LLND p;
|
|
int num_paren = 0;
|
|
|
|
p = pllnd->entry.binary_op.l_operand;
|
|
j = p->variant;
|
|
if (binop(j) && precedence[i] < precedence[j-EQ_OP]) {
|
|
num_paren++;
|
|
*bp++ = '(';
|
|
}
|
|
unp_llnd(p);
|
|
if (num_paren) {
|
|
*bp++ = ')';
|
|
num_paren--;
|
|
}
|
|
addstr(fop_name[i]); /* print the op name */
|
|
p = pllnd->entry.binary_op.r_operand;
|
|
j = p->variant;
|
|
if (binop(j) && precedence[i] <= precedence[j-EQ_OP]) {
|
|
num_paren++;
|
|
*bp++ = '(';
|
|
}
|
|
unp_llnd(p);
|
|
if (num_paren) {
|
|
*bp++ = ')';
|
|
num_paren--;
|
|
}
|
|
break;
|
|
}
|
|
case MINUS_OP :
|
|
addstr(" -(");
|
|
unp_llnd(pllnd->entry.unary_op.operand);
|
|
*bp++ = ')';
|
|
break;
|
|
case UNARY_ADD_OP :
|
|
addstr(" +(");
|
|
unp_llnd(pllnd->entry.unary_op.operand);
|
|
*bp++ = ')';
|
|
break;
|
|
case NOT_OP :
|
|
addstr(" .not. (");
|
|
unp_llnd(pllnd->entry.unary_op.operand);
|
|
*bp++ = ')';
|
|
break;
|
|
case PAREN_OP:
|
|
addstr("(");
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
case ASSGN_OP:
|
|
addstr("=");
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
case STAR_RANGE :
|
|
addstr(" : ");
|
|
break;
|
|
case IMPL_TYPE:
|
|
pr_ftype_name(pllnd->type, 1);
|
|
if (pllnd->entry.Template.ll_ptr1 != LLNULL)
|
|
{
|
|
addstr("(");
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
}
|
|
break;
|
|
case ORDERED_OP :
|
|
addstr("ordered ");
|
|
break;
|
|
case EXTEND_OP :
|
|
addstr("extended ");
|
|
break;
|
|
case MAXPARALLEL_OP:
|
|
addstr("max parallel = ");
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
break;
|
|
case PARAMETER_OP :
|
|
addstr("parameter ");
|
|
break;
|
|
case PUBLIC_OP :
|
|
addstr("public ");
|
|
break;
|
|
case PRIVATE_OP :
|
|
addstr("private ");
|
|
break;
|
|
case ALLOCATABLE_OP :
|
|
addstr("allocatable ");
|
|
break;
|
|
case DIMENSION_OP :
|
|
addstr("dimension (");
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
break;
|
|
case EXTERNAL_OP :
|
|
addstr("external ");
|
|
break;
|
|
case OPTIONAL_OP :
|
|
addstr("optional ");
|
|
break;
|
|
case IN_OP :
|
|
addstr("intent (in) ");
|
|
break;
|
|
case OUT_OP :
|
|
addstr("intent (out) ");
|
|
break;
|
|
case INOUT_OP :
|
|
addstr("intent (inout) ");
|
|
break;
|
|
case INTRINSIC_OP :
|
|
addstr("intrinsic ");
|
|
break;
|
|
case POINTER_OP :
|
|
addstr("pointer ");
|
|
break;
|
|
case SAVE_OP :
|
|
addstr("save ");
|
|
break;
|
|
case TARGET_OP :
|
|
addstr("target ");
|
|
break;
|
|
case LEN_OP :
|
|
addstr("*");
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
break;
|
|
case TYPE_OP :
|
|
pr_ftype_name(pllnd->type, 1);
|
|
unp_llnd(pllnd->type->entry.Template.ranges);
|
|
break;
|
|
case ONLY_NODE :
|
|
addstr("only: ");
|
|
if (pllnd->entry.Template.ll_ptr1)
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
break;
|
|
case DEREF_OP :
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
break;
|
|
case RENAME_NODE :
|
|
unp_llnd(pllnd->entry.Template.ll_ptr1);
|
|
addstr("=>");
|
|
unp_llnd(pllnd->entry.Template.ll_ptr2);
|
|
break;
|
|
case VARIABLE_NAME :
|
|
addstr(pllnd->entry.Template.symbol->ident);
|
|
break;
|
|
default :
|
|
fprintf(stderr,"unp_llnd -- bad llnd ptr %d!\n",pllnd->variant);
|
|
break;
|
|
}
|
|
}
|
|
|
|
|
|
/****************************************************************
|
|
* *
|
|
* funp_bfnd -- unparse the given bif node to source string *
|
|
* *
|
|
* Input: *
|
|
* tabs- number of tabs (2 spaces) for indenting *
|
|
* pbf - bif node to be unparsed *
|
|
* bp (implicitely) - where the output string to be *
|
|
* placed *
|
|
* *
|
|
* Output: *
|
|
* the unparse string where "bp" was pointed to *
|
|
* *
|
|
* Side Effect: *
|
|
* "bp" will be updated to the next character behind *
|
|
* the end of the unparsed string (by "addstr") *
|
|
* *
|
|
****************************************************************/
|
|
static void
|
|
funp_bfnd(tabs,pbf)
|
|
int tabs;
|
|
PTR_BFND pbf;
|
|
{
|
|
PTR_SYMB s;
|
|
|
|
if (pbf == NULL) return;
|
|
if (pbf->label) {
|
|
char b[10];
|
|
|
|
sprintf(b ,"%-5d ", (int)(pbf->label->stateno));
|
|
addstr(b);
|
|
} else
|
|
addstr(" ");
|
|
|
|
put_tabs(tabs);
|
|
switch (pbf->variant) {
|
|
case GLOBAL :
|
|
break;
|
|
case PROG_HEDR : /* program header */
|
|
addstr("program ");
|
|
if (pbf->entry.program.prog_symb &&
|
|
strcmp(pbf->entry.program.prog_symb->ident, (char *)"_MAIN")) {
|
|
addstr(pbf->entry.program.prog_symb->ident);
|
|
}
|
|
break;
|
|
case BLOCK_DATA :
|
|
addstr("block data ");
|
|
if (pbf->entry.program.prog_symb &&
|
|
strcmp(pbf->entry.program.prog_symb->ident, (char *)"_BLOCK")) {
|
|
addstr(pbf->entry.program.prog_symb->ident);
|
|
}
|
|
break;
|
|
case PROC_HEDR :
|
|
if (pbf->entry.procedure.proc_symb->attr & RECURSIVE_BIT)
|
|
addstr("recursive");
|
|
addstr("subroutine ");
|
|
addstr(pbf->entry.procedure.proc_symb->ident);
|
|
*bp++ = '(';
|
|
s = pbf->entry.procedure.proc_symb->entry.proc_decl.in_list;
|
|
while (s) {
|
|
addstr(s->ident);
|
|
s = s->entry.var_decl.next_in;
|
|
if (s) *bp++ = ',';
|
|
}
|
|
*bp++ = ')';
|
|
break;
|
|
case FUNC_HEDR :
|
|
if (pbf->entry.function.func_symb->attr & RECURSIVE_BIT)
|
|
addstr("recursive");
|
|
addstr(ftype_name[type_index(pbf->entry.function.func_symb->type->variant)]);
|
|
addstr(" function ");
|
|
addstr(pbf->entry.function.func_symb->ident);
|
|
*bp++ = '(';
|
|
s = pbf->entry.function.func_symb->entry.proc_decl.in_list;
|
|
while (s) {
|
|
addstr(s->ident);
|
|
s = s->entry.var_decl.next_in;
|
|
if (s) *bp++ = ',';
|
|
}
|
|
addstr(") ");
|
|
if (pbf->entry.Template.ll_ptr1)
|
|
{
|
|
addstr("result (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
}
|
|
break;
|
|
case ENTRY_STAT :
|
|
addstr("entry ");
|
|
addstr(pbf->entry.function.func_symb->ident);
|
|
*bp++ = '(';
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
/*
|
|
s = pbf->entry.function.func_symb->entry.proc_decl.in_list;
|
|
while (s) {
|
|
addstr(s->ident);
|
|
s = s->entry.var_decl.next_in;
|
|
if (s) *bp++ = ',';
|
|
}
|
|
*/
|
|
addstr(") ");
|
|
break;
|
|
case INTERFACE_STMT:
|
|
{
|
|
PTR_SYMB s;
|
|
char *c;
|
|
|
|
addstr("interface ");
|
|
if ( (s = (pbf->entry.Template.symbol)) != 0)
|
|
{
|
|
c = s->ident;
|
|
if (*c == '.')
|
|
{
|
|
addstr("operator (");
|
|
addstr(c);
|
|
addstr(")");
|
|
}
|
|
else if (*c == '=')
|
|
{
|
|
addstr("assignment (");
|
|
addstr("=");
|
|
addstr(")");
|
|
}
|
|
else addstr(c);
|
|
}
|
|
}
|
|
break;
|
|
case MODULE_STMT:
|
|
addstr("module ");
|
|
addstr(pbf->entry.Template.symbol->ident);
|
|
break;
|
|
case CASE_NODE:
|
|
if (pbf->entry.Template.ll_ptr3)
|
|
{
|
|
unp_llnd(pbf->entry.Template.ll_ptr3);
|
|
addstr(":");
|
|
}
|
|
addstr("select case (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
break;
|
|
case SWITCH_NODE :
|
|
addstr("case (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
if (pbf->entry.Template.symbol)
|
|
addstr(pbf->entry.Template.symbol->ident);
|
|
break;
|
|
case IF_NODE :
|
|
/* if (pbf->entry.Template.ll_ptr3)
|
|
{
|
|
unp_llnd(pbf->entry.Template.ll_ptr3);
|
|
addstr(":");
|
|
} */
|
|
gen_branch(IF_NODE, "if ", pbf);
|
|
break;
|
|
case LOGIF_NODE :
|
|
addstr("if (");
|
|
unp_llnd(pbf->entry.if_node.condition);
|
|
addstr(") ");
|
|
break;
|
|
case ELSEIF_NODE:
|
|
gen_branch(IF_NODE, "else if", pbf);
|
|
break;
|
|
case ARITHIF_NODE:
|
|
addstr("if (");
|
|
unp_llnd(pbf->entry.if_node.condition);
|
|
addstr(") ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
break;
|
|
case WHERE_BLOCK_STMT:
|
|
gen_branch(WHERE_BLOCK_STMT, "where ", pbf);
|
|
break;
|
|
case WHERE_NODE:
|
|
addstr("where (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(") ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(" = ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr3);
|
|
break;
|
|
case PARDO_NODE :
|
|
gen_loop_header("parallel do ", pbf);
|
|
break;
|
|
case PDO_NODE :
|
|
gen_loop_header("pdo ", pbf);
|
|
break;
|
|
case FOR_NODE :
|
|
if (pbf->entry.Template.ll_ptr3)
|
|
{
|
|
unp_llnd(pbf->entry.Template.ll_ptr3);
|
|
addstr(":");
|
|
}
|
|
gen_loop_header("do ",pbf);
|
|
break;
|
|
case CDOALL_NODE :
|
|
gen_loop_header("cdoall ",pbf);
|
|
break;
|
|
case WHILE_NODE :
|
|
if (pbf->entry.Template.ll_ptr3)
|
|
{
|
|
unp_llnd(pbf->entry.Template.ll_ptr3);
|
|
addstr(":");
|
|
}
|
|
addstr("do ");
|
|
if (pbf->entry.for_node.doend) {
|
|
char label[7];
|
|
|
|
sprintf(label,"%d ",(int)(pbf->entry.for_node.doend->stateno));
|
|
addstr(label);
|
|
}
|
|
addstr(" while (");
|
|
unp_llnd(pbf->entry.while_node.condition);
|
|
*bp++ = ')';
|
|
break;
|
|
case ASSIGN_STAT:
|
|
unp_llnd(pbf->entry.assign.l_value);
|
|
addstr(" = ");
|
|
unp_llnd(pbf->entry.assign.r_value);
|
|
break;
|
|
case IDENTIFY:
|
|
addstr("identify ");
|
|
unp_llnd(pbf->entry.identify.l_value);
|
|
*bp++ = ' ';
|
|
unp_llnd(pbf->entry.identify.r_value);
|
|
break;
|
|
case PRIVATE_STMT:
|
|
addstr("private ");
|
|
if (pbf->entry.Template.ll_ptr1)
|
|
{
|
|
addstr(":: ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
}
|
|
break;
|
|
case PUBLIC_STMT:
|
|
addstr("public ");
|
|
if (pbf->entry.Template.ll_ptr1)
|
|
{
|
|
addstr(":: ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
}
|
|
break;
|
|
case STRUCT_DECL:
|
|
{
|
|
PTR_LLND l;
|
|
addstr("type ");
|
|
|
|
if ( (l = pbf->entry.Template.ll_ptr1) != 0)
|
|
{
|
|
addstr(",");
|
|
unp_llnd(l);
|
|
addstr("::");
|
|
}
|
|
|
|
addstr(pbf->entry.Template.symbol->ident);
|
|
}
|
|
break;
|
|
case SEQUENCE_STMT:
|
|
addstr("sequence ");
|
|
break;
|
|
case CONTAINS_STMT:
|
|
addstr("contains ");
|
|
break;
|
|
case OVERLOADED_ASSIGN_STAT:
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr("=");
|
|
unp_llnd(pbf->entry.Template.ll_ptr3);
|
|
break;
|
|
case OVERLOADED_PROC_STAT:
|
|
case PROC_STAT :
|
|
addstr("call ");
|
|
addstr(pbf->entry.Template.symbol->ident);
|
|
*bp++ = '(';
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
*bp++ = ')';
|
|
break;
|
|
case STMTFN_STAT:
|
|
{PTR_SYMB p;
|
|
PTR_LLND body;
|
|
|
|
body = pbf->entry.Template.ll_ptr1;
|
|
p = body->entry.Template.symbol;
|
|
addstr(p->ident);
|
|
*bp++ = '(';
|
|
p=p->entry.func_decl.in_list;
|
|
while (p) {
|
|
addstr(p->ident);
|
|
if( (p=p->entry.var_decl.next_in) != 0) *bp++ = ',';
|
|
}
|
|
addstr(") = ");
|
|
unp_llnd(body->entry.Template.ll_ptr1);
|
|
break;
|
|
}
|
|
case SAVE_DECL:
|
|
addstr("save ");
|
|
if (pbf->entry.Template.ll_ptr1)
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
else
|
|
addstr("all");
|
|
break;
|
|
case CONT_STAT:
|
|
addstr("continue");
|
|
break;
|
|
case FORMAT_STAT:
|
|
/* addstr("format ("); */
|
|
unp_llnd(pbf->entry.format.spec_string);
|
|
/* *bp++ = ')'; */
|
|
break;
|
|
case GOTO_NODE:
|
|
addstr("goto ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr3);
|
|
break;
|
|
case ASSGOTO_NODE:
|
|
addstr("goto ");
|
|
addstr(pbf->entry.Template.symbol->ident);
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case COMGOTO_NODE:
|
|
addstr("goto (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(") ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
break;
|
|
case STOP_STAT:
|
|
addstr("stop");
|
|
if (pbf->entry.Template.ll_ptr1) {
|
|
addstr("'");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr("'");
|
|
}
|
|
break;
|
|
case RETURN_STAT:
|
|
addstr("return");
|
|
break;
|
|
case OPTIONAL_STMT:
|
|
addstr("optional :: ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case VAR_DECL:
|
|
{
|
|
PTR_LLND p = pbf->entry.Template.ll_ptr1;
|
|
/* PTR_TYPE q;
|
|
|
|
q = p->entry.list.item->entry.Template.symbol->type;
|
|
if (q->variant == T_ARRAY)
|
|
q = q->entry.ar_decl.base_type;
|
|
addstr(ftype_name[type_index(q->variant)]);
|
|
*bp++ = ' '; */
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
if (pbf->entry.Template.ll_ptr3)
|
|
{
|
|
addstr(",");
|
|
unp_llnd(pbf->entry.Template.ll_ptr3);
|
|
addstr("::");
|
|
}
|
|
else addstr(" ");
|
|
unp_llnd(p);
|
|
break;
|
|
}
|
|
case INTENT_STMT:
|
|
{
|
|
PTR_SYMB s;
|
|
PTR_LLND p = pbf->entry.Template.ll_ptr1;
|
|
|
|
addstr("intent ");
|
|
s = p->entry.list.item->entry.Template.symbol;
|
|
if (s->attr & IN_BIT)
|
|
addstr("(in) :: ");
|
|
if (s->attr & OUT_BIT)
|
|
addstr("(out) :: ");
|
|
if (s->attr & INOUT_BIT)
|
|
addstr("(inout) :: ");
|
|
unp_llnd(p);
|
|
break;
|
|
}
|
|
case PARAM_DECL:
|
|
addstr("parameter (");
|
|
in_param = 1;
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
in_param = 0;
|
|
break;
|
|
case DIM_STAT:
|
|
addstr("dimension ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case ALLOCATABLE_STMT:
|
|
addstr("allocatable :: ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case POINTER_STMT:
|
|
addstr("pointer :: ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case TARGET_STMT:
|
|
addstr("target :: ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case ALLOCATE_STMT:
|
|
addstr("allocate (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
if (pbf->entry.Template.ll_ptr2)
|
|
{
|
|
addstr(", stat = ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
}
|
|
addstr(")");
|
|
break;
|
|
case DEALLOCATE_STMT:
|
|
addstr("deallocate (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
if (pbf->entry.Template.ll_ptr2)
|
|
{
|
|
addstr(", stat = ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
}
|
|
addstr(")");
|
|
break;
|
|
case NULLIFY_STMT:
|
|
addstr("nullify (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
break;
|
|
case MODULE_PROC_STMT:
|
|
addstr("module procedure ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case POINTER_ASSIGN_STAT:
|
|
addstr(pbf->entry.Template.symbol->ident);
|
|
addstr("=> ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case CYCLE_STMT:
|
|
addstr("cycle ");
|
|
addstr(pbf->entry.Template.symbol->ident);
|
|
break;
|
|
case EXIT_STMT:
|
|
addstr("exit ");
|
|
addstr(pbf->entry.Template.symbol->ident);
|
|
break;
|
|
case USE_STMT:
|
|
addstr("use ");
|
|
addstr(pbf->entry.Template.symbol->ident);
|
|
if (pbf->entry.Template.ll_ptr1)
|
|
{
|
|
addstr(", ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
}
|
|
break;
|
|
case EQUI_STAT:
|
|
addstr("equivalence ");
|
|
case DATA_DECL:
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case IMPL_DECL:
|
|
addstr("implicit ");
|
|
if (pbf->entry.Template.ll_ptr1 == NULL)
|
|
addstr("none");
|
|
else {
|
|
in_impli = 1;
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
in_impli = 0;
|
|
}
|
|
break;
|
|
case EXTERN_STAT:
|
|
addstr("external ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case INTRIN_STAT:
|
|
addstr("intrinsic ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case PARREGION_NODE:
|
|
addstr("parallel ");
|
|
if (pbf->entry.Template.ll_ptr1)
|
|
{
|
|
addstr("( ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(") ");
|
|
}
|
|
break;
|
|
case PARSECTIONS_NODE:
|
|
addstr("parallel sections");
|
|
if (pbf->entry.Template.ll_ptr1)
|
|
{
|
|
addstr("( ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(") ");
|
|
}
|
|
break;
|
|
case PSECTIONS_NODE:
|
|
addstr("psections ");
|
|
if (pbf->entry.Template.ll_ptr1)
|
|
{
|
|
addstr("(");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(") ");
|
|
}
|
|
break;
|
|
case SINGLEPROCESS_NODE:
|
|
addstr("single process");
|
|
if (pbf->entry.Template.ll_ptr1)
|
|
{
|
|
addstr("( ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(") ");
|
|
}
|
|
break;
|
|
case CRITSECTION_NODE:
|
|
addstr("critical section");
|
|
if (pbf->entry.Template.ll_ptr1)
|
|
{
|
|
addstr("( ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(") ");
|
|
}
|
|
if (pbf->entry.Template.ll_ptr2)
|
|
{
|
|
addstr("guards (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(") ");
|
|
}
|
|
break;
|
|
case GUARDS_NODE:
|
|
addstr("guards ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr("(");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(")");
|
|
break;
|
|
case LOCK_NODE:
|
|
addstr("lock (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
if (pbf->entry.Template.ll_ptr2)
|
|
{
|
|
addstr("guards (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(")");
|
|
}
|
|
break;
|
|
case UNLOCK_NODE:
|
|
addstr("unlock (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
if (pbf->entry.Template.ll_ptr2)
|
|
{
|
|
addstr("guards (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(")");
|
|
}
|
|
break;
|
|
case POST_NODE:
|
|
addstr("post (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
if (pbf->entry.Template.ll_ptr2)
|
|
{
|
|
addstr("guards (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(")");
|
|
}
|
|
break;
|
|
case WAIT_NODE:
|
|
addstr("wait (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
if (pbf->entry.Template.ll_ptr2)
|
|
{
|
|
addstr("guards (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(")");
|
|
}
|
|
break;
|
|
case CLEAR_NODE:
|
|
addstr("clear (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
if (pbf->entry.Template.ll_ptr2)
|
|
{
|
|
addstr("guards (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(")");
|
|
}
|
|
break;
|
|
case POSTSEQ_NODE:
|
|
addstr("post (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(", ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(")");
|
|
if (pbf->entry.Template.ll_ptr3)
|
|
{
|
|
addstr("guards (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr3);
|
|
addstr(")");
|
|
}
|
|
break;
|
|
case WAITSEQ_NODE:
|
|
addstr("wait (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(", ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(")");
|
|
if (pbf->entry.Template.ll_ptr3)
|
|
{
|
|
addstr("guards (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr3);
|
|
addstr(")");
|
|
}
|
|
break;
|
|
case SETSEQ_NODE:
|
|
addstr("set (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(", ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(")");
|
|
if (pbf->entry.Template.ll_ptr3)
|
|
{
|
|
addstr("guards (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr3);
|
|
addstr(")");
|
|
}
|
|
break;
|
|
case SECTION_NODE:
|
|
addstr("section");
|
|
if (pbf->entry.Template.ll_ptr1)
|
|
{
|
|
addstr("(");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
}
|
|
if (pbf->entry.Template.ll_ptr2)
|
|
{
|
|
addstr("wait (");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(")");
|
|
}
|
|
break;
|
|
case ASSIGN_NODE:
|
|
addstr("assign ( ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
break;
|
|
case RELEASE_NODE:
|
|
addstr("release ( ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
break;
|
|
case PRIVATE_NODE:
|
|
addstr("private ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case READ_STAT:
|
|
{
|
|
PTR_LLND p;
|
|
PTR_LLND q;
|
|
|
|
addstr("read ");
|
|
p = pbf->entry.Template.ll_ptr2;
|
|
q = p->entry.Template.ll_ptr1;
|
|
|
|
if ((p->variant == EXPR_LIST) ||
|
|
((p->variant == SPEC_PAIR) &&
|
|
(strcmp(q->entry.string_val,"fmt") != 0)))
|
|
{
|
|
addstr("(");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(") ");
|
|
}
|
|
else
|
|
{
|
|
unp_llnd(pbf->entry.Template.ll_ptr2->entry.Template.ll_ptr2);
|
|
if (pbf->entry.Template.ll_ptr1 != LLNULL)
|
|
addstr(",");
|
|
}
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
}
|
|
break;
|
|
case WRITE_STAT:
|
|
addstr("write ");
|
|
addstr("(");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(") ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case PRINT_STAT:
|
|
addstr("print ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2->entry.Template.ll_ptr2);
|
|
if (pbf->entry.Template.ll_ptr1 != LLNULL)
|
|
addstr(",");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case OPEN_STAT:
|
|
addstr("open ");
|
|
addstr("(");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(") ");
|
|
break;
|
|
case CLOSE_STAT:
|
|
addstr("close ");
|
|
addstr("(");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(") ");
|
|
break;
|
|
case INQUIRE_STAT:
|
|
addstr("inquire ");
|
|
addstr("(");
|
|
unp_llnd(pbf->entry.Template.ll_ptr2);
|
|
addstr(") ");
|
|
break;
|
|
case SKIPPASTEOF_NODE:
|
|
{
|
|
PTR_LLND p;
|
|
PTR_LLND q;
|
|
|
|
addstr("skip past eof ");
|
|
p = pbf->entry.Template.ll_ptr2;
|
|
q = p->entry.Template.ll_ptr2;
|
|
|
|
if (p->variant == EXPR_LIST)
|
|
{
|
|
addstr("(");
|
|
unp_llnd(p);
|
|
addstr(") ");
|
|
}
|
|
else unp_llnd(q);
|
|
}
|
|
break;
|
|
case BACKSPACE_STAT:
|
|
{
|
|
PTR_LLND p;
|
|
PTR_LLND q;
|
|
|
|
addstr("backspace ");
|
|
p = pbf->entry.Template.ll_ptr2;
|
|
q = p->entry.Template.ll_ptr2;
|
|
|
|
if (p->variant == EXPR_LIST)
|
|
{
|
|
addstr("(");
|
|
unp_llnd(p);
|
|
addstr(") ");
|
|
}
|
|
else unp_llnd(q);
|
|
}
|
|
break;
|
|
case ENDFILE_STAT:
|
|
{
|
|
PTR_LLND p;
|
|
PTR_LLND q;
|
|
|
|
addstr("endfile ");
|
|
p = pbf->entry.Template.ll_ptr2;
|
|
q = p->entry.Template.ll_ptr2;
|
|
|
|
if (p->variant == EXPR_LIST)
|
|
{
|
|
addstr("(");
|
|
unp_llnd(p);
|
|
addstr(") ");
|
|
}
|
|
else unp_llnd(q);
|
|
}
|
|
break;
|
|
case REWIND_STAT:
|
|
{
|
|
PTR_LLND p;
|
|
PTR_LLND q;
|
|
|
|
addstr("rewind ");
|
|
p = pbf->entry.Template.ll_ptr2;
|
|
q = p->entry.Template.ll_ptr2;
|
|
|
|
if (p->variant == EXPR_LIST)
|
|
{
|
|
addstr("(");
|
|
unp_llnd(p);
|
|
addstr(") ");
|
|
}
|
|
else unp_llnd(q);
|
|
}
|
|
break;
|
|
case OTHERIO_STAT:
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case COMM_STAT:
|
|
addstr("common ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case NAMELIST_STAT:
|
|
addstr("namelist ");
|
|
unp_llnd(pbf->entry.Template.ll_ptr1);
|
|
break;
|
|
case CONTROL_END:
|
|
break;
|
|
default:
|
|
break; /* don't know what to do at this point */
|
|
}
|
|
|
|
if (pbf->variant != CONTROL_END) {
|
|
if (print_comments && cmnt && cmnt->type != FULL)
|
|
addstr(cmnt->string);
|
|
if (pbf->variant != LOGIF_NODE)
|
|
*bp++ = '\n';
|
|
}
|
|
}
|
|
|
|
/****************************************************************
|
|
* *
|
|
* funp_blck -- unparse the given bif node to source string *
|
|
* along with its control children (block) *
|
|
* *
|
|
* Input: *
|
|
* bif - bif node to be unparsed *
|
|
* tab - number of tabs (2 spaces) for indenting *
|
|
* bp (implicitely) - where the output string to be *
|
|
* placed *
|
|
* *
|
|
* Output: *
|
|
* the unparse string where "bp" was pointed to *
|
|
* *
|
|
* Side Effect: *
|
|
* "bp" will be updated to the next character behind *
|
|
* the end of the unparsed string (by "addstr") *
|
|
* *
|
|
****************************************************************/
|
|
static void
|
|
funp_blck(bif, tab)
|
|
PTR_BFND bif;
|
|
int tab;
|
|
{
|
|
PTR_BLOB b;
|
|
|
|
if (print_comments && (cmnt = bif->entry.Template.cmnt_ptr) != NULL)
|
|
while (cmnt != NULL && cmnt->type == FULL) {
|
|
addstr(cmnt->string);
|
|
*bp++ = '\n';
|
|
cmnt = cmnt->next;
|
|
}
|
|
|
|
funp_bfnd(tab, bif);
|
|
|
|
if (bif->variant != CDOALL_NODE && bif->variant != SDOALL_NODE) {
|
|
for (b = bif->entry.Template.bl_ptr1; b; b = b->next)
|
|
if (b->ref->variant != CONTROL_END)
|
|
funp_blck(b->ref, tab+1);
|
|
else {
|
|
PTR_CMNT cmnt = b->ref->entry.Template.cmnt_ptr;
|
|
|
|
if (print_comments && cmnt)
|
|
while (cmnt != NULL && cmnt->type == FULL) {
|
|
addstr(cmnt->string);
|
|
*bp++ = '\n';
|
|
cmnt = cmnt->next;
|
|
}
|
|
switch(bif->variant) {
|
|
case FOR_NODE:
|
|
case PARDO_NODE:
|
|
case PDO_NODE:
|
|
case WHILE_NODE:
|
|
if (!bif->entry.Template.lbl_ptr) {
|
|
put_tabs(tab-1);
|
|
if (bif->variant == PARDO_NODE)
|
|
addstr(" end parallel do");
|
|
else if (bif->variant == PDO_NODE)
|
|
addstr(" end pdo");
|
|
else addstr(" end do");
|
|
}
|
|
break;
|
|
case IF_NODE:
|
|
case ELSEIF_NODE:
|
|
put_tabs(tab-1);
|
|
if (bif->entry.Template.bl_ptr2)
|
|
addstr(" else");
|
|
else
|
|
addstr(" end if");
|
|
break;
|
|
case WHERE_BLOCK_STMT:
|
|
put_tabs(tab);
|
|
if (bif->entry.Template.bl_ptr2)
|
|
addstr(" elsewhere");
|
|
else
|
|
addstr(" end where");
|
|
break;
|
|
case CASE_NODE:
|
|
put_tabs(tab-1);
|
|
addstr(" end select ");
|
|
if (bif->entry.Template.symbol)
|
|
addstr(bif->entry.Template.symbol->ident);
|
|
break;
|
|
case SWITCH_NODE:
|
|
put_tabs(tab-1);
|
|
break;
|
|
case PROG_HEDR:
|
|
case PROC_HEDR:
|
|
case FUNC_HEDR:
|
|
case BLOCK_DATA:
|
|
addstr(" end");
|
|
break;
|
|
case MODULE_STMT:
|
|
addstr(" end module ");
|
|
addstr(bif->entry.Template.symbol->ident);
|
|
break;
|
|
case INTERFACE_STMT:
|
|
put_tabs(tab-1);
|
|
addstr(" end interface");
|
|
break;
|
|
case STRUCT_DECL:
|
|
put_tabs(tab-1);
|
|
addstr(" end type ");
|
|
addstr(bif->entry.Template.symbol->ident);
|
|
break;
|
|
case PARREGION_NODE:
|
|
put_tabs(tab-1);
|
|
addstr(" end parallel");
|
|
break;
|
|
case PARSECTIONS_NODE:
|
|
put_tabs(tab-1);
|
|
addstr(" end parallel sections");
|
|
break;
|
|
case PSECTIONS_NODE:
|
|
put_tabs(tab-1);
|
|
addstr(" end psections");
|
|
break;
|
|
case SINGLEPROCESS_NODE:
|
|
put_tabs(tab-1);
|
|
addstr(" end single process");
|
|
break;
|
|
case CRITSECTION_NODE:
|
|
put_tabs(tab-1);
|
|
addstr(" end critical section");
|
|
if (bif->entry.Template.ll_ptr1)
|
|
{
|
|
addstr("(");
|
|
unp_llnd(bif->entry.Template.ll_ptr1);
|
|
addstr(")");
|
|
}
|
|
break;
|
|
/* case SECTION_NODE: */
|
|
default:
|
|
break;
|
|
}
|
|
if (print_comments && cmnt && cmnt->type != FULL)
|
|
addstr(cmnt->string);
|
|
*bp++ = '\n';
|
|
}
|
|
|
|
for (b = bif->entry.Template.bl_ptr2; b; b = b->next)
|
|
if (b->ref->variant != CONTROL_END)
|
|
funp_blck(b->ref, tab+1);
|
|
else {
|
|
PTR_CMNT cmnt = b->ref->entry.Template.cmnt_ptr;
|
|
|
|
if (print_comments && cmnt)
|
|
while (cmnt != NULL && cmnt->type == FULL) {
|
|
addstr(cmnt->string);
|
|
*bp++ = '\n';
|
|
cmnt = cmnt->next;
|
|
}
|
|
put_tabs(tab);
|
|
if (bif->variant == PDO_NODE)
|
|
addstr(" end extended");
|
|
if (bif->variant == PSECTIONS_NODE)
|
|
addstr(" end extended");
|
|
if (bif->variant == WHERE_BLOCK_STMT)
|
|
addstr(" end where");
|
|
if ((bif->variant == IF_NODE) || (bif->variant == ELSEIF_NODE))
|
|
addstr(" end if");
|
|
if (print_comments && cmnt && cmnt->type != FULL)
|
|
addstr(cmnt->string);
|
|
*bp++ = '\n';
|
|
}
|
|
} else {
|
|
for (b = bif->entry.Template.bl_ptr2; b; b = b->next)
|
|
if (b->ref->variant != CONTROL_END)
|
|
funp_blck(b->ref, tab+1);
|
|
else {
|
|
PTR_CMNT cmnt = b->ref->entry.Template.cmnt_ptr;
|
|
|
|
if (print_comments && cmnt)
|
|
while (cmnt != NULL && cmnt->type == FULL) {
|
|
addstr(cmnt->string);
|
|
*bp++ = '\n';
|
|
cmnt = cmnt->next;
|
|
}
|
|
if (!bif->entry.Template.lbl_ptr) {
|
|
put_tabs(tab-1);
|
|
addstr(" loop");
|
|
}
|
|
if (print_comments && cmnt && cmnt->type != FULL)
|
|
addstr(cmnt->string);
|
|
*bp++ = '\n';
|
|
}
|
|
|
|
for (b = bif->entry.Template.bl_ptr1; b; b = b->next)
|
|
if (b->ref->variant != CONTROL_END)
|
|
funp_blck(b->ref, tab+1);
|
|
else {
|
|
PTR_CMNT cmnt = b->ref->entry.Template.cmnt_ptr;
|
|
|
|
if (print_comments && cmnt)
|
|
while (cmnt != NULL && cmnt->type == FULL) {
|
|
addstr(cmnt->string);
|
|
*bp++ = '\n';
|
|
cmnt = cmnt->next;
|
|
}
|
|
put_tabs(tab);
|
|
if (bif->variant == CDOALL_NODE)
|
|
addstr(" end cdoall");
|
|
else
|
|
addstr(" end sdoall");
|
|
if (print_comments && cmnt && cmnt->type != FULL)
|
|
addstr(cmnt->string);
|
|
*bp++ = '\n';
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
/****************************************************************
|
|
* *
|
|
* funparse_type -- unparse the type node for Fortran *
|
|
* *
|
|
* input: *
|
|
* type -- the node to be unparsed *
|
|
* *
|
|
* output: *
|
|
* the unparsed string *
|
|
* *
|
|
****************************************************************/
|
|
char *
|
|
funparse_type(type)
|
|
PTR_TYPE type;
|
|
{
|
|
char *b1;
|
|
|
|
if (type == NULL)
|
|
return NULL;
|
|
|
|
bp = buffer;
|
|
switch (type->variant) {
|
|
case T_INT :
|
|
case T_FLOAT :
|
|
case T_DOUBLE:
|
|
case T_CHAR :
|
|
case T_BOOL :
|
|
case T_STRING:
|
|
addstr(ftype_name[type_index(type->variant)]);
|
|
if ((type->entry.Template.ranges) != LLNULL)
|
|
unp_llnd(type->entry.Template.ranges);
|
|
break;
|
|
case T_ARRAY:
|
|
addstr(ftype_name[type_index(type->entry.ar_decl.base_type->variant)]);
|
|
*bp++ = ' ';
|
|
unp_llnd(type->entry.ar_decl.ranges);
|
|
break;
|
|
default:
|
|
return NULL;
|
|
}
|
|
*bp++ = '\n';
|
|
*bp++ = '\0';
|
|
b1 = malloc(strlen(buffer) + 1);
|
|
#ifdef __SPF
|
|
addToCollection(__LINE__, __FILE__,b1, 0);
|
|
#endif
|
|
(void) strcpy(b1, buffer);
|
|
bp = buffer;
|
|
*bp = '\0';
|
|
return b1;
|
|
}
|
|
|
|
|
|
/****************************************************************
|
|
* *
|
|
* funparse_symb -- unparse the symbol node for Fortran *
|
|
* *
|
|
* input: *
|
|
* symb -- the node to be unparsed *
|
|
* *
|
|
* output: *
|
|
* the unparsed string *
|
|
* *
|
|
****************************************************************/
|
|
char *
|
|
funparse_symb(symb)
|
|
PTR_SYMB symb;
|
|
{
|
|
int i;
|
|
char buf[100], *b1, *b2;
|
|
PTR_TYPE t;
|
|
|
|
b1 = buf;
|
|
for (i = 1; i<10; i++)
|
|
*b1++ = ' ';
|
|
t = symb->type;
|
|
i = t->variant < T_ARRAY? t->variant: t->entry.ar_decl.base_type->variant;
|
|
b2 = ftype_name[type_index(i)];
|
|
while ( (*b1 = *b2++) != 0)
|
|
b1++;
|
|
*b1++ = ' ';
|
|
if (t->variant < T_ARRAY) {
|
|
b2 = symb->ident;
|
|
while ( (*b1 = *b2++) != 0)
|
|
b1++;
|
|
} else {
|
|
bp = buffer;
|
|
unp_llnd(t->entry.ar_decl.ranges);
|
|
b2 = buffer;
|
|
while ( (*b1 = *b2++) != 0)
|
|
b1++;
|
|
}
|
|
*b1++ = '\n';
|
|
*b1++ = '\0';
|
|
b2 = malloc(strlen(buf) + 1);
|
|
#ifdef __SPF
|
|
addToCollection(__LINE__, __FILE__,b2, 0);
|
|
#endif
|
|
(void) strcpy(b2, buf);
|
|
*buffer = '\0';
|
|
return b2;
|
|
}
|
|
|
|
|
|
/****************************************************************
|
|
* *
|
|
* funparse_llnd -- unparse the low level node for Fortran *
|
|
* *
|
|
* input: *
|
|
* llnd -- the node to be unparsed *
|
|
* *
|
|
* output: *
|
|
* the unparsed string *
|
|
* *
|
|
****************************************************************/
|
|
char *
|
|
funparse_llnd(llnd)
|
|
PTR_LLND llnd;
|
|
{
|
|
int len;
|
|
char *p;
|
|
|
|
bp = buffer; /* reset the buffer pointer */
|
|
unp_llnd(llnd);
|
|
*bp++ = '\n';
|
|
*bp++ = '\0';
|
|
len = (bp - buffer) + 1; /* calculate the string length */
|
|
p = malloc(len); /* allocate space for returned value */
|
|
#ifdef __SPF
|
|
addToCollection(__LINE__, __FILE__,p, 0);
|
|
#endif
|
|
strcpy(p, buffer); /* copy the buffer for output */
|
|
*buffer = '\0';
|
|
return p;
|
|
}
|
|
|
|
|
|
/****************************************************************
|
|
* *
|
|
* funparse_bfnd -- unparse the bif node for Fortran *
|
|
* *
|
|
* input: *
|
|
* bif -- the node to be unparsed *
|
|
* *
|
|
* output: *
|
|
* the unparsed string *
|
|
* *
|
|
****************************************************************/
|
|
char *
|
|
funparse_bfnd(bif)
|
|
PTR_BFND bif;
|
|
{
|
|
int len;
|
|
char *p;
|
|
|
|
first = 1; /* Mark this is the first bif node */
|
|
bp = buffer; /* reset the buffer pointer */
|
|
funp_bfnd(0, bif);
|
|
*bp++ = '\0';
|
|
len = (bp - buffer) + 1; /* calculate the string length */
|
|
p = malloc(len); /* allocate space for returned value */
|
|
#ifdef __SPF
|
|
addToCollection(__LINE__, __FILE__,p, 0);
|
|
#endif
|
|
strcpy(p, buffer); /* copy the buffer for output */
|
|
*buffer = '\0';
|
|
return (p);
|
|
}
|
|
|
|
|
|
/****************************************************************
|
|
* *
|
|
* funparse_bfnd_w_tab -- unparse the bif node for Fortran *
|
|
* *
|
|
* input: *
|
|
* bif -- the node to be unparsed *
|
|
* *
|
|
* output: *
|
|
* the unparsed string *
|
|
* *
|
|
****************************************************************/
|
|
char *
|
|
funparse_bfnd_w_tab(tab, bif)
|
|
int tab;
|
|
PTR_BFND bif;
|
|
{
|
|
int len;
|
|
char *p;
|
|
|
|
first = 1; /* Mark this is the first bif node */
|
|
bp = buffer; /* reset the buffer pointer */
|
|
funp_bfnd(tab, bif);
|
|
*bp++ = '\0';
|
|
len = (bp - buffer) + 1; /* calculate the string length */
|
|
p = malloc(len); /* allocate space for returned value */
|
|
#ifdef __SPF
|
|
addToCollection(__LINE__, __FILE__,p, 0);
|
|
#endif
|
|
strcpy(p, buffer); /* copy the buffer for output */
|
|
*buffer = '\0';
|
|
return (p);
|
|
}
|
|
|
|
|
|
char *
|
|
funparse_blck(bif)
|
|
PTR_BFND bif;
|
|
{
|
|
int len;
|
|
char *p;
|
|
|
|
bp = buffer; /* reset the buffer pointer */
|
|
funp_blck(bif, figure_tabs(bif));
|
|
|
|
*bp++ = '\0';
|
|
len = (bp - buffer) + 1; /* calculate the string length */
|
|
p = malloc(len); /* allocate space for returned value */
|
|
#ifdef __SPF
|
|
addToCollection(__LINE__, __FILE__,p, 0);
|
|
#endif
|
|
strcpy(p, buffer); /* copy the buffer for output */
|
|
*buffer = '\0';
|
|
return (p);
|
|
}
|