自学教程：C++ xmallocarray函数代码示例

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 ();    }}

voidspread_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;    }}

voidstring_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;    }}

voidconvert_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';}

voidstring_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 voidspread_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);    }}

voidunpack0_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;//.........这里部分代码省略.........

voidpack_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)//.........这里部分代码省略.........

static voideoshift0 (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;//.........这里部分代码省略.........

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 ) ) ;//.........这里部分代码省略.........

static voidcshift0 (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://.........这里部分代码省略.........

//.........这里部分代码省略.........# 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;}

//.........这里部分代码省略.........  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 ;

//.........这里部分代码省略.........  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 ;  } 

static voidspread_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"//.........这里部分代码省略.........

static voidpack_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)    {//.........这里部分代码省略.........

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 voidunpack_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;//.........这里部分代码省略.........