예제 #1
0
파일: lread.c 프로젝트: cran/rioja
 static int
l_L(Void)
{
	int ch, rv, sawdot;

	if(f__lcount>0)
		return(0);
	f__lcount = 1;
	f__ltype=0;
	GETC(ch);
	if(isdigit(ch))
	{
		rd_count(ch);
      if(GETC(ch)!='*') {
         if(!f__cf || !feof(f__cf)) {
				errfl(f__elist->cierr,112,"no star");
         }
         else {
				err(f__elist->cierr,(EOF),"lread");
         }
      }
		GETC(ch);
	}
	sawdot = 0;
	if(ch == '.') {
		sawdot = 1;
		GETC(ch);
		}
	switch(ch)
	{
	case 't':
	case 'T':
		if (nml_read && Lfinish(ch, sawdot, &rv))
			return rv;
		f__lx=1;
		break;
	case 'f':
	case 'F':
		if (nml_read && Lfinish(ch, sawdot, &rv))
			return rv;
		f__lx=0;
		break;
	default:
		if(isblnk(ch) || issep(ch) || ch==EOF)
		{	(void) Ungetc(ch,f__cf);
			return(0);
		}
		if (nml_read > 1) {
			Ungetc(ch,f__cf);
			f__lquit = 2;
			return 0;
			}
		errfl(f__elist->cierr,112,"logical");
	}
	f__ltype=TYLONG;
	while(!issep(GETC(ch)) && ch!=EOF);
	Ungetc(ch, f__cf);
	return(0);
}
예제 #2
0
파일: rsne.c 프로젝트: barak/f2c-1
static int getname(register char *s, int slen)
{
	register char *se = s + slen - 1;
	register int ch;

	GETC(ch);
	if (!(*s++ = Alpha[ch & 0xff])) {
		if (ch != EOF)
			ch = 115;
		errfl(f__elist->cierr, ch, "namelist read");
		}
	while(*s = Alphanum[GETC(ch) & 0xff])
		if (s < se)
			s++;
	if (ch == EOF)
		err(f__elist->cierr, EOF, "namelist read");
	if (ch > ' ')
		Ungetc(ch,f__cf);
	return *s = 0;
}
예제 #3
0
파일: fmt.c 프로젝트: SemiSQ/OpenModelica
integer do_fio(ftnint *number, char *ptr, ftnlen len)
#endif
{  struct syl *p;
  int n,i;
  for(i=0;i<*number;i++,ptr+=len)
  {
loop:  switch(type_f((p= &f__syl[f__pc])->op))
  {
  default:
         fprintf(stderr,"unknown code in do_fio: %d\n%s\n",
                p->op,f__fmtbuf);
         err(f__elist->cierr,100,"do_fio");
  case NED:
         if((*f__doned)(p))
         {       f__pc++;
                goto loop;
         }
         f__pc++;
         continue;
  case ED:
         if(f__cnt[f__cp]<=0)
         {       f__cp--;
                f__pc++;
                goto loop;
         }
         if(ptr==NULL)
                return((*f__doend)());
         f__cnt[f__cp]--;
         f__workdone=1;
         if((n=(*f__doed)(p,ptr,len))>0)
                errfl(f__elist->cierr,errno,"fmt");
         if(n<0)
                err(f__elist->ciend,(EOF),"fmt");
         continue;
  case STACK:
         f__cnt[++f__cp]=p->p1;
         f__pc++;
         goto loop;
  case RET1:
         f__ret[++f__rp]=p->p1;
         f__pc++;
         goto loop;
  case GOTO:
         if(--f__cnt[f__cp]<=0)
         {       f__cp--;
                f__rp--;
                f__pc++;
                goto loop;
         }
         f__pc=1+f__ret[f__rp--];
         goto loop;
  case REVERT:
         f__rp=f__cp=0;
         f__pc = p->p1;
         if(ptr==NULL)
                return((*f__doend)());
         if(!f__workdone) return(0);
         if((n=(*f__dorevert)()) != 0) return(n);
         goto loop;
  case COLON:
         if(ptr==NULL)
                return((*f__doend)());
         f__pc++;
         goto loop;
  case NONL:
         f__nonl = 1;
         f__pc++;
         goto loop;
  case S:
  case SS:
         f__cplus=0;
         f__pc++;
         goto loop;
  case SP:
         f__cplus = 1;
         f__pc++;
         goto loop;
  case P:       f__scale=p->p1;
         f__pc++;
         goto loop;
  case BN:
         f__cblank=0;
         f__pc++;
         goto loop;
  case BZ:
         f__cblank=1;
         f__pc++;
         goto loop;
  }
  }
  return(0);
}
예제 #4
0
파일: lread.c 프로젝트: cran/rioja
l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
#endif
{
#define Ptr ((flex *)ptr)
	int i,n,ch;
	doublereal *yy;
	real *xx;
	for(i=0;i<*number;i++)
	{
		if(f__lquit) return(0);
		if(l_eof)
			err(f__elist->ciend, EOF, "list in")
		if(f__lcount == 0) {
			f__ltype = 0;
			for(;;)  {
				GETC(ch);
				switch(ch) {
				case EOF:
					err(f__elist->ciend,(EOF),"list in")
				case ' ':
				case '\t':
				case '\n':
					continue;
				case '/':
					f__lquit = 1;
					goto loopend;
				case ',':
					f__lcount = 1;
					goto loopend;
				default:
					(void) Ungetc(ch, f__cf);
					goto rddata;
				}
			}
		}
	rddata:
		switch((int)type)
		{
		case TYINT1:
		case TYSHORT:
		case TYLONG:
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
			ERR(l_R(0,1));
			break;
#endif
		case TYREAL:
		case TYDREAL:
			ERR(l_R(0,0));
			break;
#ifdef TYQUAD
		case TYQUAD:
			n = l_R(0,2);
			if (n)
				return n;
			break;
#endif
		case TYCOMPLEX:
		case TYDCOMPLEX:
			ERR(l_C());
			break;
		case TYLOGICAL1:
		case TYLOGICAL2:
		case TYLOGICAL:
			ERR(l_L());
			break;
		case TYCHAR:
			ERR(l_CHAR());
			break;
		}
	while (GETC(ch) == ' ' || ch == '\t');
	if (ch != ',' || f__lcount > 1)
		Ungetc(ch,f__cf);
	loopend:
		if(f__lquit) return(0);
		if(f__cf && ferror(f__cf)) {
			clearerr(f__cf);
			errfl(f__elist->cierr,errno,"list in");
			}
		if(f__ltype==0) goto bump;
		switch((int)type)
		{
		case TYINT1:
		case TYLOGICAL1:
			Ptr->flchar = (char)f__lx;
			break;
		case TYLOGICAL2:
		case TYSHORT:
			Ptr->flshort = (short)f__lx;
			break;
		case TYLOGICAL:
		case TYLONG:
			Ptr->flint = (ftnint)f__lx;
			break;
#ifdef Allow_TYQUAD
		case TYQUAD:
			if (!(Ptr->fllongint = f__llx))
				Ptr->fllongint = f__lx;
			break;
#endif
		case TYREAL:
			Ptr->flreal=f__lx;
			break;
		case TYDREAL:
			Ptr->fldouble=f__lx;
			break;
		case TYCOMPLEX:
			xx=(real *)ptr;
			*xx++ = f__lx;
			*xx = f__ly;
			break;
		case TYDCOMPLEX:
			yy=(doublereal *)ptr;
			*yy++ = f__lx;
			*yy = f__ly;
			break;
		case TYCHAR:
			b_char(f__lchar,ptr,len);
			break;
		}
	bump:
		if(f__lcount>0) f__lcount--;
		ptr += len;
		if (nml_read)
			nml_read++;
	}
예제 #5
0
파일: lread.c 프로젝트: cran/rioja
 static int
l_CHAR(Void)
{	int ch,size,i;
	static char rafail[] = "realloc failure";
	char quote,*p;
	if(f__lcount>0) return(0);
	f__ltype=0;
	if(f__lchar!=NULL) free(f__lchar);
	size=BUFSIZE;
	p=f__lchar = (char *)malloc((unsigned int)size);
	if(f__lchar == NULL)
		errfl(f__elist->cierr,113,"no space");

	GETC(ch);
	if(isdigit(ch)) {
		/* allow Fortran 8x-style unquoted string...	*/
		/* either find a repetition count or the string	*/
		f__lcount = ch - '0';
		*p++ = ch;
		for(i = 1;;) {
			switch(GETC(ch)) {
				case '*':
					if (f__lcount == 0) {
						f__lcount = 1;
#ifndef F8X_NML_ELIDE_QUOTES
						if (nml_read)
							goto no_quote;
#endif
						goto noquote;
						}
					p = f__lchar;
					goto have_lcount;
				case ',':
				case ' ':
				case '\t':
				case '\n':
				case '/':
					Ungetc(ch,f__cf);
					/* no break */
				case EOF:
					f__lcount = 1;
					f__ltype = TYCHAR;
					return *p = 0;
				}
			if (!isdigit(ch)) {
				f__lcount = 1;
#ifndef F8X_NML_ELIDE_QUOTES
				if (nml_read) {
 no_quote:
					errfl(f__elist->cierr,112,
						"undelimited character string");
					}
#endif
				goto noquote;
				}
			*p++ = ch;
			f__lcount = 10*f__lcount + ch - '0';
			if (++i == size) {
				f__lchar = (char *)realloc(f__lchar,
					(unsigned int)(size += BUFSIZE));
				if(f__lchar == NULL)
					errfl(f__elist->cierr,113,rafail);
				p = f__lchar + i;
				}
			}
		}
	else	(void) Ungetc(ch,f__cf);
 have_lcount:
	if(GETC(ch)=='\'' || ch=='"') quote=ch;
	else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) {
		Ungetc(ch,f__cf);
		return 0;
		}
#ifndef F8X_NML_ELIDE_QUOTES
	else if (nml_read > 1) {
		Ungetc(ch,f__cf);
		f__lquit = 2;
		return 0;
		}
#endif
	else {
		/* Fortran 8x-style unquoted string */
		*p++ = ch;
		for(i = 1;;) {
			switch(GETC(ch)) {
				case ',':
				case ' ':
				case '\t':
				case '\n':
				case '/':
					Ungetc(ch,f__cf);
					/* no break */
				case EOF:
					f__ltype = TYCHAR;
					return *p = 0;
				}
 noquote:
			*p++ = ch;
			if (++i == size) {
				f__lchar = (char *)realloc(f__lchar,
					(unsigned int)(size += BUFSIZE));
				if(f__lchar == NULL)
					errfl(f__elist->cierr,113,rafail);
				p = f__lchar + i;
				}
			}
		}
	f__ltype=TYCHAR;
	for(i=0;;)
	{	while(GETC(ch)!=quote && ch!='\n'
			&& ch!=EOF && ++i<size) *p++ = ch;
		if(i==size)
		{
		newone:
			f__lchar= (char *)realloc(f__lchar,
					(unsigned int)(size += BUFSIZE));
			if(f__lchar == NULL)
				errfl(f__elist->cierr,113,rafail);
			p=f__lchar+i-1;
			*p++ = ch;
		}
		else if(ch==EOF) return(EOF);
		else if(ch=='\n')
		{	if(*(p-1) != '\\') continue;
			i--;
			p--;
			if(++i<size) *p++ = ch;
			else goto newone;
		}
		else if(GETC(ch)==quote)
		{	if(++i<size) *p++ = ch;
			else goto newone;
		}
		else
		{	(void) Ungetc(ch,f__cf);
			*p = 0;
			return(0);
		}
	}
}
예제 #6
0
파일: lread.c 프로젝트: cran/rioja
 static int
l_C(Void)
{	int ch, nml_save;
	double lz;
	if(f__lcount>0) return(0);
	f__ltype=0;
	GETC(ch);
	if(ch!='(')
	{
		if (nml_read > 1 && (ch < '0' || ch > '9')) {
			Ungetc(ch,f__cf);
			f__lquit = 2;
			return 0;
			}
      if (rd_count(ch)) {
         if(!f__cf || !feof(f__cf)) {
				errfl(f__elist->cierr,112,"complex format");
         }
         else {
				err(f__elist->cierr,(EOF),"lread");
         }
      }
		if(GETC(ch)!='*')
		{
			if(!f__cf || !feof(f__cf))
				errfl(f__elist->cierr,112,"no star");
			else
				err(f__elist->cierr,(EOF),"lread");
		}
		if(GETC(ch)!='(')
		{	Ungetc(ch,f__cf);
			return(0);
		}
	}
	else
		f__lcount = 1;
	while(iswhit(GETC(ch)));
	Ungetc(ch,f__cf);
	nml_save = nml_read;
	nml_read = 0;
	if ((ch = l_R(1,0)))
		return ch;
	if (!f__ltype)
		errfl(f__elist->cierr,112,"no real part");
	lz = f__lx;
	while(iswhit(GETC(ch)));
	if(ch!=',')
	{	(void) Ungetc(ch,f__cf);
		errfl(f__elist->cierr,112,"no comma");
	}
	while(iswhit(GETC(ch)));
	(void) Ungetc(ch,f__cf);
	if ((ch = l_R(1,0)))
		return ch;
	if (!f__ltype)
		errfl(f__elist->cierr,112,"no imaginary part");
	while(iswhit(GETC(ch)));
	if(ch!=')') errfl(f__elist->cierr,112,"no )");
	f__ly = f__lx;
	f__lx = lz;
#ifdef Allow_TYQUAD
	f__llx = 0;
#endif
	nml_read = nml_save;
	return(0);
}
예제 #7
0
파일: lread.c 프로젝트: cran/rioja
l_R(int poststar, int reqint)
#endif
{
	char s[FMAX+EXPMAXDIGS+4];
	register int ch;
	register char *sp, *spe, *sp1;
	long e, exp;
	int havenum, havestar, se;

	if (!poststar) {
		if (f__lcount > 0)
			return(0);
		f__lcount = 1;
		}
#ifdef Allow_TYQUAD
	f__llx = 0;
#endif
	f__ltype = 0;
	exp = 0;
	havestar = 0;
retry:
	sp1 = sp = s;
	spe = sp + FMAX;
	havenum = 0;

	switch(GETC(ch)) {
		case '-': *sp++ = ch; sp1++; spe++;
		case '+':
			GETC(ch);
		}
	while(ch == '0') {
		++havenum;
		GETC(ch);
		}
	while(isdigit(ch)) {
		if (sp < spe) *sp++ = ch;
		else ++exp;
		GETC(ch);
		}
	if (ch == '*' && !poststar) {
		if (sp == sp1 || exp || *s == '-') {
			errfl(f__elist->cierr,112,"bad repetition count");
			}
		poststar = havestar = 1;
		*sp = 0;
		f__lcount = atoi(s);
		goto retry;
		}
	if (ch == '.') {
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
		if (reqint)
			errfl(f__elist->cierr,115,"invalid integer");
#endif
		GETC(ch);
		if (sp == sp1)
			while(ch == '0') {
				++havenum;
				--exp;
				GETC(ch);
				}
		while(isdigit(ch)) {
			if (sp < spe)
				{ *sp++ = ch; --exp; }
			GETC(ch);
			}
		}
	havenum += sp - sp1;
	se = 0;
	if (issign(ch))
		goto signonly;
	if (havenum && isexp(ch)) {
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
		if (reqint)
			errfl(f__elist->cierr,115,"invalid integer");
#endif
		GETC(ch);
		if (issign(ch)) {
signonly:
			if (ch == '-') se = 1;
			GETC(ch);
			}
		if (!isdigit(ch)) {
bad:
			errfl(f__elist->cierr,112,"exponent field");
			}

		e = ch - '0';
		while(isdigit(GETC(ch))) {
			e = 10*e + ch - '0';
			if (e > EXPMAX)
				goto bad;
			}
		if (se)
			exp -= e;
		else
			exp += e;
		}
	(void) Ungetc(ch, f__cf);
	if (sp > sp1) {
		++havenum;
		while(*--sp == '0')
			++exp;
		if (exp)
			sprintf(sp+1, "e%ld", exp);
		else
			sp[1] = 0;
		f__lx = atof(s);
#ifdef Allow_TYQUAD
		if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) {
			/* Assuming 64-bit longint and 32-bit long. */
			if (exp < 0)
				sp += exp;
			if (sp1 <= sp) {
				f__llx = *sp1 - '0';
				while(++sp1 <= sp)
					f__llx = 10*f__llx + (*sp1 - '0');
				}
			while(--exp >= 0)
				f__llx *= 10;
			if (*s == '-')
				f__llx = -f__llx;
			}
#endif
		}
	else
		f__lx = 0.;
	if (havenum)
		f__ltype = TYLONG;
	else
		switch(ch) {
			case ',':
			case '/':
				break;
			default:
				if (havestar && ( ch == ' '
						||ch == '\t'
						||ch == '\n'))
					break;
				if (nml_read > 1) {
					f__lquit = 2;
					return 0;
					}
				errfl(f__elist->cierr,112,"invalid number");
			}
	return 0;
	}
예제 #8
0
파일: rsne.c 프로젝트: barak/f2c-1
int x_rsne(cilist *a)
{
	int ch, got1, k, n, nd, quote, readall;
	Namelist *nl;
	static char where[] = "namelist read";
	char buf[64];
	hashtab *ht;
	Vardesc *v;
	dimen *dn, *dn0, *dn1;
	ftnlen *dims, *dims1;
	ftnlen b, b0, b1, ex, no, nomax, size, span;
	ftnint no1, no2, type;
	char *vaddr;
	long iva, ivae;
	dimen dimens[MAXDIM], substr;

	if (!Alpha['a'])
		nl_init();
	f__reading=1;
	f__formatted=1;
	got1 = 0;
 top:
	for(;;) switch(GETC(ch)) {
		case EOF:
 eof:
			err(a->ciend,(EOF),where0);
		case '&':
		case '$':
			goto have_amp;
#ifndef No_Namelist_Questions
		case '?':
			print_ne(a);
			continue;
#endif
		default:
			if (ch <= ' ' && ch >= 0)
				continue;
#ifndef No_Namelist_Comments
			while(GETC(ch) != '\n')
				if (ch == EOF)
					goto eof;
#else
			errfl(a->cierr, 115, where0);
#endif
		}
 have_amp:
	if (ch = getname(buf,sizeof(buf)))
		return ch;
	nl = (Namelist *)a->cifmt;
	if (strcmp(buf, nl->name))
#ifdef No_Bad_Namelist_Skip
		errfl(a->cierr, 118, where0);
#else
	{
		fprintf(stderr,
			"Skipping namelist \"%s\": seeking namelist \"%s\".\n",
			buf, nl->name);
		fflush(stderr);
		for(;;) switch(GETC(ch)) {
			case EOF:
				err(a->ciend, EOF, where0);
			case '/':
			case '&':
			case '$':
				if (f__external)
					e_rsle();
				else
					z_rnew();
				goto top;
			case '"':
			case '\'':
				quote = ch;
 more_quoted:
				while(GETC(ch) != quote)
					if (ch == EOF)
						err(a->ciend, EOF, where0);
				if (GETC(ch) == quote)
					goto more_quoted;
				Ungetc(ch,f__cf);
			default:
				continue;
			}
		}
#endif
	ht = mk_hashtab(nl);
	if (!ht)
		errfl(f__elist->cierr, 113, where0);
	for(;;) {
		for(;;) switch(GETC(ch)) {
			case EOF:
				if (got1)
					return 0;
				err(a->ciend, EOF, where0);
			case '/':
			case '$':
			case '&':
				return 0;
			default:
				if (ch <= ' ' && ch >= 0 || ch == ',')
					continue;
				Ungetc(ch,f__cf);
				if (ch = getname(buf,sizeof(buf)))
					return ch;
				goto havename;
			}
 havename:
		v = hash(ht,buf);
		if (!v)
			errfl(a->cierr, 119, where);
		while(GETC(ch) <= ' ' && ch >= 0);
		vaddr = v->addr;
		type = v->type;
		if (type < 0) {
			size = -type;
			type = TYCHAR;
			}
		else
			size = f__typesize[type];
		ivae = size;
		iva = readall = 0;
		if (ch == '(' /*)*/ ) {
			dn = dimens;
			if (!(dims = v->dims)) {
				if (type != TYCHAR)
					errfl(a->cierr, 122, where);
				if (k = getdimen(&ch, dn, (ftnlen)size,
						(ftnlen)size, &b))
					errfl(a->cierr, k, where);
				if (ch != ')')
					errfl(a->cierr, 115, where);
				b1 = dn->extent;
				if (--b < 0 || b + b1 > size)
					return 124;
				iva += b;
				size = b1;
				while(GETC(ch) <= ' ' && ch >= 0);
				goto scalar;
				}
			nd = (int)dims[0];
			nomax = span = dims[1];
			ivae = iva + size*nomax;
			colonseen = 0;
			if (k = getdimen(&ch, dn, size, nomax, &b))
				errfl(a->cierr, k, where);
			no = dn->extent;
			b0 = dims[2];
			dims1 = dims += 3;
			ex = 1;
			for(n = 1; n++ < nd; dims++) {
				if (ch != ',')
					errfl(a->cierr, 115, where);
				dn1 = dn + 1;
				span /= *dims;
				if (k = getdimen(&ch, dn1, dn->delta**dims,
						span, &b1))
					errfl(a->cierr, k, where);
				ex *= *dims;
				b += b1*ex;
				no *= dn1->extent;
				dn = dn1;
				}
			if (ch != ')')
				errfl(a->cierr, 115, where);
			readall = 1 - colonseen;
			b -= b0;
			if (b < 0 || b >= nomax)
				errfl(a->cierr, 125, where);
			iva += size * b;
			dims = dims1;
			while(GETC(ch) <= ' ' && ch >= 0);
			no1 = 1;
			dn0 = dimens;
			if (type == TYCHAR && ch == '(' /*)*/) {
				if (k = getdimen(&ch, &substr, size, size, &b))
					errfl(a->cierr, k, where);
				if (ch != ')')
					errfl(a->cierr, 115, where);
				b1 = substr.extent;
				if (--b < 0 || b + b1 > size)
					return 124;
				iva += b;
				b0 = size;
				size = b1;
				while(GETC(ch) <= ' ' && ch >= 0);
				if (b1 < b0)
					goto delta_adj;
				}
			if (readall)
				goto delta_adj;
			for(; dn0 < dn; dn0++) {
				if (dn0->extent != *dims++ || dn0->stride != 1)
					break;
				no1 *= dn0->extent;
				}
			if (dn0 == dimens && dimens[0].stride == 1) {
				no1 = dimens[0].extent;
				dn0++;
				}
 delta_adj:
			ex = 0;
			for(dn1 = dn0; dn1 <= dn; dn1++)
				ex += (dn1->extent-1)
					* (dn1->delta *= dn1->stride);
			for(dn1 = dn; dn1 > dn0; dn1--) {
				ex -= (dn1->extent - 1) * dn1->delta;
				dn1->delta -= ex;
				}
			}
		else if (dims = v->dims) {
			no = no1 = dims[1];
			ivae = iva + no*size;
			}
		else
 scalar:
			no = no1 = 1;
		if (ch != '=')
			errfl(a->cierr, 115, where);
		got1 = nml_read = 1;
		f__lcount = 0;
	 readloop:
		for(;;) {
			if (iva >= ivae || iva < 0) {
				f__lquit = 1;
				goto mustend;
				}
			else if (iva + no1*size > ivae)
				no1 = (ivae - iva)/size;
			f__lquit = 0;
			if (k = l_read(&no1, vaddr + iva, size, type))
				return k;
			if (f__lquit == 1)
				return 0;
			if (readall) {
				iva += dn0->delta;
				if (f__lcount > 0) {
					no2 = (ivae - iva)/size;
					if (no2 > f__lcount)
						no2 = f__lcount;
					if (k = l_read(&no2, vaddr + iva,
							size, type))
						return k;
					iva += no2 * dn0->delta;
					}
				}
 mustend:
			GETC(ch);
			if (readall)
				if (iva >= ivae)
					readall = 0;
				else for(;;) {
					switch(ch) {
						case ' ':
						case '\t':
						case '\n':
							GETC(ch);
							continue;
						}
					break;
					}
			if (ch == '/' || ch == '$' || ch == '&') {
				f__lquit = 1;
				return 0;
				}
			else if (f__lquit) {
				while(ch <= ' ' && ch >= 0)
					GETC(ch);
				Ungetc(ch,f__cf);
				if (!Alpha[ch & 0xff] && ch >= 0)
					errfl(a->cierr, 125, where);
				break;
				}
			Ungetc(ch,f__cf);
			if (readall && !Alpha[ch & 0xff])
				goto readloop;
			if ((no -= no1) <= 0)
				break;
			for(dn1 = dn0; dn1 <= dn; dn1++) {
				if (++dn1->curval < dn1->extent) {
					iva += dn1->delta;
					goto readloop;
					}
				dn1->curval = 0;
				}
			break;
			}
		}
}
예제 #9
0
파일: lread.c 프로젝트: angelhunt/SNP
l_R(int poststar)
#endif
{
	char s[FMAX+EXPMAXDIGS+4];
	register int ch;
	register char *sp, *spe, *sp1;
	long e, exp;
	int havenum, havestar, se;

	if (!poststar) {
		if (f__lcount > 0)
			return(0);
		f__lcount = 1;
		}
	f__ltype = 0;
	exp = 0;
	havestar = 0;
retry:
	sp1 = sp = s;
	spe = sp + FMAX;
	havenum = 0;

	switch(GETC(ch)) {
		case '-': *sp++ = ch; sp1++; spe++;
		case '+':
			GETC(ch);
		}
	while(ch == '0') {
		++havenum;
		GETC(ch);
		}
	while(isdigit(ch)) {
		if (sp < spe) *sp++ = ch;
		else ++exp;
		GETC(ch);
		}
	if (ch == '*' && !poststar) {
		if (sp == sp1 || exp || *s == '-') {
			errfl(f__elist->cierr,112,"bad repetition count");
			}
		poststar = havestar = 1;
		*sp = 0;
		f__lcount = atoi(s);
		goto retry;
		}
	if (ch == '.') {
		GETC(ch);
		if (sp == sp1)
			while(ch == '0') {
				++havenum;
				--exp;
				GETC(ch);
				}
		while(isdigit(ch)) {
			if (sp < spe)
				{ *sp++ = ch; --exp; }
			GETC(ch);
			}
		}
	havenum += sp - sp1;
	se = 0;
	if (issign(ch))
		goto signonly;
	if (havenum && isexp(ch)) {
		GETC(ch);
		if (issign(ch)) {
signonly:
			if (ch == '-') se = 1;
			GETC(ch);
			}
		if (!isdigit(ch)) {
bad:
			errfl(f__elist->cierr,112,"exponent field");
			}

		e = ch - '0';
		while(isdigit(GETC(ch))) {
			e = 10*e + ch - '0';
			if (e > EXPMAX)
				goto bad;
			}
		if (se)
			exp -= e;
		else
			exp += e;
		}
	(void) Ungetc(ch, f__cf);
	if (sp > sp1) {
		++havenum;
		while(*--sp == '0')
			++exp;
		if (exp)
			sprintf(sp+1, "e%ld", exp);
		else
			sp[1] = 0;
		f__lx = atof(s);
		}
	else
		f__lx = 0.;
	if (havenum)
		f__ltype = TYLONG;
	else
		switch(ch) {
			case ',':
			case '/':
				break;
			default:
				if (havestar && ( ch == ' '
						||ch == '\t'
						||ch == '\n'))
					break;
				if (nml_read > 1) {
					f__lquit = 2;
					return 0;
					}
				errfl(f__elist->cierr,112,"invalid number");
			}
	return 0;
	}