"$Header: io.c,v 1.12 87/12/14 18:36:58 sklower Exp $";
/* -[Tue Nov 22 10:01:14 1983 by jkf]-
* (c) copyright 1982, Regents of the University of California
unsigned char ctable
[132];
/* ^@ nul ^A soh ^B stx ^C etx ^D eot ^E eng ^F ack ^G bel */
VERR
, VERR
, VERR
, VERR
, VERR
, VERR
, VERR
, VERR
,
/* ^H bs ^I ht ^J nl ^K vt ^L np ^M cr ^N so ^O si */
VCHAR
, VSEP
, VSEP
, VSEP
, VSEP
, VSEP
, VERR
, VERR
,
/* ^P dle ^Q dc1 ^R dc2 ^S dc3 ^T dc4 ^U nak ^V syn ^W etb */
VERR
, VERR
, VERR
, VERR
, VERR
, VERR
, VERR
, VERR
,
/* ^X can ^Y em ^Z sub ^[ esc ^\ fs ^] gs ^^ rs ^_ us */
VERR
, VERR
, VERR
, VSEP
, VERR
, VERR
, VERR
, VERR
,
VSEP
, VCHAR
, VSD
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VSQ
,
VLPARA
, VRPARA
, VCHAR
, VSIGN
, VCHAR
, VSIGN
, VPERD
, VCHAR
,
VNUM
, VNUM
, VNUM
, VNUM
, VNUM
, VNUM
, VNUM
, VNUM
,
VNUM
, VNUM
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
,
VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
,
VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
,
VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
,
VCHAR
, VCHAR
, VCHAR
, VLBRCK
, VESC
, VRBRCK
, VCHAR
, VCHAR
,
VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
,
VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
,
VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
, VCHAR
,
VCHAR
, VCHAR
, VCHAR
, VCHAR
, VDQ
, VCHAR
, VCHAR
, VERR
,
/* unused Xsdc Xesc Xdqc */
extern unsigned char *ctable
;
lispval atomval
; /* external varaible containing atom returned
from internal atom reading routine */
lispval
readrx(); lispval
readr(); lispval
readry();
int plevel
= -1; /* contains maximum list recursion count */
int plength
= -1; /* maximum number of list elements printed */
extern lispval lastrtab
; /* external variable designating current reader
"Bad reader construction: (. <something>)\nShould be (nil . <something>)\n";
"Bad reader construction: (<something> . <something> not followed by )";
/* readr ****************************************************************/
/* returns a s-expression read in from the port specified as the first */
/* argument. Handles superbrackets, reader macros. */
register lispval handy
= Vreadtable
->a
.clb
;
rdrport
= (FILE *) useport
;
handy
= readrx(Iratom());
/* readrx **************************************************************/
/* returns a s-expression beginning with the syntax code of an atom */
/* passed in the first */
/* argument. Does the actual work for readr, including list, dotted */
/* pair, and quoted atom detection */
register lispval
*current
;
register struct argent
*result
;
Savestack(4); /* ???not necessary because np explicitly restored if
np
++->val
= nil
; /*protect(nil);*/
*current
= work
= newdot();
current
= (lispval
*) &(work
->d
.cdr
);
imacrox(result
->val
,TRUE
);
result
->val
= work
->d
.car
;
current
= (lispval
*) & (result
->val
);
macrox(); /* input and output in atomval */
errorh1(Vermisc
,"Non-list returned from splicing macro",nil
,FALSE
,7,*current
);
current
=(lispval
*)&((*current
)->d
.cdr
);
work
= result
->val
=newdot();
current
= (lispval
*) &(work
->d
.cdr
);
*current
= work
; work
= newdot();
work
->d
.cdr
= *current
; *current
= nil
;
work
->d
.car
= result
->val
;
result
->val
= errorh1(Vermisc
,baddot2
,nil
,TRUE
,58,work
);
/* there is the possibility that the expression
following the dot is terminated with a "]"
and thus needs no closing lparens to follow
errorh1(Vermisc
,"Premature end of file after ",
nil
,FALSE
,0,result
->val
);
if(work
==nil
) { code
= Iratom(); goto top
;}
if((work
= atomval
)!=nil
) {
if(TYPE(work
)==DTPR
&& work
->d
.cdr
==nil
) {
"Improper value returned from splicing macro at top-level",nil
,FALSE
,9,work
);
/* return(readrx(Iratom())); */
(work
= result
->val
)->d
.car
= quota
;
work
= work
->d
.cdr
= newdot();
work
->d
.car
= readrx(Iratom());
"read: read a right paren when expecting an s-expression",
"read: read a period when expecting an s-expression",
/* should never get here, we should have covered all cases above */
return(errorh1(Vermisc
,"Readlist error, code ",nil
,FALSE
,0,inewint((long)code
)));
svport
= rdrport
; /* save from possible changing */
protect(handy
=Iget(atomval
,lastrtab
));
errorh1(Vermisc
,"read: can't find the character macro for ",nil
,
chkrtab(Vreadtable
->a
.clb
); /* the macro could have changed
rdrport
= svport
; /* restore old value */
register lispval current
;
svport
= rdrport
; /* save from possible changing */
protect(handy
= newdot());
for(work
= handy
->d
.car
; (TYPE(work
->d
.cdr
))==DTPR
; )
protect(Iget(atomval
,lastrtab
));
chkrtab(Vreadtable
->a
.clb
); /* the macro could have changed
rdrport
= svport
; /* restore old value */
/* ratomr ***************************************************************/
/* this routine returns a pointer to an atom read in from the port given*/
/* by the first argument */
#define push(); *name++ = c; if(name>=endstrb) name = atomtoolong(name);
#define next() (((cc=getc(useport))!=EOF)?(stats = ctable[c = cc &0177]):\
((c=0),(saweof = 1),(stats = SEPMASK)))
register FILE *useport
= rdrport
;
register char c
, marker
, *name
;
extern lispval
finatom(), calcnum(), getnum();
again
: cc
= getc(useport
);
switch(synclass(ctable
[c
])) {
case synclass(VSIGN
): *name
++ = c
;
atomval
= (getnum(name
));
*name
++ = getc(useport
) & 0177;
atomval
= (finatom(name
));
if(uctolc
&& isupper(c
)) c
= tolower(c
);
atomval
= (finatom(name
));
case synclass(VLPARA
): return(TLPARA
);
case synclass(VRPARA
): return(TRPARA
);
case synclass(VPERD
): marker
= peekc(useport
) & 0177;
if(synclass(VNUM
)!=synclass(ctable
[marker
]))
{ if(SEPMASK
& ctable
[marker
])
else { *name
++ = c
; /* this period begins an atm */
atomval
= (getnum(name
));
case synclass(VLBRCK
): return(TLBKT
);
case synclass(VRBRCK
): rbktf
= TRUE
;
case synclass(VSQ
): return(TSQ
);
case synclass(VSD
): strflag
= TRUE
;
case synclass(VDQ
): name
= strbuf
;
while ((c
= getc(useport
)) != marker
) {
if(synclass(VESC
)==synclass(ctable
[c
]))
c
= getc(useport
) & 0177;
error("EOF encountered while reading atom", FALSE
);
atomval
= (lispval
) newstr(TRUE
);
atomval
= (getatom(TRUE
));
case synclass(VERR
): if (c
== '\0')
fprintf(stderr
,"[read: null read and ignored]\n");
goto again
; /* null pname */
fprintf(stderr
,"%c (%o): ",c
,(int) c
);
error("ILLEGAL CHARACTER IN ATOM",TRUE
);
if(! (SEPMASK
& ctable
[marker
]) ) {
*name
++ = c
; /* this is not a macro */
atomval
= (finatom(name
));
atomval
= (getatom(TRUE
));
register FILE *useport
=rdrport
;
int sawdigit
= 0, saweof
= 0,cc
;
char *exploc
= (char *) 0;
extern lispval
finatom(), calcnum(), newdoub(), dopow();
if(VNUM
==ctable
[*(unsigned char*)(name
-1)]) sawdigit
= 1;
push(); /* recognize [0-9]*, in "ex" parlance */
} else if(stats
& SEPMASK
) {
if(!saweof
)ungetc((int)c
,useport
);
return(calcnum(strbuf
,name
,(int)ibase
->a
.clb
->i
));
return(dopow(name
,(int)ibase
->a
.clb
->i
));
if(sawdigit
) /* _ must be preceeded by a digit */
} else if(c
=='e' || c
=='E' || c
=='d' ||c
=='D') {
/* at this point we have [0-9]*\. , which might
be a decimal int or the leading part of a
if(c
=='e' || c
=='E' || c
=='d' ||c
=='D')
return(dopow(name
,(int)ibase
->a
.clb
->i
));
} else if( stats
& SEPMASK
) {
/* Here we have 1.x where x is not number
* Here we have decimal int. NOT FORTRAN!
if(!saweof
)ungetc((int)c
,useport
);
return(calcnum(strbuf
,name
-1,10));
else goto last
; /* return a symbol */
/* Here we have [0-9]*\.[0-9]*
* next character is e,E,d or D in which case we examine
* the exponent [then we are faced with a similar
* situation to this one: is the character after the
* exponent a separator or not]
* next character is a separator, in which case we have a
* number (without an exponent)
* next character is not a separator in which case we have
* an atom (whose prefix just happens to look like a
if( (c
== 'e') || (c
== 'E') || (c
== 'd') || (c
== 'D')) goto expt
;
if(stats
& SEPMASK
) goto verylast
; /* a real number */
else goto last
; /* prefix makes it look like a number, but it isn't */
exploc
= name
; /* remember location of exponent character */
/* if a separator follows then we have a number, else just
if (stats
& SEPMASK
) goto verylast
;
last
: /* get here when what looks like a number turns out to be an atom */
if(!saweof
) ungetc((int)c
,useport
);
if(!saweof
) ungetc((int)c
,useport
);
/* scanf requires that the exponent be 'e' */
if(exploc
!= (char *) 0 ) *exploc
= 'e';
sscanf(strbuf
,"%F",&realno
);
(result
= newdoub())->r
= realno
;
register char *name
= part2
;
register FILE *useport
= rdrport
;
char *end1
= part2
- 1; lispval
Ltimes();
if(!saweof
)ungetc((int)c
,useport
);
if(c
!='.' && !(stats
& SEPMASK
)) {
np
++->val
= inewint(base
);
/* calculate "mantissa"*/
np
++->val
= calcnum(strbuf
,end1
-1,10);
np
++->val
= calcnum(strbuf
,end1
,(int)ibase
->a
.clb
->i
);
power
= calcnum(part2
,name
,10)->i
;
power
= calcnum(part2
,name
,(int)ibase
->a
.clb
->i
)->i
;
calcnum(strbuf
,name
,base
)
register lispval result
, temp
;
result
= temp
= newsdot(); /* initialize sdot cell */
else if(*p
=='-') {negflag
= 1; p
++;}
if(p
>=name
) return(getatom(TRUE
));
dmlad(temp
,(long)base
,(long)*p
-'0');
result
= inewint(temp
->i
);
register FILE *useport
= rdrport
;
while(!(next()&SEPMASK
)) {
if(synclass(stats
) == synclass(VESC
)) {
c
= getc(useport
) & 0177;
if(uctolc
&& isupper(c
)) c
= tolower(c
);
if(!saweof
)ungetc((int)c
,useport
);
register char *oldp
= strbuf
;
* the string buffer contains an string which is too long
* so we get a bigger buffer.
size
= (endstrb
- strbuf
)*4 + 28 ;
newp
= (char *) nveci(size
);
atom_buffer
= (lispval
) newp
;
endstrb
= newp
+ size
- 1;
while(oldp
< copyto
) *newp
++ = *oldp
++;
/* printr ***************************************************************/
/* prints the first argument onto the port specified by the second */
* Last modified Mar 21, 1980 for hunks
int curplength
= plength
;
debugmode
= Istsrch(matom("debugging"))->d
.cdr
->d
.cdr
->d
.cdr
;
printf("<printr:bad lisp data: 0x%x>\n",a
);
error("Bad lisp data encountered by printr", FALSE
);
printf("<printr:bad lisp data: 0x%x>",a
);
case UNBO
: fputs("<UNBOUND>",useport
);
case VALUE
: fputs("(ptr to)",useport
);
case INT
: fprintf(useport
,"%d",a
->i
);
case DOUB
: { char buf
[64];
if((cp
= ioname
[PN(a
->p
)]) == nil
)
fputs("%$unopenedport",useport
);
else fprintf(useport
,"%%%s",cp
);
hsize
= 2 << HUNKSIZE(a
);
printr(a
->h
.hunk
[0], useport
);
for (i
=1; i
< hsize
; i
++)
if (a
->h
.hunk
[i
] == hunkfree
)
printr(a
->h
.hunk
[i
], useport
);
quot
= 4; /* print out # of longwords */
/* print out 'vector' or 'vectori' except in
* property is a symbol, in which case print
* property is a list with a 'print' property,
* in which case it is funcalled to print the
if(a
->v
.vector
[VPropOff
] != nil
)
if ((i
=TYPE(a
->v
.vector
[VPropOff
])) == ATOM
)
chstr
= a
->v
.vector
[VPropOff
]->a
.pname
;
else if ((i
== DTPR
) && vectorpr(a
,useport
))
break; /* printed by vectorpr */
&& (a
->v
.vector
[VPropOff
]->d
.car
!= nil
)
&& TYPE(a
->v
.vector
[VPropOff
]->d
.car
)
chstr
= a
->v
.vector
[VPropOff
]->d
.car
->a
.pname
;
fprintf(useport
,"%s[%d]",
chstr
, a
->vl
.vectorl
[VSizeOff
]/quot
);
case ARRAY
: fputs("array[",useport
);
printr(a
->ar
.length
,useport
);
case BCD
: fprintf(useport
,"#%X-",a
->bcd
.start
);
printr(a
->bcd
.discipline
,useport
);
case OTHER
: fprintf(useport
,"#Other-%X",a
);
case SDOT
: pbignum(a
,useport
);
if(a
->d
.car
==quota
&& a
->d
.cdr
!=nil
&& a
->d
.cdr
->d
.cdr
==nil
) {
printr(a
->d
.cdr
->d
.car
,useport
);
morelist
: printr(a
->d
.car
,useport
);
if ((a
= a
->d
.cdr
) != nil
)
if (TYPE(a
) == DTPR
) goto morelist
;
case STRNG
: strflag
= TRUE
;
char *front
, *temp
, first
; int clean
;
temp
= front
= (strflag
? ((char *) a
) : a
->a
.pname
);
switch(QUTMASK
& ctable
[first
]) {
if(temp
[1]==0) clean
= 0;
if (first
=='-'||first
=='+') temp
++;
if(synclass(ctable
[*temp
])==VNUM
) clean
= 0;
if((ctable
[*temp
]&QUTMASK
)==QALWAYS
)
else if(uctolc
&& (isupper(*temp
)))
for(temp
=front
;*temp
;temp
++) {
|| (synclass(ctable
[*temp
])) == CESC
)
register char *cp
= front
;
int handy
= ctable
[*cp
& 0177];
if(synclass(handy
)==CNUM
)
else switch(handy
& QUTMASK
) {
if(cp
[1]==0) putc(Xesc
,useport
);
if((ctable
[*cp
]& QUTMASK
)==QALWAYS
)
* (perhaps) print out vector specially
* this is called with a vector whose property list begins with
* a list. We search for the 'print' property and if it exists,
* funcall the print function with two args: the vector and the port.
* We return TRUE iff we funcalled the function, else we return FALSE
* to have the standard printing done
int svplevel
= plevel
; /* save these global values */
for ( handy
= vec
->v
.vector
[VPropOff
]->d
.cdr
; handy
!= nil
; handy
= handy
->d
.cdr
->d
.cdr
)
if (handy
->d
.car
== Vprintsym
)
protect(handy
->d
.cdr
->d
.car
); /* function to call */
plevel
= svplevel
; /* restore globals */
return(TRUE
); /* did the call */
return(FALSE
); /* nothing printed */
lfltpr(buf
,val
) /* lisp floating point printer */
sprintf(buf
,(char *)Vfloatformat
->a
.clb
,val
);
for(cp1
= buf
; *cp1
; cp1
++)
if(*cp1
=='.'|| *cp1
=='E' || *cp1
== 'e') return;
/* if we are here, there was no dot, so the number was
an integer. Furthermore, cp1 already points to the
/* dmpport ****************************************************************/
/* outputs buffer indicated by first argument whether full or not */
/* protect and unprot moved to eval.c (whr) */