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;
}
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);
}
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];
}
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);
}
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;
}
}
/* 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++;
}
}