1 /* 2 * Copyright (c) 2001 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 Csar Pereira de Andrade 28 */ 29 30 /* $XFree86: xc/programs/xedit/lisp/helper.c,v 1.50 2003/05/27 22:27:03 tsi Exp $ */ 31 32 #include "lisp/helper.h" 33 #include "lisp/pathname.h" 34 #include "lisp/package.h" 35 #include "lisp/read.h" 36 #include "lisp/stream.h" 37 #include "lisp/write.h" 38 #include "lisp/hash.h" 39 #include <ctype.h> 40 #include <fcntl.h> 41 #include <errno.h> 42 #include <math.h> 43 #include <sys/stat.h> 44 45 /* 46 * Prototypes 47 */ 48 static LispObj *LispReallyDo(LispBuiltin*, int); 49 static LispObj *LispReallyDoListTimes(LispBuiltin*, int); 50 51 /* in math.c */ 52 extern LispObj *LispFloatCoerce(LispBuiltin*, LispObj*); 53 54 /* 55 * Implementation 56 */ 57 LispObj * 58 LispObjectCompare(LispObj *left, LispObj *right, int function) 59 { 60 LispType ltype, rtype; 61 LispObj *result = left == right ? T : NIL; 62 63 /* If left and right are the same object, or if function is EQ */ 64 if (result == T || function == FEQ) 65 return (result); 66 67 ltype = OBJECT_TYPE(left); 68 rtype = OBJECT_TYPE(right); 69 70 /* Equalp requires that numeric objects be compared by value, and 71 * strings or characters comparison be case insenstive */ 72 if (function == FEQUALP) { 73 switch (ltype) { 74 case LispFixnum_t: 75 case LispInteger_t: 76 case LispBignum_t: 77 case LispDFloat_t: 78 case LispRatio_t: 79 case LispBigratio_t: 80 case LispComplex_t: 81 switch (rtype) { 82 case LispFixnum_t: 83 case LispInteger_t: 84 case LispBignum_t: 85 case LispDFloat_t: 86 case LispRatio_t: 87 case LispBigratio_t: 88 case LispComplex_t: 89 result = APPLY2(Oequal_, left, right); 90 break; 91 default: 92 break; 93 } 94 goto compare_done; 95 case LispSChar_t: 96 if (rtype == LispSChar_t && 97 toupper(SCHAR_VALUE(left)) == toupper(SCHAR_VALUE(right))) 98 result = T; 99 goto compare_done; 100 case LispString_t: 101 if (rtype == LispString_t && STRLEN(left) == STRLEN(right)) { 102 long i = STRLEN(left); 103 char *sl = THESTR(left), *sr = THESTR(right); 104 105 for (--i; i >= 0; i--) 106 if (toupper(sl[i]) != toupper(sr[i])) 107 break; 108 if (i < 0) 109 result = T; 110 } 111 goto compare_done; 112 case LispArray_t: 113 if (rtype == LispArray_t && 114 left->data.array.type == right->data.array.type && 115 left->data.array.rank == right->data.array.rank && 116 LispObjectCompare(left->data.array.dim, 117 right->data.array.dim, 118 FEQUAL) != NIL) { 119 LispObj *llist = left->data.array.list, 120 *rlist = right->data.array.list; 121 122 for (; CONSP(llist); llist = CDR(llist), rlist = CDR(rlist)) 123 if (LispObjectCompare(CAR(llist), CAR(rlist), 124 FEQUALP) == NIL) 125 break; 126 if (!CONSP(llist)) 127 result = T; 128 } 129 goto compare_done; 130 case LispStruct_t: 131 if (rtype == LispStruct_t && 132 left->data.struc.def == right->data.struc.def) { 133 LispObj *lfield = left->data.struc.fields, 134 *rfield = right->data.struc.fields; 135 136 for (; CONSP(lfield); 137 lfield = CDR(lfield), rfield = CDR(rfield)) { 138 if (LispObjectCompare(CAR(lfield), CAR(rfield), 139 FEQUALP) != T) 140 break; 141 } 142 if (!CONSP(lfield)) 143 result = T; 144 } 145 goto compare_done; 146 case LispHashTable_t: 147 if (rtype == LispHashTable_t && 148 left->data.hash.table->count == 149 right->data.hash.table->count && 150 left->data.hash.test == right->data.hash.test) { 151 unsigned long i; 152 LispObj *test = left->data.hash.test; 153 LispHashEntry *lentry = left->data.hash.table->entries, 154 *llast = lentry + 155 left->data.hash.table->num_entries, 156 *rentry = right->data.hash.table->entries; 157 158 for (; lentry < llast; lentry++, rentry++) { 159 if (lentry->count != rentry->count) 160 break; 161 for (i = 0; i < lentry->count; i++) { 162 if (APPLY2(test, 163 lentry->keys[i], 164 rentry->keys[i]) == NIL || 165 LispObjectCompare(lentry->values[i], 166 rentry->values[i], 167 FEQUALP) == NIL) 168 break; 169 } 170 if (i < lentry->count) 171 break; 172 } 173 if (lentry == llast) 174 result = T; 175 } 176 goto compare_done; 177 default: 178 break; 179 } 180 } 181 182 /* Function is EQL or EQUAL, or EQUALP on arguments with the same rules */ 183 if (ltype == rtype) { 184 switch (ltype) { 185 case LispFixnum_t: 186 case LispSChar_t: 187 if (FIXNUM_VALUE(left) == FIXNUM_VALUE(right)) 188 result = T; 189 break; 190 case LispInteger_t: 191 if (INT_VALUE(left) == INT_VALUE(right)) 192 result = T; 193 break; 194 case LispDFloat_t: 195 if (DFLOAT_VALUE(left) == DFLOAT_VALUE(right)) 196 result = T; 197 break; 198 case LispRatio_t: 199 if (left->data.ratio.numerator == 200 right->data.ratio.numerator && 201 left->data.ratio.denominator == 202 right->data.ratio.denominator) 203 result = T; 204 break; 205 case LispComplex_t: 206 if (LispObjectCompare(left->data.complex.real, 207 right->data.complex.real, 208 function) == T && 209 LispObjectCompare(left->data.complex.imag, 210 right->data.complex.imag, 211 function) == T) 212 result = T; 213 break; 214 case LispBignum_t: 215 if (mpi_cmp(left->data.mp.integer, right->data.mp.integer) == 0) 216 result = T; 217 break; 218 case LispBigratio_t: 219 if (mpr_cmp(left->data.mp.ratio, right->data.mp.ratio) == 0) 220 result = T; 221 break; 222 default: 223 break; 224 } 225 226 /* Next types must be the same object for EQL */ 227 if (function == FEQL) 228 goto compare_done; 229 230 switch (ltype) { 231 case LispString_t: 232 if (STRLEN(left) == STRLEN(right) && 233 memcmp(THESTR(left), THESTR(right), STRLEN(left)) == 0) 234 result = T; 235 break; 236 case LispCons_t: 237 if (LispObjectCompare(CAR(left), CAR(right), function) == T && 238 LispObjectCompare(CDR(left), CDR(right), function) == T) 239 result = T; 240 break; 241 case LispQuote_t: 242 case LispBackquote_t: 243 case LispPathname_t: 244 result = LispObjectCompare(left->data.pathname, 245 right->data.pathname, function); 246 break; 247 case LispLambda_t: 248 result = LispObjectCompare(left->data.lambda.name, 249 right->data.lambda.name, 250 function); 251 break; 252 case LispOpaque_t: 253 if (left->data.opaque.data == right->data.opaque.data) 254 result = T; 255 break; 256 case LispRegex_t: 257 /* If the regexs are guaranteed to generate the same matches */ 258 if (left->data.regex.options == right->data.regex.options) 259 result = LispObjectCompare(left->data.regex.pattern, 260 right->data.regex.pattern, 261 function); 262 break; 263 default: 264 break; 265 } 266 } 267 268 compare_done: 269 return (result); 270 } 271 272 void 273 LispCheckSequenceStartEnd(LispBuiltin *builtin, 274 LispObj *sequence, LispObj *start, LispObj *end, 275 long *pstart, long *pend, long *plength) 276 { 277 /* Calculate length of sequence and check it's type */ 278 *plength = LispLength(sequence); 279 280 /* Check start argument */ 281 if (start == UNSPEC || start == NIL) 282 *pstart = 0; 283 else { 284 CHECK_INDEX(start); 285 *pstart = FIXNUM_VALUE(start); 286 } 287 288 /* Check end argument */ 289 if (end == UNSPEC || end == NIL) 290 *pend = *plength; 291 else { 292 CHECK_INDEX(end); 293 *pend = FIXNUM_VALUE(end); 294 } 295 296 /* Check start argument */ 297 if (*pstart > *pend) 298 LispDestroy("%s: :START %ld is larger than :END %ld", 299 STRFUN(builtin), *pstart, *pend); 300 301 /* Check end argument */ 302 if (*pend > *plength) 303 LispDestroy("%s: :END %ld is larger then sequence length %ld", 304 STRFUN(builtin), *pend, *plength); 305 } 306 307 long 308 LispLength(LispObj *sequence) 309 { 310 long length; 311 312 if (sequence == NIL) 313 return (0); 314 switch (OBJECT_TYPE(sequence)) { 315 case LispString_t: 316 length = STRLEN(sequence); 317 break; 318 case LispArray_t: 319 if (sequence->data.array.rank != 1) 320 goto not_a_sequence; 321 sequence = sequence->data.array.list; 322 /*FALLTROUGH*/ 323 case LispCons_t: 324 for (length = 0; 325 CONSP(sequence); 326 length++, sequence = CDR(sequence)) 327 ; 328 break; 329 default: 330 not_a_sequence: 331 LispDestroy("LENGTH: %s is not a sequence", STROBJ(sequence)); 332 /*NOTREACHED*/ 333 length = 0; 334 } 335 336 return (length); 337 } 338 339 LispObj * 340 LispCharacterCoerce(LispBuiltin *builtin, LispObj *object) 341 { 342 if (SCHARP(object)) 343 return (object); 344 else if (STRINGP(object) && STRLEN(object) == 1) 345 return (SCHAR(THESTR(object)[0])); 346 else if (SYMBOLP(object) && ATOMID(object)->value[1] == '\0') 347 return (SCHAR(ATOMID(object)->value[0])); 348 else if (INDEXP(object)) { 349 int c = FIXNUM_VALUE(object); 350 351 if (c <= 0xff) 352 return (SCHAR(c)); 353 } 354 else if (object == T) 355 return (SCHAR('T')); 356 357 LispDestroy("%s: cannot convert %s to character", 358 STRFUN(builtin), STROBJ(object)); 359 /*NOTREACHED*/ 360 return (NIL); 361 } 362 363 LispObj * 364 LispStringCoerce(LispBuiltin *builtin, LispObj *object) 365 { 366 if (STRINGP(object)) 367 return (object); 368 else if (SYMBOLP(object)) 369 return (LispSymbolName(object)); 370 else if (SCHARP(object)) { 371 char string[1]; 372 373 string[0] = SCHAR_VALUE(object); 374 return (LSTRING(string, 1)); 375 } 376 else if (object == NIL) 377 return (LSTRING(Snil->value, 3)); 378 else if (object == T) 379 return (LSTRING(St->value, 1)); 380 else 381 LispDestroy("%s: cannot convert %s to string", 382 STRFUN(builtin), STROBJ(object)); 383 /*NOTREACHED*/ 384 return (NIL); 385 } 386 387 LispObj * 388 LispCoerce(LispBuiltin *builtin, 389 LispObj *object, LispObj *result_type) 390 { 391 LispObj *result = NIL; 392 LispType type = LispNil_t; 393 394 if (result_type == NIL) 395 /* not even NIL can be converted to NIL? */ 396 LispDestroy("%s: cannot convert %s to NIL", 397 STRFUN(builtin), STROBJ(object)); 398 399 else if (result_type == T) 400 /* no conversion */ 401 return (object); 402 403 else if (!SYMBOLP(result_type)) 404 /* only know about simple types */ 405 LispDestroy("%s: bad argument %s", 406 STRFUN(builtin), STROBJ(result_type)); 407 408 else { 409 /* check all known types */ 410 411 Atom_id atom = ATOMID(result_type); 412 413 if (atom == Satom) { 414 if (CONSP(object)) 415 goto coerce_fail; 416 return (object); 417 } 418 /* only convert ATOM to SYMBOL */ 419 420 if (atom == Sfloat) 421 type = LispDFloat_t; 422 else if (atom == Sinteger) 423 type = LispInteger_t; 424 else if (atom == Scons || atom == Slist) { 425 if (object == NIL) 426 return (object); 427 type = LispCons_t; 428 } 429 else if (atom == Sstring) 430 type = LispString_t; 431 else if (atom == Scharacter) 432 type = LispSChar_t; 433 else if (atom == Scomplex) 434 type = LispComplex_t; 435 else if (atom == Svector || atom == Sarray) 436 type = LispArray_t; 437 else if (atom == Sopaque) 438 type = LispOpaque_t; 439 else if (atom == Srational) 440 type = LispRatio_t; 441 else if (atom == Spathname) 442 type = LispPathname_t; 443 else 444 LispDestroy("%s: invalid type specification %s", 445 STRFUN(builtin), ATOMID(result_type)->value); 446 } 447 448 if (OBJECT_TYPE(object) == LispOpaque_t) { 449 switch (type) { 450 case LispAtom_t: 451 result = ATOM(object->data.opaque.data); 452 break; 453 case LispString_t: 454 result = STRING(object->data.opaque.data); 455 break; 456 case LispSChar_t: 457 result = SCHAR((unsigned long)object->data.opaque.data); 458 break; 459 case LispDFloat_t: 460 result = DFLOAT((double)((long)object->data.opaque.data)); 461 break; 462 case LispInteger_t: 463 result = INTEGER(((long)object->data.opaque.data)); 464 break; 465 case LispOpaque_t: 466 result = OPAQUE(object->data.opaque.data, 0); 467 break; 468 default: 469 goto coerce_fail; 470 break; 471 } 472 } 473 474 else if (OBJECT_TYPE(object) != type) { 475 switch (type) { 476 case LispInteger_t: 477 if (INTEGERP(object)) 478 result = object; 479 else if (DFLOATP(object)) { 480 if ((long)DFLOAT_VALUE(object) == DFLOAT_VALUE(object)) 481 result = INTEGER((long)DFLOAT_VALUE(object)); 482 else { 483 mpi *integer = LispMalloc(sizeof(mpi)); 484 485 mpi_init(integer); 486 mpi_setd(integer, DFLOAT_VALUE(object)); 487 if (mpi_getd(integer) != DFLOAT_VALUE(object)) { 488 mpi_clear(integer); 489 LispFree(integer); 490 goto coerce_fail; 491 } 492 result = BIGNUM(integer); 493 } 494 } 495 else 496 goto coerce_fail; 497 break; 498 case LispRatio_t: 499 if (DFLOATP(object)) { 500 mpr *ratio = LispMalloc(sizeof(mpr)); 501 502 mpr_init(ratio); 503 mpr_setd(ratio, DFLOAT_VALUE(object)); 504 if (mpr_fiti(ratio)) { 505 result = RATIO(mpi_geti(mpr_num(ratio)), 506 mpi_geti(mpr_den(ratio))); 507 mpr_clear(ratio); 508 LispFree(ratio); 509 } 510 else 511 result = BIGRATIO(ratio); 512 } 513 else if (RATIONALP(object)) 514 result = object; 515 else 516 goto coerce_fail; 517 break; 518 case LispDFloat_t: 519 result = LispFloatCoerce(builtin, object); 520 break; 521 case LispComplex_t: 522 if (NUMBERP(object)) 523 result = object; 524 else 525 goto coerce_fail; 526 break; 527 case LispString_t: 528 if (object == NIL) 529 result = STRING(""); 530 else 531 result = LispStringCoerce(builtin, object); 532 break; 533 case LispSChar_t: 534 result = LispCharacterCoerce(builtin, object); 535 break; 536 case LispArray_t: 537 if (LISTP(object)) 538 result = VECTOR(object); 539 else 540 goto coerce_fail; 541 break; 542 case LispCons_t: 543 if (ARRAYP(object) && object->data.array.rank == 1) 544 result = object->data.array.list; 545 else 546 goto coerce_fail; 547 break; 548 case LispPathname_t: 549 result = APPLY1(Oparse_namestring, object); 550 break; 551 default: 552 goto coerce_fail; 553 } 554 } 555 else 556 result = object; 557 558 return (result); 559 560 coerce_fail: 561 LispDestroy("%s: cannot convert %s to %s", 562 STRFUN(builtin), STROBJ(object), ATOMID(result_type)->value); 563 /* NOTREACHED */ 564 return (NIL); 565 } 566 567 static LispObj * 568 LispReallyDo(LispBuiltin *builtin, int refs) 569 /* 570 do init test &rest body 571 do* init test &rest body 572 */ 573 { 574 GC_ENTER(); 575 int stack, lex, head; 576 LispObj *list, *symbol, *value, *values, *cons; 577 578 LispObj *init, *test, *body; 579 580 body = ARGUMENT(2); 581 test = ARGUMENT(1); 582 init = ARGUMENT(0); 583 584 if (!CONSP(test)) 585 LispDestroy("%s: end test condition must be a list, not %s", 586 STRFUN(builtin), STROBJ(init)); 587 588 CHECK_LIST(init); 589 590 /* Save state */ 591 stack = lisp__data.stack.length; 592 lex = lisp__data.env.lex; 593 head = lisp__data.env.length; 594 595 values = cons = NIL; 596 for (list = init; CONSP(list); list = CDR(list)) { 597 symbol = CAR(list); 598 if (!SYMBOLP(symbol)) { 599 CHECK_CONS(symbol); 600 value = CDR(symbol); 601 symbol = CAR(symbol); 602 CHECK_SYMBOL(symbol); 603 CHECK_CONS(value); 604 value = EVAL(CAR(value)); 605 } 606 else 607 value = NIL; 608 609 CHECK_CONSTANT(symbol); 610 611 LispAddVar(symbol, value); 612 613 /* Bind variable now */ 614 if (refs) { 615 ++lisp__data.env.head; 616 } 617 else { 618 if (values == NIL) { 619 values = cons = CONS(NIL, NIL); 620 GC_PROTECT(values); 621 } 622 else { 623 RPLACD(cons, CONS(NIL, NIL)); 624 cons = CDR(cons); 625 } 626 } 627 } 628 if (!refs) 629 lisp__data.env.head = lisp__data.env.length; 630 631 for (;;) { 632 if (EVAL(CAR(test)) != NIL) 633 break; 634 635 /* TODO Run this code in an implicit tagbody */ 636 for (list = body; CONSP(list); list = CDR(list)) 637 (void)EVAL(CAR(list)); 638 639 /* Error checking already done in the initialization */ 640 for (list = init, cons = values; CONSP(list); list = CDR(list)) { 641 symbol = CAR(list); 642 if (CONSP(symbol)) { 643 value = CDDR(symbol); 644 symbol = CAR(symbol); 645 if (CONSP(value)) 646 value = EVAL(CAR(value)); 647 else 648 value = NIL; 649 } 650 else 651 value = NIL; 652 653 if (refs) 654 LispSetVar(symbol, value); 655 else { 656 RPLACA(cons, value); 657 cons = CDR(cons); 658 } 659 } 660 if (!refs) { 661 for (list = init, cons = values; 662 CONSP(list); 663 list = CDR(list), cons = CDR(cons)) { 664 symbol = CAR(list); 665 if (CONSP(symbol)) { 666 if (CONSP(CDR(symbol))) 667 LispSetVar(CAR(symbol), CAR(cons)); 668 } 669 } 670 } 671 } 672 673 if (CONSP(CDR(test))) 674 value = EVAL(CADR(test)); 675 else 676 value = NIL; 677 678 /* Restore state */ 679 lisp__data.stack.length = stack; 680 lisp__data.env.lex = lex; 681 lisp__data.env.head = lisp__data.env.length = head; 682 GC_LEAVE(); 683 684 return (value); 685 } 686 687 LispObj * 688 LispDo(LispBuiltin *builtin, int refs) 689 /* 690 do init test &rest body 691 do* init test &rest body 692 */ 693 { 694 int jumped; 695 LispObj *result; 696 LispBlock *block; 697 698 jumped = 1; 699 result = NIL; 700 block = LispBeginBlock(NIL, LispBlockTag); 701 if (setjmp(block->jmp) == 0) { 702 result = LispReallyDo(builtin, refs); 703 jumped = 0; 704 } 705 LispEndBlock(block); 706 if (jumped) 707 result = lisp__data.block.block_ret; 708 709 return (result); 710 } 711 712 static LispObj * 713 LispReallyDoListTimes(LispBuiltin *builtin, int times) 714 /* 715 dolist init &rest body 716 dotimes init &rest body 717 */ 718 { 719 GC_ENTER(); 720 int head = lisp__data.env.length; 721 long count = 0, end = 0; 722 LispObj *symbol, *value = NIL, *result = NIL, *init, *body, *object; 723 724 body = ARGUMENT(1); 725 init = ARGUMENT(0); 726 727 /* Parse arguments */ 728 CHECK_CONS(init); 729 symbol = CAR(init); 730 CHECK_SYMBOL(symbol); 731 init = CDR(init); 732 733 if (init == NIL) { 734 if (times) 735 LispDestroy("%s: NIL is not a number", STRFUN(builtin)); 736 } 737 else { 738 CHECK_CONS(init); 739 value = CAR(init); 740 init = CDR(init); 741 if (init != NIL) { 742 CHECK_CONS(init); 743 result = CAR(init); 744 } 745 746 value = EVAL(value); 747 748 if (times) { 749 CHECK_INDEX(value); 750 end = FIXNUM_VALUE(value); 751 } 752 else { 753 CHECK_LIST(value); 754 /* Protect iteration control from gc */ 755 GC_PROTECT(value); 756 } 757 } 758 759 /* The variable is only bound inside the loop, so it is safe to optimize 760 * it out if there is no code to execute. But the result form may reference 761 * the bound variable. */ 762 if (!CONSP(body)) { 763 if (times) 764 count = end; 765 else 766 value = NIL; 767 } 768 769 /* Initialize counter */ 770 CHECK_CONSTANT(symbol); 771 if (times) 772 LispAddVar(symbol, FIXNUM(count)); 773 else 774 LispAddVar(symbol, CONSP(value) ? CAR(value) : value); 775 ++lisp__data.env.head; 776 777 if (!CONSP(body) || (times && count >= end) || (!times && !CONSP(value))) 778 goto loop_done; 779 780 /* Execute iterations */ 781 for (;;) { 782 for (object = body; CONSP(object); object = CDR(object)) 783 (void)EVAL(CAR(object)); 784 785 /* Update symbols and check exit condition */ 786 if (times) { 787 ++count; 788 LispSetVar(symbol, FIXNUM(count)); 789 if (count >= end) 790 break; 791 } 792 else { 793 value = CDR(value); 794 if (!CONSP(value)) { 795 LispSetVar(symbol, NIL); 796 break; 797 } 798 LispSetVar(symbol, CAR(value)); 799 } 800 } 801 802 loop_done: 803 result = EVAL(result); 804 lisp__data.env.head = lisp__data.env.length = head; 805 GC_LEAVE(); 806 807 return (result); 808 } 809 810 LispObj * 811 LispDoListTimes(LispBuiltin *builtin, int times) 812 /* 813 dolist init &rest body 814 dotimes init &rest body 815 */ 816 { 817 int did_jump, *pdid_jump = &did_jump; 818 LispObj *result, **presult = &result; 819 LispBlock *block; 820 821 *presult = NIL; 822 *pdid_jump = 1; 823 block = LispBeginBlock(NIL, LispBlockTag); 824 if (setjmp(block->jmp) == 0) { 825 result = LispReallyDoListTimes(builtin, times); 826 did_jump = 0; 827 } 828 LispEndBlock(block); 829 if (did_jump) 830 result = lisp__data.block.block_ret; 831 832 return (result); 833 } 834 835 LispObj * 836 LispLoadFile(LispObj *filename, int verbose, int print, int ifdoesnotexist) 837 { 838 LispObj *stream, *cod, *obj, *result; 839 int ch; 840 841 LispObj *savepackage; 842 LispPackage *savepack; 843 844 if (verbose) 845 LispMessage("; Loading %s", THESTR(filename)); 846 847 if (ifdoesnotexist) { 848 GC_ENTER(); 849 result = CONS(filename, CONS(Kif_does_not_exist, CONS(Kerror, NIL))); 850 GC_PROTECT(result); 851 stream = APPLY(Oopen, result); 852 GC_LEAVE(); 853 } 854 else 855 stream = APPLY1(Oopen, filename); 856 857 if (stream == NIL) 858 return (NIL); 859 860 result = NIL; 861 LispPushInput(stream); 862 ch = LispGet(); 863 if (ch != '#') 864 LispUnget(ch); 865 else if ((ch = LispGet()) == '!') { 866 for (;;) { 867 ch = LispGet(); 868 if (ch == '\n' || ch == EOF) 869 break; 870 } 871 } 872 else { 873 LispUnget(ch); 874 LispUnget('#'); 875 } 876 877 /* Save package environment */ 878 savepackage = PACKAGE; 879 savepack = lisp__data.pack; 880 881 cod = COD; 882 883 /*CONSTCOND*/ 884 while (1) { 885 if ((obj = LispRead()) != NULL) { 886 result = EVAL(obj); 887 COD = cod; 888 if (print) { 889 int i; 890 891 if (RETURN_COUNT >= 0) 892 LispPrint(result, NIL, 1); 893 for (i = 0; i < RETURN_COUNT; i++) 894 LispPrint(RETURN(i), NIL, 1); 895 } 896 } 897 if (lisp__data.eof) 898 break; 899 } 900 LispPopInput(stream); 901 902 /* Restore package environment */ 903 PACKAGE = savepackage; 904 lisp__data.pack = savepack; 905 906 APPLY1(Oclose, stream); 907 908 return (T); 909 } 910 911 void 912 LispGetStringArgs(LispBuiltin *builtin, 913 char **string1, char **string2, 914 long *start1, long *end1, long *start2, long *end2) 915 { 916 long length1, length2; 917 LispObj *ostring1, *ostring2, *ostart1, *oend1, *ostart2, *oend2; 918 919 oend2 = ARGUMENT(5); 920 ostart2 = ARGUMENT(4); 921 oend1 = ARGUMENT(3); 922 ostart1 = ARGUMENT(2); 923 ostring2 = ARGUMENT(1); 924 ostring1 = ARGUMENT(0); 925 926 CHECK_STRING(ostring1); 927 *string1 = THESTR(ostring1); 928 length1 = STRLEN(ostring1); 929 930 CHECK_STRING(ostring2); 931 *string2 = THESTR(ostring2); 932 length2 = STRLEN(ostring2); 933 934 if (ostart1 == UNSPEC) 935 *start1 = 0; 936 else { 937 CHECK_INDEX(ostart1); 938 *start1 = FIXNUM_VALUE(ostart1); 939 } 940 if (oend1 == UNSPEC) 941 *end1 = length1; 942 else { 943 CHECK_INDEX(oend1); 944 *end1 = FIXNUM_VALUE(oend1); 945 } 946 947 if (ostart2 == UNSPEC) 948 *start2 = 0; 949 else { 950 CHECK_INDEX(ostart2); 951 *start2 = FIXNUM_VALUE(ostart2); 952 } 953 954 if (oend2 == UNSPEC) 955 *end2 = length2; 956 else { 957 CHECK_INDEX(oend2); 958 *end2 = FIXNUM_VALUE(oend2); 959 } 960 961 if (*start1 > *end1) 962 LispDestroy("%s: :START1 %ld larger than :END1 %ld", 963 STRFUN(builtin), *start1, *end1); 964 if (*start2 > *end2) 965 LispDestroy("%s: :START2 %ld larger than :END2 %ld", 966 STRFUN(builtin), *start2, *end2); 967 if (*end1 > length1) 968 LispDestroy("%s: :END1 %ld larger than string length %ld", 969 STRFUN(builtin), *end1, length1); 970 if (*end2 > length2) 971 LispDestroy("%s: :END2 %ld larger than string length %ld", 972 STRFUN(builtin), *end2, length2); 973 } 974 975 LispObj * 976 LispPathnameField(int field, int string) 977 { 978 int offset = field; 979 LispObj *pathname, *result, *object; 980 981 pathname = ARGUMENT(0); 982 983 if (!PATHNAMEP(pathname)) 984 pathname = APPLY1(Oparse_namestring, pathname); 985 986 result = pathname->data.pathname; 987 while (offset) { 988 result = CDR(result); 989 --offset; 990 } 991 object = result; 992 result = CAR(result); 993 994 if (string) { 995 if (!STRINGP(result)) { 996 if (result == NIL) 997 result = STRING(""); 998 else if (field == PATH_DIRECTORY) { 999 char *name = THESTR(CAR(pathname->data.pathname)), *ptr; 1000 1001 ptr = strrchr(name, PATH_SEP); 1002 if (ptr) { 1003 int length = ptr - name + 1; 1004 char data[PATH_MAX]; 1005 1006 if (length > PATH_MAX - 1) 1007 length = PATH_MAX - 1; 1008 strncpy(data, name, length); 1009 data[length] = '\0'; 1010 result = STRING(data); 1011 } 1012 else 1013 result = STRING(""); 1014 } 1015 else 1016 result = Kunspecific; 1017 } 1018 else if (field == PATH_NAME) { 1019 object = CAR(CDR(object)); 1020 if (STRINGP(object)) { 1021 int length; 1022 char name[PATH_MAX + 1]; 1023 1024 strcpy(name, THESTR(result)); 1025 length = STRLEN(result); 1026 if (length + 1 < sizeof(name)) { 1027 name[length++] = PATH_TYPESEP; 1028 name[length] = '\0'; 1029 } 1030 if (STRLEN(object) + length < sizeof(name)) 1031 strcpy(name + length, THESTR(object)); 1032 /* else LispDestroy ... */ 1033 result = STRING(name); 1034 } 1035 } 1036 } 1037 1038 return (result); 1039 } 1040 1041 LispObj * 1042 LispProbeFile(LispBuiltin *builtin, int probe) 1043 { 1044 GC_ENTER(); 1045 LispObj *result; 1046 char *name = NULL, resolved[PATH_MAX + 1]; 1047 struct stat st; 1048 1049 LispObj *pathname; 1050 1051 pathname = ARGUMENT(0); 1052 1053 if (!POINTERP(pathname)) 1054 goto bad_pathname; 1055 1056 if (XSTRINGP(pathname)) 1057 name = THESTR(pathname); 1058 else if (XPATHNAMEP(pathname)) 1059 name = THESTR(CAR(pathname->data.pathname)); 1060 else if (STREAMP(pathname) && pathname->data.stream.type == LispStreamFile) 1061 name = THESTR(CAR(pathname->data.stream.pathname->data.pathname)); 1062 1063 if (realpath(name, &resolved[0]) == NULL || 1064 stat(resolved, &st)) { 1065 if (probe) 1066 return (NIL); 1067 LispDestroy("%s: realpath(\"%s\"): %s", 1068 STRFUN(builtin), name, strerror(errno)); 1069 } 1070 1071 if (S_ISDIR(st.st_mode)) { 1072 int length = strlen(resolved); 1073 1074 if (!length || resolved[length - 1] != PATH_SEP) { 1075 resolved[length++] = PATH_SEP; 1076 resolved[length] = '\0'; 1077 } 1078 } 1079 1080 result = STRING(resolved); 1081 GC_PROTECT(result); 1082 result = APPLY1(Oparse_namestring, result); 1083 GC_LEAVE(); 1084 1085 return (result); 1086 1087 bad_pathname: 1088 LispDestroy("%s: bad pathname %s", STRFUN(builtin), STROBJ(pathname)); 1089 /*NOTREACHED*/ 1090 return (NIL); 1091 } 1092 1093 LispObj * 1094 LispWriteString_(LispBuiltin *builtin, int newline) 1095 /* 1096 write-line string &optional output-stream &key start end 1097 write-string string &optional output-stream &key start end 1098 */ 1099 { 1100 char *text; 1101 long start, end, length; 1102 1103 LispObj *string, *output_stream, *ostart, *oend; 1104 1105 oend = ARGUMENT(3); 1106 ostart = ARGUMENT(2); 1107 output_stream = ARGUMENT(1); 1108 string = ARGUMENT(0); 1109 1110 CHECK_STRING(string); 1111 LispCheckSequenceStartEnd(builtin, string, ostart, oend, 1112 &start, &end, &length); 1113 if (output_stream == UNSPEC) 1114 output_stream = NIL; 1115 text = THESTR(string); 1116 if (end > start) 1117 LispWriteStr(output_stream, text + start, end - start); 1118 if (newline) 1119 LispWriteChar(output_stream, '\n'); 1120 1121 return (string); 1122 } 1123
Indexes created Wed Jul 01 00:25:26 UTC 2026