read.c revision 5dfecf96
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 } 1131 else if (ch) { 1132 if (islower(ch)) 1133 ch = toupper(ch); 1134 string[length++] = ch; 1135 } 1136 else 1137 unreadable = 1; 1138 1139 /* read remaining data */ 1140 for (; ch;) { 1141 ch = LispGet(); 1142 1143 if (ch == EOF) { 1144 if (quote) { 1145 /* if quote, file ended with an open quoted object */ 1146 if (string != stk) 1147 LispFree(string); 1148 return (NULL); 1149 } 1150 break; 1151 } 1152 else if (ch == '\0') 1153 break; 1154 1155 if (ch == '\\') { 1156 backslash = !backslash; 1157 if (quote == '"') { 1158 /* only remove backslashs from strings */ 1159 if (backslash) 1160 continue; 1161 } 1162 else 1163 unreadable = 1; 1164 } 1165 else if (backslash) 1166 backslash = 0; 1167 else if (ch == quote) 1168 break; 1169 else if (!quote && !backslash) { 1170 if (islower(ch)) 1171 ch = toupper(ch); 1172 else if (isspace(ch)) 1173 break; 1174 else if (AtomSeparator(ch, 0, 0)) { 1175 LispUnget(ch); 1176 break; 1177 } 1178 else if (ch == ':') { 1179 if (collon == 0 || 1180 (collon == (1 - unintern) && symbol == string + length)) { 1181 ++collon; 1182 symbol = string + length + 1; 1183 } 1184 else 1185 READ_ERROR0("too many collons"); 1186 } 1187 } 1188 1189 if (length + 2 >= size) { 1190 if (string == stk) { 1191 size = 1024; 1192 string = LispMalloc(size); 1193 strcpy(string, stk); 1194 } 1195 else { 1196 size += 1024; 1197 string = LispRealloc(string, size); 1198 } 1199 symbol = string + (symbol - package); 1200 package = string; 1201 } 1202 string[length++] = ch; 1203 } 1204 1205 if (info->discard) { 1206 if (string != stk) 1207 LispFree(string); 1208 1209 return (ch == EOF ? NULL : NIL); 1210 } 1211 1212 string[length] = '\0'; 1213 1214 if (unintern) { 1215 if (length == 0) 1216 READ_ERROR0("syntax error after #:"); 1217 object = UNINTERNED_ATOM(string); 1218 } 1219 1220 else if (quote == '"') 1221 object = LSTRING(string, length); 1222 1223 else if (quote == '|' || (unreadable && !collon)) { 1224 /* Set unreadable field, this atom needs quoting to be read back */ 1225 object = ATOM(string); 1226 object->data.atom->unreadable = 1; 1227 } 1228 1229 else if (collon) { 1230 /* Package specified in object name */ 1231 symbol[-1] = '\0'; 1232 if (collon > 1) 1233 symbol[-2] = '\0'; 1234 object = LispParseAtom(package, symbol, 1235 collon == 2, unreadable, 1236 read__stream, read__line); 1237 } 1238 1239 /* Check some common symbols */ 1240 else if (length == 1 && string[0] == 'T') 1241 /* The T */ 1242 object = T; 1243 1244 else if (length == 1 && string[0] == '.') 1245 /* The dot */ 1246 object = DOT; 1247 1248 else if (length == 3 && 1249 string[0] == 'N' && string[1] == 'I' && string[2] == 'L') 1250 /* The NIL */ 1251 object = NIL; 1252 1253 else if (isdigit(string[0]) || string[0] == '.' || 1254 ((string[0] == '-' || string[0] == '+') && string[1])) 1255 /* Looks like a number */ 1256 object = LispParseNumber(string, 10, read__stream, read__line); 1257 1258 else 1259 /* A normal atom */ 1260 object = ATOM(string); 1261 1262 if (string != stk) 1263 LispFree(string); 1264 1265 return (object); 1266} 1267 1268static LispObj * 1269LispParseAtom(char *package, char *symbol, int intern, int unreadable, 1270 LispObj *read__stream, int read__line) 1271{ 1272 LispObj *object = NULL, *thepackage = NULL; 1273 LispPackage *pack = NULL; 1274 1275 if (!unreadable) { 1276 /* Until NIL and T be treated as normal symbols */ 1277 if (symbol[0] == 'N' && symbol[1] == 'I' && 1278 symbol[2] == 'L' && symbol[3] == '\0') 1279 return (NIL); 1280 if (symbol[0] == 'T' && symbol[1] == '\0') 1281 return (T); 1282 unreadable = !LispCheckAtomString(symbol); 1283 } 1284 1285 /* If package is empty, it is a keyword */ 1286 if (package[0] == '\0') { 1287 thepackage = lisp__data.keyword; 1288 pack = lisp__data.key; 1289 } 1290 1291 else { 1292 /* Else, search it in the package list */ 1293 thepackage = LispFindPackageFromString(package); 1294 1295 if (thepackage == NIL) 1296 READ_ERROR1("the package %s is not available", package); 1297 1298 pack = thepackage->data.package.package; 1299 } 1300 1301 if (pack == lisp__data.pack && intern) { 1302 /* Redundant package specification, since requesting a 1303 * intern symbol, create it if does not exist */ 1304 1305 object = ATOM(symbol); 1306 if (unreadable) 1307 object->data.atom->unreadable = 1; 1308 } 1309 1310 else if (intern || pack == lisp__data.key) { 1311 /* Symbol is created, or just fetched from the specified package */ 1312 1313 LispPackage *savepack; 1314 LispObj *savepackage = PACKAGE; 1315 1316 /* Remember curent package */ 1317 savepack = lisp__data.pack; 1318 1319 /* Temporarily set another package */ 1320 lisp__data.pack = pack; 1321 PACKAGE = thepackage; 1322 1323 /* Get the object pointer */ 1324 if (pack == lisp__data.key) 1325 object = KEYWORD(LispDoGetAtom(symbol, 0)->string); 1326 else 1327 object = ATOM(symbol); 1328 if (unreadable) 1329 object->data.atom->unreadable = 1; 1330 1331 /* Restore current package */ 1332 lisp__data.pack = savepack; 1333 PACKAGE = savepackage; 1334 } 1335 1336 else { 1337 /* Symbol must exist (and be extern) in the specified package */ 1338 1339 int i; 1340 LispAtom *atom; 1341 1342 i = STRHASH(symbol); 1343 atom = pack->atoms[i]; 1344 while (atom) { 1345 if (strcmp(atom->string, symbol) == 0) { 1346 object = atom->object; 1347 break; 1348 } 1349 1350 atom = atom->next; 1351 } 1352 1353 /* No object found */ 1354 if (object == NULL || object->data.atom->ext == 0) 1355 READ_ERROR2("no extern symbol %s in package %s", symbol, package); 1356 } 1357 1358 return (object); 1359} 1360 1361static LispObj * 1362LispParseNumber(char *str, int radix, LispObj *read__stream, int read__line) 1363{ 1364 int len; 1365 long integer; 1366 double dfloat; 1367 char *ratio, *ptr; 1368 LispObj *number; 1369 mpi *bignum; 1370 mpr *bigratio; 1371 1372 if (radix < 2 || radix > 36) 1373 READ_ERROR1("radix %d is not in the range 2 to 36", radix); 1374 1375 if (*str == '\0') 1376 return (NULL); 1377 1378 ratio = strchr(str, '/'); 1379 if (ratio) { 1380 /* check if looks like a correctly specified ratio */ 1381 if (ratio[1] == '\0' || strchr(ratio + 1, '/') != NULL) 1382 return (ATOM(str)); 1383 1384 /* ratio must point to an integer in radix base */ 1385 *ratio++ = '\0'; 1386 } 1387 else if (radix == 10) { 1388 int dot = 0; 1389 int type = 0; 1390 1391 /* check if it is a floating point number */ 1392 ptr = str; 1393 if (*ptr == '-' || *ptr == '+') 1394 ++ptr; 1395 else if (*ptr == '.') { 1396 dot = 1; 1397 ++ptr; 1398 } 1399 while (*ptr) { 1400 if (*ptr == '.') { 1401 if (dot) 1402 return (ATOM(str)); 1403 /* ignore it if last char is a dot */ 1404 if (ptr[1] == '\0') { 1405 *ptr = '\0'; 1406 break; 1407 } 1408 dot = 1; 1409 } 1410 else if (!isdigit(*ptr)) 1411 break; 1412 ++ptr; 1413 } 1414 1415 switch (*ptr) { 1416 case '\0': 1417 if (dot) /* if dot, it is default float */ 1418 type = 'E'; 1419 break; 1420 case 'E': case 'S': case 'F': case 'D': case 'L': 1421 type = *ptr; 1422 *ptr = 'E'; 1423 break; 1424 default: 1425 return (ATOM(str)); /* syntax error */ 1426 } 1427 1428 /* if type set, it is not an integer specification */ 1429 if (type) { 1430 if (*ptr) { 1431 int itype = *ptr; 1432 char *ptype = ptr; 1433 1434 ++ptr; 1435 if (*ptr == '+' || *ptr == '-') 1436 ++ptr; 1437 while (*ptr && isdigit(*ptr)) 1438 ++ptr; 1439 if (*ptr) { 1440 *ptype = itype; 1441 1442 return (ATOM(str)); 1443 } 1444 } 1445 1446 dfloat = strtod(str, NULL); 1447 if (!finite(dfloat)) 1448 READ_ERROR0("floating point overflow"); 1449 1450 return (DFLOAT(dfloat)); 1451 } 1452 } 1453 1454 /* check if correctly specified in the given radix */ 1455 len = strlen(str) - 1; 1456 if (!ratio && radix != 10 && str[len] == '.') 1457 str[len] = '\0'; 1458 1459 if (ratio || radix != 10) { 1460 if (!StringInRadix(str, radix, 1)) { 1461 if (ratio) 1462 ratio[-1] = '/'; 1463 return (ATOM(str)); 1464 } 1465 if (ratio && !StringInRadix(ratio, radix, 0)) { 1466 ratio[-1] = '/'; 1467 return (ATOM(str)); 1468 } 1469 } 1470 1471 bignum = NULL; 1472 bigratio = NULL; 1473 1474 errno = 0; 1475 integer = strtol(str, NULL, radix); 1476 1477 /* if does not fit in a long */ 1478 if (errno == ERANGE && 1479 ((*str == '-' && integer == LONG_MIN) || 1480 (*str != '-' && integer == LONG_MAX))) { 1481 bignum = LispMalloc(sizeof(mpi)); 1482 mpi_init(bignum); 1483 mpi_setstr(bignum, str, radix); 1484 } 1485 1486 1487 if (ratio && integer != 0) { 1488 long denominator; 1489 1490 errno = 0; 1491 denominator = strtol(ratio, NULL, radix); 1492 if (denominator == 0) 1493 READ_ERROR0("divide by zero"); 1494 1495 if (bignum == NULL) { 1496 if (integer == MINSLONG || 1497 (denominator == LONG_MAX && errno == ERANGE)) { 1498 bigratio = LispMalloc(sizeof(mpr)); 1499 mpr_init(bigratio); 1500 mpi_seti(mpr_num(bigratio), integer); 1501 mpi_setstr(mpr_den(bigratio), ratio, radix); 1502 } 1503 } 1504 else { 1505 bigratio = LispMalloc(sizeof(mpr)); 1506 mpr_init(bigratio); 1507 mpi_set(mpr_num(bigratio), bignum); 1508 mpi_clear(bignum); 1509 LispFree(bignum); 1510 mpi_setstr(mpr_den(bigratio), ratio, radix); 1511 } 1512 1513 if (bigratio) { 1514 mpr_canonicalize(bigratio); 1515 if (mpi_fiti(mpr_num(bigratio)) && 1516 mpi_fiti(mpr_den(bigratio))) { 1517 integer = mpi_geti(mpr_num(bigratio)); 1518 denominator = mpi_geti(mpr_den(bigratio)); 1519 mpr_clear(bigratio); 1520 LispFree(bigratio); 1521 if (denominator == 1) 1522 number = INTEGER(integer); 1523 else 1524 number = RATIO(integer, denominator); 1525 } 1526 else 1527 number = BIGRATIO(bigratio); 1528 } 1529 else { 1530 long num = integer, den = denominator, rest; 1531 1532 if (num < 0) 1533 num = -num; 1534 for (;;) { 1535 if ((rest = den % num) == 0) 1536 break; 1537 den = num; 1538 num = rest; 1539 } 1540 if (den != 1) { 1541 denominator /= num; 1542 integer /= num; 1543 } 1544 if (denominator < 0) { 1545 integer = -integer; 1546 denominator = -denominator; 1547 } 1548 if (denominator == 1) 1549 number = INTEGER(integer); 1550 else 1551 number = RATIO(integer, denominator); 1552 } 1553 } 1554 else if (bignum) 1555 number = BIGNUM(bignum); 1556 else 1557 number = INTEGER(integer); 1558 1559 return (number); 1560} 1561 1562static int 1563StringInRadix(char *str, int radix, int skip_sign) 1564{ 1565 if (skip_sign && (*str == '-' || *str == '+')) 1566 ++str; 1567 while (*str) { 1568 if (*str >= '0' && *str <= '9') { 1569 if (*str - '0' >= radix) 1570 return (0); 1571 } 1572 else if (*str >= 'A' && *str <= 'Z') { 1573 if (radix <= 10 || *str - 'A' + 10 >= radix) 1574 return (0); 1575 } 1576 else 1577 return (0); 1578 str++; 1579 } 1580 1581 return (1); 1582} 1583 1584static int 1585AtomSeparator(int ch, int check_space, int check_backslash) 1586{ 1587 if (check_space && isspace(ch)) 1588 return (1); 1589 if (check_backslash && ch == '\\') 1590 return (1); 1591 return (strchr("(),\";'`#|,", ch) != NULL); 1592} 1593 1594static LispObj * 1595LispReadVector(read_info *info) 1596{ 1597 LispObj *objects; 1598 int nodot = info->nodot; 1599 1600 info->nodot = info->level + 1; 1601 objects = LispReadList(info); 1602 info->nodot = nodot; 1603 1604 if (info->discard) 1605 return (objects); 1606 1607 return (VECTOR(objects)); 1608} 1609 1610static LispObj * 1611LispReadFunction(read_info *info) 1612{ 1613 READ_ENTER(); 1614 int nodot = info->nodot; 1615 LispObj *function; 1616 1617 info->nodot = info->level + 1; 1618 function = LispDoRead(info); 1619 info->nodot = nodot; 1620 1621 if (info->discard) 1622 return (function); 1623 1624 if (INVALIDP(function)) 1625 READ_ERROR_INVARG(); 1626 else if (CONSP(function)) { 1627 if (CAR(function) != Olambda) 1628 READ_ERROR_INVARG(); 1629 1630 return (FUNCTION_QUOTE(function)); 1631 } 1632 else if (!SYMBOLP(function)) 1633 READ_ERROR_INVARG(); 1634 1635 return (FUNCTION_QUOTE(function)); 1636} 1637 1638static LispObj * 1639LispReadRational(int radix, read_info *info) 1640{ 1641 READ_ENTER(); 1642 LispObj *number; 1643 int ch, len, size; 1644 char stk[128], *str; 1645 1646 len = 0; 1647 str = stk; 1648 size = sizeof(stk); 1649 1650 for (;;) { 1651 ch = LispGet(); 1652 if (ch == EOF || isspace(ch)) 1653 break; 1654 else if (AtomSeparator(ch, 0, 1)) { 1655 LispUnget(ch); 1656 break; 1657 } 1658 else if (islower(ch)) 1659 ch = toupper(ch); 1660 if ((ch < '0' || ch > '9') && (ch < 'A' || ch > 'Z') && 1661 ch != '+' && ch != '-' && ch != '/') { 1662 if (str != stk) 1663 LispFree(str); 1664 if (!info->discard) 1665 READ_ERROR1("bad character %c for rational number", ch); 1666 } 1667 if (len + 1 >= size) { 1668 if (str == stk) { 1669 size = 512; 1670 str = LispMalloc(size); 1671 strcpy(str + 1, stk + 1); 1672 } 1673 else { 1674 size += 512; 1675 str = LispRealloc(str, size); 1676 } 1677 } 1678 str[len++] = ch; 1679 } 1680 1681 if (info->discard) { 1682 if (str != stk) 1683 LispFree(str); 1684 1685 return (ch == EOF ? NULL : NIL); 1686 } 1687 1688 str[len] = '\0'; 1689 1690 number = LispParseNumber(str, radix, read__stream, read__line); 1691 if (str != stk) 1692 LispFree(str); 1693 1694 if (!RATIONALP(number)) 1695 READ_ERROR0("bad rational number specification"); 1696 1697 return (number); 1698} 1699 1700static LispObj * 1701LispReadCharacter(read_info *info) 1702{ 1703 READ_ENTER(); 1704 long c; 1705 int ch, len; 1706 char stk[64]; 1707 1708 ch = LispGet(); 1709 if (ch == EOF) 1710 return (NULL); 1711 1712 stk[0] = ch; 1713 len = 1; 1714 1715 for (;;) { 1716 ch = LispGet(); 1717 if (ch == EOF) 1718 break; 1719 else if (ch != '-' && !isalnum(ch)) { 1720 LispUnget(ch); 1721 break; 1722 } 1723 if (len + 1 < sizeof(stk)) 1724 stk[len++] = ch; 1725 } 1726 if (len > 1) { 1727 char **names; 1728 int found = 0; 1729 stk[len] = '\0'; 1730 1731 for (c = ch = 0; ch <= ' ' && !found; ch++) { 1732 for (names = LispChars[ch].names; *names; names++) 1733 if (strcasecmp(*names, stk) == 0) { 1734 c = ch; 1735 found = 1; 1736 break; 1737 } 1738 } 1739 if (!found) { 1740 for (names = LispChars[0177].names; *names; names++) 1741 if (strcasecmp(*names, stk) == 0) { 1742 c = 0177; 1743 found = 1; 1744 break; 1745 } 1746 } 1747 1748 if (!found) { 1749 if (info->discard) 1750 return (NIL); 1751 READ_ERROR1("unkwnown character %s", stk); 1752 } 1753 } 1754 else 1755 c = stk[0]; 1756 1757 return (SCHAR(c)); 1758} 1759 1760static void 1761LispSkipComment(void) 1762{ 1763 READ_ENTER(); 1764 int ch, comm = 1; 1765 1766 for (;;) { 1767 ch = LispGet(); 1768 if (ch == '#') { 1769 ch = LispGet(); 1770 if (ch == '|') 1771 ++comm; 1772 continue; 1773 } 1774 while (ch == '|') { 1775 ch = LispGet(); 1776 if (ch == '#' && --comm == 0) 1777 return; 1778 } 1779 if (ch == EOF) 1780 READ_ERROR_EOF(); 1781 } 1782} 1783 1784static LispObj * 1785LispReadEval(read_info *info) 1786{ 1787 READ_ENTER(); 1788 int nodot = info->nodot; 1789 LispObj *code; 1790 1791 info->nodot = info->level + 1; 1792 code = LispDoRead(info); 1793 info->nodot = nodot; 1794 1795 if (info->discard) 1796 return (code); 1797 1798 if (INVALIDP(code)) 1799 READ_ERROR_INVARG(); 1800 1801 return (EVAL(code)); 1802} 1803 1804static LispObj * 1805LispReadComplex(read_info *info) 1806{ 1807 READ_ENTER(); 1808 GC_ENTER(); 1809 int nodot = info->nodot; 1810 LispObj *number, *arguments; 1811 1812 info->nodot = info->level + 1; 1813 arguments = LispDoRead(info); 1814 info->nodot = nodot; 1815 1816 /* form read */ 1817 if (info->discard) 1818 return (arguments); 1819 1820 if (INVALIDP(arguments) || !CONSP(arguments)) 1821 READ_ERROR_INVARG(); 1822 1823 GC_PROTECT(arguments); 1824 number = APPLY(Ocomplex, arguments); 1825 GC_LEAVE(); 1826 1827 return (number); 1828} 1829 1830static LispObj * 1831LispReadPathname(read_info *info) 1832{ 1833 READ_ENTER(); 1834 GC_ENTER(); 1835 int nodot = info->nodot; 1836 LispObj *path, *arguments; 1837 1838 info->nodot = info->level + 1; 1839 arguments = LispDoRead(info); 1840 info->nodot = nodot; 1841 1842 /* form read */ 1843 if (info->discard) 1844 return (arguments); 1845 1846 if (INVALIDP(arguments)) 1847 READ_ERROR_INVARG(); 1848 1849 GC_PROTECT(arguments); 1850 path = APPLY1(Oparse_namestring, arguments); 1851 GC_LEAVE(); 1852 1853 return (path); 1854} 1855 1856static LispObj * 1857LispReadStruct(read_info *info) 1858{ 1859 READ_ENTER(); 1860 GC_ENTER(); 1861 int len, nodot = info->nodot; 1862 char stk[128], *str; 1863 LispObj *struc, *fields; 1864 1865 info->nodot = info->level + 1; 1866 fields = LispDoRead(info); 1867 info->nodot = nodot; 1868 1869 /* form read */ 1870 if (info->discard) 1871 return (fields); 1872 1873 if (INVALIDP(fields) || !CONSP(fields) || !SYMBOLP(CAR(fields))) 1874 READ_ERROR_INVARG(); 1875 1876 GC_PROTECT(fields); 1877 1878 len = strlen(ATOMID(CAR(fields))); 1879 /* MAKE- */ 1880 if (len + 6 > sizeof(stk)) 1881 str = LispMalloc(len + 6); 1882 else 1883 str = stk; 1884 sprintf(str, "MAKE-%s", ATOMID(CAR(fields))); 1885 RPLACA(fields, ATOM(str)); 1886 if (str != stk) 1887 LispFree(str); 1888 struc = APPLY(Omake_struct, fields); 1889 GC_LEAVE(); 1890 1891 return (struc); 1892} 1893 1894/* XXX This is broken, needs a rewritten as soon as true vector/arrays be 1895 * implemented. */ 1896static LispObj * 1897LispReadArray(long dimensions, read_info *info) 1898{ 1899 READ_ENTER(); 1900 GC_ENTER(); 1901 long count; 1902 int nodot = info->nodot; 1903 LispObj *arguments, *initial, *dim, *cons, *array, *data; 1904 1905 info->nodot = info->level + 1; 1906 data = LispDoRead(info); 1907 info->nodot = nodot; 1908 1909 /* form read */ 1910 if (info->discard) 1911 return (data); 1912 1913 if (INVALIDP(data)) 1914 READ_ERROR_INVARG(); 1915 1916 initial = Kinitial_contents; 1917 1918 dim = cons = NIL; 1919 if (dimensions) { 1920 LispObj *array; 1921 1922 for (count = 0, array = data; count < dimensions; count++) { 1923 long length; 1924 LispObj *item; 1925 1926 if (!CONSP(array)) 1927 READ_ERROR0("bad array for given dimension"); 1928 item = array; 1929 array = CAR(array); 1930 1931 for (length = 0; CONSP(item); item = CDR(item), length++) 1932 ; 1933 1934 if (dim == NIL) { 1935 dim = cons = CONS(FIXNUM(length), NIL); 1936 GC_PROTECT(dim); 1937 } 1938 else { 1939 RPLACD(cons, CONS(FIXNUM(length), NIL)); 1940 cons = CDR(cons); 1941 } 1942 } 1943 } 1944 1945 arguments = CONS(dim, CONS(initial, CONS(data, NIL))); 1946 GC_PROTECT(arguments); 1947 array = APPLY(Omake_array, arguments); 1948 GC_LEAVE(); 1949 1950 return (array); 1951} 1952 1953static LispObj * 1954LispReadFeature(int with, read_info *info) 1955{ 1956 READ_ENTER(); 1957 LispObj *status; 1958 LispObj *feature = LispDoRead(info); 1959 1960 /* form read */ 1961 if (info->discard) 1962 return (feature); 1963 1964 if (INVALIDP(feature)) 1965 READ_ERROR_INVARG(); 1966 1967 /* paranoia check, features must be a list, possibly empty */ 1968 if (!CONSP(FEATURES) && FEATURES != NIL) 1969 READ_ERROR1("%s is not a list", STROBJ(FEATURES)); 1970 1971 status = LispEvalFeature(feature); 1972 1973 if (with) { 1974 if (status == T) 1975 return (LispDoRead(info)); 1976 1977 /* need to use the field discard because the following expression 1978 * may be #.FORM or #,FORM or any other form that may generate 1979 * side effects */ 1980 info->discard = 1; 1981 LispDoRead(info); 1982 info->discard = 0; 1983 1984 return (LispDoRead(info)); 1985 } 1986 1987 if (status == NIL) 1988 return (LispDoRead(info)); 1989 1990 info->discard = 1; 1991 LispDoRead(info); 1992 info->discard = 0; 1993 1994 return (LispDoRead(info)); 1995} 1996 1997/* 1998 * A very simple eval loop with AND, NOT, and OR functions for testing 1999 * the available features. 2000 */ 2001static LispObj * 2002LispEvalFeature(LispObj *feature) 2003{ 2004 READ_ENTER(); 2005 Atom_id test; 2006 LispObj *object; 2007 2008 if (CONSP(feature)) { 2009 LispObj *function = CAR(feature), *arguments = CDR(feature); 2010 2011 if (!SYMBOLP(function)) 2012 READ_ERROR1("bad feature test function %s", STROBJ(function)); 2013 if (!CONSP(arguments)) 2014 READ_ERROR1("bad feature test arguments %s", STROBJ(arguments)); 2015 test = ATOMID(function); 2016 if (test == Sand) { 2017 for (; CONSP(arguments); arguments = CDR(arguments)) { 2018 if (LispEvalFeature(CAR(arguments)) == NIL) 2019 return (NIL); 2020 } 2021 return (T); 2022 } 2023 else if (test == Sor) { 2024 for (; CONSP(arguments); arguments = CDR(arguments)) { 2025 if (LispEvalFeature(CAR(arguments)) == T) 2026 return (T); 2027 } 2028 return (NIL); 2029 } 2030 else if (test == Snot) { 2031 if (CONSP(CDR(arguments))) 2032 READ_ERROR0("too many arguments to NOT"); 2033 2034 return (LispEvalFeature(CAR(arguments)) == NIL ? T : NIL); 2035 } 2036 else 2037 READ_ERROR1("unimplemented feature test function %s", test); 2038 } 2039 2040 if (KEYWORDP(feature)) 2041 feature = feature->data.quote; 2042 else if (!SYMBOLP(feature)) 2043 READ_ERROR1("bad feature specification %s", STROBJ(feature)); 2044 2045 test = ATOMID(feature); 2046 2047 for (object = FEATURES; CONSP(object); object = CDR(object)) { 2048 /* paranoia check, elements in the feature list must ge keywords */ 2049 if (!KEYWORDP(CAR(object))) 2050 READ_ERROR1("%s is not a keyword", STROBJ(CAR(object))); 2051 if (ATOMID(CAR(object)) == test) 2052 return (T); 2053 } 2054 2055 /* unknown feature */ 2056 return (NIL); 2057} 2058