1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: io.c,v 1.11 85/03/24 11:03:19 sklower Exp $";
   4: #endif
   5: 
   6: /*					-[Tue Nov 22 10:01:14 1983 by jkf]-
   7:  * 	io.c				$Locker:  $
   8:  * input output functions
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: #include "global.h"
  14: #include <ctype.h>
  15: #include "chars.h"
  16: #include "chkrtab.h"
  17: 
  18: struct readtable {
  19: unsigned char   ctable[132];
  20: } initread = {
  21: /*	^@ nul	^A soh	^B stx	^C etx	^D eot	^E eng	^F ack	^G bel  */
  22:     VERR,   VERR,   VERR,   VERR,   VERR,   VERR,   VERR,   VERR,
  23: /*	^H bs	^I ht	^J nl	^K vt	^L np	^M cr	^N so	^O si	*/
  24:     VCHAR,  VSEP,   VSEP,   VSEP,   VSEP,   VSEP,   VERR,   VERR,
  25: /*	^P dle	^Q dc1	^R dc2	^S dc3	^T dc4	^U nak	^V syn	^W etb	*/
  26:     VERR,   VERR,   VERR,   VERR,   VERR,   VERR,   VERR,   VERR,
  27: /*	^X can	^Y em	^Z sub	^[ esc	^\ fs	^] gs	^^ rs	^_ us	*/
  28:     VERR,   VERR,   VERR,   VSEP,   VERR,   VERR,   VERR,   VERR,
  29: /*	sp	!	"	#	$	%	&	'	*/
  30:     VSEP,   VCHAR,  VSD,    VCHAR,  VCHAR,  VCHAR,  VCHAR,  VSQ,
  31: /*	(	)	*	+	,	-	.	/	*/
  32:     VLPARA, VRPARA, VCHAR,  VSIGN,  VCHAR,  VSIGN,  VPERD,  VCHAR,
  33: /*	0	1	2	3	4	5	6	7	*/
  34:     VNUM,   VNUM,   VNUM,   VNUM,   VNUM,   VNUM,   VNUM,   VNUM,
  35: /*	8	9	:	;	<	=	>	?	*/
  36:     VNUM,   VNUM,   VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,
  37: /*	@	A	B	C	D	E	F	G	*/
  38:     VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,
  39: /*	H	I	J	K	L	M	N	O	*/
  40:     VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,
  41: /*	P	Q	R	S	T	U	V	W	*/
  42:     VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,
  43: /*	X	Y	Z	[	\	]	^	_	*/
  44:     VCHAR,  VCHAR,  VCHAR,  VLBRCK, VESC,   VRBRCK, VCHAR,  VCHAR,
  45: /*	`	a	b	c	d	e	f	g	*/
  46:     VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,
  47: /*	h	i	j	k	l	m	n	o	*/
  48:     VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,
  49: /*	p	q	r	s	t	u	v	w	*/
  50:     VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,  VCHAR,
  51: /*	x	y	z	{	|	}	~	del	*/
  52:     VCHAR,  VCHAR,  VCHAR,  VCHAR,  VDQ,    VCHAR,  VCHAR,  VERR,
  53: /*	unused	Xsdc	Xesc	Xdqc					*/
  54:     0,  '"',    '\\',   '|'
  55: };
  56: 
  57: extern unsigned char *ctable;
  58: lispval atomval;    /* external varaible containing atom returned
  59: 			   from internal atom reading routine */
  60: lispval readrx(); lispval readr(); lispval readry();
  61: char *atomtoolong();
  62: int keywait;
  63: int plevel = -1;    /* contains maximum list recursion count	*/
  64: int plength = -1;   /* maximum number of list elements printed	*/
  65: static int dbqflag;
  66: static int mantisfl = 0;
  67: extern int uctolc;
  68: extern lispval  lastrtab;   /* external variable designating current reader
  69: 			   table */
  70: static char baddot1[]=
  71: "Bad reader construction: (. <something>)\nShould be (nil . <something>)\n";
  72: static char baddot2[]=
  73: "Bad reader construction: (<something> . <something> not followed by )";
  74: 
  75: /* readr ****************************************************************/
  76: /* returns a s-expression read in from the port specified as the first	*/
  77: /* argument.  Handles superbrackets, reader macros.			*/
  78: lispval
  79: readr(useport)
  80: FILE *useport;
  81: {
  82:     register lispval handy = Vreadtable->a.clb;
  83: 
  84:     chkrtab(handy);
  85:     rbktf = FALSE;
  86:     rdrport = (FILE *) useport;
  87:     if(useport==stdin)
  88:         keywait = TRUE;
  89:     handy = readrx(Iratom());
  90:     if(useport==stdin)
  91:         keywait = FALSE;
  92:     return(handy);
  93: 
  94: }
  95: 
  96: 
  97: /* readrx **************************************************************/
  98: /* returns a s-expression beginning with the syntax code of an atom	*/
  99: /* passed in the first	*/
 100: /* argument.  Does the actual work for readr, including list, dotted	*/
 101: /* pair, and quoted atom detection					*/
 102: lispval
 103: readrx(code)
 104: register int code;
 105: {
 106:     register lispval work;
 107:     register lispval *current;
 108:     register struct argent *result;
 109:     int inlbkt = FALSE;
 110:     lispval errorh();
 111:     Savestack(4); /* ???not necessary because np explicitly restored if
 112: 	  changed */
 113: 
 114: top:
 115:     switch(code)
 116:     {
 117:     case TLBKT:
 118:         inlbkt = TRUE;
 119:     case TLPARA:
 120:         result = np;
 121:         current = (lispval *)np;
 122:         np++->val = nil; /*protect(nil);*/
 123:         for(EVER) {
 124:             switch(code = Iratom())
 125:             {
 126:             case TRPARA:
 127:                 if(rbktf && inlbkt)
 128:                     rbktf = FALSE;
 129:                 goto out;
 130:             default:
 131:                 atomval = readrx(code);
 132:             case TSCA:
 133:                 np++->val=atomval;
 134:                 *current = work = newdot();
 135:                 work->d.car = atomval;
 136:                 np--;
 137:                 current = (lispval *) &(work->d.cdr);
 138:                 break;
 139:             case TINF:
 140:                 imacrox(result->val,TRUE);
 141:                 work = atomval;
 142:                 result->val = work->d.car;
 143:                 current = (lispval *) & (result->val);
 144:                 goto mcom;
 145:             case TSPL:
 146:                 macrox(); /* input and output in atomval */
 147:                 *current = atomval;
 148:             mcom:
 149:                 while(*current!=nil) {
 150:                     if(TYPE(*current)!=DTPR)
 151:                         errorh1(Vermisc,"Non-list returned from splicing macro",nil,FALSE,7,*current);
 152:                     current=(lispval *)&((*current)->d.cdr);
 153:                 }
 154:                 break;
 155:             case TPERD:
 156:                 if(result->val==nil) {
 157:                     work = result->val=newdot();
 158:                     current = (lispval *) &(work->d.cdr);
 159:                     fprintf(stderr,baddot1);
 160:                 }
 161:                 work = readrx(TLPARA);
 162:                 if (work->d.cdr!=nil) {
 163:                     *current = work; work = newdot();
 164:                     work->d.cdr = *current; *current = nil;
 165:                     work->d.car = result->val;
 166:                     result->val = errorh1(Vermisc,baddot2,nil,TRUE,58,work);
 167:                     goto out;
 168:                 }
 169:                 *current = work->d.car;
 170:                 /* there is the possibility that the expression
 171: 				   following the dot is terminated with a "]"
 172: 				   and thus needs no closing lparens to follow
 173: 				*/
 174:                 if(rbktf && inlbkt)
 175:                     rbktf = FALSE;
 176:                 goto out;
 177:             case TEOF:
 178:                 errorh1(Vermisc,"Premature end of file after ",
 179:                               nil,FALSE,0,result->val);
 180:             }
 181:             if(rbktf) {
 182:                 if(inlbkt)
 183:                     rbktf = FALSE;
 184:                 goto out;
 185:             }
 186:         }
 187:     case TSCA:
 188:         Restorestack();
 189:         return(atomval);
 190:     case TEOF:
 191:         Restorestack();
 192:         return(eofa);
 193:     case TMAC:
 194:         macrox();
 195:         Restorestack();
 196:         return(atomval);
 197:     case TINF:
 198:         imacrox(nil,FALSE);
 199:         work = atomval;
 200:         if(work==nil) { code = Iratom(); goto top;}
 201:         work = work->d.car;
 202:             Restorestack();
 203:         if(work->d.cdr==nil)
 204:             return(work->d.car);
 205:         else
 206:             return(work);
 207:     case TSPL:
 208:         macrox();
 209:         if((work = atomval)!=nil) {
 210:             if(TYPE(work)==DTPR && work->d.cdr==nil) {
 211:                 Restorestack();
 212:                 return(work->d.car);
 213:             } else {
 214:                 errorh1(Vermisc,
 215: "Improper value returned from splicing macro at top-level",nil,FALSE,9,work);
 216:             }
 217:         }
 218:         code = Iratom();
 219:         goto top;
 220:         /* return(readrx(Iratom())); */
 221:     case TSQ:
 222:         result = np;
 223:         protect(newdot());
 224:         (work = result->val)->d.car = quota;
 225:         work = work->d.cdr = newdot();
 226:         work->d.car = readrx(Iratom());
 227:         goto out;
 228: 
 229:     case TRPARA:
 230:         Restorestack();
 231:         return(errorh(Vermisc,
 232:             "read: read a right paren when expecting an s-expression",
 233:             nil,FALSE,0));
 234:     case TPERD:
 235:         Restorestack();
 236:         return(errorh(Vermisc,
 237:             "read: read a period when expecting an s-expression",
 238:             nil,FALSE,0));
 239: 
 240:     /* should never get here, we should have covered all cases above */
 241:     default:
 242:         Restorestack();
 243:         return(errorh1(Vermisc,"Readlist error,  code ",nil,FALSE,0,inewint((long)code)));
 244:     }
 245: out:
 246:     work = result->val;
 247:     np = result;
 248:     Restorestack();
 249:     return(work);
 250: }
 251: macrox()
 252: {
 253:         FILE *svport;
 254:     lispval handy, Lapply();
 255: 
 256:     Savestack(0);
 257:     svport = rdrport;   /* save from possible changing */
 258:     lbot = np;
 259:     protect(handy=Iget(atomval,lastrtab));
 260:     if (handy == nil)
 261:     {
 262:         errorh1(Vermisc,"read: can't find the character macro for ",nil,
 263:                 FALSE,0,atomval);
 264:     }
 265:     protect(nil);
 266:     atomval = Lapply();
 267:     chkrtab(Vreadtable->a.clb); /* the macro could have changed
 268: 					   the readtable
 269: 					 */
 270:     rdrport = svport;   /* restore old value */
 271:     Restorestack();
 272:     return;
 273: }
 274: imacrox(current,inlist)
 275: register lispval current;
 276: {
 277:         FILE *svport;
 278:     register lispval work;
 279:     lispval Lapply(), handy;
 280: 
 281:     Savestack(2);
 282:     svport = rdrport;   /* save from possible changing */
 283:     if(inlist)
 284:     {
 285:         protect(handy = newdot());
 286:         handy->d.car = current;
 287:         for(work = handy->d.car; (TYPE(work->d.cdr))==DTPR; )
 288:             work = work->d.cdr;
 289:             handy->d.cdr = work;
 290:     }
 291:     else handy = current;
 292: 
 293:     lbot = np;
 294:     protect(Iget(atomval,lastrtab));
 295:     protect(handy);
 296:     atomval = Lfuncal();
 297:     chkrtab(Vreadtable->a.clb); /* the macro could have changed
 298: 					   the readtable
 299: 					 */
 300:     rdrport = svport;   /* restore old value */
 301:     Restorestack();
 302:     return;
 303: }
 304: 
 305: 
 306: 
 307: /* ratomr ***************************************************************/
 308: /* this routine returns a pointer to an atom read in from the port given*/
 309: /* by the first argument						*/
 310: lispval
 311: ratomr(useport)
 312: register FILE   *useport;
 313: {
 314:     rdrport = useport;
 315:     switch(Iratom())
 316:     {
 317:     case TEOF:
 318:         return(eofa);
 319:     case TSQ:
 320:     case TRPARA:
 321:     case TLPARA:
 322:     case TLBKT:
 323:     case TPERD:
 324:         strbuf[1]=0;
 325:         return(getatom(TRUE));
 326:     default:
 327:         return(atomval);
 328:     }
 329: }
 330: 
 331: #define push(); *name++ = c; if(name>=endstrb) name = atomtoolong(name);
 332: #define next() (((cc=getc(useport))!=EOF)?(stats = ctable[c = cc &0177]):\
 333:                     ((c=0),(saweof = 1),(stats = SEPMASK)))
 334: Iratom()
 335: {
 336:     register FILE   *useport = rdrport;
 337:     register char   c, marker, *name;
 338:     extern lispval finatom(), calcnum(), getnum();
 339:     int code, cc;
 340:     int strflag = FALSE;
 341: 
 342:     name = strbuf;
 343: 
 344: again:  cc = getc(useport);
 345:     if(cc==EOF)
 346:     {
 347:         clearerr(useport);
 348:         return(TEOF);
 349:     }
 350:     c = cc & 0177;
 351:     *name = c;
 352: 
 353:     switch(synclass(ctable[c])) {
 354: 
 355:     default:    goto again;
 356: 
 357:     case synclass(VNUM):
 358: 
 359:     case synclass(VSIGN):   *name++ = c;
 360:             atomval = (getnum(name));
 361:             return(TSCA);
 362: 
 363:     case synclass(VESC):
 364:             dbqflag = TRUE;
 365:             *name++ = getc(useport) & 0177;
 366:             atomval = (finatom(name));
 367:             return(TSCA);
 368: 
 369:     case synclass(VCHAR):
 370:             if(uctolc && isupper(c)) c = tolower(c);
 371:             *name++ = c;
 372:             atomval = (finatom(name));
 373:             return(TSCA);
 374: 
 375:     case synclass(VLPARA):  return(TLPARA);
 376: 
 377:     case synclass(VRPARA):  return(TRPARA);
 378: 
 379:     case synclass(VPERD):   marker = peekc(useport) & 0177;
 380:             if(synclass(VNUM)!=synclass(ctable[marker]))
 381:             {  if(SEPMASK & ctable[marker])
 382:                 return(TPERD);
 383:                else { *name++ = c;  /* this period begins an atm */
 384:                   atomval = finatom(name);
 385:                   return(TSCA);
 386:                }
 387:             }
 388:             *name++ = '.';
 389:             mantisfl = 1;
 390:             atomval = (getnum(name));
 391:             return(TSCA);
 392: 
 393:     case synclass(VLBRCK):  return(TLBKT);
 394: 
 395:     case synclass(VRBRCK):  rbktf = TRUE;
 396:             return(TRPARA);
 397: 
 398:     case synclass(VSQ): return(TSQ);
 399: 
 400:     case synclass(VSD): strflag = TRUE;
 401:     case synclass(VDQ): name = strbuf;
 402:             marker = c;
 403:             while ((c = getc(useport)) != marker) {
 404: 
 405:                 if(synclass(VESC)==synclass(ctable[c]))
 406:                     c = getc(useport) & 0177;
 407:                 push();
 408:                 if (feof(useport)) {
 409:                     clearerr(useport);
 410:                     error("EOF encountered while reading atom", FALSE);
 411:                 }
 412:             }
 413:             *name = NULL_CHAR;
 414:             if(strflag)
 415:                 atomval = (lispval) newstr(TRUE);
 416:             else
 417:                 atomval = (getatom(TRUE));
 418:             return(TSCA);
 419: 
 420:     case synclass(VERR):    if (c == '\0')
 421:             {
 422:               fprintf(stderr,"[read: null read and ignored]\n");
 423:               goto again;   /* null pname */
 424:             }
 425:             fprintf(stderr,"%c (%o): ",c,(int) c);
 426:             error("ILLEGAL CHARACTER IN ATOM",TRUE);
 427: 
 428:     case synclass(VSINF):
 429:         code = TINF;
 430:         goto same;
 431:     case synclass(VSSPL):
 432:         code = TSPL;
 433:         goto same;
 434:     case synclass(VSMAC):
 435:         code = TMAC;
 436:     same:
 437:         marker = peekc(rdrport);
 438:         if(! (SEPMASK & ctable[marker]) ) {
 439:             *name++ = c;  /* this is not a macro */
 440:             atomval = (finatom(name));
 441:             return(TSCA);
 442:         }
 443:         goto simple;
 444:     case synclass(VINF):
 445:         code = TINF;
 446:         goto simple;
 447:     case synclass(VSCA):
 448:         code = TSCA;
 449:         goto simple;
 450:     case synclass(VSPL):
 451:         code = TSPL;
 452:         goto simple;
 453:     case synclass(VMAC):
 454:         code = TMAC;
 455:     simple:
 456:         strbuf[0] = c;
 457:         strbuf[1] = 0;
 458:         atomval = (getatom(TRUE));
 459:         return(code);
 460:     }
 461: }
 462: 
 463: lispval
 464: getnum(name)
 465: register char *name;
 466: {
 467:     unsigned char c;
 468:     register lispval result;
 469:     register FILE *useport=rdrport;
 470:     unsigned char  stats;
 471:     int sawdigit = 0, saweof = 0,cc;
 472:     char *exploc = (char *) 0;
 473:     double realno;
 474:     extern lispval finatom(), calcnum(), newdoub(), dopow();
 475: 
 476:     if(mantisfl) {
 477:         mantisfl = 0;
 478:         next();
 479:         goto mantissa;
 480:     }
 481:     if(VNUM==ctable[*(unsigned char*)(name-1)]) sawdigit = 1;
 482:     while(VNUM==next()) {
 483:         push();     /* recognize [0-9]*, in "ex" parlance */
 484:         sawdigit = 1;
 485:     }
 486:     if(c=='.') {
 487:         push();     /* continue */
 488:     } else if(stats & SEPMASK) {
 489:         if(!saweof)ungetc((int)c,useport);
 490:         return(calcnum(strbuf,name,(int)ibase->a.clb->i));
 491:     } else if(c=='^') {
 492:         push();
 493:         return(dopow(name,(int)ibase->a.clb->i));
 494:     } else if(c=='_') {
 495:         if(sawdigit)    /* _ must be preceeded by a digit */
 496:         {
 497:             push();
 498:             return(dopow(name,2));
 499:         }
 500:         else goto backout;
 501:     } else if(c=='e' || c=='E' || c=='d' ||c=='D') {
 502:         if(sawdigit) goto expt;
 503:         else goto backout;
 504:     } else {
 505:     backout:
 506:         ungetc((int)c,useport);
 507:         return(finatom(name));
 508:     }
 509:                 /* at this point we have [0-9]*\. , which might
 510: 				   be a decimal int or the leading part of a
 511: 				   float				*/
 512:     if(next()!=VNUM) {
 513:         if(c=='e' || c=='E' || c=='d' ||c=='D')
 514:             goto expt;
 515:         else if(c=='^') {
 516:             push();
 517:             return(dopow(name,(int)ibase->a.clb->i));
 518:         } else if(c=='_') {
 519:             push();
 520:             return(dopow(name,2));
 521:         } else if( stats & SEPMASK) {
 522:                 /* Here we have 1.x where x is not number
 523: 				 * but is a separator
 524: 				 * Here we have decimal int. NOT FORTRAN!
 525: 				 */
 526:             if(!saweof)ungetc((int)c,useport);
 527:             return(calcnum(strbuf,name-1,10));
 528:         }
 529:         else goto last;  /* return a symbol */
 530:     }
 531: mantissa:
 532:     do {
 533:         push();
 534:     } while (VNUM==next());
 535: 
 536:     /* Here we have [0-9]*\.[0-9]*
 537: 	 * three possibilities:
 538: 	 *   next character is e,E,d or D in which case we examine
 539: 	 *	the exponent [then we are faced with a similar
 540: 	 *	situation to this one: is the character after the
 541: 	 *	exponent a separator or not]
 542: 	 *   next character is a separator, in which case we have a
 543: 	 *      number (without an exponent)
 544: 	 *   next character is not a separator in which case we have
 545: 	 *      an atom (whose prefix just happens to look like a
 546: 	 *	number)
 547: 	 */
 548:     if( (c == 'e') || (c == 'E') || (c == 'd') || (c == 'D')) goto expt;
 549: 
 550:     if(stats & SEPMASK) goto verylast;  /* a real number */
 551:     else goto last; /* prefix makes it look like a number, but it isn't */
 552: 
 553: expt:
 554:     exploc = name;  /* remember location of exponent character */
 555:     push();
 556:     next();
 557:     if(c=='+' || c =='-') {
 558:         push();
 559:         next();
 560:     }
 561:     while (VNUM==stats) {
 562:         push();
 563:         next();
 564:     }
 565: 
 566:     /* if a separator follows then we have a number, else just
 567: 	 * an atom
 568: 	 */
 569:     if (stats & SEPMASK) goto verylast;
 570: 
 571: last:   /* get here when what looks like a number turns out to be an atom */
 572:     if(!saweof) ungetc((int)c,useport);
 573:     return(finatom(name));
 574: 
 575: verylast:
 576:     if(!saweof) ungetc((int)c,useport);
 577:     /* scanf requires that the exponent be 'e' */
 578:     if(exploc != (char *) 0 ) *exploc = 'e';
 579:     *name=0;
 580:     sscanf(strbuf,"%F",&realno);
 581:     (result = newdoub())->r = realno;
 582:     return(result);
 583: }
 584: 
 585: lispval
 586: dopow(part2,base)
 587: register char *part2;
 588: {
 589:     register char *name = part2;
 590:     register FILE *useport = rdrport;
 591:     register int power;
 592:     lispval work;
 593:     unsigned char stats,c;
 594:     int cc, saweof = 0;
 595:     char *end1 = part2 - 1; lispval Ltimes();
 596:     Savestack(4);
 597: 
 598:     while(VNUM==next()) {
 599:         push();
 600:     }
 601:     if(c!='.') {
 602:         if(!saweof)ungetc((int)c,useport);
 603:     }
 604:     if(c!='.' && !(stats & SEPMASK)) {
 605:         return(finatom(name));
 606:     }
 607:     lbot = np;
 608:     np++->val = inewint(base);
 609:     /* calculate "mantissa"*/
 610:     if(*end1=='.')
 611:         np++->val = calcnum(strbuf,end1-1,10);
 612:     else
 613:         np++->val = calcnum(strbuf,end1,(int)ibase->a.clb->i);
 614: 
 615:     /* calculate exponent */
 616:     if(c=='.')
 617:         power = calcnum(part2,name,10)->i;
 618:     else
 619:         power = calcnum(part2,name,(int)ibase->a.clb->i)->i;
 620:     while(power-- > 0)
 621:         lbot[1].val = Ltimes();
 622:     work = lbot[1].val;
 623:     Restorestack();
 624:     return(work);
 625: }
 626: 
 627: 
 628: lispval
 629: calcnum(strbuf,name,base)
 630: register char *name;
 631: char *strbuf;
 632: {
 633:     register char *p;
 634:     register lispval result, temp;
 635:     int negflag = 0;
 636: 
 637:     result = temp = newsdot();      /* initialize sdot cell */
 638:     protect(temp);
 639:     p = strbuf;
 640:     if(*p=='+') p++;
 641:     else if(*p=='-') {negflag = 1; p++;}
 642:     *name = 0;
 643:     if(p>=name) return(getatom(TRUE));
 644: 
 645:     for(;p < name; p++)
 646:         dmlad(temp,(long)base,(long)*p-'0');
 647:     if(negflag)
 648:         dmlad(temp,-1L,0L);
 649: 
 650:     if(temp->s.CDR==0) {
 651:         result = inewint(temp->i);
 652:         pruneb(np[-1].val);
 653:     }
 654:     np--;
 655:     return(result);
 656: }
 657: lispval
 658: finatom(name)
 659: register char *name;
 660: {
 661:     register FILE *useport = rdrport;
 662:     unsigned char c, stats;
 663:     int cc, saweof = 0;
 664: 
 665:     while(!(next()&SEPMASK)) {
 666: 
 667:         if(synclass(stats) == synclass(VESC)) {
 668:             c = getc(useport) & 0177;
 669:         } else {
 670:             if(uctolc && isupper(c)) c = tolower(c);
 671:         }
 672:         push();
 673:     }
 674:     *name = NULL_CHAR;
 675:     if(!saweof)ungetc((int)c,useport);
 676:     return(getatom(TRUE));
 677: }
 678: 
 679: char *
 680: atomtoolong(copyto)
 681: char *copyto;
 682: {
 683:     int size;
 684:     register char *oldp = strbuf;
 685:     register char *newp;
 686:     lispval nveci();
 687:     /*
 688:      * the string buffer contains an string which is too long
 689:      * so we get a bigger buffer.
 690:      */
 691: 
 692:     size =  (endstrb - strbuf)*4 + 28 ;
 693:     newp = (char *) nveci(size);
 694:     atom_buffer = (lispval) newp;
 695:     strbuf = newp;
 696:     endstrb = newp + size - 1;
 697:     while(oldp < copyto) *newp++ = *oldp++;
 698:     return(newp);
 699: }
 700: 
 701: /* printr ***************************************************************/
 702: /* prints the first argument onto the port specified by the second 	*/
 703: 
 704: /*
 705:  * Last modified Mar 21, 1980 for hunks
 706:  */
 707: 
 708: printr(a,useport)
 709: register lispval a;
 710: register FILE *useport;
 711: {
 712:     register hsize, i;
 713:     char strflag = 0;
 714:     char Idqc = 0;
 715:     char *chstr;
 716:     int curplength = plength;
 717:     int quot;
 718:     lispval Istsrch();
 719:     lispval debugmode;
 720: 
 721: val_loop:
 722:     if(! VALID(a)) {
 723:         debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr;
 724:         if(debugmode != nil) {
 725:         printf("<printr:bad lisp data: 0x%x>\n",a);
 726:         error("Bad lisp data encountered by printr", FALSE);
 727:         } else {
 728:         a = badst;
 729:         printf("<printr:bad lisp data: 0x%x>",a);
 730:         return;
 731:         }
 732:     }
 733: 
 734:     switch (TYPE(a))
 735:     {
 736: 
 737: 
 738:     case UNBO:  fputs("<UNBOUND>",useport);
 739:             break;
 740: 
 741:     case VALUE: fputs("(ptr to)",useport);
 742:             a = a->l;
 743:             goto val_loop;
 744: 
 745:     case INT:   fprintf(useport,"%d",a->i);
 746:             break;
 747: 
 748:     case DOUB:  {  char buf[64];
 749:                lfltpr(buf,a->r);
 750:                fputs(buf,useport);
 751:             }
 752:             break;
 753: 
 754:     case PORT:  { lispval  cp;
 755:               if((cp = ioname[PN(a->p)]) == nil)
 756:                  fputs("%$unopenedport",useport);
 757:               else fprintf(useport,"%%%s",cp);
 758:             }
 759:             break;
 760: 
 761:     case HUNK2:
 762:     case HUNK4:
 763:     case HUNK8:
 764:     case HUNK16:
 765:     case HUNK32:
 766:     case HUNK64:
 767:     case HUNK128:
 768:             if(plevel == 0)
 769:             {
 770:                  fputs("%",useport);
 771:                  break;
 772:             }
 773:             hsize = 2 << HUNKSIZE(a);
 774:             fputs("{", useport);
 775:             plevel--;
 776:             printr(a->h.hunk[0], useport);
 777:             curplength--;
 778:             for (i=1; i < hsize; i++)
 779:             {
 780:                 if (a->h.hunk[i] == hunkfree)
 781:                 break;
 782:                 if (curplength-- == 0)
 783:                 {
 784:                     fputs(" ...",useport);
 785:                 break;
 786:                 }
 787:                 else
 788:                 {
 789:                     fputs(" ", useport);
 790:                 printr(a->h.hunk[i], useport);
 791:                 }
 792:             }
 793:             fputs("}", useport);
 794:             plevel++;
 795:             break;
 796: 
 797:     case VECTOR:
 798:             chstr = "vector";
 799:             quot = 4;   /* print out # of longwords */
 800:             goto veccommon;
 801: 
 802:     case VECTORI:
 803:             chstr = "vectori";
 804:             quot = 1;
 805:        veccommon:
 806:             /* print out 'vector' or 'vectori' except in
 807: 			 * these circumstances:
 808: 			 * property is a symbol, in which case print
 809: 			 *  the symbol's pname
 810: 			 * property is a list with a 'print' property,
 811: 			 *  in which case it is funcalled to print the
 812: 			 *  vector
 813: 			 */
 814:             if(a->v.vector[VPropOff] != nil)
 815:             {
 816:                 if ((i=TYPE(a->v.vector[VPropOff])) == ATOM)
 817:                 {
 818:                 chstr = a->v.vector[VPropOff]->a.pname;
 819:                 }
 820:                 else if ((i == DTPR) && vectorpr(a,useport))
 821:                 {
 822:                 break;  /* printed by vectorpr */
 823:                 }
 824:                 else if ((i == DTPR)
 825:                          && (a->v.vector[VPropOff]->d.car != nil)
 826:                          && TYPE(a->v.vector[VPropOff]->d.car)
 827:                          == ATOM)
 828:                 {
 829:                 chstr = a->v.vector[VPropOff]->d.car->a.pname;
 830:                 }
 831:             }
 832:             fprintf(useport,"%s[%d]",
 833:                     chstr, a->vl.vectorl[VSizeOff]/quot);
 834:             break;
 835: 
 836:     case ARRAY: fputs("array[",useport);
 837:             printr(a->ar.length,useport);
 838:             fputs("]",useport);
 839:             break;
 840: 
 841:     case BCD:   fprintf(useport,"#%X-",a->bcd.start);
 842:             printr(a->bcd.discipline,useport);
 843:             break;
 844: 
 845:     case OTHER: fprintf(useport,"#Other-%X",a);
 846:             break;
 847: 
 848:     case SDOT:  pbignum(a,useport);
 849:             break;
 850: 
 851:     case DTPR:  if(plevel==0)
 852:             {
 853:                  fputs("&",useport);
 854:                  break;
 855:             }
 856:             plevel--;
 857:             if(a->d.car==quota && a->d.cdr!=nil
 858:                 && a->d.cdr->d.cdr==nil) {
 859:                 putc('\'',useport);
 860:                 printr(a->d.cdr->d.car,useport);
 861:                 plevel++;
 862:                 break;
 863:             }
 864:             putc('(',useport);
 865:             curplength--;
 866:     morelist:   printr(a->d.car,useport);
 867:             if ((a = a->d.cdr) != nil)
 868:                 {
 869:                 if(curplength-- == 0)
 870:                 {
 871:                     fputs(" ...",useport);
 872:                     goto out;
 873:                 }
 874:                 putc(' ',useport);
 875:                 if (TYPE(a) == DTPR) goto morelist;
 876:                 fputs(". ",useport);
 877:                 printr(a,useport);
 878:                 }
 879:         out:
 880:             fputc(')',useport);
 881:             plevel++;
 882:             break;
 883: 
 884:     case STRNG: strflag = TRUE;
 885:             Idqc = Xsdc;
 886: 
 887:     case ATOM:  {
 888:             char    *front, *temp, first; int clean;
 889:             temp = front = (strflag ? ((char *) a) : a->a.pname);
 890:             if(Idqc==0) Idqc = Xdqc;
 891: 
 892:             if(Idqc) {
 893:                 clean = first = *temp;
 894:                 first &= 0177;
 895:                 switch(QUTMASK & ctable[first]) {
 896:                 case QWNFRST:
 897:                 case QALWAYS:
 898:                     clean = 0; break;
 899:                 case QWNUNIQ:
 900:                     if(temp[1]==0) clean = 0;
 901:                 }
 902:                 if (first=='-'||first=='+') temp++;
 903:                 if(synclass(ctable[*temp])==VNUM) clean = 0;
 904:                 while (clean && *temp) {
 905:                     if((ctable[*temp]&QUTMASK)==QALWAYS)
 906:                         clean = 0;
 907:                     else if(uctolc && (isupper(*temp)))
 908:                             clean = 0;
 909:                     temp++;
 910:                 }
 911:                 if (clean && !strflag)
 912:                     fputs(front,useport);
 913:                 else     {
 914:                     putc(Idqc,useport);
 915:                     for(temp=front;*temp;temp++) {
 916:                         if(  *temp==Idqc
 917:                           || (synclass(ctable[*temp])) == CESC)
 918:                             putc(Xesc,useport);
 919:                         putc(*temp,useport);
 920:                     }
 921:                     putc(Idqc,useport);
 922:                 }
 923: 
 924:             }  else {
 925:                 register char *cp = front;
 926:                 int handy = ctable[*cp & 0177];
 927: 
 928:                 if(synclass(handy)==CNUM)
 929:                     putc(Xesc,useport);
 930:                 else switch(handy & QUTMASK) {
 931:                 case QWNUNIQ:
 932:                     if(cp[1]==0) putc(Xesc,useport);
 933:                     break;
 934:                 case QWNFRST:
 935:                 case QALWAYS:
 936:                     putc(Xesc,useport);
 937:                 }
 938:                 for(; *cp; cp++) {
 939:                     if((ctable[*cp]& QUTMASK)==QALWAYS)
 940:                         putc(Xesc,useport);
 941:                     putc(*cp,useport);
 942:                 }
 943:             }
 944:         }
 945:     }
 946: }
 947: 
 948: /* -- vectorpr
 949:  * (perhaps) print out vector specially
 950:  * this is called with a vector whose property list begins with
 951:  * a list.  We search for the 'print' property and if it exists,
 952:  * funcall the print function with two args: the vector and the port.
 953:  * We return TRUE iff we funcalled the function, else we return FALSE
 954:  * to have the standard printing done
 955:  */
 956: 
 957: vectorpr(vec,port)
 958: register lispval vec;
 959: FILE *port;
 960: {
 961:     register lispval handy;
 962:     int svplevel = plevel;  /* save these global values */
 963:     int svplength = plength;
 964:     Savestack(2);
 965: 
 966: 
 967:     for ( handy = vec->v.vector[VPropOff]->d.cdr
 968:           ; handy != nil; handy = handy->d.cdr->d.cdr)
 969:     {
 970:     if (handy->d.car == Vprintsym)
 971:     {
 972:         lbot = np;
 973:         protect(handy->d.cdr->d.car);   /* function to call */
 974:         protect(vec);
 975:         protect(P(port));
 976:         Lfuncal();
 977:         plevel = svplevel;      /* restore globals */
 978:         plength = svplength;
 979:         Restorestack();
 980:         return(TRUE);   /* did the call */
 981:     }
 982:     }
 983:     Restorestack();
 984:     return(FALSE);  /* nothing printed */
 985: }
 986: 
 987: 
 988: 
 989: 
 990: 
 991: 
 992: lfltpr(buf,val)     /* lisp floating point printer */
 993: char *buf;
 994: double val;
 995: {
 996:     register char *cp1; char *sprintf();
 997: 
 998:     sprintf(buf,(char *)Vfloatformat->a.clb,val);
 999:     for(cp1 = buf; *cp1; cp1++)
1000:         if(*cp1=='.'|| *cp1=='E' || *cp1 == 'e') return;
1001: 
1002:     /* if we are here, there was no dot, so the number was
1003: 	   an integer.  Furthermore, cp1 already points to the
1004: 	   end of the string. */
1005: 
1006:     *cp1++ = '.';
1007:     *cp1++ = '0';
1008:     *cp1++ = 0;
1009: }
1010: 
1011: 
1012: /* dmpport ****************************************************************/
1013: /* outputs buffer indicated by first argument whether full or not	*/
1014: 
1015: dmpport(useport)
1016: FILE *useport;
1017: {
1018:     fflush(useport);
1019: }
1020: 
1021: /*  protect and unprot moved to eval.c  (whr)  */

Defined functions

Iratom defined in line 334; used 6 times
calcnum defined in line 628; used 8 times
dopow defined in line 585; used 5 times
finatom defined in line 657; used 9 times
getnum defined in line 463; used 3 times
imacrox defined in line 274; used 2 times
lfltpr defined in line 992; used 2 times
macrox defined in line 251; used 3 times
ratomr defined in line 310; used 1 times
readr defined in line 78; used 3 times
readrx defined in line 102; used 5 times
vectorpr defined in line 957; used 1 times

Defined variables

baddot1 defined in line 70; used 1 times
baddot2 defined in line 72; used 1 times
dbqflag defined in line 65; used 1 times
initread defined in line 20; used 1 times
keywait defined in line 62; used 3 times
mantisfl defined in line 66; used 3 times
plength defined in line 64; used 3 times
plevel defined in line 63; used 9 times
rcsid defined in line 2; never used

Defined struct's

readtable defined in line 18; never used

Defined macros

next defined in line 332; used 9 times
push defined in line 331; used 13 times
Last modified: 1985-08-14
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 2289
Valid CSS Valid XHTML 1.0 Strict