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;
}
