euslisp: reader.c Source File

Go to the documentation of this file.
00001 /****************************************************************/
00002 /* euslisp reader
00003 /*      Copyright (c) T.Matsui, Electrotechnical Laboratory
00004 /*      1986-
00005 /*      1987-Jan        dispatch macros
00006 /*      1987-May        labeled expression #n= and #n#
00007 /*      1988-July       multiple escape |...|
00008 /****************************************************************/
00009 static char *rcsid="@(#)$Id$";
00010 
00011 #include <ctype.h>
00012 #include <fcntl.h>
00013 #include <signal.h>
00014 #include <string.h>
00015 #include "eus.h"
00016 
00017 #if !alpha
00018 #define FALSE (0)
00019 #define TRUE (1)
00020 #endif
00021 
00022 #define MAXTOKENLENGTH  1024
00023 #define MAXSTRINGLENGTH 16384
00024 #define to_upper(c) (islower(c) ? ((c)-'a'+'A') : (c))
00025 #define to_lower(c) (isupper(c) ? ((c)-'A'+'a') : (c))
00026 
00027 #define syntaxtype(ch) ((enum ch_type)(current_syntax[thr_self()][ch]))
00028 
00029 extern pointer FEATURES,READBASE,QREADTABLE;
00030 extern pointer QNOT, QAND, QOR; /*eval_read_cond, Jan/1995*/
00031 
00032 static pointer read1(context *, pointer);
00033 static pointer read2(context *, pointer, int, int, int, char*, int);
00034 extern pointer makelabref();
00035 
00036 extern void mul_int_big();
00037 extern pointer normalize_bignum();
00038 
00039 /* the following two global variables are hazardous to multi-threads */
00040 /* These should be eliminated in the next release. */
00041 byte *current_syntax[MAXTHREAD];
00042 pointer oblabels[MAXTHREAD];    /*keep labeled-objects in read*/
00043 
00044 /****************************************************************/
00045 /* character type table
00046 /****************************************************************/
00047 
00048 /*exported*/
00049 enum ch_type chartype[256]={
00050         ch_illegal,     ch_illegal,     ch_illegal,     ch_illegal, /*0-3*/
00051         ch_illegal,     ch_illegal,     ch_illegal,     ch_illegal, /*4-7*/
00052         ch_constituent, ch_white,       ch_white,       ch_illegal, /*8-b*/
00053         ch_white,       ch_white,       ch_illegal,     ch_illegal, /*c-f*/
00054         ch_illegal,     ch_illegal,     ch_illegal,     ch_illegal, /*10-13*/
00055         ch_illegal,     ch_illegal,     ch_illegal,     ch_illegal, /*14-17*/
00056         ch_illegal,     ch_illegal,     ch_illegal,     ch_illegal, /*18-1b*/
00057         ch_illegal,     ch_illegal,     ch_illegal,     ch_illegal, /*1c-1f*/
00058         ch_white,       ch_constituent, ch_termmacro,   ch_nontermacro,   /*20-23*/
00059         ch_constituent, ch_constituent, ch_constituent, ch_termmacro,   /*24-27*/
00060         ch_termmacro,   ch_termmacro,   ch_constituent, ch_constituent, /*28-2b*/
00061         ch_termmacro,   ch_constituent, ch_constituent, ch_constituent, /*2c-2f*/
00062         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*30-33*/
00063         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*34-37*/
00064         ch_constituent, ch_constituent, ch_constituent, ch_termmacro,    /*38-3b*/
00065         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*3c-3f*/
00066         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*40-43*/
00067         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*44-47*/
00068         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*48-4b*/
00069         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*4c-4f*/
00070         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*50-53*/
00071         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*54-57*/
00072         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*58-5b*/
00073         ch_sglescape,   ch_constituent, ch_constituent, ch_constituent, /*5c-5f*/
00074         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*60-63*/
00075         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*64-67*/
00076         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*68-6b*/
00077         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*6c-6f*/
00078         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*70-73*/
00079         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*74-77*/
00080         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*78-7b*/
00081         ch_multiescape, ch_constituent, ch_constituent, ch_constituent, /*7c-7f*/
00082         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*80*/
00083         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00084         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00085         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00086         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*90*/
00087         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00088         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00089         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00090         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*a0*/
00091         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00092         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00093         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00094         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*b0*/
00095         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00096         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00097         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00098         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*c0*/
00099         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00100         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00101         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00102         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*d0*/
00103         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00104         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00105         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00106         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*e0*/
00107         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00108         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00109         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00110         ch_constituent, ch_constituent, ch_constituent, ch_constituent, /*f0*/
00111         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00112         ch_constituent, ch_constituent, ch_constituent, ch_constituent, 
00113         ch_constituent, ch_constituent, ch_constituent, ch_constituent};
00114 
00115 enum ch_attr charattr[256]={
00116         illegal,        illegal,        illegal,        illegal,        /*0*/
00117         illegal,        illegal,        illegal,        illegal,
00118         illegal,        illegal,        illegal,        illegal,
00119         illegal,        illegal,        illegal,        illegal,
00120         illegal,        illegal,        illegal,        illegal,        /*10*/
00121         illegal,        illegal,        illegal,        illegal,
00122         illegal,        illegal,        illegal,        illegal,
00123         illegal,        illegal,        illegal,        illegal,
00124         alphabetic,     alphabetic,     alphabetic,     alphabetic,     /*20*/
00125         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00126         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00127         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00128         alphadigit,     alphadigit,     alphadigit,     alphadigit,     /*30*/
00129         alphadigit,     alphadigit,     alphadigit,     alphadigit,
00130         alphadigit,     alphadigit,     package_marker, alphabetic,
00131         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00132         alphabetic,     alphabetic,     alphabetic,     alphabetic,     /*40*/
00133         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00134         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00135         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00136         alphabetic,     alphabetic,     alphabetic,     alphabetic,     /*50*/
00137         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00138         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00139         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00140         alphabetic,     alphabetic,     alphabetic,     alphabetic,     /*60*/
00141         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00142         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00143         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00144         alphabetic,     alphabetic,     alphabetic,     alphabetic,     /*70*/
00145         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00146         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00147         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00148         alphabetic,     alphabetic,     alphabetic,     alphabetic,     /*80*/
00149         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00150         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00151         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00152         alphabetic,     alphabetic,     alphabetic,     alphabetic,     /*90*/
00153         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00154         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00155         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00156         alphabetic,     alphabetic,     alphabetic,     alphabetic,     /*a0*/
00157         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00158         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00159         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00160         alphabetic,     alphabetic,     alphabetic,     alphabetic,     /*b0*/
00161         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00162         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00163         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00164         alphabetic,     alphabetic,     alphabetic,     alphabetic,     /*c0*/
00165         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00166         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00167         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00168         alphabetic,     alphabetic,     alphabetic,     alphabetic,     /*d0*/
00169         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00170         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00171         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00172         alphabetic,     alphabetic,     alphabetic,     alphabetic,     /*e0*/
00173         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00174         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00175         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00176         alphabetic,     alphabetic,     alphabetic,     alphabetic,     /*f0*/
00177         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00178         alphabetic,     alphabetic,     alphabetic,     alphabetic,
00179         alphabetic,     alphabetic,     alphabetic,     alphabetic
00180         };
00181 
00182 /****************************************************************/
00183 /* euLisp READER                                                */
00184 /****************************************************************/
00185 /*
00186 /* reader primitives
00187 */
00188 #if IRIX || Linux_ppc
00189 #define Char int
00190 #else
00191 #if ARM
00192 #define Char signed char
00193 #else
00194 #define Char char
00195 #endif
00196 #endif
00197 
00198 static Char skip(ctx, f, ch)
00199 context *ctx;
00200 register pointer f;
00201 Char ch;
00202 { skipblank:
00203   while (syntaxtype((char)ch)==ch_white) {
00204     ch=readch(f);
00205     if (ch==EOF) return(EOF);}
00206   if (ch == ';' && (Spevalof(QREADTABLE)->c.rdtab.macro->c.vec.v[ch]
00207                 == charmacro[';'])) {
00208     /*syntax type for comment should be checked*/
00209     do {
00210       ch=readch(f);
00211       if (ch==EOF) return(EOF); }
00212       while(ch!='\n');
00213     goto skipblank;}  return(ch); }
00214 
00215 static int nextch(ctx, f)
00216 context *ctx;
00217 register pointer f;
00218 { 
00219   Char ch;
00220   ch=readch(f); ch=skip(ctx, f,ch); return(ch);}
00221 
00222 
00223 /****************************************************************/
00224 /*  labeled expression (#n=, #n#)
00225 /****************************************************************/
00226 
00227 static pointer findlabel(labx)
00228 eusinteger_t labx;
00229 { register pointer obj,labid;
00230   labid=makeint(labx);
00231   obj=oblabels[thr_self()]->c.lab.next;
00232   while (obj!=NIL) {
00233     if (obj->c.lab.label==labid) return(obj);
00234     else obj=obj->c.lab.next; }
00235   return(NIL);}
00236 
00237 static pointer readlabdef(ctx,f,labx)
00238 context *ctx;
00239 pointer f;      /*stream*/
00240 eusinteger_t labx;
00241 { pointer  unsol, *unsolp, result,newlab;
00242 
00243   if (findlabel(labx)!=NIL)  error(E_READLABEL,makeint(labx));  /*already defined*/
00244   newlab=(pointer)makelabref(makeint(labx),UNBOUND,oblabels[thr_self()]->c.lab.next);
00245   pointer_update(oblabels[thr_self()]->c.lab.next,newlab);
00246   result=read1(ctx,f);
00247 
00248   /*solve references*/
00249   pointer_update(newlab->c.lab.value,result);
00250   unsol=newlab->c.lab.unsolved;
00251   while (unsol!=NIL) {
00252 #if sun3 || (!alpha && system5) || sanyo
00253     unsolp=(pointer *)unsol;
00254 #endif
00255 #if sun4 || vax || news || mips || alpha || i386
00256     unsolp=(pointer *)((eusinteger_t)unsol & ~3);/*???? */
00257 #elif (WORD_SIZE == 64)
00258     unsolp=(pointer *)((eusinteger_t)unsol & ~3L);/*???? */
00259 #endif
00260     unsol= *unsolp;
00261     pointer_update(*unsolp,result); }
00262   return(result);}
00263 
00264 static void addunsolved(labp,addr)
00265 pointer labp;
00266 pointer *addr;
00267 { pointer_update(*addr,labp->c.lab.unsolved);
00268 #if sun3 ||( !alpha && system5 ) || sanyo
00269   labp->c.lab.unsolved=(pointer)addr;
00270 #endif
00271 #if sun4 || vax || news || mips || alpha || i386 || x86_64 || ARM
00272   { eusinteger_t i;
00273     i=(((eusinteger_t)addr)>>2);
00274     labp->c.lab.unsolved=makeint(i);}
00275 #endif
00276 }
00277 
00278 static pointer readlabref(ctx,f,val,subchar)
00279 register context *ctx;
00280 pointer f;
00281 eusinteger_t val;
00282 int subchar;
00283 { register pointer obj,element;
00284   obj=findlabel(val);
00285   if (obj==NIL) error(E_READLABEL,makeint(val));        /*undefined label*/
00286   if ((element=obj->c.lab.value)==UNBOUND) return(obj);
00287   else return(element);}
00288 
00289 
00290 /****************************************************************/
00291 /* read vector and object
00292 /* #(, #v(, #f(, #i(, #j(
00293 /****************************************************************/
00294 static pointer readvector(ctx,f,size)
00295 register context *ctx;
00296 register pointer f;
00297 register int size;
00298 { register pointer result,element;
00299   register int i=0;
00300   Char ch;
00301   ch=nextch(ctx,f);
00302   if (size>0) {
00303     result=makevector(C_VECTOR,size);
00304     vpush(result);
00305     while ((ch!=')') && (ch!=EOF) && (i<size)) {
00306       unreadch(f,ch);
00307       element=read1(ctx,f);
00308       if (islabref(element)) {  /*refer to undefined labeled obj*/
00309         addunsolved(element,&result->c.vec.v[i]); }
00310       else pointer_update(result->c.vec.v[i],element);
00311       i++;
00312       ch=nextch(ctx,f);}
00313     if (ch==')') 
00314       while (i<size) {pointer_update(result->c.vec.v[i],element);i++;}
00315     else {
00316       while (ch!=')' && ch!=EOF) ch=nextch(ctx,f);
00317       error(E_READ); }
00318     return(result);}
00319   else {
00320     while ((ch!=')') && (ch!=EOF)) {
00321       unreadch(f,ch);
00322       element=read1(ctx,f);
00323       ckpush(element);
00324       i++;
00325       ch=nextch(ctx,f);}
00326     result=makevector(C_VECTOR,i);
00327     while (i>0) {
00328       i--;
00329       element=vpop();
00330       if (islabref(element)) addunsolved(element,&result->c.vec.v[i]);
00331       else pointer_update(result->c.vec.v[i],element); }
00332     return(result); } }
00333 
00334 static pointer readivector(ctx,s)
00335 register context *ctx;
00336 register pointer s;
00337 { register int i=0;
00338   register eusinteger_t x;
00339   register pointer elm;
00340   register pointer rvec;
00341   Char ch;
00342   ch=nextch(ctx,s);
00343   if (ch!='(') error(E_READFVECTOR);
00344   ch=nextch(ctx,s);
00345   while (ch!=')' && ch!=EOF) {
00346     unreadch(s,ch);
00347     elm=read1(ctx,s);
00348     x=ckintval(elm);
00349     ch=nextch(ctx,s);
00350     vpush(elm);
00351     i++;}
00352   rvec=makevector(C_INTVECTOR,i);
00353   while (i>0) {
00354     elm=vpop();
00355     x=bigintval(elm);
00356     rvec->c.ivec.iv[--i]=x;}
00357   return(rvec);}
00358 
00359 static pointer readfvector(ctx,s)
00360 register context *ctx;
00361 register pointer s;
00362 { register int i=0,x;
00363   register pointer elm;
00364   eusfloat_t f;
00365   Char ch;
00366   numunion nu;
00367 
00368   ch=nextch(ctx,s);
00369   if (ch!='(') error(E_READFVECTOR);
00370   ch=nextch(ctx,s);
00371   while (ch!=')' && ch!=EOF) {
00372     unreadch(s,ch);
00373     elm=read1(ctx,s);
00374     if (!isnum(elm)) error(E_READFVECTOR);
00375     if (isint(elm)) { f=intval(elm); elm=makeflt(f);}
00376     ckpush(elm);
00377     i++;
00378     ch=nextch(ctx,s);}
00379   elm=makevector(C_FLTVECTOR,i);
00380   while (i>0) elm->c.fvec.fv[--i]=fltval(vpop());
00381   return(elm);}
00382 
00383 static pointer readobject(ctx,s)
00384 register context *ctx;
00385 register pointer s;     /*input stream*/
00386 {
00387   register pointer name, klass, elem, result;
00388   register eusinteger_t sz;
00389   register int i;
00390   Char ch;
00391 
00392   ch=nextch(ctx,s);
00393   if (ch!='(') error(E_READOBJECT);
00394   name=read1(ctx,s);
00395   if (!issymbol(name)) error(E_READOBJECT);
00396   klass=speval(name);
00397   if (klass==UNBOUND) error(E_NOCLASS,name);
00398   if (!isclass(klass)) error(E_READOBJECT);
00399   if (isvecclass(klass)) {
00400     elem=read1(ctx,s);
00401     if (!isint(elem)) error(E_READOBJECT);      /*vector size*/
00402     sz=intval(elem);
00403     result=makevector(klass,sz);
00404     i=1;}
00405   else if (isclass(klass)) {
00406     result=(pointer)makeobject(klass);
00407     i=0;}
00408   else error(E_NOCLASS,name);
00409   vpush(result);
00410   ch=nextch(ctx,s);
00411   while (ch!=')' && ch!=EOF) {
00412     unreadch(s,ch);
00413     elem=read1(ctx,s);
00414     if (islabref(elem)) {       /*refer to undefined labeled obj*/
00415         addunsolved(elem,&result->c.obj.iv[i++]); }
00416     else result->c.obj.iv[i++]=elem;
00417     ch=nextch(ctx,s);
00418     }
00419   vpop();
00420   return(result); }
00421 
00422 static pointer readstructure(ctx,s)
00423 register context *ctx;
00424 register pointer s;     /*input stream*/
00425 { register pointer name, klass, slot, elem, result, varvec, *slotp;
00426   Char ch;
00427 
00428   ch=nextch(ctx,s);
00429   if (ch!='(') error(E_READOBJECT);
00430   name=read1(ctx,s);
00431   if (!issymbol(name)) error(E_READOBJECT);
00432   klass=speval(name);
00433   if (klass==UNBOUND) error(E_NOCLASS,name);
00434   if (!isclass(klass)) error(E_READOBJECT);
00435   if (isvecclass(klass)) { error(E_NOCLASS,name);}
00436   else if (isclass(klass)) result=(pointer)makeobject(klass);
00437   else error(E_NOCLASS,name);
00438   vpush(result);
00439   ch=nextch(ctx,s);
00440   while (ch!=')' && ch!=EOF) {
00441     unreadch(s,ch);
00442     slot=read1(ctx,s);
00443     if (!issymbol(slot)) error(E_NOSYMBOL);
00444     elem=read1(ctx,s);
00445     slotp=(pointer *)getobjv(slot,klass->c.cls.vars,result);
00446     if (slotp!=NULL) {
00447       if (islabref(elem)) {     /*refer to undefined labeled obj*/
00448         addunsolved(elem,slotp); }
00449       else pointer_update(*slotp,elem); }
00450     ch=nextch(ctx,s);
00451     }
00452   vpop();
00453   return(result); }
00454 
00455 /****************************************************************/
00456 /* read dispatch macro expression
00457 /****************************************************************/
00458 static pointer read_sharp_char(ctx,f,val,subchar)       /* #\ */
00459 register context *ctx;
00460 register pointer f;
00461 eusinteger_t val;
00462 int subchar;
00463 { char ch;
00464   ch=readch(f); return(makeint(ch));}
00465 
00466 static pointer read_sharp_comment(ctx,f,val,subchar)    /* #| ... |# */
00467 register context *ctx;
00468 register pointer f;
00469 register eusinteger_t val;
00470 register int subchar;
00471 { Char ch;
00472   val=0;
00473   ch=readch(f);
00474  morecomments:
00475   while (ch!=subchar && ch!='#' && ch!=EOF) ch=readch(f);
00476   if (ch==EOF) return((pointer)EOF);
00477   if (ch==subchar) {
00478     ch=readch(f);
00479     if (ch=='#') { if (--val<0) return(UNBOUND);}
00480     goto morecomments;}
00481   ch=readch(f);
00482   if (ch==subchar)  { ch=readch(f); val++;}
00483   goto morecomments;}
00484 
00485 static pointer read_sharp_hex(ctx,f,val,subchar)
00486 register context *ctx;
00487 register pointer f;
00488 eusinteger_t val;
00489 int subchar;
00490 { register int i=0,j,c,p,q;
00491   pointer b;
00492   eusinteger_t *bv,x;
00493   char ch, buf[WORD_SIZE];
00494 
00495   ch=readch(f);
00496   while (i<WORD_SIZE && isxdigit(ch)) { buf[i++] = ch; ch=readch(f);}
00497   unreadch(f,ch); buf[i]=0;
00498   j = i*4 - (buf[0]<'2' ? 3 :
00499              buf[0]<'4' ? 2 :
00500              buf[0]<'8' ? 1 : 0); /* alphabet is bigger than '9'*/
00501   if (j<WORD_SIZE-2) { sscanf(buf,"%lx",&val);  return(makeint(val));}
00502   else {
00503     b= (pointer)makebig((j+WORD_SIZE-2)/(WORD_SIZE-1));
00504     bv=bigvec(b);
00505     p=0;q=0;
00506     for (j=i-1; j>=0; j--) {
00507       c=toupper(buf[j]);
00508       x=(c<='9')?(c-'0'):(c-'A'+10);
00509       bv[p/(WORD_SIZE-1)] |= ((x << q) & MASK);
00510       if (q>=(WORD_SIZE-4) && (x>>(WORD_SIZE-1-q)))
00511         bv[p/(WORD_SIZE-1) + 1] = x>>(WORD_SIZE-1-q);
00512       p +=4; q = (q+4) % (WORD_SIZE-1);
00513       }
00514     b=(pointer)normalize_bignum(b);
00515     return(b);}
00516   }
00517 
00518 static pointer read_sharp_octal(ctx,f,val,subchar)
00519 register context *ctx;
00520 pointer f;
00521 eusinteger_t val;
00522 int subchar;
00523 { register int i=0;
00524   char buf[WORD_SIZE/2], ch;
00525   ch=readch(f); val=0;
00526   while (i<WORD_SIZE/2 && ch>='0' && ch<'8') { buf[i++] = ch; ch=readch(f);}
00527   unreadch(f,ch); buf[i]=0;
00528   sscanf(buf,"%lo",&val);
00529   return(makeint(val));}
00530 
00531 static pointer read_sharp_function(ctx,f,val,subchar)   /* #' */
00532 register context *ctx;
00533 pointer f;
00534 eusinteger_t val;
00535 int subchar;
00536 { return(cons(ctx,FUNCTION,cons(ctx,read1(ctx,f),NIL)));}
00537 
00538 static pointer read_uninterned_symbol(ctx,f,val,subchar,token)  /* #: */
00539 context *ctx;
00540 pointer f;
00541 eusinteger_t val;
00542 int subchar;
00543 char token[];
00544 { register int i=0;
00545   char ch;
00546   ch=readch(f);
00547   while (syntaxtype(ch)==ch_constituent) {
00548     token[i++]=to_upper(ch); ch=readch(f);}
00549   token[i]=0; unreadch(f,ch);
00550   return(makesymbol(ctx,(char *)token,i,NIL));}
00551 
00552 static pointer read_sharp_eval(ctx,f)
00553 register context *ctx;
00554 pointer f;
00555 { pointer p;
00556   p=read1(ctx,f);
00557 /*  if (debug) prinx(ctx,p,Spevalof(QSTDOUT)); */
00558   return(eval(ctx,p));}
00559 
00560 static pointer eval_read_cond(ctx,expr)
00561 context *ctx;
00562 pointer expr;
00563 { pointer r;
00564   if (issymbol(expr)) return(memq(expr,speval(FEATURES)));
00565   if (iscons(expr)) {
00566     if (ccar(expr)==QNOT) {
00567       r=eval_read_cond(ctx,ccar(ccdr(expr)));
00568       return((r==NIL)?T:NIL);}
00569     else if (ccar(expr)==QAND) {
00570       expr=ccdr(expr);
00571       while (iscons(expr)) {
00572         r=eval_read_cond(ctx,ccar(expr));
00573         if (r==NIL) return(NIL);
00574         else expr=ccdr(expr);}
00575       return(T);}
00576     else if (ccar(expr)==QOR) {
00577       expr=ccdr(expr);
00578       while (iscons(expr)) {
00579         r=eval_read_cond(ctx,ccar(expr));
00580         if (r!=NIL) return(T);
00581         else expr=ccdr(expr);}
00582       return(NIL);}}
00583   error(E_USER,(pointer)"AND/OR/NOT expected in #+ or #-", expr);}
00584 
00585 static pointer read_cond_plus(ctx,f)    /* #+ */
00586 register context *ctx;
00587 register pointer f;
00588 { register pointer flag,result;
00589   flag=read1(ctx,f);
00590   vpush(flag);
00591   result=read1(ctx,f);
00592   if (eval_read_cond(ctx,flag)==NIL) result=(pointer)UNBOUND;
00593   vpop();
00594   return(result);}
00595 
00596 static pointer read_cond_minus(ctx,f)   /* #- */
00597 register context *ctx;
00598 register pointer f;
00599 { register pointer flag,result;
00600   flag=read1(ctx,f);
00601   vpush(flag);
00602   result=read1(ctx,f);
00603   if (eval_read_cond(ctx,flag)!=NIL) result=(pointer)UNBOUND;
00604   vpop();
00605   return(result);}
00606 
00607 static pointer read_sharp_object(ctx,f) /* #< */
00608 register context *ctx;
00609 register pointer f;
00610 { register pointer element,result,obj;
00611   register eusinteger_t val;
00612   Char ch;
00613   element=read1(ctx,f);
00614   if (!issymbol(element)) error(E_NOSYMBOL);  /*class name*/
00615   element=speval(element);
00616   if (element==UNBOUND || !isclass(element)) error(E_NOCLASS,element);
00617   obj=read1(ctx,f); val=ckintval(obj);
00618   result=makepointer(val);
00619   if (classof(result)!=element)
00620      error(E_TYPEMISMATCH, (pointer)"read #<> class mismatch");   /* ???? */
00621   ch=readch(f);
00622   while (ch!='>' && ch!=EOF) ch=readch(f);
00623   return(result);}
00624 
00625 static pointer readsharp(ctx,f,ch,token)
00626 register context *ctx;
00627 register pointer f;
00628 Char ch;
00629 char token[];
00630 { register eusinteger_t val=0;
00631   register int i=0,subchar;
00632   pointer macrofunc,result;
00633   pointer (*intmac)();
00634 
00635   ch=readch(f);
00636   if (ch==EOF) return(UNBOUND);
00637   while (isdigit(ch)) { 
00638     val=val*10+ch-'0'; ch=nextch(ctx,f);
00639     if (ch==EOF) return(UNBOUND);}
00640   subchar=to_upper(ch);
00641   macrofunc=Spevalof(QREADTABLE)->c.rdtab.dispatch->c.vec.v[subchar];
00642   if (macrofunc==NIL) error(E_USER,(pointer)"no # macro defined");
00643   if (isint(macrofunc)) {       /*internal macro*/
00644     intmac=(pointer (*)())(intval(macrofunc));
00645     result=(*intmac)(ctx,f,val,subchar,token);}
00646   else {
00647     vpush(f); vpush(makeint(subchar)); vpush(makeint(val));
00648     result=ufuncall(ctx,macrofunc,macrofunc,(pointer)(ctx->vsp-3),NULL,3);
00649     ctx->vsp-=3;}
00650   return(result);}
00651 
00652 static pointer readstring(ctx,f,terminator)
00653 register context *ctx;
00654 pointer f;
00655 int terminator;
00656 { int tleng = 0, lengmax=MAXSTRINGLENGTH;      /* '"' is ignored */
00657   byte buf[MAXSTRINGLENGTH], *token, *newtoken;
00658   int ch, malloced=FALSE;
00659   pointer p;
00660 
00661   ch=readch(f);
00662   token=buf;
00663   while ((ch!=terminator) && (ch!=EOF)) {
00664     if (syntaxtype(ch) == ch_sglescape) ch=readch(f);     /*read escaped char*/
00665     token[tleng++]=ch;
00666     if (tleng >= lengmax) { /*allocate bigger string buffer*/
00667                             /*and copy the accumulated characters so far*/
00668       newtoken=(byte *)malloc(lengmax*2);
00669       memcpy(newtoken,token,tleng);
00670       if (malloced==TRUE) cfree(token);
00671       malloced=TRUE;
00672       token=newtoken; lengmax=lengmax*2;
00673       }
00674     ch=readch(f);}
00675   token[tleng] = '\0';
00676   p=makestring((char *)token,tleng);
00677   if (malloced==TRUE) cfree(token);
00678   return(p);
00679   }
00680 
00681 static pointer readsymbol(ctx,leng,colon, token)
00682 register context *ctx;
00683 register int leng,colon;
00684 char token[];
00685 { register pointer pkg;
00686   pointer pkgstr,sym;
00687   register int doublecolon=1;
00688   int hash;
00689   if (colon==0) pkg=keywordpkg;
00690   else if (colon>0) {
00691     if (charattr[token[colon-1]]==package_marker) {
00692       pkg=(pointer)searchpkg((byte *)token,colon-1);}
00693     else {
00694       doublecolon=0;
00695       pkg=(pointer)searchpkg((byte *)token,colon);}
00696     if (pkg==(pointer)NULL) {
00697       if (doublecolon) colon--;
00698       pkgstr=makestring(token,colon);
00699       vpush(pkgstr);
00700       error(E_NOPACKAGE,pkgstr);} }
00701   else pkg=Spevalof(PACKAGE);   /*use current package for symbol search*/
00702   colon++;  /*colon-th character starts symbol name string*/
00703   if (doublecolon) return(intern(ctx,&token[colon],leng-colon,pkg));
00704   else {
00705     sym=findsymbol((byte *)&token[colon],leng-colon, pkg->c.pkg.symvector, &hash);
00706 /*    sym=findsymbol((char *)&token[colon],leng-colon, pkg->c.pkg.symvector, &hash);*/
00707     if (sym) return(sym);
00708     else {
00709       pkgstr=makestring(token,leng);
00710         fprintf(stderr,"%s ",token);
00711       vpush(pkgstr);
00712       error(E_EXTSYMBOL,pkgstr);}
00713   } }
00714 
00715 /* news does not have strtol routine! */
00716 #if news || sanyo
00717 int strtol(str,ptr,base)
00718 register char *str,**ptr;
00719 register int base;
00720 { long val=0,sign=1;
00721   char ch;
00722   while (isspace(*str)) str++;
00723   ch= *str;
00724   if (ch=='+') str++; else if (ch=='-') { str++; sign= -1;}
00725   if (base<=10) {
00726     while ('0'<= *str && *str<('0'+base)) val=val*base+(*str++)-'0';
00727     return(sign*val);}
00728   else {
00729     while (1) {
00730       if ('0'<= *str && *str<='9') val=val*base+(*str++ -'0');
00731       else if ('A'<= *str && *str<('A'+base-10)) val=val*base+(*str++ - 'A'+10);
00732       else if ('a'<= *str && *str<('a'+base-10)) val=val*base+(*str++ - 'a'+10);
00733       else break;
00734       continue;}
00735     return(sign*val);}}
00736 #endif
00737 
00738 static pointer readint(ctx,token,len)
00739 context *ctx;
00740 char *token;
00741 int len;
00742 { eusinteger_t base=intval(Spevalof(READBASE));
00743   int head,i,sign=1, k;
00744   pointer b;
00745 
00746   if (len<8) {
00747     i=strtol(token,NULL,base);
00748     return(makeint(i));}
00749   else {
00750     if (token[0]=='+') { head=1;}
00751     else if (token[0]=='-') {head=1; sign= -1;}
00752     else head=0;
00753     b=(pointer)makebig1(0);
00754     vpush(b);
00755     for (i=head; i<len; i++) {
00756       k= (int) token[i];
00757       if (k>='0' && k<='9') k= k-'0';
00758       else if (k>='A' && k<='Z') k=k-'A'+10;
00759       else if (k>='a' && k<='z') k=k-'a'+10;
00760       else if (k=='.') continue;
00761       else error(E_USER,(pointer)"illegal integer consituent char");
00762       mul_int_big(base,b);
00763       add_int_big(k,b);  }
00764     if (sign<0) complement_big(b);
00765     b=(pointer)normalize_bignum(b);
00766     }
00767   ctx->lastalloc= vpop();
00768   return(b);}
00769 
00770 int is_digit(ch,base)
00771 register int ch,base;
00772 { if (ch<'0') return(FALSE);
00773   if (base<=10)
00774     if (ch<'0'+base) return(TRUE);
00775     else return(FALSE);
00776   else if (ch<='9') return(TRUE);
00777   else if ('A'<=ch && ch<'A'+base-10) return(TRUE);
00778   else return(FALSE);}
00779 
00780 pointer read_delimited_list(ctx,f,delim_char,token)
00781 register context *ctx;
00782 pointer f;
00783 int delim_char;
00784 char token[];
00785 { pointer result=NIL;
00786   pointer temp,element;
00787   Char ch;
00788   ch=nextch(ctx,f);
00789   vpush(STOPPER);       /*marker*/
00790   while (ch!=delim_char && ch!=EOF) {
00791     if (ch=='.') {
00792       ch=readch(f); unreadch(f,ch);
00793       if (syntaxtype(ch)==ch_constituent) {
00794         token[0]='.';
00795         element=read2(ctx,f,0,0,1,token, -1);}
00796       else if (syntaxtype(ch)==ch_white) {
00797         result=read1(ctx,f);
00798         ch=nextch(ctx,f);
00799         if (ch!=delim_char) error(E_READ);
00800         break;}
00801       else error(E_READ);}
00802     else { unreadch(f,ch);  element=read1(ctx,f);}
00803     if (element!=UNBOUND && element!=(pointer)EOF) ckpush(element);
00804     ch=nextch(ctx,f);}
00805   while ((element=vpop())!=STOPPER) {
00806     temp=cons(ctx,element,result);
00807     if (islabref(element)) addunsolved(element,&temp->c.cons.car);
00808     if (islabref(result)) addunsolved(result,&temp->c.cons.cdr);
00809     result=temp;}
00810   return(result); }
00811 
00812 static pointer readlist(ctx,f,ch,token)
00813 register context *ctx;
00814 pointer f;
00815 char ch, token[];
00816 { return(read_delimited_list(ctx,f,')',token));}
00817 
00818 static pointer readquote(ctx,f)
00819 register context *ctx;
00820 pointer f;
00821 { pointer q;
00822   q=read1(ctx,f);
00823   if (q==(pointer)EOF) return((pointer)EOF);
00824   return(cons(ctx,QUOTE,cons(ctx,q,NIL)));}
00825 
00826 static pointer readcomment(ctx,f)
00827 register context *ctx;
00828 pointer f;
00829 { register Char ch;
00830   do { ch=readch(f);} while (ch!='\n' && ch!=EOF);
00831   return(UNBOUND);}
00832 
00833 static pointer readrparen(ctx,f)
00834 register context *ctx;
00835 pointer f;
00836 { return(UNBOUND);}
00837 
00838 
00839 
00840 int gcd(u,v)
00841 register int u,v;
00842 { register int t;
00843   if(u<0) u = -u;
00844   if(v<0) v = -v;
00845   if(u<v) {t=u; u=v; v=t;}
00846   while(v!=0){t=u % v; u=v; v=t;}
00847   return(u);}
00848 
00849 static pointer readratio(ctx,token,slash)
00850 context *ctx;
00851 char *token;
00852 int slash;
00853 { int num, denom, g;
00854   extern pointer makeratio();
00855   num=strtol(token,NULL,intval(Spevalof(READBASE)));
00856   denom=strtol(&token[slash+1],NULL,intval(Spevalof(READBASE)));
00857   g=gcd(num, denom);
00858   if (g!=0) { num /= g; denom /= g;}
00859   else return(makeint(0));
00860   if (denom==1) return(makeint(num));
00861   return(makeratio(num, denom));}
00862 
00863 
00864 static pointer read2(ctx,ins,escaped,multiescaped,i,token,colon)
00865 register context *ctx;
00866 register pointer ins;
00867 int escaped,multiescaped,i;
00868 char token[];
00869 int colon;
00870 { register int j,c;
00871   register eusinteger_t base;
00872   int slash;
00873   enum ch_type ctype;
00874   /*Char ch;*/
00875   int ch;
00876   pointer readcase; 
00877   numunion nu;
00878   extern double atof();
00879   
00880   readcase=Spevalof(QREADTABLE)->c.rdtab.readcase;
00881 
00882   if (multiescaped) goto step9;
00883  step8:
00884     if (i>=MAXTOKENLENGTH) error(E_LONGSTRING);
00885     ch=readch(ins);
00886     if (ch==EOF) goto step10;
00887     if (ch<0) ch &= 0xff;
00888     ctype=syntaxtype(ch);
00889     switch(ctype) {
00890       case ch_constituent: case ch_nontermacro:
00891         if (charattr[ch]==package_marker) colon=i;
00892         if (readcase==K_DOWNCASE) ch=to_lower(ch);
00893         else if (readcase==K_PRESERVE) ch=ch;
00894         else  ch=to_upper(ch);
00895         token[i++]=ch; goto step8;
00896       case ch_sglescape:
00897         token[i++]=readch(ins); escaped=1; goto step8;
00898       case ch_multiescape:
00899         goto step9;
00900       case ch_illegal:
00901         error(E_ILLCH,makeint(ch)); break;
00902       case ch_termmacro:
00903         unreadch(ins,ch); goto step10;
00904       case ch_white:
00905         unreadch(ins,ch); goto step10;
00906       default: error(E_USER,(pointer)"unknown char type");}
00907  step9:
00908     escaped=1;
00909     if (i>=MAXTOKENLENGTH) error(E_LONGSTRING);
00910     ch=readch(ins);
00911     if (ch==EOF) error(E_EOF);
00912     ch &= 0xff;
00913     ctype=syntaxtype(ch);
00914     switch(ctype) {
00915       case ch_constituent: case ch_white:
00916       case ch_nontermacro: case ch_termmacro:
00917         token[i++]=ch; goto step9;
00918       case ch_sglescape:
00919         ch=readch(ins); token[i++]=ch; goto step9;
00920       case ch_multiescape:
00921         goto step8;
00922       default: error(E_ILLCH,makeint(ch));}
00923  step10:
00924     /*token is accumulated; analyze syntax*/
00925     token[i]=0;
00926     if (escaped) return(readsymbol(ctx,i,colon,token));
00927     base=intval(Spevalof(READBASE));
00928 
00929     j=0;
00930     if ((token[j]=='+') || (token[j]=='-')) j++;
00931     else if (token[j]=='.' && token[j+1]=='\0')
00932       return(readsymbol(ctx,i,colon,token));
00933     if (is_digit(token[j],base) || token[j]=='.') {
00934       while (is_digit(token[j],base)) j++;
00935       if (token[j] == '.') {    /*float?*/
00936         if (++j==i) return(readint(ctx,token,i));
00937         /*float or symbol*/
00938         while (is_digit(token[j],base)) j++;
00939         c=to_upper(token[j]);
00940         if (c=='E' || c=='D' || c=='F' || c=='L') {
00941           c=j;  j++;
00942           if ((token[j]=='+') || (token[j]=='-')) j++;
00943           while (is_digit(token[j],base)) j++;
00944           if (j==i) { token[c]='E'; return(makeflt(atof(token)));}
00945           else return(readsymbol(ctx,i,colon,token));}
00946         else if (j==i) return(makeflt(atof(token)));
00947         else return(readsymbol(ctx,i,colon,token));}
00948       else if (token[j] == '/') {  /* ratio? */
00949         slash=j;
00950         if (++j==i) return(readsymbol(ctx,i,colon,token));
00951         /*ratio or symbol*/
00952         while (is_digit(token[j],base)) j++;
00953         if (j==i) return(readratio(ctx,token,slash));
00954         else return(readsymbol(ctx,i,colon,token));}
00955       else if (j==i) return(readint(ctx,token,i));
00956       else {
00957         c=to_upper(token[j]);
00958         if (c=='E' || c=='D' || c=='F' || c=='L') {
00959           c=j;  j++;
00960           if ((token[j]=='+') || (token[j]=='-')) j++;
00961           while (is_digit(token[j],base)) j++;
00962           if (j==i) {/*all digits*/ token[c]='E'; return(makeflt(atof(token)));}
00963           else return(readsymbol(ctx,i,colon,token));}
00964         else if (j==i) return(makeflt(atof(token)));
00965         else return(readsymbol(ctx,i,colon,token));} }
00966     else return(readsymbol(ctx,i,colon,token));}
00967 
00968 static pointer read1(ctx,ins)
00969 register context *ctx;
00970 register pointer ins;
00971 { register enum ch_type ctype;
00972   register int firstch;
00973   register pointer macrofunc,result;
00974   pointer (*intmac)();
00975   int colon;
00976 /*  Char ch; */
00977   int ch;
00978   char token[MAXTOKENLENGTH];
00979   pointer readcase;
00980 
00981   colon= -1;
00982   step1:
00983     ch=readch(ins);
00984     if (ch==EOF) return((pointer)EOF);
00985     ch &= 0xff;
00986     firstch=ch;
00987     ctype=syntaxtype(ch);
00988     switch(ctype) {
00989       case ch_illegal: error(E_ILLCH,makeint(ch));
00990       case ch_white: goto step1;
00991       case ch_termmacro: case ch_nontermacro:
00992               macrofunc=Spevalof(QREADTABLE)->c.rdtab.macro->c.vec.v[ch];
00993               if (macrofunc==NIL) error(E_USER,(pointer)"no char macro defined");
00994               if (isint(macrofunc)) {   /*internal macro*/
00995                 intmac=(pointer (*)())(intval(macrofunc));
00996                 result=(*intmac)(ctx,ins,ch,token);}
00997               else {
00998                 vpush(ins); vpush(makeint(ch));
00999                 result=ufuncall(ctx,macrofunc,macrofunc,(pointer)(ctx->vsp-2),NULL,2);
01000                 ctx->vsp-=2;}
01001 /*            if (result==UNBOUND && firstch!=')') goto step1;
01002               else return(result);*/
01003               return(result);
01004       case ch_sglescape: token[0]=readch(ins);
01005                          return(read2(ctx,ins,1,0,1,token,colon));
01006       case ch_multiescape: return(read2(ctx,ins,1,1,0,token,colon));
01007       case ch_constituent:
01008               if (charattr[ch]==package_marker) colon=0;
01009               readcase=Spevalof(QREADTABLE)->c.rdtab.readcase;
01010               if (readcase==K_DOWNCASE) ch=to_lower(ch);
01011               else if (readcase==K_PRESERVE) ch=ch;
01012               else  ch=to_upper(ch);
01013               token[0]= ch;
01014               return(read2(ctx,ins,0,0,1,token,colon));}}
01015 
01016 pointer reader(ctx,f,recursivep)
01017 register context *ctx;
01018 register pointer f,recursivep;
01019 { register pointer val;
01020   Char ch;
01021   current_syntax[thr_self()]=Spevalof(QREADTABLE)->c.rdtab.syntax->c.str.chars;
01022   ch=nextch(ctx,f);
01023   if (ch==EOF) return((pointer)EOF);
01024   while (ch==')') ch=nextch(ctx,f);
01025   unreadch(f,ch);
01026   if (recursivep==NIL) {
01027     pointer_update(oblabels[thr_self()]->c.lab.next,NIL);
01028     val=read1(ctx,f);
01029     pointer_update(oblabels[thr_self()]->c.lab.next,NIL);}
01030   else val=read1(ctx,f);        /*if called recursively, keep #n= scope*/
01031   if (val==UNBOUND) return(NIL);
01032   return(val);}
01033 
01034 void initreader(ctx)
01035 register context *ctx;
01036 { register pointer rdtable;
01037   register int i;
01038 
01039   charmacro['(']=makeint((eusinteger_t)readlist);
01040   charmacro[')']=makeint((eusinteger_t)readrparen);
01041   charmacro['#']=makeint((eusinteger_t)readsharp);
01042   charmacro['\'']=makeint((eusinteger_t)readquote);
01043   charmacro['"']=makeint((eusinteger_t)readstring);
01044   charmacro[';']=makeint((eusinteger_t)readcomment);
01045 
01046   sharpmacro['\\']=makeint((eusinteger_t)read_sharp_char);
01047   sharpmacro['\'']=makeint((eusinteger_t)read_sharp_function);
01048   sharpmacro[':']=makeint((eusinteger_t)read_uninterned_symbol);
01049   sharpmacro[',']=makeint((eusinteger_t)read_sharp_eval);
01050   sharpmacro['.']=makeint((eusinteger_t)read_sharp_eval);
01051   sharpmacro['|']=makeint((eusinteger_t)read_sharp_comment);
01052   sharpmacro['+']=makeint((eusinteger_t)read_cond_plus);
01053   sharpmacro['-']=makeint((eusinteger_t)read_cond_minus);
01054   sharpmacro['#']=makeint((eusinteger_t)readlabref);
01055   sharpmacro['=']=makeint((eusinteger_t)readlabdef);
01056   sharpmacro['(']=makeint((eusinteger_t)readvector);
01057   sharpmacro['<']=makeint((eusinteger_t)read_sharp_object);
01058   sharpmacro['X']=makeint((eusinteger_t)read_sharp_hex);
01059   sharpmacro['O']=makeint((eusinteger_t)read_sharp_octal);
01060   sharpmacro['S']=makeint((eusinteger_t)readstructure);
01061   sharpmacro['F']=makeint((eusinteger_t)readfvector);
01062   sharpmacro['I']=makeint((eusinteger_t)readivector);
01063   sharpmacro['J']=makeint((eusinteger_t)readobject);
01064   sharpmacro['V']=makeint((eusinteger_t)readobject);
01065 
01066   /* make default readtable */
01067   rdtable=(pointer)makereadtable(ctx);
01068   pointer_update(Spevalof(QREADTABLE),rdtable);
01069   for (i=0; i<256; i++) {
01070     rdtable->c.rdtab.syntax->c.str.chars[i]=(int)chartype[i];
01071     rdtable->c.rdtab.macro->c.vec.v[i]=charmacro[i];
01072     rdtable->c.rdtab.dispatch->c.vec.v[i]=sharpmacro[i];
01073     rdtable->c.rdtab.readcase=K_UPCASE;
01074     }
01075   }