int convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length) { char *endptr = NULL; switch (length) { case 4: *((GFC_REAL_4*) dest) = #if defined(HAVE_STRTOF) gfc_strtof (buffer, &endptr); #else (GFC_REAL_4) gfc_strtod (buffer, &endptr); #endif break; case 8: *((GFC_REAL_8*) dest) = gfc_strtod (buffer, &endptr); break; #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD) case 10: *((GFC_REAL_10*) dest) = gfc_strtold (buffer, &endptr); break; #endif #if defined(HAVE_GFC_REAL_16) # if defined(GFC_REAL_16_IS_FLOAT128) case 16: *((GFC_REAL_16*) dest) = __qmath_(strtoflt128) (buffer, &endptr); break; # elif defined(HAVE_STRTOLD) case 16: *((GFC_REAL_16*) dest) = gfc_strtold (buffer, &endptr); break; # endif #endif default: internal_error (&dtp->common, "Unsupported real kind during IO"); } if (buffer == endptr) { generate_error (&dtp->common, LIBERROR_READ_VALUE, "Error during floating point read"); next_record (dtp, 1); return 1; } return 0; }
void FnCall::renderasm(ASMhandle& context, ExprResult** dest /*=NULL*/){ try{ Function* fncalled = context.find_function_definition(name); } catch(const ErrorgenT& error_in){ generate_error("No function with name \""+string(name)+"\" defined"); } vector<ExprResult**> params_results; if(arguments!=NULL){ // Calculate the values of the parameters that you need to pass vector<BaseExpression*>::iterator it; for(it=arguments->begin(); it!=arguments->end(); ++it){ ExprResult** param_dest = new ExprResult*(NULL); (*it)->renderasm(context, param_dest); params_results.push_back(param_dest); } // Load register parameters for(int i=0; i<4; i++){ if((*params_results[i])->get_result_type()==RESULT_ptr){ ExprResult* to_cast = *params_results[i]; Pointer* tmp = static_cast<Pointer*>(to_cast); tmp->load_memory_location(string("$a" + std::to_string(i)).c_str()); } else (*params_results[i])->load(string("$a" + std::to_string(i)).c_str()); } // Load stack parameters if(params_results.size()>4) context.push_subroutine_stack_params(params_results); } // Call the function assembler.push_back(ss<<pad<<"la"<<"$t0, "<<name<<endl); assembler.push_back(ss<<pad<<"jalr"<<"$t0"<<endl); assembler.push_back(ss<<pad<<"nop"<<endl); // Load the return value in the destination if(dest!=NULL){ if(*dest==NULL) *dest = new Temporary(context.allocate_var()); // Not null when called by Variables (*dest)->store("$v0"); } // Deallocate memory for(int i=0; i<params_results.size(); i++){ if( (*params_results[i])->get_result_type() == RESULT_tmp ){ delete (*params_results[i]); } delete params_results[i]; } }
static void already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags) { if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0) { edit_modes (opp, u, flags); return; } /* If the file is connected to something else, close it and open a new unit. */ if (!compare_file_filename (u, opp->file, opp->file_len)) { #if !HAVE_UNLINK_OPEN_FILE char *path = NULL; if (u->file && u->flags.status == STATUS_SCRATCH) { path = (char *) gfc_alloca (u->file_len + 1); unpack_filename (path, u->file, u->file_len); } #endif if (sclose (u->s) == FAILURE) { unlock_unit (u); generate_error (&opp->common, LIBERROR_OS, "Error closing file in OPEN statement"); return; } u->s = NULL; if (u->file) free_mem (u->file); u->file = NULL; u->file_len = 0; #if !HAVE_UNLINK_OPEN_FILE if (path != NULL) unlink (path); #endif u = new_unit (opp, u, flags); if (u != NULL) unlock_unit (u); return; } edit_modes (opp, u, flags); }
static void formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u) { gfc_offset base; char p[READ_CHUNK]; ssize_t n; base = stell (u->s) - 1; do { n = (base < READ_CHUNK) ? base : READ_CHUNK; base -= n; if (sseek (u->s, base, SEEK_SET) < 0) goto io_error; if (sread (u->s, p, n) != n) goto io_error; /* We have moved backwards from the current position, it should not be possible to get a short read. Because it is not clear what to do about such thing, we ignore the possibility. */ /* There is no memrchr() in the C library, so we have to do it ourselves. */ while (n > 0) { n--; if (p[n] == '\n') { base += n + 1; goto done; } } } while (base != 0); /* base is the new pointer. Seek to it exactly. */ done: if (sseek (u->s, base, SEEK_SET) < 0) goto io_error; u->last_record--; u->endfile = NO_ENDFILE; return; io_error: generate_error (&fpp->common, LIBERROR_OS, NULL); }
int find_option (st_parameter_common *cmp, const char *s1, gfc_charlen_type s1_len, const st_option * opts, const char *error_message) { /* Strip trailing blanks from the Fortran string. */ size_t len = (size_t) fstrlen (s1, s1_len); for (; opts->name; opts++) if (len == strlen(opts->name) && strncasecmp (s1, opts->name, len) == 0) return opts->value; generate_error (cmp, LIBERROR_BAD_OPTION, error_message); return -1; }
// -------------------------------------------------------------------------- // METHODS FOR GENERAL PURPOSES // -------------------------------------------------------------------------- int new_block_struct (int const bs, block_t* block) { int i; block->block_size = bs; block->x = 0; block->y = 0; block->data = calloc (bs, sizeof(double*)); if (block->data == NULL) { generate_error ("Unable to allocate block structure..."); return 1; } for (i=0; i<bs; ++i) { block->data[i] = calloc (bs, sizeof(double)); if (block->data[i] == NULL) { generate_error ("Unable to allocate block structure..."); return 1; } } return 0; }
int convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length) { errno = 0; switch (length) { case 4: *((GFC_REAL_4*) dest) = #if defined(HAVE_STRTOF) strtof (buffer, NULL); #else (GFC_REAL_4) strtod (buffer, NULL); #endif break; case 8: *((GFC_REAL_8*) dest) = strtod (buffer, NULL); break; #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD) case 10: *((GFC_REAL_10*) dest) = strtold (buffer, NULL); break; #endif #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD) case 16: *((GFC_REAL_16*) dest) = strtold (buffer, NULL); break; #endif default: internal_error (&dtp->common, "Unsupported real kind during IO"); } if (errno == EINVAL) { generate_error (&dtp->common, LIBERROR_READ_VALUE, "Error during floating point read"); next_record (dtp, 1); return 1; } return 0; }
void format_error (st_parameter_dt *dtp, const fnode *f, const char *message) { int width, i, j, offset; #define BUFLEN 300 char *p, buffer[BUFLEN]; format_data *fmt = dtp->u.p.fmt; if (f != NULL) fmt->format_string = f->source; if (message == unexpected_element) snprintf (buffer, BUFLEN, message, fmt->error_element); else snprintf (buffer, BUFLEN, "%s\n", message); j = fmt->format_string - dtp->format; offset = (j > 60) ? j - 40 : 0; j -= offset; width = dtp->format_len - offset; if (width > 80) width = 80; /* Show the format */ p = strchr (buffer, '\0'); memcpy (p, dtp->format + offset, width); p += width; *p++ = '\n'; /* Show where the problem is */ for (i = 1; i < j; i++) *p++ = ' '; *p++ = '^'; *p = '\0'; generate_error (&dtp->common, LIBERROR_FORMAT, buffer); }
void st_endfile (st_parameter_filepos *fpp) { gfc_unit *u; library_start (&fpp->common); u = find_unit (fpp->common.unit); if (u != NULL) { if (u->flags.access == ACCESS_DIRECT) { generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT, "Cannot perform ENDFILE on a file opened" " for DIRECT access"); goto done; } /* If there are previously written bytes from a write with ADVANCE="no", add a record marker before performing the ENDFILE. */ if (u->previous_nonadvancing_write) finish_last_advance_record (u); u->previous_nonadvancing_write = 0; if (u->current_record) { st_parameter_dt dtp; dtp.common = fpp->common; memset (&dtp.u.p, 0, sizeof (dtp.u.p)); dtp.u.p.current_unit = u; next_record (&dtp, 1); } unit_truncate (u, stell (u->s), &fpp->common); u->endfile = AFTER_ENDFILE; if (0 == stell (u->s)) u->flags.position = POSITION_REWIND; done: unlock_unit (u); } library_end (); }
void read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length) { char *p; int w; w = f->u.w; p = read_block_form (dtp, &w); if (p == NULL) return; while (*p == ' ') { if (--w == 0) goto bad; p++; } if (*p == '.') { if (--w == 0) goto bad; p++; } switch (*p) { case 't': case 'T': set_integer (dest, (GFC_INTEGER_LARGEST) 1, length); break; case 'f': case 'F': set_integer (dest, (GFC_INTEGER_LARGEST) 0, length); break; default: bad: generate_error (&dtp->common, LIBERROR_READ_VALUE, "Bad value on logical read"); next_record (dtp, 1); break; } }
static void namelist_write_newline (st_parameter_dt *dtp) { if (!is_internal_unit (dtp)) { #ifdef HAVE_CRLF write_character (dtp, "\r\n", 1, 2); #else write_character (dtp, "\n", 1, 1); #endif return; } if (is_array_io (dtp)) { gfc_offset record; int finished, length; length = (int) dtp->u.p.current_unit->bytes_left; /* Now that the current record has been padded out, determine where the next record in the array is. */ record = next_array_record (dtp, dtp->u.p.current_unit->ls, &finished); if (finished) dtp->u.p.current_unit->endfile = AT_ENDFILE; else { /* Now seek to this record */ record = record * dtp->u.p.current_unit->recl; if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) { generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); return; } dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; } } else write_character (dtp, " ", 1, 1); }
/* unlike PCRE, partial matching won't return the actual substrings/matches */ static int Gregex_dfa_exec (lua_State *L) { TArgExec argE; TGrgx *ud; gboolean res; checkarg_dfa_exec (L, &argE, &ud); gerror_free (ud); res = g_regex_match_all_full (ud->pr, argE.text, (int)argE.textlen, argE.startoffset, (GRegexMatchFlags)argE.eflags, &ud->match_info, &ud->error); if (ALG_ISMATCH (res)) { int i, start_pos, end_pos; int max = g_match_info_get_match_count (ud->match_info); g_match_info_fetch_pos (ud->match_info, 0, &start_pos, NULL); lua_pushinteger (L, start_pos + 1); /* 1-st return value */ lua_newtable (L); /* 2-nd return value */ for (i=0; i<max; i++) { g_match_info_fetch_pos (ud->match_info, i, NULL, &end_pos); /* I don't know why these offsets aren't incremented by 1 to match Lua indexing? */ lua_pushinteger (L, end_pos); lua_rawseti (L, -2, i+1); } lua_pushinteger (L, max); /* 3-rd return value */ minfo_free (ud); return 3; } else if (g_match_info_is_partial_match(ud->match_info)) { lua_pushboolean(L,1); minfo_free (ud); return 1; } else { minfo_free (ud); if (ALG_NOMATCH (res)) return lua_pushnil (L), 1; else return generate_error (L, ud, 0); } }
void format_error (fnode * f, const char *message) { int width, i, j, offset; char *p, buffer[300]; if (f != NULL) format_string = f->source; free_fnodes (); st_sprintf (buffer, "%s\n", message); j = format_string - ioparm.format; offset = (j > 60) ? j - 40 : 0; j -= offset; width = ioparm.format_len - offset; if (width > 80) width = 80; /* Show the format */ p = strchr (buffer, '\0'); memcpy (p, ioparm.format + offset, width); p += width; *p++ = '\n'; /* Show where the problem is */ for (i = 1; i < j; i++) *p++ = ' '; *p++ = '^'; *p = '\0'; generate_error (ERROR_FORMAT, buffer); }
static int compile_regex (lua_State *L, const TArgComp *argC, TPosix **pud) { int res; TPosix *ud; ud = (TPosix *)lua_newuserdata (L, sizeof (TPosix)); memset (ud, 0, sizeof (TPosix)); /* initialize all members to 0 */ res = tre_regncomp (&ud->r, argC->pattern, argC->patlen, argC->cflags); if (res != 0) return generate_error (L, ud, res); if (argC->cflags & REG_NOSUB) ud->r.re_nsub = 0; ud->match = (regmatch_t *) Lmalloc (L, (ALG_NSUB(ud) + 1) * sizeof (regmatch_t)); lua_pushvalue (L, LUA_ENVIRONINDEX); lua_setmetatable (L, -2); if (pud) *pud = ud; return 1; }
static int compile_regex (lua_State *L, const TArgComp *argC, TOnig **pud) { TOnig *ud; int r; ud = (TOnig*)lua_newuserdata (L, sizeof (TOnig)); memset (ud, 0, sizeof (TOnig)); /* initialize all members to 0 */ lua_pushvalue (L, LUA_ENVIRONINDEX); lua_setmetatable (L, -2); r = onig_new(&ud->reg, (CUC)argC->pattern, (CUC)argC->pattern + argC->patlen, argC->cflags, (OnigEncoding)argC->locale, (OnigSyntaxType*)argC->syntax, &ud->einfo); if (r != ONIG_NORMAL) return generate_error(L, ud, r); if ((ud->region = onig_region_new()) == NULL) return luaL_error(L, "`onig_region_new' failed"); if (pud) *pud = ud; return 1; }
static void already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags) { if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0) { edit_modes (opp, u, flags); return; } /* If the file is connected to something else, close it and open a new unit. */ if (!compare_file_filename (u, opp->file, opp->file_len)) { if (sclose (u->s) == -1) { unlock_unit (u); generate_error (&opp->common, LIBERROR_OS, "Error closing file in OPEN statement"); return; } u->s = NULL; #if !HAVE_UNLINK_OPEN_FILE if (u->filename && u->flags.status == STATUS_SCRATCH) remove (u->filename); #endif free (u->filename); u->filename = NULL; u = new_unit (opp, u, flags); if (u != NULL) unlock_unit (u); return; } edit_modes (opp, u, flags); }
int trim_list (list_t* list, unsigned int const max_blocks) { group_node_t* tmp = *list; // validate input list if (tmp == NULL) { generate_error ("Invalid reference list for trimming list..."); return 1; } // go through all groups if (max_blocks > 0) { while (tmp->next != NULL) { if (trim_group(&tmp->group, max_blocks) != 0) { return 1; } tmp = tmp->next; } } return 0; }
static int generic_atfind (lua_State *L, int tfind) { int res; TArgExec argE; TPosix *ud; regaparams_t argP; regamatch_t res_match; checkarg_atfind (L, &argE, &ud, &argP); if (argE.startoffset > (int)argE.textlen) return lua_pushnil(L), 1; argE.text += argE.startoffset; res_match.nmatch = ALG_NSUB(ud) + 1; res_match.pmatch = ud->match; /* execute the search */ res = tre_reganexec (&ud->r, argE.text, argE.textlen - argE.startoffset, &res_match, argP, argE.eflags); if (ALG_ISMATCH (res)) { ALG_PUSHOFFSETS (L, ud, argE.startoffset, 0); if (tfind) push_substring_table (L, ud, argE.text); else push_offset_table (L, ud, argE.startoffset); /* set values in the dictionary part of the table */ set_int_field (L, "cost", res_match.cost); set_int_field (L, "num_ins", res_match.num_ins); set_int_field (L, "num_del", res_match.num_del); set_int_field (L, "num_subst", res_match.num_subst); return 3; } else if (ALG_NOMATCH (res)) return lua_pushnil (L), 1; else return generate_error (L, ud, res); }
void st_flush (st_parameter_filepos *fpp) { gfc_unit *u; library_start (&fpp->common); u = find_unit (fpp->common.unit); if (u != NULL) { /* Make sure format buffer is flushed. */ if (u->flags.form == FORM_FORMATTED) fbuf_flush (u, u->mode); sflush (u->s); unlock_unit (u); } else /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */ generate_error (&fpp->common, LIBERROR_BAD_OPTION, "Specified UNIT in FLUSH is not connected"); library_end (); }
static int Lpcre_dfa_exec (lua_State *L) { TArgExec argE; TPcre *ud; int res; int *buf, *ovector, *wspace; checkarg_dfa_exec (L, &argE, &ud); buf = (int*) Lmalloc (L, (argE.ovecsize + argE.wscount) * sizeof(int)); ovector = buf; wspace = buf + argE.ovecsize; res = pcre_dfa_exec (ud->pr, ud->extra, argE.text, (int)argE.textlen, argE.startoffset, argE.eflags, ovector, argE.ovecsize, wspace, argE.wscount); if (ALG_ISMATCH (res) || res == PCRE_ERROR_PARTIAL) { int i; int max = (res>0) ? res : (res==0) ? (int)argE.ovecsize/2 : 1; lua_pushinteger (L, ovector[0] + 1); /* 1-st return value */ lua_newtable (L); /* 2-nd return value */ for (i=0; i<max; i++) { lua_pushinteger (L, ovector[i+i+1]); lua_rawseti (L, -2, i+1); } lua_pushinteger (L, res); /* 3-rd return value */ free (buf); return 3; } else { free (buf); if (res == ALG_NOMATCH) return lua_pushnil (L), 1; else return generate_error (L, ud, res); } }
static void inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) { const char *p; GFC_INTEGER_4 cf = iqp->common.flags; if (iqp->common.unit == GFC_INTERNAL_UNIT || iqp->common.unit == GFC_INTERNAL_UNIT4 || u->internal_unit_kind != 0) generate_error (&iqp->common, LIBERROR_INQUIRE_INTERNAL_UNIT, NULL); if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0) *iqp->exist = (u != NULL) || (iqp->common.unit >= 0); if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0) *iqp->opened = (u != NULL); if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0) *iqp->number = (u != NULL) ? u->unit_number : -1; if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0) *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH); if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0 && u != NULL && u->flags.status != STATUS_SCRATCH) { #if defined(HAVE_TTYNAME_R) || defined(HAVE_TTYNAME) if (u->unit_number == options.stdin_unit || u->unit_number == options.stdout_unit || u->unit_number == options.stderr_unit) { int err = stream_ttyname (u->s, iqp->name, iqp->name_len); if (err == 0) { gfc_charlen_type tmplen = strlen (iqp->name); if (iqp->name_len > tmplen) memset (&iqp->name[tmplen], ' ', iqp->name_len - tmplen); } else /* If ttyname does not work, go with the default. */ cf_strcpy (iqp->name, iqp->name_len, u->filename); } else cf_strcpy (iqp->name, iqp->name_len, u->filename); #elif defined __MINGW32__ if (u->unit_number == options.stdin_unit) fstrcpy (iqp->name, iqp->name_len, "CONIN$", sizeof("CONIN$")); else if (u->unit_number == options.stdout_unit) fstrcpy (iqp->name, iqp->name_len, "CONOUT$", sizeof("CONOUT$")); else if (u->unit_number == options.stderr_unit) fstrcpy (iqp->name, iqp->name_len, "CONERR$", sizeof("CONERR$")); else cf_strcpy (iqp->name, iqp->name_len, u->filename); #else cf_strcpy (iqp->name, iqp->name_len, u->filename); #endif } if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0) { if (u == NULL) p = undefined; else switch (u->flags.access) { case ACCESS_SEQUENTIAL: p = "SEQUENTIAL"; break; case ACCESS_DIRECT: p = "DIRECT"; break; case ACCESS_STREAM: p = "STREAM"; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad access"); } cf_strcpy (iqp->access, iqp->access_len, p); } if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0) { if (u == NULL) p = inquire_sequential (NULL, 0); else switch (u->flags.access) { case ACCESS_DIRECT: case ACCESS_STREAM: p = no; break; case ACCESS_SEQUENTIAL: p = yes; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad access"); } cf_strcpy (iqp->sequential, iqp->sequential_len, p); } if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0) { if (u == NULL) p = inquire_direct (NULL, 0); else switch (u->flags.access) { case ACCESS_SEQUENTIAL: case ACCESS_STREAM: p = no; break; case ACCESS_DIRECT: p = yes; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad access"); } cf_strcpy (iqp->direct, iqp->direct_len, p); } if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0) { if (u == NULL) p = undefined; else switch (u->flags.form) { case FORM_FORMATTED: p = "FORMATTED"; break; case FORM_UNFORMATTED: p = "UNFORMATTED"; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad form"); } cf_strcpy (iqp->form, iqp->form_len, p); } if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0) { if (u == NULL) p = inquire_formatted (NULL, 0); else switch (u->flags.form) { case FORM_FORMATTED: p = yes; break; case FORM_UNFORMATTED: p = no; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad form"); } cf_strcpy (iqp->formatted, iqp->formatted_len, p); } if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0) { if (u == NULL) p = inquire_unformatted (NULL, 0); else switch (u->flags.form) { case FORM_FORMATTED: p = no; break; case FORM_UNFORMATTED: p = yes; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad form"); } cf_strcpy (iqp->unformatted, iqp->unformatted_len, p); } if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0) *iqp->recl_out = (u != NULL) ? u->recl : 0; if ((cf & IOPARM_INQUIRE_HAS_STRM_POS_OUT) != 0) *iqp->strm_pos_out = (u != NULL) ? u->strm_pos : 0; if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0) { /* This only makes sense in the context of DIRECT access. */ if (u != NULL && u->flags.access == ACCESS_DIRECT) *iqp->nextrec = u->last_record + 1; else *iqp->nextrec = 0; } if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0) { if (u == NULL || u->flags.form != FORM_FORMATTED) p = undefined; else switch (u->flags.blank) { case BLANK_NULL: p = "NULL"; break; case BLANK_ZERO: p = "ZERO"; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad blank"); } cf_strcpy (iqp->blank, iqp->blank_len, p); } if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0) { if (u == NULL || u->flags.form != FORM_FORMATTED) p = undefined; else switch (u->flags.pad) { case PAD_YES: p = yes; break; case PAD_NO: p = no; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad pad"); } cf_strcpy (iqp->pad, iqp->pad_len, p); } if (cf & IOPARM_INQUIRE_HAS_FLAGS2) { GFC_INTEGER_4 cf2 = iqp->flags2; if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0) *iqp->pending = 0; if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0) *iqp->id = 0; if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0) { if (u == NULL || u->flags.form != FORM_FORMATTED) p = undefined; else switch (u->flags.encoding) { case ENCODING_DEFAULT: p = "UNKNOWN"; break; case ENCODING_UTF8: p = "UTF-8"; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad encoding"); } cf_strcpy (iqp->encoding, iqp->encoding_len, p); } if ((cf2 & IOPARM_INQUIRE_HAS_DECIMAL) != 0) { if (u == NULL || u->flags.form != FORM_FORMATTED) p = undefined; else switch (u->flags.decimal) { case DECIMAL_POINT: p = "POINT"; break; case DECIMAL_COMMA: p = "COMMA"; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad comma"); } cf_strcpy (iqp->decimal, iqp->decimal_len, p); } if ((cf2 & IOPARM_INQUIRE_HAS_ASYNCHRONOUS) != 0) { if (u == NULL) p = undefined; else switch (u->flags.async) { case ASYNC_YES: p = yes; break; case ASYNC_NO: p = no; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad async"); } cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p); } if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0) { if (u == NULL) p = undefined; else switch (u->flags.sign) { case SIGN_PROCDEFINED: p = "PROCESSOR_DEFINED"; break; case SIGN_SUPPRESS: p = "SUPPRESS"; break; case SIGN_PLUS: p = "PLUS"; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad sign"); } cf_strcpy (iqp->sign, iqp->sign_len, p); } if ((cf2 & IOPARM_INQUIRE_HAS_ROUND) != 0) { if (u == NULL) p = undefined; else switch (u->flags.round) { case ROUND_UP: p = "UP"; break; case ROUND_DOWN: p = "DOWN"; break; case ROUND_ZERO: p = "ZERO"; break; case ROUND_NEAREST: p = "NEAREST"; break; case ROUND_COMPATIBLE: p = "COMPATIBLE"; break; case ROUND_PROCDEFINED: p = "PROCESSOR_DEFINED"; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad round"); } cf_strcpy (iqp->round, iqp->round_len, p); } if ((cf2 & IOPARM_INQUIRE_HAS_SIZE) != 0) { if (u == NULL) *iqp->size = -1; else { sflush (u->s); *iqp->size = ssize (u->s); } } if ((cf2 & IOPARM_INQUIRE_HAS_IQSTREAM) != 0) { if (u == NULL) p = "UNKNOWN"; else switch (u->flags.access) { case ACCESS_SEQUENTIAL: case ACCESS_DIRECT: p = no; break; case ACCESS_STREAM: p = yes; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad pad"); } cf_strcpy (iqp->iqstream, iqp->iqstream_len, p); } } if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0) { if (u == NULL || u->flags.access == ACCESS_DIRECT) p = undefined; else { /* If the position is unspecified, check if we can figure out whether it's at the beginning or end. */ if (u->flags.position == POSITION_UNSPECIFIED) { gfc_offset cur = stell (u->s); if (cur == 0) u->flags.position = POSITION_REWIND; else if (cur != -1 && (ssize (u->s) == cur)) u->flags.position = POSITION_APPEND; } switch (u->flags.position) { case POSITION_REWIND: p = "REWIND"; break; case POSITION_APPEND: p = "APPEND"; break; case POSITION_ASIS: p = "ASIS"; break; default: /* If the position has changed and is not rewind or append, it must be set to a processor-dependent value. */ p = "UNSPECIFIED"; break; } } cf_strcpy (iqp->position, iqp->position_len, p); } if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0) { if (u == NULL) p = undefined; else switch (u->flags.action) { case ACTION_READ: p = "READ"; break; case ACTION_WRITE: p = "WRITE"; break; case ACTION_READWRITE: p = "READWRITE"; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad action"); } cf_strcpy (iqp->action, iqp->action_len, p); } if ((cf & IOPARM_INQUIRE_HAS_READ) != 0) { p = (!u || u->flags.action == ACTION_WRITE) ? no : yes; cf_strcpy (iqp->read, iqp->read_len, p); } if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0) { p = (!u || u->flags.action == ACTION_READ) ? no : yes; cf_strcpy (iqp->write, iqp->write_len, p); } if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0) { p = (!u || u->flags.action != ACTION_READWRITE) ? no : yes; cf_strcpy (iqp->readwrite, iqp->readwrite_len, p); } if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0) { if (u == NULL || u->flags.form != FORM_FORMATTED) p = undefined; else switch (u->flags.delim) { case DELIM_NONE: case DELIM_UNSPECIFIED: p = "NONE"; break; case DELIM_QUOTE: p = "QUOTE"; break; case DELIM_APOSTROPHE: p = "APOSTROPHE"; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad delim"); } cf_strcpy (iqp->delim, iqp->delim_len, p); } if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0) { if (u == NULL || u->flags.form != FORM_FORMATTED) p = undefined; else switch (u->flags.pad) { case PAD_NO: p = no; break; case PAD_YES: p = yes; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad pad"); } cf_strcpy (iqp->pad, iqp->pad_len, p); } if ((cf & IOPARM_INQUIRE_HAS_CONVERT) != 0) { if (u == NULL) p = undefined; else switch (u->flags.convert) { /* big_endian is 0 for little-endian, 1 for big-endian. */ case GFC_CONVERT_NATIVE: p = big_endian ? "BIG_ENDIAN" : "LITTLE_ENDIAN"; break; case GFC_CONVERT_SWAP: p = big_endian ? "LITTLE_ENDIAN" : "BIG_ENDIAN"; break; default: internal_error (&iqp->common, "inquire_via_unit(): Bad convert"); } cf_strcpy (iqp->convert, iqp->convert_len, p); } }
void st_open (void) { unit_flags flags; gfc_unit *u = NULL; library_start (); /* Decode options. */ flags.access = (ioparm.access == NULL) ? ACCESS_UNSPECIFIED : find_option (ioparm.access, ioparm.access_len, access_opt, "Bad ACCESS parameter in OPEN statement"); flags.action = (ioparm.action == NULL) ? ACTION_UNSPECIFIED : find_option (ioparm.action, ioparm.action_len, action_opt, "Bad ACTION parameter in OPEN statement"); flags.blank = (ioparm.blank == NULL) ? BLANK_UNSPECIFIED : find_option (ioparm.blank, ioparm.blank_len, blank_opt, "Bad BLANK parameter in OPEN statement"); flags.delim = (ioparm.delim == NULL) ? DELIM_UNSPECIFIED : find_option (ioparm.delim, ioparm.delim_len, delim_opt, "Bad DELIM parameter in OPEN statement"); flags.pad = (ioparm.pad == NULL) ? PAD_UNSPECIFIED : find_option (ioparm.pad, ioparm.pad_len, pad_opt, "Bad PAD parameter in OPEN statement"); flags.form = (ioparm.form == NULL) ? FORM_UNSPECIFIED : find_option (ioparm.form, ioparm.form_len, form_opt, "Bad FORM parameter in OPEN statement"); flags.position = (ioparm.position == NULL) ? POSITION_UNSPECIFIED : find_option (ioparm.position, ioparm.position_len, position_opt, "Bad POSITION parameter in OPEN statement"); flags.status = (ioparm.status == NULL) ? STATUS_UNSPECIFIED : find_option (ioparm.status, ioparm.status_len, status_opt, "Bad STATUS parameter in OPEN statement"); if (ioparm.unit < 0) generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement"); if (flags.position != POSITION_UNSPECIFIED && flags.access == ACCESS_DIRECT) generate_error (ERROR_BAD_OPTION, "Cannot use POSITION with direct access files"); if (flags.position == POSITION_UNSPECIFIED) flags.position = POSITION_ASIS; if (ioparm.library_return != LIBRARY_OK) { library_end (); return; } u = find_unit (ioparm.unit); if (u == NULL) new_unit (&flags); else already_open (u, &flags); library_end (); }
void new_unit (unit_flags * flags) { gfc_unit *u; stream *s; char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */]; /* Change unspecifieds to defaults. Leave (flags->action == ACTION_UNSPECIFIED) alone so open_external() can set it based on what type of open actually works. */ if (flags->access == ACCESS_UNSPECIFIED) flags->access = ACCESS_SEQUENTIAL; if (flags->form == FORM_UNSPECIFIED) flags->form = (flags->access == ACCESS_SEQUENTIAL) ? FORM_FORMATTED : FORM_UNFORMATTED; if (flags->delim == DELIM_UNSPECIFIED) flags->delim = DELIM_NONE; else { if (flags->form == FORM_UNFORMATTED) { generate_error (ERROR_OPTION_CONFLICT, "DELIM parameter conflicts with UNFORMATTED form in " "OPEN statement"); goto cleanup; } } if (flags->blank == BLANK_UNSPECIFIED) flags->blank = BLANK_NULL; else { if (flags->form == FORM_UNFORMATTED) { generate_error (ERROR_OPTION_CONFLICT, "BLANK parameter conflicts with UNFORMATTED form in " "OPEN statement"); goto cleanup; } } if (flags->pad == PAD_UNSPECIFIED) flags->pad = PAD_YES; else { if (flags->form == FORM_UNFORMATTED) { generate_error (ERROR_OPTION_CONFLICT, "PAD paramter conflicts with UNFORMATTED form in " "OPEN statement"); goto cleanup; } } if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT) { generate_error (ERROR_OPTION_CONFLICT, "ACCESS parameter conflicts with SEQUENTIAL access in " "OPEN statement"); goto cleanup; } else if (flags->position == POSITION_UNSPECIFIED) flags->position = POSITION_ASIS; if (flags->status == STATUS_UNSPECIFIED) flags->status = STATUS_UNKNOWN; /* Checks. */ if (flags->access == ACCESS_DIRECT && ioparm.recl_in == 0) { generate_error (ERROR_MISSING_OPTION, "Missing RECL parameter in OPEN statement"); goto cleanup; } if (ioparm.recl_in != 0 && ioparm.recl_in <= 0) { generate_error (ERROR_BAD_OPTION, "RECL parameter is non-positive in OPEN statement"); goto cleanup; } switch (flags->status) { case STATUS_SCRATCH: if (ioparm.file == NULL) break; generate_error (ERROR_BAD_OPTION, "FILE parameter must not be present in OPEN statement"); return; case STATUS_OLD: case STATUS_NEW: case STATUS_REPLACE: case STATUS_UNKNOWN: if (ioparm.file != NULL) break; ioparm.file = tmpname; ioparm.file_len = sprintf(ioparm.file, "fort.%d", ioparm.unit); break; default: internal_error ("new_unit(): Bad status"); } /* Make sure the file isn't already open someplace else. Do not error if opening file preconnected to stdin, stdout, stderr. */ u = find_file (); if (u != NULL && (options.stdin_unit < 0 || u->unit_number != options.stdin_unit) && (options.stdout_unit < 0 || u->unit_number != options.stdout_unit) && (options.stderr_unit < 0 || u->unit_number != options.stderr_unit)) { generate_error (ERROR_ALREADY_OPEN, NULL); goto cleanup; } /* Open file. */ s = open_external (flags); if (s == NULL) { generate_error (ERROR_OS, NULL); goto cleanup; } if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE) flags->status = STATUS_OLD; /* Create the unit structure. */ u = get_mem (sizeof (gfc_unit) + ioparm.file_len); memset (u, '\0', sizeof (gfc_unit) + ioparm.file_len); u->unit_number = ioparm.unit; u->s = s; u->flags = *flags; if (flags->position == POSITION_APPEND) { if (sseek (u->s, file_length (u->s)) == FAILURE) generate_error (ERROR_OS, NULL); u->endfile = AT_ENDFILE; } /* Unspecified recl ends up with a processor dependent value. */ u->recl = (ioparm.recl_in != 0) ? ioparm.recl_in : g.max_offset; u->last_record = 0; u->current_record = 0; /* If the file is direct access, calculate the maximum record number via a division now instead of letting the multiplication overflow later. */ if (flags->access == ACCESS_DIRECT) u->maxrec = g.max_offset / u->recl; memmove (u->file, ioparm.file, ioparm.file_len); u->file_len = ioparm.file_len; insert_unit (u); /* The file is now connected. Errors after this point leave the file connected. Curiously, the standard requires that the position specifier be ignored for new files so a newly connected file starts out that the initial point. We still need to figure out if the file is at the end or not. */ test_endfile (u); cleanup: /* Free memory associated with a temporary filename. */ if (flags->status == STATUS_SCRATCH) free_mem (ioparm.file); }
static void edit_modes (gfc_unit * u, unit_flags * flags) { /* Complain about attempts to change the unchangeable. */ if (flags->status != STATUS_UNSPECIFIED && u->flags.status != flags->position) generate_error (ERROR_BAD_OPTION, "Cannot change STATUS parameter in OPEN statement"); if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access) generate_error (ERROR_BAD_OPTION, "Cannot change ACCESS parameter in OPEN statement"); if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form) generate_error (ERROR_BAD_OPTION, "Cannot change FORM parameter in OPEN statement"); if (ioparm.recl_in != 0 && ioparm.recl_in != u->recl) generate_error (ERROR_BAD_OPTION, "Cannot change RECL parameter in OPEN statement"); if (flags->action != ACTION_UNSPECIFIED && u->flags.access != flags->access) generate_error (ERROR_BAD_OPTION, "Cannot change ACTION parameter in OPEN statement"); /* Status must be OLD if present. */ if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD) generate_error (ERROR_BAD_OPTION, "OPEN statement must have a STATUS of OLD"); if (u->flags.form == FORM_UNFORMATTED) { if (flags->delim != DELIM_UNSPECIFIED) generate_error (ERROR_OPTION_CONFLICT, "DELIM parameter conflicts with UNFORMATTED form in " "OPEN statement"); if (flags->blank != BLANK_UNSPECIFIED) generate_error (ERROR_OPTION_CONFLICT, "BLANK parameter conflicts with UNFORMATTED form in " "OPEN statement"); if (flags->pad != PAD_UNSPECIFIED) generate_error (ERROR_OPTION_CONFLICT, "PAD paramter conflicts with UNFORMATTED form in " "OPEN statement"); } if (ioparm.library_return == LIBRARY_OK) { /* Change the changeable: */ if (flags->blank != BLANK_UNSPECIFIED) u->flags.blank = flags->blank; if (flags->delim != DELIM_UNSPECIFIED) u->flags.delim = flags->delim; if (flags->pad != PAD_UNSPECIFIED) u->flags.pad = flags->pad; } /* Reposition the file if necessary. */ switch (flags->position) { case POSITION_UNSPECIFIED: case POSITION_ASIS: break; case POSITION_REWIND: if (sseek (u->s, 0) == FAILURE) goto seek_error; u->current_record = 0; u->last_record = 0; test_endfile (u); /* We might be at the end. */ break; case POSITION_APPEND: if (sseek (u->s, file_length (u->s)) == FAILURE) goto seek_error; u->current_record = 0; u->endfile = AT_ENDFILE; /* We are at the end. */ break; seek_error: generate_error (ERROR_OS, NULL); break; } }
void read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length) { int w, seen_dp, exponent; int exponent_sign; const char *p; char *buffer; char *out; int seen_int_digit; /* Seen a digit before the decimal point? */ int seen_dec_digit; /* Seen a digit after the decimal point? */ seen_dp = 0; seen_int_digit = 0; seen_dec_digit = 0; exponent_sign = 1; exponent = 0; w = f->u.w; /* Read in the next block. */ p = read_block_form (dtp, &w); if (p == NULL) return; p = eat_leading_spaces (&w, (char*) p); if (w == 0) goto zero; /* In this buffer we're going to re-format the number cleanly to be parsed by convert_real in the end; this assures we're using strtod from the C library for parsing and thus probably get the best accuracy possible. This process may add a '+0.0' in front of the number as well as change the exponent because of an implicit decimal point or the like. Thus allocating strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the original buffer had should be enough. */ buffer = gfc_alloca (w + 11); out = buffer; /* Optional sign */ if (*p == '-' || *p == '+') { if (*p == '-') *(out++) = '-'; ++p; --w; } p = eat_leading_spaces (&w, (char*) p); if (w == 0) goto zero; /* Process the mantissa string. */ while (w > 0) { switch (*p) { case ',': if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA) goto bad_float; /* Fall through. */ case '.': if (seen_dp) goto bad_float; if (!seen_int_digit) *(out++) = '0'; *(out++) = '.'; seen_dp = 1; break; case ' ': if (dtp->u.p.blank_status == BLANK_ZERO) { *(out++) = '0'; goto found_digit; } else if (dtp->u.p.blank_status == BLANK_NULL) break; else /* TODO: Should we check instead that there are only trailing blanks here, as is done below for exponents? */ goto done; /* Fall through. */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': *(out++) = *p; found_digit: if (!seen_dp) seen_int_digit = 1; else seen_dec_digit = 1; break; case '-': case '+': goto exponent; case 'e': case 'E': case 'd': case 'D': ++p; --w; goto exponent; default: goto bad_float; } ++p; --w; } /* No exponent has been seen, so we use the current scale factor. */ exponent = - dtp->u.p.scale_factor; goto done; /* At this point the start of an exponent has been found. */ exponent: p = eat_leading_spaces (&w, (char*) p); if (*p == '-' || *p == '+') { if (*p == '-') exponent_sign = -1; ++p; --w; } /* At this point a digit string is required. We calculate the value of the exponent in order to take account of the scale factor and the d parameter before explict conversion takes place. */ if (w == 0) goto bad_float; if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) { while (w > 0 && isdigit (*p)) { exponent *= 10; exponent += *p - '0'; ++p; --w; } /* Only allow trailing blanks. */ while (w > 0) { if (*p != ' ') goto bad_float; ++p; --w; } } else /* BZ or BN status is enabled. */ { while (w > 0) { if (*p == ' ') { if (dtp->u.p.blank_status == BLANK_ZERO) exponent *= 10; else assert (dtp->u.p.blank_status == BLANK_NULL); } else if (!isdigit (*p)) goto bad_float; else { exponent *= 10; exponent += *p - '0'; } ++p; --w; } } exponent *= exponent_sign; done: /* Use the precision specified in the format if no decimal point has been seen. */ if (!seen_dp) exponent -= f->u.real.d; /* Output a trailing '0' after decimal point if not yet found. */ if (seen_dp && !seen_dec_digit) *(out++) = '0'; /* Print out the exponent to finish the reformatted number. Maximum 4 digits for the exponent. */ if (exponent != 0) { int dig; *(out++) = 'e'; if (exponent < 0) { *(out++) = '-'; exponent = - exponent; } assert (exponent < 10000); for (dig = 3; dig >= 0; --dig) { out[dig] = (char) ('0' + exponent % 10); exponent /= 10; } out += 4; } *(out++) = '\0'; /* Do the actual conversion. */ convert_real (dtp, dest, buffer, length); return; /* The value read is zero. */ zero: switch (length) { case 4: *((GFC_REAL_4 *) dest) = 0.0; break; case 8: *((GFC_REAL_8 *) dest) = 0.0; break; #ifdef HAVE_GFC_REAL_10 case 10: *((GFC_REAL_10 *) dest) = 0.0; break; #endif #ifdef HAVE_GFC_REAL_16 case 16: *((GFC_REAL_16 *) dest) = 0.0; break; #endif default: internal_error (&dtp->common, "Unsupported real kind during IO"); } return; bad_float: generate_error (&dtp->common, LIBERROR_READ_VALUE, "Bad value during floating point read"); next_record (dtp, 1); return; }
void read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length, int radix) { GFC_UINTEGER_LARGEST value, maxv, maxv_r; GFC_INTEGER_LARGEST v; int w, negative; char c, *p; w = f->u.w; p = read_block_form (dtp, &w); if (p == NULL) return; p = eat_leading_spaces (&w, p); if (w == 0) { set_integer (dest, (GFC_INTEGER_LARGEST) 0, length); return; } maxv = max_value (length, 0); maxv_r = maxv / radix; negative = 0; value = 0; switch (*p) { case '-': negative = 1; /* Fall through */ case '+': p++; if (--w == 0) goto bad; /* Fall through */ default: break; } /* At this point we have a digit-string */ value = 0; for (;;) { c = next_char (dtp, &p, &w); if (c == '\0') break; if (c == ' ') { if (dtp->u.p.blank_status == BLANK_NULL) continue; if (dtp->u.p.blank_status == BLANK_ZERO) c = '0'; } switch (radix) { case 2: if (c < '0' || c > '1') goto bad; break; case 8: if (c < '0' || c > '7') goto bad; break; case 16: switch (c) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': break; case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': c = c - 'a' + '9' + 1; break; case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': c = c - 'A' + '9' + 1; break; default: goto bad; } break; } if (value > maxv_r) goto overflow; c -= '0'; value = radix * value; if (maxv - c < value) goto overflow; value += c; } v = value; if (negative) v = -v; set_integer (dest, v, length); return; bad: generate_error (&dtp->common, LIBERROR_READ_VALUE, "Bad value during integer read"); next_record (dtp, 1); return; overflow: generate_error (&dtp->common, LIBERROR_READ_OVERFLOW, "Value overflowed during integer read"); next_record (dtp, 1); }
void read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length) { GFC_UINTEGER_LARGEST value, maxv, maxv_10; GFC_INTEGER_LARGEST v; int w, negative; char c, *p; w = f->u.w; p = read_block_form (dtp, &w); if (p == NULL) return; p = eat_leading_spaces (&w, p); if (w == 0) { set_integer (dest, (GFC_INTEGER_LARGEST) 0, length); return; } maxv = max_value (length, 1); maxv_10 = maxv / 10; negative = 0; value = 0; switch (*p) { case '-': negative = 1; /* Fall through */ case '+': p++; if (--w == 0) goto bad; /* Fall through */ default: break; } /* At this point we have a digit-string */ value = 0; for (;;) { c = next_char (dtp, &p, &w); if (c == '\0') break; if (c == ' ') { if (dtp->u.p.blank_status == BLANK_NULL) continue; if (dtp->u.p.blank_status == BLANK_ZERO) c = '0'; } if (c < '0' || c > '9') goto bad; if (value > maxv_10 && compile_options.range_check == 1) goto overflow; c -= '0'; value = 10 * value; if (value > maxv - c && compile_options.range_check == 1) goto overflow; value += c; } v = value; if (negative) v = -v; set_integer (dest, v, length); return; bad: generate_error (&dtp->common, LIBERROR_READ_VALUE, "Bad value during integer read"); next_record (dtp, 1); return; overflow: generate_error (&dtp->common, LIBERROR_READ_OVERFLOW, "Value overflowed during integer read"); next_record (dtp, 1); }
static gfc_char4_t read_utf8 (st_parameter_dt *dtp, int *nbytes) { static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 }; static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC }; int i, nb, nread; gfc_char4_t c; char *s; *nbytes = 1; s = read_block_form (dtp, nbytes); if (s == NULL) return 0; /* If this is a short read, just return. */ if (*nbytes == 0) return 0; c = (uchar) s[0]; if (c < 0x80) return c; /* The number of leading 1-bits in the first byte indicates how many bytes follow. */ for (nb = 2; nb < 7; nb++) if ((c & ~masks[nb-1]) == patns[nb-1]) goto found; goto invalid; found: c = (c & masks[nb-1]); nread = nb - 1; s = read_block_form (dtp, &nread); if (s == NULL) return 0; /* Decode the bytes read. */ for (i = 1; i < nb; i++) { gfc_char4_t n = *s++; if ((n & 0xC0) != 0x80) goto invalid; c = ((c << 6) + (n & 0x3F)); } /* Make sure the shortest possible encoding was used. */ if (c <= 0x7F && nb > 1) goto invalid; if (c <= 0x7FF && nb > 2) goto invalid; if (c <= 0xFFFF && nb > 3) goto invalid; if (c <= 0x1FFFFF && nb > 4) goto invalid; if (c <= 0x3FFFFFF && nb > 5) goto invalid; /* Make sure the character is valid. */ if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF)) goto invalid; return c; invalid: generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding"); return (gfc_char4_t) '?'; }
void st_open (st_parameter_open *opp) { unit_flags flags; gfc_unit *u = NULL; GFC_INTEGER_4 cf = opp->common.flags; unit_convert conv; library_start (&opp->common); /* Decode options. */ flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED : find_option (&opp->common, opp->access, opp->access_len, access_opt, "Bad ACCESS parameter in OPEN statement"); flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED : find_option (&opp->common, opp->action, opp->action_len, action_opt, "Bad ACTION parameter in OPEN statement"); flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED : find_option (&opp->common, opp->blank, opp->blank_len, blank_opt, "Bad BLANK parameter in OPEN statement"); flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED : find_option (&opp->common, opp->delim, opp->delim_len, delim_opt, "Bad DELIM parameter in OPEN statement"); flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED : find_option (&opp->common, opp->pad, opp->pad_len, pad_opt, "Bad PAD parameter in OPEN statement"); flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED : find_option (&opp->common, opp->decimal, opp->decimal_len, decimal_opt, "Bad DECIMAL parameter in OPEN statement"); flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED : find_option (&opp->common, opp->encoding, opp->encoding_len, encoding_opt, "Bad ENCODING parameter in OPEN statement"); flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED : find_option (&opp->common, opp->asynchronous, opp->asynchronous_len, async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement"); flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED : find_option (&opp->common, opp->round, opp->round_len, round_opt, "Bad ROUND parameter in OPEN statement"); flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED : find_option (&opp->common, opp->sign, opp->sign_len, sign_opt, "Bad SIGN parameter in OPEN statement"); flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED : find_option (&opp->common, opp->form, opp->form_len, form_opt, "Bad FORM parameter in OPEN statement"); flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED : find_option (&opp->common, opp->position, opp->position_len, position_opt, "Bad POSITION parameter in OPEN statement"); flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED : find_option (&opp->common, opp->status, opp->status_len, status_opt, "Bad STATUS parameter in OPEN statement"); /* First, we check wether the convert flag has been set via environment variable. This overrides the convert tag in the open statement. */ conv = get_unformatted_convert (opp->common.unit); if (conv == GFC_CONVERT_NONE) { /* Nothing has been set by environment variable, check the convert tag. */ if (cf & IOPARM_OPEN_HAS_CONVERT) conv = find_option (&opp->common, opp->convert, opp->convert_len, convert_opt, "Bad CONVERT parameter in OPEN statement"); else conv = compile_options.convert; } /* We use big_endian, which is 0 on little-endian machines and 1 on big-endian machines. */ switch (conv) { case GFC_CONVERT_NATIVE: case GFC_CONVERT_SWAP: break; case GFC_CONVERT_BIG: conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP; break; case GFC_CONVERT_LITTLE: conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE; break; default: internal_error (&opp->common, "Illegal value for CONVERT"); break; } flags.convert = conv; if (flags.position != POSITION_UNSPECIFIED && flags.access == ACCESS_DIRECT) generate_error (&opp->common, LIBERROR_BAD_OPTION, "Cannot use POSITION with direct access files"); if (flags.access == ACCESS_APPEND) { if (flags.position != POSITION_UNSPECIFIED && flags.position != POSITION_APPEND) generate_error (&opp->common, LIBERROR_BAD_OPTION, "Conflicting ACCESS and POSITION flags in" " OPEN statement"); notify_std (&opp->common, GFC_STD_GNU, "Extension: APPEND as a value for ACCESS in OPEN statement"); flags.access = ACCESS_SEQUENTIAL; flags.position = POSITION_APPEND; } if (flags.position == POSITION_UNSPECIFIED) flags.position = POSITION_ASIS; if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK) { if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT)) opp->common.unit = get_unique_unit_number(opp); else if (opp->common.unit < 0) { u = find_unit (opp->common.unit); if (u == NULL) /* Negative unit and no NEWUNIT-created unit found. */ generate_error (&opp->common, LIBERROR_BAD_OPTION, "Bad unit number in OPEN statement"); } if (u == NULL) u = find_or_create_unit (opp->common.unit); if (u->s == NULL) { u = new_unit (opp, u, &flags); if (u != NULL) unlock_unit (u); } else already_open (opp, u, &flags); } if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT) && (opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK) *opp->newunit = opp->common.unit; library_end (); }
int img2array (png_img* img, int const channel, char* const path, char* const name) { FILE* fd; char outfile[40]; int i, j; png_byte* row; png_byte* tmp; // obtain entire output filename if (get_output_filename (outfile, path, name, "txt", 0) != 0) { generate_error ("Unable to process output filename for group..."); return 1; } fd = fopen (outfile, "w"); if (fd == NULL) { generate_error ("Unable to open file for printing group..."); return 1; } // write pixel values to the file for (j=0; j<img->height; ++j) { row = img->data[j]; for (i=0; i<img->width; ++i) { tmp = &(row[i*3]); fprintf (fd, "%d ", tmp[channel]); } fprintf (fd, "\n"); } fclose (fd); return 0; }