static void dump_constant(g95_expr *e) { switch(e->ts.type) { case BT_INTEGER: dumpf("integer(%L,%s)", &e->where, bi_to_string(e->value.integer)); break; case BT_REAL: dumpf("real(%L,'%s')", &e->where, bg_to_string(e->value.real)); break; case BT_COMPLEX: dumpf("complex(%L,'%s','%s')", &e->where, bg_to_string(e->value.complex.r), bg_to_string(e->value.complex.i)); break; case BT_LOGICAL: dumpf("logical(%L,%d)", &e->where, e->value.logical); break; case BT_CHARACTER: dumpf("char(%L, %S)", &e->where, e->value.character.string); break; default: g95_internal_error("dump_constant(): Bad constant"); } }
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"); } }
static void dump_name(g95_symbol *sym, g95_intrinsic_sym *isym) { if (isym == NULL) dumpf("%p", sym); else if (isym->name[0] != '\0') dumpf("%S", isym->name); else /* Nameless intrinsics */ switch(isym->id) { case G95_ISYM_ABS: dumpf("'abs'"); break; case G95_ISYM_ACOS: dumpf("'acos'"); break; case G95_ISYM_AIMAG: dumpf("'aimag'"); break; case G95_ISYM_ASIN: dumpf("'asin'"); break; case G95_ISYM_ATAN: dumpf("'atan'"); break; case G95_ISYM_ATAN2: dumpf("'atan2'"); break; case G95_ISYM_CONJG: dumpf("'conjg'"); break; case G95_ISYM_COS: dumpf("'cos'"); break; case G95_ISYM_COSH: dumpf("'cosh'"); break; case G95_ISYM_EXP: dumpf("'exp'"); break; case G95_ISYM_LOG: dumpf("'log'"); break; case G95_ISYM_LOG10: dumpf("'log10'"); break; case G95_ISYM_MOD: dumpf("'mod'"); break; case G95_ISYM_SIN: dumpf("'sin'"); break; case G95_ISYM_SINH: dumpf("'sinh'"); break; case G95_ISYM_SQRT: dumpf("'sqrt'"); break; case G95_ISYM_TAN: dumpf("'tan'"); break; case G95_ISYM_TANH: dumpf("'tanh'"); break; default: g95_internal_error("dump_name(): Nameless intrinsic!"); } }
char *g95_code2string(mstring *c, int codep) { while(c->string != NULL) { if (c->tag == codep) return c->string; c++; } g95_internal_error("g95_code2string(): Bad code"); return NULL; }
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; } }
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"); } }
static int find_mask_symbol(g95_expr *j, g95_symbol *target) { g95_actual_arglist *ap; g95_ref *r; int retval; if (j == NULL) return 0; retval = 0; switch(j->type) { case EXPR_OP: retval = find_mask_symbol(j->op1, target) || find_mask_symbol(j->op2, target); break; case EXPR_CONSTANT: case EXPR_NULL: break; case EXPR_FUNCTION: for(ap=j->value.function.actual; ap; ap=ap->next) if (find_mask_symbol(ap->u.expr, target)) { retval = 1; break; } break; case EXPR_VARIABLE: if (j->symbol == target) { retval = 1; break; } for(r=j->ref; r; r=r->next) retval |= find_mask_ref(r, target); break; case EXPR_SUBSTRING: retval = find_mask_ref(j->ref, target); break; case EXPR_STRUCTURE: case EXPR_ARRAY: retval = find_mask_constructor(j->value.constructor, target); break; default: g95_internal_error("find_mask_symbol(): Bad expression"); } return retval; }
char *g95_basic_typename(bt type) { char *v; switch(type) { case BT_INTEGER: v = "INTEGER"; break; case BT_REAL: v = "REAL"; break; case BT_COMPLEX: v = "COMPLEX"; break; case BT_LOGICAL: v = "LOGICAL"; break; case BT_CHARACTER: v = "CHARACTER"; break; case BT_DERIVED: v = "DERIVED"; break; case BT_PROCEDURE: v = "PROCEDURE"; break; case BT_UNKNOWN: v = "UNKNOWN"; break; default: g95_internal_error("g95_basic_typename(): Undefined type"); } return v; }
static void dump_intrinsic(g95_expr *e) { char *name; int binary; binary = 1; switch(e->value.op.operator) { case INTRINSIC_UPLUS: name = "uplus"; binary = 0; break; case INTRINSIC_NOT: name = "unot"; binary = 0; break; case INTRINSIC_UMINUS: name = "uminus"; binary = 0; break; case INTRINSIC_PLUS: name = "plus"; break; case INTRINSIC_MINUS: name = "minus"; break; case INTRINSIC_TIMES: name = "times"; break; case INTRINSIC_DIVIDE: name = "divide"; break; case INTRINSIC_POWER: name = "power"; break; case INTRINSIC_CONCAT: name = "concat"; break; case INTRINSIC_AND: name = "logical_and"; break; case INTRINSIC_OR: name = "logical_or"; break; case INTRINSIC_EQV: name = "logical_eqv"; break; case INTRINSIC_NEQV: name = "logical_neqv"; break; case INTRINSIC_EQ: name = "cmp_eq"; break; case INTRINSIC_NE: name = "cmp_ne"; break; case INTRINSIC_GT: name = "cmp_gt"; break; case INTRINSIC_GE: name = "cmp_ge"; break; case INTRINSIC_LT: name = "cmp_lt"; break; case INTRINSIC_LE: name = "cmp_le"; break; case INTRINSIC_PAREN: dump_expr(e->value.op.op1); return; default: g95_internal_error("dump_intrinsic(): Bad intrinsic"); } dumpf("%s(%L,", name, &e->where); dump_expr(e->value.op.op1); if (binary) { dump_char(','); dump_expr(e->value.op.op2); } dump_char(')'); }
static int compare_expr(g95_expr *a, g95_expr *b) { int rc; switch(a->ts.type) { case BT_INTEGER: rc = bi_compare(a->value.integer, b->value.integer); break; case BT_CHARACTER: rc = g95_compare_string(a, b, NULL); break; case BT_LOGICAL: rc = a->value.logical != b->value.logical; break; default: g95_internal_error("compare_expr(): Bad type"); } return rc; }
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"); } }
char *g95_typename(g95_typespec *typ) { static char buffer1[60], buffer2[60]; static int flag = 0; char *buffer; buffer = flag ? buffer1 : buffer2; flag = !flag; switch(typ->type) { case BT_INTEGER: sprintf(buffer, "INTEGER(%d)", typ->kind); break; case BT_REAL: sprintf(buffer, "REAL(%d)", typ->kind); break; case BT_COMPLEX: sprintf(buffer, "COMPLEX(%d)", typ->kind); break; case BT_LOGICAL: sprintf(buffer, "LOGICAL(%d)", typ->kind); break; case BT_CHARACTER: sprintf(buffer, "CHARACTER(%d)", typ->kind); break; case BT_DERIVED: sprintf(buffer, "TYPE(%s)", typ->derived->name); break; case BT_PROCEDURE: strcpy(buffer, "PROCEDURE"); break; case BT_UNKNOWN: strcpy(buffer, "UNKNOWN"); break; default: g95_internal_error("g95_typespec(): Undefined type"); } return buffer; }
static void dump_ns(g95_namespace *ns) { g95_symbol *sym, *result; g95_namespace *p, *save; g95_locus *where; g95_annot *a; int m, rank; save = g95_current_ns; g95_current_ns = ns; where = &ns->declared_at; sym = ns->proc_name; switch(ns->state) { case COMP_PROGRAM: if (ns->unit_name == NULL) dumpf("program(None, %L)\n", where); else dumpf("program(%S,%L)\n", ns->unit_name, where); break; case COMP_MODULE: dumpf("module(%S,%L,%L)\n", sym->name, where, &ns->proc_name->declared_at); break; case COMP_SUBROUTINE: dumpf("subroutine(%S,%S,%L,", sym->name, sym->module, &ns->proc_name->declared_at); dump_formal(ns->proc_name); dumpf(")\n"); break; case COMP_FUNCTION: result = sym->result; rank = (result->as == NULL) ? 0 : result->as->rank; dumpf("function(%S,%S,%L,%S,%d,%d,", sym->name, sym->module, &ns->proc_name->declared_at, g95_typename(&result->ts), rank, result->attr.pointer); dump_formal(ns->proc_name); dumpf(")\n"); break; case COMP_BLOCK_DATA: if (ns->proc_name->name == NULL) dumpf("block_data(None,%L)\n", where); else dumpf("block_data(%S,%L)\n", sym->name, where); break; case COMP_NONE: return; default: g95_internal_error("dump_ns(): Bad state"); } g95_traverse_symtree(ns, g95_clear_sym_mark); g95_traverse_symtree(ns, dump_symtree); dump_common(ns->common_root); for(a=ns->annotation; a; a=a->next) switch(a->type) { case ANNOT_PARAMETER: dumpf("parameter_use(%p,%L)\n", a->u.sym, &a->where); break; case ANNOT_DERIVED: dumpf("derived_use(%p,%L)\n", a->u.sym, &a->where); break; case ANNOT_LABEL: dumpf("label_use(%p,%L)\n", a->u.sym, &a->where); break; case ANNOT_OPERATOR: dumpf("operator_use(%p,%L)\n", a->u.sym, &a->where); break; default: g95_internal_error("init_dump(): Bad type"); } m = dump_code(ns->code); dumpf("add_code(%C)\n", m); if (m != 0) dumpf("del %C\n", m); for(p=ns->contained; p; p=p->sibling) dump_ns(p); dumpf("end()\n"); g95_current_ns = save; }
static int dump_code(g95_code *c) { int m, n, list_size, *list, node[2]; g95_forall_iterator *f; g95_filepos *filepos; g95_inquire *inquire; g95_close *close; g95_flush *flush; g95_alloc *alloc; g95_open *open; g95_wait *wait; g95_case *sel; g95_code *d; g95_dt *dt; if (c == NULL) return 0; n = st_n++; list = NULL; list_size = 0; dumpf("%C = []\n", n); for(; c; c=c->next) { switch(c->type) { case EXEC_CONTINUE: case EXEC_NOP: case EXEC_DT_END: dumpf("%C.append(st_nop(%L", n, &c->where); break; case EXEC_ASSIGN: dumpf("%C.append(st_assign(%L,", n, &c->where); dump_expr(c->expr); dump_char(','); dump_expr(c->expr2); break; case EXEC_POINTER_ASSIGN: dumpf("%C.append(st_ptr_assign(%L,", n, &c->where); dump_expr(c->expr); dump_char(','); dump_expr(c->expr2); break; case EXEC_GOTO: dumpf("%C.append(st_goto(%L, %d", n, &c->where, c->label->value); break; case EXEC_PAUSE: dumpf("%C.append(st_pause(%L", n, &c->where); break; case EXEC_STOP: dumpf("%C.append(st_stop(%L", n, &c->where); break; case EXEC_RETURN: dumpf("%C.append(st_return(%L", n, &c->where); if (c->expr != NULL) { dumpf(",rc="); dump_expr(c->expr); } break; case EXEC_IF: node[0] = dump_code(c->block); node[1] = dump_code(c->ext.block); list = node; list_size = 2; dumpf("%C.append(st_if(%L,", n, &c->where); dump_expr(c->expr); dumpf(",%C,%C", node[0], node[1]); break; case EXEC_DO_WHILE: node[0] = dump_code(c->block); list = node; list_size = 1; dumpf("%C.append(st_do_while(%L,", n, &c->where, node[0]); dump_expr(c->expr); dumpf(",%C", node[0]); if (c->sym != NULL) dumpf(",label='%s'", c->sym->name); break; case EXEC_DO: node[0] = dump_code(c->block); list = node; list_size = 1; dumpf("%C.append(st_do(%L, ", n, &c->where); dump_expr(c->ext.iterator->var); dump_char(','); dump_expr(c->ext.iterator->start); dump_char(','); dump_expr(c->ext.iterator->end); dump_char(','); dump_expr(c->ext.iterator->step); dumpf(",%C", node[0]); if (c->sym != NULL) dumpf(",label='%s'", c->sym->name); break; case EXEC_OPEN: open = c->ext.open; dumpf("%C.append(st_open(%L", n, &c->where); if (open->unit != NULL) { dumpf(",unit="); dump_expr(open->unit); } if (open->file != NULL) { dumpf(",file="); dump_expr(open->file); } if (open->status != NULL) { dumpf(",status="); dump_expr(open->status); } if (open->access != NULL) { dumpf(",access="); dump_expr(open->access); } if (open->form != NULL) { dumpf(",form="); dump_expr(open->form); } if (open->recl != NULL) { dumpf(",recl="); dump_expr(open->recl); } if (open->decimal != NULL) { dumpf(",decimal="); dump_expr(open->decimal); } if (open->blank != NULL) { dumpf(",blank="); dump_expr(open->position); } if (open->position != NULL) { dumpf(",position="); dump_expr(open->position); } if (open->action != NULL) { dumpf(",action="); dump_expr(open->action); } if (open->delim != NULL) { dumpf(",delim="); dump_expr(open->delim); } if (open->pad != NULL) { dumpf(",pad="); dump_expr(open->pad); } if (open->iostat != NULL) { dumpf(",iostat="); dump_expr(open->iostat); } if (open->err != NULL) dumpf(",err=%d", open->err->value); break; case EXEC_CLOSE: close = c->ext.close; dumpf("%C.append(st_close(%L", n, &c->where); if (close->unit != NULL) { dumpf(",unit="); dump_expr(close->unit); } if (close->status != NULL) { dumpf(",status="); dump_expr(close->status); } if (close->iostat != NULL) { dumpf(",iostat="); dump_expr(close->iostat); } if (close->err != NULL) dumpf(",err=%d", close->err->value); break; case EXEC_BACKSPACE: dumpf("%C.append(st_backspace(%L", n, &c->where); goto show_filepos; case EXEC_ENDFILE: dumpf("%C.append(st_endfile(%L", n, &c->where); goto show_filepos; case EXEC_REWIND: dumpf("%C.append(st_rewind(%L", n, &c->where); show_filepos: filepos = c->ext.filepos; if (filepos->unit != NULL) { dumpf(",unit="); dump_expr(filepos->unit); } if (filepos->iostat != NULL) { dumpf(",iostat="); dump_expr(filepos->iostat); } if (filepos->err != NULL) dumpf(",err=%d", filepos->err->value); break; case EXEC_INQUIRE: dumpf("%C.append(st_inquire(%L", n, &c->where); inquire = c->ext.inquire; if (inquire->unit != NULL) { dumpf(",unit="); dump_expr(inquire->unit); } if (inquire->file != NULL) { dumpf(",file="); dump_expr(inquire->file); } if (inquire->iostat != NULL) { dumpf(",iostat="); dump_expr(inquire->iostat); } if (inquire->exist != NULL) { dumpf(",exist="); dump_expr(inquire->exist); } if (inquire->opened != NULL) { dumpf(",opened="); dump_expr(inquire->opened); } if (inquire->number != NULL) { dumpf(",number="); dump_expr(inquire->number); } if (inquire->named != NULL) { dumpf(",named="); dump_expr(inquire->named); } if (inquire->name != NULL) { dumpf(",name="); dump_expr(inquire->name); } if (inquire->access != NULL) { dumpf(",access="); dump_expr(inquire->access); } if (inquire->sequential != NULL) { dumpf(",sequential="); dump_expr(inquire->sequential); } if (inquire->direct != NULL) { dumpf(",direct="); dump_expr(inquire->direct); } if (inquire->form != NULL) { dumpf(",form="); dump_expr(inquire->form); } if (inquire->formatted != NULL) { dumpf(",formatted="); dump_expr(inquire->formatted); } if (inquire->unformatted != NULL) { dumpf(",unformatted="); dump_expr(inquire->unformatted); } if (inquire->recl != NULL) { dumpf(",recl="); dump_expr(inquire->recl); } if (inquire->nextrec != NULL) { dumpf(",nextrec="); dump_expr(inquire->nextrec); } if (inquire->blank != NULL) { dumpf(",blank="); dump_expr(inquire->blank); } if (inquire->position != NULL) { dumpf(",position="); dump_expr(inquire->position); } if (inquire->action != NULL) { dumpf(",action="); dump_expr(inquire->action); } if (inquire->read != NULL) { dumpf(",read="); dump_expr(inquire->read); } if (inquire->write != NULL) { dumpf(",write="); dump_expr(inquire->write); } if (inquire->readwrite != NULL) { dumpf(",readwrite="); dump_expr(inquire->readwrite); } if (inquire->delim != NULL) { dumpf(",delim="); dump_expr(inquire->delim); } if (inquire->pad != NULL) { dumpf(",pad="); dump_expr(inquire->pad); } if (inquire->pos != NULL) { dumpf(",pos="); dump_expr(inquire->pos); } if (inquire->iolength != NULL) { dumpf(",iolength="); dump_expr(inquire->iolength); } if (inquire->size != NULL) { dumpf(",size="); dump_expr(inquire->size); } if (inquire->err != NULL) dumpf(",err=%d", inquire->err->value); break; case EXEC_FLUSH: dumpf("%C.append(st_flush(%L", n, &c->where); flush = c->ext.flush; if (flush->unit != NULL) { dumpf(",unit="); dump_expr(flush->unit); } if (flush->iostat != NULL) { dumpf(",iostat="); dump_expr(flush->iostat); } if (flush->iomsg != NULL) { dumpf(",iomsg="); dump_expr(flush->iomsg); } if (flush->err != NULL) dumpf(",err=%d", flush->err->value); break; case EXEC_WAIT: dumpf("%C.append(st_wait(%L", n, &c->where); wait = c->ext.wait; if (wait->unit != NULL) { dumpf(",unit="); dump_expr(wait->unit); } if (wait->id != NULL) { dumpf(",id="); dump_expr(wait->id); } if (wait->iostat != NULL) { dumpf(",iostat="); dump_expr(wait->iostat); } if (wait->iomsg != NULL) { dumpf(",iomsg="); dump_expr(wait->iomsg); } if (wait->err != NULL) dumpf(",err=%d", wait->err->value); if (wait->end != NULL) dumpf(",end=%d", wait->end->value); if (wait->eor != NULL) dumpf(",eof=%d", wait->eor->value); break; case EXEC_IOLENGTH: dumpf("%C.append(st_iolength(%L,", n, &c->where); dump_expr(c->expr); break; case EXEC_WRITE: dumpf("%C.append(st_write(%L", n, &c->where); goto show_dt; case EXEC_READ: dumpf("%C.append(st_read(%L", n, &c->where); show_dt: dt = c->ext.dt; if (dt->io_unit->ts.type == BT_INTEGER) dumpf(",unit="); else dumpf(",internal_unit="); dump_expr(dt->io_unit); if (dt->format_expr != NULL) { dumpf(",format_expr="); dump_expr(dt->format_expr); } if (dt->rec != NULL) { dumpf(",rec="); dump_expr(dt->rec); } if (dt->advance != NULL) { dumpf(",advance="); dump_expr(dt->advance); } if (dt->iostat != NULL) { dumpf(",iostat="); dump_expr(dt->iostat); } if (dt->size != NULL) { dumpf(",size="); dump_expr(dt->size); } if (dt->pos != NULL) { dumpf(",pos="); dump_expr(dt->pos); } if (dt->decimal != NULL) { dumpf(",decimal="); dump_expr(dt->decimal); } if (dt->namelist != NULL) dumpf(",namelist=(%S,%L)", dt->namelist->name, &dt->namelist_where); if (dt->format_label != NULL) dumpf(",format_label=%d", dt->format_label->value); if (dt->err != NULL) dumpf(",err=%d", dt->err->value); if (dt->end != NULL) dumpf(",end=%d", dt->end->value); if (dt->eor != NULL) dumpf(",eof=%d", dt->eor->value); break; case EXEC_TRANSFER: dumpf("%C.append(st_transfer(%L,%d,", n, &c->expr->where, c->ext.transfer == M_READ); dump_expr(c->expr); break; case EXEC_ALLOCATE: dumpf("%C.append(st_allocate(%L,", n, &c->where); goto show_alloc; case EXEC_DEALLOCATE: dumpf("%C.append(st_deallocate(%L,", n, &c->where); show_alloc: dumpf("["); alloc = c->ext.alloc_list; while(alloc != NULL) { dump_expr(alloc->expr); if (alloc->next != NULL) dump_char(','); alloc = alloc->next; } dumpf("]"); if (c->expr != NULL) { dumpf(",stat="); dump_expr(c->expr); } break; case EXEC_ARITHMETIC_IF: dumpf("%C.append(st_arith_if(%L,", n, &c->where); dump_expr(c->expr); dumpf(", %d, %d, %d", c->label->value, c->label2->value, c->label3->value); break; case EXEC_LABEL_ASSIGN: dumpf("%C.append(st_label_assign(%L,", n, &c->where); dump_expr(c->expr); dumpf(", %d", c->label->value); break; case EXEC_SELECT: for(d=c->block; d; d=d->block) list_size++; list = g95_getmem(list_size * sizeof(int)); m = 0; for(d=c->block; d; d=d->block) list[m++] = dump_code(d->next); dumpf("%C.append(st_select(%L, ", n, &c->where); dump_expr(c->expr); dumpf(",["); m = 0; for(d=c->block; d; d=d->next) { dumpf("["); for(sel=d->ext.case_list; sel; sel=sel->next) { dump_char('('); if (sel->low == NULL) dumpf("None"); else dump_expr(sel->low); dumpf(","); if (sel->high == NULL) dumpf("None"); else dump_expr(sel->high); } dumpf("],%C,", list[m++]); } dump_char(']'); break; case EXEC_CYCLE: dumpf("%C.append(st_cycle(%L", n, &c->where); if (c->sym != NULL) dumpf(",label=%p", c->sym); break; case EXEC_EXIT: dumpf("%C.append(st_exit(%L", n, &c->where); if (c->sym != NULL) dumpf(",label=%p", c->sym); break; case EXEC_ENTRY: dumpf("%C.append(st_entry(%L,'%s',", n, &c->where, c->sym->name); dump_formal(c->sym); break; case EXEC_WHERE: for(d=c->block; d; d=d->block) list_size++; list = g95_getmem(list_size * sizeof(int)); m = 0; for(d=c->block; d; d=d->block) list[m++] = dump_code(d->next); dumpf("%C.append(st_where(%L, [", n, &c->where); m = 0; for(d=c->block; d; d=d->block) { dump_char('('); if (d->expr == NULL) dumpf("None"); else dump_expr(d->expr); dumpf(",%C),", list[m++]); } dump_char(']'); break; case EXEC_FORALL: node[0] = dump_code(c->block); list = node; list_size = 1; dumpf("%C.append(st_forall(%L, [", n, &c->where); for(f=c->ext.forall_iterator; f; f=f->next) { dump_char('('); dump_expr(f->var); dump_char(','); dump_expr(f->start); dump_char(','); dump_expr(f->end); dump_char(','); dump_expr(f->stride); dump_char(')'); if (f->next != NULL) dump_char(','); } dumpf("], %C", node[0]); if (c->expr != NULL) { dumpf(", mask="); dump_expr(c->expr); } break; case EXEC_CALL: dumpf("%C.append(st_call(%L,", n, &c->where); dump_name(c->sym, c->ext.sub.isym); dump_char(','); dump_actual(c->ext.sub.actual); break; default: g95_internal_error("dump_code(): Bad code"); break; } if (c->here != NULL) dumpf(",here=%d", c->here->value); dumpf("))\n"); for(m=0; m<list_size; m++) if (list[m] != 0) dumpf("del %C\n", list[m]); list_size = 0; if (list != NULL && list != node) g95_free(list); } return n; }
static void dumpf(char *format, ...) { char *p, c, buffer[100]; g95_locus *where; va_list ap; long ptr; int m; va_start(ap, format); for(;;) { c = *format++; if (c == '\0') break; if (c != '%') { dump_char(c); continue; } switch(*format++) { case 'd': sprintf(buffer, "%d", va_arg(ap, int)); p = buffer; while(*p != '\0') dump_char(*p++); break; case 's': p = va_arg(ap, char *); while(*p != '\0') dump_char(*p++); break; case 'p': ptr = va_arg(ap, long); dump_char('"'); dump_char(':'); do { dump_char('A' + (ptr & 0x0F)); ptr >>= 4; } while(ptr != 0); dump_char('"'); break; case 'S': dump_char('\''); p = va_arg(ap, char *); if (p != NULL) while(*p) { c = *p++; switch(c) { case '\'': case '\\': dump_char('\\'); /* Fall through */ default: dump_char(c); break; } } dump_char('\''); break; case 'L': where = va_arg(ap, g95_locus *); if (where == NULL) p = "None"; else { sprintf(buffer, "loc(%d,%d)", where->lb->linenum, where->column); p = buffer; } while(*p != '\0') dump_char(*p++); break; case 'C': /* Statement lists. Zero is the null list. */ m = va_arg(ap, int); if (m == 0) { dump_char('['); dump_char(']'); } else { sprintf(buffer, "st%d", m); p = buffer; while(*p != '\0') dump_char(*p++); } break; case '%': dump_char('%'); break; default: g95_internal_error("dumpf(): Bad %-code"); break; } } va_end(ap); }
static void dump_symtree(g95_symtree *st) { g95_symbol *sym, *result; char *module, *name; sym_flavor flavor; int rank; if (st == NULL) return; dump_symtree(st->left); dump_symtree(st->right); sym = st->n.sym; if (sym->mark) return; sym->mark = 1; flavor = sym->attr.flavor; module = sym->module; if (module == NULL && sym->ns->state == COMP_MODULE) module = sym->ns->proc_name->name; if (g95_current_ns->proc_name == sym && sym->attr.function && sym->result == sym) sym->attr.flavor = FL_VARIABLE; switch(sym->attr.flavor) { case FL_PROGRAM: case FL_BLOCK_DATA: case FL_MODULE: break; case FL_VARIABLE: rank = (sym->as == NULL) ? 0 : sym->as->rank; if (sym->attr.result_var) name = "sym_result1"; else if (sym->attr.function && sym->result == sym) name = "sym_result2"; else name = "sym_variable"; dumpf("%s(%p, %S, %S, %L, %d, %S, %d, %d, %d, %d)\n", name, sym, sym->name, module, &sym->declared_at, sym->attr.use_assoc, g95_typename(&sym->ts), rank, sym->attr.dummy, sym->attr.pointer, sym->attr.in_common); break; case FL_PARAMETER: rank = (sym->as == NULL) ? 0 : sym->as->rank; dumpf("sym_parameter(%p, %S, %S, %L, %S, %d)\n", sym, sym->name, sym->module, &sym->declared_at, g95_typename(&sym->ts), rank); break; case FL_LABEL: dumpf("sym_label(%p, %S, %L)\n", sym, sym->name, &sym->declared_at); break; case FL_PROCEDURE: switch(sym->attr.proc) { case PROC_INTRINSIC: break; case PROC_ST_FUNCTION: dumpf("sym_st_function(%p, %S, %L, %S)\n", sym, sym->name, &sym->declared_at, g95_typename(&sym->ts)); break; case PROC_MODULE: case PROC_INTERNAL: case PROC_DUMMY: case PROC_EXTERNAL: case PROC_UNKNOWN: if (sym == g95_current_ns->proc_name) break; if (!sym->attr.function && !sym->attr.subroutine) dumpf("sym_procedure(%p, %S, %L)\n", sym, sym->name, &sym->declared_at); else if (sym->attr.subroutine) dumpf("sym_subroutine(%p, %S, %S, %L, %d, %d)\n", sym, sym->name, sym->module, &sym->declared_at, sym->attr.use_assoc, sym->attr.proc == PROC_INTERNAL); else { result = sym->result; rank = (result->as == NULL) ? 0 : result->as->rank; dumpf("sym_function(%p, %S, %S, %L, %d, %d, %S, %d, %d)\n", sym, sym->name, sym->module, &sym->declared_at, sym->attr.use_assoc, sym->attr.proc == PROC_INTERNAL, g95_typename(&result->ts), rank, result->attr.pointer, result->attr.pointer); } break; default: g95_internal_error("dump_symtree(): Bad procedure\n"); break; } break; case FL_DERIVED: dumpf("sym_derived(%p, %S, %S, %d, %L)\n", sym, sym->name, sym->module, sym->attr.use_assoc, &sym->declared_at); break; case FL_NAMELIST: dumpf("sym_namelist(%S, %L)\n", sym->name, &sym->declared_at); break; default: g95_internal_error("dump_symtree(): Bad flavor"); break; } sym->attr.flavor = flavor; }
static void dump_variable(g95_expr *e) { g95_ref *ref; int i; dumpf("var(%L,%p,[", &e->where, e->symbol); for(ref=e->ref; ref; ref=ref->next) { switch(ref->type) { case REF_ARRAY: switch(ref->u.ar.type) { case AR_FULL: dumpf("ar_full()"); break; case AR_ELEMENT: dumpf("ar_element(["); for(i=0; i<ref->u.ar.dimen; i++) { dump_expr(ref->u.ar.start[i]); if (i < ref->u.ar.dimen-1) dump_char(','); } dumpf("])"); break; case AR_SECTION: dumpf("ar_section(["); for(i=0; i<ref->u.ar.dimen; i++) { switch(ref->u.ar.dimen_type[i]) { case DIMEN_ELEMENT: case DIMEN_VECTOR: dump_expr(ref->u.ar.start[i]); break; case DIMEN_RANGE: dump_char('('); dump_expr(ref->u.ar.start[i]); dump_char(','); dump_expr(ref->u.ar.end[i]); dump_char(','); dump_expr(ref->u.ar.stride[i]); dump_char(')'); break; default: g95_internal_error("dump_variable(): Bad dimen"); } if (i < ref->u.ar.dimen-1) dump_char(','); } dumpf("])"); break; default: g95_internal_error("dump_variable(): Bad array ref"); } break; case REF_COARRAY: dumpf("coarray(["); for(i=0; i<ref->u.car.dimen; i++) { dump_expr(ref->u.car.element[i]); dump_char(','); } dumpf("])"); break; case REF_COMPONENT: dumpf("component(%S)", ref->u.c.name); break; case REF_SUBSTRING: dumpf("substring("); dump_expr(ref->u.ss.start); dump_char(','); dump_expr(ref->u.ss.end); dump_char(')'); break; default: g95_internal_error("dump_variable(): Bad ref"); } if (ref->next != NULL) dump_char(','); } dump_char(']'); dump_char(')'); }
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'); }
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(')'); }
static void dump_expr(g95_expr *e) { if (e == NULL) { dumpf("None"); return; } switch(e->type) { case EXPR_NULL: dumpf("null(%L,%S,%d)", &e->where, g95_typename(&e->ts), e->rank); break; case EXPR_OP: dump_intrinsic(e); break; case EXPR_CONSTANT: dump_constant(e); break; case EXPR_VARIABLE: dump_variable(e); break; case EXPR_FUNCTION: if (e->value.function.isym != NULL && e->value.function.isym->id == G95_ISYM_CONVERSION) dump_expr(e->value.function.actual->u.expr); else { dumpf("fcall(%L,", &e->where); dump_name(e->symbol, e->value.function.isym); dumpf(",%S,%d,", g95_typename(&e->ts), e->rank); dump_actual(e->value.function.actual); dump_char(')'); } break; case EXPR_PROCEDURE: dumpf("procedure(%L,", &e->where); dump_name(e->symbol, NULL); dump_char(')'); break; case EXPR_STRUCTURE: dump_cons("scons", e); break; case EXPR_ARRAY: dump_cons("acons", e); break; case EXPR_SUBSTRING: dumpf("substring_exp(%L,", &e->where); dump_constant(e); dump_char(','); dump_expr(e->ref->u.ss.start); dump_char(','); dump_expr(e->ref->u.ss.end); dump_char(')'); break; default: g95_internal_error("dump_expr(): Bad expression"); } }
static void forall_body(g95_forall_iterator *m, int msk, g95_code *c) { g95_ref *re, *alloc_ref; g95_expr *e, *mask_expr; g95_forall_iterator *p; g95_symbol *v; g95_code *r; int k, rank; if (!msk) mask_expr = NULL; else { mask_expr = g95_build_funcall(NULL, NULL); mask_expr->value.function.isym = &forall_get; mask_expr->value.function.name = PREFIX "forall_get"; mask_expr->ts.type = BT_INTEGER; mask_expr->ts.kind = g95_default_integer_kind(); } switch(c->type) { case EXEC_FORALL: g95_expand_forall(c); r = build_loops(m, mask_expr, c); insert_post(r); return; case EXEC_WHERE: g95_expand_where(&c); r = build_loops(m, mask_expr, c); insert_post(c); return; case EXEC_ASSIGN: case EXEC_POINTER_ASSIGN: break; default: g95_internal_error("g95_expand_forall(): Bad code node"); } if (!find_mask_symbol(c->expr2, c->expr->symbol)) { r = build_loops(m, mask_expr, c); insert_post(r); } else { rank = 0; for(p=m; p; p=p->next) rank++; v = g95_get_temporary(&c->expr->ts, rank); r = g95_get_code(); r->type = EXEC_ALLOCATE; r->where = c->expr->where; r->ext.alloc_list = g95_get_alloc(); r->ext.alloc_list->expr = e = g95_get_expr(); e->type = EXPR_VARIABLE; e->where = current_node->where; e->ts = v->ts; e->symbol = v; e->ref = alloc_ref = g95_get_ref(); e->where = current_node->where; alloc_ref->type = REF_ARRAY; alloc_ref->u.ar.type = AR_SECTION; p = m; for(k=0; k<rank; k++) { forall_temp_array(&alloc_ref->u.ar, k, p); p = p->next; } alloc_ref->u.ar.dimen = rank; insert_post(r); e = c->expr; c->expr = forall_temp_expr(v, m); r = build_loops(m, g95_copy_expr(mask_expr), c); insert_post(r); /* Copy temp back */ r = g95_get_code(); r->type = EXEC_ASSIGN; r->where = current_node->where; r->expr = e; r->expr2 = forall_temp_expr(v, m); r = build_loops(m, g95_copy_expr(mask_expr), r); insert_post(r); r = g95_get_code(); r->type = EXEC_DEALLOCATE; r->where = c->where; r->ext.alloc_list = g95_get_alloc(); r->ext.alloc_list->expr = e = g95_get_expr(); e->type = EXPR_VARIABLE; e->where = current_node->where; e->ts = v->ts; e->symbol = v; e->ref = re = g95_get_ref(); e->rank = rank; e->where = c->where; re->type = REF_ARRAY; re->u.ar.type = AR_FULL; insert_post(r); } }