conv.c

来自「<B>Digital的Unix操作系统VAX 4.2源码</B>」· C语言 代码 · 共 959 行 · 第 1/2 页

      p = errnode();
      break;
    }

  return (p);
}



LOCAL expptr
cdreal(cp)
Constp cp;
{
  static char *compat1 =
	"logical datum assigned to a double precision variable";
  static char *compat2 =
	"character datum assigned to a double precision variable";

  register expptr p;
  register long *longp;
  register long *rp;

  switch (cp->vtype)
    {
    case TYBITSTR:
      longp = (long *) grabbits(8, cp);
      p = (expptr) mkconst(TYDREAL);
      rp = (long *) &(p->constblock.const.cd[0]);
      rp[0] = longp[0];
      rp[1] = longp[1];
      free((char *) longp);
      break;

    case TYSHORT:
    case TYLONG:
      p = (expptr) mkconst(TYDREAL);
      p->constblock.const.cd[0] = cp->const.ci;
      break;

    case TYREAL:
    case TYDREAL:
    case TYCOMPLEX:
    case TYDCOMPLEX:
      p = (expptr) mkconst(TYDREAL);
      longp = (long *) &(cp->const.cd[0]);
      rp = (long *) &(p->constblock.const.cd[0]);
      rp[0] = longp[0];
      rp[1] = longp[1];
      break;

    case TYLOGICAL:
      if (badvalue <= 1)
	{
	  badvalue = 2;
	  err(compat1);
	}
      p = errnode();
      break;

    case TYCHAR:
      if ( !ftn66flag && badvalue == 0 )
	{
	  badvalue = 1;
	  warn(compat2);
	}

    case TYHOLLERITH:
      longp = (long *) grabbytes(8, cp);
      p = (expptr) mkconst(TYDREAL);
      rp = (long *) &(p->constblock.const.cd[0]);
      rp[0] = longp[0];
      rp[1] = longp[1];
      free((char *) longp);
      break;

    case TYERROR:
      p = errnode();
      break;
    }

  return (p);
}



LOCAL expptr
ccomplex(cp)
Constp cp;
{
  static char *toobig = "data value too large";
  static char *compat1 = "logical datum assigned to a complex variable";
  static char *compat2 = "character datum assigned to a complex variable";

  register expptr p;
  register long *longp;
  register long *rp;
  register double *minp;
  register double *maxp;
  realvalue re, im;
  int overflow;
  float x;

  switch (cp->vtype)
    {
    case TYBITSTR:
      longp = (long *) grabbits(8, cp);
      p = (expptr) mkconst(TYCOMPLEX);
      rp = (long *) &(p->constblock.const.cd[0]);
      rp[0] = longp[0];
      rp[2] = longp[1];
      free((char *) longp);
      break;

    case TYSHORT:
    case TYLONG:
      p = (expptr) mkconst(TYCOMPLEX);
      p->constblock.const.cd[0] = cp->const.ci;
      break;

    case TYREAL:
    case TYDREAL:
    case TYCOMPLEX:
    case TYDCOMPLEX:
      overflow = 0;
      minp = (double *) dminreal;
      maxp = (double *) dmaxreal;
      rp = (long *) &(cp->const.cd[0]);
      re.q.word1 = rp[0];
      re.q.word2 = rp[1];
      im.q.word1 = rp[2];
      im.q.word2 = rp[3];
      if (((re.f.sign == 0 || re.f.exp != 0) &&
	   (re.d < *minp || re.d > *maxp))       ||
	  ((im.f.sign == 0 || re.f.exp != 0) &&
	   (im.d < *minp || re.d > *maxp)))
	{
	  if (badvalue <= 1)
	    {
	      badvalue = 2;
	      err(toobig);
	    }
	  p = errnode();
	}
      else
	{
	  p = (expptr) mkconst(TYCOMPLEX);
	  if (re.f.sign == 1 && re.f.exp == 0)
	    re.q.word2 = 0;
	  else
	    {
	      x = re.d;
	      re.d = x;
	    }
	  if (im.f.sign == 1 && im.f.exp == 0)
	    im.q.word2 = 0;
	  else
	    {
	      x = im.d;
	      im.d = x;
	    }
	  rp = (long *) &(p->constblock.const.cd[0]);
	  rp[0] = re.q.word1;
	  rp[1] = re.q.word2;
	  rp[2] = im.q.word1;
	  rp[3] = im.q.word2;
	}
      break;

    case TYLOGICAL:
      if (badvalue <= 1)
	{
	  badvalue = 2;
	  err(compat1);
	}
      break;

    case TYCHAR:
      if ( !ftn66flag && badvalue == 0)
	{
	  badvalue = 1;
	  warn(compat2);
	}

    case TYHOLLERITH:
      longp = (long *) grabbytes(8, cp);
      p = (expptr) mkconst(TYCOMPLEX);
      rp = (long *) &(p->constblock.const.cd[0]);
      rp[0] = longp[0];
      rp[2] = longp[1];
      free((char *) longp);
      break;

    case TYERROR:
      p = errnode();
      break;
    }

  return (p);
}



LOCAL expptr
cdcomplex(cp)
Constp cp;
{
  static char *compat1 = "logical datum assigned to a complex variable";
  static char *compat2 = "character datum assigned to a complex variable";

  register expptr p;
  register long *longp;
  register long *rp;

  switch (cp->vtype)
    {
    case TYBITSTR:
      longp = (long *) grabbits(16, cp);
      p = (expptr) mkconst(TYDCOMPLEX);
      rp = (long *) &(p->constblock.const.cd[0]);
      rp[0] = longp[0];
      rp[1] = longp[1];
      rp[2] = longp[2];
      rp[3] = longp[3];
      free((char *) longp);
      break;

    case TYSHORT:
    case TYLONG:
      p = (expptr) mkconst(TYDCOMPLEX);
      p->constblock.const.cd[0] = cp->const.ci;
      break;

    case TYREAL:
    case TYDREAL:
    case TYCOMPLEX:
    case TYDCOMPLEX:
      p = (expptr) mkconst(TYDCOMPLEX);
      longp = (long *) &(cp->const.cd[0]);
      rp = (long *) &(p->constblock.const.cd[0]);
      rp[0] = longp[0];
      rp[1] = longp[1];
      rp[2] = longp[2];
      rp[3] = longp[3];
      break;

    case TYLOGICAL:
      if (badvalue <= 1)
	{
	  badvalue = 2;
	  err(compat1);
	}
      p = errnode();
      break;

    case TYCHAR:
      if ( !ftn66flag && badvalue == 0 )
	{
	  badvalue = 1;
	  warn(compat2);
	}

    case TYHOLLERITH:
      longp = (long *) grabbytes(16, cp);
      p = (expptr) mkconst(TYDCOMPLEX);
      rp = (long *) &(p->constblock.const.cd[0]);
      rp[0] = longp[0];
      rp[1] = longp[1];
      rp[2] = longp[2];
      rp[3] = longp[3];
      free((char *) longp);
      break;

    case TYERROR:
      p = errnode();
      break;
    }

  return (p);
}



LOCAL expptr
clogical(cp)
Constp cp;
{
  static char *compat1 = "numeric datum assigned to a logical variable";
  static char *compat2 = "character datum assigned to a logical variable";

  register expptr p;
  register long *longp;
  register short *shortp;
  register int size;

  size = typesize[tylogical];

  switch (cp->vtype)
    {
    case TYBITSTR:
      p = (expptr) mkconst(tylogical);
      if (tylogical == TYSHORT)
	{
	  shortp = (short *) grabbits(size, cp);
	  p->constblock.const.ci = (int) *shortp;
	  free((char *) shortp);
	}
      else
	{
	  longp = (long *) grabbits(size, cp);
	  p->constblock.const.ci = *longp;
	  free((char *) longp);
	}
      break;

    case TYSHORT:
    case TYLONG:
    case TYREAL:
    case TYDREAL:
    case TYCOMPLEX:
    case TYDCOMPLEX:
      if (badvalue <= 1)
	{
	  badvalue = 2;
	  err(compat1);
	}
      p = errnode();
      break;

    case TYLOGICAL:
      p = (expptr) cpexpr(cp);
      p->constblock.vtype = tylogical;
      break;

    case TYCHAR:
      if ( !ftn66flag && badvalue == 0 )
	{
	  badvalue = 1;
	  warn(compat2);
	}

    case TYHOLLERITH:
      p = (expptr) mkconst(tylogical);
      if (tylogical == TYSHORT)
	{
	  shortp = (short *) grabbytes(size, cp);
	  p->constblock.const.ci = (int) *shortp;
	  free((char *) shortp);
	}
      else
	{
	  longp = (long *) grabbytes(4, cp);
	  p->constblock.const.ci = *longp;
	  free((char *) longp);
	}
      break;

    case TYERROR:
      p = errnode();
      break;
    }

  return (p);
}



LOCAL expptr
cchar(len, cp)
int len;
Constp cp;
{
  static char *compat1 = "numeric datum assigned to a character variable";
  static char *compat2 = "logical datum assigned to a character variable";

  register expptr p;
  register char *value;

  switch (cp->vtype)
    {
    case TYBITSTR:
      value = grabbits(len, cp);
      p = (expptr) mkstrcon(len, value);
      free(value);
      break;

    case TYSHORT:
    case TYLONG:
    case TYREAL:
    case TYDREAL:
    case TYCOMPLEX:
    case TYDCOMPLEX:
      if (badvalue <= 1)
	{
	  badvalue = 2;
	  err(compat1);
	}
      p = errnode();
      break;

    case TYLOGICAL:
      if (badvalue <= 1)
	{
	  badvalue = 2;
	  err(compat2);
	}
      p = errnode();
      break;

    case TYCHAR:
    case TYHOLLERITH:
      value = grabbytes(len, cp);
      p = (expptr) mkstrcon(len, value);
      free(value);
      break;

    case TYERROR:
      p = errnode();
      break;
    }

  return (p);
}



expptr
convconst(type, len, const)
int type;
int len;
Constp const;
{
  register expptr p;

  switch (type)
    {
    case TYSHORT:
      p = cshort(const);
      break;

    case TYLONG:
      p = clong(const);
      break;

    case TYREAL:
      p = creal(const);
      break;

    case TYDREAL:
      p = cdreal(const);
      break;

    case TYCOMPLEX:
      p = ccomplex(const);
      break;

    case TYDCOMPLEX:
      p = cdcomplex(const);
      break;

    case TYLOGICAL:
      p = clogical(const);
      break;

    case TYCHAR:
      p = cchar(len, const);
      break;

    case TYERROR:
    case TYUNKNOWN:
      p = errnode();
      break;

    default:
      badtype("convconst", type);
    }

  return (p);
}