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/core.c,v 1.71tsi Exp $ */ 31 32 #include "lisp/io.h" 33 #include "lisp/core.h" 34 #include "lisp/format.h" 35 #include "lisp/helper.h" 36 #include "lisp/package.h" 37 #include "lisp/private.h" 38 #include "lisp/write.h" 39 40 /* 41 * Types 42 */ 43 typedef struct _SeqInfo { 44 LispType type; 45 union { 46 LispObj *list; 47 LispObj **vector; 48 unsigned char *string; 49 } data; 50 } SeqInfo; 51 52 #define SETSEQ(seq, object) \ 53 switch (seq.type = XOBJECT_TYPE(object)) { \ 54 case LispString_t: \ 55 seq.data.string = (unsigned char*)THESTR(object); \ 56 break; \ 57 case LispCons_t: \ 58 seq.data.list = object; \ 59 break; \ 60 default: \ 61 seq.data.list = object->data.array.list; \ 62 break; \ 63 } 64 65 #ifdef __APPLE__ 66 # define finite(x) isfinite(x) 67 #endif 68 69 #ifdef NEED_SETENV 70 extern int setenv(const char *name, const char *value, int overwrite); 71 extern void unsetenv(const char *name); 72 #endif 73 74 /* 75 * Prototypes 76 */ 77 #define NONE 0 78 79 #define REMOVE 1 80 #define SUBSTITUTE 2 81 #define DELETE 3 82 #define NSUBSTITUTE 4 83 84 #define ASSOC 1 85 #define MEMBER 2 86 87 #define FIND 1 88 #define POSITION 2 89 90 #define IF 1 91 #define IFNOT 2 92 93 #define UNION 1 94 #define INTERSECTION 2 95 #define SETDIFFERENCE 3 96 #define SETEXCLUSIVEOR 4 97 #define SUBSETP 5 98 #define NSETDIFFERENCE 6 99 #define NINTERSECTION 7 100 #define NUNION 8 101 #define NSETEXCLUSIVEOR 9 102 103 #define COPY_LIST 1 104 #define COPY_ALIST 2 105 #define COPY_TREE 3 106 107 #define EVERY 1 108 #define SOME 2 109 #define NOTEVERY 3 110 #define NOTANY 4 111 112 /* Call directly LispObjectCompare() if possible */ 113 #define FCODE(predicate) \ 114 predicate == Oeql ? FEQL : \ 115 predicate == Oequal ? FEQUAL : \ 116 predicate == Oeq ? FEQ : \ 117 predicate == Oequalp ? FEQUALP : 0 118 #define FCOMPARE(predicate, left, right, code) \ 119 code == FEQ ? left == right : \ 120 code ? LispObjectCompare(left, right, code) != NIL : \ 121 APPLY2(predicate, left, right) != NIL 122 123 #define FUNCTION_CHECK(predicate) \ 124 if (FUNCTIONP(predicate)) \ 125 predicate = (predicate)->data.atom->object 126 127 #define CHECK_TEST_0() \ 128 if (test != UNSPEC && test_not != UNSPEC) \ 129 LispDestroy("%s: specify either :TEST or :TEST-NOT", \ 130 STRFUN(builtin)) 131 132 #define CHECK_TEST() \ 133 CHECK_TEST_0(); \ 134 if (test_not == UNSPEC) { \ 135 if (test == UNSPEC) \ 136 lambda = Oeql; \ 137 else \ 138 lambda = test; \ 139 expect = 1; \ 140 } \ 141 else { \ 142 lambda = test_not; \ 143 expect = 0; \ 144 } \ 145 FUNCTION_CHECK(lambda); \ 146 code = FCODE(lambda) 147 148 149 static LispObj *LispAdjoin(LispBuiltin*, 150 LispObj*, LispObj*, LispObj*, LispObj*, LispObj*); 151 static LispObj *LispAssocOrMember(LispBuiltin*, int, int); 152 static LispObj *LispEverySomeAnyNot(LispBuiltin*, int); 153 static LispObj *LispFindOrPosition(LispBuiltin*, int, int); 154 static LispObj *LispDeleteOrRemoveDuplicates(LispBuiltin*, int); 155 static LispObj *LispDeleteRemoveXSubstitute(LispBuiltin*, int, int); 156 static LispObj *LispListSet(LispBuiltin*, int); 157 static LispObj *LispMapc(LispBuiltin*, int); 158 static LispObj *LispMapl(LispBuiltin*, int); 159 static LispObj *LispMapnconc(LispObj*); 160 extern LispObj *LispRunSetf(LispArgList*, LispObj*, LispObj*, LispObj*); 161 extern LispObj *LispRunSetfMacro(LispAtom*, LispObj*, LispObj*); 162 static LispObj *LispMergeSort(LispObj*, LispObj*, LispObj*, int); 163 static LispObj *LispXReverse(LispBuiltin*, int); 164 static LispObj *LispCopyList(LispBuiltin*, LispObj*, int); 165 static LispObj *LispValuesList(LispBuiltin*, int); 166 static LispObj *LispTreeEqual(LispObj*, LispObj*, LispObj*, int); 167 static LispDocType_t LispDocumentationType(LispBuiltin*, LispObj*); 168 169 extern void LispSetAtomObjectProperty(LispAtom*, LispObj*); 170 171 /* 172 * Initialization 173 */ 174 LispObj *Oeq, *Oeql, *Oequal, *Oequalp, *Omake_array, 175 *Kinitial_contents, *Osetf, *Ootherwise, *Oquote; 176 LispObj *Ogensym_counter; 177 178 Atom_id Svariable, Sstructure, Stype, Ssetf; 179 180 /* 181 * Implementation 182 */ 183 void 184 LispCoreInit(void) 185 { 186 Oeq = STATIC_ATOM("EQ"); 187 Oeql = STATIC_ATOM("EQL"); 188 Oequal = STATIC_ATOM("EQUAL"); 189 Oequalp = STATIC_ATOM("EQUALP"); 190 Omake_array = STATIC_ATOM("MAKE-ARRAY"); 191 Kinitial_contents = KEYWORD("INITIAL-CONTENTS"); 192 Osetf = STATIC_ATOM("SETF"); 193 Ootherwise = STATIC_ATOM("OTHERWISE"); 194 LispExportSymbol(Ootherwise); 195 Oquote = STATIC_ATOM("QUOTE"); 196 LispExportSymbol(Oquote); 197 198 Svariable = GETATOMID("VARIABLE"); 199 Sstructure = GETATOMID("STRUCTURE"); 200 Stype = GETATOMID("TYPE"); 201 202 /* Create as a constant so that only the C code should change the value */ 203 Ogensym_counter = STATIC_ATOM("*GENSYM-COUNTER*"); 204 LispDefconstant(Ogensym_counter, FIXNUM(0), NIL); 205 LispExportSymbol(Ogensym_counter); 206 207 Ssetf = ATOMID(Osetf); 208 } 209 210 LispObj * 211 Lisp_Acons(LispBuiltin *builtin) 212 /* 213 acons key datum alist 214 */ 215 { 216 LispObj *key, *datum, *alist; 217 218 alist = ARGUMENT(2); 219 datum = ARGUMENT(1); 220 key = ARGUMENT(0); 221 222 return (CONS(CONS(key, datum), alist)); 223 } 224 225 static LispObj * 226 LispAdjoin(LispBuiltin*builtin, LispObj *item, LispObj *list, 227 LispObj *key, LispObj *test, LispObj *test_not) 228 { 229 GC_ENTER(); 230 int code, expect, value; 231 LispObj *lambda, *compare, *object; 232 233 CHECK_LIST(list); 234 CHECK_TEST(); 235 236 if (key != UNSPEC) { 237 item = APPLY1(key, item); 238 /* Result is not guaranteed to be gc protected */ 239 GC_PROTECT(item); 240 } 241 242 /* Check if item is not already in place */ 243 for (object = list; CONSP(object); object = CDR(object)) { 244 compare = CAR(object); 245 if (key != UNSPEC) { 246 compare = APPLY1(key, compare); 247 GC_PROTECT(compare); 248 value = FCOMPARE(lambda, item, compare, code); 249 /* Unprotect compare... */ 250 --lisp__data.protect.length; 251 } 252 else 253 value = FCOMPARE(lambda, item, compare, code); 254 255 if (value == expect) { 256 /* Item is already in list */ 257 GC_LEAVE(); 258 259 return (list); 260 } 261 } 262 GC_LEAVE(); 263 264 return (CONS(item, list)); 265 } 266 267 LispObj * 268 Lisp_Adjoin(LispBuiltin *builtin) 269 /* 270 adjoin item list &key key test test-not 271 */ 272 { 273 LispObj *item, *list, *key, *test, *test_not; 274 275 test_not = ARGUMENT(4); 276 test = ARGUMENT(3); 277 key = ARGUMENT(2); 278 list = ARGUMENT(1); 279 item = ARGUMENT(0); 280 281 return (LispAdjoin(builtin, item, list, key, test, test_not)); 282 } 283 284 LispObj * 285 Lisp_Append(LispBuiltin *builtin) 286 /* 287 append &rest lists 288 */ 289 { 290 GC_ENTER(); 291 LispObj *result, *cons, *list; 292 293 LispObj *lists; 294 295 lists = ARGUMENT(0); 296 297 /* no arguments */ 298 if (!CONSP(lists)) 299 return (NIL); 300 301 /* skip initial nil lists */ 302 for (; CONSP(CDR(lists)) && CAR(lists) == NIL; lists = CDR(lists)) 303 ; 304 305 /* last argument is not copied (even if it is the single argument) */ 306 if (!CONSP(CDR(lists))) 307 return (CAR(lists)); 308 309 /* make sure result is a list */ 310 list = CAR(lists); 311 CHECK_CONS(list); 312 result = cons = CONS(CAR(list), NIL); 313 GC_PROTECT(result); 314 for (list = CDR(list); CONSP(list); list = CDR(list)) { 315 RPLACD(cons, CONS(CAR(list), NIL)); 316 cons = CDR(cons); 317 } 318 lists = CDR(lists); 319 320 /* copy intermediate lists */ 321 for (; CONSP(CDR(lists)); lists = CDR(lists)) { 322 list = CAR(lists); 323 if (list == NIL) 324 continue; 325 /* intermediate elements must be lists */ 326 CHECK_CONS(list); 327 for (; CONSP(list); list = CDR(list)) { 328 RPLACD(cons, CONS(CAR(list), NIL)); 329 cons = CDR(cons); 330 } 331 } 332 333 /* add last element */ 334 RPLACD(cons, CAR(lists)); 335 336 GC_LEAVE(); 337 338 return (result); 339 } 340 341 LispObj * 342 Lisp_Aref(LispBuiltin *builtin) 343 /* 344 aref array &rest subscripts 345 */ 346 { 347 long c, count, idx, seq; 348 LispObj *obj, *dim; 349 350 LispObj *array, *subscripts; 351 352 subscripts = ARGUMENT(1); 353 array = ARGUMENT(0); 354 355 /* accept strings also */ 356 if (STRINGP(array) && CONSP(subscripts) && CDR(subscripts) == NIL) { 357 long offset, length = STRLEN(array); 358 359 CHECK_INDEX(CAR(subscripts)); 360 offset = FIXNUM_VALUE(CAR(subscripts)); 361 362 if (offset >= length) 363 LispDestroy("%s: index %ld too large for sequence length %ld", 364 STRFUN(builtin), offset, length); 365 366 return (SCHAR(THESTR(array)[offset])); 367 } 368 369 CHECK_ARRAY(array); 370 371 for (count = 0, dim = subscripts, obj = array->data.array.dim; CONSP(dim); 372 count++, dim = CDR(dim), obj = CDR(obj)) { 373 if (count >= array->data.array.rank) 374 LispDestroy("%s: too many subscripts %s", 375 STRFUN(builtin), STROBJ(subscripts)); 376 if (!INDEXP(CAR(dim)) || 377 FIXNUM_VALUE(CAR(dim)) >= FIXNUM_VALUE(CAR(obj))) 378 LispDestroy("%s: %s is out of range or a bad index", 379 STRFUN(builtin), STROBJ(CAR(dim))); 380 } 381 if (count < array->data.array.rank) 382 LispDestroy("%s: too few subscripts %s", 383 STRFUN(builtin), STROBJ(subscripts)); 384 385 for (count = seq = 0, dim = subscripts; CONSP(dim); dim = CDR(dim), seq++) { 386 for (idx = 0, obj = array->data.array.dim; idx < seq; 387 obj = CDR(obj), ++idx) 388 ; 389 for (c = 1, obj = CDR(obj); obj != NIL; obj = CDR(obj)) 390 c *= FIXNUM_VALUE(CAR(obj)); 391 count += c * FIXNUM_VALUE(CAR(dim)); 392 } 393 394 for (array = array->data.array.list; count > 0; array = CDR(array), count--) 395 ; 396 397 return (CAR(array)); 398 } 399 400 static LispObj * 401 LispAssocOrMember(LispBuiltin *builtin, int function, int comparison) 402 /* 403 assoc item list &key test test-not key 404 assoc-if predicate list &key key 405 assoc-if-not predicate list &key key 406 member item list &key test test-not key 407 member-if predicate list &key key 408 member-if-not predicate list &key key 409 */ 410 { 411 int code = 0, expect, value; 412 LispObj *lambda, *result, *compare; 413 414 LispObj *item, *list, *test, *test_not, *key; 415 416 if (comparison == NONE) { 417 key = ARGUMENT(4); 418 test_not = ARGUMENT(3); 419 test = ARGUMENT(2); 420 list = ARGUMENT(1); 421 item = ARGUMENT(0); 422 lambda = NIL; 423 } 424 else { 425 key = ARGUMENT(2); 426 list = ARGUMENT(1); 427 lambda = ARGUMENT(0); 428 test = test_not = UNSPEC; 429 item = NIL; 430 } 431 432 if (list == NIL) 433 return (NIL); 434 CHECK_CONS(list); 435 436 /* Resolve compare function, and expected result of comparison */ 437 if (comparison == NONE) { 438 CHECK_TEST(); 439 } 440 else 441 expect = comparison == IFNOT ? 0 : 1; 442 443 result = NIL; 444 for (; CONSP(list); list = CDR(list)) { 445 compare = CAR(list); 446 if (function == ASSOC) { 447 if (!CONSP(compare)) 448 continue; 449 compare = CAR(compare); 450 } 451 if (key != UNSPEC) 452 compare = APPLY1(key, compare); 453 454 if (comparison == NONE) 455 value = FCOMPARE(lambda, item, compare, code); 456 else 457 value = APPLY1(lambda, compare) != NIL; 458 if (value == expect) { 459 result = list; 460 if (function == ASSOC) 461 result = CAR(result); 462 break; 463 } 464 } 465 if (function == MEMBER) { 466 CHECK_LIST(list); 467 } 468 469 return (result); 470 } 471 472 LispObj * 473 Lisp_Assoc(LispBuiltin *builtin) 474 /* 475 assoc item list &key test test-not key 476 */ 477 { 478 return (LispAssocOrMember(builtin, ASSOC, NONE)); 479 } 480 481 LispObj * 482 Lisp_AssocIf(LispBuiltin *builtin) 483 /* 484 assoc-if predicate list &key key 485 */ 486 { 487 return (LispAssocOrMember(builtin, ASSOC, IF)); 488 } 489 490 LispObj * 491 Lisp_AssocIfNot(LispBuiltin *builtin) 492 /* 493 assoc-if-not predicate list &key key 494 */ 495 { 496 return (LispAssocOrMember(builtin, ASSOC, IFNOT)); 497 } 498 499 LispObj * 500 Lisp_And(LispBuiltin *builtin) 501 /* 502 and &rest args 503 */ 504 { 505 LispObj *result = T, *args; 506 507 args = ARGUMENT(0); 508 509 for (; CONSP(args); args = CDR(args)) { 510 result = EVAL(CAR(args)); 511 if (result == NIL) 512 break; 513 } 514 515 return (result); 516 } 517 518 LispObj * 519 Lisp_Apply(LispBuiltin *builtin) 520 /* 521 apply function arg &rest more-args 522 */ 523 { 524 GC_ENTER(); 525 LispObj *result, *arguments; 526 527 LispObj *function, *arg, *more_args; 528 529 more_args = ARGUMENT(2); 530 arg = ARGUMENT(1); 531 function = ARGUMENT(0); 532 533 if (more_args == NIL) { 534 CHECK_LIST(arg); 535 arguments = arg; 536 for (; CONSP(arg); arg = CDR(arg)) 537 ; 538 CHECK_LIST(arg); 539 } 540 else { 541 LispObj *cons; 542 543 CHECK_CONS(more_args); 544 arguments = cons = CONS(arg, NIL); 545 GC_PROTECT(arguments); 546 for (arg = CDR(more_args); 547 CONSP(arg); 548 more_args = arg, arg = CDR(arg)) { 549 RPLACD(cons, CONS(CAR(more_args), NIL)); 550 cons = CDR(cons); 551 } 552 more_args = CAR(more_args); 553 if (more_args != NIL) { 554 for (arg = more_args; CONSP(arg); arg = CDR(arg)) 555 ; 556 CHECK_LIST(arg); 557 RPLACD(cons, more_args); 558 } 559 } 560 561 result = APPLY(function, arguments); 562 GC_LEAVE(); 563 564 return (result); 565 } 566 567 LispObj * 568 Lisp_Atom(LispBuiltin *builtin) 569 /* 570 atom object 571 */ 572 { 573 LispObj *object; 574 575 object = ARGUMENT(0); 576 577 return (CONSP(object) ? NIL : T); 578 } 579 580 LispObj * 581 Lisp_Block(LispBuiltin *builtin) 582 /* 583 block name &rest body 584 */ 585 { 586 int did_jump, *pdid_jump = &did_jump; 587 LispObj *res, **pres = &res; 588 LispBlock *block; 589 590 LispObj *name, *body; 591 592 body = ARGUMENT(1); 593 name = ARGUMENT(0); 594 595 if (!SYMBOLP(name) && name != NIL && name != T) 596 LispDestroy("%s: %s cannot name a block", 597 STRFUN(builtin), STROBJ(name)); 598 599 *pres = NIL; 600 *pdid_jump = 1; 601 block = LispBeginBlock(name, LispBlockTag); 602 if (setjmp(block->jmp) == 0) { 603 for (; CONSP(body); body = CDR(body)) 604 res = EVAL(CAR(body)); 605 *pdid_jump = 0; 606 } 607 LispEndBlock(block); 608 if (*pdid_jump) 609 *pres = lisp__data.block.block_ret; 610 611 return (res); 612 } 613 614 LispObj * 615 Lisp_Boundp(LispBuiltin *builtin) 616 /* 617 boundp symbol 618 */ 619 { 620 LispAtom *atom; 621 622 LispObj *symbol = ARGUMENT(0); 623 624 CHECK_SYMBOL(symbol); 625 626 atom = symbol->data.atom; 627 if (atom->package == lisp__data.keyword || 628 (atom->a_object && atom->property->value != UNBOUND)) 629 return (T); 630 631 return (NIL); 632 } 633 634 LispObj * 635 Lisp_Butlast(LispBuiltin *builtin) 636 /* 637 butlast list &optional count 638 */ 639 { 640 GC_ENTER(); 641 long length, count; 642 LispObj *result, *cons, *list, *ocount; 643 644 ocount = ARGUMENT(1); 645 list = ARGUMENT(0); 646 647 CHECK_LIST(list); 648 if (ocount == UNSPEC) 649 count = 1; 650 else { 651 CHECK_INDEX(ocount); 652 count = FIXNUM_VALUE(ocount); 653 } 654 length = LispLength(list); 655 656 if (count == 0) 657 return (list); 658 else if (count >= length) 659 return (NIL); 660 661 length -= count + 1; 662 result = cons = CONS(CAR(list), NIL); 663 GC_PROTECT(result); 664 for (list = CDR(list); length > 0; list = CDR(list), length--) { 665 RPLACD(cons, CONS(CAR(list), NIL)); 666 cons = CDR(cons); 667 } 668 GC_LEAVE(); 669 670 return (result); 671 } 672 673 LispObj * 674 Lisp_Nbutlast(LispBuiltin *builtin) 675 /* 676 nbutlast list &optional count 677 */ 678 { 679 long length, count; 680 LispObj *result, *list, *ocount; 681 682 ocount = ARGUMENT(1); 683 list = ARGUMENT(0); 684 685 CHECK_LIST(list); 686 if (ocount == UNSPEC) 687 count = 1; 688 else { 689 CHECK_INDEX(ocount); 690 count = FIXNUM_VALUE(ocount); 691 } 692 length = LispLength(list); 693 694 if (count == 0) 695 return (list); 696 else if (count >= length) 697 return (NIL); 698 699 length -= count + 1; 700 result = list; 701 for (; length > 0; list = CDR(list), length--) 702 ; 703 RPLACD(list, NIL); 704 705 return (result); 706 } 707 708 LispObj * 709 Lisp_Car(LispBuiltin *builtin) 710 /* 711 car list 712 */ 713 { 714 LispObj *list, *result = NULL; 715 716 list = ARGUMENT(0); 717 718 if (list == NIL) 719 result = NIL; 720 else { 721 CHECK_CONS(list); 722 result = CAR(list); 723 } 724 725 return (result); 726 } 727 728 LispObj * 729 Lisp_Case(LispBuiltin *builtin) 730 /* 731 case keyform &rest body 732 */ 733 { 734 LispObj *result, *code, *keyform, *body, *form; 735 736 body = ARGUMENT(1); 737 keyform = ARGUMENT(0); 738 739 result = NIL; 740 keyform = EVAL(keyform); 741 742 for (; CONSP(body); body = CDR(body)) { 743 code = CAR(body); 744 CHECK_CONS(code); 745 746 form = CAR(code); 747 if (form == T || form == Ootherwise) { 748 if (CONSP(CDR(body))) 749 LispDestroy("%s: %s must be the last clause", 750 STRFUN(builtin), STROBJ(CAR(code))); 751 result = CDR(code); 752 break; 753 } 754 else if (CONSP(form)) { 755 for (; CONSP(form); form = CDR(form)) 756 if (XEQL(keyform, CAR(form)) == T) { 757 result = CDR(code); 758 break; 759 } 760 if (CONSP(form)) /* if found match */ 761 break; 762 } 763 else if (XEQL(keyform, form) == T) { 764 result = CDR(code); 765 break; 766 } 767 } 768 769 for (body = result; CONSP(body); body = CDR(body)) 770 result = EVAL(CAR(body)); 771 772 return (result); 773 } 774 775 LispObj * 776 Lisp_Catch(LispBuiltin *builtin) 777 /* 778 catch tag &rest body 779 */ 780 { 781 int did_jump, *pdid_jump = &did_jump; 782 LispObj *res, **pres = &res; 783 LispBlock *block; 784 785 LispObj *tag, *body; 786 787 body = ARGUMENT(1); 788 tag = ARGUMENT(0); 789 790 *pres = NIL; 791 *pdid_jump = 1; 792 block = LispBeginBlock(tag, LispBlockCatch); 793 if (setjmp(block->jmp) == 0) { 794 for (; CONSP(body); body = CDR(body)) 795 res = EVAL(CAR(body)); 796 *pdid_jump = 0; 797 } 798 LispEndBlock(block); 799 if (*pdid_jump) 800 *pres = lisp__data.block.block_ret; 801 802 return (res); 803 } 804 805 LispObj * 806 Lisp_Coerce(LispBuiltin *builtin) 807 /* 808 coerce object result-type 809 */ 810 { 811 LispObj *object, *result_type; 812 813 result_type = ARGUMENT(1); 814 object = ARGUMENT(0); 815 816 return (LispCoerce(builtin, object, result_type)); 817 } 818 819 LispObj * 820 Lisp_Cdr(LispBuiltin *builtin) 821 /* 822 cdr list 823 */ 824 { 825 LispObj *list, *result = NULL; 826 827 list = ARGUMENT(0); 828 829 if (list == NIL) 830 result = NIL; 831 else { 832 CHECK_CONS(list); 833 result = CDR(list); 834 } 835 836 return (result); 837 } 838 839 LispObj * 840 Lisp_C_r(LispBuiltin *builtin) 841 /* 842 c[ad]{2,4}r list 843 */ 844 { 845 char *desc; 846 847 LispObj *list, *result = NULL; 848 849 list = ARGUMENT(0); 850 851 result = list; 852 desc = STRFUN(builtin); 853 while (desc[1] != 'R') 854 ++desc; 855 while (*desc != 'C') { 856 if (result == NIL) 857 break; 858 CHECK_CONS(result); 859 result = *desc == 'A' ? CAR(result) : CDR(result); 860 --desc; 861 } 862 863 return (result); 864 } 865 866 LispObj * 867 Lisp_Cond(LispBuiltin *builtin) 868 /* 869 cond &rest body 870 */ 871 { 872 LispObj *result, *code, *body; 873 874 body = ARGUMENT(0); 875 876 result = NIL; 877 for (; CONSP(body); body = CDR(body)) { 878 code = CAR(body); 879 880 CHECK_CONS(code); 881 result = EVAL(CAR(code)); 882 if (result == NIL) 883 continue; 884 for (code = CDR(code); CONSP(code); code = CDR(code)) 885 result = EVAL(CAR(code)); 886 break; 887 } 888 889 return (result); 890 } 891 892 static LispObj * 893 LispCopyList(LispBuiltin *builtin, LispObj *list, int function) 894 { 895 GC_ENTER(); 896 LispObj *result, *cons; 897 898 if (list == NIL) 899 return (list); 900 CHECK_CONS(list); 901 902 result = cons = CONS(NIL, NIL); 903 GC_PROTECT(result); 904 if (CONSP(CAR(list))) { 905 switch (function) { 906 case COPY_LIST: 907 RPLACA(result, CAR(list)); 908 break; 909 case COPY_ALIST: 910 RPLACA(result, CONS(CAR(CAR(list)), CDR(CAR(list)))); 911 break; 912 case COPY_TREE: 913 RPLACA(result, LispCopyList(builtin, CAR(list), COPY_TREE)); 914 break; 915 } 916 } 917 else 918 RPLACA(result, CAR(list)); 919 920 for (list = CDR(list); CONSP(list); list = CDR(list)) { 921 CDR(cons) = CONS(NIL, NIL); 922 cons = CDR(cons); 923 if (CONSP(CAR(list))) { 924 switch (function) { 925 case COPY_LIST: 926 RPLACA(cons, CAR(list)); 927 break; 928 case COPY_ALIST: 929 RPLACA(cons, CONS(CAR(CAR(list)), CDR(CAR(list)))); 930 break; 931 case COPY_TREE: 932 RPLACA(cons, LispCopyList(builtin, CAR(list), COPY_TREE)); 933 break; 934 } 935 } 936 else 937 RPLACA(cons, CAR(list)); 938 } 939 /* in case list is dotted */ 940 RPLACD(cons, list); 941 GC_LEAVE(); 942 943 return (result); 944 } 945 946 LispObj * 947 Lisp_CopyAlist(LispBuiltin *builtin) 948 /* 949 copy-alist list 950 */ 951 { 952 LispObj *list; 953 954 list = ARGUMENT(0); 955 956 return (LispCopyList(builtin, list, COPY_ALIST)); 957 } 958 959 LispObj * 960 Lisp_CopyList(LispBuiltin *builtin) 961 /* 962 copy-list list 963 */ 964 { 965 LispObj *list; 966 967 list = ARGUMENT(0); 968 969 return (LispCopyList(builtin, list, COPY_LIST)); 970 } 971 972 LispObj * 973 Lisp_CopyTree(LispBuiltin *builtin) 974 /* 975 copy-tree list 976 */ 977 { 978 LispObj *list; 979 980 list = ARGUMENT(0); 981 982 return (LispCopyList(builtin, list, COPY_TREE)); 983 } 984 985 LispObj * 986 Lisp_Cons(LispBuiltin *builtin) 987 /* 988 cons car cdr 989 */ 990 { 991 LispObj *car, *cdr; 992 993 cdr = ARGUMENT(1); 994 car = ARGUMENT(0); 995 996 return (CONS(car, cdr)); 997 } 998 999 LispObj * 1000 Lisp_Consp(LispBuiltin *builtin) 1001 /* 1002 consp object 1003 */ 1004 { 1005 LispObj *object; 1006 1007 object = ARGUMENT(0); 1008 1009 return (CONSP(object) ? T : NIL); 1010 } 1011 1012 LispObj * 1013 Lisp_Constantp(LispBuiltin *builtin) 1014 /* 1015 constantp form &optional environment 1016 */ 1017 { 1018 LispObj *form; 1019 1020 form = ARGUMENT(0); 1021 1022 /* not all self-evaluating objects are considered constants */ 1023 if (!POINTERP(form) || 1024 NUMBERP(form) || 1025 XQUOTEP(form) || 1026 (XCONSP(form) && CAR(form) == Oquote) || 1027 (XSYMBOLP(form) && form->data.atom->constant) || 1028 XSTRINGP(form) || 1029 XARRAYP(form)) 1030 return (T); 1031 1032 return (NIL); 1033 } 1034 1035 LispObj * 1036 Lisp_Defconstant(LispBuiltin *builtin) 1037 /* 1038 defconstant name initial-value &optional documentation 1039 */ 1040 { 1041 LispObj *name, *initial_value, *documentation; 1042 1043 documentation = ARGUMENT(2); 1044 initial_value = ARGUMENT(1); 1045 name = ARGUMENT(0); 1046 1047 CHECK_SYMBOL(name); 1048 if (documentation != UNSPEC) { 1049 CHECK_STRING(documentation); 1050 } 1051 else 1052 documentation = NIL; 1053 LispDefconstant(name, EVAL(initial_value), documentation); 1054 1055 return (name); 1056 } 1057 1058 LispObj * 1059 Lisp_Defmacro(LispBuiltin *builtin) 1060 /* 1061 defmacro name lambda-list &rest body 1062 */ 1063 { 1064 LispArgList *alist; 1065 1066 LispObj *lambda, *name, *lambda_list, *body; 1067 1068 body = ARGUMENT(2); 1069 lambda_list = ARGUMENT(1); 1070 name = ARGUMENT(0); 1071 1072 CHECK_SYMBOL(name); 1073 alist = LispCheckArguments(LispMacro, lambda_list, ATOMID(name)->value, 0); 1074 1075 if (CONSP(body) && STRINGP(CAR(body))) { 1076 LispAddDocumentation(name, CAR(body), LispDocFunction); 1077 body = CDR(body); 1078 } 1079 1080 lambda_list = LispListProtectedArguments(alist); 1081 lambda = LispNewLambda(name, body, lambda_list, LispMacro); 1082 1083 if (name->data.atom->a_builtin || name->data.atom->a_compiled) { 1084 if (name->data.atom->a_builtin) { 1085 ERROR_CHECK_SPECIAL_FORM(name->data.atom); 1086 } 1087 /* redefining these may cause surprises if bytecode 1088 * compiled functions references them */ 1089 LispWarning("%s: %s is being redefined", STRFUN(builtin), 1090 ATOMID(name)->value); 1091 1092 LispRemAtomBuiltinProperty(name->data.atom); 1093 } 1094 1095 LispSetAtomFunctionProperty(name->data.atom, lambda, alist); 1096 LispUseArgList(alist); 1097 1098 return (name); 1099 } 1100 1101 LispObj * 1102 Lisp_Defun(LispBuiltin *builtin) 1103 /* 1104 defun name lambda-list &rest body 1105 */ 1106 { 1107 LispArgList *alist; 1108 1109 LispObj *lambda, *name, *lambda_list, *body; 1110 1111 body = ARGUMENT(2); 1112 lambda_list = ARGUMENT(1); 1113 name = ARGUMENT(0); 1114 1115 CHECK_SYMBOL(name); 1116 alist = LispCheckArguments(LispFunction, lambda_list, ATOMID(name)->value, 0); 1117 1118 if (CONSP(body) && STRINGP(CAR(body))) { 1119 LispAddDocumentation(name, CAR(body), LispDocFunction); 1120 body = CDR(body); 1121 } 1122 1123 lambda_list = LispListProtectedArguments(alist); 1124 lambda = LispNewLambda(name, body, lambda_list, LispFunction); 1125 1126 if (name->data.atom->a_builtin || name->data.atom->a_compiled) { 1127 if (name->data.atom->a_builtin) { 1128 ERROR_CHECK_SPECIAL_FORM(name->data.atom); 1129 } 1130 /* redefining these may cause surprises if bytecode 1131 * compiled functions references them */ 1132 LispWarning("%s: %s is being redefined", STRFUN(builtin), 1133 ATOMID(name)->value); 1134 1135 LispRemAtomBuiltinProperty(name->data.atom); 1136 } 1137 LispSetAtomFunctionProperty(name->data.atom, lambda, alist); 1138 LispUseArgList(alist); 1139 1140 return (name); 1141 } 1142 1143 LispObj * 1144 Lisp_Defsetf(LispBuiltin *builtin) 1145 /* 1146 defsetf function lambda-list &rest body 1147 */ 1148 { 1149 LispArgList *alist; 1150 LispObj *obj; 1151 LispObj *lambda, *function, *lambda_list, *store, *body; 1152 1153 body = ARGUMENT(2); 1154 lambda_list = ARGUMENT(1); 1155 function = ARGUMENT(0); 1156 1157 CHECK_SYMBOL(function); 1158 1159 if (body == NIL || (CONSP(body) && STRINGP(CAR(body)))) { 1160 if (!SYMBOLP(lambda_list)) 1161 LispDestroy("%s: syntax error %s %s", 1162 STRFUN(builtin), STROBJ(function), STROBJ(lambda_list)); 1163 if (body != NIL) 1164 LispAddDocumentation(function, CAR(body), LispDocSetf); 1165 1166 LispSetAtomSetfProperty(function->data.atom, lambda_list, NULL); 1167 1168 return (function); 1169 } 1170 1171 alist = LispCheckArguments(LispSetf, lambda_list, ATOMID(function)->value, 0); 1172 1173 store = CAR(body); 1174 if (!CONSP(store)) 1175 LispDestroy("%s: %s is a bad store value", 1176 STRFUN(builtin), STROBJ(store)); 1177 for (obj = store; CONSP(obj); obj = CDR(obj)) { 1178 CHECK_SYMBOL(CAR(obj)); 1179 } 1180 1181 body = CDR(body); 1182 if (CONSP(body) && STRINGP(CAR(body))) { 1183 LispAddDocumentation(function, CAR(body), LispDocSetf); 1184 body = CDR(body); 1185 } 1186 1187 lambda = LispNewLambda(function, body, store, LispSetf); 1188 LispSetAtomSetfProperty(function->data.atom, lambda, alist); 1189 LispUseArgList(alist); 1190 1191 return (function); 1192 } 1193 1194 LispObj * 1195 Lisp_Defparameter(LispBuiltin *builtin) 1196 /* 1197 defparameter name initial-value &optional documentation 1198 */ 1199 { 1200 LispObj *name, *initial_value, *documentation; 1201 1202 documentation = ARGUMENT(2); 1203 initial_value = ARGUMENT(1); 1204 name = ARGUMENT(0); 1205 1206 CHECK_SYMBOL(name); 1207 if (documentation != UNSPEC) { 1208 CHECK_STRING(documentation); 1209 } 1210 else 1211 documentation = NIL; 1212 1213 LispProclaimSpecial(name, EVAL(initial_value), documentation); 1214 1215 return (name); 1216 } 1217 1218 LispObj * 1219 Lisp_Defvar(LispBuiltin *builtin) 1220 /* 1221 defvar name &optional initial-value documentation 1222 */ 1223 { 1224 LispObj *name, *initial_value, *documentation; 1225 1226 documentation = ARGUMENT(2); 1227 initial_value = ARGUMENT(1); 1228 name = ARGUMENT(0); 1229 1230 CHECK_SYMBOL(name); 1231 if (documentation != UNSPEC) { 1232 CHECK_STRING(documentation); 1233 } 1234 else 1235 documentation = NIL; 1236 1237 LispProclaimSpecial(name, 1238 initial_value != UNSPEC ? EVAL(initial_value) : NULL, 1239 documentation); 1240 1241 return (name); 1242 } 1243 1244 LispObj * 1245 Lisp_Delete(LispBuiltin *builtin) 1246 /* 1247 delete item sequence &key from-end test test-not start end count key 1248 */ 1249 { 1250 return (LispDeleteRemoveXSubstitute(builtin, DELETE, NONE)); 1251 } 1252 1253 LispObj * 1254 Lisp_DeleteIf(LispBuiltin *builtin) 1255 /* 1256 delete-if predicate sequence &key from-end start end count key 1257 */ 1258 { 1259 return (LispDeleteRemoveXSubstitute(builtin, DELETE, IF)); 1260 } 1261 1262 LispObj * 1263 Lisp_DeleteIfNot(LispBuiltin *builtin) 1264 /* 1265 delete-if-not predicate sequence &key from-end start end count key 1266 */ 1267 { 1268 return (LispDeleteRemoveXSubstitute(builtin, DELETE, IFNOT)); 1269 } 1270 1271 LispObj * 1272 Lisp_DeleteDuplicates(LispBuiltin *builtin) 1273 /* 1274 delete-duplicates sequence &key from-end test test-not start end key 1275 */ 1276 { 1277 return (LispDeleteOrRemoveDuplicates(builtin, DELETE)); 1278 } 1279 1280 LispObj * 1281 Lisp_Do(LispBuiltin *builtin) 1282 /* 1283 do init test &rest body 1284 */ 1285 { 1286 return (LispDo(builtin, 0)); 1287 } 1288 1289 LispObj * 1290 Lisp_DoP(LispBuiltin *builtin) 1291 /* 1292 do* init test &rest body 1293 */ 1294 { 1295 return (LispDo(builtin, 1)); 1296 } 1297 1298 static LispDocType_t 1299 LispDocumentationType(LispBuiltin *builtin, LispObj *type) 1300 { 1301 Atom_id atom; 1302 LispDocType_t doc_type = LispDocVariable; 1303 1304 CHECK_SYMBOL(type); 1305 atom = ATOMID(type); 1306 1307 if (atom == Svariable) 1308 doc_type = LispDocVariable; 1309 else if (atom == Sfunction) 1310 doc_type = LispDocFunction; 1311 else if (atom == Sstructure) 1312 doc_type = LispDocStructure; 1313 else if (atom == Stype) 1314 doc_type = LispDocType; 1315 else if (atom == Ssetf) 1316 doc_type = LispDocSetf; 1317 else { 1318 LispDestroy("%s: unknown documentation type %s", 1319 STRFUN(builtin), STROBJ(type)); 1320 /*NOTREACHED*/ 1321 } 1322 1323 return (doc_type); 1324 } 1325 1326 LispObj * 1327 Lisp_Documentation(LispBuiltin *builtin) 1328 /* 1329 documentation symbol type 1330 */ 1331 { 1332 LispObj *symbol, *type; 1333 1334 type = ARGUMENT(1); 1335 symbol = ARGUMENT(0); 1336 1337 CHECK_SYMBOL(symbol); 1338 /* type is checked in LispDocumentationType() */ 1339 1340 return (LispGetDocumentation(symbol, LispDocumentationType(builtin, type))); 1341 } 1342 1343 LispObj * 1344 Lisp_DoList(LispBuiltin *builtin) 1345 { 1346 return (LispDoListTimes(builtin, 0)); 1347 } 1348 1349 LispObj * 1350 Lisp_DoTimes(LispBuiltin *builtin) 1351 { 1352 return (LispDoListTimes(builtin, 1)); 1353 } 1354 1355 LispObj * 1356 Lisp_Elt(LispBuiltin *builtin) 1357 /* 1358 elt sequence index 1359 svref sequence index 1360 */ 1361 { 1362 long offset, length; 1363 LispObj *result, *sequence, *oindex; 1364 1365 oindex = ARGUMENT(1); 1366 sequence = ARGUMENT(0); 1367 1368 length = LispLength(sequence); 1369 1370 CHECK_INDEX(oindex); 1371 offset = FIXNUM_VALUE(oindex); 1372 1373 if (offset >= length) 1374 LispDestroy("%s: index %ld too large for sequence length %ld", 1375 STRFUN(builtin), offset, length); 1376 1377 if (STRINGP(sequence)) 1378 result = SCHAR(THESTR(sequence)[offset]); 1379 else { 1380 if (ARRAYP(sequence)) 1381 sequence = sequence->data.array.list; 1382 1383 for (; offset > 0; offset--, sequence = CDR(sequence)) 1384 ; 1385 result = CAR(sequence); 1386 } 1387 1388 return (result); 1389 } 1390 1391 LispObj * 1392 Lisp_Endp(LispBuiltin *builtin) 1393 /* 1394 endp object 1395 */ 1396 { 1397 LispObj *object; 1398 1399 object = ARGUMENT(0); 1400 1401 if (object == NIL) 1402 return (T); 1403 CHECK_CONS(object); 1404 1405 return (NIL); 1406 } 1407 1408 LispObj * 1409 Lisp_Eq(LispBuiltin *builtin) 1410 /* 1411 eq left right 1412 */ 1413 { 1414 LispObj *left, *right; 1415 1416 right = ARGUMENT(1); 1417 left = ARGUMENT(0); 1418 1419 return (XEQ(left, right)); 1420 } 1421 1422 LispObj * 1423 Lisp_Eql(LispBuiltin *builtin) 1424 /* 1425 eql left right 1426 */ 1427 { 1428 LispObj *left, *right; 1429 1430 right = ARGUMENT(1); 1431 left = ARGUMENT(0); 1432 1433 return (XEQL(left, right)); 1434 } 1435 1436 LispObj * 1437 Lisp_Equal(LispBuiltin *builtin) 1438 /* 1439 equal left right 1440 */ 1441 { 1442 LispObj *left, *right; 1443 1444 right = ARGUMENT(1); 1445 left = ARGUMENT(0); 1446 1447 return (XEQUAL(left, right)); 1448 } 1449 1450 LispObj * 1451 Lisp_Equalp(LispBuiltin *builtin) 1452 /* 1453 equalp left right 1454 */ 1455 { 1456 LispObj *left, *right; 1457 1458 right = ARGUMENT(1); 1459 left = ARGUMENT(0); 1460 1461 return (XEQUALP(left, right)); 1462 } 1463 1464 LispObj * 1465 Lisp_Error(LispBuiltin *builtin) 1466 /* 1467 error control-string &rest arguments 1468 */ 1469 { 1470 LispObj *string, *arglist; 1471 1472 LispObj *control_string, *arguments; 1473 1474 arguments = ARGUMENT(1); 1475 control_string = ARGUMENT(0); 1476 1477 arglist = CONS(NIL, CONS(control_string, arguments)); 1478 GC_PROTECT(arglist); 1479 string = APPLY(Oformat, arglist); 1480 LispDestroy("%s", THESTR(string)); 1481 /*NOTREACHED*/ 1482 1483 /* No need to call GC_ENTER() and GC_LEAVE() macros */ 1484 return (NIL); 1485 } 1486 1487 LispObj * 1488 Lisp_Eval(LispBuiltin *builtin) 1489 /* 1490 eval form 1491 */ 1492 { 1493 int lex; 1494 LispObj *form, *result; 1495 1496 form = ARGUMENT(0); 1497 1498 /* make sure eval form will not access local variables */ 1499 lex = lisp__data.env.lex; 1500 lisp__data.env.lex = lisp__data.env.length; 1501 result = EVAL(form); 1502 lisp__data.env.lex = lex; 1503 1504 return (result); 1505 } 1506 1507 static LispObj * 1508 LispEverySomeAnyNot(LispBuiltin *builtin, int function) 1509 /* 1510 every predicate sequence &rest more-sequences 1511 some predicate sequence &rest more-sequences 1512 notevery predicate sequence &rest more-sequences 1513 notany predicate sequence &rest more-sequences 1514 */ 1515 { 1516 GC_ENTER(); 1517 long i, j, length, count; 1518 LispObj *result, *list, *item, *arguments, *acons, *value; 1519 SeqInfo stk[8], *seqs; 1520 1521 LispObj *predicate, *sequence, *more_sequences; 1522 1523 more_sequences = ARGUMENT(2); 1524 sequence = ARGUMENT(1); 1525 predicate = ARGUMENT(0); 1526 1527 count = 1; 1528 length = LispLength(sequence); 1529 for (list = more_sequences; CONSP(list); list = CDR(list), count++) { 1530 i = LispLength(CAR(list)); 1531 if (i < length) 1532 length = i; 1533 } 1534 1535 result = function == EVERY || function == NOTANY ? T : NIL; 1536 1537 /* if at least one sequence has length zero */ 1538 if (length == 0) 1539 return (result); 1540 1541 if (count > sizeof(stk) / sizeof(stk[0])) 1542 seqs = LispMalloc(count * sizeof(SeqInfo)); 1543 else 1544 seqs = &stk[0]; 1545 1546 /* build information about sequences */ 1547 SETSEQ(seqs[0], sequence); 1548 for (i = 1, list = more_sequences; CONSP(list); list = CDR(list), i++) { 1549 item = CAR(list); 1550 SETSEQ(seqs[i], item); 1551 } 1552 1553 /* prepare argument list */ 1554 arguments = acons = CONS(NIL, NIL); 1555 GC_PROTECT(arguments); 1556 for (i = 1; i < count; i++) { 1557 RPLACD(acons, CONS(NIL, NIL)); 1558 acons = CDR(acons); 1559 } 1560 1561 /* loop applying predicate in sequence elements */ 1562 for (i = 0; i < length; i++) { 1563 1564 /* build argument list */ 1565 for (acons = arguments, j = 0; j < count; acons = CDR(acons), j++) { 1566 if (seqs[j].type == LispString_t) 1567 item = SCHAR(*seqs[j].data.string++); 1568 else { 1569 item = CAR(seqs[j].data.list); 1570 seqs[j].data.list = CDR(seqs[j].data.list); 1571 } 1572 RPLACA(acons, item); 1573 } 1574 1575 /* apply predicate */ 1576 value = APPLY(predicate, arguments); 1577 1578 /* check if needs to terminate loop */ 1579 if (value == NIL) { 1580 if (function == EVERY) { 1581 result = NIL; 1582 break; 1583 } 1584 if (function == NOTEVERY) { 1585 result = T; 1586 break; 1587 } 1588 } 1589 else { 1590 if (function == SOME) { 1591 result = value; 1592 break; 1593 } 1594 if (function == NOTANY) { 1595 result = NIL; 1596 break; 1597 } 1598 } 1599 } 1600 1601 GC_LEAVE(); 1602 if (seqs != &stk[0]) 1603 LispFree(seqs); 1604 1605 return (result); 1606 } 1607 1608 LispObj * 1609 Lisp_Every(LispBuiltin *builtin) 1610 /* 1611 every predicate sequence &rest more-sequences 1612 */ 1613 { 1614 return (LispEverySomeAnyNot(builtin, EVERY)); 1615 } 1616 1617 LispObj * 1618 Lisp_Some(LispBuiltin *builtin) 1619 /* 1620 some predicate sequence &rest more-sequences 1621 */ 1622 { 1623 return (LispEverySomeAnyNot(builtin, SOME)); 1624 } 1625 1626 LispObj * 1627 Lisp_Notevery(LispBuiltin *builtin) 1628 /* 1629 notevery predicate sequence &rest more-sequences 1630 */ 1631 { 1632 return (LispEverySomeAnyNot(builtin, NOTEVERY)); 1633 } 1634 1635 LispObj * 1636 Lisp_Notany(LispBuiltin *builtin) 1637 /* 1638 notany predicate sequence &rest more-sequences 1639 */ 1640 { 1641 return (LispEverySomeAnyNot(builtin, NOTANY)); 1642 } 1643 1644 LispObj * 1645 Lisp_Fboundp(LispBuiltin *builtin) 1646 /* 1647 fboundp symbol 1648 */ 1649 { 1650 LispAtom *atom; 1651 1652 LispObj *symbol = ARGUMENT(0); 1653 1654 CHECK_SYMBOL(symbol); 1655 1656 atom = symbol->data.atom; 1657 if (atom->a_function || atom->a_builtin || atom->a_compiled) 1658 return (T); 1659 1660 return (NIL); 1661 } 1662 1663 LispObj * 1664 Lisp_Find(LispBuiltin *builtin) 1665 /* 1666 find item sequence &key from-end test test-not start end key 1667 */ 1668 { 1669 return (LispFindOrPosition(builtin, FIND, NONE)); 1670 } 1671 1672 LispObj * 1673 Lisp_FindIf(LispBuiltin *builtin) 1674 /* 1675 find-if predicate sequence &key from-end start end key 1676 */ 1677 { 1678 return (LispFindOrPosition(builtin, FIND, IF)); 1679 } 1680 1681 LispObj * 1682 Lisp_FindIfNot(LispBuiltin *builtin) 1683 /* 1684 find-if-not predicate sequence &key from-end start end key 1685 */ 1686 { 1687 return (LispFindOrPosition(builtin, FIND, IFNOT)); 1688 } 1689 1690 LispObj * 1691 Lisp_Fill(LispBuiltin *builtin) 1692 /* 1693 fill sequence item &key start end 1694 */ 1695 { 1696 long i, start, end, length; 1697 1698 LispObj *sequence, *item, *ostart, *oend; 1699 1700 oend = ARGUMENT(3); 1701 ostart = ARGUMENT(2); 1702 item = ARGUMENT(1); 1703 sequence = ARGUMENT(0); 1704 1705 LispCheckSequenceStartEnd(builtin, sequence, ostart, oend, 1706 &start, &end, &length); 1707 1708 if (STRINGP(sequence)) { 1709 int ch; 1710 char *string = THESTR(sequence); 1711 1712 CHECK_STRING_WRITABLE(sequence); 1713 CHECK_SCHAR(item); 1714 ch = SCHAR_VALUE(item); 1715 for (i = start; i < end; i++) 1716 string[i] = ch; 1717 } 1718 else { 1719 LispObj *list; 1720 1721 if (CONSP(sequence)) 1722 list = sequence; 1723 else 1724 list = sequence->data.array.list; 1725 1726 for (i = 0; i < start; i++, list = CDR(list)) 1727 ; 1728 for (; i < end; i++, list = CDR(list)) 1729 RPLACA(list, item); 1730 } 1731 1732 return (sequence); 1733 } 1734 1735 LispObj * 1736 Lisp_Fmakunbound(LispBuiltin *builtin) 1737 /* 1738 fmkaunbound symbol 1739 */ 1740 { 1741 LispObj *symbol; 1742 1743 symbol = ARGUMENT(0); 1744 1745 CHECK_SYMBOL(symbol); 1746 if (symbol->data.atom->a_function) 1747 LispRemAtomFunctionProperty(symbol->data.atom); 1748 else if (symbol->data.atom->a_builtin) 1749 LispRemAtomBuiltinProperty(symbol->data.atom); 1750 else if (symbol->data.atom->a_compiled) 1751 LispRemAtomCompiledProperty(symbol->data.atom); 1752 1753 return (symbol); 1754 } 1755 1756 LispObj * 1757 Lisp_Funcall(LispBuiltin *builtin) 1758 /* 1759 funcall function &rest arguments 1760 */ 1761 { 1762 LispObj *result; 1763 1764 LispObj *function, *arguments; 1765 1766 arguments = ARGUMENT(1); 1767 function = ARGUMENT(0); 1768 1769 result = APPLY(function, arguments); 1770 1771 return (result); 1772 } 1773 1774 LispObj * 1775 Lisp_Functionp(LispBuiltin *builtin) 1776 /* 1777 functionp object 1778 */ 1779 { 1780 LispObj *object; 1781 1782 object = ARGUMENT(0); 1783 1784 return (FUNCTIONP(object) || LAMBDAP(object) ? T : NIL); 1785 } 1786 1787 LispObj * 1788 Lisp_Get(LispBuiltin *builtin) 1789 /* 1790 get symbol indicator &optional default 1791 */ 1792 { 1793 LispObj *result; 1794 1795 LispObj *symbol, *indicator, *defalt; 1796 1797 defalt = ARGUMENT(2); 1798 indicator = ARGUMENT(1); 1799 symbol = ARGUMENT(0); 1800 1801 CHECK_SYMBOL(symbol); 1802 1803 result = LispGetAtomProperty(symbol->data.atom, indicator); 1804 1805 if (result != NIL) 1806 result = CAR(result); 1807 else 1808 result = defalt == UNSPEC ? NIL : defalt; 1809 1810 return (result); 1811 } 1812 1813 /* 1814 * ext::getenv 1815 */ 1816 LispObj * 1817 Lisp_Getenv(LispBuiltin *builtin) 1818 /* 1819 getenv name 1820 */ 1821 { 1822 char *value; 1823 1824 LispObj *name; 1825 1826 name = ARGUMENT(0); 1827 1828 CHECK_STRING(name); 1829 value = getenv(THESTR(name)); 1830 1831 return (value ? STRING(value) : NIL); 1832 } 1833 1834 LispObj * 1835 Lisp_Gc(LispBuiltin *builtin) 1836 /* 1837 gc &optional car cdr 1838 */ 1839 { 1840 LispObj *car, *cdr; 1841 1842 cdr = ARGUMENT(1); 1843 car = ARGUMENT(0); 1844 1845 LispGC(car, cdr); 1846 1847 return (NIL); 1848 } 1849 1850 LispObj * 1851 Lisp_Gensym(LispBuiltin *builtin) 1852 /* 1853 gensym &optional arg 1854 */ 1855 { 1856 const char *preffix = "G"; 1857 char name[132]; 1858 long counter = LONGINT_VALUE(Ogensym_counter->data.atom->property->value); 1859 LispObj *symbol; 1860 1861 LispObj *arg; 1862 1863 arg = ARGUMENT(0); 1864 if (arg != UNSPEC) { 1865 if (STRINGP(arg)) 1866 preffix = THESTR(arg); 1867 else { 1868 CHECK_INDEX(arg); 1869 counter = FIXNUM_VALUE(arg); 1870 } 1871 } 1872 snprintf(name, sizeof(name), "%s%ld", preffix, counter); 1873 if (strlen(name) >= 128) 1874 LispDestroy("%s: name %s too long", STRFUN(builtin), name); 1875 Ogensym_counter->data.atom->property->value = INTEGER(counter + 1); 1876 1877 symbol = UNINTERNED_ATOM(name); 1878 symbol->data.atom->unreadable = !LispCheckAtomString(name); 1879 1880 return (symbol); 1881 } 1882 1883 LispObj * 1884 Lisp_Go(LispBuiltin *builtin) 1885 /* 1886 go tag 1887 */ 1888 { 1889 unsigned blevel = lisp__data.block.block_level; 1890 1891 LispObj *tag; 1892 1893 tag = ARGUMENT(0); 1894 1895 while (blevel) { 1896 LispBlock *block = lisp__data.block.block[--blevel]; 1897 1898 if (block->type == LispBlockClosure) 1899 /* if reached a function call */ 1900 break; 1901 if (block->type == LispBlockBody) { 1902 lisp__data.block.block_ret = tag; 1903 LispBlockUnwind(block); 1904 BLOCKJUMP(block); 1905 } 1906 } 1907 1908 LispDestroy("%s: no visible tagbody for %s", 1909 STRFUN(builtin), STROBJ(tag)); 1910 /*NOTREACHED*/ 1911 return (NIL); 1912 } 1913 1914 LispObj * 1915 Lisp_If(LispBuiltin *builtin) 1916 /* 1917 if test then &optional else 1918 */ 1919 { 1920 LispObj *result, *test, *then, *oelse; 1921 1922 oelse = ARGUMENT(2); 1923 then = ARGUMENT(1); 1924 test = ARGUMENT(0); 1925 1926 test = EVAL(test); 1927 if (test != NIL) 1928 result = EVAL(then); 1929 else if (oelse != UNSPEC) 1930 result = EVAL(oelse); 1931 else 1932 result = NIL; 1933 1934 return (result); 1935 } 1936 1937 LispObj * 1938 Lisp_IgnoreErrors(LispBuiltin *builtin) 1939 /* 1940 ignore-erros &rest body 1941 */ 1942 { 1943 LispObj *result; 1944 int i, jumped; 1945 LispBlock *block; 1946 1947 /* interpreter state */ 1948 GC_ENTER(); 1949 int stack, lex, length; 1950 1951 /* memory allocation */ 1952 int mem_level; 1953 void **mem; 1954 1955 LispObj *body; 1956 1957 body = ARGUMENT(0); 1958 1959 /* Save environment information */ 1960 stack = lisp__data.stack.length; 1961 lex = lisp__data.env.lex; 1962 length = lisp__data.env.length; 1963 1964 /* Save memory allocation information */ 1965 mem_level = lisp__data.mem.level; 1966 mem = LispMalloc(mem_level * sizeof(void*)); 1967 memcpy(mem, lisp__data.mem.mem, mem_level * sizeof(void*)); 1968 1969 ++lisp__data.ignore_errors; 1970 result = NIL; 1971 jumped = 1; 1972 block = LispBeginBlock(NIL, LispBlockProtect); 1973 if (setjmp(block->jmp) == 0) { 1974 for (; CONSP(body); body = CDR(body)) 1975 result = EVAL(CAR(body)); 1976 jumped = 0; 1977 } 1978 LispEndBlock(block); 1979 if (!lisp__data.destroyed && jumped) 1980 result = lisp__data.block.block_ret; 1981 1982 if (lisp__data.destroyed) { 1983 /* Restore environment */ 1984 lisp__data.stack.length = stack; 1985 lisp__data.env.lex = lex; 1986 lisp__data.env.head = lisp__data.env.length = length; 1987 GC_LEAVE(); 1988 1989 /* Check for possible leaks due to ignoring errors */ 1990 for (i = 0; i < mem_level; i++) { 1991 if (lisp__data.mem.mem[i] && mem[i] != lisp__data.mem.mem[i]) 1992 LispFree(lisp__data.mem.mem[i]); 1993 } 1994 for (; i < lisp__data.mem.level; i++) { 1995 if (lisp__data.mem.mem[i]) 1996 LispFree(lisp__data.mem.mem[i]); 1997 } 1998 1999 lisp__data.destroyed = 0; 2000 result = NIL; 2001 RETURN_COUNT = 1; 2002 RETURN(0) = lisp__data.error_condition; 2003 } 2004 LispFree(mem); 2005 --lisp__data.ignore_errors; 2006 2007 return (result); 2008 } 2009 2010 LispObj * 2011 Lisp_Intersection(LispBuiltin *builtin) 2012 /* 2013 intersection list1 list2 &key test test-not key 2014 */ 2015 { 2016 return (LispListSet(builtin, INTERSECTION)); 2017 } 2018 2019 LispObj * 2020 Lisp_Nintersection(LispBuiltin *builtin) 2021 /* 2022 nintersection list1 list2 &key test test-not key 2023 */ 2024 { 2025 return (LispListSet(builtin, NINTERSECTION)); 2026 } 2027 2028 LispObj * 2029 Lisp_Keywordp(LispBuiltin *builtin) 2030 /* 2031 keywordp object 2032 */ 2033 { 2034 LispObj *object; 2035 2036 object = ARGUMENT(0); 2037 2038 return (KEYWORDP(object) ? T : NIL); 2039 } 2040 2041 LispObj * 2042 Lisp_Lambda(LispBuiltin *builtin) 2043 /* 2044 lambda lambda-list &rest body 2045 */ 2046 { 2047 GC_ENTER(); 2048 LispObj *name; 2049 LispArgList *alist; 2050 2051 LispObj *lambda, *lambda_list, *body; 2052 2053 body = ARGUMENT(1); 2054 lambda_list = ARGUMENT(0); 2055 2056 alist = LispCheckArguments(LispLambda, lambda_list, Snil->value, 0); 2057 2058 name = OPAQUE(alist, LispArgList_t); 2059 lambda_list = LispListProtectedArguments(alist); 2060 GC_PROTECT(name); 2061 GC_PROTECT(lambda_list); 2062 lambda = LispNewLambda(name, body, lambda_list, LispLambda); 2063 LispUseArgList(alist); 2064 GC_LEAVE(); 2065 2066 return (lambda); 2067 } 2068 2069 LispObj * 2070 Lisp_Last(LispBuiltin *builtin) 2071 /* 2072 last list &optional count 2073 */ 2074 { 2075 long count, length; 2076 LispObj *list, *ocount; 2077 2078 ocount = ARGUMENT(1); 2079 list = ARGUMENT(0); 2080 2081 if (!CONSP(list)) 2082 return (list); 2083 2084 length = LispLength(list); 2085 2086 if (ocount == UNSPEC) 2087 count = 1; 2088 else { 2089 CHECK_INDEX(ocount); 2090 count = FIXNUM_VALUE(ocount); 2091 } 2092 2093 if (count >= length) 2094 return (list); 2095 2096 length -= count; 2097 for (; length > 0; length--) 2098 list = CDR(list); 2099 2100 return (list); 2101 } 2102 2103 LispObj * 2104 Lisp_Length(LispBuiltin *builtin) 2105 /* 2106 length sequence 2107 */ 2108 { 2109 LispObj *sequence; 2110 2111 sequence = ARGUMENT(0); 2112 2113 return (FIXNUM(LispLength(sequence))); 2114 } 2115 2116 LispObj * 2117 Lisp_Let(LispBuiltin *builtin) 2118 /* 2119 let init &rest body 2120 */ 2121 { 2122 GC_ENTER(); 2123 int head = lisp__data.env.length; 2124 LispObj *init, *body, *pair, *result, *list, *cons = NIL; 2125 2126 body = ARGUMENT(1); 2127 init = ARGUMENT(0); 2128 2129 CHECK_LIST(init); 2130 for (list = NIL; CONSP(init); init = CDR(init)) { 2131 LispObj *symbol, *value; 2132 2133 pair = CAR(init); 2134 if (SYMBOLP(pair)) { 2135 symbol = pair; 2136 value = NIL; 2137 } 2138 else { 2139 CHECK_CONS(pair); 2140 symbol = CAR(pair); 2141 CHECK_SYMBOL(symbol); 2142 pair = CDR(pair); 2143 if (CONSP(pair)) { 2144 value = CAR(pair); 2145 if (CDR(pair) != NIL) 2146 LispDestroy("%s: too much arguments to initialize %s", 2147 STRFUN(builtin), STROBJ(symbol)); 2148 value = EVAL(value); 2149 } 2150 else 2151 value = NIL; 2152 } 2153 pair = CONS(symbol, value); 2154 if (list == NIL) { 2155 list = cons = CONS(pair, NIL); 2156 GC_PROTECT(list); 2157 } 2158 else { 2159 RPLACD(cons, CONS(pair, NIL)); 2160 cons = CDR(cons); 2161 } 2162 } 2163 /* Add variables */ 2164 for (; CONSP(list); list = CDR(list)) { 2165 pair = CAR(list); 2166 CHECK_CONSTANT(CAR(pair)); 2167 LispAddVar(CAR(pair), CDR(pair)); 2168 ++lisp__data.env.head; 2169 } 2170 /* Values of symbols are now protected */ 2171 GC_LEAVE(); 2172 2173 /* execute body */ 2174 for (result = NIL; CONSP(body); body = CDR(body)) 2175 result = EVAL(CAR(body)); 2176 2177 lisp__data.env.head = lisp__data.env.length = head; 2178 2179 return (result); 2180 } 2181 2182 LispObj * 2183 Lisp_LetP(LispBuiltin *builtin) 2184 /* 2185 let* init &rest body 2186 */ 2187 { 2188 int head = lisp__data.env.length; 2189 LispObj *init, *body, *pair, *result; 2190 2191 body = ARGUMENT(1); 2192 init = ARGUMENT(0); 2193 2194 CHECK_LIST(init); 2195 for (; CONSP(init); init = CDR(init)) { 2196 LispObj *symbol, *value; 2197 2198 pair = CAR(init); 2199 if (SYMBOLP(pair)) { 2200 symbol = pair; 2201 value = NIL; 2202 } 2203 else { 2204 CHECK_CONS(pair); 2205 symbol = CAR(pair); 2206 CHECK_SYMBOL(symbol); 2207 pair = CDR(pair); 2208 if (CONSP(pair)) { 2209 value = CAR(pair); 2210 if (CDR(pair) != NIL) 2211 LispDestroy("%s: too much arguments to initialize %s", 2212 STRFUN(builtin), STROBJ(symbol)); 2213 value = EVAL(value); 2214 } 2215 else 2216 value = NIL; 2217 } 2218 2219 CHECK_CONSTANT(symbol); 2220 LispAddVar(symbol, value); 2221 ++lisp__data.env.head; 2222 } 2223 2224 /* execute body */ 2225 for (result = NIL; CONSP(body); body = CDR(body)) 2226 result = EVAL(CAR(body)); 2227 2228 lisp__data.env.head = lisp__data.env.length = head; 2229 2230 return (result); 2231 } 2232 2233 LispObj * 2234 Lisp_List(LispBuiltin *builtin) 2235 /* 2236 list &rest args 2237 */ 2238 { 2239 LispObj *args; 2240 2241 args = ARGUMENT(0); 2242 2243 return (args); 2244 } 2245 2246 LispObj * 2247 Lisp_ListP(LispBuiltin *builtin) 2248 /* 2249 list* object &rest more-objects 2250 */ 2251 { 2252 GC_ENTER(); 2253 LispObj *result, *cons; 2254 2255 LispObj *object, *more_objects; 2256 2257 more_objects = ARGUMENT(1); 2258 object = ARGUMENT(0); 2259 2260 if (!CONSP(more_objects)) 2261 return (object); 2262 2263 result = cons = CONS(object, CAR(more_objects)); 2264 GC_PROTECT(result); 2265 for (more_objects = CDR(more_objects); CONSP(more_objects); 2266 more_objects = CDR(more_objects)) { 2267 object = CAR(more_objects); 2268 RPLACD(cons, CONS(CDR(cons), object)); 2269 cons = CDR(cons); 2270 } 2271 GC_LEAVE(); 2272 2273 return (result); 2274 } 2275 2276 /* "classic" list-length */ 2277 LispObj * 2278 Lisp_ListLength(LispBuiltin *builtin) 2279 /* 2280 list-length list 2281 */ 2282 { 2283 long length; 2284 LispObj *fast, *slow; 2285 2286 LispObj *list; 2287 2288 list = ARGUMENT(0); 2289 2290 CHECK_LIST(list); 2291 for (fast = slow = list, length = 0; 2292 CONSP(slow); 2293 slow = CDR(slow), length += 2) { 2294 if (fast == NIL) 2295 break; 2296 CHECK_CONS(fast); 2297 fast = CDR(fast); 2298 if (fast == NIL) { 2299 ++length; 2300 break; 2301 } 2302 CHECK_CONS(fast); 2303 fast = CDR(fast); 2304 if (slow == fast) 2305 /* circular list */ 2306 return (NIL); 2307 } 2308 2309 return (FIXNUM(length)); 2310 } 2311 2312 LispObj * 2313 Lisp_Listp(LispBuiltin *builtin) 2314 /* 2315 listp object 2316 */ 2317 { 2318 LispObj *object; 2319 2320 object = ARGUMENT(0); 2321 2322 return (object == NIL || CONSP(object) ? T : NIL); 2323 } 2324 2325 static LispObj * 2326 LispListSet(LispBuiltin *builtin, int function) 2327 /* 2328 intersection list1 list2 &key test test-not key 2329 nintersection list1 list2 &key test test-not key 2330 set-difference list1 list2 &key test test-not key 2331 nset-difference list1 list2 &key test test-not key 2332 set-exclusive-or list1 list2 &key test test-not key 2333 nset-exclusive-or list1 list2 &key test test-not key 2334 subsetp list1 list2 &key test test-not key 2335 union list1 list2 &key test test-not key 2336 nunion list1 list2 &key test test-not key 2337 */ 2338 { 2339 GC_ENTER(); 2340 int code, expect, value, inplace, check_list2, 2341 intersection, setdifference, xunion, setexclusiveor; 2342 LispObj *lambda, *result, *cmp, *cmp1, *cmp2, 2343 *item, *clist1, *clist2, *cons, *cdr; 2344 2345 LispObj *list1, *list2, *test, *test_not, *key; 2346 2347 key = ARGUMENT(4); 2348 test_not = ARGUMENT(3); 2349 test = ARGUMENT(2); 2350 list2 = ARGUMENT(1); 2351 list1 = ARGUMENT(0); 2352 2353 /* Check if arguments are valid lists */ 2354 CHECK_LIST(list1); 2355 CHECK_LIST(list2); 2356 2357 setdifference = intersection = xunion = setexclusiveor = inplace = 0; 2358 switch (function) { 2359 case NSETDIFFERENCE: 2360 inplace = 1; 2361 case SETDIFFERENCE: 2362 setdifference = 1; 2363 break; 2364 case NINTERSECTION: 2365 inplace = 1; 2366 case INTERSECTION: 2367 intersection = 1; 2368 break; 2369 case NUNION: 2370 inplace = 1; 2371 case UNION: 2372 xunion = 1; 2373 break; 2374 case NSETEXCLUSIVEOR: 2375 inplace = 1; 2376 case SETEXCLUSIVEOR: 2377 setexclusiveor = 1; 2378 break; 2379 } 2380 2381 /* Check for fast return */ 2382 if (list1 == NIL) 2383 return (setdifference || intersection ? 2384 NIL : function == SUBSETP ? T : list2); 2385 if (list2 == NIL) 2386 return (intersection || xunion || function == SUBSETP ? NIL : list1); 2387 2388 CHECK_TEST(); 2389 clist1 = cdr = NIL; 2390 2391 /* Make a copy of list2 with the key predicate applied */ 2392 if (key != UNSPEC) { 2393 result = cons = CONS(APPLY1(key, CAR(list2)), NIL); 2394 GC_PROTECT(result); 2395 for (cmp2 = CDR(list2); CONSP(cmp2); cmp2 = CDR(cmp2)) { 2396 item = APPLY1(key, CAR(cmp2)); 2397 RPLACD(cons, CONS(APPLY1(key, CAR(cmp2)), NIL)); 2398 cons = CDR(cons); 2399 } 2400 /* check if list2 is a proper list */ 2401 CHECK_LIST(cmp2); 2402 clist2 = result; 2403 check_list2 = 0; 2404 } 2405 else { 2406 clist2 = list2; 2407 check_list2 = 1; 2408 } 2409 result = cons = NIL; 2410 2411 /* Compare elements of lists 2412 * Logic: 2413 * UNION 2414 * 1) Walk list1 and if CAR(list1) not in list2, add it to result 2415 * 2) Add list2 to result 2416 * INTERSECTION 2417 * 1) Walk list1 and if CAR(list1) in list2, add it to result 2418 * SET-DIFFERENCE 2419 * 1) Walk list1 and if CAR(list1) not in list2, add it to result 2420 * SET-EXCLUSIVE-OR 2421 * 1) Walk list1 and if CAR(list1) not in list2, add it to result 2422 * 2) Walk list2 and if CAR(list2) not in list1, add it to result 2423 * SUBSETP 2424 * 1) Walk list1 and if CAR(list1) not in list2, return NIL 2425 * 2) Return T 2426 */ 2427 value = 0; 2428 for (cmp1 = list1; CONSP(cmp1); cmp1 = CDR(cmp1)) { 2429 item = CAR(cmp1); 2430 2431 /* Apply key predicate if required */ 2432 if (key != UNSPEC) { 2433 cmp = APPLY1(key, item); 2434 if (setexclusiveor) { 2435 if (clist1 == NIL) { 2436 clist1 = cdr = CONS(cmp, NIL); 2437 GC_PROTECT(clist1); 2438 } 2439 else { 2440 RPLACD(cdr, CONS(cmp, NIL)); 2441 cdr = CDR(cdr); 2442 } 2443 } 2444 } 2445 else 2446 cmp = item; 2447 2448 /* Compare against list2 */ 2449 for (cmp2 = clist2; CONSP(cmp2); cmp2 = CDR(cmp2)) { 2450 value = FCOMPARE(lambda, cmp, CAR(cmp2), code); 2451 if (value == expect) 2452 break; 2453 } 2454 if (check_list2 && value != expect) { 2455 /* check if list2 is a proper list */ 2456 CHECK_LIST(cmp2); 2457 check_list2 = 0; 2458 } 2459 2460 if (function == SUBSETP) { 2461 /* Element of list1 not in list2? */ 2462 if (value != expect) { 2463 GC_LEAVE(); 2464 2465 return (NIL); 2466 } 2467 } 2468 /* If need to add item to result */ 2469 else if (((setdifference || xunion || setexclusiveor) && 2470 value != expect) || 2471 (intersection && value == expect)) { 2472 if (inplace) { 2473 if (result == NIL) 2474 result = cons = cmp1; 2475 else { 2476 if (setexclusiveor) { 2477 /* don't remove elements yet, will need 2478 * to check agains't list2 later */ 2479 for (cmp2 = cons; CDR(cmp2) != cmp1; cmp2 = CDR(cmp2)) 2480 ; 2481 if (cmp2 != cons) { 2482 RPLACD(cmp2, list1); 2483 list1 = cmp2; 2484 } 2485 } 2486 RPLACD(cons, cmp1); 2487 cons = cmp1; 2488 } 2489 } 2490 else { 2491 if (result == NIL) { 2492 result = cons = CONS(item, NIL); 2493 GC_PROTECT(result); 2494 } 2495 else { 2496 RPLACD(cons, CONS(item, NIL)); 2497 cons = CDR(cons); 2498 } 2499 } 2500 } 2501 } 2502 /* check if list1 is a proper list */ 2503 CHECK_LIST(cmp1); 2504 2505 if (function == SUBSETP) { 2506 GC_LEAVE(); 2507 2508 return (T); 2509 } 2510 else if (xunion) { 2511 /* Add list2 to tail of result */ 2512 if (result == NIL) 2513 result = list2; 2514 else 2515 RPLACD(cons, list2); 2516 } 2517 else if (setexclusiveor) { 2518 LispObj *result2, *cons2; 2519 2520 result2 = cons2 = NIL; 2521 for (cmp2 = list2; CONSP(cmp2); cmp2 = CDR(cmp2)) { 2522 item = CAR(cmp2); 2523 2524 if (key != UNSPEC) { 2525 cmp = CAR(clist2); 2526 /* XXX changing clist2 */ 2527 clist2 = CDR(clist2); 2528 cmp1 = clist1; 2529 } 2530 else { 2531 cmp = item; 2532 cmp1 = list1; 2533 } 2534 2535 /* Compare against list1 */ 2536 for (; CONSP(cmp1); cmp1 = CDR(cmp1)) { 2537 value = FCOMPARE(lambda, cmp, CAR(cmp1), code); 2538 if (value == expect) 2539 break; 2540 } 2541 2542 if (value != expect) { 2543 if (inplace) { 2544 if (result2 == NIL) 2545 result2 = cons2 = cmp2; 2546 else { 2547 RPLACD(cons2, cmp2); 2548 cons2 = cmp2; 2549 } 2550 } 2551 else { 2552 if (result == NIL) { 2553 result = cons = CONS(item, NIL); 2554 GC_PROTECT(result); 2555 } 2556 else { 2557 RPLACD(cons, CONS(item, NIL)); 2558 cons = CDR(cons); 2559 } 2560 } 2561 } 2562 } 2563 if (inplace) { 2564 if (CONSP(cons2)) 2565 RPLACD(cons2, NIL); 2566 if (result == NIL) 2567 result = result2; 2568 else 2569 RPLACD(cons, result2); 2570 } 2571 } 2572 else if ((function == NSETDIFFERENCE || function == NINTERSECTION) && 2573 CONSP(cons)) 2574 RPLACD(cons, NIL); 2575 2576 GC_LEAVE(); 2577 2578 return (result); 2579 } 2580 2581 LispObj * 2582 Lisp_Loop(LispBuiltin *builtin) 2583 /* 2584 loop &rest body 2585 */ 2586 { 2587 LispObj *code, *result; 2588 LispBlock *block; 2589 2590 LispObj *body; 2591 2592 body = ARGUMENT(0); 2593 2594 result = NIL; 2595 block = LispBeginBlock(NIL, LispBlockTag); 2596 if (setjmp(block->jmp) == 0) { 2597 for (;;) 2598 for (code = body; CONSP(code); code = CDR(code)) 2599 (void)EVAL(CAR(code)); 2600 } 2601 LispEndBlock(block); 2602 result = lisp__data.block.block_ret; 2603 2604 return (result); 2605 } 2606 2607 /* XXX This function is broken, needs a review 2608 (being delayed until true array/vectors be implemented) */ 2609 LispObj * 2610 Lisp_MakeArray(LispBuiltin *builtin) 2611 /* 2612 make-array dimensions &key element-type initial-element initial-contents 2613 adjustable fill-pointer displaced-to 2614 displaced-index-offset 2615 */ 2616 { 2617 long rank = 0, count = 1, offset, zero, c; 2618 LispObj *obj, *dim, *array; 2619 LispType type; 2620 2621 LispObj *dimensions, *element_type, *initial_element, *initial_contents, 2622 *displaced_to, *displaced_index_offset; 2623 2624 dim = array = NIL; 2625 type = LispNil_t; 2626 2627 displaced_index_offset = ARGUMENT(7); 2628 displaced_to = ARGUMENT(6); 2629 initial_contents = ARGUMENT(3); 2630 initial_element = ARGUMENT(2); 2631 element_type = ARGUMENT(1); 2632 dimensions = ARGUMENT(0); 2633 2634 if (INDEXP(dimensions)) { 2635 dim = CONS(dimensions, NIL); 2636 rank = 1; 2637 count = FIXNUM_VALUE(dimensions); 2638 } 2639 else if (CONSP(dimensions)) { 2640 dim = dimensions; 2641 2642 for (rank = 0; CONSP(dim); rank++, dim = CDR(dim)) { 2643 obj = CAR(dim); 2644 CHECK_INDEX(obj); 2645 count *= FIXNUM_VALUE(obj); 2646 } 2647 dim = dimensions; 2648 } 2649 else if (dimensions == NIL) { 2650 dim = NIL; 2651 rank = count = 0; 2652 } 2653 else 2654 LispDestroy("%s: %s is a bad array dimension", 2655 STRFUN(builtin), STROBJ(dimensions)); 2656 2657 /* check element-type */ 2658 if (element_type != UNSPEC) { 2659 if (element_type == T) 2660 type = LispNil_t; 2661 else if (!SYMBOLP(element_type)) 2662 LispDestroy("%s: unsupported element type %s", 2663 STRFUN(builtin), STROBJ(element_type)); 2664 else { 2665 Atom_id atom = ATOMID(element_type); 2666 2667 if (atom == Satom) 2668 type = LispAtom_t; 2669 else if (atom == Sinteger) 2670 type = LispInteger_t; 2671 else if (atom == Scharacter) 2672 type = LispSChar_t; 2673 else if (atom == Sstring) 2674 type = LispString_t; 2675 else if (atom == Slist) 2676 type = LispCons_t; 2677 else if (atom == Sopaque) 2678 type = LispOpaque_t; 2679 else 2680 LispDestroy("%s: unsupported element type %s", 2681 STRFUN(builtin), ATOMID(element_type)->value); 2682 } 2683 } 2684 2685 /* check initial-contents */ 2686 if (rank) { 2687 CHECK_LIST(initial_contents); 2688 } 2689 2690 /* check displaced-to */ 2691 if (displaced_to != UNSPEC) { 2692 CHECK_ARRAY(displaced_to); 2693 } 2694 2695 /* check displaced-index-offset */ 2696 offset = -1; 2697 if (displaced_index_offset != UNSPEC) { 2698 CHECK_INDEX(displaced_index_offset); 2699 offset = FIXNUM_VALUE(displaced_index_offset); 2700 } 2701 2702 c = 0; 2703 if (initial_element != UNSPEC) 2704 ++c; 2705 if (initial_contents != UNSPEC) 2706 ++c; 2707 if (displaced_to != UNSPEC || offset >= 0) 2708 ++c; 2709 if (c > 1) 2710 LispDestroy("%s: more than one initialization specified", 2711 STRFUN(builtin)); 2712 if (initial_element == UNSPEC) 2713 initial_element = NIL; 2714 2715 zero = count == 0; 2716 if (displaced_to != UNSPEC) { 2717 CHECK_ARRAY(displaced_to); 2718 if (offset < 0) 2719 offset = 0; 2720 for (c = 1, obj = displaced_to->data.array.dim; obj != NIL; 2721 obj = CDR(obj)) 2722 c *= FIXNUM_VALUE(CAR(obj)); 2723 if (c < count + offset) 2724 LispDestroy("%s: array-total-size + displaced-index-offset " 2725 "exceeds total size", STRFUN(builtin)); 2726 for (c = 0, array = displaced_to->data.array.list; c < offset; c++) 2727 array = CDR(array); 2728 } 2729 else if (initial_contents != UNSPEC) { 2730 CHECK_CONS(initial_contents); 2731 if (rank == 0) 2732 array = initial_contents; 2733 else if (rank == 1) { 2734 for (array = initial_contents, c = 0; c < count; 2735 array = CDR(array), c++) 2736 if (!CONSP(array)) 2737 LispDestroy("%s: bad argument or size %s", 2738 STRFUN(builtin), STROBJ(array)); 2739 if (array != NIL) 2740 LispDestroy("%s: bad argument or size %s", 2741 STRFUN(builtin), STROBJ(array)); 2742 array = initial_contents; 2743 } 2744 else { 2745 LispObj *err = NIL; 2746 /* check if list matches */ 2747 int i, j, k, *dims, *loop; 2748 2749 /* create iteration variables */ 2750 dims = LispMalloc(sizeof(int) * rank); 2751 loop = LispCalloc(1, sizeof(int) * (rank - 1)); 2752 for (i = 0, obj = dim; CONSP(obj); i++, obj = CDR(obj)) 2753 dims[i] = FIXNUM_VALUE(CAR(obj)); 2754 2755 /* check if list matches specified dimensions */ 2756 while (loop[0] < dims[0]) { 2757 for (obj = initial_contents, i = 0; i < rank - 1; i++) { 2758 for (j = 0; j < loop[i]; j++) 2759 obj = CDR(obj); 2760 err = obj; 2761 if (!CONSP(obj = CAR(obj))) 2762 goto make_array_error; 2763 err = obj; 2764 } 2765 --i; 2766 for (;;) { 2767 ++loop[i]; 2768 if (i && loop[i] >= dims[i]) 2769 loop[i] = 0; 2770 else 2771 break; 2772 --i; 2773 } 2774 for (k = 0; k < dims[rank - 1]; obj = CDR(obj), k++) { 2775 if (!CONSP(obj)) 2776 goto make_array_error; 2777 } 2778 if (obj == NIL) 2779 continue; 2780 make_array_error: 2781 LispFree(dims); 2782 LispFree(loop); 2783 LispDestroy("%s: bad argument or size %s", 2784 STRFUN(builtin), STROBJ(err)); 2785 } 2786 2787 /* list is correct, use it to fill initial values */ 2788 2789 /* reset loop */ 2790 memset(loop, 0, sizeof(int) * (rank - 1)); 2791 2792 GCDisable(); 2793 /* fill array with supplied values */ 2794 array = NIL; 2795 while (loop[0] < dims[0]) { 2796 for (obj = initial_contents, i = 0; i < rank - 1; i++) { 2797 for (j = 0; j < loop[i]; j++) 2798 obj = CDR(obj); 2799 obj = CAR(obj); 2800 } 2801 --i; 2802 for (;;) { 2803 ++loop[i]; 2804 if (i && loop[i] >= dims[i]) 2805 loop[i] = 0; 2806 else 2807 break; 2808 --i; 2809 } 2810 for (k = 0; k < dims[rank - 1]; obj = CDR(obj), k++) { 2811 if (array == NIL) 2812 array = CONS(CAR(obj), NIL); 2813 else { 2814 RPLACD(array, CONS(CAR(array), CDR(array))); 2815 RPLACA(array, CAR(obj)); 2816 } 2817 } 2818 } 2819 LispFree(dims); 2820 LispFree(loop); 2821 array = LispReverse(array); 2822 GCEnable(); 2823 } 2824 } 2825 else { 2826 GCDisable(); 2827 /* allocate array */ 2828 if (count) { 2829 --count; 2830 array = CONS(initial_element, NIL); 2831 while (count) { 2832 RPLACD(array, CONS(CAR(array), CDR(array))); 2833 RPLACA(array, initial_element); 2834 count--; 2835 } 2836 } 2837 GCEnable(); 2838 } 2839 2840 obj = LispNew(array, dim); 2841 obj->type = LispArray_t; 2842 obj->data.array.list = array; 2843 obj->data.array.dim = dim; 2844 obj->data.array.rank = rank; 2845 obj->data.array.type = type; 2846 obj->data.array.zero = zero; 2847 2848 return (obj); 2849 } 2850 2851 LispObj * 2852 Lisp_MakeList(LispBuiltin *builtin) 2853 /* 2854 make-list size &key initial-element 2855 */ 2856 { 2857 GC_ENTER(); 2858 long count; 2859 LispObj *result, *cons; 2860 2861 LispObj *size, *initial_element; 2862 2863 initial_element = ARGUMENT(1); 2864 size = ARGUMENT(0); 2865 2866 CHECK_INDEX(size); 2867 count = FIXNUM_VALUE(size); 2868 2869 if (count == 0) 2870 return (NIL); 2871 if (initial_element == UNSPEC) 2872 initial_element = NIL; 2873 2874 result = cons = CONS(initial_element, NIL); 2875 GC_PROTECT(result); 2876 for (; count > 1; count--) { 2877 RPLACD(cons, CONS(initial_element, NIL)); 2878 cons = CDR(cons); 2879 } 2880 GC_LEAVE(); 2881 2882 return (result); 2883 } 2884 2885 LispObj * 2886 Lisp_MakeSymbol(LispBuiltin *builtin) 2887 /* 2888 make-symbol name 2889 */ 2890 { 2891 LispObj *name, *symbol; 2892 2893 name = ARGUMENT(0); 2894 CHECK_STRING(name); 2895 2896 symbol = UNINTERNED_ATOM(THESTR(name)); 2897 symbol->data.atom->unreadable = !LispCheckAtomString(THESTR(name)); 2898 2899 return (symbol); 2900 } 2901 2902 LispObj * 2903 Lisp_Makunbound(LispBuiltin *builtin) 2904 /* 2905 makunbound symbol 2906 */ 2907 { 2908 LispObj *symbol; 2909 2910 symbol = ARGUMENT(0); 2911 2912 CHECK_SYMBOL(symbol); 2913 LispUnsetVar(symbol); 2914 2915 return (symbol); 2916 } 2917 2918 LispObj * 2919 Lisp_Mapc(LispBuiltin *builtin) 2920 /* 2921 mapc function list &rest more-lists 2922 */ 2923 { 2924 return (LispMapc(builtin, 0)); 2925 } 2926 2927 LispObj * 2928 Lisp_Mapcar(LispBuiltin *builtin) 2929 /* 2930 mapcar function list &rest more-lists 2931 */ 2932 { 2933 return (LispMapc(builtin, 1)); 2934 } 2935 2936 /* Like nconc but ignore non list arguments */ 2937 LispObj * 2938 LispMapnconc(LispObj *list) 2939 { 2940 LispObj *result = NIL; 2941 2942 if (CONSP(list)) { 2943 LispObj *cons, *head, *tail; 2944 2945 cons = NIL; 2946 for (; CONSP(CDR(list)); list = CDR(list)) { 2947 head = CAR(list); 2948 if (CONSP(head)) { 2949 for (tail = head; CONSP(CDR(tail)); tail = CDR(tail)) 2950 ; 2951 if (cons != NIL) 2952 RPLACD(cons, head); 2953 else 2954 result = head; 2955 cons = tail; 2956 } 2957 } 2958 head = CAR(list); 2959 if (CONSP(head)) { 2960 if (cons != NIL) 2961 RPLACD(cons, head); 2962 else 2963 result = head; 2964 } 2965 } 2966 2967 return (result); 2968 } 2969 2970 LispObj * 2971 Lisp_Mapcan(LispBuiltin *builtin) 2972 /* 2973 mapcan function list &rest more-lists 2974 */ 2975 { 2976 return (LispMapnconc(LispMapc(builtin, 1))); 2977 } 2978 2979 static LispObj * 2980 LispMapc(LispBuiltin *builtin, int mapcar) 2981 { 2982 GC_ENTER(); 2983 long i, offset, count, length; 2984 LispObj *result = NIL, *cons, *arguments, *acons, *rest, *alist, *value; 2985 LispObj *stk[8], **cdrs; 2986 2987 LispObj *function, *list, *more_lists; 2988 2989 more_lists = ARGUMENT(2); 2990 list = ARGUMENT(1); 2991 function = ARGUMENT(0); 2992 2993 /* Result will be no longer than this */ 2994 for (length = 0, alist = list; CONSP(alist); length++, alist = CDR(alist)) 2995 ; 2996 2997 /* If first argument is not a list... */ 2998 if (length == 0) 2999 return (NIL); 3000 3001 /* At least one argument will be passed to function, count how many 3002 * extra arguments will be used, and calculate result length. */ 3003 count = 0; 3004 for (rest = more_lists; CONSP(rest); rest = CDR(rest), count++) { 3005 3006 /* Check if extra list is really a list, and if it is smaller 3007 * than the first list */ 3008 for (i = 0, alist = CAR(rest); 3009 i < length && CONSP(alist); 3010 i++, alist = CDR(alist)) 3011 ; 3012 3013 /* If it is not a true list */ 3014 if (i == 0) 3015 return (NIL); 3016 3017 /* If it is smaller than the currently calculated result length */ 3018 if (i < length) 3019 length = i; 3020 } 3021 3022 if (mapcar) { 3023 /* Initialize gc protected object cells for resulting list */ 3024 result = cons = CONS(NIL, NIL); 3025 GC_PROTECT(result); 3026 } 3027 else 3028 result = cons = list; 3029 3030 if (count >= sizeof(stk) / sizeof(stk[0])) 3031 cdrs = LispMalloc(count * sizeof(LispObj*)); 3032 else 3033 cdrs = &stk[0]; 3034 for (i = 0, rest = more_lists; i < count; i++, rest = CDR(rest)) 3035 cdrs[i] = CAR(rest); 3036 3037 /* Initialize gc protected object cells for argument list */ 3038 arguments = acons = CONS(NIL, NIL); 3039 GC_PROTECT(arguments); 3040 3041 /* Allocate space for extra arguments */ 3042 for (i = 0; i < count; i++) { 3043 RPLACD(acons, CONS(NIL, NIL)); 3044 acons = CDR(acons); 3045 } 3046 3047 /* For every element of the list that will be used */ 3048 for (offset = 0;; list = CDR(list)) { 3049 acons = arguments; 3050 3051 /* Add first argument */ 3052 RPLACA(acons, CAR(list)); 3053 acons = CDR(acons); 3054 3055 /* For every extra list argument */ 3056 for (i = 0; i < count; i++) { 3057 alist = cdrs[i]; 3058 cdrs[i] = CDR(cdrs[i]); 3059 3060 /* Add element to argument list */ 3061 RPLACA(acons, CAR(alist)); 3062 acons = CDR(acons); 3063 } 3064 3065 value = APPLY(function, arguments); 3066 3067 if (mapcar) { 3068 /* Store result */ 3069 RPLACA(cons, value); 3070 3071 /* Allocate new result cell */ 3072 if (++offset < length) { 3073 RPLACD(cons, CONS(NIL, NIL)); 3074 cons = CDR(cons); 3075 } 3076 else 3077 break; 3078 } 3079 else if (++offset >= length) 3080 break; 3081 } 3082 3083 /* Unprotect argument and result list */ 3084 GC_LEAVE(); 3085 if (cdrs != &stk[0]) 3086 LispFree(cdrs); 3087 3088 return (result); 3089 } 3090 3091 static LispObj * 3092 LispMapl(LispBuiltin *builtin, int maplist) 3093 { 3094 GC_ENTER(); 3095 long i, offset, count, length; 3096 LispObj *result = NIL, *cons, *arguments, *acons, *rest, *alist, *value; 3097 LispObj *stk[8], **cdrs; 3098 3099 LispObj *function, *list, *more_lists; 3100 3101 more_lists = ARGUMENT(2); 3102 list = ARGUMENT(1); 3103 function = ARGUMENT(0); 3104 3105 /* count is the number of lists, length is the length of the result */ 3106 for (length = 0, alist = list; CONSP(alist); length++, alist = CDR(alist)) 3107 ; 3108 3109 /* first argument is not a list */ 3110 if (length == 0) 3111 return (NIL); 3112 3113 /* check remaining arguments */ 3114 for (count = 0, rest = more_lists; CONSP(rest); rest = CDR(rest), count++) { 3115 for (i = 0, alist = CAR(rest); 3116 i < length && CONSP(alist); 3117 i++, alist = CDR(alist)) 3118 ; 3119 /* argument is not a list */ 3120 if (i == 0) 3121 return (NIL); 3122 /* result will have the length of the smallest list */ 3123 if (i < length) 3124 length = i; 3125 } 3126 3127 /* result will be a list */ 3128 if (maplist) { 3129 result = cons = CONS(NIL, NIL); 3130 GC_PROTECT(result); 3131 } 3132 else 3133 result = cons = list; 3134 3135 if (count >= sizeof(stk) / sizeof(stk[0])) 3136 cdrs = LispMalloc(count * sizeof(LispObj*)); 3137 else 3138 cdrs = &stk[0]; 3139 for (i = 0, rest = more_lists; i < count; i++, rest = CDR(rest)) 3140 cdrs[i] = CAR(rest); 3141 3142 /* initialize argument list */ 3143 arguments = acons = CONS(NIL, NIL); 3144 GC_PROTECT(arguments); 3145 for (i = 0; i < count; i++) { 3146 RPLACD(acons, CONS(NIL, NIL)); 3147 acons = CDR(acons); 3148 } 3149 3150 /* for every used list element */ 3151 for (offset = 0;; list = CDR(list)) { 3152 acons = arguments; 3153 3154 /* first argument */ 3155 RPLACA(acons, list); 3156 acons = CDR(acons); 3157 3158 /* for every extra list */ 3159 for (i = 0; i < count; i++) { 3160 RPLACA(acons, cdrs[i]); 3161 cdrs[i] = CDR(cdrs[i]); 3162 acons = CDR(acons); 3163 } 3164 3165 value = APPLY(function, arguments); 3166 3167 if (maplist) { 3168 /* store result */ 3169 RPLACA(cons, value); 3170 3171 /* allocate new cell */ 3172 if (++offset < length) { 3173 RPLACD(cons, CONS(NIL, NIL)); 3174 cons = CDR(cons); 3175 } 3176 else 3177 break; 3178 } 3179 else if (++offset >= length) 3180 break; 3181 } 3182 3183 GC_LEAVE(); 3184 if (cdrs != &stk[0]) 3185 LispFree(cdrs); 3186 3187 return (result); 3188 } 3189 3190 LispObj * 3191 Lisp_Mapl(LispBuiltin *builtin) 3192 /* 3193 mapl function list &rest more-lists 3194 */ 3195 { 3196 return (LispMapl(builtin, 0)); 3197 } 3198 3199 LispObj * 3200 Lisp_Maplist(LispBuiltin *builtin) 3201 /* 3202 maplist function list &rest more-lists 3203 */ 3204 { 3205 return (LispMapl(builtin, 1)); 3206 } 3207 3208 LispObj * 3209 Lisp_Mapcon(LispBuiltin *builtin) 3210 /* 3211 mapcon function list &rest more-lists 3212 */ 3213 { 3214 return (LispMapnconc(LispMapl(builtin, 1))); 3215 } 3216 3217 LispObj * 3218 Lisp_Member(LispBuiltin *builtin) 3219 /* 3220 member item list &key test test-not key 3221 */ 3222 { 3223 int code, expect; 3224 LispObj *compare, *lambda; 3225 LispObj *item, *list, *test, *test_not, *key; 3226 3227 key = ARGUMENT(4); 3228 test_not = ARGUMENT(3); 3229 test = ARGUMENT(2); 3230 list = ARGUMENT(1); 3231 item = ARGUMENT(0); 3232 3233 if (list == NIL) 3234 return (NIL); 3235 CHECK_CONS(list); 3236 3237 CHECK_TEST(); 3238 if (key == UNSPEC) { 3239 if (code == FEQ) { 3240 for (; CONSP(list); list = CDR(list)) 3241 if (item == CAR(list)) 3242 return (list); 3243 } 3244 else { 3245 for (; CONSP(list); list = CDR(list)) 3246 if ((FCOMPARE(lambda, item, CAR(list), code)) == expect) 3247 return (list); 3248 } 3249 } 3250 else { 3251 if (code == FEQ) { 3252 for (; CONSP(list); list = CDR(list)) 3253 if (item == APPLY1(key, CAR(list))) 3254 return (list); 3255 } 3256 else { 3257 for (; CONSP(list); list = CDR(list)) { 3258 compare = APPLY1(key, CAR(list)); 3259 if ((FCOMPARE(lambda, item, compare, code)) == expect) 3260 return (list); 3261 } 3262 } 3263 } 3264 /* check if is a proper list */ 3265 CHECK_LIST(list); 3266 3267 return (NIL); 3268 } 3269 3270 LispObj * 3271 Lisp_MemberIf(LispBuiltin *builtin) 3272 /* 3273 member-if predicate list &key key 3274 */ 3275 { 3276 return (LispAssocOrMember(builtin, MEMBER, IF)); 3277 } 3278 3279 LispObj * 3280 Lisp_MemberIfNot(LispBuiltin *builtin) 3281 /* 3282 member-if-not predicate list &key key 3283 */ 3284 { 3285 return (LispAssocOrMember(builtin, MEMBER, IFNOT)); 3286 } 3287 3288 LispObj * 3289 Lisp_MultipleValueBind(LispBuiltin *builtin) 3290 /* 3291 multiple-value-bind symbols values &rest body 3292 */ 3293 { 3294 int i, head = lisp__data.env.length; 3295 LispObj *result, *symbol, *value; 3296 3297 LispObj *symbols, *values, *body; 3298 3299 body = ARGUMENT(2); 3300 values = ARGUMENT(1); 3301 symbols = ARGUMENT(0); 3302 3303 result = EVAL(values); 3304 for (i = -1; CONSP(symbols); symbols = CDR(symbols), i++) { 3305 symbol = CAR(symbols); 3306 CHECK_SYMBOL(symbol); 3307 CHECK_CONSTANT(symbol); 3308 if (i >= 0 && i < RETURN_COUNT) 3309 value = RETURN(i); 3310 else if (i < 0) 3311 value = result; 3312 else 3313 value = NIL; 3314 LispAddVar(symbol, value); 3315 ++lisp__data.env.head; 3316 } 3317 3318 /* Execute code with binded variables (if any) */ 3319 for (result = NIL; CONSP(body); body = CDR(body)) 3320 result = EVAL(CAR(body)); 3321 3322 lisp__data.env.head = lisp__data.env.length = head; 3323 3324 return (result); 3325 } 3326 3327 LispObj * 3328 Lisp_MultipleValueCall(LispBuiltin *builtin) 3329 /* 3330 multiple-value-call function &rest form 3331 */ 3332 { 3333 GC_ENTER(); 3334 int i; 3335 LispObj *arguments, *cons, *result; 3336 3337 LispObj *function, *form; 3338 3339 form = ARGUMENT(1); 3340 function = ARGUMENT(0); 3341 3342 /* build argument list */ 3343 arguments = cons = NIL; 3344 for (; CONSP(form); form = CDR(form)) { 3345 RETURN_COUNT = 0; 3346 result = EVAL(CAR(form)); 3347 if (RETURN_COUNT >= 0) { 3348 if (arguments == NIL) { 3349 arguments = cons = CONS(result, NIL); 3350 GC_PROTECT(arguments); 3351 } 3352 else { 3353 RPLACD(cons, CONS(result, NIL)); 3354 cons = CDR(cons); 3355 } 3356 for (i = 0; i < RETURN_COUNT; i++) { 3357 RPLACD(cons, CONS(RETURN(i), NIL)); 3358 cons = CDR(cons); 3359 } 3360 } 3361 } 3362 3363 /* apply function */ 3364 if (POINTERP(function) && !XSYMBOLP(function) && !XFUNCTIONP(function)) { 3365 function = EVAL(function); 3366 GC_PROTECT(function); 3367 } 3368 result = APPLY(function, arguments); 3369 GC_LEAVE(); 3370 3371 return (result); 3372 } 3373 3374 LispObj * 3375 Lisp_MultipleValueProg1(LispBuiltin *builtin) 3376 /* 3377 multiple-value-prog1 first-form &rest form 3378 */ 3379 { 3380 GC_ENTER(); 3381 int i, count; 3382 LispObj *values, *cons; 3383 3384 LispObj *first_form, *form; 3385 3386 form = ARGUMENT(1); 3387 first_form = ARGUMENT(0); 3388 3389 values = EVAL(first_form); 3390 if (!CONSP(form)) 3391 return (values); 3392 3393 cons = NIL; 3394 count = RETURN_COUNT; 3395 if (count < 0) 3396 values = NIL; 3397 else if (count == 0) { 3398 GC_PROTECT(values); 3399 } 3400 else { 3401 values = cons = CONS(values, NIL); 3402 GC_PROTECT(values); 3403 for (i = 0; i < count; i++) { 3404 RPLACD(cons, CONS(RETURN(i), NIL)); 3405 cons = CDR(cons); 3406 } 3407 } 3408 3409 for (; CONSP(form); form = CDR(form)) 3410 EVAL(CAR(form)); 3411 3412 RETURN_COUNT = count; 3413 if (count > 0) { 3414 for (i = 0, cons = CDR(values); CONSP(cons); cons = CDR(cons), i++) 3415 RETURN(i) = CAR(cons); 3416 values = CAR(values); 3417 } 3418 GC_LEAVE(); 3419 3420 return (values); 3421 } 3422 3423 LispObj * 3424 Lisp_MultipleValueList(LispBuiltin *builtin) 3425 /* 3426 multiple-value-list form 3427 */ 3428 { 3429 int i; 3430 GC_ENTER(); 3431 LispObj *form, *result, *cons; 3432 3433 form = ARGUMENT(0); 3434 3435 result = EVAL(form); 3436 3437 if (RETURN_COUNT < 0) 3438 return (NIL); 3439 3440 result = cons = CONS(result, NIL); 3441 GC_PROTECT(result); 3442 for (i = 0; i < RETURN_COUNT; i++) { 3443 RPLACD(cons, CONS(RETURN(i), NIL)); 3444 cons = CDR(cons); 3445 } 3446 GC_LEAVE(); 3447 3448 return (result); 3449 } 3450 3451 LispObj * 3452 Lisp_MultipleValueSetq(LispBuiltin *builtin) 3453 /* 3454 multiple-value-setq symbols form 3455 */ 3456 { 3457 int i; 3458 LispObj *result, *symbol, *value; 3459 3460 LispObj *symbols, *form; 3461 3462 form = ARGUMENT(1); 3463 symbols = ARGUMENT(0); 3464 3465 CHECK_LIST(symbols); 3466 result = EVAL(form); 3467 if (CONSP(symbols)) { 3468 symbol = CAR(symbols); 3469 CHECK_SYMBOL(symbol); 3470 CHECK_CONSTANT(symbol); 3471 LispSetVar(symbol, result); 3472 symbols = CDR(symbols); 3473 } 3474 for (i = 0; CONSP(symbols); symbols = CDR(symbols), i++) { 3475 symbol = CAR(symbols); 3476 CHECK_SYMBOL(symbol); 3477 CHECK_CONSTANT(symbol); 3478 if (i < RETURN_COUNT && RETURN_COUNT > 0) 3479 value = RETURN(i); 3480 else 3481 value = NIL; 3482 LispSetVar(symbol, value); 3483 } 3484 3485 return (result); 3486 } 3487 3488 LispObj * 3489 Lisp_Nconc(LispBuiltin *builtin) 3490 /* 3491 nconc &rest lists 3492 */ 3493 { 3494 LispObj *list, *lists, *cons, *head, *tail; 3495 3496 lists = ARGUMENT(0); 3497 3498 /* skip any initial empty lists */ 3499 for (; CONSP(lists); lists = CDR(lists)) 3500 if (CAR(lists) != NIL) 3501 break; 3502 3503 /* don't check if a proper list */ 3504 if (!CONSP(lists)) 3505 return (lists); 3506 3507 /* setup to concatenate lists */ 3508 list = CAR(lists); 3509 CHECK_CONS(list); 3510 for (cons = list; CONSP(CDR(cons)); cons = CDR(cons)) 3511 ; 3512 3513 /* if only two lists */ 3514 lists = CDR(lists); 3515 if (!CONSP(lists)) { 3516 RPLACD(cons, lists); 3517 3518 return (list); 3519 } 3520 3521 /* concatenate */ 3522 for (; CONSP(CDR(lists)); lists = CDR(lists)) { 3523 head = CAR(lists); 3524 if (head == NIL) 3525 continue; 3526 CHECK_CONS(head); 3527 for (tail = head; CONSP(CDR(tail)); tail = CDR(tail)) 3528 ; 3529 RPLACD(cons, head); 3530 cons = tail; 3531 } 3532 /* add last list */ 3533 RPLACD(cons, CAR(lists)); 3534 3535 return (list); 3536 } 3537 3538 LispObj * 3539 Lisp_Nreverse(LispBuiltin *builtin) 3540 /* 3541 nreverse sequence 3542 */ 3543 { 3544 return (LispXReverse(builtin, 1)); 3545 } 3546 3547 LispObj * 3548 Lisp_NsetDifference(LispBuiltin *builtin) 3549 /* 3550 nset-difference list1 list2 &key test test-not key 3551 */ 3552 { 3553 return (LispListSet(builtin, NSETDIFFERENCE)); 3554 } 3555 3556 LispObj * 3557 Lisp_Nsubstitute(LispBuiltin *builtin) 3558 /* 3559 nsubstitute newitem olditem sequence &key from-end test test-not start end count key 3560 */ 3561 { 3562 return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, NONE)); 3563 } 3564 3565 LispObj * 3566 Lisp_NsubstituteIf(LispBuiltin *builtin) 3567 /* 3568 nsubstitute-if newitem test sequence &key from-end start end count key 3569 */ 3570 { 3571 return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, IF)); 3572 } 3573 3574 LispObj * 3575 Lisp_NsubstituteIfNot(LispBuiltin *builtin) 3576 /* 3577 nsubstitute-if-not newitem test sequence &key from-end start end count key 3578 */ 3579 { 3580 return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, IFNOT)); 3581 } 3582 3583 LispObj * 3584 Lisp_Nth(LispBuiltin *builtin) 3585 /* 3586 nth index list 3587 */ 3588 { 3589 long position; 3590 LispObj *oindex, *list; 3591 3592 list = ARGUMENT(1); 3593 oindex = ARGUMENT(0); 3594 3595 CHECK_INDEX(oindex); 3596 position = FIXNUM_VALUE(oindex); 3597 3598 if (list == NIL) 3599 return (NIL); 3600 3601 CHECK_CONS(list); 3602 for (; position > 0; position--) { 3603 if (!CONSP(list)) 3604 return (NIL); 3605 list = CDR(list); 3606 } 3607 3608 return (CONSP(list) ? CAR(list) : NIL); 3609 } 3610 3611 LispObj * 3612 Lisp_Nthcdr(LispBuiltin *builtin) 3613 /* 3614 nthcdr index list 3615 */ 3616 { 3617 long position; 3618 LispObj *oindex, *list; 3619 3620 list = ARGUMENT(1); 3621 oindex = ARGUMENT(0); 3622 3623 CHECK_INDEX(oindex); 3624 position = FIXNUM_VALUE(oindex); 3625 3626 if (list == NIL) 3627 return (NIL); 3628 CHECK_CONS(list); 3629 3630 for (; position > 0; position--) { 3631 if (!CONSP(list)) 3632 return (NIL); 3633 list = CDR(list); 3634 } 3635 3636 return (list); 3637 } 3638 3639 LispObj * 3640 Lisp_NthValue(LispBuiltin *builtin) 3641 /* 3642 nth-value index form 3643 */ 3644 { 3645 long i; 3646 LispObj *oindex, *form, *result; 3647 3648 form = ARGUMENT(1); 3649 oindex = ARGUMENT(0); 3650 3651 oindex = EVAL(oindex); 3652 CHECK_INDEX(oindex); 3653 i = FIXNUM_VALUE(oindex) - 1; 3654 3655 result = EVAL(form); 3656 if (RETURN_COUNT < 0 || i >= RETURN_COUNT) 3657 result = NIL; 3658 else if (i >= 0) 3659 result = RETURN(i); 3660 3661 return (result); 3662 } 3663 3664 LispObj * 3665 Lisp_Null(LispBuiltin *builtin) 3666 /* 3667 null list 3668 */ 3669 { 3670 LispObj *list; 3671 3672 list = ARGUMENT(0); 3673 3674 return (list == NIL ? T : NIL); 3675 } 3676 3677 LispObj * 3678 Lisp_Or(LispBuiltin *builtin) 3679 /* 3680 or &rest args 3681 */ 3682 { 3683 LispObj *result = NIL, *args; 3684 3685 args = ARGUMENT(0); 3686 3687 for (; CONSP(args); args = CDR(args)) { 3688 result = EVAL(CAR(args)); 3689 if (result != NIL) 3690 break; 3691 } 3692 3693 return (result); 3694 } 3695 3696 LispObj * 3697 Lisp_Pairlis(LispBuiltin *builtin) 3698 /* 3699 pairlis key data &optional alist 3700 */ 3701 { 3702 LispObj *result, *cons; 3703 3704 LispObj *key, *data, *alist; 3705 3706 alist = ARGUMENT(2); 3707 data = ARGUMENT(1); 3708 key = ARGUMENT(0); 3709 3710 if (CONSP(key) && CONSP(data)) { 3711 GC_ENTER(); 3712 3713 result = cons = CONS(CONS(CAR(key), CAR(data)), NIL); 3714 GC_PROTECT(result); 3715 key = CDR(key); 3716 data = CDR(data); 3717 for (; CONSP(key) && CONSP(data); key = CDR(key), data = CDR(data)) { 3718 RPLACD(cons, CONS(CONS(CAR(key), CAR(data)), NIL)); 3719 cons = CDR(cons); 3720 } 3721 if (CONSP(key) || CONSP(data)) 3722 LispDestroy("%s: different length lists", STRFUN(builtin)); 3723 GC_LEAVE(); 3724 if (alist != UNSPEC) 3725 RPLACD(cons, alist); 3726 } 3727 else 3728 result = alist == UNSPEC ? NIL : alist; 3729 3730 return (result); 3731 } 3732 3733 static LispObj * 3734 LispFindOrPosition(LispBuiltin *builtin, 3735 int function, int comparison) 3736 /* 3737 find item sequence &key from-end test test-not start end key 3738 find-if predicate sequence &key from-end start end key 3739 find-if-not predicate sequence &key from-end start end key 3740 position item sequence &key from-end test test-not start end key 3741 position-if predicate sequence &key from-end start end key 3742 position-if-not predicate sequence &key from-end start end key 3743 */ 3744 { 3745 int code = 0, istring, expect, value; 3746 char *string = NULL; 3747 long offset = -1, start, end, length, i = comparison == NONE ? 7 : 5; 3748 LispObj *cmp, *element, **objects = NULL; 3749 3750 LispObj *item, *predicate, *sequence, *from_end, 3751 *test, *test_not, *ostart, *oend, *key; 3752 3753 key = ARGUMENT(i); --i; 3754 oend = ARGUMENT(i); --i; 3755 ostart = ARGUMENT(i); --i; 3756 if (comparison == NONE) { 3757 test_not = ARGUMENT(i); --i; 3758 test = ARGUMENT(i); --i; 3759 } 3760 else 3761 test_not = test = UNSPEC; 3762 from_end = ARGUMENT(i); --i; 3763 if (from_end == UNSPEC) 3764 from_end = NIL; 3765 sequence = ARGUMENT(i); --i; 3766 if (comparison == NONE) { 3767 item = ARGUMENT(i); 3768 predicate = Oeql; 3769 } 3770 else { 3771 predicate = ARGUMENT(i); 3772 item = NIL; 3773 } 3774 3775 LispCheckSequenceStartEnd(builtin, sequence, ostart, oend, 3776 &start, &end, &length); 3777 3778 if (sequence == NIL) 3779 return (NIL); 3780 3781 /* Cannot specify both :test and :test-not */ 3782 if (test != UNSPEC && test_not != UNSPEC) 3783 LispDestroy("%s: specify either :TEST or :TEST-NOT", STRFUN(builtin)); 3784 3785 expect = 1; 3786 if (comparison == NONE) { 3787 if (test != UNSPEC) 3788 predicate = test; 3789 else if (test_not != UNSPEC) { 3790 predicate = test_not; 3791 expect = 0; 3792 } 3793 FUNCTION_CHECK(predicate); 3794 code = FCODE(predicate); 3795 } 3796 3797 cmp = element = NIL; 3798 istring = STRINGP(sequence); 3799 if (istring) 3800 string = THESTR(sequence); 3801 else { 3802 if (!CONSP(sequence)) 3803 sequence = sequence->data.array.list; 3804 for (i = 0; i < start; i++) 3805 sequence = CDR(sequence); 3806 } 3807 3808 if ((length = end - start) == 0) 3809 return (NIL); 3810 3811 if (from_end != NIL && !istring) { 3812 objects = LispMalloc(sizeof(LispObj*) * length); 3813 for (i = length - 1; i >= 0; i--, sequence = CDR(sequence)) 3814 objects[i] = CAR(sequence); 3815 } 3816 3817 for (i = 0; i < length; i++) { 3818 if (istring) 3819 element = SCHAR(string[from_end == NIL ? i + start : end - i - 1]); 3820 else 3821 element = from_end == NIL ? CAR(sequence) : objects[i]; 3822 3823 if (key != UNSPEC) 3824 cmp = APPLY1(key, element); 3825 else 3826 cmp = element; 3827 3828 /* Update list */ 3829 if (!istring && from_end == NIL) 3830 sequence = CDR(sequence); 3831 3832 if (comparison == NONE) 3833 value = FCOMPARE(predicate, item, cmp, code); 3834 else 3835 value = APPLY1(predicate, cmp) != NIL; 3836 3837 if ((!value && 3838 (comparison == IFNOT || 3839 (comparison == NONE && !expect))) || 3840 (value && 3841 (comparison == IF || 3842 (comparison == NONE && expect)))) { 3843 offset = from_end == NIL ? i + start : end - i - 1; 3844 break; 3845 } 3846 } 3847 3848 if (from_end != NIL && !istring) 3849 LispFree(objects); 3850 3851 return (offset == -1 ? NIL : function == FIND ? element : FIXNUM(offset)); 3852 } 3853 3854 LispObj * 3855 Lisp_Pop(LispBuiltin *builtin) 3856 /* 3857 pop place 3858 */ 3859 { 3860 LispObj *result, *value; 3861 3862 LispObj *place; 3863 3864 place = ARGUMENT(0); 3865 3866 if (SYMBOLP(place)) { 3867 result = LispGetVar(place); 3868 if (result == NULL) 3869 LispDestroy("EVAL: the variable %s is unbound", STROBJ(place)); 3870 CHECK_CONSTANT(place); 3871 if (result != NIL) { 3872 CHECK_CONS(result); 3873 value = CDR(result); 3874 result = CAR(result); 3875 } 3876 else 3877 value = NIL; 3878 LispSetVar(place, value); 3879 } 3880 else { 3881 GC_ENTER(); 3882 LispObj quote; 3883 3884 result = EVAL(place); 3885 if (result != NIL) { 3886 CHECK_CONS(result); 3887 value = CDR(result); 3888 GC_PROTECT(value); 3889 result = CAR(result); 3890 } 3891 else 3892 value = NIL; 3893 quote.type = LispQuote_t; 3894 quote.data.quote = value; 3895 APPLY2(Osetf, place, "e); 3896 GC_LEAVE(); 3897 } 3898 3899 return (result); 3900 } 3901 3902 LispObj * 3903 Lisp_Position(LispBuiltin *builtin) 3904 /* 3905 position item sequence &key from-end test test-not start end key 3906 */ 3907 { 3908 return (LispFindOrPosition(builtin, POSITION, NONE)); 3909 } 3910 3911 LispObj * 3912 Lisp_PositionIf(LispBuiltin *builtin) 3913 /* 3914 position-if predicate sequence &key from-end start end key 3915 */ 3916 { 3917 return (LispFindOrPosition(builtin, POSITION, IF)); 3918 } 3919 3920 LispObj * 3921 Lisp_PositionIfNot(LispBuiltin *builtin) 3922 /* 3923 position-if-not predicate sequence &key from-end start end key 3924 */ 3925 { 3926 return (LispFindOrPosition(builtin, POSITION, IFNOT)); 3927 } 3928 3929 LispObj * 3930 Lisp_Proclaim(LispBuiltin *builtin) 3931 /* 3932 proclaim declaration 3933 */ 3934 { 3935 LispObj *arguments, *object; 3936 char *operation; 3937 3938 LispObj *declaration; 3939 3940 declaration = ARGUMENT(0); 3941 3942 CHECK_CONS(declaration); 3943 3944 arguments = declaration; 3945 object = CAR(arguments); 3946 CHECK_SYMBOL(object); 3947 3948 operation = ATOMID(object)->value; 3949 if (strcmp(operation, "SPECIAL") == 0) { 3950 for (arguments = CDR(arguments); CONSP(arguments); 3951 arguments = CDR(arguments)) { 3952 object = CAR(arguments); 3953 CHECK_SYMBOL(object); 3954 LispProclaimSpecial(object, NULL, NIL); 3955 } 3956 } 3957 else if (strcmp(operation, "TYPE") == 0) { 3958 /* XXX no type checking yet, but should be added */ 3959 } 3960 /* else do nothing */ 3961 3962 return (NIL); 3963 } 3964 3965 LispObj * 3966 Lisp_Prog1(LispBuiltin *builtin) 3967 /* 3968 prog1 first &rest body 3969 */ 3970 { 3971 GC_ENTER(); 3972 LispObj *result; 3973 3974 LispObj *first, *body; 3975 3976 body = ARGUMENT(1); 3977 first = ARGUMENT(0); 3978 3979 result = EVAL(first); 3980 3981 GC_PROTECT(result); 3982 for (; CONSP(body); body = CDR(body)) 3983 (void)EVAL(CAR(body)); 3984 GC_LEAVE(); 3985 3986 return (result); 3987 } 3988 3989 LispObj * 3990 Lisp_Prog2(LispBuiltin *builtin) 3991 /* 3992 prog2 first second &rest body 3993 */ 3994 { 3995 GC_ENTER(); 3996 LispObj *result; 3997 3998 LispObj *first, *second, *body; 3999 4000 body = ARGUMENT(2); 4001 second = ARGUMENT(1); 4002 first = ARGUMENT(0); 4003 4004 (void)EVAL(first); 4005 result = EVAL(second); 4006 GC_PROTECT(result); 4007 for (; CONSP(body); body = CDR(body)) 4008 (void)EVAL(CAR(body)); 4009 GC_LEAVE(); 4010 4011 return (result); 4012 } 4013 4014 LispObj * 4015 Lisp_Progn(LispBuiltin *builtin) 4016 /* 4017 progn &rest body 4018 */ 4019 { 4020 LispObj *result = NIL; 4021 4022 LispObj *body; 4023 4024 body = ARGUMENT(0); 4025 4026 for (; CONSP(body); body = CDR(body)) 4027 result = EVAL(CAR(body)); 4028 4029 return (result); 4030 } 4031 4032 /* 4033 * This does what I believe is the expected behaviour (or at least 4034 * acceptable for the the interpreter), if the code being executed 4035 * ever tries to change/bind a progv symbol, the symbol state will 4036 * be restored when exiting the progv block, so, code like: 4037 * (progv '(*x*) '(1) (defvar *x* 10)) 4038 * when exiting the block, will have *x* unbound, and not a dynamic 4039 * symbol; if it was already bound, will have the old value. 4040 * Symbols already dynamic can be freely changed, even unbounded in 4041 * the progv block. 4042 */ 4043 LispObj * 4044 Lisp_Progv(LispBuiltin *builtin) 4045 /* 4046 progv symbols values &rest body 4047 */ 4048 { 4049 GC_ENTER(); 4050 int head = lisp__data.env.length, i, count, ostk[32], *offsets; 4051 LispObj *result, *list, *symbol, *value; 4052 int jumped; 4053 char fstk[32], *flags; 4054 LispBlock *block; 4055 LispAtom *atom; 4056 4057 LispObj *symbols, *values, *body; 4058 4059 /* Possible states */ 4060 #define DYNAMIC_SYMBOL 1 4061 #define GLOBAL_SYMBOL 2 4062 #define UNBOUND_SYMBOL 3 4063 4064 body = ARGUMENT(2); 4065 values = ARGUMENT(1); 4066 symbols = ARGUMENT(0); 4067 4068 /* get symbol names */ 4069 symbols = EVAL(symbols); 4070 GC_PROTECT(symbols); 4071 4072 /* get symbol values */ 4073 values = EVAL(values); 4074 GC_PROTECT(values); 4075 4076 /* count/check symbols and allocate space to remember symbol state */ 4077 for (count = 0, list = symbols; CONSP(list); count++, list = CDR(list)) { 4078 symbol = CAR(list); 4079 CHECK_SYMBOL(symbol); 4080 CHECK_CONSTANT(symbol); 4081 } 4082 if (count > sizeof(fstk)) { 4083 flags = LispMalloc(count); 4084 offsets = LispMalloc(count * sizeof(int)); 4085 } 4086 else { 4087 flags = &fstk[0]; 4088 offsets = &ostk[0]; 4089 } 4090 4091 /* store flags and save old value if required */ 4092 for (i = 0, list = symbols; i < count; i++, list = CDR(list)) { 4093 atom = CAR(list)->data.atom; 4094 if (atom->dyn) 4095 flags[i] = DYNAMIC_SYMBOL; 4096 else if (atom->a_object) { 4097 flags[i] = GLOBAL_SYMBOL; 4098 offsets[i] = lisp__data.protect.length; 4099 GC_PROTECT(atom->property->value); 4100 } 4101 else 4102 flags[i] = UNBOUND_SYMBOL; 4103 } 4104 4105 /* bind the symbols */ 4106 for (i = 0, list = symbols; i < count; i++, list = CDR(list)) { 4107 symbol = CAR(list); 4108 atom = symbol->data.atom; 4109 if (CONSP(values)) { 4110 value = CAR(values); 4111 values = CDR(values); 4112 } 4113 else 4114 value = NIL; 4115 if (flags[i] != DYNAMIC_SYMBOL) { 4116 if (!atom->a_object) 4117 LispSetAtomObjectProperty(atom, value); 4118 else 4119 SETVALUE(atom, value); 4120 } 4121 else 4122 LispAddVar(symbol, value); 4123 } 4124 /* bind dynamic symbols */ 4125 lisp__data.env.head = lisp__data.env.length; 4126 4127 jumped = 0; 4128 result = NIL; 4129 block = LispBeginBlock(NIL, LispBlockProtect); 4130 if (setjmp(block->jmp) == 0) { 4131 for (; CONSP(body); body = CDR(body)) 4132 result = EVAL(CAR(body)); 4133 } 4134 4135 /* restore symbols */ 4136 for (i = 0, list = symbols; i < count; i++, list = CDR(list)) { 4137 symbol = CAR(list); 4138 atom = symbol->data.atom; 4139 if (flags[i] != DYNAMIC_SYMBOL) { 4140 if (flags[i] == UNBOUND_SYMBOL) 4141 LispUnsetVar(symbol); 4142 else { 4143 /* restore global symbol value */ 4144 LispSetAtomObjectProperty(atom, lisp__data.protect.objects 4145 [offsets[i]]); 4146 atom->dyn = 0; 4147 } 4148 } 4149 } 4150 /* unbind dynamic symbols */ 4151 lisp__data.env.head = lisp__data.env.length = head; 4152 GC_LEAVE(); 4153 4154 if (count > sizeof(fstk)) { 4155 LispFree(flags); 4156 LispFree(offsets); 4157 } 4158 4159 LispEndBlock(block); 4160 if (!lisp__data.destroyed) { 4161 if (jumped) 4162 result = lisp__data.block.block_ret; 4163 } 4164 else { 4165 /* check if there is an unwind-protect block */ 4166 LispBlockUnwind(NULL); 4167 4168 /* no unwind-protect block, return to the toplevel */ 4169 LispDestroy("."); 4170 } 4171 4172 return (result); 4173 } 4174 4175 LispObj * 4176 Lisp_Provide(LispBuiltin *builtin) 4177 /* 4178 provide module 4179 */ 4180 { 4181 LispObj *module, *obj; 4182 4183 module = ARGUMENT(0); 4184 4185 CHECK_STRING(module); 4186 for (obj = MOD; obj != NIL; obj = CDR(obj)) { 4187 if (STRLEN(CAR(obj)) == STRLEN(module) && 4188 memcmp(THESTR(CAR(obj)), THESTR(module), STRLEN(module)) == 0) 4189 return (module); 4190 } 4191 4192 if (MOD == NIL) 4193 MOD = CONS(module, NIL); 4194 else { 4195 RPLACD(MOD, CONS(CAR(MOD), CDR(MOD))); 4196 RPLACA(MOD, module); 4197 } 4198 4199 LispSetVar(lisp__data.modules, MOD); 4200 4201 return (MOD); 4202 } 4203 4204 LispObj * 4205 Lisp_Push(LispBuiltin *builtin) 4206 /* 4207 push item place 4208 */ 4209 { 4210 LispObj *result, *list; 4211 4212 LispObj *item, *place; 4213 4214 place = ARGUMENT(1); 4215 item = ARGUMENT(0); 4216 4217 item = EVAL(item); 4218 4219 if (SYMBOLP(place)) { 4220 list = LispGetVar(place); 4221 if (list == NULL) 4222 LispDestroy("EVAL: the variable %s is unbound", STROBJ(place)); 4223 CHECK_CONSTANT(place); 4224 LispSetVar(place, result = CONS(item, list)); 4225 } 4226 else { 4227 GC_ENTER(); 4228 LispObj quote; 4229 4230 list = EVAL(place); 4231 result = CONS(item, list); 4232 GC_PROTECT(result); 4233 quote.type = LispQuote_t; 4234 quote.data.quote = result; 4235 APPLY2(Osetf, place, "e); 4236 GC_LEAVE(); 4237 } 4238 4239 return (result); 4240 } 4241 4242 LispObj * 4243 Lisp_Pushnew(LispBuiltin *builtin) 4244 /* 4245 pushnew item place &key key test test-not 4246 */ 4247 { 4248 GC_ENTER(); 4249 LispObj *result, *list; 4250 4251 LispObj *item, *place, *key, *test, *test_not; 4252 4253 test_not = ARGUMENT(4); 4254 test = ARGUMENT(3); 4255 key = ARGUMENT(2); 4256 place = ARGUMENT(1); 4257 item = ARGUMENT(0); 4258 4259 /* Evaluate place */ 4260 if (SYMBOLP(place)) { 4261 list = LispGetVar(place); 4262 if (list == NULL) 4263 LispDestroy("EVAL: the variable %s is unbound", STROBJ(place)); 4264 /* Do error checking now. */ 4265 CHECK_CONSTANT(place); 4266 } 4267 else 4268 /* It is possible that list is not gc protected? */ 4269 list = EVAL(place); 4270 4271 item = EVAL(item); 4272 GC_PROTECT(item); 4273 if (key != UNSPEC) { 4274 key = EVAL(key); 4275 GC_PROTECT(key); 4276 } 4277 if (test != UNSPEC) { 4278 test = EVAL(test); 4279 GC_PROTECT(test); 4280 } 4281 else if (test_not != UNSPEC) { 4282 test_not = EVAL(test_not); 4283 GC_PROTECT(test_not); 4284 } 4285 4286 result = LispAdjoin(builtin, item, list, key, test, test_not); 4287 4288 /* Item already in list */ 4289 if (result == list) { 4290 GC_LEAVE(); 4291 4292 return (result); 4293 } 4294 4295 if (SYMBOLP(place)) { 4296 CHECK_CONSTANT(place); 4297 LispSetVar(place, result); 4298 } 4299 else { 4300 LispObj quote; 4301 4302 GC_PROTECT(result); 4303 quote.type = LispQuote_t; 4304 quote.data.quote = result; 4305 APPLY2(Osetf, place, "e); 4306 } 4307 GC_LEAVE(); 4308 4309 return (result); 4310 } 4311 4312 #ifdef __SUNPRO_C 4313 /* prevent "Function has no return statement" error for Lisp_Quit */ 4314 #pragma does_not_return(exit) 4315 #endif 4316 4317 LispObj * 4318 Lisp_Quit(LispBuiltin *builtin) 4319 /* 4320 quit &optional status 4321 */ 4322 { 4323 int status = 0; 4324 LispObj *ostatus; 4325 4326 ostatus = ARGUMENT(0); 4327 4328 if (FIXNUMP(ostatus)) 4329 status = (int)FIXNUM_VALUE(ostatus); 4330 else if (ostatus != UNSPEC) 4331 LispDestroy("%s: bad exit status argument %s", 4332 STRFUN(builtin), STROBJ(ostatus)); 4333 4334 exit(status); 4335 } 4336 4337 LispObj * 4338 Lisp_Quote(LispBuiltin *builtin) 4339 /* 4340 quote object 4341 */ 4342 { 4343 LispObj *object; 4344 4345 object = ARGUMENT(0); 4346 4347 return (object); 4348 } 4349 4350 LispObj * 4351 Lisp_Replace(LispBuiltin *builtin) 4352 /* 4353 replace sequence1 sequence2 &key start1 end1 start2 end2 4354 */ 4355 { 4356 long length, length1, length2, start1, end1, start2, end2; 4357 LispObj *sequence1, *sequence2, *ostart1, *oend1, *ostart2, *oend2; 4358 4359 oend2 = ARGUMENT(5); 4360 ostart2 = ARGUMENT(4); 4361 oend1 = ARGUMENT(3); 4362 ostart1 = ARGUMENT(2); 4363 sequence2 = ARGUMENT(1); 4364 sequence1 = ARGUMENT(0); 4365 4366 LispCheckSequenceStartEnd(builtin, sequence1, ostart1, oend1, 4367 &start1, &end1, &length1); 4368 LispCheckSequenceStartEnd(builtin, sequence2, ostart2, oend2, 4369 &start2, &end2, &length2); 4370 4371 if (start1 == end1 || start2 == end2) 4372 return (sequence1); 4373 4374 length = end1 - start1; 4375 if (length > end2 - start2) 4376 length = end2 - start2; 4377 4378 if (STRINGP(sequence1)) { 4379 CHECK_STRING_WRITABLE(sequence1); 4380 if (!STRINGP(sequence2)) 4381 LispDestroy("%s: cannot store %s in %s", 4382 STRFUN(builtin), STROBJ(sequence2), THESTR(sequence1)); 4383 4384 memmove(THESTR(sequence1) + start1, THESTR(sequence2) + start2, length); 4385 } 4386 else { 4387 int i; 4388 LispObj *from, *to; 4389 4390 if (ARRAYP(sequence1)) 4391 sequence1 = sequence1->data.array.list; 4392 if (ARRAYP(sequence2)) 4393 sequence2 = sequence2->data.array.list; 4394 4395 /* adjust pointers */ 4396 for (i = 0, from = sequence2; i < start2; i++, from = CDR(from)) 4397 ; 4398 for (i = 0, to = sequence1; i < start1; i++, to = CDR(to)) 4399 ; 4400 4401 /* copy data */ 4402 for (i = 0; i < length; i++, from = CDR(from), to = CDR(to)) 4403 RPLACA(to, CAR(from)); 4404 } 4405 4406 return (sequence1); 4407 } 4408 4409 static LispObj * 4410 LispDeleteOrRemoveDuplicates(LispBuiltin *builtin, int function) 4411 /* 4412 delete-duplicates sequence &key from-end test test-not start end key 4413 remove-duplicates sequence &key from-end test test-not start end key 4414 */ 4415 { 4416 GC_ENTER(); 4417 int code, expect, value = 0; 4418 long i, j, start, end, length, count; 4419 LispObj *lambda, *result, *cons, *compare; 4420 4421 LispObj *sequence, *from_end, *test, *test_not, *ostart, *oend, *key; 4422 4423 key = ARGUMENT(6); 4424 oend = ARGUMENT(5); 4425 ostart = ARGUMENT(4); 4426 test_not = ARGUMENT(3); 4427 test = ARGUMENT(2); 4428 from_end = ARGUMENT(1); 4429 if (from_end == UNSPEC) 4430 from_end = NIL; 4431 sequence = ARGUMENT(0); 4432 4433 LispCheckSequenceStartEnd(builtin, sequence, ostart, oend, 4434 &start, &end, &length); 4435 4436 /* Check if need to do something */ 4437 if (start == end) 4438 return (sequence); 4439 4440 CHECK_TEST(); 4441 4442 /* Initialize */ 4443 count = 0; 4444 4445 result = cons = NIL; 4446 if (STRINGP(sequence)) { 4447 char *ptr, *string, *buffer = LispMalloc(length + 1); 4448 4449 /* Use same code, update start/end offsets */ 4450 if (from_end != NIL) { 4451 i = length - start; 4452 start = length - end; 4453 end = i; 4454 } 4455 4456 if (from_end == NIL) 4457 string = THESTR(sequence); 4458 else { 4459 /* Make a reversed copy of the sequence */ 4460 string = LispMalloc(length + 1); 4461 for (ptr = THESTR(sequence) + length - 1, i = 0; i < length; i++) 4462 string[i] = *ptr--; 4463 string[i] = '\0'; 4464 } 4465 4466 ptr = buffer; 4467 /* Copy leading bytes */ 4468 for (i = 0; i < start; i++) 4469 *ptr++ = string[i]; 4470 4471 compare = SCHAR(string[i]); 4472 if (key != UNSPEC) 4473 compare = APPLY1(key, compare); 4474 result = cons = CONS(compare, NIL); 4475 GC_PROTECT(result); 4476 for (++i; i < end; i++) { 4477 compare = SCHAR(string[i]); 4478 if (key != UNSPEC) 4479 compare = APPLY1(key, compare); 4480 RPLACD(cons, CONS(compare, NIL)); 4481 cons = CDR(cons); 4482 } 4483 4484 for (i = start; i < end; i++, result = CDR(result)) { 4485 compare = CAR(result); 4486 for (j = i + 1, cons = CDR(result); j < end; j++, cons = CDR(cons)) { 4487 value = FCOMPARE(lambda, compare, CAR(cons), code); 4488 if (value == expect) 4489 break; 4490 } 4491 if (value != expect) 4492 *ptr++ = string[i]; 4493 else 4494 ++count; 4495 } 4496 4497 if (count) { 4498 /* Copy ending bytes */ 4499 for (; i <= length; i++) /* Also copy the ending nul */ 4500 *ptr++ = string[i]; 4501 4502 if (from_end == NIL) 4503 ptr = buffer; 4504 else { 4505 for (i = 0, ptr = buffer + strlen(buffer); 4506 ptr > buffer; 4507 i++) 4508 string[i] = *--ptr; 4509 string[i] = '\0'; 4510 ptr = string; 4511 LispFree(buffer); 4512 } 4513 if (function == REMOVE) 4514 result = STRING2(ptr); 4515 else { 4516 CHECK_STRING_WRITABLE(sequence); 4517 result = sequence; 4518 free(THESTR(result)); 4519 THESTR(result) = ptr; 4520 LispMused(ptr); 4521 } 4522 } 4523 else { 4524 result = sequence; 4525 if (from_end != NIL) 4526 LispFree(string); 4527 } 4528 } 4529 else { 4530 long xlength = end - start; 4531 LispObj *list, *object, **kobjects = NULL, **xobjects; 4532 LispObj **objects = LispMalloc(sizeof(LispObj*) * xlength); 4533 4534 if (!CONSP(sequence)) 4535 object = sequence->data.array.list; 4536 else 4537 object = sequence; 4538 list = object; 4539 4540 for (i = 0; i < start; i++) 4541 object = CDR(object); 4542 4543 /* Put data in a vector */ 4544 if (from_end == NIL) { 4545 for (i = 0; i < xlength; i++, object = CDR(object)) 4546 objects[i] = CAR(object); 4547 } 4548 else { 4549 for (i = xlength - 1; i >= 0; i--, object = CDR(object)) 4550 objects[i] = CAR(object); 4551 } 4552 4553 /* Apply key predicate if required */ 4554 if (key != UNSPEC) { 4555 kobjects = LispMalloc(sizeof(LispObj*) * xlength); 4556 for (i = 0; i < xlength; i++) { 4557 kobjects[i] = APPLY1(key, objects[i]); 4558 GC_PROTECT(kobjects[i]); 4559 } 4560 xobjects = kobjects; 4561 } 4562 else 4563 xobjects = objects; 4564 4565 /* Check if needs to remove something */ 4566 for (i = 0; i < xlength; i++) { 4567 compare = xobjects[i]; 4568 for (j = i + 1; j < xlength; j++) { 4569 value = FCOMPARE(lambda, compare, xobjects[j], code); 4570 if (value == expect) { 4571 objects[i] = NULL; 4572 ++count; 4573 break; 4574 } 4575 } 4576 } 4577 4578 if (count) { 4579 /* Create/set result list */ 4580 object = list; 4581 4582 if (start) { 4583 /* Skip first elements of resulting list */ 4584 if (function == REMOVE) { 4585 result = cons = CONS(CAR(object), NIL); 4586 GC_PROTECT(result); 4587 for (i = 1, object = CDR(object); 4588 i < start; 4589 i++, object = CDR(object)) { 4590 RPLACD(cons, CONS(CAR(object), NIL)); 4591 cons = CDR(cons); 4592 } 4593 } 4594 else { 4595 result = cons = object; 4596 for (i = 1; i < start; i++, cons = CDR(cons)) 4597 ; 4598 } 4599 } 4600 else if (function == DELETE) 4601 result = list; 4602 4603 /* Skip initial removed elements */ 4604 if (function == REMOVE) { 4605 for (i = 0; objects[i] == NULL && i < xlength; i++) 4606 ; 4607 } 4608 else 4609 i = 0; 4610 4611 if (i < xlength) { 4612 int xstart, xlimit, xinc; 4613 4614 if (from_end == NIL) { 4615 xstart = i; 4616 xlimit = xlength; 4617 xinc = 1; 4618 } 4619 else { 4620 xstart = xlength - 1; 4621 xlimit = i - 1; 4622 xinc = -1; 4623 } 4624 4625 if (function == REMOVE) { 4626 for (i = xstart; i != xlimit; i += xinc) { 4627 if (objects[i] != NULL) { 4628 if (result == NIL) { 4629 result = cons = CONS(objects[i], NIL); 4630 GC_PROTECT(result); 4631 } 4632 else { 4633 RPLACD(cons, CONS(objects[i], NIL)); 4634 cons = CDR(cons); 4635 } 4636 } 4637 } 4638 } 4639 else { 4640 /* Delete duplicates */ 4641 for (i = xstart; i != xlimit; i += xinc) { 4642 if (objects[i] == NULL) { 4643 if (cons == NIL) { 4644 if (CONSP(CDR(result))) { 4645 RPLACA(result, CADR(result)); 4646 RPLACD(result, CDDR(result)); 4647 } 4648 else { 4649 RPLACA(result, CDR(result)); 4650 RPLACD(result, NIL); 4651 } 4652 } 4653 else { 4654 if (CONSP(CDR(cons))) 4655 RPLACD(cons, CDDR(cons)); 4656 else 4657 RPLACD(cons, NIL); 4658 } 4659 } 4660 else { 4661 if (cons == NIL) 4662 cons = result; 4663 else 4664 cons = CDR(cons); 4665 } 4666 } 4667 } 4668 } 4669 if (end < length && function == REMOVE) { 4670 for (i = start; i < end; i++, object = CDR(object)) 4671 ; 4672 if (result == NIL) { 4673 result = cons = CONS(CAR(object), NIL); 4674 GC_PROTECT(result); 4675 ++i; 4676 object = CDR(object); 4677 } 4678 for (; i < length; i++, object = CDR(object)) { 4679 RPLACD(cons, CONS(CAR(object), NIL)); 4680 cons = CDR(cons); 4681 } 4682 } 4683 } 4684 else 4685 result = sequence; 4686 LispFree(objects); 4687 if (key != UNSPEC) 4688 LispFree(kobjects); 4689 4690 if (count && !CONSP(sequence)) { 4691 if (function == REMOVE) 4692 result = VECTOR(result); 4693 else { 4694 length = FIXNUM_VALUE(CAR(sequence->data.array.dim)) - count; 4695 CAR(sequence->data.array.dim) = FIXNUM(length); 4696 result = sequence; 4697 } 4698 } 4699 } 4700 GC_LEAVE(); 4701 4702 return (result); 4703 } 4704 4705 LispObj * 4706 Lisp_RemoveDuplicates(LispBuiltin *builtin) 4707 /* 4708 remove-duplicates sequence &key from-end test test-not start end key 4709 */ 4710 { 4711 return (LispDeleteOrRemoveDuplicates(builtin, REMOVE)); 4712 } 4713 4714 static LispObj * 4715 LispDeleteRemoveXSubstitute(LispBuiltin *builtin, 4716 int function, int comparison) 4717 /* 4718 delete item sequence &key from-end test test-not start end count key 4719 delete-if predicate sequence &key from-end start end count key 4720 delete-if-not predicate sequence &key from-end start end count key 4721 remove item sequence &key from-end test test-not start end count key 4722 remove-if predicate sequence &key from-end start end count key 4723 remove-if-not predicate sequence &key from-end start end count key 4724 substitute newitem olditem sequence &key from-end test test-not start end count key 4725 substitute-if newitem test sequence &key from-end start end count key 4726 substitute-if-not newitem test sequence &key from-end start end count key 4727 nsubstitute newitem olditem sequence &key from-end test test-not start end count key 4728 nsubstitute-if newitem test sequence &key from-end start end count key 4729 nsubstitute-if-not newitem test sequence &key from-end start end count key 4730 */ 4731 { 4732 GC_ENTER(); 4733 int code, expect, value, inplace, substitute; 4734 long i, j, start, end, length, copy, count, xstart, xend, xinc, xlength; 4735 4736 LispObj *result, *compare; 4737 4738 LispObj *item, *newitem, *lambda, *sequence, *from_end, 4739 *test, *test_not, *ostart, *oend, *ocount, *key; 4740 4741 substitute = function == SUBSTITUTE || function == NSUBSTITUTE; 4742 if (!substitute) 4743 i = comparison == NONE ? 8 : 6; 4744 else /* substitute */ 4745 i = comparison == NONE ? 9 : 7; 4746 4747 /* Get function arguments */ 4748 key = ARGUMENT(i); --i; 4749 ocount = ARGUMENT(i); --i; 4750 oend = ARGUMENT(i); --i; 4751 ostart = ARGUMENT(i); --i; 4752 if (comparison == NONE) { 4753 test_not = ARGUMENT(i); --i; 4754 test = ARGUMENT(i); --i; 4755 } 4756 else 4757 test_not = test = UNSPEC; 4758 from_end = ARGUMENT(i); --i; 4759 if (from_end == UNSPEC) 4760 from_end = NIL; 4761 sequence = ARGUMENT(i); --i; 4762 if (comparison != NONE) { 4763 lambda = ARGUMENT(i); --i; 4764 if (substitute) 4765 newitem = ARGUMENT(0); 4766 else 4767 newitem = NIL; 4768 item = NIL; 4769 } 4770 else { 4771 lambda = NIL; 4772 if (substitute) { 4773 item = ARGUMENT(1); 4774 newitem = ARGUMENT(0); 4775 } 4776 else { 4777 item = ARGUMENT(0); 4778 newitem = NIL; 4779 } 4780 } 4781 4782 /* Check if argument is a valid sequence, and if start/end 4783 * are correctly specified. */ 4784 LispCheckSequenceStartEnd(builtin, sequence, ostart, oend, 4785 &start, &end, &length); 4786 4787 /* Check count argument */ 4788 if (ocount == UNSPEC) { 4789 count = length; 4790 /* Doesn't matter, but left to right should be slightly faster */ 4791 from_end = NIL; 4792 } 4793 else { 4794 CHECK_INDEX(ocount); 4795 count = FIXNUM_VALUE(ocount); 4796 } 4797 4798 /* Check if need to do something */ 4799 if (start == end || count == 0) 4800 return (sequence); 4801 4802 CHECK_TEST_0(); 4803 4804 /* Resolve comparison function, and expected result of comparison */ 4805 if (comparison == NONE) { 4806 if (test_not == UNSPEC) { 4807 if (test == UNSPEC) 4808 lambda = Oeql; 4809 else 4810 lambda = test; 4811 expect = 1; 4812 } 4813 else { 4814 lambda = test_not; 4815 expect = 0; 4816 } 4817 FUNCTION_CHECK(lambda); 4818 } 4819 else 4820 expect = comparison == IFNOT ? 0 : 1; 4821 4822 /* Check for fast path to comparison function */ 4823 code = FCODE(lambda); 4824 4825 /* Initialize for loop */ 4826 copy = count; 4827 result = sequence; 4828 inplace = function == DELETE || function == NSUBSTITUTE; 4829 xlength = end - start; 4830 4831 /* String is easier */ 4832 if (STRINGP(sequence)) { 4833 char *buffer, *string; 4834 4835 if (comparison == NONE) { 4836 CHECK_SCHAR(item); 4837 } 4838 if (substitute) { 4839 CHECK_SCHAR(newitem); 4840 } 4841 4842 if (from_end == NIL) { 4843 xstart = start; 4844 xend = end; 4845 xinc = 1; 4846 } 4847 else { 4848 xstart = end - 1; 4849 xend = start - 1; 4850 xinc = -1; 4851 } 4852 4853 string = THESTR(sequence); 4854 buffer = LispMalloc(length + 1); 4855 4856 /* Copy leading bytes, if any */ 4857 for (i = 0; i < start; i++) 4858 buffer[i] = string[i]; 4859 4860 for (j = xstart; i != xend && count > 0; i += xinc) { 4861 compare = SCHAR(string[i]); 4862 if (key != UNSPEC) { 4863 compare = APPLY1(key, compare); 4864 /* Value returned by the key predicate may not be protected */ 4865 GC_PROTECT(compare); 4866 if (comparison == NONE) 4867 value = FCOMPARE(lambda, item, compare, code); 4868 else 4869 value = APPLY1(lambda, compare) != NIL; 4870 /* Unprotect value returned by the key predicate */ 4871 GC_LEAVE(); 4872 } 4873 else { 4874 if (comparison == NONE) 4875 value = FCOMPARE(lambda, item, compare, code); 4876 else 4877 value = APPLY1(lambda, compare) != NIL; 4878 } 4879 4880 if (value != expect) { 4881 buffer[j] = string[i]; 4882 j += xinc; 4883 } 4884 else { 4885 if (substitute) { 4886 buffer[j] = SCHAR_VALUE(newitem); 4887 j += xinc; 4888 } 4889 else 4890 --count; 4891 } 4892 } 4893 4894 if (count != copy && from_end != NIL) 4895 memmove(buffer + start, buffer + copy - count, count); 4896 4897 /* Copy remaining bytes, if any */ 4898 for (; i < length; i++, j++) 4899 buffer[j] = string[i]; 4900 buffer[j] = '\0'; 4901 4902 xlength = length - (copy - count); 4903 if (inplace) { 4904 CHECK_STRING_WRITABLE(sequence); 4905 /* result is a pointer to sequence */ 4906 LispFree(THESTR(sequence)); 4907 LispMused(buffer); 4908 THESTR(sequence) = buffer; 4909 STRLEN(sequence) = xlength; 4910 } 4911 else 4912 result = LSTRING2(buffer, xlength); 4913 } 4914 4915 /* If inplace, need to update CAR and CDR of sequence */ 4916 else { 4917 LispObj *list, *object; 4918 LispObj **objects = LispMalloc(sizeof(LispObj*) * xlength); 4919 4920 if (!CONSP(sequence)) 4921 list = sequence->data.array.list; 4922 else 4923 list = sequence; 4924 4925 /* Put data in a vector */ 4926 for (i = 0, object = list; i < start; i++) 4927 object = CDR(object); 4928 4929 for (i = 0; i < xlength; i++, object = CDR(object)) 4930 objects[i] = CAR(object); 4931 4932 if (from_end == NIL) { 4933 xstart = 0; 4934 xend = xlength; 4935 xinc = 1; 4936 } 4937 else { 4938 xstart = xlength - 1; 4939 xend = -1; 4940 xinc = -1; 4941 } 4942 4943 /* Check if needs to remove something */ 4944 for (i = xstart; i != xend && count > 0; i += xinc) { 4945 compare = objects[i]; 4946 if (key != UNSPEC) { 4947 compare = APPLY1(key, compare); 4948 GC_PROTECT(compare); 4949 if (comparison == NONE) 4950 value = FCOMPARE(lambda, item, compare, code); 4951 else 4952 value = APPLY1(lambda, compare) != NIL; 4953 GC_LEAVE(); 4954 } 4955 else { 4956 if (comparison == NONE) 4957 value = FCOMPARE(lambda, item, compare, code); 4958 else 4959 value = APPLY1(lambda, compare) != NIL; 4960 } 4961 if (value == expect) { 4962 if (substitute) 4963 objects[i] = newitem; 4964 else 4965 objects[i] = NULL; 4966 --count; 4967 } 4968 } 4969 4970 if (copy != count) { 4971 LispObj *cons = NIL; 4972 4973 i = 0; 4974 object = list; 4975 if (inplace) { 4976 /* While result is NIL, skip initial elements of sequence */ 4977 result = start ? list : NIL; 4978 4979 /* Skip initial elements, if any */ 4980 for (; i < start; i++, cons = object, object = CDR(object)) 4981 ; 4982 } 4983 /* Copy initial elements, if any */ 4984 else { 4985 result = NIL; 4986 if (start) { 4987 result = cons = CONS(CAR(list), NIL); 4988 GC_PROTECT(result); 4989 for (++i, object = CDR(list); 4990 i < start; 4991 i++, object = CDR(object)) { 4992 RPLACD(cons, CONS(CAR(object), NIL)); 4993 cons = CDR(cons); 4994 } 4995 } 4996 } 4997 4998 /* Skip initial removed elements, if any */ 4999 for (i = 0; i < xlength && objects[i] == NULL; i++) 5000 ; 5001 5002 for (i = 0; i < xlength; i++, object = CDR(object)) { 5003 if (objects[i]) { 5004 if (inplace) { 5005 if (result == NIL) 5006 result = cons = object; 5007 else { 5008 RPLACD(cons, object); 5009 cons = CDR(cons); 5010 } 5011 if (function == NSUBSTITUTE) 5012 RPLACA(cons, objects[i]); 5013 } 5014 else { 5015 if (result == NIL) { 5016 result = cons = CONS(objects[i], NIL); 5017 GC_PROTECT(result); 5018 } 5019 else { 5020 RPLACD(cons, CONS(objects[i], NIL)); 5021 cons = CDR(cons); 5022 } 5023 } 5024 } 5025 } 5026 5027 if (inplace) { 5028 if (result == NIL) 5029 result = object; 5030 else 5031 RPLACD(cons, object); 5032 5033 if (!CONSP(sequence)) { 5034 result = sequence; 5035 CAR(result)->data.array.dim = 5036 FIXNUM(length - (copy - count)); 5037 } 5038 } 5039 else if (end < length) { 5040 i = end; 5041 /* Copy ending elements, if any */ 5042 if (result == NIL) { 5043 result = cons = CONS(CAR(object), NIL); 5044 GC_PROTECT(result); 5045 object = CDR(object); 5046 i++; 5047 } 5048 for (; i < length; i++, object = CDR(object)) { 5049 RPLACD(cons, CONS(CAR(object), NIL)); 5050 cons = CDR(cons); 5051 } 5052 } 5053 } 5054 5055 /* Release comparison vector */ 5056 LispFree(objects); 5057 } 5058 5059 GC_LEAVE(); 5060 5061 return (result); 5062 } 5063 5064 LispObj * 5065 Lisp_Remove(LispBuiltin *builtin) 5066 /* 5067 remove item sequence &key from-end test test-not start end count key 5068 */ 5069 { 5070 return (LispDeleteRemoveXSubstitute(builtin, REMOVE, NONE)); 5071 } 5072 5073 LispObj * 5074 Lisp_RemoveIf(LispBuiltin *builtin) 5075 /* 5076 remove-if predicate sequence &key from-end start end count key 5077 */ 5078 { 5079 return (LispDeleteRemoveXSubstitute(builtin, REMOVE, IF)); 5080 } 5081 5082 LispObj * 5083 Lisp_RemoveIfNot(LispBuiltin *builtin) 5084 /* 5085 remove-if-not predicate sequence &key from-end start end count key 5086 */ 5087 { 5088 return (LispDeleteRemoveXSubstitute(builtin, REMOVE, IFNOT)); 5089 } 5090 5091 LispObj * 5092 Lisp_Remprop(LispBuiltin *builtin) 5093 /* 5094 remprop symbol indicator 5095 */ 5096 { 5097 LispObj *symbol, *indicator; 5098 5099 indicator = ARGUMENT(1); 5100 symbol = ARGUMENT(0); 5101 5102 CHECK_SYMBOL(symbol); 5103 5104 return (LispRemAtomProperty(symbol->data.atom, indicator)); 5105 } 5106 5107 LispObj * 5108 Lisp_Return(LispBuiltin *builtin) 5109 /* 5110 return &optional result 5111 */ 5112 { 5113 unsigned blevel = lisp__data.block.block_level; 5114 5115 LispObj *result; 5116 5117 result = ARGUMENT(0); 5118 5119 while (blevel) { 5120 LispBlock *block = lisp__data.block.block[--blevel]; 5121 5122 if (block->type == LispBlockClosure) 5123 /* if reached a function call */ 5124 break; 5125 if (block->type == LispBlockTag && block->tag == NIL) { 5126 lisp__data.block.block_ret = result == UNSPEC ? NIL : EVAL(result); 5127 LispBlockUnwind(block); 5128 BLOCKJUMP(block); 5129 } 5130 } 5131 LispDestroy("%s: no visible NIL block", STRFUN(builtin)); 5132 5133 /*NOTREACHED*/ 5134 return (NIL); 5135 } 5136 5137 LispObj * 5138 Lisp_ReturnFrom(LispBuiltin *builtin) 5139 /* 5140 return-from name &optional result 5141 */ 5142 { 5143 unsigned blevel = lisp__data.block.block_level; 5144 5145 LispObj *name, *result; 5146 5147 result = ARGUMENT(1); 5148 name = ARGUMENT(0); 5149 5150 if (name != NIL && name != T && !SYMBOLP(name)) 5151 LispDestroy("%s: %s is not a valid block name", 5152 STRFUN(builtin), STROBJ(name)); 5153 5154 while (blevel) { 5155 LispBlock *block = lisp__data.block.block[--blevel]; 5156 5157 if (name == block->tag && 5158 (block->type == LispBlockTag || block->type == LispBlockClosure)) { 5159 lisp__data.block.block_ret = result == UNSPEC ? NIL : EVAL(result); 5160 LispBlockUnwind(block); 5161 BLOCKJUMP(block); 5162 } 5163 if (block->type == LispBlockClosure) 5164 /* can use return-from only in the current function */ 5165 break; 5166 } 5167 LispDestroy("%s: no visible block named %s", 5168 STRFUN(builtin), STROBJ(name)); 5169 5170 /*NOTREACHED*/ 5171 return (NIL); 5172 } 5173 5174 static LispObj * 5175 LispXReverse(LispBuiltin *builtin, int inplace) 5176 /* 5177 nreverse sequence 5178 reverse sequence 5179 */ 5180 { 5181 long length; 5182 LispObj *list, *result = NIL; 5183 5184 LispObj *sequence; 5185 5186 sequence = ARGUMENT(0); 5187 5188 /* Do error checking for arrays and object type. */ 5189 length = LispLength(sequence); 5190 if (length <= 1) 5191 return (sequence); 5192 5193 switch (XOBJECT_TYPE(sequence)) { 5194 case LispString_t: { 5195 long i; 5196 char *from, *to; 5197 5198 from = THESTR(sequence) + length - 1; 5199 if (inplace) { 5200 char temp; 5201 5202 CHECK_STRING_WRITABLE(sequence); 5203 to = THESTR(sequence); 5204 for (i = 0; i < length / 2; i++) { 5205 temp = to[i]; 5206 to[i] = from[-i]; 5207 from[-i] = temp; 5208 } 5209 result = sequence; 5210 } 5211 else { 5212 to = LispMalloc(length + 1); 5213 to[length] = '\0'; 5214 for (i = 0; i < length; i++) 5215 to[i] = from[-i]; 5216 result = STRING2(to); 5217 } 5218 } return (result); 5219 case LispCons_t: 5220 if (inplace) { 5221 long i, j; 5222 LispObj *temp; 5223 5224 /* For large lists this can be very slow, but for small 5225 * amounts of data, this avoid allocating a buffer to 5226 * to store the CAR of the sequence. This is only done 5227 * to not destroy the contents of a variable. 5228 */ 5229 for (i = 0, list = sequence; 5230 i < (length + 1) / 2; 5231 i++, list = CDR(list)) 5232 ; 5233 length /= 2; 5234 for (i = 0; i < length; i++, list = CDR(list)) { 5235 for (j = length - i - 1, result = sequence; 5236 j > 0; 5237 j--, result = CDR(result)) 5238 ; 5239 temp = CAR(list); 5240 RPLACA(list, CAR(result)); 5241 RPLACA(result, temp); 5242 } 5243 return (sequence); 5244 } 5245 list = sequence; 5246 break; 5247 case LispArray_t: 5248 if (inplace) { 5249 sequence->data.array.list = 5250 LispReverse(sequence->data.array.list); 5251 return (sequence); 5252 } 5253 list = sequence->data.array.list; 5254 break; 5255 default: /* LispNil_t */ 5256 return (result); 5257 } 5258 5259 { 5260 GC_ENTER(); 5261 LispObj *cons; 5262 5263 result = cons = CONS(CAR(list), NIL); 5264 GC_PROTECT(result); 5265 for (list = CDR(list); CONSP(list); list = CDR(list)) { 5266 RPLACD(cons, CONS(CAR(list), NIL)); 5267 cons = CDR(cons); 5268 } 5269 result = LispReverse(result); 5270 5271 GC_LEAVE(); 5272 } 5273 5274 if (ARRAYP(sequence)) { 5275 list = result; 5276 5277 result = LispNew(list, NIL); 5278 result->type = LispArray_t; 5279 result->data.array.list = list; 5280 result->data.array.dim = sequence->data.array.dim; 5281 result->data.array.rank = sequence->data.array.rank; 5282 result->data.array.type = sequence->data.array.type; 5283 result->data.array.zero = sequence->data.array.zero; 5284 } 5285 5286 return (result); 5287 } 5288 5289 LispObj * 5290 Lisp_Reverse(LispBuiltin *builtin) 5291 /* 5292 reverse sequence 5293 */ 5294 { 5295 return (LispXReverse(builtin, 0)); 5296 } 5297 5298 LispObj * 5299 Lisp_Rplaca(LispBuiltin *builtin) 5300 /* 5301 rplaca place value 5302 */ 5303 { 5304 LispObj *place, *value; 5305 5306 value = ARGUMENT(1); 5307 place = ARGUMENT(0); 5308 5309 CHECK_CONS(place); 5310 RPLACA(place, value); 5311 5312 return (place); 5313 } 5314 5315 LispObj * 5316 Lisp_Rplacd(LispBuiltin *builtin) 5317 /* 5318 rplacd place value 5319 */ 5320 { 5321 LispObj *place, *value; 5322 5323 value = ARGUMENT(1); 5324 place = ARGUMENT(0); 5325 5326 CHECK_CONS(place); 5327 RPLACD(place, value); 5328 5329 return (place); 5330 } 5331 5332 LispObj * 5333 Lisp_Search(LispBuiltin *builtin) 5334 /* 5335 search sequence1 sequence2 &key from-end test test-not key start1 start2 end1 end2 5336 */ 5337 { 5338 int code = 0, expect, value; 5339 long start1, start2, end1, end2, length1, length2, off1, off2, offset = -1; 5340 LispObj *cmp1, *cmp2, *list1 = NIL, *lambda; 5341 SeqInfo seq1, seq2; 5342 5343 LispObj *sequence1, *sequence2, *from_end, *test, *test_not, 5344 *key, *ostart1, *ostart2, *oend1, *oend2; 5345 5346 oend2 = ARGUMENT(9); 5347 oend1 = ARGUMENT(8); 5348 ostart2 = ARGUMENT(7); 5349 ostart1 = ARGUMENT(6); 5350 key = ARGUMENT(5); 5351 test_not = ARGUMENT(4); 5352 test = ARGUMENT(3); 5353 from_end = ARGUMENT(2); 5354 sequence2 = ARGUMENT(1); 5355 sequence1 = ARGUMENT(0); 5356 5357 LispCheckSequenceStartEnd(builtin, sequence1, ostart1, oend1, 5358 &start1, &end1, &length1); 5359 LispCheckSequenceStartEnd(builtin, sequence2, ostart2, oend2, 5360 &start2, &end2, &length2); 5361 5362 /* Check for special conditions */ 5363 if (start1 == end1) 5364 return (FIXNUM(end2)); 5365 else if (start2 == end2) 5366 return (start1 == end1 ? FIXNUM(start2) : NIL); 5367 5368 CHECK_TEST(); 5369 5370 if (from_end == UNSPEC) 5371 from_end = NIL; 5372 5373 SETSEQ(seq1, sequence1); 5374 SETSEQ(seq2, sequence2); 5375 5376 length1 = end1 - start1; 5377 length2 = end2 - start2; 5378 5379 /* update start of sequences */ 5380 if (start1) { 5381 if (seq1.type == LispString_t) 5382 seq1.data.string += start1; 5383 else { 5384 for (cmp1 = seq1.data.list; start1; cmp1 = CDR(cmp1), --start1) 5385 ; 5386 seq1.data.list = cmp1; 5387 } 5388 end1 = length1; 5389 } 5390 if (start2) { 5391 if (seq2.type == LispString_t) 5392 seq2.data.string += start2; 5393 else { 5394 for (cmp2 = seq2.data.list; start2; cmp2 = CDR(cmp2), --start2) 5395 ; 5396 seq2.data.list = cmp2; 5397 } 5398 end2 = length2; 5399 } 5400 5401 /* easier case */ 5402 if (from_end == NIL) { 5403 LispObj *list2 = NIL; 5404 5405 /* while a match is possible */ 5406 while (end2 - start2 >= length1) { 5407 5408 /* prepare to search */ 5409 off1 = 0; 5410 off2 = start2; 5411 if (seq1.type != LispString_t) 5412 list1 = seq1.data.list; 5413 if (seq2.type != LispString_t) 5414 list2 = seq2.data.list; 5415 5416 /* for every element that must match in sequence1 */ 5417 while (off1 < length1) { 5418 if (seq1.type == LispString_t) 5419 cmp1 = SCHAR(seq1.data.string[off1]); 5420 else 5421 cmp1 = CAR(list1); 5422 if (seq2.type == LispString_t) 5423 cmp2 = SCHAR(seq2.data.string[off2]); 5424 else 5425 cmp2 = CAR(list2); 5426 if (key != UNSPEC) { 5427 cmp1 = APPLY1(key, cmp1); 5428 cmp2 = APPLY1(key, cmp2); 5429 } 5430 5431 /* compare elements */ 5432 value = FCOMPARE(lambda, cmp1, cmp2, code); 5433 if (value != expect) 5434 break; 5435 5436 /* update offsets/sequence pointers */ 5437 ++off1; 5438 ++off2; 5439 if (seq1.type != LispString_t) 5440 list1 = CDR(list1); 5441 if (seq2.type != LispString_t) 5442 list2 = CDR(list2); 5443 } 5444 5445 /* if everything matched */ 5446 if (off1 == end1) { 5447 offset = off2 - length1; 5448 break; 5449 } 5450 5451 /* update offset/sequence2 pointer */ 5452 ++start2; 5453 if (seq2.type != LispString_t) 5454 seq2.data.list = CDR(seq2.data.list); 5455 } 5456 } 5457 else { 5458 /* allocate vector if required, only list2 requires it. 5459 * list1 can be traversed forward */ 5460 if (seq2.type != LispString_t) { 5461 cmp2 = seq2.data.list; 5462 seq2.data.vector = LispMalloc(sizeof(LispObj*) * length2); 5463 for (off2 = 0; off2 < end2; off2++, cmp2 = CDR(cmp2)) 5464 seq2.data.vector[off2] = CAR(cmp2); 5465 } 5466 5467 /* while a match is possible */ 5468 while (end2 >= length1) { 5469 5470 /* prepare to search */ 5471 off1 = 0; 5472 off2 = end2 - length1; 5473 if (seq1.type != LispString_t) 5474 list1 = seq1.data.list; 5475 5476 /* for every element that must match in sequence1 */ 5477 while (off1 < end1) { 5478 if (seq1.type == LispString_t) 5479 cmp1 = SCHAR(seq1.data.string[off1]); 5480 else 5481 cmp1 = CAR(list1); 5482 if (seq2.type == LispString_t) 5483 cmp2 = SCHAR(seq2.data.string[off2]); 5484 else 5485 cmp2 = seq2.data.vector[off2]; 5486 if (key != UNSPEC) { 5487 cmp1 = APPLY1(key, cmp1); 5488 cmp2 = APPLY1(key, cmp2); 5489 } 5490 5491 /* Compare elements */ 5492 value = FCOMPARE(lambda, cmp1, cmp2, code); 5493 if (value != expect) 5494 break; 5495 5496 /* Update offsets */ 5497 ++off1; 5498 ++off2; 5499 if (seq1.type != LispString_t) 5500 list1 = CDR(list1); 5501 } 5502 5503 /* If all elements matched */ 5504 if (off1 == end1) { 5505 offset = off2 - length1; 5506 break; 5507 } 5508 5509 /* Update offset */ 5510 --end2; 5511 } 5512 5513 if (seq2.type != LispString_t) 5514 LispFree(seq2.data.vector); 5515 } 5516 5517 return (offset == -1 ? NIL : FIXNUM(offset)); 5518 } 5519 5520 /* 5521 * ext::getenv 5522 */ 5523 LispObj * 5524 Lisp_Setenv(LispBuiltin *builtin) 5525 /* 5526 setenv name value &optional overwrite 5527 */ 5528 { 5529 char *name, *value; 5530 5531 LispObj *oname, *ovalue, *overwrite; 5532 5533 overwrite = ARGUMENT(2); 5534 ovalue = ARGUMENT(1); 5535 oname = ARGUMENT(0); 5536 5537 CHECK_STRING(oname); 5538 name = THESTR(oname); 5539 5540 CHECK_STRING(ovalue); 5541 value = THESTR(ovalue); 5542 5543 setenv(name, value, overwrite != UNSPEC && overwrite != NIL); 5544 value = getenv(name); 5545 5546 return (value ? STRING(value) : NIL); 5547 } 5548 5549 LispObj * 5550 Lisp_Set(LispBuiltin *builtin) 5551 /* 5552 set symbol value 5553 */ 5554 { 5555 LispAtom *atom; 5556 LispObj *symbol, *value; 5557 5558 value = ARGUMENT(1); 5559 symbol = ARGUMENT(0); 5560 5561 CHECK_SYMBOL(symbol); 5562 atom = symbol->data.atom; 5563 if (atom->dyn) 5564 LispSetVar(symbol, value); 5565 else if (atom->watch || !atom->a_object) 5566 LispSetAtomObjectProperty(atom, value); 5567 else { 5568 CHECK_CONSTANT(symbol); 5569 SETVALUE(atom, value); 5570 } 5571 5572 return (value); 5573 } 5574 5575 LispObj * 5576 Lisp_SetDifference(LispBuiltin *builtin) 5577 /* 5578 set-difference list1 list2 &key test test-not key 5579 */ 5580 { 5581 return (LispListSet(builtin, SETDIFFERENCE)); 5582 } 5583 5584 LispObj * 5585 Lisp_SetExclusiveOr(LispBuiltin *builtin) 5586 /* 5587 set-exclusive-or list1 list2 &key test test-not key 5588 */ 5589 { 5590 return (LispListSet(builtin, SETEXCLUSIVEOR)); 5591 } 5592 5593 LispObj * 5594 Lisp_NsetExclusiveOr(LispBuiltin *builtin) 5595 /* 5596 nset-exclusive-or list1 list2 &key test test-not key 5597 */ 5598 { 5599 return (LispListSet(builtin, NSETEXCLUSIVEOR)); 5600 } 5601 5602 LispObj * 5603 Lisp_SetQ(LispBuiltin *builtin) 5604 /* 5605 setq &rest form 5606 */ 5607 { 5608 LispObj *result, *variable, *form; 5609 5610 form = ARGUMENT(0); 5611 5612 result = NIL; 5613 for (; CONSP(form); form = CDR(form)) { 5614 variable = CAR(form); 5615 CHECK_SYMBOL(variable); 5616 CHECK_CONSTANT(variable); 5617 form = CDR(form); 5618 if (!CONSP(form)) 5619 LispDestroy("%s: odd number of arguments", STRFUN(builtin)); 5620 result = EVAL(CAR(form)); 5621 LispSetVar(variable, result); 5622 } 5623 5624 return (result); 5625 } 5626 5627 LispObj * 5628 Lisp_Psetq(LispBuiltin *builtin) 5629 /* 5630 psetq &rest form 5631 */ 5632 { 5633 GC_ENTER(); 5634 int base = gc__protect; 5635 LispObj *value, *symbol, *list, *form; 5636 5637 form = ARGUMENT(0); 5638 5639 /* parallel setq, first pass evaluate values and basic error checking */ 5640 for (list = form; CONSP(list); list = CDR(list)) { 5641 symbol = CAR(list); 5642 CHECK_SYMBOL(symbol); 5643 list = CDR(list); 5644 if (!CONSP(list)) 5645 LispDestroy("%s: odd number of arguments", STRFUN(builtin)); 5646 value = EVAL(CAR(list)); 5647 GC_PROTECT(value); 5648 } 5649 5650 /* second pass, assign values */ 5651 for (; CONSP(form); form = CDDR(form)) { 5652 symbol = CAR(form); 5653 CHECK_CONSTANT(symbol); 5654 LispSetVar(symbol, lisp__data.protect.objects[base++]); 5655 } 5656 GC_LEAVE(); 5657 5658 return (NIL); 5659 } 5660 5661 LispObj * 5662 Lisp_Setf(LispBuiltin *builtin) 5663 /* 5664 setf &rest form 5665 */ 5666 { 5667 LispAtom *atom; 5668 LispObj *setf, *place, *value, *result = NIL, *data; 5669 5670 LispObj *form; 5671 5672 form = ARGUMENT(0); 5673 5674 for (; CONSP(form); form = CDR(form)) { 5675 place = CAR(form); 5676 form = CDR(form); 5677 if (!CONSP(form)) 5678 LispDestroy("%s: odd number of arguments", STRFUN(builtin)); 5679 value = CAR(form); 5680 5681 if (!POINTERP(place)) 5682 goto invalid_place; 5683 if (XSYMBOLP(place)) { 5684 CHECK_CONSTANT(place); 5685 result = EVAL(value); 5686 (void)LispSetVar(place, result); 5687 } 5688 else if (XCONSP(place)) { 5689 /* it really should not be required to protect any object 5690 * evaluated here, but is done for safety in case one of 5691 * the evaluated forms returns data not gc protected, what 5692 * could cause surprises if the object is garbage collected 5693 * before finishing setf. */ 5694 GC_ENTER(); 5695 5696 setf = CAR(place); 5697 if (!SYMBOLP(setf)) 5698 goto invalid_place; 5699 if (!CONSP(CDR(place))) 5700 goto invalid_place; 5701 5702 value = EVAL(value); 5703 GC_PROTECT(value); 5704 5705 atom = setf->data.atom; 5706 if (atom->a_defsetf == 0) { 5707 if (atom->a_defstruct && 5708 atom->property->structure.function >= 0) { 5709 /* Use a default setf method for the structure field, as 5710 * if this definition have been done 5711 * (defsetf THE-STRUCT-FIELD (struct) (value) 5712 * `(lisp::struct-store 'THE-STRUCT-FIELD ,struct ,value)) 5713 */ 5714 place = CDR(place); 5715 data = CAR(place); 5716 if (CONSP(CDR(place))) 5717 goto invalid_place; 5718 data = EVAL(data); 5719 GC_PROTECT(data); 5720 result = APPLY3(Ostruct_store, setf, data, value); 5721 GC_LEAVE(); 5722 continue; 5723 } 5724 /* Must also expand macros */ 5725 else if (atom->a_function && 5726 atom->property->fun.function->funtype == LispMacro) { 5727 result = LispRunSetfMacro(atom, CDR(place), value); 5728 continue; 5729 } 5730 goto invalid_place; 5731 } 5732 5733 place = CDR(place); 5734 setf = setf->data.atom->property->setf; 5735 if (SYMBOLP(setf)) { 5736 LispObj *arguments, *cons; 5737 5738 if (!CONSP(CDR(place))) { 5739 arguments = EVAL(CAR(place)); 5740 GC_PROTECT(arguments); 5741 result = APPLY2(setf, arguments, value); 5742 } 5743 else if (!CONSP(CDDR(place))) { 5744 arguments = EVAL(CAR(place)); 5745 GC_PROTECT(arguments); 5746 cons = EVAL(CADR(place)); 5747 GC_PROTECT(cons); 5748 result = APPLY3(setf, arguments, cons, value); 5749 } 5750 else { 5751 arguments = cons = CONS(EVAL(CAR(place)), NIL); 5752 GC_PROTECT(arguments); 5753 for (place = CDR(place); CONSP(place); place = CDR(place)) { 5754 RPLACD(cons, CONS(EVAL(CAR(place)), NIL)); 5755 cons = CDR(cons); 5756 } 5757 RPLACD(cons, CONS(value, NIL)); 5758 result = APPLY(setf, arguments); 5759 } 5760 } 5761 else 5762 result = LispRunSetf(atom->property->salist, setf, place, value); 5763 GC_LEAVE(); 5764 } 5765 else 5766 goto invalid_place; 5767 } 5768 5769 return (result); 5770 invalid_place: 5771 LispDestroy("%s: %s is an invalid place", STRFUN(builtin), STROBJ(place)); 5772 /*NOTREACHED*/ 5773 return (NIL); 5774 } 5775 5776 LispObj * 5777 Lisp_Psetf(LispBuiltin *builtin) 5778 /* 5779 psetf &rest form 5780 */ 5781 { 5782 int base; 5783 GC_ENTER(); 5784 LispAtom *atom; 5785 LispObj *setf, *place = NIL, *value, *data; 5786 5787 LispObj *form; 5788 5789 form = ARGUMENT(0); 5790 5791 /* parallel setf, first pass evaluate values and basic error checking */ 5792 base = gc__protect; 5793 for (setf = form; CONSP(setf); setf = CDR(setf)) { 5794 if (!POINTERP(CAR(setf))) 5795 goto invalid_place; 5796 setf = CDR(setf); 5797 if (!CONSP(setf)) 5798 LispDestroy("%s: odd number of arguments", STRFUN(builtin)); 5799 value = EVAL(CAR(setf)); 5800 GC_PROTECT(value); 5801 } 5802 5803 /* second pass, assign values */ 5804 for (; CONSP(form); form = CDDR(form)) { 5805 place = CAR(form); 5806 value = lisp__data.protect.objects[base++]; 5807 5808 if (XSYMBOLP(place)) { 5809 CHECK_CONSTANT(place); 5810 (void)LispSetVar(place, value); 5811 } 5812 else if (XCONSP(place)) { 5813 LispObj *arguments, *cons; 5814 int xbase = lisp__data.protect.length; 5815 5816 setf = CAR(place); 5817 if (!SYMBOLP(setf)) 5818 goto invalid_place; 5819 if (!CONSP(CDR(place))) 5820 goto invalid_place; 5821 5822 atom = setf->data.atom; 5823 if (atom->a_defsetf == 0) { 5824 if (atom->a_defstruct && 5825 atom->property->structure.function >= 0) { 5826 place = CDR(place); 5827 data = CAR(place); 5828 if (CONSP(CDR(place))) 5829 goto invalid_place; 5830 data = EVAL(data); 5831 GC_PROTECT(data); 5832 (void)APPLY3(Ostruct_store, setf, data, value); 5833 lisp__data.protect.length = xbase; 5834 continue; 5835 } 5836 else if (atom->a_function && 5837 atom->property->fun.function->funtype == LispMacro) { 5838 (void)LispRunSetfMacro(atom, CDR(place), value); 5839 lisp__data.protect.length = xbase; 5840 continue; 5841 } 5842 goto invalid_place; 5843 } 5844 5845 place = CDR(place); 5846 setf = setf->data.atom->property->setf; 5847 if (SYMBOLP(setf)) { 5848 if (!CONSP(CDR(place))) { 5849 arguments = EVAL(CAR(place)); 5850 GC_PROTECT(arguments); 5851 (void)APPLY2(setf, arguments, value); 5852 } 5853 else if (!CONSP(CDDR(place))) { 5854 arguments = EVAL(CAR(place)); 5855 GC_PROTECT(arguments); 5856 cons = EVAL(CADR(place)); 5857 GC_PROTECT(cons); 5858 (void)APPLY3(setf, arguments, cons, value); 5859 } 5860 else { 5861 arguments = cons = CONS(EVAL(CAR(place)), NIL); 5862 GC_PROTECT(arguments); 5863 for (place = CDR(place); CONSP(place); place = CDR(place)) { 5864 RPLACD(cons, CONS(EVAL(CAR(place)), NIL)); 5865 cons = CDR(cons); 5866 } 5867 RPLACD(cons, CONS(value, NIL)); 5868 (void)APPLY(setf, arguments); 5869 } 5870 lisp__data.protect.length = xbase; 5871 } 5872 else 5873 (void)LispRunSetf(atom->property->salist, setf, place, value); 5874 } 5875 else 5876 goto invalid_place; 5877 } 5878 GC_LEAVE(); 5879 5880 return (NIL); 5881 invalid_place: 5882 LispDestroy("%s: %s is an invalid place", STRFUN(builtin), STROBJ(place)); 5883 /*NOTREACHED*/ 5884 return (NIL); 5885 } 5886 5887 LispObj * 5888 Lisp_Sleep(LispBuiltin *builtin) 5889 /* 5890 sleep seconds 5891 */ 5892 { 5893 long sec, msec; 5894 double value, dsec; 5895 5896 LispObj *seconds; 5897 5898 seconds = ARGUMENT(0); 5899 5900 value = -1.0; 5901 switch (OBJECT_TYPE(seconds)) { 5902 case LispFixnum_t: 5903 value = FIXNUM_VALUE(seconds); 5904 break; 5905 case LispDFloat_t: 5906 value = DFLOAT_VALUE(seconds); 5907 break; 5908 default: 5909 break; 5910 } 5911 5912 if (value < 0.0 || value > MOST_POSITIVE_FIXNUM) 5913 LispDestroy("%s: %s is not a positive fixnum", 5914 STRFUN(builtin), STROBJ(seconds)); 5915 5916 msec = modf(value, &dsec) * 1e6; 5917 sec = dsec; 5918 5919 if (sec) 5920 sleep(sec); 5921 if (msec) 5922 usleep(msec); 5923 5924 return (NIL); 5925 } 5926 5927 /* 5928 * This function is called recursively, but the contents of "list2" are 5929 * kept gc protected until it returns to LispSort. This is required partly 5930 * because the "gc protection logic" protects an object, not the contents 5931 * of the c pointer. 5932 */ 5933 static LispObj * 5934 LispMergeSort(LispObj *list, LispObj *predicate, LispObj *key, int code) 5935 { 5936 int protect; 5937 LispObj *list1, *list2, *left, *right, *result, *cons; 5938 5939 /* Check if list length is larger than 1 */ 5940 if (!CONSP(list) || !CONSP(CDR(list))) 5941 return (list); 5942 5943 list1 = list2 = list; 5944 for (;;) { 5945 list = CDR(list); 5946 if (!CONSP(list)) 5947 break; 5948 list = CDR(list); 5949 if (!CONSP(list)) 5950 break; 5951 list2 = CDR(list2); 5952 } 5953 cons = list2; 5954 list2 = CDR(list2); 5955 RPLACD(cons, NIL); 5956 5957 protect = 0; 5958 if (lisp__data.protect.length + 2 >= lisp__data.protect.space) 5959 LispMoreProtects(); 5960 lisp__data.protect.objects[lisp__data.protect.length++] = list2; 5961 list1 = LispMergeSort(list1, predicate, key, code); 5962 list2 = LispMergeSort(list2, predicate, key, code); 5963 5964 left = CAR(list1); 5965 right = CAR(list2); 5966 if (key != UNSPEC) { 5967 protect = lisp__data.protect.length; 5968 left = APPLY1(key, left); 5969 lisp__data.protect.objects[protect] = left; 5970 right = APPLY1(key, right); 5971 lisp__data.protect.objects[protect + 1] = right; 5972 } 5973 5974 result = NIL; 5975 for (;;) { 5976 if ((FCOMPARE(predicate, left, right, code)) == 0 && 5977 (FCOMPARE(predicate, right, left, code)) == 1) { 5978 /* right is "smaller" */ 5979 if (result == NIL) 5980 result = list2; 5981 else 5982 RPLACD(cons, list2); 5983 cons = list2; 5984 list2 = CDR(list2); 5985 if (!CONSP(list2)) { 5986 RPLACD(cons, list1); 5987 break; 5988 } 5989 right = CAR(list2); 5990 if (key != UNSPEC) { 5991 right = APPLY1(key, right); 5992 lisp__data.protect.objects[protect + 1] = right; 5993 } 5994 } 5995 else { 5996 /* left is "smaller" */ 5997 if (result == NIL) 5998 result = list1; 5999 else 6000 RPLACD(cons, list1); 6001 cons = list1; 6002 list1 = CDR(list1); 6003 if (!CONSP(list1)) { 6004 RPLACD(cons, list2); 6005 break; 6006 } 6007 left = CAR(list1); 6008 if (key != UNSPEC) { 6009 left = APPLY1(key, left); 6010 lisp__data.protect.objects[protect] = left; 6011 } 6012 } 6013 } 6014 if (key != UNSPEC) 6015 lisp__data.protect.length = protect; 6016 6017 return (result); 6018 } 6019 6020 /* XXX The first version made a copy of the list and then adjusted 6021 * the CARs of the list. To minimize GC time now it is now doing 6022 * the sort inplace. So, instead of writing just (sort variable) 6023 * now it is required to write (setq variable (sort variable)) 6024 * if the variable should always keep all elements. 6025 */ 6026 LispObj * 6027 Lisp_Sort(LispBuiltin *builtin) 6028 /* 6029 sort sequence predicate &key key 6030 */ 6031 { 6032 GC_ENTER(); 6033 int istring, code; 6034 long length; 6035 char *string; 6036 6037 LispObj *list, *work, *cons = NULL; 6038 6039 LispObj *sequence, *predicate, *key; 6040 6041 key = ARGUMENT(2); 6042 predicate = ARGUMENT(1); 6043 sequence = ARGUMENT(0); 6044 6045 length = LispLength(sequence); 6046 if (length < 2) 6047 return (sequence); 6048 6049 list = sequence; 6050 istring = XSTRINGP(sequence); 6051 if (istring) { 6052 CHECK_STRING_WRITABLE(sequence); 6053 /* Convert string to list */ 6054 string = THESTR(sequence); 6055 work = cons = CONS(SCHAR(string[0]), NIL); 6056 GC_PROTECT(work); 6057 for (++string; *string; ++string) { 6058 RPLACD(cons, CONS(SCHAR(*string), NIL)); 6059 cons = CDR(cons); 6060 } 6061 } 6062 else if (ARRAYP(list)) 6063 work = list->data.array.list; 6064 else 6065 work = list; 6066 6067 FUNCTION_CHECK(predicate); 6068 code = FCODE(predicate); 6069 work = LispMergeSort(work, predicate, key, code); 6070 6071 if (istring) { 6072 /* Convert list to string */ 6073 string = THESTR(sequence); 6074 for (; CONSP(work); ++string, work = CDR(work)) 6075 *string = SCHAR_VALUE(CAR(work)); 6076 } 6077 else if (ARRAYP(list)) 6078 list->data.array.list = work; 6079 else 6080 sequence = work; 6081 GC_LEAVE(); 6082 6083 return (sequence); 6084 } 6085 6086 LispObj * 6087 Lisp_Subseq(LispBuiltin *builtin) 6088 /* 6089 subseq sequence start &optional end 6090 */ 6091 { 6092 long start, end, length, seqlength; 6093 6094 LispObj *sequence, *ostart, *oend, *result; 6095 6096 oend = ARGUMENT(2); 6097 ostart = ARGUMENT(1); 6098 sequence = ARGUMENT(0); 6099 6100 LispCheckSequenceStartEnd(builtin, sequence, ostart, oend, 6101 &start, &end, &length); 6102 6103 seqlength = end - start; 6104 6105 if (sequence == NIL) 6106 result = NIL; 6107 else if (XSTRINGP(sequence)) { 6108 char *string = LispMalloc(seqlength + 1); 6109 6110 memcpy(string, THESTR(sequence) + start, seqlength); 6111 string[seqlength] = '\0'; 6112 result = STRING2(string); 6113 } 6114 else { 6115 GC_ENTER(); 6116 LispObj *object; 6117 6118 if (end > start) { 6119 /* list or array */ 6120 int count; 6121 LispObj *cons; 6122 6123 if (ARRAYP(sequence)) 6124 object = sequence->data.array.list; 6125 else 6126 object = sequence; 6127 /* goto first element to copy */ 6128 for (count = 0; count < start; count++, object = CDR(object)) 6129 ; 6130 result = cons = CONS(CAR(object), NIL); 6131 GC_PROTECT(result); 6132 for (++count, object = CDR(object); count < end; count++, 6133 object = CDR(object)) { 6134 RPLACD(cons, CONS(CAR(object), NIL)); 6135 cons = CDR(cons); 6136 } 6137 } 6138 else 6139 result = NIL; 6140 6141 if (ARRAYP(sequence)) { 6142 object = LispNew(NIL, NIL); 6143 GC_PROTECT(object); 6144 object->type = LispArray_t; 6145 object->data.array.list = result; 6146 object->data.array.dim = CONS(FIXNUM(seqlength), NIL); 6147 object->data.array.rank = 1; 6148 object->data.array.type = sequence->data.array.type; 6149 object->data.array.zero = length == 0; 6150 result = object; 6151 } 6152 GC_LEAVE(); 6153 } 6154 6155 return (result); 6156 } 6157 6158 LispObj * 6159 Lisp_Subsetp(LispBuiltin *builtin) 6160 /* 6161 subsetp list1 list2 &key test test-not key 6162 */ 6163 { 6164 return (LispListSet(builtin, SUBSETP)); 6165 } 6166 6167 6168 LispObj * 6169 Lisp_Substitute(LispBuiltin *builtin) 6170 /* 6171 substitute newitem olditem sequence &key from-end test test-not start end count key 6172 */ 6173 { 6174 return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, NONE)); 6175 } 6176 6177 LispObj * 6178 Lisp_SubstituteIf(LispBuiltin *builtin) 6179 /* 6180 substitute-if newitem test sequence &key from-end start end count key 6181 */ 6182 { 6183 return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, IF)); 6184 } 6185 6186 LispObj * 6187 Lisp_SubstituteIfNot(LispBuiltin *builtin) 6188 /* 6189 substitute-if-not newitem test sequence &key from-end start end count key 6190 */ 6191 { 6192 return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, IFNOT)); 6193 } 6194 6195 LispObj * 6196 Lisp_Symbolp(LispBuiltin *builtin) 6197 /* 6198 symbolp object 6199 */ 6200 { 6201 LispObj *object; 6202 6203 object = ARGUMENT(0); 6204 6205 return (SYMBOLP(object) ? T : NIL); 6206 } 6207 6208 LispObj * 6209 Lisp_SymbolFunction(LispBuiltin *builtin) 6210 /* 6211 symbol-function symbol 6212 */ 6213 { 6214 LispObj *symbol; 6215 6216 symbol = ARGUMENT(0); 6217 CHECK_SYMBOL(symbol); 6218 6219 return (LispSymbolFunction(symbol)); 6220 } 6221 6222 LispObj * 6223 Lisp_SymbolName(LispBuiltin *builtin) 6224 /* 6225 symbol-name symbol 6226 */ 6227 { 6228 LispObj *symbol; 6229 6230 symbol = ARGUMENT(0); 6231 CHECK_SYMBOL(symbol); 6232 6233 return (LispSymbolName(symbol)); 6234 } 6235 6236 LispObj * 6237 Lisp_SymbolPackage(LispBuiltin *builtin) 6238 /* 6239 symbol-package symbol 6240 */ 6241 { 6242 LispObj *symbol; 6243 6244 symbol = ARGUMENT(0); 6245 CHECK_SYMBOL(symbol); 6246 6247 symbol = symbol->data.atom->package; 6248 6249 return (symbol ? symbol : NIL); 6250 } 6251 6252 LispObj * 6253 Lisp_SymbolPlist(LispBuiltin *builtin) 6254 /* 6255 symbol-plist symbol 6256 */ 6257 { 6258 LispObj *symbol; 6259 6260 symbol = ARGUMENT(0); 6261 6262 CHECK_SYMBOL(symbol); 6263 6264 return (symbol->data.atom->a_property ? 6265 symbol->data.atom->property->properties : NIL); 6266 } 6267 6268 LispObj * 6269 Lisp_SymbolValue(LispBuiltin *builtin) 6270 /* 6271 symbol-value symbol 6272 */ 6273 { 6274 LispAtom *atom; 6275 LispObj *symbol; 6276 6277 symbol = ARGUMENT(0); 6278 6279 CHECK_SYMBOL(symbol); 6280 atom = symbol->data.atom; 6281 if (!atom->a_object || atom->property->value == UNBOUND) { 6282 if (atom->package == lisp__data.keyword) 6283 return (symbol); 6284 LispDestroy("%s: the symbol %s has no value", 6285 STRFUN(builtin), STROBJ(symbol)); 6286 } 6287 6288 return (atom->dyn ? LispGetVar(symbol) : atom->property->value); 6289 } 6290 6291 LispObj * 6292 Lisp_Tagbody(LispBuiltin *builtin) 6293 /* 6294 tagbody &rest body 6295 */ 6296 { 6297 GC_ENTER(); 6298 int stack, lex, length; 6299 LispObj *list, *body, *ptr, *tag, *labels, *map, **p_body; 6300 LispBlock *block; 6301 6302 body = ARGUMENT(0); 6303 6304 /* Save environment information */ 6305 stack = lisp__data.stack.length; 6306 lex = lisp__data.env.lex; 6307 length = lisp__data.env.length; 6308 6309 /* Since the body may be large, and the code may iterate several 6310 * thousand times, it is not a bad idea to avoid checking all 6311 * elements of the body to verify if it is a tag. */ 6312 for (labels = map = NIL, ptr = body; CONSP(ptr); ptr = CDR(ptr)) { 6313 tag = CAR(ptr); 6314 switch (OBJECT_TYPE(tag)) { 6315 case LispNil_t: 6316 case LispAtom_t: 6317 case LispFixnum_t: 6318 /* Don't allow duplicated labels */ 6319 for (list = labels; CONSP(list); list = CDDR(list)) { 6320 if (CAR(list) == tag) 6321 LispDestroy("%s: tag %s specified more than once", 6322 STRFUN(builtin), STROBJ(tag)); 6323 } 6324 if (labels == NIL) { 6325 labels = CONS(tag, CONS(NIL, NIL)); 6326 map = CDR(labels); 6327 GC_PROTECT(labels); 6328 } 6329 else { 6330 RPLACD(map, CONS(tag, CONS(NIL, NIL))); 6331 map = CDDR(map); 6332 } 6333 break; 6334 case LispCons_t: 6335 /* Restart point for tag */ 6336 if (map != NIL && CAR(map) == NIL) 6337 RPLACA(map, ptr); 6338 break; 6339 default: 6340 break; 6341 } 6342 } 6343 /* Check for consecutive labels without code between them */ 6344 for (ptr = labels; CONSP(ptr); ptr = CDDR(ptr)) { 6345 if (CADR(ptr) == NIL) { 6346 for (map = CDDR(ptr); CONSP(map); map = CDDR(map)) { 6347 if (CADR(map) != NIL) { 6348 RPLACA(CDR(ptr), CADR(map)); 6349 break; 6350 } 6351 } 6352 } 6353 } 6354 6355 /* Initialize */ 6356 list = body; 6357 p_body = &body; 6358 block = LispBeginBlock(NIL, LispBlockBody); 6359 6360 /* Loop */ 6361 if (setjmp(block->jmp) != 0) { 6362 /* Restore environment */ 6363 lisp__data.stack.length = stack; 6364 lisp__data.env.lex = lex; 6365 lisp__data.env.head = lisp__data.env.length = length; 6366 6367 tag = lisp__data.block.block_ret; 6368 for (ptr = labels; CONSP(ptr); ptr = CDDR(ptr)) { 6369 map = CAR(ptr); 6370 if (map == tag) 6371 break; 6372 } 6373 6374 if (!CONSP(ptr)) 6375 LispDestroy("%s: no such tag %s", STRFUN(builtin), STROBJ(tag)); 6376 6377 *p_body = CADR(ptr); 6378 } 6379 6380 /* Execute code */ 6381 for (; CONSP(body); body = CDR(body)) { 6382 LispObj *form = CAR(body); 6383 6384 if (CONSP(form)) 6385 EVAL(form); 6386 } 6387 /* If got here, (go) not called, else, labels will be candidate to gc 6388 * when GC_LEAVE() be called by the code in the bottom of the stack. */ 6389 GC_LEAVE(); 6390 6391 /* Finished */ 6392 LispEndBlock(block); 6393 6394 /* Always return NIL */ 6395 return (NIL); 6396 } 6397 6398 LispObj * 6399 Lisp_The(LispBuiltin *builtin) 6400 /* 6401 the value-type form 6402 */ 6403 { 6404 LispObj *value_type, *form; 6405 6406 form = ARGUMENT(1); 6407 value_type = ARGUMENT(0); 6408 6409 form = EVAL(form); 6410 6411 return (LispCoerce(builtin, form, value_type)); 6412 } 6413 6414 LispObj * 6415 Lisp_Throw(LispBuiltin *builtin) 6416 /* 6417 throw tag result 6418 */ 6419 { 6420 unsigned blevel = lisp__data.block.block_level; 6421 6422 LispObj *tag, *result; 6423 6424 result = ARGUMENT(1); 6425 tag = ARGUMENT(0); 6426 6427 tag = EVAL(tag); 6428 6429 if (blevel == 0) 6430 LispDestroy("%s: not within a block", STRFUN(builtin)); 6431 6432 while (blevel) { 6433 LispBlock *block = lisp__data.block.block[--blevel]; 6434 6435 if (block->type == LispBlockCatch && tag == block->tag) { 6436 lisp__data.block.block_ret = EVAL(result); 6437 LispBlockUnwind(block); 6438 BLOCKJUMP(block); 6439 } 6440 } 6441 LispDestroy("%s: %s is not a valid tag", STRFUN(builtin), STROBJ(tag)); 6442 6443 /*NOTREACHED*/ 6444 return (NIL); 6445 } 6446 6447 static LispObj * 6448 LispTreeEqual(LispObj *left, LispObj *right, LispObj *test, int expect) 6449 { 6450 LispObj *cmp_left, *cmp_right; 6451 6452 if ((OBJECT_TYPE(left)) ^ (OBJECT_TYPE(right))) 6453 return (NIL); 6454 if (CONSP(left)) { 6455 for (; CONSP(left) && CONSP(right); 6456 left = CDR(left), right = CDR(right)) { 6457 cmp_left = CAR(left); 6458 cmp_right = CAR(right); 6459 if ((OBJECT_TYPE(cmp_left)) ^ (OBJECT_TYPE(cmp_right))) 6460 return (NIL); 6461 if (CONSP(cmp_left)) { 6462 if (LispTreeEqual(cmp_left, cmp_right, test, expect) == NIL) 6463 return (NIL); 6464 } 6465 else { 6466 if (POINTERP(cmp_left) && 6467 (XQUOTEP(cmp_left) || XBACKQUOTEP(cmp_left))) { 6468 cmp_left = cmp_left->data.quote; 6469 cmp_right = cmp_right->data.quote; 6470 } 6471 else if (COMMAP(cmp_left)) { 6472 cmp_left = cmp_left->data.comma.eval; 6473 cmp_right = cmp_right->data.comma.eval; 6474 } 6475 if ((APPLY2(test, cmp_left, cmp_right) != NIL) != expect) 6476 return (NIL); 6477 } 6478 } 6479 if ((OBJECT_TYPE(left)) ^ (OBJECT_TYPE(right))) 6480 return (NIL); 6481 } 6482 6483 if (POINTERP(left) && (XQUOTEP(left) || XBACKQUOTEP(left))) { 6484 left = left->data.quote; 6485 right = right->data.quote; 6486 } 6487 else if (COMMAP(left)) { 6488 left = left->data.comma.eval; 6489 right = right->data.comma.eval; 6490 } 6491 6492 return ((APPLY2(test, left, right) != NIL) == expect ? T : NIL); 6493 } 6494 6495 LispObj * 6496 Lisp_TreeEqual(LispBuiltin *builtin) 6497 /* 6498 tree-equal tree-1 tree-2 &key test test-not 6499 */ 6500 { 6501 int expect; 6502 LispObj *compare; 6503 6504 LispObj *tree_1, *tree_2, *test, *test_not; 6505 6506 test_not = ARGUMENT(3); 6507 test = ARGUMENT(2); 6508 tree_2 = ARGUMENT(1); 6509 tree_1 = ARGUMENT(0); 6510 6511 CHECK_TEST_0(); 6512 if (test_not != UNSPEC) { 6513 expect = 0; 6514 compare = test_not; 6515 } 6516 else { 6517 if (test == UNSPEC) 6518 test = Oeql; 6519 expect = 1; 6520 compare = test; 6521 } 6522 6523 return (LispTreeEqual(tree_1, tree_2, compare, expect)); 6524 } 6525 6526 LispObj * 6527 Lisp_Typep(LispBuiltin *builtin) 6528 /* 6529 typep object type 6530 */ 6531 { 6532 LispObj *result = NULL; 6533 6534 LispObj *object, *type; 6535 6536 type = ARGUMENT(1); 6537 object = ARGUMENT(0); 6538 6539 if (SYMBOLP(type)) { 6540 Atom_id atom = ATOMID(type); 6541 6542 if (OBJECT_TYPE(object) == LispStruct_t) 6543 result = ATOMID(CAR(object->data.struc.def)) == atom ? T : NIL; 6544 else if (type->data.atom->a_defstruct && 6545 type->data.atom->property->structure.function == STRUCT_NAME) 6546 result = NIL; 6547 else if (atom == Snil) 6548 result = object == NIL ? T : NIL; 6549 else if (atom == St) 6550 result = object == T ? T : NIL; 6551 else if (atom == Satom) 6552 result = !CONSP(object) ? T : NIL; 6553 else if (atom == Ssymbol) 6554 result = SYMBOLP(object) || object == NIL || object == T ? T : NIL; 6555 else if (atom == Sinteger) 6556 result = INTEGERP(object) ? T : NIL; 6557 else if (atom == Srational) 6558 result = RATIONALP(object) ? T : NIL; 6559 else if (atom == Scons || atom == Slist) 6560 result = CONSP(object) ? T : NIL; 6561 else if (atom == Sstring) 6562 result = STRINGP(object) ? T : NIL; 6563 else if (atom == Scharacter) 6564 result = SCHARP(object) ? T : NIL; 6565 else if (atom == Scomplex) 6566 result = COMPLEXP(object) ? T : NIL; 6567 else if (atom == Svector || atom == Sarray) 6568 result = ARRAYP(object) ? T : NIL; 6569 else if (atom == Skeyword) 6570 result = KEYWORDP(object) ? T : NIL; 6571 else if (atom == Sfunction) 6572 result = LAMBDAP(object) ? T : NIL; 6573 else if (atom == Spathname) 6574 result = PATHNAMEP(object) ? T : NIL; 6575 else if (atom == Sopaque) 6576 result = OPAQUEP(object) ? T : NIL; 6577 } 6578 else if (CONSP(type)) { 6579 if (OBJECT_TYPE(object) == LispStruct_t && 6580 SYMBOLP(CAR(type)) && ATOMID(CAR(type)) == Sstruct && 6581 SYMBOLP(CAR(CDR(type))) && CDR(CDR(type)) == NIL) { 6582 result = ATOMID(CAR(object->data.struc.def)) == 6583 ATOMID(CAR(CDR(type))) ? T : NIL; 6584 } 6585 } 6586 else if (type == NIL) 6587 result = object == NIL ? T : NIL; 6588 else if (type == T) 6589 result = object == T ? T : NIL; 6590 if (result == NULL) 6591 LispDestroy("%s: bad type specification %s", 6592 STRFUN(builtin), STROBJ(type)); 6593 6594 return (result); 6595 } 6596 6597 LispObj * 6598 Lisp_Union(LispBuiltin *builtin) 6599 /* 6600 union list1 list2 &key test test-not key 6601 */ 6602 { 6603 return (LispListSet(builtin, UNION)); 6604 } 6605 6606 LispObj * 6607 Lisp_Nunion(LispBuiltin *builtin) 6608 /* 6609 nunion list1 list2 &key test test-not key 6610 */ 6611 { 6612 return (LispListSet(builtin, NUNION)); 6613 } 6614 6615 LispObj * 6616 Lisp_Unless(LispBuiltin *builtin) 6617 /* 6618 unless test &rest body 6619 */ 6620 { 6621 LispObj *result, *test, *body; 6622 6623 body = ARGUMENT(1); 6624 test = ARGUMENT(0); 6625 6626 result = NIL; 6627 test = EVAL(test); 6628 RETURN_COUNT = 0; 6629 if (test == NIL) { 6630 for (; CONSP(body); body = CDR(body)) 6631 result = EVAL(CAR(body)); 6632 } 6633 6634 return (result); 6635 } 6636 6637 /* 6638 * ext::until 6639 */ 6640 LispObj * 6641 Lisp_Until(LispBuiltin *builtin) 6642 /* 6643 until test &rest body 6644 */ 6645 { 6646 LispObj *result, *test, *body, *prog; 6647 6648 body = ARGUMENT(1); 6649 test = ARGUMENT(0); 6650 6651 result = NIL; 6652 for (;;) { 6653 if ((result = EVAL(test)) == NIL) { 6654 for (prog = body; CONSP(prog); prog = CDR(prog)) 6655 (void)EVAL(CAR(prog)); 6656 } 6657 else 6658 break; 6659 } 6660 6661 return (result); 6662 } 6663 6664 LispObj * 6665 Lisp_UnwindProtect(LispBuiltin *builtin) 6666 /* 6667 unwind-protect protect &rest cleanup 6668 */ 6669 { 6670 LispObj *result, **presult = &result; 6671 int did_jump, *pdid_jump = &did_jump, destroyed; 6672 LispBlock *block; 6673 6674 LispObj *protect, *cleanup, **pcleanup = &cleanup; 6675 6676 cleanup = ARGUMENT(1); 6677 protect = ARGUMENT(0); 6678 6679 /* run protected code */ 6680 *presult = NIL; 6681 *pdid_jump = 1; 6682 block = LispBeginBlock(NIL, LispBlockProtect); 6683 if (setjmp(block->jmp) == 0) { 6684 *presult = EVAL(protect); 6685 *pdid_jump = 0; 6686 } 6687 LispEndBlock(block); 6688 if (!lisp__data.destroyed && *pdid_jump) 6689 *presult = lisp__data.block.block_ret; 6690 6691 destroyed = lisp__data.destroyed; 6692 lisp__data.destroyed = 0; 6693 6694 /* run cleanup, unprotected code */ 6695 if (CONSP(*pcleanup)) 6696 for (; CONSP(cleanup); cleanup = CDR(cleanup)) 6697 (void)EVAL(CAR(cleanup)); 6698 6699 if (destroyed) { 6700 /* in case there is another unwind-protect */ 6701 LispBlockUnwind(NULL); 6702 /* if not, just return to the toplevel */ 6703 lisp__data.destroyed = 1; 6704 LispDestroy("."); 6705 } 6706 6707 return (result); 6708 } 6709 6710 static LispObj * 6711 LispValuesList(LispBuiltin *builtin, int check_list) 6712 { 6713 long i, count; 6714 LispObj *result; 6715 6716 LispObj *list; 6717 6718 list = ARGUMENT(0); 6719 6720 count = LispLength(list) - 1; 6721 6722 if (count >= 0) { 6723 result = CAR(list); 6724 if ((RETURN_CHECK(count)) != count) 6725 LispDestroy("%s: too many values", STRFUN(builtin)); 6726 RETURN_COUNT = count; 6727 for (i = 0, list = CDR(list); count && CONSP(list); 6728 count--, i++, list = CDR(list)) 6729 RETURN(i) = CAR(list); 6730 if (check_list) { 6731 CHECK_LIST(list); 6732 } 6733 } 6734 else { 6735 RETURN_COUNT = -1; 6736 result = NIL; 6737 } 6738 6739 return (result); 6740 } 6741 6742 LispObj * 6743 Lisp_Values(LispBuiltin *builtin) 6744 /* 6745 values &rest objects 6746 */ 6747 { 6748 return (LispValuesList(builtin, 0)); 6749 } 6750 6751 LispObj * 6752 Lisp_ValuesList(LispBuiltin *builtin) 6753 /* 6754 values-list list 6755 */ 6756 { 6757 return (LispValuesList(builtin, 1)); 6758 } 6759 6760 LispObj * 6761 Lisp_Vector(LispBuiltin *builtin) 6762 /* 6763 vector &rest objects 6764 */ 6765 { 6766 LispObj *objects; 6767 6768 objects = ARGUMENT(0); 6769 6770 return (VECTOR(objects)); 6771 } 6772 6773 LispObj * 6774 Lisp_When(LispBuiltin *builtin) 6775 /* 6776 when test &rest body 6777 */ 6778 { 6779 LispObj *result, *test, *body; 6780 6781 body = ARGUMENT(1); 6782 test = ARGUMENT(0); 6783 6784 result = NIL; 6785 test = EVAL(test); 6786 RETURN_COUNT = 0; 6787 if (test != NIL) { 6788 for (; CONSP(body); body = CDR(body)) 6789 result = EVAL(CAR(body)); 6790 } 6791 6792 return (result); 6793 } 6794 6795 /* 6796 * ext::while 6797 */ 6798 LispObj * 6799 Lisp_While(LispBuiltin *builtin) 6800 /* 6801 while test &rest body 6802 */ 6803 { 6804 LispObj *test, *body, *prog; 6805 6806 body = ARGUMENT(1); 6807 test = ARGUMENT(0); 6808 6809 for (;;) { 6810 if (EVAL(test) != NIL) { 6811 for (prog = body; CONSP(prog); prog = CDR(prog)) 6812 (void)EVAL(CAR(prog)); 6813 } 6814 else 6815 break; 6816 } 6817 6818 return (NIL); 6819 } 6820 6821 /* 6822 * ext::unsetenv 6823 */ 6824 LispObj * 6825 Lisp_Unsetenv(LispBuiltin *builtin) 6826 /* 6827 unsetenv name 6828 */ 6829 { 6830 char *name; 6831 6832 LispObj *oname; 6833 6834 oname = ARGUMENT(0); 6835 6836 CHECK_STRING(oname); 6837 name = THESTR(oname); 6838 6839 unsetenv(name); 6840 6841 return (NIL); 6842 } 6843 6844 LispObj * 6845 Lisp_XeditEltStore(LispBuiltin *builtin) 6846 /* 6847 lisp::elt-store sequence index value 6848 */ 6849 { 6850 int length, offset; 6851 6852 LispObj *sequence, *oindex, *value; 6853 6854 value = ARGUMENT(2); 6855 oindex = ARGUMENT(1); 6856 sequence = ARGUMENT(0); 6857 6858 CHECK_INDEX(oindex); 6859 offset = FIXNUM_VALUE(oindex); 6860 length = LispLength(sequence); 6861 6862 if (offset >= length) 6863 LispDestroy("%s: index %d too large for sequence length %d", 6864 STRFUN(builtin), offset, length); 6865 6866 if (STRINGP(sequence)) { 6867 int ch; 6868 6869 CHECK_STRING_WRITABLE(sequence); 6870 CHECK_SCHAR(value); 6871 ch = SCHAR_VALUE(value); 6872 if (ch < 0 || ch > 255) 6873 LispDestroy("%s: cannot represent character %d", 6874 STRFUN(builtin), ch); 6875 THESTR(sequence)[offset] = ch; 6876 } 6877 else { 6878 if (ARRAYP(sequence)) 6879 sequence = sequence->data.array.list; 6880 6881 for (; offset > 0; offset--, sequence = CDR(sequence)) 6882 ; 6883 RPLACA(sequence, value); 6884 } 6885 6886 return (value); 6887 } 6888 6889 LispObj * 6890 Lisp_XeditPut(LispBuiltin *builtin) 6891 /* 6892 lisp::put symbol indicator value 6893 */ 6894 { 6895 LispObj *symbol, *indicator, *value; 6896 6897 value = ARGUMENT(2); 6898 indicator = ARGUMENT(1); 6899 symbol = ARGUMENT(0); 6900 6901 CHECK_SYMBOL(symbol); 6902 6903 return (CAR(LispPutAtomProperty(symbol->data.atom, indicator, value))); 6904 } 6905 6906 LispObj * 6907 Lisp_XeditSetSymbolPlist(LispBuiltin *builtin) 6908 /* 6909 lisp::set-symbol-plist symbol list 6910 */ 6911 { 6912 LispObj *symbol, *list; 6913 6914 list = ARGUMENT(1); 6915 symbol = ARGUMENT(0); 6916 6917 CHECK_SYMBOL(symbol); 6918 6919 return (LispReplaceAtomPropertyList(symbol->data.atom, list)); 6920 } 6921 6922 LispObj * 6923 Lisp_XeditVectorStore(LispBuiltin *builtin) 6924 /* 6925 lisp::vector-store array &rest values 6926 */ 6927 { 6928 LispObj *value, *list, *object; 6929 long rank, count, sequence, offset, accum; 6930 6931 LispObj *array, *values; 6932 6933 values = ARGUMENT(1); 6934 array = ARGUMENT(0); 6935 6936 /* check for errors */ 6937 for (rank = 0, list = values; 6938 CONSP(list) && CONSP(CDR(list)); 6939 list = CDR(list), rank++) { 6940 CHECK_INDEX(CAR(values)); 6941 } 6942 6943 if (rank == 0) 6944 LispDestroy("%s: too few subscripts", STRFUN(builtin)); 6945 value = CAR(list); 6946 6947 if (STRINGP(array) && rank == 1) { 6948 long ch; 6949 long length = STRLEN(array); 6950 long offset = FIXNUM_VALUE(CAR(values)); 6951 6952 CHECK_SCHAR(value); 6953 CHECK_STRING_WRITABLE(array); 6954 ch = SCHAR_VALUE(value); 6955 if (offset >= length) 6956 LispDestroy("%s: index %ld too large for sequence length %ld", 6957 STRFUN(builtin), offset, length); 6958 6959 if (ch < 0 || ch > 255) 6960 LispDestroy("%s: cannot represent character %ld", 6961 STRFUN(builtin), ch); 6962 THESTR(array)[offset] = ch; 6963 6964 return (value); 6965 } 6966 6967 CHECK_ARRAY(array); 6968 if (rank != array->data.array.rank) 6969 LispDestroy("%s: too %s subscripts", STRFUN(builtin), 6970 rank < array->data.array.rank ? "few" : "many"); 6971 6972 for (list = values, object = array->data.array.dim; 6973 CONSP(CDR(list)); 6974 list = CDR(list), object = CDR(object)) { 6975 if (FIXNUM_VALUE(CAR(list)) >= FIXNUM_VALUE(CAR(object))) 6976 LispDestroy("%s: %ld is out of range, index %ld", 6977 STRFUN(builtin), 6978 FIXNUM_VALUE(CAR(list)), 6979 FIXNUM_VALUE(CAR(object))); 6980 } 6981 6982 for (count = sequence = 0, list = values; 6983 CONSP(CDR(list)); 6984 list = CDR(list), sequence++) { 6985 for (offset = 0, object = array->data.array.dim; 6986 offset < sequence; object = CDR(object), offset++) 6987 ; 6988 for (accum = 1, object = CDR(object); CONSP(object); 6989 object = CDR(object)) 6990 accum *= FIXNUM_VALUE(CAR(object)); 6991 count += accum * FIXNUM_VALUE(CAR(list)); 6992 } 6993 6994 for (array = array->data.array.list; count > 0; array = CDR(array), count--) 6995 ; 6996 6997 RPLACA(array, value); 6998 6999 return (value); 7000 } 7001 7002 LispObj * 7003 Lisp_XeditDocumentationStore(LispBuiltin *builtin) 7004 /* 7005 lisp::documentation-store symbol type string 7006 */ 7007 { 7008 LispDocType_t doc_type; 7009 7010 LispObj *symbol, *type, *string; 7011 7012 string = ARGUMENT(2); 7013 type = ARGUMENT(1); 7014 symbol = ARGUMENT(0); 7015 7016 CHECK_SYMBOL(symbol); 7017 7018 /* type is checked in LispDocumentationType() */ 7019 doc_type = LispDocumentationType(builtin, type); 7020 7021 if (string == NIL) 7022 /* allow explicitly releasing memory used for documentation */ 7023 LispRemDocumentation(symbol, doc_type); 7024 else { 7025 CHECK_STRING(string); 7026 LispAddDocumentation(symbol, string, doc_type); 7027 } 7028 7029 return (string); 7030 } 7031
Indexes created Wed Jul 01 00:25:26 UTC 2026