Exemple #1
0
static void show_uop(g95_user_op *uop) {
g95_interface *intr;

    g95_status("user_op('%s', [", uop->name);

    for(intr=uop->operator; intr; intr=intr->next)
	g95_status(" '%s',", intr->sym->name);

    g95_status("])\n");
}
Exemple #2
0
static void code_indent(int level, g95_st_label *label) {
int i;

    if (label != NULL)
	g95_status("%-6d; ", label->value);
    else
	g95_status("        ");

    for(i=0; i<2*level; i++)
	g95_status_char(' ');
}
Exemple #3
0
static void show_constant(g95_expr *p) {

    switch(p->ts.type) {
    case BT_INTEGER:
	g95_status_char('\'');
	fputs(bi_to_string(p->value.integer), stdout);

	if (p->ts.kind != g95_default_integer_kind(0))
	    g95_status("_%d", p->ts.kind);

	g95_status_char('\'');
	break;

    case BT_LOGICAL:
	g95_status(p->value.logical ? "'.true.'" : "'.false.'");
	break;

    case BT_REAL:
	g95_status_char('\'');
	fputs(bg_to_string(p->value.real), stdout);

	if (p->ts.kind != g95_default_real_kind(1))
	    g95_status("_%d", p->ts.kind);

	g95_status_char('\'');
	break;

    case BT_CHARACTER:
	show_string_constant(p->value.character.string,
			     p->value.character.length);
	break;

    case BT_COMPLEX:
	g95_status_char('\'');

	fputs(bg_to_string(p->value.complex.r), stdout);
	if (p->ts.kind != g95_default_complex_kind())
	    g95_status("_%d", p->ts.kind);

	g95_status_char(' ');

	fputs(bg_to_string(p->value.complex.i), stdout);
	if (p->ts.kind != g95_default_complex_kind())
	    g95_status("_%d", p->ts.kind);

	g95_status_char('\'');
	break;

    default:
	g95_internal_error("show_constant(): Bad type");
	break;
    }
}
Exemple #4
0
static void show_array_spec(g95_array_spec *as) {
int i;

    g95_status("as('%s', %d",
	       g95_code2string(array_specs, as->type), as->rank);

    for(i=0; i<as->rank; i++) {
	g95_status(", lower%d=", i);
	g95_show_expr(as->lower[i]);

	g95_status(", upper%d=", i);
	g95_show_expr(as->upper[i]);
    }

    g95_status(")");
}
Exemple #5
0
static void show_constructor(g95_constructor *c) {

    for(;c ;c=c->next) {
	if (c->iterator == NULL)
	    g95_show_expr(c->expr);
	else {
	    g95_status_char('(');
	    g95_show_expr(c->expr);

	    g95_status_char(' ');
	    g95_show_expr(c->iterator->var);
	    g95_status_char('=');
	    g95_show_expr(c->iterator->start);
	    g95_status_char(',');
	    g95_show_expr(c->iterator->end);
	    g95_status_char(',');
	    g95_show_expr(c->iterator->step);

	    g95_status_char(')');
	}

	if (c->next != NULL)
	    g95_status(", ");
    }
}
Exemple #6
0
static void show_symtree(g95_symtree *st) {

    show_indent();
    g95_status("symtree('%s', symbol=%s", st->name,
	       g95_symbol_name(st->n.sym));

    if (st->ambiguous)
	g95_status(", ambiguous=1");

    g95_status(")");

    if (st->n.sym->ns != g95_current_ns)
	g95_status("  # from namespace %s\n", st->n.sym->ns->proc_name->name);

    else {
	g95_status_char('\n');
	show_symbol(st->n.sym);
    }
}
Exemple #7
0
static void show_array_ref(g95_array_ref *ar) {
int i;

    switch(ar->type) {
    case AR_FULL:
	g95_status("full()");
	break;

    case AR_SECTION: 
	g95_status("section(");
	for(i=0; i<ar->dimen; i++) {
	    g95_status_char('(');
	    g95_show_expr(ar->start[i]);

	    if (ar->end[i] != NULL) {
		g95_status(", ");
		g95_show_expr(ar->end[i]);
	    }

	    if (ar->stride[i] != NULL) {
		g95_status(", ");
		g95_show_expr(ar->stride[i]);
	    }

	    g95_status_char(')');

	    if (i != ar->dimen-1)
		g95_status(", ");
	}

	g95_status_char(')');
	break;

    case AR_ELEMENT:
	g95_status("element(");

	for(i=0; i<ar->dimen; i++) {
	    g95_show_expr(ar->start[i]);
	    if (i != ar->dimen - 1)
		g95_status(", ");
	}

	g95_status_char(')');
	break;

    case AR_UNKNOWN:
	g95_status("UNKNOWN");
	break;

    default:
	g95_internal_error("g95_show_array_ref(): Unknown array reference");
    }
}
Exemple #8
0
void g95_show_typespec(g95_typespec *typ) {     
     
  g95_status("(%s ", g95_basic_typename(typ->type));     
     
  switch(typ->type) {          
  case BT_DERIVED:   
    g95_status("%s", typ->derived->name); 
    break;    
    
  case BT_CHARACTER:         
    g95_show_expr(typ->cl->length);       
    break;   
   
  default:         
    g95_status("%d", typ->kind);      
    break;
  }        
        
  g95_status(")");          
} 
Exemple #9
0
static void show_refs(g95_ref *ref) {

    g95_status_char('[');

    for(; ref; ref=ref->next) {
	show_ref(ref);

	if (ref->next != NULL)
	    g95_status(", ");
    }

    g95_status_char(']');
}
Exemple #10
0
static void show_ref(g95_ref *p) {
int i;

    switch(p->type) {
    case REF_ARRAY:
	show_array_ref(&p->u.ar);
	break;

    case REF_COMPONENT:
	g95_status("comp('%s')", p->u.c.component->name);
	break;

    case REF_SUBSTRING:
	g95_status("substr(start=");
	g95_show_expr(p->u.ss.start);

	g95_status(", end=");
	g95_show_expr(p->u.ss.end);

	g95_status_char(')');
	break;

    case REF_COARRAY:
	g95_status("coarray(");

	for(i=0; i<p->u.car.dimen; i++) {
	    g95_show_expr(p->u.car.element[i]);

	    if (i != p->u.car.dimen - 1)
		g95_status_char(',');
	}

	g95_status_char(')');
	break;

    default:
	g95_internal_error("show_ref(): Bad component code");
    }
}
Exemple #11
0
static void show_actual_arglist(g95_actual_arglist *a) {

    g95_status_char('[');

    for(; a; a=a->next) {
	g95_status("arg(");  

	if (a->type == ARG_ALT_RETURN)
	    g95_status(", alt=%d", a->u.label->value);

	else if (a->u.expr == NULL)
	    g95_status("None");

	else {
	    g95_show_expr(a->u.expr);

	    if (a->pointer)
		g95_status("pointer=1");

	    if (a->name != NULL)
		g95_status("name='%s'", a->name);

	    switch(a->type) {
	    case ARG_ARRAY:          g95_status(", array=1");   break;
	    case ARG_ARRAY_ELEMENT:  g95_status(", element=1"); break;
	    case ARG_ARRAY_DESC:     g95_status(", desc=1 ");   break;
	    default:                                            break;
	    }
	}

	g95_status_char(')');

	if (a->next != NULL)
	    g95_status(", ");
    }

    g95_status_char(']');
}
Exemple #12
0
int main(int argc, char *argv[]) {         
int errors, warnings, v; 
 
  if (argc == 1) g95_display_help();        
        
#ifdef __GLIBC__
  mtrace();
#endif
       
  g95_init_options();       
       
  argv++;

  while(argc > 1) {  
    v = g95_parse_arg(argc, argv);        
    if (v < 0) v = -v;      
      
    argc -= v;       
    argv += v;       
  }      
      
  g95_init_1();     
     
  if (g95_option.source == NULL) g95_fatal_error("Need a file to compile");       
       
  if (g95_new_file(g95_option.source, g95_option.form) != SUCCESS) return 3;

  g95_parse_file();          
          
  g95_done_1();   
  release_options();        
        
  g95_get_errors(&warnings, &errors);     
     
  if (!g95_option.quiet)    
    g95_status("Warnings: %d  Errors: %d\n", warnings, errors);   
   
  if (errors > 0) return 2;    
  if (warnings > 0) return 1;
  return 0; 
}  
Exemple #13
0
static void show_component(g95_component *c) {

    g95_status("comp(%s, ts=", c->name);
    show_typespec(&c->ts);

    if (c->pointer)
	g95_status(", pointer=1");

    if (c->dimension)
	g95_status(", dimension=1");

    if (c->allocatable)
	g95_status(", allocatable=1");

    if (c->as != NULL) {
	g95_status(", as=");
	show_array_spec(c->as);
    }

    g95_status(")");
}
Exemple #14
0
static void show_typespec(g95_typespec *ts) {

    switch(ts->type) {
    case BT_INTEGER:    g95_status("ts('INTEGER', kind=%d)", ts->kind); break;
    case BT_REAL:       g95_status("ts('REAL', kind=%d)",    ts->kind); break;
    case BT_COMPLEX:    g95_status("ts('COMPLEX', kind=%d",  ts->kind); break;
    case BT_LOGICAL:    g95_status("ts('LOGICAL', kind=%d",  ts->kind); break;
    case BT_PROCEDURE:  g95_status("ts('PROCEDURE')");  break;
    case BT_UNKNOWN:    g95_status("ts('UNKNOWN')");    break;
    case BT_DERIVED:    g95_status("ts('DERIVED', derived=%s",
				   g95_symbol_name(ts->derived)); break;

    case BT_CHARACTER:  g95_status("ts('CHARACTER', kind=%d, len=", ts->kind);
	if (ts->cl == &g95_unknown_charlen)
	    g95_status("None");
	else if (ts->cl == NULL)
	    g95_status("'*'");
	else
	    g95_show_expr(ts->cl->length);

	g95_status(")");
	break;

    default:
	g95_internal_error("show_typespec(): Undefined type");
    }
}
Exemple #15
0
int g95_parse_arg(int argc, char *argv[]) {
const char *option;
int i;

    option = argv[0];

    if (strcmp(option, "-v") == 0) {
	g95_option.verbose = 1;
	return 1;
    }

    if (strcmp(option, "-Wline-truncation") == 0) {
	g95_option.line_truncation = 1;
	return 1;
    }

    if (strcmp(option, "-Wunused-label") == 0) {
	g95_option.unused_label = 1;
	return -1;
    }

    if (strncmp(option, "-Wno=", 5) == 0) {
	set_nowarn(option+5);
	return 1;
    }

    if (strcmp(option, "-fimplicit-none") == 0 ||
	strcmp(option, "-Wimplicit") == 0) {
	g95_option.implicit_none = 1;
	return -1;
    }

    if (strcmp(option, "-ffixed-line-length-80") == 0) {
	g95_option.fixed_line_length = 80;
	return -1;
    }

    if (strcmp(option, "-ffixed-line-length-132") == 0) {
	g95_option.fixed_line_length = 132;
	return -1;
    }

    if (strcmp(option, "-ffree-form") == 0) {
	g95_option.form = FORM_FREE;
	return -1;
    }

    if (strcmp(option, "-ffixed-form") == 0) {
	g95_option.form = FORM_FIXED;
	return -1;
    }

    if (strcmp(option, "-fmodule-private") == 0) {
	g95_option.module_access_private = 1;
	return -1;
    }

    if (strcmp(option, "-fdollar-ok") == 0) {
	g95_option.dollar = 1;
	return 1;
    }

    if (strcmp(option, "-fno-backslash") == 0) {
	g95_option.no_backslash = 1;
	return 1;
    }

    if (strcmp(option, "-fno-underscoring") == 0) {
	g95_option.no_underscoring = 1;
	return 1;
    }

    if (strcmp(option, "-fno-second-underscore") == 0) {
	g95_option.no_second_underscore = 1;
	return 1;
    }

    if (strncmp(option, "-fqkind=", 8) == 0) {
	i = atoi(option+8);
	if (g95_validate_kind(BT_REAL, i) < 0)
	    g95_fatal_error("Argument to -fqkind isn't a valid real kind");

	g95_option.q_kind = i;
	return -1;
    }

    if (strcmp(option, "-fquiet") == 0 || strcmp(option, "-quiet") == 0) {
	g95_option.quiet = 1;
	return 1;
    }

    if (strcmp(option, "-i8") == 0) {
	g95_option.default_integer = 8;
	return -1;
    }

    if (strcmp(option, "-r8") == 0) {
	g95_option.r_value = 8;
	return -1;
    }

    if (strcmp(option, "-d8") == 0) {
	g95_option.r_value = 8;
	g95_option.default_integer = 8;
	return -1;
    }

    if (strcmp(option, "-l1") == 0) {
	g95_option.l1 = 1;
	return -1;
    }

    if (option[0] == '-' && option[1] == 'I') {
	if (option[2] != '\0') {
	    add_path(&option[2]);
	    return 1;
	}

	if (argc <= 2 || argv[1][0] == '-') {
	    g95_status("g95: Directory required after -I\n");
	    exit(3);
	}

	add_path(argv[1]);
	return 2;
    }

    if (strncmp(option, "-fmod=", 6) == 0) {
	module_path(option);
	add_path(option + 6);
	return 1;
    }

    if (option[0] == '-') {
	g95_status("g95: Unrecognized option '%s'\n", option);
	exit(3);
    }

    if (g95_source_file != NULL) {
	g95_status("g95: Second source file '%s' found\n", option);
	exit(3);
    }

    g95_source_file = (char *) option;
    return 1;
}
Exemple #16
0
static void show_code0(int level, g95_code *c) {
g95_forall_iterator *fa;
char *module, *name;
g95_close *close;
g95_filepos *fp;
g95_inquire *i;
g95_open *open;
int m, comma;
g95_case *cp;
g95_alloc *a;
g95_code *d;
g95_dt *dt;

    code_indent(level, c->here); 

    switch(c->type) {
    case EXEC_NOP:
	g95_status("nop(");
	comma = 0;
	break;

    case EXEC_CONTINUE:
	g95_status("cont(");
	comma = 0;
	break;

    case EXEC_AC_START:
	g95_status("ac_start(sym='%s'", c->sym->name);
	comma = 1;
	break;

    case EXEC_AC_ASSIGN:
	g95_status("ac_assign(sym='%s', expr=", c->sym->name);
	g95_show_expr(c->expr);
	break;

    case EXEC_ASSIGN:
	g95_status("assign(lhs=");
	g95_show_expr(c->expr);
	g95_status(", rhs=");
	g95_show_expr(c->expr2);
	comma = 1;
	break;

    case EXEC_WHERE_ASSIGN:
	g95_status("where_assign(lhs=");
	g95_show_expr(c->expr);
	g95_status(", rhs=");
	g95_show_expr(c->expr2);
	comma = 1;
	break;

    case EXEC_POINTER_ASSIGN:
	g95_status("ptr_assign(lhs=");
	g95_show_expr(c->expr);
	g95_status(", rhs=");
	g95_show_expr(c->expr2);
	comma = 1;
	break;

    case EXEC_GOTO:
	if (c->label != NULL)
	    g95_status("goto(label=%d", c->label->value);
	else
	    g95_status("goto(var='%s'", c->sym->name);

	comma = 1;
	break;

    case EXEC_CALL:
	if (c->sym == NULL)
	    module = name = "";
	else {
	    module = c->sym->module;
	    name   = c->sym->name;
	}

	g95_status("call(name='%s:%s', sub='%s', arg=",
		   module, name, c->ext.sub.sub_name);
	show_actual_arglist(c->ext.sub.actual);
	comma = 1;
	break;

    case EXEC_RETURN:
	g95_status("ret(");
	comma = 0;

	if (c->expr) {
	    g95_status("value=");
	    g95_show_expr(c->expr);
	    comma = 1;
	}

	break;

    case EXEC_STOP:
	g95_status("stop(");

	if (c->expr != NULL) {
	    g95_status("expr=");
	    g95_show_expr(c->expr);
	} else
	    g95_status("code=%d", c->ext.stop_code);

	comma = 1;
	break;

  case EXEC_PAUSE:
      g95_status("pause(");

      if (c->expr != NULL) {
	  g95_status("expr=");
	  g95_show_expr(c->expr);
      } else
	  g95_status("code=%d", c->ext.stop_code);

      comma = 1;
      break;

    case EXEC_ARITHMETIC_IF:
	g95_status("arith_if(expr=");

	g95_show_expr(c->expr);

	g95_status(", lt0=%d, eq0=%d, gt0=%d",
		   c->label->value, c->label2->value, c->label3->value);

	comma = 1;
	break;

    case EXEC_IF:
	g95_status("log_if(expr=");
	g95_show_expr(c->expr);

	g95_status(", true=\n");
	show_code(level+1, c->block);

	if (c->ext.block != NULL) {
	    code_indent(level, 0);
	    g95_status(", else=\n");
	    show_code(level+1, c->ext.block);
	}

	code_indent(level, c->label);
	g95_status(") # ENDIF\n");
	break;

    case EXEC_SELECT:
	d = c->block;
	g95_status("select(expr=");
	g95_show_expr((c->expr != NULL) ? c->expr : c->expr2);
	g95_status(", cases=[\n");

	for(;d ;d=d->block) {
	    code_indent(level, 0);

	    g95_status("case(");
	    for(cp=d->ext.case_list; cp; cp=cp->next) {
		g95_status_char('(');
		g95_show_expr(cp->low);
		g95_status_char(' ');
		g95_show_expr(cp->high);
		g95_status_char(')');
		g95_status_char(' ');
	    }

	    g95_status_char('\n');

	    show_code(level+1, d->next);
	}

	code_indent(level, c->label);
	g95_status("END SELECT");
	break;

    case EXEC_WHERE:
	g95_status("WHERE ");

	d = c->block;
	g95_show_expr(d->expr);
	g95_status_char('\n');

	show_code(level+1, d->next);

	for(d=d->block; d; d=d->block) {
	    code_indent(level, 0);
	    g95_status("ELSE WHERE ");
	    g95_show_expr(d->expr);
	    g95_status_char('\n');
	    show_code(level+1, d->next);
	}

	code_indent(level, 0);
	g95_status("END WHERE");
	break;

    case EXEC_FORALL:
	g95_status("FORALL ");
	for(fa=c->ext.forall_iterator; fa; fa=fa->next) {
	    g95_show_expr(fa->var);
	    g95_status_char(' ');
	    g95_show_expr(fa->start);
	    g95_status_char(':');
	    g95_show_expr(fa->end);
	    g95_status_char(':');
	    g95_show_expr(fa->stride);

	    if (fa->next != NULL)
		g95_status_char(',');
	}

	if (c->expr != NULL) {
	    g95_status_char(',');
	    g95_show_expr(c->expr);
	}

	g95_status_char('\n');

	show_code(level+1, c->block);

	code_indent(level, 0);
	g95_status("END FORALL");
	break;
    
    case EXEC_DO:
	g95_status("do(var=");
	g95_show_expr(c->ext.iterator->var);

	g95_status(", start=");
	g95_show_expr(c->ext.iterator->start);

	g95_status(", end=");
	g95_show_expr(c->ext.iterator->end);

	g95_status(", step=");
	g95_show_expr(c->ext.iterator->step);

	g95_status(", body=\n");
	show_code(level+1, c->block);

	code_indent(level, 0);
	comma = 1;
	break;

    case EXEC_DO_WHILE:
	g95_status("do_while(expr=");
	g95_show_expr(c->expr);
	g95_status(", body=");

	show_code(level+1, c->block);

	code_indent(level, c->label);
	break;

    case EXEC_CYCLE:
	g95_status("cycle(");
	comma = 0;

	if (c->sym) {
	    g95_status("label='%s'", c->sym->name);
	    comma = 1;
	}

	break;

    case EXEC_EXIT:
	g95_status("exit(");
	comma = 0;

	if (c->sym) {
	    g95_status("label='%s'", c->sym->name);
	    comma = 1;
	}

	break;

    case EXEC_ALLOCATE:
	g95_status("allocate(");
	comma = 0;

	if (c->expr) {
	    g95_status("stat=");
	    g95_show_expr(c->expr);
	    comma = 1;
	}

	if (comma)
	    g95_status(", ");

	g95_status("alloc=[");

	for(a=c->ext.alloc_list; a; a=a->next) {
	    g95_show_expr(a->expr);
	    g95_status_char('(');

	    for(m=0; m < a->rank+a->corank; m++) {
		g95_show_expr(a->lower[m]);
		g95_status_char(':');
		g95_show_expr(a->upper[m]);

		if (m != a->rank + a->corank - 1)
		    g95_status_char(',');
	    }

	    g95_status_char(')');

	    if (a->next != NULL)
		g95_status(", ");
	}

	g95_status_char(']');
	comma = 1;
	break;

    case EXEC_DEALLOCATE:
	g95_status("deallocate(");
	comma = 0;

	if (c->expr) {
	    g95_status("stat=");
	    g95_show_expr(c->expr);
	    comma = 1;
	}

	if (comma)
	    g95_status(", ");

	g95_status("alloc=[");

	for(a=c->ext.alloc_list; a; a=a->next) {
	    g95_show_expr(a->expr);
	    if (a->next != NULL)
		g95_status(", ");
	}

	g95_status_char(']');
	comma = 1;
	break;

    case EXEC_OPEN:
	g95_status("open_(");
	open = c->ext.open;
	comma = 0;

	if (open->unit) {
	    if (comma)
		g95_status(", ");

	    g95_status("unit=");
	    g95_show_expr(open->unit);
	    comma = 1;
	}

	if (open->iostat) {
	    if (comma)
		g95_status(", ");

	    g95_status("iostat=");
	    g95_show_expr(open->iostat);
	    comma = 1;
	}

	if (open->file) {
	    if (comma)
		g95_status(", ");

	    g95_status("file=");
	    g95_show_expr(open->file);
	    comma = 1;
	}

	if (open->status) {
	    if (comma)
		g95_status(", ");

	    g95_status("status=");
	    g95_show_expr(open->status);
	    comma = 1;
	}

	if (open->access) {
	    if (comma)
		g95_status(", ");

	    g95_status("access=");
	    g95_show_expr(open->access);
	    comma = 1;
	}

	if (open->form) {
	    if (comma)
		g95_status(", ");

	    g95_status("form=");
	    g95_show_expr(open->form);
	    comma = 1;
	}

	if (open->recl) {
	    if (comma)
		g95_status(", ");

	    g95_status("recl=");
	    g95_show_expr(open->recl);
	    comma = 1;
	}

	if (open->blank) {
	    if (comma)
		g95_status(", ");

	    g95_status("blank=");
	    g95_show_expr(open->blank);
	    comma = 1;
	}

	if (open->position) {
	    if (comma)
		g95_status(", ");

	    g95_status("position=");
	    g95_show_expr(open->position);
	    comma = 1;
	}

	if (open->action) {
	    if (comma)
		g95_status(", ");

	    g95_status("action=");
	    g95_show_expr(open->action);
	    comma = 1;
	}

	if (open->delim) {
	    if (comma)
		g95_status(", ");

	    g95_status("delim=");
	    g95_show_expr(open->delim);
	    comma = 1;
	}

	if (open->pad) {
	    if (comma)
		g95_status(", ");

	    g95_status("pad=");
	    g95_show_expr(open->pad);
	    comma = 1;
	}

	if (open->err != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("err=%d", open->err->value);
	    comma = 1;
	}

	break;

    case EXEC_CLOSE:
	g95_status("close(");
	close = c->ext.close;
	comma = 0;

	if (close->unit) {
	    if (comma)
		g95_status(", ");
	    
	    g95_status("unit=");
	    g95_show_expr(close->unit);
	    comma = 1;
	}

	if (close->iostat) {
	    if (comma)
		g95_status(", ");

	    g95_status("iostat=");
	    g95_show_expr(close->iostat);
	    comma = 1;
	}

	if (close->status) {
	    if (comma)
		g95_status(", ");

	    g95_status("status=");
	    g95_show_expr(close->status);
	    comma = 1;
	}

	if (close->err != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("err=%d", close->err->value);
	    comma = 1;
	}

	break;

    case EXEC_BACKSPACE:
	g95_status("backspace(");
	goto show_filepos;

    case EXEC_ENDFILE:
	g95_status("endfile(");
	goto show_filepos;

    case EXEC_REWIND:
	g95_status("rewind(");

    show_filepos:
	fp = c->ext.filepos;
	comma = 0;

	if (fp->unit) {
	    if (comma)
		g95_status(", ");

	    g95_status("unit=");
	    g95_show_expr(fp->unit);
	    comma = 1;
	}

	if (fp->iostat) {
	    if (comma)
		g95_status(", ");
	    
	    g95_status("iostat=");
	    g95_show_expr(fp->iostat);
	    comma = 1;
	}

	if (fp->err != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("err=%d", fp->err->value);
	    comma = 1;
	}

	break;

    case EXEC_INQUIRE:
	g95_status("inquire(");
	i = c->ext.inquire;
	comma = 0;

	if (i->unit) {
	    if (comma)
		g95_status(", ");

	    g95_status("unit=");
	    g95_show_expr(i->unit);
	    comma = 1;
	}

	if (i->file) {
	    if (comma)
		g95_status(", ");

	    g95_status("file=");
	    g95_show_expr(i->file);
	    comma = 1;
	}

	if (i->iostat) {
	    if (comma)
		g95_status(", ");

	    g95_status("iostat=");
	    g95_show_expr(i->iostat);
	    comma = 1;
	}

	if (i->exist) {
	    if (comma)
		g95_status(", ");

	    g95_status("exist=");
	    g95_show_expr(i->exist);
	    comma = 1;
	}

	if (i->opened) {
	    if (comma)
		g95_status(", ");

	    g95_status("opened=");
	    g95_show_expr(i->opened);
	    comma = 1;
	}

	if (i->number) {
	    if (comma)
		g95_status(", ");

	    g95_status("number=");
	    g95_show_expr(i->number);
	    comma = 1;
	}

	if (i->named) {
	    if (comma)
		g95_status(", ");

	    g95_status("named=");
	    g95_show_expr(i->named);
	    comma = 1;
	}

	if (i->name) {
	    if (comma)
		g95_status(", ");

	    g95_status("name=");
	    g95_show_expr(i->name);
	    comma = 1;
	}

	if (i->access) {
	    if (comma)
		g95_status(", ");

	    g95_status("access=");
	    g95_show_expr(i->access);
	    comma = 1;
	}

	if (i->sequential) {
	    if (comma)
		g95_status(", ");

	    g95_status("sequential=");
	    g95_show_expr(i->sequential);
	    comma = 1;
	}

	if (i->direct) {
	    if (comma)
		g95_status(", ");

	    g95_status("direct=");
	    g95_show_expr(i->direct);
	    comma = 1;
	}

	if (i->form) {
	    if (comma)
		g95_status(", ");

	    g95_status("form=");
	    g95_show_expr(i->form);
	    comma = 1;
	}

	if (i->formatted) {
	    if (comma)
		g95_status(", ");

	    g95_status("formatted=");
	    g95_show_expr(i->formatted);
	    comma = 1;
	}

	if (i->unformatted) {
	    if (comma)
		g95_status(", ");

	    g95_status("unformatted=");
	    g95_show_expr(i->unformatted);
	    comma = 1;
	}

	if (i->recl) {
	    if (comma)
		g95_status(", ");
	    
	    g95_status("recl=");
	    g95_show_expr(i->recl);
	    comma = 1;
	}

	if (i->nextrec) {
	    if (comma)
		g95_status(", ");

	    g95_status("nextrec=");
	    g95_show_expr(i->nextrec);
	    comma = 1;
	}

	if (i->blank) {
	    if (comma)
		g95_status(", ");

	    g95_status("blank=");
	    g95_show_expr(i->blank);
	    comma = 1;
	}

	if (i->position) {
	    if (comma)
		g95_status(", ");

	    g95_status("position=");
	    g95_show_expr(i->position);
	    comma = 1;
	}

	if (i->action) {
	    if (comma)
		g95_status(", ");

	    g95_status("action=");
	    g95_show_expr(i->action);
	    comma = 1;
	}

	if (i->read) {
	    if (comma)
		g95_status(", ");

	    g95_status("read=");
	    g95_show_expr(i->read);
	    comma = 1;
	}

	if (i->write) {
	    if (comma)
		g95_status(", ");

	    g95_status("write=");
	    g95_show_expr(i->write);
	    comma = 1;
	}

	if (i->readwrite) {
	    if (comma)
		g95_status(", ");

	    g95_status("readwrite=");
	    g95_show_expr(i->readwrite);
	    comma = 1;
	}

	if (i->delim) {
	    if (comma)
		g95_status(", ");
	    
	    g95_status("delim=");
	    g95_show_expr(i->delim);
	    comma = 1;
	}

	if (i->stream != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("stream=");
	    g95_show_expr(i->stream);
	    comma = 1;
	}

	if (i->pad) {
	    if (comma)
		g95_status(", ");

	    g95_status("pad=");
	    g95_show_expr(i->pad);
	    comma = 1;
	}

	if (i->err != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("err=%d", i->err->value);
	    comma = 1;
	}

	break;

    case EXEC_IOLENGTH:
	g95_status("iolength(expr=");
	g95_show_expr(c->expr);
	comma = 0;
	break;

    case EXEC_READ:
	g95_status("read(expr=");
	goto show_dt;

    case EXEC_WRITE:
	g95_status("write(expr=");

    show_dt:
	dt = c->ext.dt;
	comma = 0;

	if (dt->io_unit) {
	    if (comma)
		g95_status(", ");

	    g95_status("unit=");
	    g95_show_expr(dt->io_unit);
	    comma = 1;
	}

	if (dt->format_expr) {
	    if (comma)
		g95_status(", ");

	    g95_status("format_expr=");
	    g95_show_expr(dt->format_expr);
	    comma = 1;
	}

	if (dt->format_label != NULL) {
	    if (comma)
		g95_status(", ");
	    
	    g95_status("format_label=%d", dt->format_label->value);
	    comma = 1;
	}

	if (dt->namelist != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("nml=%s", dt->namelist->name);
	    comma = 1;
	}

	if (dt->iostat != NULL) {
	    if (comma)
		g95_status(", ");
	    g95_status("iostat=");
	    g95_show_expr(dt->iostat);
	    comma = 1;
	}

	if (dt->size != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("size=");
	    g95_show_expr(dt->size);
	    comma = 1;
	}

	if (dt->rec != NULL) {
	    if (comma)
		g95_status(", ");

	    g95_status("rec=");
	    g95_show_expr(dt->rec);
	    comma = 1;
	}

	if (dt->advance) {
	    if (comma)
		g95_status(", ");

	    g95_status("advance=");
	    g95_show_expr(dt->advance);
	    comma = 1;
	}

	break;

  case EXEC_TRANSFER:
      g95_status("transfer(expr=");
      g95_show_expr(c->expr);
      comma = 1;
      break;

  case EXEC_DT_END:
      g95_status("dt_end(");
      comma = 0;

      dt = c->ext.dt;
      if (dt != NULL) {
	  if (dt->err != NULL) {
	      if (comma)
		  g95_status(", ");
	      
	      g95_status("err=%d", dt->err->value);
	      comma = 1;
	  }

	  if (dt->end != NULL) {
	      if (comma)
		  g95_status(", ");
	      g95_status("end=%d", dt->end->value);
	      comma = 1;
	  }

	  if (dt->eor != NULL) {
	      if (comma)
		  g95_status(", ");

	      g95_status("eor=%d", dt->eor->value);
	      comma = 1;
	  }
      }

      break;

    case EXEC_ENTRY:
	g95_status("entry(name='%s'", c->sym->name);
	comma = 1;
	break;

    case EXEC_LABEL_ASSIGN:
	g95_status("assign_label(expr=");
	g95_show_expr(c->expr);
	g95_status(", label=%d", c->label->value);
	comma = 1;
	break;

    case EXEC_ERROR_STOP:
	g95_status("ERROR STOP(");
	break;

    case EXEC_SYNC_ALL:
	g95_status("SYNC ALL(");
	break;

    case EXEC_SYNC_MEMORY:
	g95_status("SYNC MEMORY(");
	break;

    case EXEC_SYNC_IMAGES:
	g95_status("SYNC IMAGES(");

	if (c->expr == NULL)
	    g95_status_char('*');

	else
	    g95_show_expr(c->expr);

	break;

    case EXEC_SYNC_TEAM:
	g95_status("SYNC TEAM(");

	if (c->expr == NULL)
	    g95_status_char('*');

	else
	    g95_show_expr(c->expr);

	break;

    case EXEC_CRITICAL:
	g95_status("CRITICAL\n");
	show_code(level+1, c->block);

	code_indent(level, 0);
	g95_status("END CRITICAL");
	break;

    default:
	g95_internal_error("show_code0(): Bad statement code");
    }

    g95_status_char(')');
    g95_status_char('\n');
}
Exemple #17
0
static void show_symbol(g95_symbol *sym) {
g95_formal_arglist *formal;
symbol_attribute *attr;
g95_component *c;

    if (sym == NULL)
	return;

    show_indent();

    g95_status("symbol(%s, ts=", g95_symbol_name(sym));
    show_typespec(&sym->ts);

    attr = &sym->attr;
    g95_status(", flavor='%s'", g95_flavor_string(attr->flavor));

    if (attr->intent != INTENT_UNKNOWN)
	g95_status(", intent='%s'", g95_intent_string(attr->intent));

    if (attr->access != ACCESS_UNKNOWN)
	g95_status(", access='%s'", g95_access_string(attr->access));

    if (attr->proc != PROC_UNKNOWN)
	g95_status(", proc='%s'", g95_procedure_string(attr->proc));

    if (attr->allocatable)
	g95_status(", allocatable=1");

    if (attr->dimension)
	g95_status(", dimension=1");

    if (attr->external)
	g95_status(", external=1");

    if (attr->intrinsic)
	g95_status(", intrinsic=1");

    if (attr->optional)
	g95_status(", optional=1");

    if (attr->pointer)
	g95_status(", pointer=1");

    if (attr->save)
	g95_status(", save=1");

    if (attr->target)
	g95_status(", target=1");

    if (attr->dummy)
	g95_status(", dummy=1");

    if (attr->result_var)
	g95_status(", result=1");

    if (attr->entry)
	g95_status(", entry=1");

    if (attr->data)
	g95_status(", data=1");

    if (attr->use_assoc)
	g95_status(", use_assoc=1");

    if (attr->in_namelist)
	g95_status(", in_namelist=1");

    if (attr->in_common)
	g95_status(", in_common=1");

    if (attr->function)
	g95_status(", function=1");

    if (attr->subroutine)
	g95_status(", subroutine=1");

    if (attr->sequence)
	g95_status(", sequence=1");

    if (attr->elemental)
	g95_status(", elemental=1");

    if (attr->pure)
	g95_status(", pure=1");

    if (attr->recursive)
	g95_status(", recursive=1");

    if (attr->artificial)
	g95_status(", artificial=1");

    if (sym->value) {
	g95_status(", value=");
	g95_show_expr(sym->value);
    }

    if (sym->as != NULL) {
	g95_status(", as=");
	show_array_spec(sym->as);
    }

    if (sym->result)
	g95_status(", result=%s", g95_symbol_name(sym->result));

    if (sym->components) {
	g95_status(", components=[");
	for(c=sym->components; c; c=c->next)
	    show_component(c);

	g95_status("]");
    }

    if (sym->formal) {
	show_indent();
	g95_status("formal=[");

	for(formal=sym->formal; formal; formal=formal->next)
	    if (formal->sym == NULL)
		g95_status("*");
	    else
		g95_status("'%s', ", formal->sym->name);

	g95_status("]");
    }

    g95_status(")\n");
}
Exemple #18
0
void g95_show_expr(g95_expr *p) {
g95_symbol *sym;

    if (p == NULL) {
	g95_status("expr()");
	return;
    }

/* Show expression */

    switch(p->type) {
    case EXPR_SUBSTRING:
	g95_status("substr(");

	show_string_constant(p->value.character.string,
			     p->value.character.length);

	g95_status(", start=");
	g95_show_expr(p->ref->u.ss.start);
	g95_status(", end=");
	g95_show_expr(p->ref->u.ss.end);
	break;

    case EXPR_STRUCTURE:
	g95_status("scons('%s', cons=", p->symbol->name);
	show_constructor(p->value.constructor.c);
	break;

    case EXPR_ARRAY:
	g95_status("acons(cons=");
	show_constructor(p->value.constructor.c);
 
	if (p->ref != NULL) {
	    g95_status(", ref=");
	    show_refs(p->ref);
	}

	break;

    case EXPR_NULL:
	g95_status("null()");
	break;

    case EXPR_CONSTANT:
	g95_status("const(");
	show_constant(p);
	break;

    case EXPR_VARIABLE:
	g95_status("var(");

	sym = p->symbol;

	if (sym->ns->proc_name != NULL && sym->ns->proc_name->name != NULL)
	    g95_status("'%s:%s'", sym->ns->proc_name->name, sym->name);
	else
	    g95_status("'%s'", sym->name);

	if (p->ref != NULL) {
	    g95_status(", ref=");
	    show_refs(p->ref);
	}

	break;

    case EXPR_OP:
	g95_status("op(");
	switch(p->value.op.operator) {
	case INTRINSIC_UPLUS:   g95_status("'U+'");    break;
	case INTRINSIC_UMINUS:  g95_status("'U-'");    break;
	case INTRINSIC_PLUS:    g95_status("'+'");     break;
	case INTRINSIC_MINUS:   g95_status("'-'");     break;
	case INTRINSIC_TIMES:   g95_status("'*'");     break;
	case INTRINSIC_DIVIDE:  g95_status("'/'");     break;
	case INTRINSIC_POWER:   g95_status("'**'");    break;
	case INTRINSIC_CONCAT:  g95_status("'//'");    break;
	case INTRINSIC_AND:     g95_status("'AND'");   break;
	case INTRINSIC_OR:      g95_status("'OR'");    break;
	case INTRINSIC_EQV:     g95_status("'EQV'");   break;
	case INTRINSIC_NEQV:    g95_status("'NEQV'");  break;
	case INTRINSIC_EQ:      g95_status("'='");     break;
	case INTRINSIC_NE:      g95_status("'<>'");    break;
	case INTRINSIC_GT:      g95_status("'>'");     break;
	case INTRINSIC_GE:      g95_status("'>='");    break;
	case INTRINSIC_LT:      g95_status("'<'");     break;
	case INTRINSIC_LE:      g95_status("'<='");    break;
	case INTRINSIC_NOT:     g95_status("'NOT'");   break;
	case INTRINSIC_PAREN:   g95_status("()");      break;

	default:
	    g95_internal_error("g95_show_expr(): "
			       "Bad intrinsic in expression!");
	}

	g95_status(", op1=");
	g95_show_expr(p->value.op.op1);

	if (p->value.op.op2) {
	    g95_status(", op2=");
	    g95_show_expr(p->value.op.op2);
	}

	break;

    case EXPR_FUNCTION:
	g95_status("func(");
	if (p->value.function.isym == NULL)
	    g95_status("'%s:%s'", p->symbol->module, p->symbol->name);
	else
	    g95_status("'%s'", p->value.function.iname);

	g95_status(", arg=");
	show_actual_arglist(p->value.function.actual);
	break;

    case EXPR_UNKNOWN:
	g95_status("unknown('%s'", p->symbol->name);
	break;

    default:
	g95_internal_error("g95_show_expr(): Bad type");
	break;
    }

    g95_status_char(')');
}
Exemple #19
0
void g95_show_namespace(g95_namespace *ns) {
g95_interface *intr;
g95_namespace *save;
int i;

    if (ns == NULL)
	return;

    save = g95_current_ns; 

    show_indent();
    g95_status("ns(");

    for(i=0; i<G95_LETTERS; i++) {
	g95_status("%c=", i+'A');
	show_typespec(&ns->default_type[i]);

	if (i != G95_LETTERS-1)
	    g95_status_char(',');

	g95_status_char((i % 3 == 2) ? '\n' : ' ');
    }

    if (ns->proc_name != NULL)
	g95_status(", name='%s'", ns->proc_name->name);

    g95_status(")\n");

    for(i=0; i<G95_INTRINSIC_OPS; i++) {    /* User operator interfaces */
	intr = ns->operator[i];
	if (intr == NULL)
	    continue;

	g95_status("operator('%s', [", g95_op2string(i));

	for(; intr; intr=intr->next)
	    g95_status(" '%s',", intr->sym->name);

	g95_status("])\n");
    }

    g95_traverse_user_op(ns, show_uop);

    g95_traverse_symtree(ns, g95_clear_sym_mark);

    g95_current_ns = ns;
    g95_traverse_symtree(ns, show_symtree);
    g95_status("\n\n");

    show_code(0, ns->code);
    show_level++; 

    for(ns=ns->contained; ns; ns=ns->sibling) {
	g95_status("# Contains\n");
	g95_show_namespace(ns);
    }

    show_level--;
    g95_status_char('\n');
    g95_current_ns = save;
}