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


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 6 2019 18:05:53