Пример #1
0
array<typename array_nd<T, S>::create_new> split(
	const array_nd<T, S>& a, const array<size_t, D>& spoint , size_t dim)
{
	CHECK (dim < a.ndims(), edims());
	CHECK (dim >= 0, edims());

	array<typename array_nd<T, S>::create_new> result(spoint.length() + 1);

	for (size_t j = 0; j < spoint.length(); j++)
		CHECK(spoint[j] <= a.size_nd()[dim], erange());

	for (size_t j = 0; j < spoint.length() + 1; j++) {
		array<index_array, tiny> indx(a.ndims());
		for (size_t i = 0; i < a.ndims(); i++) {
			if(i != dim)
				indx[i] = size_array(
					size_range(0, a.size_nd()[i] - 1));
			else
				indx[i] = size_array(size_range((j == 0 ? 0 : spoint[j - 1]),
					(j == (spoint.length()) ?
						a.size_nd()[i] - 1 : spoint[j] - 1) ));
		}
		result[j] = a(indx);
	}
	return result;
}
Пример #2
0
	void operate(array<T1, S1>& u, array <array <T2, S21>, S22>& p, sep,
					 const array<T3, S3>& a, const size_array& idx = size_array())  // f only used internally!
	{
		if (a.empty()) { u.init(); p.init(); return; }
		size_array first = find(arr(true).cat(diff(a) != 0));
		u = a[first];
		if (idx.empty()) (_, p) = partition++(size_array((0, _, a.length() - 1)), first);  // TODO: remove size_array copy
		else             (_, p) = partition++(idx, first);
	}
Пример #3
0
	void operate(array<T1, S1>& u, array <T2, S2>& p, sep,
					 const array<T3, S3>& a, const size_array& idx = size_array())  // f only used internally!
	{
		if (a.empty()) { u.init(); p.init(); return; }
		if (FIRST) (_, p) = find++(arr(true).cat(diff(a) != 0));  // TODO: check speed of cat()
		else       (_, p) = find++((diff(a) != 0).cat(arr(true)));
		u = a[p];
		if (!idx.empty()) force(p) = idx[p];
	}
Пример #4
0
	void operate(array<T1, S1>& u, array <T2, S2>& p, array <T3, S3>& q, sep,
					 const array<T4, S4>& a, const size_array& idx = size_array())  // idx only used internally!
	{
		if (a.empty()) { u.init(); p.init(); q.init(); return; }
		q = arr(true).cat(diff(a) != 0);
		if (FIRST) (_, p) = find++(q);
		else       (_, p) = find++(cshift(q, -1));
		u = a[p];
		if (!idx.empty()) force(p) = idx[p];
		q[0] = T3();
		q = cumsum(q);
	}
Пример #5
0
size_t
gfc_target_expr_size (gfc_expr *e)
{
  tree type;

  gcc_assert (e != NULL);

  if (e->expr_type == EXPR_ARRAY)
    return size_array (e);

  switch (e->ts.type)
    {
    case BT_INTEGER:
      return size_integer (e->ts.kind);
    case BT_REAL:
      return size_float (e->ts.kind);
    case BT_COMPLEX:
      return size_complex (e->ts.kind);
    case BT_LOGICAL:
      return size_logical (e->ts.kind);
    case BT_CHARACTER:
      if (e->expr_type == EXPR_SUBSTRING && e->ref)
        {
          int start, end;

          gfc_extract_int (e->ref->u.ss.start, &start);
          gfc_extract_int (e->ref->u.ss.end, &end);
          return size_character (MAX(end - start + 1, 0), e->ts.kind);
        }
      else
        return size_character (e->value.character.length, e->ts.kind);
    case BT_HOLLERITH:
      return e->representation.length;
    case BT_DERIVED:
      type = gfc_typenode_for_spec (&e->ts);
      return int_size_in_bytes (type);
    default:
      gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
      return 0;
    }
}
Пример #6
0
/* QUERY -- Query the user for the value of a parameter.  Prompt with the
 *  current value if any.  Keep this up until we can push a reasonable value.
 *  Also, store the new value in the parameter (except for list params, where,
 *  since the values are not kept, all that may change is P_LEOF if seen).
 * Give prompt, or name if none, current value and range if int, real or 
 *   filename.  Accept CR to leave value unchanged, else take the string
 *   entered to be the new value.  Repeat until parameter value is in range.
 * We mean to talk straight to the user here; thus, interact with the real
 *   stdio, not the effective t_stdio, so that redirections do not get in
 *   the way.  In batch mode, a forced query is handled by writing a
 *   message on the terminal of the parent cl (the original stderr), and
 *   leaving some info describing the query in a file in uparm (if there is
 *   no uparm, we abort).  We then loop, waiting for the user to run "service"
 *   in the interactive cl to service the query, leaving the answer in a
 *   another file which we read and then delete.  If we wait a long time and
 *   get no response, we timeout.
 */
void 
query (struct param *pp)
{
	static	char *oormsg =
		"ERROR: Parameter value is out of range; try again";
	register char *ip;
	char	buf[SZ_PROMPTBUF+1];
	struct	operand o;
	int	bastype, batch, arrflag, offset=0, n_ele, max_ele, fd;
	char	*index(), *nlp, *nextstr();
	char	*bkg_query(), *query_status;
	char	*abuf;

	bastype = pp->p_type & OT_BASIC;
	batch = firstask->t_flags & T_BATCH;
	arrflag = pp->p_type & PT_ARRAY;

	if (arrflag) {			/* We may access the array many     */
	    offset = getoffset (pp);	/* times, so save the offset and    */
					/* push it when necessary.	    */
	    poffset (offset);
	    max_ele = size_array (pp) - offset;
	} else
	    max_ele = 1;


	forever {
	    if (batch) {
		/* Query from a background job.
		 */
		query_status = bkg_query (buf, SZ_PROMPTBUF, pp);

	    } else if (pp->p_type & (PT_GCUR|PT_IMCUR)) {
		/* Read a graphics cursor.
		 */
		char	source[33];
		int	cursor;

		/* Determine the source of graphics cursor input, chosen from
		 * either the graphics or image cursor or the terminal.
		 */
		if (pp->p_type & PT_GCUR) {
		    if (c_envfind ("stdgcur", source, 32) <= 0)
			strcpy (source, "stdgraph");
		} else {
		    if (c_envfind ("stdimcur", source, 32) <= 0)
			strcpy (source, "stdimage");
		}

		if (strcmp (source, "stdgraph") == 0)
		    cursor = STDGRAPH;
		else if (strcmp (source, "stdimage") == 0)
		    cursor = STDIMAGE;
		else
		    goto text_query;		/* get value from terminal */

		/* Read a physical graphics cursor.
		 */
		pp->p_flags &= ~P_LEOF;
		if (cursor == STDIMAGE) {
		    /* The following is a kludge used to temporarily implement
		     * the logical image cursor read.  In the future this will
		     * be eliminated, and the c_rcursor call below (cursor
		     * mode) will be used for stdimage as well as for stdgraph.
		     * The present code (IMDRCUR) goes directly to the display
		     * server to get the cursor value, bypassing cursor mode
		     * and the (currently nonexistent) stdimage kernel.
		     */
		    char    str[SZ_LINE+1], keystr[10];
		    int     wcs, key;
		    float   x, y;

		    if (c_imdrcur ("stdimage",
			&x,&y,&wcs,&key,str,SZ_LINE, 1, 1) == EOF) {
			query_status = NULL;

		    } else {
			if (isprint(key) && !isspace(key))
			    sprintf (keystr, "%c", key);
			else
			    sprintf (keystr, "\\%03o", key);
			sprintf (buf, "%.3f %.3f %d %s %s\n",
			    x, y, wcs, keystr, str);
		        query_status = (char *) ((XINT) strlen(buf));
		    }

		} else if (c_rcursor (cursor, buf, SZ_PROMPTBUF) == EOF) {
		    query_status = NULL;
		} else
		    query_status = (char *) ((XINT) strlen(buf));

	    } else if (pp->p_type & PT_UKEY) {
		/* Read a user keystroke command from the terminal.
		 */
		pp->p_flags &= ~P_LEOF;
		if (c_rdukey (buf, SZ_PROMPTBUF) == EOF)
		    query_status = NULL;
		else
		    query_status = (char *) ((XINT) strlen(buf));

	    } else {
text_query:	fd = spf_open (buf, SZ_PROMPTBUF);
		pquery (pp, fdopen(fd,"a"));
		spf_close (fd);

		c_stgputline ((XINT)STDOUT, buf);
		if (c_stggetline ((XINT)STDIN, buf, SZ_PROMPTBUF) > 0)
		    query_status = (char *) ((XINT) strlen(buf));
		else
		    query_status = NULL;
	    }

	    ip = buf;

	    /* Set o to the current value of the parameter.  Beware that some
	     * of the logical branches which follow assume that struct o has
	     * been initialized to the current value of the parameter.
	     */
	    if (pp->p_type & PT_LIST)
		setopundef (&o);
	    else if (arrflag) {
		paramget(pp, FN_VALUE);
		poffset (offset);
		o = popop();
	    } else
		o = pp->p_valo;

	    /* Handle eof, a null-length line (lone carriage return),
	     * and line with more than SZ_LINE chars.  Ignore leading whitespace
	     * if basic type is not string.
	     */
	    if (query_status == NULL) {
		/* Typing eof will use current value (as will a lone
		 * newline) but if param is a list, it is a meaningful
		 * answer.
		 */
		if (pp->p_type & PT_LIST) {
		    closelist (pp);		/* close an existing file */
		    pp->p_flags |= P_LEOF;
		    o = makeop (eofstr, OT_STRING);
		    break;
		}
		goto testval;
	    }

	    /* Ignore leading whitespace if it is not significant for this
	     * datatype.  Do this before testing for empty line, so that a
	     * return such as " \n" is equivalent to "\n".  I.e., do not
	     * penalize the user if they type the space bar by accident before
	     * typing return to accept the default value.
	     */
	    if (bastype != OT_STRING || (pp->p_type & (PT_FILNAM|PT_PSET)))
		while (*ip == ' ' || *ip == '\t')
		    ip++;

	    if (*ip == '\n') {
		/* Blank lines usually just accept the current value
		 * but if the param is a string and is undefined,
		 * it sets the string to a (defined) nullstring.
		 */
		*ip = '\0';
		if (bastype == OT_STRING && opundef (&o))
		    o = makeop (ip, bastype);
		else
		    goto testval;
	    }

	    if ((nlp = index (ip, '\n')) != NULL)
		*nlp = '\0';			/* cancel the newline	*/
	    else
		goto testval;

	    /* Finally, we have handled the pathological cases...
	     */
	    if ((pp->p_type & PT_LIST) &&
		(!strcmp (ip,eofstr) || !strcmp (ip,"eof"))) {

		closelist (pp);
		pp->p_flags |= P_LEOF;
		o = makeop (eofstr, OT_STRING);
		break;

	    } else {
		if (arrflag) {
		    /* In querying for arrays we may set more than one
		     * element of the array in a single query.  However
		     * we must set the first element.  So we will pretend
		     * to be a scalar until that first element is set
		     * and then enter a loop where we may set other
		     * elements.
		     */
		    abuf = ip;
		    ip = nextstr(&abuf, stdin);
		    if (ip == NULL  ||  ip == (char *) ERR  ||  ip == undefval)
			goto testval;
		}

		o = makeop (ip, bastype);
	    }

testval:
	    /* If parameter value is in range, we are done.  If it is out of
	     * range and we are a batch job or an interactive terminal job,
	     * print an error message and request that the user enter a legal
	     * value.  If the CL is being run taking input from a file, abort,
	     * else we will go into a loop reading illegal values from the
	     * input file and printing out lots of error messages.
	     */
	    if (inrange (pp, &o))
		break;
	    else if (batch)
		eprintf ("\n[%d] %s", bkgno, oormsg);
	    else if (isatty (fileno (stdin)))
		eprintf ("%s\n", oormsg);
	    else
		cl_error (E_UERR, oormsg);
	}

	if (!(pp->p_type & PT_LIST)) {
	    /* update param with new value.
	     */
	    if (cldebug) {
		eprintf ("changing `%s.p_val' to ", pp->p_name);
		fprop (stderr, &o);
		eprintf ("\n");
	    }

	    pushop (&o);
	    paramset (pp, FN_VALUE);
	    pp->p_flags |= P_QUERY;
	}

	pushop (&o);

	if (arrflag  &&  query_status != NULL  &&  *ip != '\0') {
	    /* If we have an array assign values until something
	     * is used up or until we hit any error.
	     */
	    n_ele = 1;
	    forever {
		if (n_ele >= max_ele)		/* End of array. */
		    break;
		ip = nextstr(&abuf, stdin);

		if (ip == NULL)			/* End of query line. */
		    break;

		if (ip == (char *) ERR) {	/* Error on query line. */
		    eprintf("Error loading array value.\n");
		    break;
		}

		if (ip != undefval) {
		    o = makeop (ip, bastype);
		    if ( ! inrange (pp, &o) ) {	/* Not in range. */
			eprintf("Array value outside range.\n");
			break;
		    }

		    offset++;			/* Next element in array. */
		    poffset (offset);

		    pushop (&o);
		    paramset (pp, FN_VALUE);
		} else
		    offset++;

		n_ele++;
	    }
	}