read.c revision 31de2854
1/* 2 * Copyright (c) 2002 by The XFree86 Project, Inc. 3 * 4 * Permission is hereby granted, free of charge, to any person obtaining a 5 * copy of this software and associated documentation files (the "Software"), 6 * to deal in the Software without restriction, including without limitation 7 * the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 * and/or sell copies of the Software, and to permit persons to whom the 9 * Software is furnished to do so, subject to the following conditions: 10 * 11 * The above copyright notice and this permission notice shall be included in 12 * all copies or substantial portions of the Software. 13 * 14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 17 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 18 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF 19 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 20 * SOFTWARE. 21 * 22 * Except as contained in this notice, the name of the XFree86 Project shall 23 * not be used in advertising or otherwise to promote the sale, use or other 24 * dealings in this Software without prior written authorization from the 25 * XFree86 Project. 26 * 27 * Author: Paulo César Pereira de Andrade 28 */ 29 30/* $XFree86: xc/programs/xedit/lisp/read.c,v 1.36tsi Exp $ */ 31 32#include <errno.h> 33#include "lisp/read.h" 34#include "lisp/package.h" 35#include "lisp/write.h" 36#include <fcntl.h> 37#include <stdarg.h> 38 39/* This should be visible only in read.c, but if an error is generated, 40 * the current code in write.c will print it as #<ERROR> */ 41#define LABEL_BIT_COUNT 8 42#define LABEL_BIT_MASK 0xff 43#define MAX_LABEL_VALUE ((1L << (sizeof(long) * 8 - 9)) - 1) 44#define READLABEL(label) \ 45 (LispObj*)(((label) << LABEL_BIT_COUNT) | READLABEL_MASK) 46#define READLABELP(object) \ 47 (((unsigned long)(object) & LABEL_BIT_MASK) == READLABEL_MASK) 48#define READLABEL_VALUE(object) \ 49 ((long)(object) >> LABEL_BIT_COUNT) 50 51#define READ_ENTER() \ 52 LispObj *read__stream = SINPUT; \ 53 int read__line = LispGetLine(read__stream) 54#define READ_ERROR0(format) \ 55 LispReadError(read__stream, read__line, format) 56#define READ_ERROR1(format, arg1) \ 57 LispReadError(read__stream, read__line, format, arg1) 58#define READ_ERROR2(format, arg1, arg2) \ 59 LispReadError(read__stream, read__line, format, arg1, arg2) 60 61#define READ_ERROR_EOF() READ_ERROR0("unexpected end of input") 62#define READ_ERROR_FIXNUM() READ_ERROR0("number is not a fixnum") 63#define READ_ERROR_INVARG() READ_ERROR0("invalid argument") 64 65#ifdef __UNIXOS2__ 66# define finite(x) isfinite(x) 67#endif 68 69/* 70 * Types 71 */ 72typedef struct _object_info { 73 long label; /* the read label of this object */ 74 LispObj *object; /* the resulting object */ 75 long num_circles; /* references to object before it was completely read */ 76} object_info; 77 78typedef struct _read_info { 79 int level; /* level of open parentheses */ 80 81 int nodot; /* flag set when reading a "special" list */ 82 83 int discard; /* flag used when reading an unavailable feature */ 84 85 long circle_count; /* if non zero, must resolve some labels */ 86 87 /* information for #<number>= and #<number># */ 88 object_info *objects; 89 long num_objects; 90 91 /* could use only the objects field as all circular data is known, 92 * but check every object so that circular/shared references generated 93 * by evaluations would not cause an infinite loop at read time */ 94 LispObj **circles; 95 long num_circles; 96} read_info; 97 98/* 99 * Protypes 100 */ 101static LispObj *LispReadChar(LispBuiltin*, int); 102 103static int LispGetLine(LispObj*); 104#ifdef __GNUC__ 105#define PRINTF_FORMAT __attribute__ ((format (printf, 3, 4))) 106#else 107#define PRINTF_FORMAT /**/ 108#endif 109static void LispReadError(LispObj*, int, char*, ...); 110#undef PRINTF_FORMAT 111static void LispReadFixCircle(LispObj*, read_info*); 112static LispObj *LispReadLabelCircle(LispObj*, read_info*); 113static int LispReadCheckCircle(LispObj*, read_info*); 114static LispObj *LispDoRead(read_info*); 115static int LispSkipWhiteSpace(void); 116static LispObj *LispReadList(read_info*); 117static LispObj *LispReadQuote(read_info*); 118static LispObj *LispReadBackquote(read_info*); 119static LispObj *LispReadCommaquote(read_info*); 120static LispObj *LispReadObject(int, read_info*); 121static LispObj *LispParseAtom(char*, char*, int, int, LispObj*, int); 122static LispObj *LispParseNumber(char*, int, LispObj*, int); 123static int StringInRadix(char*, int, int); 124static int AtomSeparator(int, int, int); 125static LispObj *LispReadVector(read_info*); 126static LispObj *LispReadMacro(read_info*); 127static LispObj *LispReadFunction(read_info*); 128static LispObj *LispReadRational(int, read_info*); 129static LispObj *LispReadCharacter(read_info*); 130static void LispSkipComment(void); 131static LispObj *LispReadEval(read_info*); 132static LispObj *LispReadComplex(read_info*); 133static LispObj *LispReadPathname(read_info*); 134static LispObj *LispReadStruct(read_info*); 135static LispObj *LispReadMacroArg(read_info*); 136static LispObj *LispReadArray(long, read_info*); 137static LispObj *LispReadFeature(int, read_info*); 138static LispObj *LispEvalFeature(LispObj*); 139 140/* 141 * Initialization 142 */ 143static char *Char_Nul[] = {"Null", "Nul", NULL}; 144static char *Char_Soh[] = {"Soh", NULL}; 145static char *Char_Stx[] = {"Stx", NULL}; 146static char *Char_Etx[] = {"Etx", NULL}; 147static char *Char_Eot[] = {"Eot", NULL}; 148static char *Char_Enq[] = {"Enq", NULL}; 149static char *Char_Ack[] = {"Ack", NULL}; 150static char *Char_Bel[] = {"Bell", "Bel", NULL}; 151static char *Char_Bs[] = {"Backspace", "Bs", NULL}; 152static char *Char_Tab[] = {"Tab", NULL}; 153static char *Char_Nl[] = {"Newline", "Nl", "Lf", "Linefeed", NULL}; 154static char *Char_Vt[] = {"Vt", NULL}; 155static char *Char_Np[] = {"Page", "Np", NULL}; 156static char *Char_Cr[] = {"Return", "Cr", NULL}; 157static char *Char_Ff[] = {"So", "Ff", NULL}; 158static char *Char_Si[] = {"Si", NULL}; 159static char *Char_Dle[] = {"Dle", NULL}; 160static char *Char_Dc1[] = {"Dc1", NULL}; 161static char *Char_Dc2[] = {"Dc2", NULL}; 162static char *Char_Dc3[] = {"Dc3", NULL}; 163static char *Char_Dc4[] = {"Dc4", NULL}; 164static char *Char_Nak[] = {"Nak", NULL}; 165static char *Char_Syn[] = {"Syn", NULL}; 166static char *Char_Etb[] = {"Etb", NULL}; 167static char *Char_Can[] = {"Can", NULL}; 168static char *Char_Em[] = {"Em", NULL}; 169static char *Char_Sub[] = {"Sub", NULL}; 170static char *Char_Esc[] = {"Escape", "Esc", NULL}; 171static char *Char_Fs[] = {"Fs", NULL}; 172static char *Char_Gs[] = {"Gs", NULL}; 173static char *Char_Rs[] = {"Rs", NULL}; 174static char *Char_Us[] = {"Us", NULL}; 175static char *Char_Sp[] = {"Space", "Sp", NULL}; 176static char *Char_Del[] = {"Rubout", "Del", "Delete", NULL}; 177 178LispCharInfo LispChars[256] = { 179 {Char_Nul}, 180 {Char_Soh}, 181 {Char_Stx}, 182 {Char_Etx}, 183 {Char_Eot}, 184 {Char_Enq}, 185 {Char_Ack}, 186 {Char_Bel}, 187 {Char_Bs}, 188 {Char_Tab}, 189 {Char_Nl}, 190 {Char_Vt}, 191 {Char_Np}, 192 {Char_Cr}, 193 {Char_Ff}, 194 {Char_Si}, 195 {Char_Dle}, 196 {Char_Dc1}, 197 {Char_Dc2}, 198 {Char_Dc3}, 199 {Char_Dc4}, 200 {Char_Nak}, 201 {Char_Syn}, 202 {Char_Etb}, 203 {Char_Can}, 204 {Char_Em}, 205 {Char_Sub}, 206 {Char_Esc}, 207 {Char_Fs}, 208 {Char_Gs}, 209 {Char_Rs}, 210 {Char_Us}, 211 {Char_Sp}, 212 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 213 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 214 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 215 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 216 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 217 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 218 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 219 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 220 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 221 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 222 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 223 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 224 {Char_Del}, 225 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 226 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 227 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 228 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 229 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 230 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 231 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 232 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 233 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 234 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 235 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 236 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 237 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 238 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 239 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, 240 {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL}, {NULL} 241 242}; 243 244Atom_id Sand, Sor, Snot; 245 246 247/* 248 * Implementation 249 */ 250LispObj * 251Lisp_Read(LispBuiltin *builtin) 252/* 253 read &optional input-stream eof-error-p eof-value recursive-p 254 */ 255{ 256 LispObj *result; 257 258 LispObj *input_stream, *eof_error_p, *eof_value; 259 260 eof_value = ARGUMENT(2); 261 eof_error_p = ARGUMENT(1); 262 input_stream = ARGUMENT(0); 263 264 if (input_stream == UNSPEC) 265 input_stream = NIL; 266 else if (input_stream != NIL) { 267 CHECK_STREAM(input_stream); 268 else if (!input_stream->data.stream.readable) 269 LispDestroy("%s: stream %s is not readable", 270 STRFUN(builtin), STROBJ(input_stream)); 271 LispPushInput(input_stream); 272 } 273 else if (CONSP(lisp__data.input_list)) { 274 input_stream = STANDARD_INPUT; 275 LispPushInput(input_stream); 276 } 277 278 if (eof_value == UNSPEC) 279 eof_value = NIL; 280 281 result = LispRead(); 282 if (input_stream != NIL) 283 LispPopInput(input_stream); 284 285 if (result == NULL) { 286 if (eof_error_p != NIL) 287 LispDestroy("%s: EOF reading stream %s", 288 STRFUN(builtin), STROBJ(input_stream)); 289 else 290 result = eof_value; 291 } 292 293 return (result); 294} 295 296static LispObj * 297LispReadChar(LispBuiltin *builtin, int nohang) 298{ 299 int character; 300 301 LispObj *input_stream, *eof_error_p, *eof_value; 302 303 eof_value = ARGUMENT(2); 304 eof_error_p = ARGUMENT(1); 305 input_stream = ARGUMENT(0); 306 307 if (input_stream == UNSPEC) 308 input_stream = NIL; 309 else if (input_stream != NIL) { 310 CHECK_STREAM(input_stream); 311 } 312 else 313 input_stream = lisp__data.input; 314 315 if (eof_value == UNSPEC) 316 eof_value = NIL; 317 318 character = EOF; 319 320 if (input_stream->data.stream.readable) { 321 LispFile *file = NULL; 322 323 switch (input_stream->data.stream.type) { 324 case LispStreamStandard: 325 case LispStreamFile: 326 file = FSTREAMP(input_stream); 327 break; 328 case LispStreamPipe: 329 file = IPSTREAMP(input_stream); 330 break; 331 case LispStreamString: 332 character = LispSgetc(SSTREAMP(input_stream)); 333 break; 334 default: 335 break; 336 } 337 if (file != NULL) { 338 if (file->available || file->offset < file->length) 339 character = LispFgetc(file); 340 else { 341 if (nohang && !file->nonblock) { 342 if (fcntl(file->descriptor, F_SETFL, O_NONBLOCK) < 0) 343 LispDestroy("%s: fcntl(%d): %s", 344 STRFUN(builtin), file->descriptor, 345 strerror(errno)); 346 file->nonblock = 1; 347 } 348 else if (!nohang && file->nonblock) { 349 if (fcntl(file->descriptor, F_SETFL, 0) < 0) 350 LispDestroy("%s: fcntl(%d): %s", 351 STRFUN(builtin), file->descriptor, 352 strerror(errno)); 353 file->nonblock = 0; 354 } 355 if (nohang) { 356 unsigned char ch; 357 358 if (read(file->descriptor, &ch, 1) == 1) 359 character = ch; 360 else if (errno == EAGAIN) 361 return (NIL); /* XXX no character available */ 362 else 363 character = EOF; 364 } 365 else 366 character = LispFgetc(file); 367 } 368 } 369 } 370 else 371 LispDestroy("%s: stream %s is unreadable", 372 STRFUN(builtin), STROBJ(input_stream)); 373 374 if (character == EOF) { 375 if (eof_error_p != NIL) 376 LispDestroy("%s: EOF reading stream %s", 377 STRFUN(builtin), STROBJ(input_stream)); 378 379 return (eof_value); 380 } 381 382 return (SCHAR(character)); 383} 384 385LispObj * 386Lisp_ReadChar(LispBuiltin *builtin) 387/* 388 read-char &optional input-stream eof-error-p eof-value recursive-p 389 */ 390{ 391 return (LispReadChar(builtin, 0)); 392} 393 394LispObj * 395Lisp_ReadCharNoHang(LispBuiltin *builtin) 396/* 397 read-char-no-hang &optional input-stream eof-error-p eof-value recursive-p 398 */ 399{ 400 return (LispReadChar(builtin, 1)); 401} 402 403LispObj * 404Lisp_ReadLine(LispBuiltin *builtin) 405/* 406 read-line &optional input-stream eof-error-p eof-value recursive-p 407 */ 408{ 409 char *string; 410 int ch, length; 411 LispObj *result, *status = NIL; 412 413 LispObj *input_stream, *eof_error_p, *eof_value; 414 415 eof_value = ARGUMENT(2); 416 eof_error_p = ARGUMENT(1); 417 input_stream = ARGUMENT(0); 418 419 if (input_stream == UNSPEC) 420 input_stream = NIL; 421 else if (input_stream == NIL) 422 input_stream = STANDARD_INPUT; 423 else { 424 CHECK_STREAM(input_stream); 425 } 426 427 if (eof_value == UNSPEC) 428 eof_value = NIL; 429 430 result = NIL; 431 string = NULL; 432 length = 0; 433 434 if (!input_stream->data.stream.readable) 435 LispDestroy("%s: stream %s is unreadable", 436 STRFUN(builtin), STROBJ(input_stream)); 437 if (input_stream->data.stream.type == LispStreamString) { 438 char *start, *end, *ptr; 439 440 if (SSTREAMP(input_stream)->input >= 441 SSTREAMP(input_stream)->length) { 442 if (eof_error_p != NIL) 443 LispDestroy("%s: EOS found reading %s", 444 STRFUN(builtin), STROBJ(input_stream)); 445 446 status = T; 447 result = eof_value; 448 goto read_line_done; 449 } 450 451 start = SSTREAMP(input_stream)->string + 452 SSTREAMP(input_stream)->input; 453 end = SSTREAMP(input_stream)->string + 454 SSTREAMP(input_stream)->length; 455 /* Search for a newline */ 456 for (ptr = start; *ptr != '\n' && ptr < end; ptr++) 457 ; 458 if (ptr == end) 459 status = T; 460 else if (!SSTREAMP(input_stream)->binary) 461 ++SSTREAMP(input_stream)->line; 462 length = ptr - start; 463 string = LispMalloc(length + 1); 464 memcpy(string, start, length); 465 string[length] = '\0'; 466 result = LSTRING2(string, length); 467 /* macro LSTRING2 does not make a copy of it's arguments, and 468 * calls LispMused on it. */ 469 SSTREAMP(input_stream)->input += length + (status == NIL); 470 } 471 else /*if (input_stream->data.stream.type == LispStreamFile || 472 input_stream->data.stream.type == LispStreamStandard || 473 input_stream->data.stream.type == LispStreamPipe)*/ { 474 LispFile *file; 475 476 if (input_stream->data.stream.type == LispStreamPipe) 477 file = IPSTREAMP(input_stream); 478 else 479 file = FSTREAMP(input_stream); 480 481 if (file->nonblock) { 482 if (fcntl(file->descriptor, F_SETFL, 0) < 0) 483 LispDestroy("%s: fcntl: %s", 484 STRFUN(builtin), strerror(errno)); 485 file->nonblock = 0; 486 } 487 488 while (1) { 489 ch = LispFgetc(file); 490 if (ch == EOF) { 491 if (length) 492 break; 493 if (eof_error_p != NIL) 494 LispDestroy("%s: EOF found reading %s", 495 STRFUN(builtin), STROBJ(input_stream)); 496 if (string) 497 LispFree(string); 498 499 status = T; 500 result = eof_value; 501 goto read_line_done; 502 } 503 else if (ch == '\n') 504 break; 505 else if ((length % 64) == 0) 506 string = LispRealloc(string, length + 64); 507 string[length++] = ch; 508 } 509 if (string) { 510 if ((length % 64) == 0) 511 string = LispRealloc(string, length + 1); 512 string[length] = '\0'; 513 result = LSTRING2(string, length); 514 } 515 else 516 result = STRING(""); 517 } 518 519read_line_done: 520 RETURN(0) = status; 521 RETURN_COUNT = 1; 522 523 return (result); 524} 525 526LispObj * 527LispRead(void) 528{ 529 READ_ENTER(); 530 read_info info; 531 LispObj *result, *code = COD; 532 533 info.level = info.nodot = info.discard = 0; 534 info.circle_count = 0; 535 info.objects = NULL; 536 info.num_objects = 0; 537 538 result = LispDoRead(&info); 539 540 /* fix circular/shared lists, note that this is done when returning to 541 * the toplevel, so, if some circular/shared reference was evaluated, 542 * it should have generated an expected error */ 543 if (info.num_objects) { 544 if (info.circle_count) { 545 info.circles = NULL; 546 info.num_circles = 0; 547 LispReadFixCircle(result, &info); 548 if (info.num_circles) 549 LispFree(info.circles); 550 } 551 LispFree(info.objects); 552 } 553 554 if (result == EOLIST) 555 READ_ERROR0("object cannot start with #\\)"); 556 else if (result == DOT) 557 READ_ERROR0("dot allowed only on lists"); 558 559 if (result != NULL && POINTERP(result)) { 560 if (code == NIL) 561 COD = result; 562 else 563 COD = CONS(COD, result); 564 } 565 566 return (result); 567} 568 569static int 570LispGetLine(LispObj *stream) 571{ 572 int line = -1; 573 574 if (STREAMP(stream)) { 575 switch (stream->data.stream.type) { 576 case LispStreamStandard: 577 case LispStreamFile: 578 if (!FSTREAMP(stream)->binary) 579 line = FSTREAMP(stream)->line; 580 break; 581 case LispStreamPipe: 582 if (!IPSTREAMP(stream)->binary) 583 line = IPSTREAMP(stream)->line; 584 break; 585 case LispStreamString: 586 if (!SSTREAMP(stream)->binary) 587 line = SSTREAMP(stream)->line; 588 break; 589 default: 590 break; 591 } 592 } 593 else if (stream == NIL && !Stdin->binary) 594 line = Stdin->line; 595 596 return (line); 597} 598 599static void 600LispReadError(LispObj *stream, int line, char *fmt, ...) 601{ 602 char string[128], *buffer_string; 603 LispObj *buffer = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0); 604 int length; 605 va_list ap; 606 607 va_start(ap, fmt); 608 vsnprintf(string, sizeof(string), fmt, ap); 609 va_end(ap); 610 611 LispFwrite(Stderr, "*** Reading ", 12); 612 LispWriteObject(buffer, stream); 613 buffer_string = LispGetSstring(SSTREAMP(buffer), &length); 614 LispFwrite(Stderr, buffer_string, length); 615 LispFwrite(Stderr, " at line ", 9); 616 if (line < 0) 617 LispFwrite(Stderr, "?\n", 2); 618 else { 619 char str[32]; 620 621 sprintf(str, "%d\n", line); 622 LispFputs(Stderr, str); 623 } 624 625 LispDestroy("READ: %s", string); 626} 627 628static void 629LispReadFixCircle(LispObj *object, read_info *info) 630{ 631 LispObj *cons; 632 633fix_again: 634 switch (OBJECT_TYPE(object)) { 635 case LispCons_t: 636 for (cons = object; 637 CONSP(object); 638 cons = object, object = CDR(object)) { 639 if (READLABELP(CAR(object))) 640 CAR(object) = LispReadLabelCircle(CAR(object), info); 641 else if (LispReadCheckCircle(object, info)) 642 return; 643 else 644 LispReadFixCircle(CAR(object), info); 645 } 646 if (READLABELP(object)) 647 CDR(cons) = LispReadLabelCircle(object, info); 648 else 649 goto fix_again; 650 break; 651 case LispArray_t: 652 if (READLABELP(object->data.array.list)) 653 object->data.array.list = 654 LispReadLabelCircle(object->data.array.list, info); 655 else if (!LispReadCheckCircle(object, info)) { 656 object = object->data.array.list; 657 goto fix_again; 658 } 659 break; 660 case LispStruct_t: 661 if (READLABELP(object->data.struc.fields)) 662 object->data.struc.fields = 663 LispReadLabelCircle(object->data.struc.fields, info); 664 else if (!LispReadCheckCircle(object, info)) { 665 object = object->data.struc.fields; 666 goto fix_again; 667 } 668 break; 669 case LispQuote_t: 670 case LispBackquote_t: 671 case LispFunctionQuote_t: 672 if (READLABELP(object->data.quote)) 673 object->data.quote = 674 LispReadLabelCircle(object->data.quote, info); 675 else { 676 object = object->data.quote; 677 goto fix_again; 678 } 679 break; 680 case LispComma_t: 681 if (READLABELP(object->data.comma.eval)) 682 object->data.comma.eval = 683 LispReadLabelCircle(object->data.comma.eval, info); 684 else { 685 object = object->data.comma.eval; 686 goto fix_again; 687 } 688 break; 689 case LispLambda_t: 690 if (READLABELP(object->data.lambda.code)) 691 object->data.lambda.code = 692 LispReadLabelCircle(object->data.lambda.code, info); 693 else if (!LispReadCheckCircle(object, info)) { 694 object = object->data.lambda.code; 695 goto fix_again; 696 } 697 break; 698 default: 699 break; 700 } 701} 702 703static LispObj * 704LispReadLabelCircle(LispObj *label, read_info *info) 705{ 706 long i, value = READLABEL_VALUE(label); 707 708 for (i = 0; i < info->num_objects; i++) 709 if (info->objects[i].label == value) 710 return (info->objects[i].object); 711 712 LispDestroy("READ: internal error"); 713 /*NOTREACHED*/ 714 return (label); 715} 716 717static int 718LispReadCheckCircle(LispObj *object, read_info *info) 719{ 720 long i; 721 722 for (i = 0; i < info->num_circles; i++) 723 if (info->circles[i] == object) 724 return (1); 725 726 if ((info->num_circles % 16) == 0) 727 info->circles = LispRealloc(info->circles, sizeof(LispObj*) * 728 (info->num_circles + 16)); 729 info->circles[info->num_circles++] = object; 730 731 return (0); 732} 733 734static LispObj * 735LispDoRead(read_info *info) 736{ 737 LispObj *object; 738 int ch = LispSkipWhiteSpace(); 739 740 switch (ch) { 741 case '(': 742 object = LispReadList(info); 743 break; 744 case ')': 745 for (ch = LispGet(); ch != EOF && ch != '\n'; ch = LispGet()) { 746 if (!isspace(ch)) { 747 LispUnget(ch); 748 break; 749 } 750 } 751 return (EOLIST); 752 case EOF: 753 return (NULL); 754 case '\'': 755 object = LispReadQuote(info); 756 break; 757 case '`': 758 object = LispReadBackquote(info); 759 break; 760 case ',': 761 object = LispReadCommaquote(info); 762 break; 763 case '#': 764 object = LispReadMacro(info); 765 break; 766 default: 767 LispUnget(ch); 768 object = LispReadObject(0, info); 769 break; 770 } 771 772 return (object); 773} 774 775static LispObj * 776LispReadMacro(read_info *info) 777{ 778 READ_ENTER(); 779 LispObj *result = NULL; 780 int ch = LispGet(); 781 782 switch (ch) { 783 case '(': 784 result = LispReadVector(info); 785 break; 786 case '\'': 787 result = LispReadFunction(info); 788 break; 789 case 'b': 790 case 'B': 791 result = LispReadRational(2, info); 792 break; 793 case 'o': 794 case 'O': 795 result = LispReadRational(8, info); 796 break; 797 case 'x': 798 case 'X': 799 result = LispReadRational(16, info); 800 break; 801 case '\\': 802 result = LispReadCharacter(info); 803 break; 804 case '|': 805 LispSkipComment(); 806 result = LispDoRead(info); 807 break; 808 case '.': /* eval when compiling */ 809 case ',': /* eval when loading */ 810 result = LispReadEval(info); 811 break; 812 case 'c': 813 case 'C': 814 result = LispReadComplex(info); 815 break; 816 case 'p': 817 case 'P': 818 result = LispReadPathname(info); 819 break; 820 case 's': 821 case 'S': 822 result = LispReadStruct(info); 823 break; 824 case '+': 825 result = LispReadFeature(1, info); 826 break; 827 case '-': 828 result = LispReadFeature(0, info); 829 break; 830 case ':': 831 /* Uninterned symbol */ 832 result = LispReadObject(1, info); 833 break; 834 default: 835 if (isdigit(ch)) { 836 LispUnget(ch); 837 result = LispReadMacroArg(info); 838 } 839 else if (!info->discard) 840 READ_ERROR1("undefined dispatch macro character #%c", ch); 841 break; 842 } 843 844 return (result); 845} 846 847static LispObj * 848LispReadMacroArg(read_info *info) 849{ 850 READ_ENTER(); 851 LispObj *result = NIL; 852 long i, integer; 853 int ch; 854 855 /* skip leading zeros */ 856 while (ch = LispGet(), ch != EOF && isdigit(ch) && ch == '0') 857 ; 858 859 if (ch == EOF) 860 READ_ERROR_EOF(); 861 862 /* if ch is not a number the argument was zero */ 863 if (isdigit(ch)) { 864 char stk[32], *str; 865 int len = 1; 866 867 stk[0] = ch; 868 for (;;) { 869 ch = LispGet(); 870 if (!isdigit(ch)) 871 break; 872 if (len + 1 >= sizeof(stk)) 873 READ_ERROR_FIXNUM(); 874 stk[len++] = ch; 875 } 876 stk[len] = '\0'; 877 errno = 0; 878 integer = strtol(stk, &str, 10); 879 /* number is positive because sign is not processed here */ 880 if (*str || errno == ERANGE || integer > MOST_POSITIVE_FIXNUM) 881 READ_ERROR_FIXNUM(); 882 } 883 else 884 integer = 0; 885 886 switch (ch) { 887 case 'a': 888 case 'A': 889 if (integer == 1) { 890 /* LispReadArray and LispReadList expect 891 * the '(' being already read */ 892 if ((ch = LispSkipWhiteSpace()) != '(') { 893 if (info->discard) 894 return (ch == EOF ? NULL : NIL); 895 READ_ERROR0("bad array specification"); 896 } 897 result = LispReadVector(info); 898 } 899 else 900 result = LispReadArray(integer, info); 901 break; 902 case 'r': 903 case 'R': 904 result = LispReadRational(integer, info); 905 break; 906 case '=': 907 if (integer > MAX_LABEL_VALUE) 908 READ_ERROR_FIXNUM(); 909 if (!info->discard) { 910 long num_objects = info->num_objects; 911 912 /* check for duplicated label */ 913 for (i = 0; i < info->num_objects; i++) { 914 if (info->objects[i].label == integer) 915 READ_ERROR1("label #%ld# defined more than once", 916 integer); 917 } 918 info->objects = LispRealloc(info->objects, 919 sizeof(object_info) * 920 (num_objects + 1)); 921 /* if this label is referenced it is a shared/circular object */ 922 info->objects[num_objects].label = integer; 923 info->objects[num_objects].object = NULL; 924 info->objects[num_objects].num_circles = 0; 925 ++info->num_objects; 926 result = LispDoRead(info); 927 if (READLABELP(result) && READLABEL_VALUE(result) == integer) 928 READ_ERROR2("incorrect syntax #%ld= #%ld#", 929 integer, integer); 930 /* any reference to it now is not shared/circular */ 931 info->objects[num_objects].object = result; 932 } 933 else 934 result = LispDoRead(info); 935 break; 936 case '#': 937 if (integer > MAX_LABEL_VALUE) 938 READ_ERROR_FIXNUM(); 939 if (!info->discard) { 940 /* search object */ 941 for (i = 0; i < info->num_objects; i++) { 942 if (info->objects[i].label == integer) { 943 result = info->objects[i].object; 944 if (result == NULL) { 945 ++info->objects[i].num_circles; 946 ++info->circle_count; 947 result = READLABEL(integer); 948 } 949 break; 950 } 951 } 952 if (i == info->num_objects) 953 READ_ERROR1("undefined label #%ld#", integer); 954 } 955 break; 956 default: 957 if (!info->discard) 958 READ_ERROR1("undefined dispatch macro character #%c", ch); 959 break; 960 } 961 962 return (result); 963} 964 965static int 966LispSkipWhiteSpace(void) 967{ 968 int ch; 969 970 for (;;) { 971 while (ch = LispGet(), isspace(ch) && ch != EOF) 972 ; 973 if (ch == ';') { 974 while (ch = LispGet(), ch != '\n' && ch != EOF) 975 ; 976 if (ch == EOF) 977 return (EOF); 978 } 979 else 980 break; 981 } 982 983 return (ch); 984} 985 986/* any data in the format '(' FORM ')' is read here */ 987static LispObj * 988LispReadList(read_info *info) 989{ 990 READ_ENTER(); 991 GC_ENTER(); 992 LispObj *result, *cons, *object; 993 int dot = 0; 994 995 ++info->level; 996 /* check for () */ 997 object = LispDoRead(info); 998 if (object == EOLIST) { 999 --info->level; 1000 1001 return (NIL); 1002 } 1003 1004 if (object == DOT) 1005 READ_ERROR0("illegal start of dotted list"); 1006 1007 result = cons = CONS(object, NIL); 1008 1009 /* make sure GC will not release data being read */ 1010 GC_PROTECT(result); 1011 1012 while ((object = LispDoRead(info)) != EOLIST) { 1013 if (object == NULL) 1014 READ_ERROR_EOF(); 1015 if (object == DOT) { 1016 if (info->nodot == info->level) 1017 READ_ERROR0("dotted list not allowed"); 1018 /* this is a dotted list */ 1019 if (dot) 1020 READ_ERROR0("more than one . in list"); 1021 dot = 1; 1022 } 1023 else { 1024 if (dot) { 1025 /* only one object after a dot */ 1026 if (++dot > 2) 1027 READ_ERROR0("more than one object after . in list"); 1028 RPLACD(cons, object); 1029 } 1030 else { 1031 RPLACD(cons, CONS(object, NIL)); 1032 cons = CDR(cons); 1033 } 1034 } 1035 } 1036 1037 /* this will happen if last list element was a dot */ 1038 if (dot == 1) 1039 READ_ERROR0("illegal end of dotted list"); 1040 1041 --info->level; 1042 GC_LEAVE(); 1043 1044 return (result); 1045} 1046 1047static LispObj * 1048LispReadQuote(read_info *info) 1049{ 1050 READ_ENTER(); 1051 LispObj *quote = LispDoRead(info), *result; 1052 1053 if (INVALIDP(quote)) 1054 READ_ERROR_INVARG(); 1055 1056 result = QUOTE(quote); 1057 1058 return (result); 1059} 1060 1061static LispObj * 1062LispReadBackquote(read_info *info) 1063{ 1064 READ_ENTER(); 1065 LispObj *backquote = LispDoRead(info), *result; 1066 1067 if (INVALIDP(backquote)) 1068 READ_ERROR_INVARG(); 1069 1070 result = BACKQUOTE(backquote); 1071 1072 return (result); 1073} 1074 1075static LispObj * 1076LispReadCommaquote(read_info *info) 1077{ 1078 READ_ENTER(); 1079 LispObj *comma, *result; 1080 int atlist = LispGet(); 1081 1082 if (atlist == EOF) 1083 READ_ERROR_EOF(); 1084 else if (atlist != '@' && atlist != '.') 1085 LispUnget(atlist); 1086 1087 comma = LispDoRead(info); 1088 if (comma == DOT) { 1089 atlist = '@'; 1090 comma = LispDoRead(info); 1091 } 1092 if (INVALIDP(comma)) 1093 READ_ERROR_INVARG(); 1094 1095 result = COMMA(comma, atlist == '@' || atlist == '.'); 1096 1097 return (result); 1098} 1099 1100/* 1101 * Read anything that is not readily identifiable by it's first character 1102 * and also put the code for reading atoms, numbers and strings together. 1103 */ 1104static LispObj * 1105LispReadObject(int unintern, read_info *info) 1106{ 1107 READ_ENTER(); 1108 LispObj *object; 1109 char stk[128], *string, *package, *symbol; 1110 int ch, length, backslash, size, quote, unreadable, collon; 1111 1112 package = symbol = string = stk; 1113 size = sizeof(stk); 1114 backslash = quote = unreadable = collon = 0; 1115 length = 0; 1116 1117 ch = LispGet(); 1118 if (unintern && (ch == ':' || ch == '"')) 1119 READ_ERROR0("syntax error after #:"); 1120 else if (ch == '"' || ch == '|') 1121 quote = ch; 1122 else if (ch == '\\') { 1123 unreadable = backslash = 1; 1124 string[length++] = ch; 1125 } 1126 else if (ch == ':') { 1127 collon = 1; 1128 string[length++] = ch; 1129 symbol = string + 1; 1130 ch = LispGet(); 1131 if (ch == '|') { 1132 quote = ch; 1133 unreadable = 1; 1134 } 1135 else if (ch != EOF) 1136 LispUnget(ch); 1137 } 1138 else if (ch) { 1139 if (islower(ch)) 1140 ch = toupper(ch); 1141 string[length++] = ch; 1142 } 1143 else 1144 unreadable = 1; 1145 1146 /* read remaining data */ 1147 for (; ch;) { 1148 ch = LispGet(); 1149 1150 if (ch == EOF) { 1151 if (quote) { 1152 /* if quote, file ended with an open quoted object */ 1153 if (string != stk) 1154 LispFree(string); 1155 return (NULL); 1156 } 1157 break; 1158 } 1159 else if (ch == '\0') 1160 break; 1161 1162 if (ch == '\\') { 1163 backslash = !backslash; 1164 if (quote == '"') { 1165 /* only remove backslashs from strings */ 1166 if (backslash) 1167 continue; 1168 } 1169 else 1170 unreadable = 1; 1171 } 1172 else if (backslash) 1173 backslash = 0; 1174 else if (ch == quote) 1175 break; 1176 else if (!quote && !backslash) { 1177 if (islower(ch)) 1178 ch = toupper(ch); 1179 else if (isspace(ch)) 1180 break; 1181 else if (AtomSeparator(ch, 0, 0)) { 1182 LispUnget(ch); 1183 break; 1184 } 1185 else if (ch == ':') { 1186 if (collon == 0 || 1187 (collon == (1 - unintern) && symbol == string + length)) { 1188 ++collon; 1189 symbol = string + length + 1; 1190 } 1191 else 1192 READ_ERROR0("too many collons"); 1193 } 1194 } 1195 1196 if (length + 2 >= size) { 1197 if (string == stk) { 1198 size = 1024; 1199 string = LispMalloc(size); 1200 strcpy(string, stk); 1201 } 1202 else { 1203 size += 1024; 1204 string = LispRealloc(string, size); 1205 } 1206 symbol = string + (symbol - package); 1207 package = string; 1208 } 1209 string[length++] = ch; 1210 } 1211 1212 if (info->discard) { 1213 if (string != stk) 1214 LispFree(string); 1215 1216 return (ch == EOF ? NULL : NIL); 1217 } 1218 1219 string[length] = '\0'; 1220 1221 if (unintern) { 1222 if (length == 0) 1223 READ_ERROR0("syntax error after #:"); 1224 object = UNINTERNED_ATOM(string); 1225 } 1226 1227 else if (quote == '"') 1228 object = LSTRING(string, length); 1229 1230 else if (collon) { 1231 /* Package specified in object name */ 1232 symbol[-1] = '\0'; 1233 if (collon > 1) 1234 symbol[-2] = '\0'; 1235 object = LispParseAtom(package, symbol, 1236 collon == 2, unreadable, 1237 read__stream, read__line); 1238 } 1239 1240 else if (quote == '|' || (unreadable && !collon)) { 1241 /* Set unreadable field, this atom needs quoting to be read back */ 1242 object = ATOM(string); 1243 object->data.atom->unreadable = 1; 1244 } 1245 1246 /* Check some common symbols */ 1247 else if (length == 1 && string[0] == 'T') 1248 /* The T */ 1249 object = T; 1250 1251 else if (length == 1 && string[0] == '.') 1252 /* The dot */ 1253 object = DOT; 1254 1255 else if (length == 3 && 1256 string[0] == 'N' && string[1] == 'I' && string[2] == 'L') 1257 /* The NIL */ 1258 object = NIL; 1259 1260 else if (isdigit(string[0]) || string[0] == '.' || 1261 ((string[0] == '-' || string[0] == '+') && string[1])) 1262 /* Looks like a number */ 1263 object = LispParseNumber(string, 10, read__stream, read__line); 1264 1265 else 1266 /* A normal atom */ 1267 object = ATOM(string); 1268 1269 if (string != stk) 1270 LispFree(string); 1271 1272 return (object); 1273} 1274 1275static LispObj * 1276LispParseAtom(char *package, char *symbol, int intern, int unreadable, 1277 LispObj *read__stream, int read__line) 1278{ 1279 LispObj *object = NULL, *thepackage = NULL; 1280 LispPackage *pack = NULL; 1281 1282 if (!unreadable) { 1283 /* Until NIL and T be treated as normal symbols */ 1284 if (symbol[0] == 'N' && symbol[1] == 'I' && 1285 symbol[2] == 'L' && symbol[3] == '\0') 1286 return (NIL); 1287 if (symbol[0] == 'T' && symbol[1] == '\0') 1288 return (T); 1289 unreadable = !LispCheckAtomString(symbol); 1290 } 1291 1292 /* If package is empty, it is a keyword */ 1293 if (package[0] == '\0') { 1294 thepackage = lisp__data.keyword; 1295 pack = lisp__data.key; 1296 } 1297 1298 else { 1299 /* Else, search it in the package list */ 1300 thepackage = LispFindPackageFromString(package); 1301 1302 if (thepackage == NIL) 1303 READ_ERROR1("the package %s is not available", package); 1304 1305 pack = thepackage->data.package.package; 1306 } 1307 1308 if (pack == lisp__data.pack && intern) { 1309 /* Redundant package specification, since requesting a 1310 * intern symbol, create it if does not exist */ 1311 1312 object = ATOM(symbol); 1313 if (unreadable) 1314 object->data.atom->unreadable = 1; 1315 } 1316 1317 else if (intern || pack == lisp__data.key) { 1318 /* Symbol is created, or just fetched from the specified package */ 1319 1320 LispPackage *savepack; 1321 LispObj *savepackage = PACKAGE; 1322 1323 /* Remember curent package */ 1324 savepack = lisp__data.pack; 1325 1326 /* Temporarily set another package */ 1327 lisp__data.pack = pack; 1328 PACKAGE = thepackage; 1329 1330 /* Get the object pointer */ 1331 if (pack == lisp__data.key) 1332 object = KEYWORD(LispDoGetAtom(symbol, 0)->key->value); 1333 else 1334 object = ATOM(symbol); 1335 if (unreadable) 1336 object->data.atom->unreadable = 1; 1337 1338 /* Restore current package */ 1339 lisp__data.pack = savepack; 1340 PACKAGE = savepackage; 1341 } 1342 1343 else { 1344 /* Symbol must exist (and be extern) in the specified package */ 1345 1346 LispAtom *atom; 1347 1348 atom = (LispAtom *)hash_check(pack->atoms, symbol, strlen(symbol)); 1349 if (atom) 1350 object = atom->object; 1351 1352 /* No object found */ 1353 if (object == NULL || object->data.atom->ext == 0) 1354 READ_ERROR2("no extern symbol %s in package %s", symbol, package); 1355 } 1356 1357 return (object); 1358} 1359 1360static LispObj * 1361LispParseNumber(char *str, int radix, LispObj *read__stream, int read__line) 1362{ 1363 int len; 1364 long integer; 1365 double dfloat; 1366 char *ratio, *ptr; 1367 LispObj *number; 1368 mpi *bignum; 1369 mpr *bigratio; 1370 1371 if (radix < 2 || radix > 36) 1372 READ_ERROR1("radix %d is not in the range 2 to 36", radix); 1373 1374 if (*str == '\0') 1375 return (NULL); 1376 1377 ratio = strchr(str, '/'); 1378 if (ratio) { 1379 /* check if looks like a correctly specified ratio */ 1380 if (ratio[1] == '\0' || strchr(ratio + 1, '/') != NULL) 1381 return (ATOM(str)); 1382 1383 /* ratio must point to an integer in radix base */ 1384 *ratio++ = '\0'; 1385 } 1386 else if (radix == 10) { 1387 int dot = 0; 1388 int type = 0; 1389 1390 /* check if it is a floating point number */ 1391 ptr = str; 1392 if (*ptr == '-' || *ptr == '+') 1393 ++ptr; 1394 else if (*ptr == '.') { 1395 dot = 1; 1396 ++ptr; 1397 } 1398 while (*ptr) { 1399 if (*ptr == '.') { 1400 if (dot) 1401 return (ATOM(str)); 1402 /* ignore it if last char is a dot */ 1403 if (ptr[1] == '\0') { 1404 *ptr = '\0'; 1405 break; 1406 } 1407 dot = 1; 1408 } 1409 else if (!isdigit(*ptr)) 1410 break; 1411 ++ptr; 1412 } 1413 1414 switch (*ptr) { 1415 case '\0': 1416 if (dot) /* if dot, it is default float */ 1417 type = 'E'; 1418 break; 1419 case 'E': case 'S': case 'F': case 'D': case 'L': 1420 type = *ptr; 1421 *ptr = 'E'; 1422 break; 1423 default: 1424 return (ATOM(str)); /* syntax error */ 1425 } 1426 1427 /* if type set, it is not an integer specification */ 1428 if (type) { 1429 if (*ptr) { 1430 int itype = *ptr; 1431 char *ptype = ptr; 1432 1433 ++ptr; 1434 if (*ptr == '+' || *ptr == '-') 1435 ++ptr; 1436 while (*ptr && isdigit(*ptr)) 1437 ++ptr; 1438 if (*ptr) { 1439 *ptype = itype; 1440 1441 return (ATOM(str)); 1442 } 1443 } 1444 1445 dfloat = strtod(str, NULL); 1446 if (!finite(dfloat)) 1447 READ_ERROR0("floating point overflow"); 1448 1449 return (DFLOAT(dfloat)); 1450 } 1451 } 1452 1453 /* check if correctly specified in the given radix */ 1454 len = strlen(str) - 1; 1455 if (!ratio && radix != 10 && str[len] == '.') 1456 str[len] = '\0'; 1457 1458 if (ratio || radix != 10) { 1459 if (!StringInRadix(str, radix, 1)) { 1460 if (ratio) 1461 ratio[-1] = '/'; 1462 return (ATOM(str)); 1463 } 1464 if (ratio && !StringInRadix(ratio, radix, 0)) { 1465 ratio[-1] = '/'; 1466 return (ATOM(str)); 1467 } 1468 } 1469 1470 bignum = NULL; 1471 bigratio = NULL; 1472 1473 errno = 0; 1474 integer = strtol(str, NULL, radix); 1475 1476 /* if does not fit in a long */ 1477 if (errno == ERANGE) { 1478 bignum = LispMalloc(sizeof(mpi)); 1479 mpi_init(bignum); 1480 mpi_setstr(bignum, str, radix); 1481 } 1482 1483 1484 if (ratio && integer != 0) { 1485 long denominator; 1486 1487 errno = 0; 1488 denominator = strtol(ratio, NULL, radix); 1489 if (denominator == 0) 1490 READ_ERROR0("divide by zero"); 1491 1492 if (bignum == NULL) { 1493 if (integer == MINSLONG || 1494 (denominator == LONG_MAX && errno == ERANGE)) { 1495 bigratio = LispMalloc(sizeof(mpr)); 1496 mpr_init(bigratio); 1497 mpi_seti(mpr_num(bigratio), integer); 1498 mpi_setstr(mpr_den(bigratio), ratio, radix); 1499 } 1500 } 1501 else { 1502 bigratio = LispMalloc(sizeof(mpr)); 1503 mpr_init(bigratio); 1504 mpi_set(mpr_num(bigratio), bignum); 1505 mpi_clear(bignum); 1506 LispFree(bignum); 1507 mpi_setstr(mpr_den(bigratio), ratio, radix); 1508 } 1509 1510 if (bigratio) { 1511 mpr_canonicalize(bigratio); 1512 if (mpi_fiti(mpr_num(bigratio)) && 1513 mpi_fiti(mpr_den(bigratio))) { 1514 integer = mpi_geti(mpr_num(bigratio)); 1515 denominator = mpi_geti(mpr_den(bigratio)); 1516 mpr_clear(bigratio); 1517 LispFree(bigratio); 1518 if (denominator == 1) 1519 number = INTEGER(integer); 1520 else 1521 number = RATIO(integer, denominator); 1522 } 1523 else 1524 number = BIGRATIO(bigratio); 1525 } 1526 else { 1527 long num = integer, den = denominator, rest; 1528 1529 if (num < 0) 1530 num = -num; 1531 for (;;) { 1532 if ((rest = den % num) == 0) 1533 break; 1534 den = num; 1535 num = rest; 1536 } 1537 if (den != 1) { 1538 denominator /= num; 1539 integer /= num; 1540 } 1541 if (denominator < 0) { 1542 integer = -integer; 1543 denominator = -denominator; 1544 } 1545 if (denominator == 1) 1546 number = INTEGER(integer); 1547 else 1548 number = RATIO(integer, denominator); 1549 } 1550 } 1551 else if (bignum) 1552 number = BIGNUM(bignum); 1553 else 1554 number = INTEGER(integer); 1555 1556 return (number); 1557} 1558 1559static int 1560StringInRadix(char *str, int radix, int skip_sign) 1561{ 1562 if (skip_sign && (*str == '-' || *str == '+')) 1563 ++str; 1564 while (*str) { 1565 if (*str >= '0' && *str <= '9') { 1566 if (*str - '0' >= radix) 1567 return (0); 1568 } 1569 else if (*str >= 'A' && *str <= 'Z') { 1570 if (radix <= 10 || *str - 'A' + 10 >= radix) 1571 return (0); 1572 } 1573 else 1574 return (0); 1575 str++; 1576 } 1577 1578 return (1); 1579} 1580 1581static int 1582AtomSeparator(int ch, int check_space, int check_backslash) 1583{ 1584 if (check_space && isspace(ch)) 1585 return (1); 1586 if (check_backslash && ch == '\\') 1587 return (1); 1588 return (strchr("(),\";'`#|,", ch) != NULL); 1589} 1590 1591static LispObj * 1592LispReadVector(read_info *info) 1593{ 1594 LispObj *objects; 1595 int nodot = info->nodot; 1596 1597 info->nodot = info->level + 1; 1598 objects = LispReadList(info); 1599 info->nodot = nodot; 1600 1601 if (info->discard) 1602 return (objects); 1603 1604 return (VECTOR(objects)); 1605} 1606 1607static LispObj * 1608LispReadFunction(read_info *info) 1609{ 1610 READ_ENTER(); 1611 int nodot = info->nodot; 1612 LispObj *function; 1613 1614 info->nodot = info->level + 1; 1615 function = LispDoRead(info); 1616 info->nodot = nodot; 1617 1618 if (info->discard) 1619 return (function); 1620 1621 if (INVALIDP(function)) 1622 READ_ERROR_INVARG(); 1623 else if (CONSP(function)) { 1624 if (CAR(function) != Olambda) 1625 READ_ERROR_INVARG(); 1626 1627 return (FUNCTION_QUOTE(function)); 1628 } 1629 else if (!SYMBOLP(function)) 1630 READ_ERROR_INVARG(); 1631 1632 return (FUNCTION_QUOTE(function)); 1633} 1634 1635static LispObj * 1636LispReadRational(int radix, read_info *info) 1637{ 1638 READ_ENTER(); 1639 LispObj *number; 1640 int ch, len, size; 1641 char stk[128], *str; 1642 1643 len = 0; 1644 str = stk; 1645 size = sizeof(stk); 1646 1647 for (;;) { 1648 ch = LispGet(); 1649 if (ch == EOF || isspace(ch)) 1650 break; 1651 else if (AtomSeparator(ch, 0, 1)) { 1652 LispUnget(ch); 1653 break; 1654 } 1655 else if (islower(ch)) 1656 ch = toupper(ch); 1657 if ((ch < '0' || ch > '9') && (ch < 'A' || ch > 'Z') && 1658 ch != '+' && ch != '-' && ch != '/') { 1659 if (str != stk) 1660 LispFree(str); 1661 if (!info->discard) 1662 READ_ERROR1("bad character %c for rational number", ch); 1663 } 1664 if (len + 1 >= size) { 1665 if (str == stk) { 1666 size = 512; 1667 str = LispMalloc(size); 1668 strcpy(str + 1, stk + 1); 1669 } 1670 else { 1671 size += 512; 1672 str = LispRealloc(str, size); 1673 } 1674 } 1675 str[len++] = ch; 1676 } 1677 1678 if (info->discard) { 1679 if (str != stk) 1680 LispFree(str); 1681 1682 return (ch == EOF ? NULL : NIL); 1683 } 1684 1685 str[len] = '\0'; 1686 1687 number = LispParseNumber(str, radix, read__stream, read__line); 1688 if (str != stk) 1689 LispFree(str); 1690 1691 if (!RATIONALP(number)) 1692 READ_ERROR0("bad rational number specification"); 1693 1694 return (number); 1695} 1696 1697static LispObj * 1698LispReadCharacter(read_info *info) 1699{ 1700 READ_ENTER(); 1701 long c; 1702 int ch, len; 1703 char stk[64]; 1704 1705 ch = LispGet(); 1706 if (ch == EOF) 1707 return (NULL); 1708 1709 stk[0] = ch; 1710 len = 1; 1711 1712 for (;;) { 1713 ch = LispGet(); 1714 if (ch == EOF) 1715 break; 1716 else if (ch != '-' && !isalnum(ch)) { 1717 LispUnget(ch); 1718 break; 1719 } 1720 if (len + 1 < sizeof(stk)) 1721 stk[len++] = ch; 1722 } 1723 if (len > 1) { 1724 char **names; 1725 int found = 0; 1726 stk[len] = '\0'; 1727 1728 for (c = ch = 0; ch <= ' ' && !found; ch++) { 1729 for (names = LispChars[ch].names; *names; names++) 1730 if (strcasecmp(*names, stk) == 0) { 1731 c = ch; 1732 found = 1; 1733 break; 1734 } 1735 } 1736 if (!found) { 1737 for (names = LispChars[0177].names; *names; names++) 1738 if (strcasecmp(*names, stk) == 0) { 1739 c = 0177; 1740 found = 1; 1741 break; 1742 } 1743 } 1744 1745 if (!found) { 1746 if (info->discard) 1747 return (NIL); 1748 READ_ERROR1("unkwnown character %s", stk); 1749 } 1750 } 1751 else 1752 c = stk[0]; 1753 1754 return (SCHAR(c)); 1755} 1756 1757static void 1758LispSkipComment(void) 1759{ 1760 READ_ENTER(); 1761 int ch, comm = 1; 1762 1763 for (;;) { 1764 ch = LispGet(); 1765 if (ch == '#') { 1766 ch = LispGet(); 1767 if (ch == '|') 1768 ++comm; 1769 continue; 1770 } 1771 while (ch == '|') { 1772 ch = LispGet(); 1773 if (ch == '#' && --comm == 0) 1774 return; 1775 } 1776 if (ch == EOF) 1777 READ_ERROR_EOF(); 1778 } 1779} 1780 1781static LispObj * 1782LispReadEval(read_info *info) 1783{ 1784 READ_ENTER(); 1785 int nodot = info->nodot; 1786 LispObj *code; 1787 1788 info->nodot = info->level + 1; 1789 code = LispDoRead(info); 1790 info->nodot = nodot; 1791 1792 if (info->discard) 1793 return (code); 1794 1795 if (INVALIDP(code)) 1796 READ_ERROR_INVARG(); 1797 1798 return (EVAL(code)); 1799} 1800 1801static LispObj * 1802LispReadComplex(read_info *info) 1803{ 1804 READ_ENTER(); 1805 GC_ENTER(); 1806 int nodot = info->nodot; 1807 LispObj *number, *arguments; 1808 1809 info->nodot = info->level + 1; 1810 arguments = LispDoRead(info); 1811 info->nodot = nodot; 1812 1813 /* form read */ 1814 if (info->discard) 1815 return (arguments); 1816 1817 if (INVALIDP(arguments) || !CONSP(arguments)) 1818 READ_ERROR_INVARG(); 1819 1820 GC_PROTECT(arguments); 1821 number = APPLY(Ocomplex, arguments); 1822 GC_LEAVE(); 1823 1824 return (number); 1825} 1826 1827static LispObj * 1828LispReadPathname(read_info *info) 1829{ 1830 READ_ENTER(); 1831 GC_ENTER(); 1832 int nodot = info->nodot; 1833 LispObj *path, *arguments; 1834 1835 info->nodot = info->level + 1; 1836 arguments = LispDoRead(info); 1837 info->nodot = nodot; 1838 1839 /* form read */ 1840 if (info->discard) 1841 return (arguments); 1842 1843 if (INVALIDP(arguments)) 1844 READ_ERROR_INVARG(); 1845 1846 GC_PROTECT(arguments); 1847 path = APPLY1(Oparse_namestring, arguments); 1848 GC_LEAVE(); 1849 1850 return (path); 1851} 1852 1853static LispObj * 1854LispReadStruct(read_info *info) 1855{ 1856 READ_ENTER(); 1857 GC_ENTER(); 1858 int len, nodot = info->nodot; 1859 char stk[128], *str; 1860 LispObj *struc, *fields; 1861 1862 info->nodot = info->level + 1; 1863 fields = LispDoRead(info); 1864 info->nodot = nodot; 1865 1866 /* form read */ 1867 if (info->discard) 1868 return (fields); 1869 1870 if (INVALIDP(fields) || !CONSP(fields) || !SYMBOLP(CAR(fields))) 1871 READ_ERROR_INVARG(); 1872 1873 GC_PROTECT(fields); 1874 1875 len = ATOMID(CAR(fields))->length; 1876 /* MAKE- */ 1877 if (len + 6 > sizeof(stk)) 1878 str = LispMalloc(len + 6); 1879 else 1880 str = stk; 1881 sprintf(str, "MAKE-%s", ATOMID(CAR(fields))->value); 1882 RPLACA(fields, ATOM(str)); 1883 if (str != stk) 1884 LispFree(str); 1885 struc = APPLY(Omake_struct, fields); 1886 GC_LEAVE(); 1887 1888 return (struc); 1889} 1890 1891/* XXX This is broken, needs a rewritten as soon as true vector/arrays be 1892 * implemented. */ 1893static LispObj * 1894LispReadArray(long dimensions, read_info *info) 1895{ 1896 READ_ENTER(); 1897 GC_ENTER(); 1898 long count; 1899 int nodot = info->nodot; 1900 LispObj *arguments, *initial, *dim, *cons, *array, *data; 1901 1902 info->nodot = info->level + 1; 1903 data = LispDoRead(info); 1904 info->nodot = nodot; 1905 1906 /* form read */ 1907 if (info->discard) 1908 return (data); 1909 1910 if (INVALIDP(data)) 1911 READ_ERROR_INVARG(); 1912 1913 initial = Kinitial_contents; 1914 1915 dim = cons = NIL; 1916 if (dimensions) { 1917 LispObj *array; 1918 1919 for (count = 0, array = data; count < dimensions; count++) { 1920 long length; 1921 LispObj *item; 1922 1923 if (!CONSP(array)) 1924 READ_ERROR0("bad array for given dimension"); 1925 item = array; 1926 array = CAR(array); 1927 1928 for (length = 0; CONSP(item); item = CDR(item), length++) 1929 ; 1930 1931 if (dim == NIL) { 1932 dim = cons = CONS(FIXNUM(length), NIL); 1933 GC_PROTECT(dim); 1934 } 1935 else { 1936 RPLACD(cons, CONS(FIXNUM(length), NIL)); 1937 cons = CDR(cons); 1938 } 1939 } 1940 } 1941 1942 arguments = CONS(dim, CONS(initial, CONS(data, NIL))); 1943 GC_PROTECT(arguments); 1944 array = APPLY(Omake_array, arguments); 1945 GC_LEAVE(); 1946 1947 return (array); 1948} 1949 1950static LispObj * 1951LispReadFeature(int with, read_info *info) 1952{ 1953 READ_ENTER(); 1954 LispObj *status; 1955 LispObj *feature = LispDoRead(info); 1956 1957 /* form read */ 1958 if (info->discard) 1959 return (feature); 1960 1961 if (INVALIDP(feature)) 1962 READ_ERROR_INVARG(); 1963 1964 /* paranoia check, features must be a list, possibly empty */ 1965 if (!CONSP(FEATURES) && FEATURES != NIL) 1966 READ_ERROR1("%s is not a list", STROBJ(FEATURES)); 1967 1968 status = LispEvalFeature(feature); 1969 1970 if (with) { 1971 if (status == T) 1972 return (LispDoRead(info)); 1973 1974 /* need to use the field discard because the following expression 1975 * may be #.FORM or #,FORM or any other form that may generate 1976 * side effects */ 1977 info->discard = 1; 1978 LispDoRead(info); 1979 info->discard = 0; 1980 1981 return (LispDoRead(info)); 1982 } 1983 1984 if (status == NIL) 1985 return (LispDoRead(info)); 1986 1987 info->discard = 1; 1988 LispDoRead(info); 1989 info->discard = 0; 1990 1991 return (LispDoRead(info)); 1992} 1993 1994/* 1995 * A very simple eval loop with AND, NOT, and OR functions for testing 1996 * the available features. 1997 */ 1998static LispObj * 1999LispEvalFeature(LispObj *feature) 2000{ 2001 READ_ENTER(); 2002 Atom_id test; 2003 LispObj *object; 2004 2005 if (CONSP(feature)) { 2006 LispObj *function = CAR(feature), *arguments = CDR(feature); 2007 2008 if (!SYMBOLP(function)) 2009 READ_ERROR1("bad feature test function %s", STROBJ(function)); 2010 if (!CONSP(arguments)) 2011 READ_ERROR1("bad feature test arguments %s", STROBJ(arguments)); 2012 test = ATOMID(function); 2013 if (test == Sand) { 2014 for (; CONSP(arguments); arguments = CDR(arguments)) { 2015 if (LispEvalFeature(CAR(arguments)) == NIL) 2016 return (NIL); 2017 } 2018 return (T); 2019 } 2020 else if (test == Sor) { 2021 for (; CONSP(arguments); arguments = CDR(arguments)) { 2022 if (LispEvalFeature(CAR(arguments)) == T) 2023 return (T); 2024 } 2025 return (NIL); 2026 } 2027 else if (test == Snot) { 2028 if (CONSP(CDR(arguments))) 2029 READ_ERROR0("too many arguments to NOT"); 2030 2031 return (LispEvalFeature(CAR(arguments)) == NIL ? T : NIL); 2032 } 2033 else 2034 READ_ERROR1("unimplemented feature test function %s", test); 2035 } 2036 2037 if (KEYWORDP(feature)) 2038 feature = feature->data.quote; 2039 else if (!SYMBOLP(feature)) 2040 READ_ERROR1("bad feature specification %s", STROBJ(feature)); 2041 2042 test = ATOMID(feature); 2043 2044 for (object = FEATURES; CONSP(object); object = CDR(object)) { 2045 /* paranoia check, elements in the feature list must ge keywords */ 2046 if (!KEYWORDP(CAR(object))) 2047 READ_ERROR1("%s is not a keyword", STROBJ(CAR(object))); 2048 if (ATOMID(CAR(object)) == test) 2049 return (T); 2050 } 2051 2052 /* unknown feature */ 2053 return (NIL); 2054} 2055