void init_unformatted (variable * v)
{
char *val;
val = getenv (v->name);
def = GFC_CONVERT_NONE;
n_elist = 0;
if (val == NULL)
return;
do_count = 1;
p = val;
do_parse ();
if (do_count <= 0)
{
n_elist = 0;
elist = NULL;
}
else
{
elist = xmallocarray (unit_count, sizeof (exception_t));
do_count = 0;
p = val;
do_parse ();
}
}
void
spread_scalar_r10 (gfc_array_r10 *ret, const GFC_REAL_10 *source,
const index_type along, const index_type ncopies)
{
GFC_REAL_10 * restrict dest;
index_type stride;
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->base_addr == NULL)
{
ret->base_addr = xmallocarray (ncopies, sizeof (GFC_REAL_10));
ret->offset = 0;
GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
}
else
{
if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
/ GFC_DESCRIPTOR_STRIDE(ret,0))
runtime_error ("dim too large in spread()");
}
dest = ret->base_addr;
stride = GFC_DESCRIPTOR_STRIDE(ret,0);
for (index_type n = 0; n < ncopies; n++)
{
*dest = *source;
dest += stride;
}
}
void
string_minmax (gfc_charlen_type *rlen, CHARTYPE **dest, int op, int nargs, ...)
{
va_list ap;
int i;
CHARTYPE *next, *res;
gfc_charlen_type nextlen, reslen;
va_start (ap, nargs);
reslen = va_arg (ap, gfc_charlen_type);
res = va_arg (ap, CHARTYPE *);
*rlen = reslen;
if (res == NULL)
runtime_error ("First argument of '%s' intrinsic should be present",
op > 0 ? "MAX" : "MIN");
for (i = 1; i < nargs; i++)
{
nextlen = va_arg (ap, gfc_charlen_type);
next = va_arg (ap, CHARTYPE *);
if (next == NULL)
{
if (i == 1)
runtime_error ("Second argument of '%s' intrinsic should be "
"present", op > 0 ? "MAX" : "MIN");
else
continue;
}
if (nextlen > *rlen)
*rlen = nextlen;
if (op * compare_string (reslen, res, nextlen, next) < 0)
{
reslen = nextlen;
res = next;
}
}
va_end (ap);
if (*rlen == 0)
*dest = &zero_length_string;
else
{
CHARTYPE *tmp = xmallocarray (*rlen, sizeof (CHARTYPE));
memcpy (tmp, res, reslen * sizeof (CHARTYPE));
MEMSET (&tmp[reslen], ' ', *rlen - reslen);
*dest = tmp;
}
}
void
convert_char1_to_char4 (gfc_char4_t **dst, gfc_charlen_type len,
const unsigned char *src)
{
gfc_charlen_type i, l;
l = len > 0 ? len : 0;
*dst = xmallocarray ((l + 1), sizeof (gfc_char4_t));
for (i = 0; i < l; i++)
(*dst)[i] = src[i];
(*dst)[l] = '\0';
}
void
string_trim (gfc_charlen_type *len, CHARTYPE **dest, gfc_charlen_type slen,
const CHARTYPE *src)
{
*len = string_len_trim (slen, src);
if (*len == 0)
*dest = &zero_length_string;
else
{
/* Allocate space for result string. */
*dest = xmallocarray (*len, sizeof (CHARTYPE));
/* Copy string if necessary. */
memcpy (*dest, src, *len * sizeof (CHARTYPE));
}
}
void
initialize ( void )
{
kpsesetprogramname ( argv [0 ], "tftopl" ) ;
kpseinitprog ( "TFTOPL" , 0 , nil , nil ) ;
tfmfilearray = xmallocarray ( byte , 1002 ) ;
parsearguments () ;
tfmfile = kpseopenfile ( tfmname , kpsetfmformat ) ;
if ( verbose )
{
Fputs ( stderr , "This is TFtoPL, Version 3.3" ) ;
fprintf ( stderr , "%s\n", versionstring ) ;
}
if ( optind + 1 == argc )
{
plfile = stdout ;
}
else {
plname = extendfilename ( cmdline ( optind + 1 ) , "pl" ) ;
rewrite ( plfile , plname ) ;
}
ASCII04 = " !\"#$%&'()*+,-./0123456789:;<=>?" ;
ASCII10 = " @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_" ;
ASCII14 = " `abcdefghijklmnopqrstuvwxyz{|}~ " ;
strcpy ( ASCIIall , ASCII04 ) ;
strcat ( ASCIIall , "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_" ) ;
strcat ( ASCIIall , "`abcdefghijklmnopqrstuvwxyz{|}~" ) ;
MBLstring = " MBL" ;
RIstring = " RI " ;
RCEstring = " RCE" ;
level = 0 ;
charsonline = 0 ;
perfect = true ;
boundarychar = 256 ;
bcharlabel = 32767 ;
labelptr = 0 ;
labeltable [0 ].rr = 0 ;
}
static void
spread_internal_scalar (gfc_array_char *ret, const char *source,
const index_type *along, const index_type *pncopies)
{
int n;
int ncopies = *pncopies;
char * dest;
size_t size;
size = GFC_DESCRIPTOR_SIZE(ret);
if (GFC_DESCRIPTOR_RANK (ret) != 1)
runtime_error ("incorrect destination rank in spread()");
if (*along > 1)
runtime_error ("dim outside of rank in spread()");
if (ret->base_addr == NULL)
{
ret->base_addr = xmallocarray (ncopies, size);
ret->offset = 0;
GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
}
else
{
if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
/ GFC_DESCRIPTOR_STRIDE(ret,0))
runtime_error ("dim too large in spread()");
}
for (n = 0; n < ncopies; n++)
{
dest = (char*)(ret->base_addr + n * GFC_DESCRIPTOR_STRIDE_BYTES(ret,0));
memcpy (dest , source, size);
}
}
void
unpack0_r4 (gfc_array_r4 *ret, const gfc_array_r4 *vector,
const gfc_array_l1 *mask, const GFC_REAL_4 *fptr)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rs;
GFC_REAL_4 * restrict rptr;
/* v.* indicates the vector array. */
index_type vstride0;
GFC_REAL_4 *vptr;
/* Value for field, this is constant. */
const GFC_REAL_4 fval = *fptr;
/* m.* indicates the mask array. */
index_type mstride[GFC_MAX_DIMENSIONS];
index_type mstride0;
const GFC_LOGICAL_1 *mptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
int empty;
int mask_kind;
empty = 0;
mptr = mask->base_addr;
/* Use the same loop for all logical types, by using GFC_LOGICAL_1
and using shifting to address size and endian issues. */
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
{
/* Do not convert a NULL pointer as we use test for NULL below. */
if (mptr)
mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
}
else
runtime_error ("Funny sized logical array");
if (ret->base_addr == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
dim = GFC_DESCRIPTOR_RANK (mask);
rs = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
GFC_DIMENSION_SET(ret->dim[n], 0,
GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
empty = empty || extent[n] <= 0;
rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
rs *= extent[n];
}
ret->offset = 0;
ret->base_addr = xmallocarray (rs, sizeof (GFC_REAL_4));
}
else
{
dim = GFC_DESCRIPTOR_RANK (ret);
/* Initialize to avoid -Wmaybe-uninitialized complaints. */
rstride[0] = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
empty = empty || extent[n] <= 0;
rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
}
if (rstride[0] == 0)
rstride[0] = 1;
}
if (empty)
return;
if (mstride[0] == 0)
mstride[0] = 1;
vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
if (vstride0 == 0)
vstride0 = 1;
rstride0 = rstride[0];
mstride0 = mstride[0];
rptr = ret->base_addr;
vptr = vector->base_addr;
while (rptr)
{
if (*mptr)
{
/* From vector. */
*rptr = *vptr;
vptr += vstride0;
}
else
{
/* From field. */
*rptr = fval;
}
/* Advance to the next element. */
rptr += rstride0;
mptr += mstride0;
count[0]++;
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
rptr -= rstride[n] * extent[n];
mptr -= mstride[n] * extent[n];
n++;
if (n >= dim)
{
/* Break out of the loop. */
rptr = NULL;
break;
}
else
{
count[n]++;
rptr += rstride[n];
mptr += mstride[n];
}
}
}
}
void
pack_r4 (gfc_array_r4 *ret, const gfc_array_r4 *array,
const gfc_array_l1 *mask, const gfc_array_r4 *vector)
{
/* r.* indicates the return array. */
index_type rstride0;
GFC_REAL_4 * restrict rptr;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
const GFC_REAL_4 *sptr;
/* m.* indicates the mask array. */
index_type mstride[GFC_MAX_DIMENSIONS];
index_type mstride0;
const GFC_LOGICAL_1 *mptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
int zero_sized;
index_type n;
index_type dim;
index_type nelem;
index_type total;
int mask_kind;
dim = GFC_DESCRIPTOR_RANK (array);
mptr = mask->base_addr;
/* Use the same loop for all logical types, by using GFC_LOGICAL_1
and using shifting to address size and endian issues. */
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
{
/* Do not convert a NULL pointer as we use test for NULL below. */
if (mptr)
mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
}
else
runtime_error ("Funny sized logical array");
zero_sized = 0;
for (n = 0; n < dim; n++)
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] <= 0)
zero_sized = 1;
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
}
if (sstride[0] == 0)
sstride[0] = 1;
if (mstride[0] == 0)
mstride[0] = mask_kind;
if (zero_sized)
sptr = NULL;
else
sptr = array->base_addr;
if (ret->base_addr == NULL || unlikely (compile_options.bounds_check))
{
/* Count the elements, either for allocating memory or
for bounds checking. */
if (vector != NULL)
{
/* The return array will have as many
elements as there are in VECTOR. */
total = GFC_DESCRIPTOR_EXTENT(vector,0);
if (total < 0)
{
total = 0;
vector = NULL;
}
}
else
{
/* We have to count the true elements in MASK. */
total = count_0 (mask);
}
if (ret->base_addr == NULL)
{
/* Setup the array descriptor. */
GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);
ret->offset = 0;
/* xmallocarray allocates a single byte for zero size. */
ret->base_addr = xmallocarray (total, sizeof (GFC_REAL_4));
if (total == 0)
return;
}
else
{
/* We come here because of range checking. */
index_type ret_extent;
ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
if (total != ret_extent)
runtime_error ("Incorrect extent in return value of PACK intrinsic;"
" is %ld, should be %ld", (long int) total,
(long int) ret_extent);
}
}
rstride0 = GFC_DESCRIPTOR_STRIDE(ret,0);
if (rstride0 == 0)
rstride0 = 1;
sstride0 = sstride[0];
mstride0 = mstride[0];
rptr = ret->base_addr;
while (sptr && mptr)
{
/* Test this element. */
if (*mptr)
{
/* Add it. */
*rptr = *sptr;
rptr += rstride0;
}
/* Advance to the next element. */
sptr += sstride0;
mptr += mstride0;
count[0]++;
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
sptr -= sstride[n] * extent[n];
mptr -= mstride[n] * extent[n];
n++;
if (n >= dim)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
mptr += mstride[n];
}
}
}
/* Add any remaining elements from VECTOR. */
if (vector)
{
n = GFC_DESCRIPTOR_EXTENT(vector,0);
nelem = ((rptr - ret->base_addr) / rstride0);
if (n > nelem)
{
sstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
if (sstride0 == 0)
sstride0 = 1;
sptr = vector->base_addr + sstride0 * nelem;
n -= nelem;
while (n--)
{
*rptr = *sptr;
rptr += rstride0;
sptr += sstride0;
}
}
}
}
static void
eoshift0 (gfc_array_char * ret, const gfc_array_char * array,
int shift, const char * pbound, int which, index_type size,
const char *filler, index_type filler_len)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type roffset;
char * restrict rptr;
char *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type soffset;
const char *sptr;
const char *src;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
index_type len;
index_type n;
index_type arraysize;
/* The compiler cannot figure out that these are set, initialize
them to avoid warnings. */
len = 0;
soffset = 0;
roffset = 0;
arraysize = size0 ((array_t *) array);
if (ret->base_addr == NULL)
{
int i;
ret->offset = 0;
ret->dtype = array->dtype;
for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
{
index_type ub, str;
ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
if (i == 0)
str = 1;
else
str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
* GFC_DESCRIPTOR_STRIDE(ret,i-1);
GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
}
/* xmallocarray allocates a single byte for zero size. */
ret->base_addr = xmallocarray (arraysize, size);
}
else if (unlikely (compile_options.bounds_check))
{
bounds_equal_extents ((array_t *) ret, (array_t *) array,
"return value", "EOSHIFT");
}
if (arraysize == 0)
return;
which = which - 1;
extent[0] = 1;
count[0] = 0;
sstride[0] = -1;
rstride[0] = -1;
n = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
if (dim == which)
{
roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
if (roffset == 0)
roffset = size;
soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
if (soffset == 0)
soffset = size;
len = GFC_DESCRIPTOR_EXTENT(array,dim);
}
else
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
n++;
}
}
if (sstride[0] == 0)
sstride[0] = size;
if (rstride[0] == 0)
rstride[0] = size;
dim = GFC_DESCRIPTOR_RANK (array);
rstride0 = rstride[0];
sstride0 = sstride[0];
rptr = ret->base_addr;
sptr = array->base_addr;
if ((shift >= 0 ? shift : -shift) > len)
{
shift = len;
len = 0;
}
else
{
if (shift > 0)
len = len - shift;
else
len = len + shift;
}
while (rptr)
{
/* Do the shift for this dimension. */
if (shift > 0)
{
src = &sptr[shift * soffset];
dest = rptr;
}
else
{
src = sptr;
dest = &rptr[-shift * roffset];
}
for (n = 0; n < len; n++)
{
memcpy (dest, src, size);
dest += roffset;
src += soffset;
}
if (shift >= 0)
{
n = shift;
}
else
{
dest = rptr;
n = -shift;
}
if (pbound)
while (n--)
{
memcpy (dest, pbound, size);
dest += roffset;
}
else
while (n--)
{
index_type i;
if (filler_len == 1)
memset (dest, filler[0], size);
else
for (i = 0; i < size ; i += filler_len)
memcpy (&dest[i], filler, filler_len);
dest += roffset;
}
/* Advance to the next section. */
rptr += rstride0;
sptr += sstride0;
count[0]++;
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
rptr -= rstride[n] * extent[n];
sptr -= sstride[n] * extent[n];
n++;
if (n >= dim - 1)
{
/* Break out of the loop. */
rptr = NULL;
break;
}
else
{
count[n]++;
rptr += rstride[n];
sptr += sstride[n];
}
}
}
}
void
storebasefile ( void )
{
integer k ;
halfword p, q ;
integer x ;
fourquarters w ;
ASCIIcode * baseengine ;
selector = 5 ;
print ( 1074 ) ;
print ( jobname ) ;
printchar ( 32 ) ;
printint ( roundunscaled ( internal [14 ]) ) ;
printchar ( 46 ) ;
printint ( roundunscaled ( internal [15 ]) ) ;
printchar ( 46 ) ;
printint ( roundunscaled ( internal [16 ]) ) ;
printchar ( 41 ) ;
if ( interaction == 0 )
selector = 2 ;
else selector = 3 ;
{
if ( poolptr + 1 > maxpoolptr )
{
if ( poolptr + 1 > poolsize )
overflow ( 257 , poolsize - initpoolptr ) ;
maxpoolptr = poolptr + 1 ;
}
}
baseident = makestring () ;
strref [baseident ]= 127 ;
packjobname ( 743 ) ;
while ( ! wopenout ( basefile ) ) promptfilename ( 1075 , 743 ) ;
printnl ( 1076 ) ;
slowprint ( wmakenamestring ( basefile ) ) ;
flushstring ( strptr - 1 ) ;
printnl ( 261 ) ;
slowprint ( baseident ) ;
dumpint ( 1462914374L ) ;
x = strlen ( enginename ) ;
baseengine = xmallocarray ( ASCIIcode , x + 4 ) ;
strcpy ( stringcast ( baseengine ) , enginename ) ;
{register integer for_end; k = x ;for_end = x + 3 ; if ( k <= for_end) do
baseengine [k ]= 0 ;
while ( k++ < for_end ) ;}
x = x + 4 - ( x % 4 ) ;
dumpint ( x ) ;
dumpthings ( baseengine [0 ], x ) ;
libcfree ( baseengine ) ;
dumpint ( 228418379L ) ;
dumpthings ( xord [0 ], 256 ) ;
dumpthings ( xchr [0 ], 256 ) ;
dumpthings ( xprn [0 ], 256 ) ;
dumpint ( 0 ) ;
dumpint ( memtop ) ;
dumpint ( 9500 ) ;
dumpint ( 7919 ) ;
dumpint ( 15 ) ;
dumpint ( poolptr ) ;
dumpint ( strptr ) ;
{register integer for_end; k = 0 ;for_end = strptr ; if ( k <= for_end) do
dumpint ( strstart [k ]) ;
while ( k++ < for_end ) ;}
k = 0 ;
while ( k + 4 < poolptr ) {
w .b0 = strpool [k ];
w .b1 = strpool [k + 1 ];
w .b2 = strpool [k + 2 ];
w .b3 = strpool [k + 3 ];
dumpqqqq ( w ) ;
k = k + 4 ;
}
k = poolptr - 4 ;
w .b0 = strpool [k ];
w .b1 = strpool [k + 1 ];
w .b2 = strpool [k + 2 ];
w .b3 = strpool [k + 3 ];
dumpqqqq ( w ) ;
println () ;
printint ( strptr ) ;
print ( 1071 ) ;
printint ( poolptr ) ;
sortavail () ;
varused = 0 ;
dumpint ( lomemmax ) ;
dumpint ( rover ) ;
p = 0 ;
q = rover ;
x = 0 ;
do {
{ register integer for_end; k = p ;for_end = q + 1 ; if ( k <=
for_end) do
dumpwd ( mem [k ]) ;
while ( k++ < for_end ) ;}
x = x + q + 2 - p ;
varused = varused + q - p ;
p = q + mem [q ].hhfield .lhfield ;
q = mem [q + 1 ].hhfield .v.RH ;
} while ( ! ( q == rover ) ) ;
varused = varused + lomemmax - p ;
dynused = memend + 1 - himemmin ;
{register integer for_end; k = p ;for_end = lomemmax ; if ( k <= for_end)
do
dumpwd ( mem [k ]) ;
while ( k++ < for_end ) ;}
x = x + lomemmax + 1 - p ;
dumpint ( himemmin ) ;
dumpint ( avail ) ;
{register integer for_end; k = himemmin ;for_end = memend ; if ( k <=
for_end) do
dumpwd ( mem [k ]) ;
while ( k++ < for_end ) ;}
x = x + memend + 1 - himemmin ;
p = avail ;
while ( p != 0 ) {
decr ( dynused ) ;
p = mem [p ].hhfield .v.RH ;
}
dumpint ( varused ) ;
dumpint ( dynused ) ;
println () ;
printint ( x ) ;
print ( 1072 ) ;
printint ( varused ) ;
printchar ( 38 ) ;
printint ( dynused ) ;
dumpint ( hashused ) ;
stcount = 9756 - hashused ;
{register integer for_end; p = 1 ;for_end = hashused ; if ( p <= for_end)
do
if ( hash [p ].v.RH != 0 )
{
dumpint ( p ) ;
dumphh ( hash [p ]) ;
dumphh ( eqtb [p ]) ;
incr ( stcount ) ;
}
while ( p++ < for_end ) ;}
{register integer for_end; p = hashused + 1 ;for_end = 9769 ; if ( p <=
for_end) do
{
dumphh ( hash [p ]) ;
dumphh ( eqtb [p ]) ;
}
while ( p++ < for_end ) ;}
dumpint ( stcount ) ;
println () ;
printint ( stcount ) ;
print ( 1073 ) ;
dumpint ( intptr ) ;
{register integer for_end; k = 1 ;for_end = intptr ; if ( k <= for_end) do
{
dumpint ( internal [k ]) ;
dumpint ( intname [k ]) ;
}
while ( k++ < for_end ) ;}
dumpint ( startsym ) ;
dumpint ( interaction ) ;
dumpint ( baseident ) ;
dumpint ( bgloc ) ;
dumpint ( egloc ) ;
dumpint ( serialno ) ;
dumpint ( 69069L ) ;
internal [12 ]= 0 ;
wclose ( basefile ) ;
}
static void
cshift0 (gfc_array_char * ret, const gfc_array_char * array,
ptrdiff_t shift, int which, index_type size)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type roffset;
char *rptr;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type soffset;
const char *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type dim;
index_type len;
index_type n;
index_type arraysize;
index_type type_size;
if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
arraysize = size0 ((array_t *) array);
if (ret->base_addr == NULL)
{
int i;
ret->offset = 0;
GFC_DTYPE_COPY(ret,array);
for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
{
index_type ub, str;
ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
if (i == 0)
str = 1;
else
str = GFC_DESCRIPTOR_EXTENT(ret,i-1) *
GFC_DESCRIPTOR_STRIDE(ret,i-1);
GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
}
/* xmallocarray allocates a single byte for zero size. */
ret->base_addr = xmallocarray (arraysize, size);
}
else if (unlikely (compile_options.bounds_check))
{
bounds_equal_extents ((array_t *) ret, (array_t *) array,
"return value", "CSHIFT");
}
if (arraysize == 0)
return;
type_size = GFC_DTYPE_TYPE_SIZE (array);
switch(type_size)
{
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_INTEGER_1:
cshift0_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array, shift, which);
return;
case GFC_DTYPE_LOGICAL_2:
case GFC_DTYPE_INTEGER_2:
cshift0_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array, shift, which);
return;
case GFC_DTYPE_LOGICAL_4:
case GFC_DTYPE_INTEGER_4:
cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift, which);
return;
case GFC_DTYPE_LOGICAL_8:
case GFC_DTYPE_INTEGER_8:
cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift, which);
return;
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_LOGICAL_16:
case GFC_DTYPE_INTEGER_16:
cshift0_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array, shift,
which);
return;
#endif
case GFC_DTYPE_REAL_4:
cshift0_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array, shift, which);
return;
case GFC_DTYPE_REAL_8:
cshift0_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array, shift, which);
return;
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_REAL_10
case GFC_DTYPE_REAL_10:
cshift0_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array, shift,
which);
return;
# endif
# ifdef HAVE_GFC_REAL_16
case GFC_DTYPE_REAL_16:
cshift0_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array, shift,
which);
return;
# endif
#endif
case GFC_DTYPE_COMPLEX_4:
cshift0_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array, shift, which);
return;
case GFC_DTYPE_COMPLEX_8:
cshift0_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array, shift, which);
return;
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_COMPLEX_10
case GFC_DTYPE_COMPLEX_10:
cshift0_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array, shift,
which);
return;
# endif
# ifdef HAVE_GFC_COMPLEX_16
case GFC_DTYPE_COMPLEX_16:
cshift0_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array, shift,
which);
return;
# endif
#endif
default:
break;
}
switch (size)
{
/* Let's check the actual alignment of the data pointers. If they
are suitably aligned, we can safely call the unpack functions. */
case sizeof (GFC_INTEGER_1):
cshift0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, shift,
which);
break;
case sizeof (GFC_INTEGER_2):
if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr))
break;
else
{
cshift0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, shift,
which);
return;
}
case sizeof (GFC_INTEGER_4):
if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr))
break;
else
{
cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift,
which);
return;
}
case sizeof (GFC_INTEGER_8):
if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr))
{
/* Let's try to use the complex routines. First, a sanity
check that the sizes match; this should be optimized to
a no-op. */
if (sizeof(GFC_INTEGER_8) != sizeof(GFC_COMPLEX_4))
break;
if (GFC_UNALIGNED_C4(ret->base_addr)
|| GFC_UNALIGNED_C4(array->base_addr))
break;
cshift0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, shift,
which);
return;
}
else
{
cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift,
which);
return;
}
#ifdef HAVE_GFC_INTEGER_16
case sizeof (GFC_INTEGER_16):
if (GFC_UNALIGNED_16(ret->base_addr)
|| GFC_UNALIGNED_16(array->base_addr))
{
/* Let's try to use the complex routines. First, a sanity
check that the sizes match; this should be optimized to
a no-op. */
if (sizeof(GFC_INTEGER_16) != sizeof(GFC_COMPLEX_8))
break;
if (GFC_UNALIGNED_C8(ret->base_addr)
|| GFC_UNALIGNED_C8(array->base_addr))
break;
cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
which);
return;
}
else
{
cshift0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
shift, which);
return;
}
#else
case sizeof (GFC_COMPLEX_8):
if (GFC_UNALIGNED_C8(ret->base_addr)
|| GFC_UNALIGNED_C8(array->base_addr))
break;
else
{
cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift,
which);
return;
}
#endif
default:
break;
}
which = which - 1;
sstride[0] = 0;
rstride[0] = 0;
extent[0] = 1;
count[0] = 0;
n = 0;
/* Initialized for avoiding compiler warnings. */
roffset = size;
soffset = size;
len = 0;
for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
{
if (dim == which)
{
roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
if (roffset == 0)
roffset = size;
soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
if (soffset == 0)
soffset = size;
len = GFC_DESCRIPTOR_EXTENT(array,dim);
}
else
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
n++;
}
}
if (sstride[0] == 0)
sstride[0] = size;
if (rstride[0] == 0)
rstride[0] = size;
dim = GFC_DESCRIPTOR_RANK (array);
rstride0 = rstride[0];
sstride0 = sstride[0];
rptr = ret->base_addr;
sptr = array->base_addr;
shift = len == 0 ? 0 : shift % (ptrdiff_t)len;
if (shift < 0)
shift += len;
while (rptr)
{
/* Do the shift for this dimension. */
/* If elements are contiguous, perform the operation
in two block moves. */
if (soffset == size && roffset == size)
{
size_t len1 = shift * size;
size_t len2 = (len - shift) * size;
memcpy (rptr, sptr + len1, len2);
memcpy (rptr + len2, sptr, len1);
}
else
{
/* Otherwise, we'll have to perform the copy one element at
a time. */
char *dest = rptr;
const char *src = &sptr[shift * soffset];
for (n = 0; n < len - shift; n++)
{
memcpy (dest, src, size);
dest += roffset;
src += soffset;
}
for (src = sptr, n = 0; n < shift; n++)
{
memcpy (dest, src, size);
dest += roffset;
src += soffset;
}
}
/* Advance to the next section. */
rptr += rstride0;
sptr += sstride0;
count[0]++;
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
rptr -= rstride[n] * extent[n];
sptr -= sstride[n] * extent[n];
n++;
if (n >= dim - 1)
{
/* Break out of the loop. */
rptr = NULL;
break;
}
else
{
count[n]++;
rptr += rstride[n];
sptr += sstride[n];
}
}
}
}
void *
internal_pack (gfc_array_char * source)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type stride[GFC_MAX_DIMENSIONS];
index_type stride0;
index_type dim;
index_type ssize;
const char *src;
char *dest;
void *destptr;
int n;
int packed;
index_type size;
index_type type_size;
if (source->base_addr == NULL)
return NULL;
type_size = GFC_DTYPE_TYPE_SIZE(source);
size = GFC_DESCRIPTOR_SIZE (source);
switch (type_size)
{
case GFC_DTYPE_INTEGER_1:
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_DERIVED_1:
return internal_pack_1 ((gfc_array_i1 *) source);
case GFC_DTYPE_INTEGER_2:
case GFC_DTYPE_LOGICAL_2:
return internal_pack_2 ((gfc_array_i2 *) source);
case GFC_DTYPE_INTEGER_4:
case GFC_DTYPE_LOGICAL_4:
return internal_pack_4 ((gfc_array_i4 *) source);
case GFC_DTYPE_INTEGER_8:
case GFC_DTYPE_LOGICAL_8:
return internal_pack_8 ((gfc_array_i8 *) source);
#if defined(HAVE_GFC_INTEGER_16)
case GFC_DTYPE_INTEGER_16:
case GFC_DTYPE_LOGICAL_16:
return internal_pack_16 ((gfc_array_i16 *) source);
#endif
case GFC_DTYPE_REAL_4:
return internal_pack_r4 ((gfc_array_r4 *) source);
case GFC_DTYPE_REAL_8:
return internal_pack_r8 ((gfc_array_r8 *) source);
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# if defined (HAVE_GFC_REAL_10)
case GFC_DTYPE_REAL_10:
return internal_pack_r10 ((gfc_array_r10 *) source);
# endif
# if defined (HAVE_GFC_REAL_16)
case GFC_DTYPE_REAL_16:
return internal_pack_r16 ((gfc_array_r16 *) source);
# endif
#endif
case GFC_DTYPE_COMPLEX_4:
return internal_pack_c4 ((gfc_array_c4 *) source);
case GFC_DTYPE_COMPLEX_8:
return internal_pack_c8 ((gfc_array_c8 *) source);
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# if defined (HAVE_GFC_COMPLEX_10)
case GFC_DTYPE_COMPLEX_10:
return internal_pack_c10 ((gfc_array_c10 *) source);
# endif
# if defined (HAVE_GFC_COMPLEX_16)
case GFC_DTYPE_COMPLEX_16:
return internal_pack_c16 ((gfc_array_c16 *) source);
# endif
#endif
case GFC_DTYPE_DERIVED_2:
if (GFC_UNALIGNED_2(source->base_addr))
break;
else
return internal_pack_2 ((gfc_array_i2 *) source);
case GFC_DTYPE_DERIVED_4:
if (GFC_UNALIGNED_4(source->base_addr))
break;
else
return internal_pack_4 ((gfc_array_i4 *) source);
case GFC_DTYPE_DERIVED_8:
if (GFC_UNALIGNED_8(source->base_addr))
break;
else
return internal_pack_8 ((gfc_array_i8 *) source);
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_DERIVED_16:
if (GFC_UNALIGNED_16(source->base_addr))
break;
else
return internal_pack_16 ((gfc_array_i16 *) source);
#endif
default:
break;
}
dim = GFC_DESCRIPTOR_RANK (source);
ssize = 1;
packed = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
stride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
if (extent[n] <= 0)
{
/* Do nothing. */
packed = 1;
break;
}
if (ssize != stride[n])
packed = 0;
ssize *= extent[n];
}
if (packed)
return source->base_addr;
/* Allocate storage for the destination. */
destptr = xmallocarray (ssize, size);
dest = (char *)destptr;
src = source->base_addr;
stride0 = stride[0] * size;
while (src)
{
/* Copy the data. */
memcpy(dest, src, size);
/* Advance to the next element. */
dest += size;
src += stride0;
count[0]++;
/* Advance to the next source element. */
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
src -= stride[n] * extent[n] * size;
n++;
if (n == dim)
{
src = NULL;
break;
}
else
{
count[n]++;
src += stride[n] * size;
}
}
}
return destptr;
}
static void
transpose_internal (gfc_array_char *ret, gfc_array_char *source)
{
/* r.* indicates the return array. */
index_type rxstride, rystride;
char *rptr;
/* s.* indicates the source array. */
index_type sxstride, systride;
const char *sptr;
index_type xcount, ycount;
index_type x, y;
index_type size;
assert (GFC_DESCRIPTOR_RANK (source) == 2
&& GFC_DESCRIPTOR_RANK (ret) == 2);
size = GFC_DESCRIPTOR_SIZE(ret);
if (ret->base_addr == NULL)
{
assert (ret->dtype == source->dtype);
GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1,
1);
GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1,
GFC_DESCRIPTOR_EXTENT(source, 1));
ret->base_addr = xmallocarray (size0 ((array_t*)ret), size);
ret->offset = 0;
}
else if (unlikely (compile_options.bounds_check))
{
index_type ret_extent, src_extent;
ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
src_extent = GFC_DESCRIPTOR_EXTENT(source,1);
if (src_extent != ret_extent)
runtime_error ("Incorrect extent in return value of TRANSPOSE"
" intrinsic in dimension 1: is %ld,"
" should be %ld", (long int) src_extent,
(long int) ret_extent);
ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1);
src_extent = GFC_DESCRIPTOR_EXTENT(source,0);
if (src_extent != ret_extent)
runtime_error ("Incorrect extent in return value of TRANSPOSE"
" intrinsic in dimension 2: is %ld,"
" should be %ld", (long int) src_extent,
(long int) ret_extent);
}
sxstride = GFC_DESCRIPTOR_STRIDE_BYTES(source,0);
systride = GFC_DESCRIPTOR_STRIDE_BYTES(source,1);
xcount = GFC_DESCRIPTOR_EXTENT(source,0);
ycount = GFC_DESCRIPTOR_EXTENT(source,1);
rxstride = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
rystride = GFC_DESCRIPTOR_STRIDE_BYTES(ret,1);
rptr = ret->base_addr;
sptr = source->base_addr;
for (y = 0; y < ycount; y++)
{
for (x = 0; x < xcount; x++)
{
memcpy (rptr, sptr, size);
sptr += sxstride;
rptr += rystride;
}
sptr += systride - (sxstride * xcount);
rptr += rxstride - (rystride * xcount);
}
}
/* 10 */ smallnumber c ;
c = curmod ;
if ( jobname == 0 )
openlogfile () ;
while ( inputptr > 0 ) if ( ( curinput .indexfield > 15 ) )
endtokenlist () ;
else endfilereading () ;
while ( loopptr != 0 ) stopiteration () ;
while ( openparens > 0 ) {
print ( 1078 ) ;
decr ( openparens ) ;
}
while ( condptr != 0 ) {
printnl ( 1079 ) ;
printcmdmod ( 2 , curif ) ;
if ( ifline != 0 )
{
print ( 1080 ) ;
printint ( ifline ) ;
}
print ( 1081 ) ;
ifline = mem [condptr + 1 ].cint ;
curif = mem [condptr ].hhfield .b1 ;
loopptr = condptr ;
condptr = mem [condptr ].hhfield .v.RH ;
freenode ( loopptr , 2 ) ;
}
if ( history != 0 ) {
if ( ( ( history == 1 ) || ( interaction < 3 ) ) ) {
if ( selector == 3 )
{
selector = 1 ;
printnl ( 1082 ) ;
selector = 3 ;
}
}
}
if ( c == 1 )
{
;
#ifdef INIMF
if ( iniversion )
{
storebasefile () ;
goto lab10 ;
}
#endif /* INIMF */
printnl ( 1083 ) ;
goto lab10 ;
}
lab10: ;
}
#ifdef INIMF
void
initprim ( void )
{
primitive ( 409 , 41 , 1 ) ;
primitive ( 410 , 41 , 2 ) ;
primitive ( 411 , 41 , 3 ) ;
primitive ( 412 , 41 , 4 ) ;
primitive ( 413 , 41 , 5 ) ;
primitive ( 414 , 41 , 6 ) ;
primitive ( 415 , 41 , 7 ) ;
primitive ( 416 , 41 , 8 ) ;
primitive ( 417 , 41 , 9 ) ;
primitive ( 418 , 41 , 10 ) ;
primitive ( 419 , 41 , 11 ) ;
primitive ( 420 , 41 , 12 ) ;
primitive ( 421 , 41 , 13 ) ;
primitive ( 422 , 41 , 14 ) ;
primitive ( 423 , 41 , 15 ) ;
primitive ( 424 , 41 , 16 ) ;
primitive ( 425 , 41 , 17 ) ;
primitive ( 426 , 41 , 18 ) ;
primitive ( 427 , 41 , 19 ) ;
primitive ( 428 , 41 , 20 ) ;
primitive ( 429 , 41 , 21 ) ;
primitive ( 430 , 41 , 22 ) ;
primitive ( 431 , 41 , 23 ) ;
primitive ( 432 , 41 , 24 ) ;
primitive ( 433 , 41 , 25 ) ;
primitive ( 434 , 41 , 26 ) ;
primitive ( 435 , 41 , 27 ) ;
primitive ( 436 , 41 , 28 ) ;
primitive ( 437 , 41 , 29 ) ;
primitive ( 438 , 41 , 30 ) ;
primitive ( 439 , 41 , 31 ) ;
primitive ( 440 , 41 , 32 ) ;
primitive ( 441 , 41 , 33 ) ;
primitive ( 442 , 41 , 34 ) ;
primitive ( 443 , 41 , 35 ) ;
primitive ( 444 , 41 , 36 ) ;
primitive ( 445 , 41 , 37 ) ;
primitive ( 446 , 41 , 38 ) ;
primitive ( 447 , 41 , 39 ) ;
primitive ( 448 , 41 , 40 ) ;
primitive ( 449 , 41 , 41 ) ;
primitive ( 408 , 48 , 0 ) ;
primitive ( 91 , 64 , 0 ) ;
eqtb [9760 ]= eqtb [cursym ];
primitive ( 93 , 65 , 0 ) ;
primitive ( 125 , 66 , 0 ) ;
primitive ( 123 , 47 , 0 ) ;
primitive ( 58 , 82 , 0 ) ;
eqtb [9762 ]= eqtb [cursym ];
primitive ( 459 , 81 , 0 ) ;
primitive ( 460 , 80 , 0 ) ;
primitive ( 461 , 78 , 0 ) ;
primitive ( 44 , 83 , 0 ) ;
primitive ( 59 , 84 , 0 ) ;
eqtb [9763 ]= eqtb [cursym ];
primitive ( 92 , 7 , 0 ) ;
primitive ( 462 , 19 , 0 ) ;
primitive ( 463 , 73 , 0 ) ;
primitive ( 464 , 60 , 0 ) ;
primitive ( 465 , 33 , 0 ) ;
bgloc = cursym ;
primitive ( 466 , 58 , 0 ) ;
primitive ( 467 , 20 , 0 ) ;
primitive ( 468 , 61 , 0 ) ;
primitive ( 469 , 28 , 0 ) ;
primitive ( 470 , 12 , 0 ) ;
primitive ( 453 , 85 , 0 ) ;
eqtb [9767 ]= eqtb [cursym ];
egloc = cursym ;
primitive ( 471 , 27 , 0 ) ;
primitive ( 472 , 6 , 0 ) ;
primitive ( 473 , 10 , 0 ) ;
primitive ( 474 , 71 , 0 ) ;
primitive ( 475 , 74 , 0 ) ;
primitive ( 476 , 14 , 0 ) ;
primitive ( 477 , 15 , 0 ) ;
primitive ( 478 , 16 , 0 ) ;
primitive ( 479 , 70 , 0 ) ;
primitive ( 480 , 29 , 0 ) ;
primitive ( 481 , 25 , 0 ) ;
primitive ( 482 , 9 , 0 ) ;
primitive ( 483 , 13 , 0 ) ;
primitive ( 484 , 8 , 0 ) ;
primitive ( 485 , 18 , 0 ) ;
primitive ( 486 , 79 , 0 ) ;
primitive ( 487 , 75 , 0 ) ;
primitive ( 488 , 36 , 0 ) ;
primitive ( 489 , 59 , 0 ) ;
primitive ( 490 , 72 , 0 ) ;
primitive ( 491 , 76 , 0 ) ;
primitive ( 656 , 17 , 1 ) ;
primitive ( 657 , 17 , 2 ) ;
primitive ( 658 , 17 , 54 ) ;
primitive ( 659 , 17 , 45 ) ;
primitive ( 660 , 17 , 50 ) ;
primitive ( 454 , 17 , 0 ) ;
eqtb [9765 ]= eqtb [cursym ];
primitive ( 661 , 4 , 9770 ) ;
primitive ( 662 , 4 , 9920 ) ;
primitive ( 663 , 4 , 1 ) ;
primitive ( 455 , 4 , 0 ) ;
eqtb [9764 ]= eqtb [cursym ];
primitive ( 664 , 62 , 0 ) ;
primitive ( 665 , 62 , 1 ) ;
primitive ( 64 , 62 , 2 ) ;
primitive ( 666 , 62 , 3 ) ;
primitive ( 677 , 57 , 9770 ) ;
primitive ( 678 , 57 , 9920 ) ;
primitive ( 679 , 57 , 10070 ) ;
primitive ( 680 , 57 , 1 ) ;
primitive ( 681 , 57 , 2 ) ;
primitive ( 682 , 57 , 3 ) ;
primitive ( 692 , 3 , 0 ) ;
primitive ( 618 , 3 , 1 ) ;
primitive ( 719 , 1 , 1 ) ;
primitive ( 452 , 2 , 2 ) ;
eqtb [9766 ]= eqtb [cursym ];
primitive ( 720 , 2 , 3 ) ;
primitive ( 721 , 2 , 4 ) ;
primitive ( 347 , 34 , 30 ) ;
primitive ( 348 , 34 , 31 ) ;
primitive ( 349 , 34 , 32 ) ;
primitive ( 350 , 34 , 33 ) ;
primitive ( 351 , 34 , 34 ) ;
primitive ( 352 , 34 , 35 ) ;
primitive ( 353 , 34 , 36 ) ;
primitive ( 354 , 34 , 37 ) ;
primitive ( 355 , 35 , 38 ) ;
primitive ( 356 , 35 , 39 ) ;
primitive ( 357 , 35 , 40 ) ;
primitive ( 358 , 35 , 41 ) ;
primitive ( 359 , 35 , 42 ) ;
primitive ( 360 , 35 , 43 ) ;
primitive ( 361 , 35 , 44 ) ;
primitive ( 362 , 35 , 45 ) ;
primitive ( 363 , 35 , 46 ) ;
primitive ( 364 , 35 , 47 ) ;
primitive ( 365 , 35 , 48 ) ;
primitive ( 366 , 35 , 49 ) ;
primitive ( 367 , 35 , 50 ) ;
primitive ( 368 , 35 , 51 ) ;
primitive ( 369 , 35 , 52 ) ;
primitive ( 370 , 35 , 53 ) ;
primitive ( 371 , 35 , 54 ) ;
primitive ( 372 , 35 , 55 ) ;
primitive ( 373 , 35 , 56 ) ;
primitive ( 374 , 35 , 57 ) ;
primitive ( 375 , 35 , 58 ) ;
primitive ( 376 , 35 , 59 ) ;
primitive ( 377 , 35 , 60 ) ;
primitive ( 378 , 35 , 61 ) ;
primitive ( 379 , 35 , 62 ) ;
primitive ( 380 , 35 , 63 ) ;
primitive ( 381 , 35 , 64 ) ;
primitive ( 382 , 35 , 65 ) ;
primitive ( 383 , 35 , 66 ) ;
primitive ( 384 , 35 , 67 ) ;
primitive ( 385 , 37 , 68 ) ;
primitive ( 43 , 44 , 69 ) ;
primitive ( 45 , 44 , 70 ) ;
primitive ( 42 , 56 , 71 ) ;
primitive ( 47 , 55 , 72 ) ;
eqtb [9761 ]= eqtb [cursym ];
primitive ( 386 , 46 , 73 ) ;
primitive ( 310 , 46 , 74 ) ;
primitive ( 388 , 53 , 76 ) ;
primitive ( 387 , 46 , 75 ) ;
primitive ( 60 , 51 , 77 ) ;
primitive ( 389 , 51 , 78 ) ;
primitive ( 62 , 51 , 79 ) ;
primitive ( 390 , 51 , 80 ) ;
primitive ( 61 , 52 , 81 ) ;
primitive ( 391 , 51 , 82 ) ;
primitive ( 401 , 38 , 94 ) ;
primitive ( 402 , 38 , 95 ) ;
primitive ( 403 , 38 , 96 ) ;
primitive ( 404 , 38 , 97 ) ;
primitive ( 405 , 38 , 98 ) ;
primitive ( 406 , 38 , 99 ) ;
primitive ( 407 , 38 , 100 ) ;
primitive ( 38 , 49 , 83 ) ;
primitive ( 392 , 56 , 84 ) ;
primitive ( 393 , 56 , 85 ) ;
primitive ( 394 , 56 , 86 ) ;
primitive ( 395 , 56 , 87 ) ;
primitive ( 396 , 56 , 88 ) ;
primitive ( 397 , 56 , 89 ) ;
primitive ( 398 , 56 , 90 ) ;
primitive ( 399 , 56 , 91 ) ;
primitive ( 400 , 46 , 92 ) ;
primitive ( 340 , 31 , 15 ) ;
primitive ( 326 , 31 , 4 ) ;
primitive ( 324 , 31 , 2 ) ;
primitive ( 331 , 31 , 9 ) ;
primitive ( 328 , 31 , 6 ) ;
primitive ( 333 , 31 , 11 ) ;
primitive ( 335 , 31 , 13 ) ;
primitive ( 336 , 31 , 14 ) ;
primitive ( 913 , 86 , 0 ) ;
primitive ( 914 , 86 , 1 ) ;
primitive ( 273 , 24 , 0 ) ;
primitive ( 274 , 24 , 1 ) ;
primitive ( 275 , 24 , 2 ) ;
primitive ( 920 , 24 , 3 ) ;
primitive ( 921 , 22 , 0 ) ;
primitive ( 922 , 22 , 1 ) ;
primitive ( 936 , 23 , 0 ) ;
primitive ( 937 , 23 , 1 ) ;
primitive ( 938 , 23 , 2 ) ;
primitive ( 939 , 23 , 3 ) ;
primitive ( 940 , 23 , 4 ) ;
primitive ( 957 , 69 , 1 ) ;
primitive ( 958 , 69 , 0 ) ;
primitive ( 959 , 69 , 2 ) ;
primitive ( 960 , 67 , 6 ) ;
primitive ( 961 , 67 , 16 ) ;
primitive ( 962 , 68 , 0 ) ;
primitive ( 963 , 68 , 1 ) ;
primitive ( 993 , 26 , 0 ) ;
primitive ( 994 , 26 , 1 ) ;
primitive ( 995 , 26 , 2 ) ;
primitive ( 1005 , 21 , 0 ) ;
primitive ( 1006 , 21 , 1 ) ;
primitive ( 1007 , 21 , 2 ) ;
primitive ( 1008 , 21 , 3 ) ;
primitive ( 1009 , 21 , 4 ) ;
primitive ( 1027 , 77 , 0 ) ;
primitive ( 1028 , 77 , 1 ) ;
primitive ( 1029 , 77 , 5 ) ;
primitive ( 1030 , 77 , 2 ) ;
primitive ( 1031 , 77 , 6 ) ;
primitive ( 1032 , 77 , 3 ) ;
primitive ( 1033 , 77 , 7 ) ;
primitive ( 1034 , 77 , 11 ) ;
primitive ( 1035 , 77 , 128 ) ;
primitive ( 1060 , 30 , 4 ) ;
primitive ( 1061 , 30 , 16 ) ;
}
void
inittab ( void )
{
integer k ;
rover = 23 ;
mem [rover ].hhfield .v.RH = 268435455L ;
mem [rover ].hhfield .lhfield = 1000 ;
mem [rover + 1 ].hhfield .lhfield = rover ;
mem [rover + 1 ].hhfield .v.RH = rover ;
lomemmax = rover + 1000 ;
mem [lomemmax ].hhfield .v.RH = 0 ;
mem [lomemmax ].hhfield .lhfield = 0 ;
{register integer for_end; k = memtop - 2 ;for_end = memtop ; if ( k <=
for_end) do
mem [k ]= mem [lomemmax ];
while ( k++ < for_end ) ;}
avail = 0 ;
memend = memtop ;
himemmin = memtop - 2 ;
varused = 23 ;
dynused = memtop + 1 - himemmin ;
intname [1 ]= 409 ;
intname [2 ]= 410 ;
intname [3 ]= 411 ;
intname [4 ]= 412 ;
intname [5 ]= 413 ;
intname [6 ]= 414 ;
intname [7 ]= 415 ;
intname [8 ]= 416 ;
intname [9 ]= 417 ;
intname [10 ]= 418 ;
intname [11 ]= 419 ;
intname [12 ]= 420 ;
intname [13 ]= 421 ;
intname [14 ]= 422 ;
intname [15 ]= 423 ;
intname [16 ]= 424 ;
intname [17 ]= 425 ;
intname [18 ]= 426 ;
intname [19 ]= 427 ;
intname [20 ]= 428 ;
intname [21 ]= 429 ;
intname [22 ]= 430 ;
intname [23 ]= 431 ;
intname [24 ]= 432 ;
intname [25 ]= 433 ;
intname [26 ]= 434 ;
intname [27 ]= 435 ;
intname [28 ]= 436 ;
intname [29 ]= 437 ;
intname [30 ]= 438 ;
intname [31 ]= 439 ;
intname [32 ]= 440 ;
intname [33 ]= 441 ;
intname [34 ]= 442 ;
intname [35 ]= 443 ;
intname [36 ]= 444 ;
intname [37 ]= 445 ;
intname [38 ]= 446 ;
intname [39 ]= 447 ;
intname [40 ]= 448 ;
intname [41 ]= 449 ;
hashused = 9757 ;
stcount = 0 ;
hash [9768 ].v.RH = 451 ;
hash [9766 ].v.RH = 452 ;
hash [9767 ].v.RH = 453 ;
hash [9765 ].v.RH = 454 ;
hash [9764 ].v.RH = 455 ;
hash [9763 ].v.RH = 59 ;
hash [9762 ].v.RH = 58 ;
hash [9761 ].v.RH = 47 ;
hash [9760 ].v.RH = 91 ;
hash [9759 ].v.RH = 41 ;
hash [9757 ].v.RH = 456 ;
eqtb [9759 ].lhfield = 63 ;
mem [19 ].hhfield .lhfield = 9770 ;
mem [19 ].hhfield .v.RH = 0 ;
mem [memtop ].hhfield .lhfield = 268435455L ;
mem [3 ].hhfield .lhfield = 0 ;
mem [3 ].hhfield .v.RH = 0 ;
mem [4 ].hhfield .lhfield = 1 ;
mem [4 ].hhfield .v.RH = 0 ;
{register integer for_end; k = 5 ;for_end = 11 ; if ( k <= for_end) do
mem [k ]= mem [4 ];
while ( k++ < for_end ) ;}
mem [12 ].cint = 0 ;
mem [0 ].hhfield .v.RH = 0 ;
mem [0 ].hhfield .lhfield = 0 ;
mem [1 ].cint = 0 ;
mem [2 ].cint = 0 ;
serialno = 0 ;
mem [13 ].hhfield .v.RH = 13 ;
mem [14 ].hhfield .lhfield = 13 ;
mem [13 ].hhfield .lhfield = 0 ;
mem [14 ].hhfield .v.RH = 0 ;
mem [21 ].hhfield .b1 = 0 ;
mem [21 ].hhfield .v.RH = 9768 ;
eqtb [9768 ].v.RH = 21 ;
eqtb [9768 ].lhfield = 42 ;
eqtb [9758 ].lhfield = 92 ;
hash [9758 ].v.RH = 736 ;
mem [17 ].hhfield .b1 = 11 ;
mem [20 ].cint = 1073741824L ;
mem [16 ].cint = 0 ;
mem [15 ].hhfield .lhfield = 0 ;
if ( iniversion )
baseident = 1070 ;
}
#endif /* INIMF */
void mainbody( void ) {
bounddefault = 250000L ;
boundname = "main_memory" ;
setupboundvariable ( addressof ( mainmemory ) , boundname , bounddefault ) ;
bounddefault = 3000 ;
boundname = "buf_size" ;
setupboundvariable ( addressof ( bufsize ) , boundname , bounddefault ) ;
bounddefault = 79 ;
boundname = "error_line" ;
setupboundvariable ( addressof ( errorline ) , boundname , bounddefault ) ;
bounddefault = 50 ;
boundname = "half_error_line" ;
setupboundvariable ( addressof ( halferrorline ) , boundname , bounddefault
) ;
bounddefault = 79 ;
boundname = "max_print_line" ;
setupboundvariable ( addressof ( maxprintline ) , boundname , bounddefault )
;
bounddefault = 768 ;
boundname = "screen_width" ;
setupboundvariable ( addressof ( screenwidth ) , boundname , bounddefault )
;
bounddefault = 1024 ;
boundname = "screen_depth" ;
setupboundvariable ( addressof ( screendepth ) , boundname , bounddefault )
;
bounddefault = 16384 ;
boundname = "gf_buf_size" ;
setupboundvariable ( addressof ( gfbufsize ) , boundname , bounddefault ) ;
if ( errorline > 255 )
errorline = 255 ;
if ( screenwidth > 32767 )
screenwidth = 32767 ;
if ( screendepth > 32767 )
screendepth = 32767 ;
{
if ( mainmemory < infmainmemory )
mainmemory = infmainmemory ;
else if ( mainmemory > supmainmemory )
mainmemory = supmainmemory ;
}
memtop = 0 + mainmemory - 1 ;
memmax = memtop ;
{
if ( bufsize < infbufsize )
bufsize = infbufsize ;
else if ( bufsize > supbufsize )
bufsize = supbufsize ;
}
buffer = xmallocarray ( ASCIIcode , bufsize ) ;
rowtransition = xmallocarray ( screencol , screenwidth ) ;
gfbuf = xmallocarray ( eightbits , gfbufsize ) ;
sourcefilenamestack = xmallocarray ( strnumber , 15 ) ;
fullsourcefilenamestack = xmallocarray ( strnumber , 15 ) ;
#ifdef INIMF
if ( iniversion )
{
mem = xmallocarray ( memoryword , memtop + 1 ) ;
}
#endif /* INIMF */
mfluabeginprogram () ;
history = 3 ;
if ( readyalready == 314159L )
goto lab1 ;
bad = 0 ;
if ( ( halferrorline < 30 ) || ( halferrorline > errorline - 15 ) )
bad = 1 ;
if ( maxprintline < 60 )
bad = 2 ;
if ( gfbufsize % 8 != 0 )
bad = 3 ;
if ( 1100 > memtop )
bad = 4 ;
if ( 7919 > 9500 )
bad = 5 ;
if ( headersize % 4 != 0 )
bad = 6 ;
if ( ( ligtablesize < 255 ) || ( ligtablesize > 32510 ) )
bad = 7 ;
#ifdef INIMF
if ( memmax != memtop )
bad = 10 ;
#endif /* INIMF */
if ( memmax < memtop )
bad = 10 ;
if ( ( 0 > 0 ) || ( 255 < 127 ) )
bad = 11 ;
if ( ( 0 > 0 ) || ( 268435455L < 32767 ) )
bad = 12 ;
if ( ( 0 < 0 ) || ( 255 > 268435455L ) )
bad = 13 ;
if ( ( 0 < 0 ) || ( memmax >= 268435455L ) )
bad = 14 ;
if ( maxstrings > 268435455L )
bad = 15 ;
if ( bufsize > 268435455L )
bad = 16 ;
if ( ( 255 < 255 ) || ( 268435455L < 65535L ) )
bad = 17 ;
if ( 9769 + maxinternal > 268435455L )
bad = 21 ;
if ( 10220 > 268435455L )
bad = 22 ;
if ( 15 * 11 > bistacksize )
bad = 31 ;
if ( 20 + 17 * 45 > bistacksize )
bad = 32 ;
if ( basedefaultlength > maxint )
bad = 41 ;
if ( bad > 0 )
{
fprintf ( stdout , "%s%s%ld\n", "Ouch---my internal constants have been clobbered!" , "---case " , (long)bad ) ;
goto lab9999 ;
}
initialize () ;
#ifdef INIMF
if ( iniversion )
{
if ( ! getstringsstarted () )
goto lab9999 ;
inittab () ;
initprim () ;
initstrptr = strptr ;
initpoolptr = poolptr ;
maxstrptr = strptr ;
maxpoolptr = poolptr ;
fixdateandtime () ;
}
#endif /* INIMF */
readyalready = 314159L ;
mfluaPREstartofMF () ;
lab1: selector = 1 ;
tally = 0 ;
termoffset = 0 ;
fileoffset = 0 ;
fprintf ( stdout , "%s%s", "This is MFLua, Version 2.7182818" , "-0.5" ) ;
Fputs ( stdout , versionstring ) ;
if ( baseident == 0 )
fprintf ( stdout , "%s%s%c\n", " (preloaded base=" , dumpname , ')' ) ;
else {
slowprint ( baseident ) ;
println () ;
}
if ( translatefilename )
{
putc ( '(' , stdout );
fputs ( translatefilename , stdout ) ;
{ putc ( ')' , stdout ); putc ( '\n', stdout ); }
}
fflush ( stdout ) ;
jobname = 0 ;
logopened = false ;
outputfilename = 0 ;
{
{
inputptr = 0 ;
maxinstack = 0 ;
inopen = 0 ;
openparens = 0 ;
maxbufstack = 0 ;
paramptr = 0 ;
maxparamstack = 0 ;
first = 1 ;
curinput .startfield = 1 ;
curinput .indexfield = 0 ;
line = 0 ;
curinput .namefield = 0 ;
forceeof = false ;
if ( ! initterminal () )
goto lab9999 ;
curinput .limitfield = last ;
first = last + 1 ;
}
scannerstatus = 0 ;
if ( ( baseident == 0 ) || ( buffer [curinput .locfield ]== 38 ) )
{
if ( baseident != 0 )
initialize () ;
if ( ! openbasefile () )
goto lab9999 ;
if ( ! loadbasefile () )
{
wclose ( basefile ) ;
goto lab9999 ;
}
wclose ( basefile ) ;
while ( ( curinput .locfield < curinput .limitfield ) && ( buffer [
curinput .locfield ]== 32 ) ) incr ( curinput .locfield ) ;
}
buffer [curinput .limitfield ]= 37 ;
fixdateandtime () ;
initrandoms ( ( internal [17 ]/ 65536L ) + internal [16 ]) ;
if ( interaction == 0 )
selector = 0 ;
else selector = 1 ;
if ( curinput .locfield < curinput .limitfield ) {
if ( buffer [curinput .locfield ]!= 92 )
startinput () ;
}
}
history = 0 ;
mfluainitialize () ;
if ( startsym > 0 )
{
cursym = startsym ;
backinput () ;
}
mfluaPREmaincontrol () ;
maincontrol () ;
mfluaPOSTmaincontrol () ;
finalcleanup () ;
mfluaPOSTfinalcleanup () ;
closefilesandterminate () ;
lab9999: {
fflush ( stdout ) ;
readyalready = 0 ;
if ( ( history != 0 ) && ( history != 1 ) )
uexit ( 1 ) ;
else uexit ( 0 ) ;
}
}
/* 30 10 */ register boolean Result; unsigned char k, l ;
strnumber g ;
poolptr = 0 ;
strptr = 0 ;
maxpoolptr = 0 ;
maxstrptr = 0 ;
strstart [0 ]= 0 ;
{register integer for_end; k = 0 ;for_end = 255 ; if ( k <= for_end) do
{
if ( ( ( k < 32 ) || ( k > 126 ) ) )
{
{
strpool [poolptr ]= 94 ;
incr ( poolptr ) ;
}
{
strpool [poolptr ]= 94 ;
incr ( poolptr ) ;
}
if ( k < 64 )
{
strpool [poolptr ]= k + 64 ;
incr ( poolptr ) ;
}
else if ( k < 128 )
{
strpool [poolptr ]= k - 64 ;
incr ( poolptr ) ;
}
else {
l = k / 16 ;
if ( l < 10 )
{
strpool [poolptr ]= l + 48 ;
incr ( poolptr ) ;
}
else {
strpool [poolptr ]= l + 87 ;
incr ( poolptr ) ;
}
l = k % 16 ;
if ( l < 10 )
{
strpool [poolptr ]= l + 48 ;
incr ( poolptr ) ;
}
else {
strpool [poolptr ]= l + 87 ;
incr ( poolptr ) ;
}
}
}
else {
strpool [poolptr ]= k ;
incr ( poolptr ) ;
}
g = makestring () ;
strref [g ]= 127 ;
}
while ( k++ < for_end ) ;}
g = loadpoolstrings ( ( poolsize - stringvacancies ) ) ;
if ( g == 0 )
{
;
fprintf ( stdout , "%s\n", "! You have to increase POOLSIZE." ) ;
Result = false ;
goto lab10 ;
}
Result = true ;
lab10: ;
return Result ;
}
#endif /* INIMF */
#ifdef INIMF
void
sortavail ( void )
{
halfword p, q, r ;
halfword oldrover ;
p = getnode ( 1073741824L ) ;
p = mem [rover + 1 ].hhfield .v.RH ;
mem [rover + 1 ].hhfield .v.RH = 268435455L ;
oldrover = rover ;
while ( p != oldrover ) if ( p < rover )
{
q = p ;
p = mem [q + 1 ].hhfield .v.RH ;
mem [q + 1 ].hhfield .v.RH = rover ;
rover = q ;
}
else {
q = rover ;
while ( mem [q + 1 ].hhfield .v.RH < p ) q = mem [q + 1 ].hhfield
.v.RH ;
r = mem [p + 1 ].hhfield .v.RH ;
mem [p + 1 ].hhfield .v.RH = mem [q + 1 ].hhfield .v.RH ;
mem [q + 1 ].hhfield .v.RH = p ;
p = r ;
}
p = rover ;
while ( mem [p + 1 ].hhfield .v.RH != 268435455L ) {
mem [mem [p + 1 ].hhfield .v.RH + 1 ].hhfield .lhfield = p ;
p = mem [p + 1 ].hhfield .v.RH ;
}
mem [p + 1 ].hhfield .v.RH = rover ;
mem [rover + 1 ].hhfield .lhfield = p ;
}
#endif /* INIMF */
#ifdef INIMF
void
zprimitive ( strnumber s , halfword c , halfword o )
{
poolpointer k ;
smallnumber j ;
smallnumber l ;
k = strstart [s ];
l = strstart [s + 1 ]- k ;
{register integer for_end; j = 0 ;for_end = l - 1 ; if ( j <= for_end) do
buffer [j ]= strpool [k + j ];
while ( j++ < for_end ) ;}
cursym = idlookup ( 0 , l ) ;
if ( s >= 256 )
{
flushstring ( strptr - 1 ) ;
hash [cursym ].v.RH = s ;
}
eqtb [cursym ].lhfield = c ;
eqtb [cursym ].v.RH = o ;
}
#endif /* INIMF */
#ifdef INIMF
void
storebasefile ( void )
{
integer k ;
halfword p, q ;
integer x ;
fourquarters w ;
ASCIIcode * baseengine ;
selector = 5 ;
print ( 1074 ) ;
print ( jobname ) ;
printchar ( 32 ) ;
printint ( roundunscaled ( internal [14 ]) ) ;
printchar ( 46 ) ;
printint ( roundunscaled ( internal [15 ]) ) ;
printchar ( 46 ) ;
printint ( roundunscaled ( internal [16 ]) ) ;
printchar ( 41 ) ;
if ( interaction == 0 )
selector = 2 ;
else selector = 3 ;
{
if ( poolptr + 1 > maxpoolptr )
{
if ( poolptr + 1 > poolsize )
overflow ( 257 , poolsize - initpoolptr ) ;
maxpoolptr = poolptr + 1 ;
}
}
baseident = makestring () ;
strref [baseident ]= 127 ;
packjobname ( 743 ) ;
while ( ! wopenout ( basefile ) ) promptfilename ( 1075 , 743 ) ;
printnl ( 1076 ) ;
slowprint ( wmakenamestring ( basefile ) ) ;
flushstring ( strptr - 1 ) ;
printnl ( 261 ) ;
slowprint ( baseident ) ;
dumpint ( 1462914374L ) ;
x = strlen ( enginename ) ;
baseengine = xmallocarray ( ASCIIcode , x + 4 ) ;
strcpy ( stringcast ( baseengine ) , enginename ) ;
{register integer for_end; k = x ;for_end = x + 3 ; if ( k <= for_end) do
baseengine [k ]= 0 ;
while ( k++ < for_end ) ;}
x = x + 4 - ( x % 4 ) ;
dumpint ( x ) ;
dumpthings ( baseengine [0 ], x ) ;
libcfree ( baseengine ) ;
dumpint ( 228418379L ) ;
dumpthings ( xord [0 ], 256 ) ;
dumpthings ( xchr [0 ], 256 ) ;
dumpthings ( xprn [0 ], 256 ) ;
dumpint ( 0 ) ;
dumpint ( memtop ) ;
dumpint ( 9500 ) ;
dumpint ( 7919 ) ;
dumpint ( 15 ) ;
dumpint ( poolptr ) ;
dumpint ( strptr ) ;
{register integer for_end; k = 0 ;for_end = strptr ; if ( k <= for_end) do
dumpint ( strstart [k ]) ;
while ( k++ < for_end ) ;}
k = 0 ;
while ( k + 4 < poolptr ) {
w .b0 = strpool [k ];
w .b1 = strpool [k + 1 ];
w .b2 = strpool [k + 2 ];
w .b3 = strpool [k + 3 ];
dumpqqqq ( w ) ;
k = k + 4 ;
}
k = poolptr - 4 ;
w .b0 = strpool [k ];
w .b1 = strpool [k + 1 ];
w .b2 = strpool [k + 2 ];
w .b3 = strpool [k + 3 ];
dumpqqqq ( w ) ;
println () ;
printint ( strptr ) ;
print ( 1071 ) ;
printint ( poolptr ) ;
sortavail () ;
varused = 0 ;
dumpint ( lomemmax ) ;
dumpint ( rover ) ;
p = 0 ;
q = rover ;
x = 0 ;
do {
{ register integer for_end; k = p ;for_end = q + 1 ; if ( k <=
for_end) do
dumpwd ( mem [k ]) ;
while ( k++ < for_end ) ;}
x = x + q + 2 - p ;
varused = varused + q - p ;
p = q + mem [q ].hhfield .lhfield ;
q = mem [q + 1 ].hhfield .v.RH ;
} while ( ! ( q == rover ) ) ;
varused = varused + lomemmax - p ;
dynused = memend + 1 - himemmin ;
{register integer for_end; k = p ;for_end = lomemmax ; if ( k <= for_end)
do
dumpwd ( mem [k ]) ;
while ( k++ < for_end ) ;}
x = x + lomemmax + 1 - p ;
dumpint ( himemmin ) ;
dumpint ( avail ) ;
{register integer for_end; k = himemmin ;for_end = memend ; if ( k <=
for_end) do
dumpwd ( mem [k ]) ;
while ( k++ < for_end ) ;}
x = x + memend + 1 - himemmin ;
p = avail ;
while ( p != 0 ) {
decr ( dynused ) ;
p = mem [p ].hhfield .v.RH ;
}
dumpint ( varused ) ;
dumpint ( dynused ) ;
println () ;
printint ( x ) ;
print ( 1072 ) ;
printint ( varused ) ;
printchar ( 38 ) ;
printint ( dynused ) ;
dumpint ( hashused ) ;
stcount = 9756 - hashused ;
{register integer for_end; p = 1 ;for_end = hashused ; if ( p <= for_end)
do
if ( hash [p ].v.RH != 0 )
{
dumpint ( p ) ;
dumphh ( hash [p ]) ;
dumphh ( eqtb [p ]) ;
incr ( stcount ) ;
}
while ( p++ < for_end ) ;}
{register integer for_end; p = hashused + 1 ;for_end = 9769 ; if ( p <=
for_end) do
{
dumphh ( hash [p ]) ;
dumphh ( eqtb [p ]) ;
}
while ( p++ < for_end ) ;}
dumpint ( stcount ) ;
println () ;
printint ( stcount ) ;
print ( 1073 ) ;
dumpint ( intptr ) ;
{register integer for_end; k = 1 ;for_end = intptr ; if ( k <= for_end) do
{
dumpint ( internal [k ]) ;
dumpint ( intname [k ]) ;
}
while ( k++ < for_end ) ;}
dumpint ( startsym ) ;
dumpint ( interaction ) ;
dumpint ( baseident ) ;
dumpint ( bgloc ) ;
dumpint ( egloc ) ;
dumpint ( serialno ) ;
dumpint ( 69069L ) ;
internal [12 ]= 0 ;
wclose ( basefile ) ;
}
#endif /* INIMF */
boolean
loadbasefile ( void )
{
/* 6666 10 */ register boolean Result; integer k ;
halfword p, q ;
integer x ;
fourquarters w ;
ASCIIcode * baseengine ;
ASCIIcode dummyxord ;
ASCIIcode dummyxchr ;
ASCIIcode dummyxprn ;
undumpint ( x ) ;
if ( x != 1462914374L )
goto lab6666 ;
undumpint ( x ) ;
if ( ( x < 0 ) || ( x > 256 ) )
goto lab6666 ;
baseengine = xmallocarray ( ASCIIcode , x ) ;
undumpthings ( baseengine [0 ], x ) ;
baseengine [x - 1 ]= 0 ;
if ( strcmp ( enginename , stringcast ( baseengine ) ) )
{
;
fprintf ( stdout , "%s%s%s%s\n", "---! " , stringcast ( nameoffile + 1 ) , " was written by " , stringcast ( baseengine ) ) ;
libcfree ( baseengine ) ;
goto lab6666 ;
}
libcfree ( baseengine ) ;
undumpint ( x ) ;
if ( x != 228418379L )
{
;
fprintf ( stdout , "%s%s%s%s\n", "---! " , stringcast ( nameoffile + 1 ) , " doesn't match " , poolname ) ;
goto lab6666 ;
}
if ( translatefilename )
{
{register integer for_end; k = 0 ;for_end = 255 ; if ( k <= for_end) do
undumpthings ( dummyxord , 1 ) ;
while ( k++ < for_end ) ;}
{register integer for_end; k = 0 ;for_end = 255 ; if ( k <= for_end) do
undumpthings ( dummyxchr , 1 ) ;
while ( k++ < for_end ) ;}
{register integer for_end; k = 0 ;for_end = 255 ; if ( k <= for_end) do
undumpthings ( dummyxprn , 1 ) ;
while ( k++ < for_end ) ;}
}
else {
undumpthings ( xord [0 ], 256 ) ;
undumpthings ( xchr [0 ], 256 ) ;
undumpthings ( xprn [0 ], 256 ) ;
if ( eightbitp )
{register integer for_end; k = 0 ;for_end = 255 ; if ( k <= for_end) do
xprn [k ]= 1 ;
while ( k++ < for_end ) ;}
}
undumpint ( x ) ;
if ( x != 0 )
goto lab6666 ;
;
#ifdef INIMF
if ( iniversion )
{
libcfree ( mem ) ;
}
#endif /* INIMF */
undumpint ( memtop ) ;
if ( memmax < memtop )
memmax = memtop ;
if ( 1100 > memtop )
goto lab6666 ;
mem = xmallocarray ( memoryword , memmax + 1 ) ;
undumpint ( x ) ;
if ( x != 9500 )
goto lab6666 ;
undumpint ( x ) ;
if ( x != 7919 )
goto lab6666 ;
undumpint ( x ) ;
if ( x != 15 )
goto lab6666 ;
{
undumpint ( x ) ;
if ( x < 0 )
goto lab6666 ;
if ( x > poolsize )
{
;
fprintf ( stdout , "%s%s\n", "---! Must increase the " , "string pool size" ) ;
goto lab6666 ;
}
else poolptr = x ;
}
{
undumpint ( x ) ;
if ( x < 0 )
goto lab6666 ;
if ( x > maxstrings )
{
;
fprintf ( stdout , "%s%s\n", "---! Must increase the " , "max strings" ) ;
goto lab6666 ;
}
else strptr = x ;
}
{register integer for_end; k = 0 ;for_end = strptr ; if ( k <= for_end) do
{
{
undumpint ( x ) ;
if ( ( x < 0 ) || ( x > poolptr ) )
goto lab6666 ;
else strstart [k ]= x ;
}
strref [k ]= 127 ;
}
while ( k++ < for_end ) ;}
k = 0 ;
while ( k + 4 < poolptr ) {
undumpqqqq ( w ) ;
strpool [k ]= w .b0 ;
strpool [k + 1 ]= w .b1 ;
strpool [k + 2 ]= w .b2 ;
strpool [k + 3 ]= w .b3 ;
k = k + 4 ;
}
k = poolptr - 4 ;
undumpqqqq ( w ) ;
strpool [k ]= w .b0 ;
strpool [k + 1 ]= w .b1 ;
strpool [k + 2 ]= w .b2 ;
strpool [k + 3 ]= w .b3 ;
initstrptr = strptr ;
initpoolptr = poolptr ;
maxstrptr = strptr ;
maxpoolptr = poolptr ;
{
undumpint ( x ) ;
if ( ( x < 1022 ) || ( x > memtop - 3 ) )
goto lab6666 ;
else lomemmax = x ;
}
{
undumpint ( x ) ;
if ( ( x < 23 ) || ( x > lomemmax ) )
goto lab6666 ;
else rover = x ;
}
p = 0 ;
q = rover ;
do {
{ register integer for_end; k = p ;for_end = q + 1 ; if ( k <=
for_end) do
undumpwd ( mem [k ]) ;
while ( k++ < for_end ) ;}
p = q + mem [q ].hhfield .lhfield ;
if ( ( p > lomemmax ) || ( ( q >= mem [q + 1 ].hhfield .v.RH ) && ( mem
[q + 1 ].hhfield .v.RH != rover ) ) )
goto lab6666 ;
q = mem [q + 1 ].hhfield .v.RH ;
} while ( ! ( q == rover ) ) ;
{register integer for_end; k = p ;for_end = lomemmax ; if ( k <= for_end)
do
undumpwd ( mem [k ]) ;
while ( k++ < for_end ) ;}
{
undumpint ( x ) ;
if ( ( x < lomemmax + 1 ) || ( x > memtop - 2 ) )
goto lab6666 ;
else himemmin = x ;
}
{
undumpint ( x ) ;
if ( ( x < 0 ) || ( x > memtop ) )
goto lab6666 ;
else avail = x ;
}
memend = memtop ;
{register integer for_end; k = himemmin ;for_end = memend ; if ( k <=
for_end) do
undumpwd ( mem [k ]) ;
while ( k++ < for_end ) ;}
undumpint ( varused ) ;
undumpint ( dynused ) ;
{
undumpint ( x ) ;
if ( ( x < 1 ) || ( x > 9757 ) )
goto lab6666 ;
else hashused = x ;
}
p = 0 ;
do {
{
undumpint ( x ) ;
if ( ( x < p + 1 ) || ( x > hashused ) )
goto lab6666 ;
else p = x ;
}
undumphh ( hash [p ]) ;
undumphh ( eqtb [p ]) ;
} while ( ! ( p == hashused ) ) ;
{register integer for_end; p = hashused + 1 ;for_end = 9769 ; if ( p <=
for_end) do
{
undumphh ( hash [p ]) ;
undumphh ( eqtb [p ]) ;
}
while ( p++ < for_end ) ;}
undumpint ( stcount ) ;
{
undumpint ( x ) ;
if ( ( x < 41 ) || ( x > maxinternal ) )
goto lab6666 ;
else intptr = x ;
}
{register integer for_end; k = 1 ;for_end = intptr ; if ( k <= for_end) do
{
undumpint ( internal [k ]) ;
{
undumpint ( x ) ;
if ( ( x < 0 ) || ( x > strptr ) )
goto lab6666 ;
else intname [k ]= x ;
}
}
while ( k++ < for_end ) ;}
{
undumpint ( x ) ;
if ( ( x < 0 ) || ( x > 9757 ) )
goto lab6666 ;
else startsym = x ;
}
{
undumpint ( x ) ;
if ( ( x < 0 ) || ( x > 3 ) )
goto lab6666 ;
else interaction = x ;
}
if ( interactionoption != 4 )
interaction = interactionoption ;
{
undumpint ( x ) ;
if ( ( x < 0 ) || ( x > strptr ) )
goto lab6666 ;
else baseident = x ;
}
{
undumpint ( x ) ;
if ( ( x < 1 ) || ( x > 9769 ) )
goto lab6666 ;
else bgloc = x ;
}
{
undumpint ( x ) ;
if ( ( x < 1 ) || ( x > 9769 ) )
goto lab6666 ;
else egloc = x ;
}
undumpint ( serialno ) ;
undumpint ( x ) ;
if ( x != 69069L )
goto lab6666 ;
Result = true ;
goto lab10 ;
lab6666: ;
fprintf ( stdout , "%s\n", "(Fatal base file error; I'm stymied)" ) ;
Result = false ;
lab10: ;
return Result ;
}
static void
spread_internal (gfc_array_char *ret, const gfc_array_char *source,
const index_type *along, const index_type *pncopies)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rdelta = 0;
index_type rrank;
index_type rs;
char *rptr;
char *dest;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
index_type srank;
const char *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ncopies;
index_type size;
size = GFC_DESCRIPTOR_SIZE(source);
srank = GFC_DESCRIPTOR_RANK(source);
rrank = srank + 1;
if (rrank > GFC_MAX_DIMENSIONS)
runtime_error ("return rank too large in spread()");
if (*along > rrank)
runtime_error ("dim outside of rank in spread()");
ncopies = *pncopies;
if (ret->base_addr == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
size_t ub, stride;
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
stride = rs;
if (n == *along - 1)
{
ub = ncopies - 1;
rdelta = rs * size;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
rstride[dim] = rs * size;
ub = extent[dim]-1;
rs *= extent[dim];
dim++;
}
GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
}
ret->offset = 0;
ret->base_addr = xmallocarray (rs, size);
if (rs <= 0)
return;
}
else
{
int zero_sized;
zero_sized = 0;
dim = 0;
if (GFC_DESCRIPTOR_RANK(ret) != rrank)
runtime_error ("rank mismatch in spread()");
if (compile_options.bounds_check)
{
for (n = 0; n < rrank; n++)
{
index_type ret_extent;
ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
if (n == *along - 1)
{
rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
if (ret_extent != ncopies)
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent, (long int) ncopies);
}
else
{
count[dim] = 0;
extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
if (ret_extent != extent[dim])
runtime_error("Incorrect extent in return value of SPREAD"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", (long int) n+1,
(long int) ret_extent,
(long int) extent[dim]);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == *along - 1)
{
rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
}
else
{
count[dim] = 0;
extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
dim++;
}
}
}
if (zero_sized)
return;
if (sstride[0] == 0)
sstride[0] = size;
}
sstride0 = sstride[0];
rstride0 = rstride[0];
rptr = ret->base_addr;
sptr = source->base_addr;
while (sptr)
{
/* Spread this element. */
dest = rptr;
for (n = 0; n < ncopies; n++)
{
memcpy (dest, sptr, size);
dest += rdelta;
}
/* Advance to the next element. */
sptr += sstride0;
rptr += rstride0;
count[0]++;
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
sptr -= sstride[n] * extent[n];
rptr -= rstride[n] * extent[n];
n++;
if (n >= srank)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
rptr += rstride[n];
}
}
}
}
static void
pack_s_internal (gfc_array_char *ret, const gfc_array_char *array,
const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,
index_type size)
{
/* r.* indicates the return array. */
index_type rstride0;
char *rptr;
/* s.* indicates the source array. */
index_type sstride[GFC_MAX_DIMENSIONS];
index_type sstride0;
const char *sptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type ssize;
index_type nelem;
index_type total;
dim = GFC_DESCRIPTOR_RANK (array);
/* Initialize sstride[0] to avoid -Wmaybe-uninitialized
complaints. */
sstride[0] = size;
ssize = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
ssize *= extent[n];
}
if (sstride[0] == 0)
sstride[0] = size;
sstride0 = sstride[0];
if (ssize != 0)
sptr = array->base_addr;
else
sptr = NULL;
if (ret->base_addr == NULL)
{
/* Allocate the memory for the result. */
if (vector != NULL)
{
/* The return array will have as many elements as there are
in vector. */
total = GFC_DESCRIPTOR_EXTENT(vector,0);
if (total <= 0)
{
total = 0;
vector = NULL;
}
}
else
{
if (*mask)
{
/* The result array will have as many elements as the input
array. */
total = extent[0];
for (n = 1; n < dim; n++)
total *= extent[n];
}
else
/* The result array will be empty. */
total = 0;
}
/* Setup the array descriptor. */
GFC_DIMENSION_SET(ret->dim[0],0,total-1,1);
ret->offset = 0;
ret->base_addr = xmallocarray (total, size);
if (total == 0)
return;
}
rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
if (rstride0 == 0)
rstride0 = size;
rptr = ret->base_addr;
/* The remaining possibilities are now:
If MASK is .TRUE., we have to copy the source array into the
result array. We then have to fill it up with elements from VECTOR.
If MASK is .FALSE., we have to copy VECTOR into the result
array. If VECTOR were not present we would have already returned. */
if (*mask && ssize != 0)
{
while (sptr)
{
/* Add this element. */
memcpy (rptr, sptr, size);
rptr += rstride0;
/* Advance to the next element. */
sptr += sstride0;
count[0]++;
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and
increment the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a
less frequently used path so probably not worth it. */
sptr -= sstride[n] * extent[n];
n++;
if (n >= dim)
{
/* Break out of the loop. */
sptr = NULL;
break;
}
else
{
count[n]++;
sptr += sstride[n];
}
}
}
}
/* Add any remaining elements from VECTOR. */
if (vector)
{
n = GFC_DESCRIPTOR_EXTENT(vector,0);
nelem = ((rptr - ret->base_addr) / rstride0);
if (n > nelem)
{
sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
if (sstride0 == 0)
sstride0 = size;
sptr = vector->base_addr + sstride0 * nelem;
n -= nelem;
while (n--)
{
memcpy (rptr, sptr, size);
rptr += rstride0;
sptr += sstride0;
}
}
}
}
GFC_INTEGER_4 *
internal_pack_4 (gfc_array_i4 * source)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type stride[GFC_MAX_DIMENSIONS];
index_type stride0;
index_type dim;
index_type ssize;
const GFC_INTEGER_4 *src;
GFC_INTEGER_4 * restrict dest;
GFC_INTEGER_4 *destptr;
int n;
int packed;
/* TODO: Investigate how we can figure out if this is a temporary
since the stride=0 thing has been removed from the frontend. */
dim = GFC_DESCRIPTOR_RANK (source);
ssize = 1;
packed = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
stride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
if (extent[n] <= 0)
{
/* Do nothing. */
packed = 1;
break;
}
if (ssize != stride[n])
packed = 0;
ssize *= extent[n];
}
if (packed)
return source->base_addr;
/* Allocate storage for the destination. */
destptr = xmallocarray (ssize, sizeof (GFC_INTEGER_4));
dest = destptr;
src = source->base_addr;
stride0 = stride[0];
while (src)
{
/* Copy the data. */
*(dest++) = *src;
/* Advance to the next element. */
src += stride0;
count[0]++;
/* Advance to the next source element. */
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
src -= stride[n] * extent[n];
n++;
if (n == dim)
{
src = NULL;
break;
}
else
{
count[n]++;
src += stride[n];
}
}
}
return destptr;
}
static void
unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
const gfc_array_l1 *mask, const gfc_array_char *field,
index_type size)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rs;
char * restrict rptr;
/* v.* indicates the vector array. */
index_type vstride0;
char *vptr;
/* f.* indicates the field array. */
index_type fstride[GFC_MAX_DIMENSIONS];
index_type fstride0;
const char *fptr;
/* m.* indicates the mask array. */
index_type mstride[GFC_MAX_DIMENSIONS];
index_type mstride0;
const GFC_LOGICAL_1 *mptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
int empty;
int mask_kind;
empty = 0;
mptr = mask->base_addr;
/* Use the same loop for all logical types, by using GFC_LOGICAL_1
and using shifting to address size and endian issues. */
mask_kind = GFC_DESCRIPTOR_SIZE (mask);
if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| mask_kind == 16
#endif
)
{
/* Don't convert a NULL pointer as we use test for NULL below. */
if (mptr)
mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
}
else
runtime_error ("Funny sized logical array");
if (ret->base_addr == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
dim = GFC_DESCRIPTOR_RANK (mask);
rs = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
GFC_DIMENSION_SET(ret->dim[n], 0,
GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
empty = empty || extent[n] <= 0;
rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret, n);
fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
rs *= extent[n];
}
ret->offset = 0;
ret->base_addr = xmallocarray (rs, size);
}
else
{
dim = GFC_DESCRIPTOR_RANK (ret);
for (n = 0; n < dim; n++)
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
empty = empty || extent[n] <= 0;
rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret, n);
fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
}
}
if (empty)
return;
/* This assert makes sure GCC knows we can access *stride[0] later. */
assert (dim > 0);
vstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
rstride0 = rstride[0];
fstride0 = fstride[0];
mstride0 = mstride[0];
rptr = ret->base_addr;
fptr = field->base_addr;
vptr = vector->base_addr;
while (rptr)
{
if (*mptr)
{
/* From vector. */
memcpy (rptr, vptr, size);
vptr += vstride0;
}
else
{
/* From field. */
memcpy (rptr, fptr, size);
}
/* Advance to the next element. */
rptr += rstride0;
fptr += fstride0;
mptr += mstride0;
count[0]++;
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
rptr -= rstride[n] * extent[n];
fptr -= fstride[n] * extent[n];
mptr -= mstride[n] * extent[n];
n++;
if (n >= dim)
{
/* Break out of the loop. */
rptr = NULL;
break;
}
else
{
count[n]++;
rptr += rstride[n];
fptr += fstride[n];
mptr += mstride[n];
}
}
}
}
