static void add_path(const char *path) { g95_directorylist *dir, **list; const char *p; list = &g95_option.include_dirs; p = path; while (*p == ' ' || *p == '\t') /* someone might do 'g95 "-I include"' */ if (*p++ == '\0') return; dir = *list; if (!dir) { dir = *list = g95_getmem(sizeof(g95_directorylist)); } else { while(dir->next) dir = dir->next; dir->next = g95_getmem(sizeof(g95_directorylist)); dir = dir->next; } dir->next = NULL; dir->path = g95_getmem(strlen(p)+2); strcpy(dir->path, p); strcat(dir->path, "/"); /* make '/' last character */ }
char *g95_get_string(char *format, ...) { char temp_name[50]; string_node *m; va_list a; int s; va_start(a, format); vsprintf(temp_name, format, a); va_end(a); s = hash(temp_name); /* Search */ for(m=string_head[s]; m; m=m->next) if (strcmp(m->string, temp_name) == 0) return m->string; /* Add */ m = g95_getmem(sizeof(string_node) + strlen(temp_name)); strcpy(m->string, temp_name); m->next = string_head[s]; string_head[s] = m; return m->string; }
g95_code *g95_get_code(void) { g95_code *h; h = g95_getmem(sizeof(g95_code)); h->where = g95_current_locus; return h; }
static void module_path(const char *option) { if (g95_option.module_dir != NULL) g95_fatal_error("Only one -fmod= option allowed\n"); if (option[0] == '\0') g95_fatal_error("Directory required after -fmod=\n"); g95_option.module_dir = (char *) g95_getmem(strlen(option)+2); strcpy(g95_option.module_dir, option); strcat(g95_option.module_dir, "/"); }
g95_annot *g95_annotate(int type, g95_locus *where) { g95_annot *a; a = g95_getmem(sizeof(g95_annot)); a->type = type; a->where = *where; a->next = g95_current_ns->annotation; g95_current_ns->annotation = a; return a; }
static void set_error_list(const char *p) { g95_warning_list *n; do { if (*p < '0' || *p > '9') break; n = g95_getmem(sizeof(g95_warning_list)); n->warning = atoi(p); n->next = g95_option.error_list; g95_option.error_list = n; while(*p >= '0' && *p <= '9') p++; } while(*p++ == ','); }
static try check_format(void) { char *error, *posint_required = "Positive width required", *period_required = "Period required", *nonneg_required = "Nonnegative width required", *unexpected_element = "Unexpected element", *unexpected_end = "Unexpected end of format string"; format_token l, c; int m; try r; use_last_char = 0; saved_token = FMT_NONE; m = 0; r = SUCCESS; l = format_lex(); if (l != FMT_LPAREN) { error = "Missing leading left parenthesis"; goto syntax; } /* In this state, the next thing has to be a format item */ format_item: l = format_lex(); switch(l) { case FMT_POSINT: l = format_lex(); if (l == FMT_LPAREN) { m++; goto format_item; } if (l == FMT_SLASH) goto optional_comma; goto data_desc; case FMT_ZERO: l = format_lex(); if (l != FMT_P) { error = "Zero repeat count not allowed"; goto syntax; } goto p_descriptor; case FMT_LPAREN: m++; goto format_item; case FMT_RPAREN: goto rparen; case FMT_SIGNED_INT: /* Signed integer can only precede a P format */ l = format_lex(); if (l != FMT_P) { error = "Expected P edit descriptor"; goto syntax; } goto data_desc; case FMT_P: /* P and X require a prior number */ error = "P descriptor requires leading scale factor"; goto syntax; case FMT_X: error = "X descriptor requires leading space count"; goto syntax; case FMT_SIGN: case FMT_BLANK: case FMT_CHAR: goto between_desc; case FMT_COLON: case FMT_SLASH: goto optional_comma; case FMT_DOLLAR: l = format_lex(); if (l != FMT_RPAREN || m > 0) { error = "$ must the last specifier"; goto syntax; } goto finished; case FMT_POS: case FMT_IBOZ: case FMT_F: case FMT_E: case FMT_EXT: case FMT_G: case FMT_L: case FMT_A: case FMT_D: goto data_desc; case FMT_H: repeat = 1; goto handle_hollerith; case FMT_END: error = unexpected_end; goto syntax; default: error = unexpected_element; goto syntax; } /* In this state, t must currently be a data descriptor. Deal with * things that can/must follow the descriptor */ data_desc: switch(l) { case FMT_SIGN: case FMT_BLANK: case FMT_X: break; case FMT_P: p_descriptor: if (g95_option.fmode != 0) { l = format_lex(); if (l == FMT_POSINT) { error = "Repeat count cannot follow P descriptor"; goto syntax; } saved_token = l; } goto optional_comma; case FMT_POS: case FMT_L: l = format_lex(); if (l == FMT_POSINT) break; error = posint_required; goto syntax; case FMT_A: l = format_lex(); if (l != FMT_POSINT) saved_token = l; break; case FMT_D: case FMT_E: case FMT_G: case FMT_EXT: c = format_lex(); if (c != FMT_POSINT) { error = posint_required; goto syntax; } c = format_lex(); if (c != FMT_PERIOD) { error = period_required; goto syntax; } c = format_lex(); if (c != FMT_ZERO && c != FMT_POSINT) { error = nonneg_required; goto syntax; } if (l == FMT_D) break; /* Look for optional exponent */ c = format_lex(); if (c != FMT_E) { saved_token = c; } else { c = format_lex(); if (c != FMT_POSINT) { error = "Positive exponent width required"; goto syntax; } } break; case FMT_F: l = format_lex(); if (l != FMT_ZERO && l != FMT_POSINT) { error = nonneg_required; goto syntax; } l = format_lex(); if (l != FMT_PERIOD) { error = period_required; goto syntax; } l = format_lex(); if (l != FMT_ZERO && l != FMT_POSINT) { error = nonneg_required; goto syntax; } break; case FMT_H: handle_hollerith: if (g95_option.fmode != 0) { error = "The H format specifier is a deleted language feature"; goto syntax; } while(repeat>0) { if (next_char(0) == '\0') { error = unexpected_end; goto syntax; } repeat--; } break; case FMT_IBOZ: l = format_lex(); if (l != FMT_ZERO && l != FMT_POSINT) { error = nonneg_required; goto syntax; } l = format_lex(); if (l != FMT_PERIOD) { saved_token = l; } else { l = format_lex(); if (l != FMT_ZERO && l != FMT_POSINT) { error = nonneg_required; goto syntax; } } break; default: error = unexpected_element; goto syntax; } /* Between a descriptor and what comes next */ between_desc: l = format_lex(); switch(l) { case FMT_COMMA: goto format_item; case FMT_RPAREN: rparen: m--; if (m < 0) goto finished; goto between_desc; case FMT_COLON: case FMT_SLASH: goto optional_comma; case FMT_END: error = unexpected_end; goto syntax; default: error = "Missing comma"; goto syntax; } /* Optional comma is a weird between state where we've just finished * reading a colon, slash or P descriptor. */ optional_comma: l = format_lex(); switch(l) { case FMT_COMMA: break; case FMT_RPAREN: m--; if (m < 0) goto finished; goto between_desc; default: /* Assume that we have another format item */ saved_token = l; break; } goto format_item; /* Something went wrong. If the format we're checking is a string, * generate a warning, since the program is correct. If the format is * in a FORMAT statement, this messes up parsing, which is an error. */ syntax: if (mode != MODE_STRING) g95_error("%s in format string at %L", error, &where); else g95_warning(100, "%s in format string at %L", error, &where); r = FAILURE; finished: return r; } /* g95_match_format()-- Match a FORMAT statement. This amounts to * actually parsing the format descriptors in order to correctly * locate the end of the format string. */ match g95_match_format(void) { g95_locus sta; g95_expr *g; if (g95_statement_label == NULL) { g95_error("FORMAT statement at %C does not have a statement label"); return MATCH_ERROR; } g95_gobble_whitespace(); mode = MODE_FORMAT; format_length = 0; sta = where = new_where = g95_current_locus; if (check_format() == FAILURE) return MATCH_ERROR; if (g95_match_eos() != MATCH_YES) { g95_syntax_error(ST_FORMAT); return MATCH_ERROR; } /* The label doesn't get created until after the statement is done * being matched, so we have to leave the string for later. */ g95_current_locus = sta; /* Back to the beginning */ g = g95_get_expr(); g->type = EXPR_CONSTANT; g->ts.type = BT_CHARACTER; g->ts.kind = g95_default_character_kind(); g->where = sta; g->value.character.string = format_string = g95_getmem(format_length+1); g->value.character.length = format_length; g95_statement_label->format = g; mode = MODE_COPY; check_format(); /* Guaranteed to succeed */ g95_match_eos(); /* Guaranteed to succeed */ new_st.type = EXEC_NOP; return MATCH_YES; }
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; }