Пример #1
0
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;
}
Пример #2
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];
	}
}
Пример #3
0
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);
}
Пример #5
0
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;
}
Пример #6
0
// --------------------------------------------------------------------------
// 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;
}
Пример #7
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;
}
Пример #8
0
Файл: format.c Проект: Lao16/gcc
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 ();
}
Пример #10
0
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;
    }
}
Пример #11
0
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);
}
Пример #12
0
/* 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);
  }
}
Пример #13
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);
}
Пример #14
0
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;
}
Пример #15
0
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;
}
Пример #16
0
Файл: open.c Проект: kraj/gcc
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);
}
Пример #17
0
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;
}
Пример #18
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 ();
}
Пример #20
0
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);
  }
}
Пример #21
0
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);
    }
}
Пример #22
0
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 ();
}
Пример #23
0
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);
}
Пример #24
0
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;
    }
}
Пример #25
0
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;
}
Пример #26
0
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);

}
Пример #27
0
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);

}
Пример #28
0
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) '?';
}
Пример #29
0
Файл: open.c Проект: delkon/gcc
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 ();
}
Пример #30
-8
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;
}