00001
00002
00003
00004
00005
00006
00007
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;
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
00040
00041 byte *current_syntax[MAXTHREAD];
00042 pointer oblabels[MAXTHREAD];
00043
00044
00045
00046
00047
00048
00049 enum ch_type chartype[256]={
00050 ch_illegal, ch_illegal, ch_illegal, ch_illegal,
00051 ch_illegal, ch_illegal, ch_illegal, ch_illegal,
00052 ch_constituent, ch_white, ch_white, ch_illegal,
00053 ch_white, ch_white, ch_illegal, ch_illegal,
00054 ch_illegal, ch_illegal, ch_illegal, ch_illegal,
00055 ch_illegal, ch_illegal, ch_illegal, ch_illegal,
00056 ch_illegal, ch_illegal, ch_illegal, ch_illegal,
00057 ch_illegal, ch_illegal, ch_illegal, ch_illegal,
00058 ch_white, ch_constituent, ch_termmacro, ch_nontermacro,
00059 ch_constituent, ch_constituent, ch_constituent, ch_termmacro,
00060 ch_termmacro, ch_termmacro, ch_constituent, ch_constituent,
00061 ch_termmacro, ch_constituent, ch_constituent, ch_constituent,
00062 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00063 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00064 ch_constituent, ch_constituent, ch_constituent, ch_termmacro,
00065 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00066 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00067 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00068 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00069 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00070 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00071 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00072 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00073 ch_sglescape, ch_constituent, ch_constituent, ch_constituent,
00074 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00075 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00076 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00077 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00078 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00079 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00080 ch_constituent, ch_constituent, ch_constituent, ch_constituent,
00081 ch_multiescape, 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,
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,
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,
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,
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,
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,
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,
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 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,
00117 illegal, illegal, illegal, illegal,
00118 illegal, illegal, illegal, illegal,
00119 illegal, illegal, illegal, illegal,
00120 illegal, illegal, illegal, illegal,
00121 illegal, illegal, illegal, illegal,
00122 illegal, illegal, illegal, illegal,
00123 illegal, illegal, illegal, illegal,
00124 alphabetic, alphabetic, alphabetic, alphabetic,
00125 alphabetic, alphabetic, alphabetic, alphabetic,
00126 alphabetic, alphabetic, alphabetic, alphabetic,
00127 alphabetic, alphabetic, alphabetic, alphabetic,
00128 alphadigit, alphadigit, alphadigit, alphadigit,
00129 alphadigit, alphadigit, alphadigit, alphadigit,
00130 alphadigit, alphadigit, package_marker, alphabetic,
00131 alphabetic, alphabetic, alphabetic, alphabetic,
00132 alphabetic, alphabetic, alphabetic, alphabetic,
00133 alphabetic, alphabetic, alphabetic, alphabetic,
00134 alphabetic, alphabetic, alphabetic, alphabetic,
00135 alphabetic, alphabetic, alphabetic, alphabetic,
00136 alphabetic, alphabetic, alphabetic, alphabetic,
00137 alphabetic, alphabetic, alphabetic, alphabetic,
00138 alphabetic, alphabetic, alphabetic, alphabetic,
00139 alphabetic, alphabetic, alphabetic, alphabetic,
00140 alphabetic, alphabetic, alphabetic, alphabetic,
00141 alphabetic, alphabetic, alphabetic, alphabetic,
00142 alphabetic, alphabetic, alphabetic, alphabetic,
00143 alphabetic, alphabetic, alphabetic, alphabetic,
00144 alphabetic, alphabetic, alphabetic, alphabetic,
00145 alphabetic, alphabetic, alphabetic, alphabetic,
00146 alphabetic, alphabetic, alphabetic, alphabetic,
00147 alphabetic, alphabetic, alphabetic, alphabetic,
00148 alphabetic, alphabetic, alphabetic, alphabetic,
00149 alphabetic, alphabetic, alphabetic, alphabetic,
00150 alphabetic, alphabetic, alphabetic, alphabetic,
00151 alphabetic, alphabetic, alphabetic, alphabetic,
00152 alphabetic, alphabetic, alphabetic, alphabetic,
00153 alphabetic, alphabetic, alphabetic, alphabetic,
00154 alphabetic, alphabetic, alphabetic, alphabetic,
00155 alphabetic, alphabetic, alphabetic, alphabetic,
00156 alphabetic, alphabetic, alphabetic, alphabetic,
00157 alphabetic, alphabetic, alphabetic, alphabetic,
00158 alphabetic, alphabetic, alphabetic, alphabetic,
00159 alphabetic, alphabetic, alphabetic, alphabetic,
00160 alphabetic, alphabetic, alphabetic, alphabetic,
00161 alphabetic, alphabetic, alphabetic, alphabetic,
00162 alphabetic, alphabetic, alphabetic, alphabetic,
00163 alphabetic, alphabetic, alphabetic, alphabetic,
00164 alphabetic, alphabetic, alphabetic, alphabetic,
00165 alphabetic, alphabetic, alphabetic, alphabetic,
00166 alphabetic, alphabetic, alphabetic, alphabetic,
00167 alphabetic, alphabetic, alphabetic, alphabetic,
00168 alphabetic, alphabetic, alphabetic, alphabetic,
00169 alphabetic, alphabetic, alphabetic, alphabetic,
00170 alphabetic, alphabetic, alphabetic, alphabetic,
00171 alphabetic, alphabetic, alphabetic, alphabetic,
00172 alphabetic, alphabetic, alphabetic, alphabetic,
00173 alphabetic, alphabetic, alphabetic, alphabetic,
00174 alphabetic, alphabetic, alphabetic, alphabetic,
00175 alphabetic, alphabetic, alphabetic, alphabetic,
00176 alphabetic, alphabetic, alphabetic, alphabetic,
00177 alphabetic, alphabetic, alphabetic, alphabetic,
00178 alphabetic, alphabetic, alphabetic, alphabetic,
00179 alphabetic, alphabetic, alphabetic, alphabetic
00180 };
00181
00182
00183
00184
00185
00186
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
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
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;
00240 eusinteger_t labx;
00241 { pointer unsol, *unsolp, result,newlab;
00242
00243 if (findlabel(labx)!=NIL) error(E_READLABEL,makeint(labx));
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
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 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 pointer f;
00280 eusinteger_t val;
00281 int subchar;
00282 { register pointer obj,element;
00283 obj=findlabel(val);
00284 if (obj==NIL) error(E_READLABEL,makeint(val));
00285 if ((element=obj->c.lab.value)==UNBOUND) return(obj);
00286 else return(element);}
00287
00288
00289
00290
00291
00292
00293 static pointer readvector(ctx,f,size)
00294 register context *ctx;
00295 register pointer f;
00296 register int size;
00297 { register pointer result,element;
00298 register int i=0;
00299 Char ch;
00300 ch=nextch(ctx,f);
00301 if (size>0) {
00302 result=makevector(C_VECTOR,size);
00303 vpush(result);
00304 while ((ch!=')') && (ch!=EOF) && (i<size)) {
00305 unreadch(f,ch);
00306 element=read1(ctx,f);
00307 if (islabref(element)) {
00308 addunsolved(element,&result->c.vec.v[i]); }
00309 else pointer_update(result->c.vec.v[i],element);
00310 i++;
00311 ch=nextch(ctx,f);}
00312 if (ch==')')
00313 while (i<size) {pointer_update(result->c.vec.v[i],element);i++;}
00314 else {
00315 while (ch!=')' && ch!=EOF) ch=nextch(ctx,f);
00316 error(E_READ); }
00317 return(result);}
00318 else {
00319 while ((ch!=')') && (ch!=EOF)) {
00320 unreadch(f,ch);
00321 element=read1(ctx,f);
00322 ckpush(element);
00323 i++;
00324 ch=nextch(ctx,f);}
00325 result=makevector(C_VECTOR,i);
00326 while (i>0) {
00327 i--;
00328 element=vpop();
00329 if (islabref(element)) addunsolved(element,&result->c.vec.v[i]);
00330 else pointer_update(result->c.vec.v[i],element); }
00331 return(result); } }
00332
00333 static pointer readivector(ctx,s)
00334 register context *ctx;
00335 register pointer s;
00336 { register int i=0;
00337 register eusinteger_t x;
00338 register pointer elm;
00339 register pointer rvec;
00340 Char ch;
00341 ch=nextch(ctx,s);
00342 if (ch!='(') error(E_READFVECTOR);
00343 ch=nextch(ctx,s);
00344 while (ch!=')' && ch!=EOF) {
00345 unreadch(s,ch);
00346 elm=read1(ctx,s);
00347 x=ckintval(elm);
00348 ch=nextch(ctx,s);
00349 vpush(elm);
00350 i++;}
00351 rvec=makevector(C_INTVECTOR,i);
00352 while (i>0) {
00353 elm=vpop();
00354 x=bigintval(elm);
00355 rvec->c.ivec.iv[--i]=x;}
00356 return(rvec);}
00357
00358 static pointer readfvector(ctx,s)
00359 register context *ctx;
00360 register pointer s;
00361 { register int i=0,x;
00362 register pointer elm;
00363 eusfloat_t f;
00364 Char ch;
00365 numunion nu;
00366
00367 ch=nextch(ctx,s);
00368 if (ch!='(') error(E_READFVECTOR);
00369 ch=nextch(ctx,s);
00370 while (ch!=')' && ch!=EOF) {
00371 unreadch(s,ch);
00372 elm=read1(ctx,s);
00373 if (!isnum(elm)) error(E_READFVECTOR);
00374 if (isint(elm)) { f=intval(elm); elm=makeflt(f);}
00375 ckpush(elm);
00376 i++;
00377 ch=nextch(ctx,s);}
00378 elm=makevector(C_FLTVECTOR,i);
00379 while (i>0) elm->c.fvec.fv[--i]=fltval(vpop());
00380 return(elm);}
00381
00382 static pointer readobject(ctx,s)
00383 register context *ctx;
00384 register pointer s;
00385 {
00386 register pointer name, klass, elem, result;
00387 register eusinteger_t sz;
00388 register int i;
00389 Char ch;
00390
00391 ch=nextch(ctx,s);
00392 if (ch!='(') error(E_READOBJECT);
00393 name=read1(ctx,s);
00394 if (!issymbol(name)) error(E_READOBJECT);
00395 klass=speval(name);
00396 if (klass==UNBOUND) error(E_NOCLASS,name);
00397 if (!isclass(klass)) error(E_READOBJECT);
00398 if (isvecclass(klass)) {
00399 elem=read1(ctx,s);
00400 if (!isint(elem)) error(E_READOBJECT);
00401 sz=intval(elem);
00402 result=makevector(klass,sz);
00403 i=1;}
00404 else if (isclass(klass)) {
00405 result=(pointer)makeobject(klass);
00406 i=0;}
00407 else error(E_NOCLASS,name);
00408 vpush(result);
00409 ch=nextch(ctx,s);
00410 while (ch!=')' && ch!=EOF) {
00411 unreadch(s,ch);
00412 elem=read1(ctx,s);
00413 if (islabref(elem)) {
00414 addunsolved(elem,&result->c.obj.iv[i++]); }
00415 else result->c.obj.iv[i++]=elem;
00416 ch=nextch(ctx,s);
00417 }
00418 vpop();
00419 return(result); }
00420
00421 static pointer readstructure(ctx,s)
00422 register context *ctx;
00423 register pointer s;
00424 { register pointer name, klass, slot, elem, result, varvec, *slotp;
00425 Char ch;
00426
00427 ch=nextch(ctx,s);
00428 if (ch!='(') error(E_READOBJECT);
00429 name=read1(ctx,s);
00430 if (!issymbol(name)) error(E_READOBJECT);
00431 klass=speval(name);
00432 if (klass==UNBOUND) error(E_NOCLASS,name);
00433 if (!isclass(klass)) error(E_READOBJECT);
00434 if (isvecclass(klass)) { error(E_NOCLASS,name);}
00435 else if (isclass(klass)) result=(pointer)makeobject(klass);
00436 else error(E_NOCLASS,name);
00437 vpush(result);
00438 ch=nextch(ctx,s);
00439 while (ch!=')' && ch!=EOF) {
00440 unreadch(s,ch);
00441 slot=read1(ctx,s);
00442 if (!issymbol(slot)) error(E_NOSYMBOL);
00443 elem=read1(ctx,s);
00444 slotp=(pointer *)getobjv(slot,klass->c.cls.vars,result);
00445 if (slotp!=NULL) {
00446 if (islabref(elem)) {
00447 addunsolved(elem,slotp); }
00448 else pointer_update(*slotp,elem); }
00449 ch=nextch(ctx,s);
00450 }
00451 vpop();
00452 return(result); }
00453
00454
00455
00456
00457 static pointer read_sharp_char(ctx,f,val,subchar)
00458 register context *ctx;
00459 register pointer f;
00460 eusinteger_t val;
00461 int subchar;
00462 { char ch;
00463 ch=readch(f); return(makeint(ch));}
00464
00465 static pointer read_sharp_comment(ctx,f,val,subchar)
00466 register context *ctx;
00467 register pointer f;
00468 register eusinteger_t val;
00469 register int subchar;
00470 { Char ch;
00471 val=0;
00472 ch=readch(f);
00473 morecomments:
00474 while (ch!=subchar && ch!='#' && ch!=EOF) ch=readch(f);
00475 if (ch==EOF) return((pointer)EOF);
00476 if (ch==subchar) {
00477 ch=readch(f);
00478 if (ch=='#') { if (--val<0) return(UNBOUND);}
00479 goto morecomments;}
00480 ch=readch(f);
00481 if (ch==subchar) { ch=readch(f); val++;}
00482 goto morecomments;}
00483
00484 static pointer read_sharp_hex(ctx,f,val,subchar)
00485 register context *ctx;
00486 register pointer f;
00487 eusinteger_t val;
00488 int subchar;
00489 { register int i=0,j,c,p,q;
00490 pointer b;
00491 eusinteger_t *bv,x;
00492 char ch, buf[WORD_SIZE];
00493
00494 ch=readch(f);
00495 while (i<WORD_SIZE && isxdigit(ch)) { buf[i++] = ch; ch=readch(f);}
00496 unreadch(f,ch); buf[i]=0;
00497 j = i*4 - (buf[0]<'2' ? 3 :
00498 buf[0]<'4' ? 2 :
00499 buf[0]<'8' ? 1 : 0);
00500 if (j<WORD_SIZE-2) { sscanf(buf,"%lx",&val); return(makeint(val));}
00501 else {
00502 b= (pointer)makebig((j+WORD_SIZE-2)/(WORD_SIZE-1));
00503 bv=bigvec(b);
00504 p=0;q=0;
00505 for (j=i-1; j>=0; j--) {
00506 c=toupper(buf[j]);
00507 x=(c<='9')?(c-'0'):(c-'A'+10);
00508 bv[p/(WORD_SIZE-1)] |= ((x << q) & MASK);
00509 if (q>=(WORD_SIZE-4) && (x>>(WORD_SIZE-1-q)))
00510 bv[p/(WORD_SIZE-1) + 1] = x>>(WORD_SIZE-1-q);
00511 p +=4; q = (q+4) % (WORD_SIZE-1);
00512 }
00513 b=(pointer)normalize_bignum(b);
00514 return(b);}
00515 }
00516
00517 static pointer read_sharp_octal(ctx,f,val,subchar)
00518 register context *ctx;
00519 pointer f;
00520 eusinteger_t val;
00521 int subchar;
00522 { register int i=0;
00523 char buf[WORD_SIZE/2], ch;
00524 ch=readch(f); val=0;
00525 while (i<WORD_SIZE/2 && ch>='0' && ch<'8') { buf[i++] = ch; ch=readch(f);}
00526 unreadch(f,ch); buf[i]=0;
00527 sscanf(buf,"%lo",&val);
00528 return(makeint(val));}
00529
00530 static pointer read_sharp_function(ctx,f,val,subchar)
00531 register context *ctx;
00532 pointer f;
00533 eusinteger_t val;
00534 int subchar;
00535 { return(cons(ctx,FUNCTION,cons(ctx,read1(ctx,f),NIL)));}
00536
00537 static pointer read_uninterned_symbol(ctx,f,val,subchar,token)
00538 context *ctx;
00539 pointer f;
00540 eusinteger_t val;
00541 int subchar;
00542 char token[];
00543 { register int i=0;
00544 char ch;
00545 ch=readch(f);
00546 while (syntaxtype(ch)==ch_constituent) {
00547 token[i++]=to_upper(ch); ch=readch(f);}
00548 token[i]=0; unreadch(f,ch);
00549 return(makesymbol(ctx,(char *)token,i,NIL));}
00550
00551 static pointer read_sharp_eval(ctx,f)
00552 register context *ctx;
00553 pointer f;
00554 { pointer p;
00555 p=read1(ctx,f);
00556
00557 return(eval(ctx,p));}
00558
00559 static pointer eval_read_cond(ctx,expr)
00560 context *ctx;
00561 pointer expr;
00562 { pointer r;
00563 if (issymbol(expr)) return(memq(expr,speval(FEATURES)));
00564 if (iscons(expr)) {
00565 if (ccar(expr)==QNOT) {
00566 r=eval_read_cond(ctx,ccar(ccdr(expr)));
00567 return((r==NIL)?T:NIL);}
00568 else if (ccar(expr)==QAND) {
00569 expr=ccdr(expr);
00570 while (iscons(expr)) {
00571 r=eval_read_cond(ctx,ccar(expr));
00572 if (r==NIL) return(NIL);
00573 else expr=ccdr(expr);}
00574 return(T);}
00575 else if (ccar(expr)==QOR) {
00576 expr=ccdr(expr);
00577 while (iscons(expr)) {
00578 r=eval_read_cond(ctx,ccar(expr));
00579 if (r!=NIL) return(T);
00580 else expr=ccdr(expr);}
00581 return(NIL);}}
00582 error(E_USER,(pointer)"AND/OR/NOT expected in #+ or #-", expr);}
00583
00584 static pointer read_cond_plus(ctx,f)
00585 register context *ctx;
00586 register pointer f;
00587 { register pointer flag,result;
00588 flag=read1(ctx,f);
00589 vpush(flag);
00590 result=read1(ctx,f);
00591 if (eval_read_cond(ctx,flag)==NIL) result=(pointer)UNBOUND;
00592 vpop();
00593 return(result);}
00594
00595 static pointer read_cond_minus(ctx,f)
00596 register context *ctx;
00597 register pointer f;
00598 { register pointer flag,result;
00599 flag=read1(ctx,f);
00600 vpush(flag);
00601 result=read1(ctx,f);
00602 if (eval_read_cond(ctx,flag)!=NIL) result=(pointer)UNBOUND;
00603 vpop();
00604 return(result);}
00605
00606 static pointer read_sharp_object(ctx,f)
00607 register context *ctx;
00608 register pointer f;
00609 { register pointer element,result,obj;
00610 register eusinteger_t val;
00611 Char ch;
00612 element=read1(ctx,f);
00613 if (!issymbol(element)) error(E_NOSYMBOL);
00614 element=speval(element);
00615 if (element==UNBOUND || !isclass(element)) error(E_NOCLASS,element);
00616 obj=read1(ctx,f); val=ckintval(obj);
00617 result=makepointer(val);
00618 if (classof(result)!=element)
00619 error(E_TYPEMISMATCH, (pointer)"read #<> class mismatch");
00620 ch=readch(f);
00621 while (ch!='>' && ch!=EOF) ch=readch(f);
00622 return(result);}
00623
00624 static pointer readsharp(ctx,f,ch,token)
00625 register context *ctx;
00626 register pointer f;
00627 Char ch;
00628 char token[];
00629 { register eusinteger_t val=0;
00630 register int i=0,subchar;
00631 pointer macrofunc,result;
00632 pointer (*intmac)();
00633
00634 ch=readch(f);
00635 if (ch==EOF) return(UNBOUND);
00636 while (isdigit(ch)) {
00637 val=val*10+ch-'0'; ch=nextch(ctx,f);
00638 if (ch==EOF) return(UNBOUND);}
00639 subchar=to_upper(ch);
00640 macrofunc=Spevalof(QREADTABLE)->c.rdtab.dispatch->c.vec.v[subchar];
00641 if (macrofunc==NIL) error(E_USER,(pointer)"no # macro defined");
00642 if (isint(macrofunc)) {
00643 intmac=(pointer (*)())(intval(macrofunc));
00644 result=(*intmac)(ctx,f,val,subchar,token);}
00645 else {
00646 vpush(f); vpush(makeint(subchar)); vpush(makeint(val));
00647 result=ufuncall(ctx,macrofunc,macrofunc,(pointer)(ctx->vsp-3),NULL,3);
00648 ctx->vsp-=3;}
00649 return(result);}
00650
00651 static pointer readstring(ctx,f,terminator)
00652 register context *ctx;
00653 pointer f;
00654 int terminator;
00655 { int tleng = 0, lengmax=MAXSTRINGLENGTH;
00656 byte buf[MAXSTRINGLENGTH], *token, *newtoken;
00657 int ch, malloced=FALSE;
00658 pointer p;
00659
00660 ch=readch(f);
00661 token=buf;
00662 while ((ch!=terminator) && (ch!=EOF)) {
00663 if (syntaxtype(ch) == ch_sglescape) ch=readch(f);
00664 token[tleng++]=ch;
00665 if (tleng >= lengmax) {
00666
00667 newtoken=(byte *)malloc(lengmax*2);
00668 memcpy(newtoken,token,tleng);
00669 if (malloced==TRUE) cfree(token);
00670 malloced=TRUE;
00671 token=newtoken; lengmax=lengmax*2;
00672 }
00673 ch=readch(f);}
00674 token[tleng] = '\0';
00675 p=makestring((char *)token,tleng);
00676 if (malloced==TRUE) cfree(token);
00677 return(p);
00678 }
00679
00680 static pointer readsymbol(ctx,leng,colon, token)
00681 register context *ctx;
00682 register int leng,colon;
00683 char token[];
00684 { register pointer pkg;
00685 pointer pkgstr,sym;
00686 register int doublecolon=1;
00687 int hash;
00688 if (colon==0) pkg=keywordpkg;
00689 else if (colon>0) {
00690 if (charattr[token[colon-1]]==package_marker) {
00691 pkg=(pointer)searchpkg((byte *)token,colon-1);}
00692 else {
00693 doublecolon=0;
00694 pkg=(pointer)searchpkg((byte *)token,colon);}
00695 if (pkg==(pointer)NULL) {
00696 if (doublecolon) colon--;
00697 pkgstr=makestring(token,colon);
00698 vpush(pkgstr);
00699 error(E_NOPACKAGE,pkgstr);} }
00700 else pkg=Spevalof(PACKAGE);
00701 colon++;
00702 if (doublecolon) return(intern(ctx,&token[colon],leng-colon,pkg));
00703 else {
00704 sym=findsymbol((byte *)&token[colon],leng-colon, pkg->c.pkg.symvector, &hash);
00705
00706 if (sym) return(sym);
00707 else {
00708 pkgstr=makestring(token,leng);
00709 fprintf(stderr,"%s ",token);
00710 vpush(pkgstr);
00711 error(E_EXTSYMBOL,pkgstr);}
00712 } }
00713
00714
00715 #if news || sanyo
00716 int strtol(str,ptr,base)
00717 register char *str,**ptr;
00718 register int base;
00719 { long val=0,sign=1;
00720 char ch;
00721 while (isspace(*str)) str++;
00722 ch= *str;
00723 if (ch=='+') str++; else if (ch=='-') { str++; sign= -1;}
00724 if (base<=10) {
00725 while ('0'<= *str && *str<('0'+base)) val=val*base+(*str++)-'0';
00726 return(sign*val);}
00727 else {
00728 while (1) {
00729 if ('0'<= *str && *str<='9') val=val*base+(*str++ -'0');
00730 else if ('A'<= *str && *str<('A'+base-10)) val=val*base+(*str++ - 'A'+10);
00731 else if ('a'<= *str && *str<('a'+base-10)) val=val*base+(*str++ - 'a'+10);
00732 else break;
00733 continue;}
00734 return(sign*val);}}
00735 #endif
00736
00737 static pointer readint(ctx,token,len)
00738 context *ctx;
00739 char *token;
00740 int len;
00741 { eusinteger_t base=intval(Spevalof(READBASE));
00742 int head,i,sign=1, k;
00743 pointer b;
00744
00745 if (len<8) {
00746 i=strtol(token,NULL,base);
00747 return(makeint(i));}
00748 else {
00749 if (token[0]=='+') { head=1;}
00750 else if (token[0]=='-') {head=1; sign= -1;}
00751 else head=0;
00752 b=(pointer)makebig1(0);
00753 vpush(b);
00754 for (i=head; i<len; i++) {
00755 k= (int) token[i];
00756 if (k>='0' && k<='9') k= k-'0';
00757 else if (k>='A' && k<='Z') k=k-'A'+10;
00758 else if (k>='a' && k<='z') k=k-'a'+10;
00759 else if (k=='.') continue;
00760 else error(E_USER,(pointer)"illegal integer consituent char");
00761 mul_int_big(base,b);
00762 add_int_big(k,b); }
00763 if (sign<0) complement_big(b);
00764 b=(pointer)normalize_bignum(b);
00765 }
00766 ctx->lastalloc= vpop();
00767 return(b);}
00768
00769 is_digit(ch,base)
00770 register int ch,base;
00771 { if (ch<'0') return(FALSE);
00772 if (base<=10)
00773 if (ch<'0'+base) return(TRUE);
00774 else return(FALSE);
00775 else if (ch<='9') return(TRUE);
00776 else if ('A'<=ch && ch<'A'+base-10) return(TRUE);
00777 else return(FALSE);}
00778
00779 pointer read_delimited_list(ctx,f,delim_char,token)
00780 register context *ctx;
00781 pointer f;
00782 int delim_char;
00783 char token[];
00784 { pointer result=NIL;
00785 pointer temp,element;
00786 Char ch;
00787 ch=nextch(ctx,f);
00788 vpush(STOPPER);
00789 while (ch!=delim_char && ch!=EOF) {
00790 if (ch=='.') {
00791 ch=readch(f); unreadch(f,ch);
00792 if (syntaxtype(ch)==ch_constituent) {
00793 token[0]='.';
00794 element=read2(ctx,f,0,0,1,token, -1);}
00795 else if (syntaxtype(ch)==ch_white) {
00796 result=read1(ctx,f);
00797 ch=nextch(ctx,f);
00798 if (ch!=delim_char) error(E_READ);
00799 break;}
00800 else error(E_READ);}
00801 else { unreadch(f,ch); element=read1(ctx,f);}
00802 if (element!=UNBOUND && element!=(pointer)EOF) ckpush(element);
00803 ch=nextch(ctx,f);}
00804 while ((element=vpop())!=STOPPER) {
00805 temp=cons(ctx,element,result);
00806 if (islabref(element)) addunsolved(element,&temp->c.cons.car);
00807 if (islabref(result)) addunsolved(result,&temp->c.cons.cdr);
00808 result=temp;}
00809 return(result); }
00810
00811 static pointer readlist(ctx,f,ch,token)
00812 register context *ctx;
00813 pointer f;
00814 char ch, token[];
00815 { return(read_delimited_list(ctx,f,')',token));}
00816
00817 static pointer readquote(ctx,f)
00818 register context *ctx;
00819 pointer f;
00820 { pointer q;
00821 q=read1(ctx,f);
00822 if (q==(pointer)EOF) return((pointer)EOF);
00823 return(cons(ctx,QUOTE,cons(ctx,q,NIL)));}
00824
00825 static pointer readcomment(ctx,f)
00826 pointer f;
00827 { register Char ch;
00828 do { ch=readch(f);} while (ch!='\n' && ch!=EOF);
00829 return(UNBOUND);}
00830
00831 static pointer readrparen(ctx,f)
00832 { return(UNBOUND);}
00833
00834
00835
00836 int gcd(u,v)
00837 register int u,v;
00838 { register int t;
00839 if(u<0) u = -u;
00840 if(v<0) v = -v;
00841 if(u<v) {t=u; u=v; v=t;}
00842 while(v!=0){t=u % v; u=v; v=t;}
00843 return(u);}
00844
00845 static pointer readratio(ctx,token,slash)
00846 context *ctx;
00847 char *token;
00848 int slash;
00849 { int num, denom, g;
00850 extern pointer makeratio();
00851 num=strtol(token,NULL,intval(Spevalof(READBASE)));
00852 denom=strtol(&token[slash+1],NULL,intval(Spevalof(READBASE)));
00853 g=gcd(num, denom);
00854 if (g!=0) { num /= g; denom /= g;}
00855 else return(makeint(0));
00856 if (denom==1) return(makeint(num));
00857 return(makeratio(num, denom));}
00858
00859
00860 static pointer read2(ctx,ins,escaped,multiescaped,i,token,colon)
00861 register context *ctx;
00862 register pointer ins;
00863 int escaped,multiescaped,i;
00864 char token[];
00865 int colon;
00866 { register int j,c;
00867 register eusinteger_t base;
00868 int slash;
00869 enum ch_type ctype;
00870
00871 int ch;
00872 pointer readcase;
00873 numunion nu;
00874 extern double atof();
00875
00876 readcase=Spevalof(QREADTABLE)->c.rdtab.readcase;
00877
00878 if (multiescaped) goto step9;
00879 step8:
00880 if (i>=MAXTOKENLENGTH) error(E_LONGSTRING);
00881 ch=readch(ins);
00882 if (ch==EOF) goto step10;
00883 if (ch<0) ch &= 0xff;
00884 ctype=syntaxtype(ch);
00885 switch(ctype) {
00886 case ch_constituent: case ch_nontermacro:
00887 if (charattr[ch]==package_marker) colon=i;
00888 if (readcase==K_DOWNCASE) ch=to_lower(ch);
00889 else if (readcase==K_PRESERVE) ch=ch;
00890 else ch=to_upper(ch);
00891 token[i++]=ch; goto step8;
00892 case ch_sglescape:
00893 token[i++]=readch(ins); escaped=1; goto step8;
00894 case ch_multiescape:
00895 goto step9;
00896 case ch_illegal:
00897 error(E_ILLCH,makeint(ch)); break;
00898 case ch_termmacro:
00899 unreadch(ins,ch); goto step10;
00900 case ch_white:
00901 unreadch(ins,ch); goto step10;
00902 default: error(E_USER,(pointer)"unknown char type");}
00903 step9:
00904 escaped=1;
00905 if (i>=MAXTOKENLENGTH) error(E_LONGSTRING);
00906 ch=readch(ins);
00907 if (ch==EOF) error(E_EOF);
00908 ch &= 0xff;
00909 ctype=syntaxtype(ch);
00910 switch(ctype) {
00911 case ch_constituent: case ch_white:
00912 case ch_nontermacro: case ch_termmacro:
00913 token[i++]=ch; goto step9;
00914 case ch_sglescape:
00915 ch=readch(ins); token[i++]=ch; goto step9;
00916 case ch_multiescape:
00917 goto step8;
00918 default: error(E_ILLCH,makeint(ch));}
00919 step10:
00920
00921 token[i]=0;
00922 if (escaped) return(readsymbol(ctx,i,colon,token));
00923 base=intval(Spevalof(READBASE));
00924
00925 j=0;
00926 if ((token[j]=='+') || (token[j]=='-')) j++;
00927 else if (token[j]=='.' && token[j+1]=='\0')
00928 return(readsymbol(ctx,i,colon,token));
00929 if (is_digit(token[j],base) || token[j]=='.') {
00930 while (is_digit(token[j],base)) j++;
00931 if (token[j] == '.') {
00932 if (++j==i) return(readint(ctx,token,i));
00933
00934 while (is_digit(token[j],base)) j++;
00935 c=to_upper(token[j]);
00936 if (c=='E' || c=='D' || c=='F' || c=='L') {
00937 c=j; j++;
00938 if ((token[j]=='+') || (token[j]=='-')) j++;
00939 while (is_digit(token[j],base)) j++;
00940 if (j==i) { token[c]='E'; return(makeflt(atof(token)));}
00941 else return(readsymbol(ctx,i,colon,token));}
00942 else if (j==i) return(makeflt(atof(token)));
00943 else return(readsymbol(ctx,i,colon,token));}
00944 else if (token[j] == '/') {
00945 slash=j;
00946 if (++j==i) return(readsymbol(ctx,i,colon,token));
00947
00948 while (is_digit(token[j],base)) j++;
00949 if (j==i) return(readratio(ctx,token,slash));
00950 else return(readsymbol(ctx,i,colon,token));}
00951 else if (j==i) return(readint(ctx,token,i));
00952 else {
00953 c=to_upper(token[j]);
00954 if (c=='E' || c=='D' || c=='F' || c=='L') {
00955 c=j; j++;
00956 if ((token[j]=='+') || (token[j]=='-')) j++;
00957 while (is_digit(token[j],base)) j++;
00958 if (j==i) { token[c]='E'; return(makeflt(atof(token)));}
00959 else return(readsymbol(ctx,i,colon,token));}
00960 else if (j==i) return(makeflt(atof(token)));
00961 else return(readsymbol(ctx,i,colon,token));} }
00962 else return(readsymbol(ctx,i,colon,token));}
00963
00964 static pointer read1(ctx,ins)
00965 register context *ctx;
00966 register pointer ins;
00967 { register enum ch_type ctype;
00968 register int firstch;
00969 register pointer macrofunc,result;
00970 pointer (*intmac)();
00971 int colon;
00972
00973 int ch;
00974 char token[MAXTOKENLENGTH];
00975 pointer readcase;
00976
00977 colon= -1;
00978 step1:
00979 ch=readch(ins);
00980 if (ch==EOF) return((pointer)EOF);
00981 ch &= 0xff;
00982 firstch=ch;
00983 ctype=syntaxtype(ch);
00984 switch(ctype) {
00985 case ch_illegal: error(E_ILLCH,makeint(ch));
00986 case ch_white: goto step1;
00987 case ch_termmacro: case ch_nontermacro:
00988 macrofunc=Spevalof(QREADTABLE)->c.rdtab.macro->c.vec.v[ch];
00989 if (macrofunc==NIL) error(E_USER,(pointer)"no char macro defined");
00990 if (isint(macrofunc)) {
00991 intmac=(pointer (*)())(intval(macrofunc));
00992 result=(*intmac)(ctx,ins,ch,token);}
00993 else {
00994 vpush(ins); vpush(makeint(ch));
00995 result=ufuncall(ctx,macrofunc,macrofunc,(pointer)(ctx->vsp-2),NULL,2);
00996 ctx->vsp-=2;}
00997
00998
00999 return(result);
01000 case ch_sglescape: token[0]=readch(ins);
01001 return(read2(ctx,ins,1,0,1,token,colon));
01002 case ch_multiescape: return(read2(ctx,ins,1,1,0,token,colon));
01003 case ch_constituent:
01004 if (charattr[ch]==package_marker) colon=0;
01005 readcase=Spevalof(QREADTABLE)->c.rdtab.readcase;
01006 if (readcase==K_DOWNCASE) ch=to_lower(ch);
01007 else if (readcase==K_PRESERVE) ch=ch;
01008 else ch=to_upper(ch);
01009 token[0]= ch;
01010 return(read2(ctx,ins,0,0,1,token,colon));}}
01011
01012 pointer reader(ctx,f,recursivep)
01013 register context *ctx;
01014 register pointer f,recursivep;
01015 { register pointer val;
01016 Char ch;
01017 current_syntax[thr_self()]=Spevalof(QREADTABLE)->c.rdtab.syntax->c.str.chars;
01018 ch=nextch(ctx,f);
01019 if (ch==EOF) return((pointer)EOF);
01020 while (ch==')') ch=nextch(ctx,f);
01021 unreadch(f,ch);
01022 if (recursivep==NIL) {
01023 pointer_update(oblabels[thr_self()]->c.lab.next,NIL);
01024 val=read1(ctx,f);
01025 pointer_update(oblabels[thr_self()]->c.lab.next,NIL);}
01026 else val=read1(ctx,f);
01027 if (val==UNBOUND) return(NIL);
01028 return(val);}
01029
01030 void initreader(ctx)
01031 register context *ctx;
01032 { register pointer rdtable;
01033 register int i;
01034
01035 charmacro['(']=makeint((eusinteger_t)readlist);
01036 charmacro[')']=makeint((eusinteger_t)readrparen);
01037 charmacro['#']=makeint((eusinteger_t)readsharp);
01038 charmacro['\'']=makeint((eusinteger_t)readquote);
01039 charmacro['"']=makeint((eusinteger_t)readstring);
01040 charmacro[';']=makeint((eusinteger_t)readcomment);
01041
01042 sharpmacro['\\']=makeint((eusinteger_t)read_sharp_char);
01043 sharpmacro['\'']=makeint((eusinteger_t)read_sharp_function);
01044 sharpmacro[':']=makeint((eusinteger_t)read_uninterned_symbol);
01045 sharpmacro[',']=makeint((eusinteger_t)read_sharp_eval);
01046 sharpmacro['.']=makeint((eusinteger_t)read_sharp_eval);
01047 sharpmacro['|']=makeint((eusinteger_t)read_sharp_comment);
01048 sharpmacro['+']=makeint((eusinteger_t)read_cond_plus);
01049 sharpmacro['-']=makeint((eusinteger_t)read_cond_minus);
01050 sharpmacro['#']=makeint((eusinteger_t)readlabref);
01051 sharpmacro['=']=makeint((eusinteger_t)readlabdef);
01052 sharpmacro['(']=makeint((eusinteger_t)readvector);
01053 sharpmacro['<']=makeint((eusinteger_t)read_sharp_object);
01054 sharpmacro['X']=makeint((eusinteger_t)read_sharp_hex);
01055 sharpmacro['O']=makeint((eusinteger_t)read_sharp_octal);
01056 sharpmacro['S']=makeint((eusinteger_t)readstructure);
01057 sharpmacro['F']=makeint((eusinteger_t)readfvector);
01058 sharpmacro['I']=makeint((eusinteger_t)readivector);
01059 sharpmacro['J']=makeint((eusinteger_t)readobject);
01060 sharpmacro['V']=makeint((eusinteger_t)readobject);
01061
01062
01063 rdtable=(pointer)makereadtable(ctx);
01064 pointer_update(Spevalof(QREADTABLE),rdtable);
01065 for (i=0; i<256; i++) {
01066 rdtable->c.rdtab.syntax->c.str.chars[i]=(int)chartype[i];
01067 rdtable->c.rdtab.macro->c.vec.v[i]=charmacro[i];
01068 rdtable->c.rdtab.dispatch->c.vec.v[i]=sharpmacro[i];
01069 rdtable->c.rdtab.readcase=K_UPCASE;
01070 }
01071 }