1 /* 2 * Copyright (c) 2002 by The XFree86 Project, Inc. 3 * 4 * Permission is hereby granted, free of charge, to any person obtaining a 5 * copy of this software and associated documentation files (the "Software"), 6 * to deal in the Software without restriction, including without limitation 7 * the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 * and/or sell copies of the Software, and to permit persons to whom the 9 * Software is furnished to do so, subject to the following conditions: 10 * 11 * The above copyright notice and this permission notice shall be included in 12 * all copies or substantial portions of the Software. 13 * 14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 17 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 18 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF 19 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 20 * SOFTWARE. 21 * 22 * Except as contained in this notice, the name of the XFree86 Project shall 23 * not be used in advertising or otherwise to promote the sale, use or other 24 * dealings in this Software without prior written authorization from the 25 * XFree86 Project. 26 * 27 * Author: Paulo Csar Pereira de Andrade 28 */ 29 30 /* $XFree86: xc/programs/xedit/lisp/compile.c,v 1.15tsi Exp $ */ 31 32 #define VARIABLE_USED 0x0001 33 #define VARIABLE_ARGUMENT 0x0002 34 35 /* 36 * Prototypes 37 */ 38 static void ComPredicate(LispCom*, LispBuiltin*, LispBytePredicate); 39 static void ComReturnFrom(LispCom*, LispBuiltin*, int); 40 41 static int ComConstantp(LispCom*, LispObj*); 42 static void ComAddVariable(LispCom*, LispObj*, LispObj*); 43 static int ComGetVariable(LispCom*, LispObj*); 44 static void ComVariableSetFlag(LispCom*, LispAtom*, int); 45 #define COM_VARIABLE_USED(atom) \ 46 ComVariableSetFlag(com, atom, VARIABLE_USED) 47 #define COM_VARIABLE_ARGUMENT(atom) \ 48 ComVariableSetFlag(com, atom, VARIABLE_ARGUMENT) 49 50 static int FindIndex(void*, void**, int); 51 static int compare(const void*, const void*); 52 static int BuildTablePointer(void*, void***, int*); 53 54 static void ComLabel(LispCom*, LispObj*); 55 static void ComPush(LispCom*, LispObj*, LispObj*, int, int, int); 56 static int ComCall(LispCom*, LispArgList*, LispObj*, LispObj*, int, int, int); 57 static void ComFuncall(LispCom*, LispObj*, LispObj*, int); 58 static void ComProgn(LispCom*, LispObj*); 59 static void ComEval(LispCom*, LispObj*); 60 61 static void ComRecursiveCall(LispCom*, LispArgList*, LispObj*, LispObj*); 62 static void ComInlineCall(LispCom*, LispArgList*, LispObj*, LispObj*, LispObj*); 63 64 static void ComMacroBackquote(LispCom*, LispObj*); 65 static void ComMacroCall(LispCom*, LispArgList*, LispObj*, LispObj*, LispObj*); 66 static LispObj *ComMacroExpandBackquote(LispCom*, LispObj*); 67 static LispObj *ComMacroExpand(LispCom*, LispObj*); 68 static LispObj *ComMacroExpandFuncall(LispCom*, LispObj*, LispObj*); 69 static LispObj *ComMacroExpandEval(LispCom*, LispObj*); 70 71 /* 72 * Implementation 73 */ 74 void 75 Com_And(LispCom *com, LispBuiltin *builtin) 76 /* 77 and &rest args 78 */ 79 { 80 LispObj *args; 81 82 args = ARGUMENT(0); 83 84 if (CONSP(args)) { 85 /* Evaluate first argument */ 86 ComEval(com, CAR(args)); 87 args = CDR(args); 88 89 /* If more than one argument, create jump list */ 90 if (CONSP(args)) { 91 CodeTree *tree = NULL, *group; 92 93 group = NEW_TREE(CodeTreeJumpIf); 94 group->code = XBC_JUMPNIL; 95 96 for (; CONSP(args); args = CDR(args)) { 97 ComEval(com, CAR(args)); 98 tree = NEW_TREE(CodeTreeJumpIf); 99 tree->code = XBC_JUMPNIL; 100 group->group = tree; 101 group = tree; 102 } 103 /* Finish form the last CodeTree code is changed to sign the 104 * end of the AND list */ 105 group->code = XBC_NOOP; 106 if (group) 107 group->group = tree; 108 } 109 } 110 else 111 /* Identity of AND is T */ 112 com_Bytecode(com, XBC_T); 113 } 114 115 void 116 Com_Block(LispCom *com, LispBuiltin *builtin) 117 /* 118 block name &rest body 119 */ 120 { 121 122 LispObj *name, *body; 123 124 body = ARGUMENT(1); 125 name = ARGUMENT(0); 126 127 if (name != NIL && name != T && !SYMBOLP(name)) 128 LispDestroy("%s: %s cannot name a block", 129 STRFUN(builtin), STROBJ(name)); 130 if (CONSP(body)) { 131 CompileIniBlock(com, LispBlockTag, name); 132 ComProgn(com, body); 133 CompileFiniBlock(com); 134 } 135 else 136 /* Just load NIL without starting an empty block */ 137 com_Bytecode(com, XBC_NIL); 138 } 139 140 void 141 Com_C_r(LispCom *com, LispBuiltin *builtin) 142 /* 143 c[ad]{1,4}r list 144 */ 145 { 146 LispObj *list; 147 const char *desc; 148 149 list = ARGUMENT(0); 150 151 desc = STRFUN(builtin); 152 if (*desc == 'F') /* FIRST */ 153 desc = "CAR"; 154 else if (*desc == 'R') /* REST */ 155 desc = "CDR"; 156 157 /* Check if it is a list of constants */ 158 while (desc[1] != 'R') 159 desc++; 160 ComEval(com, list); 161 while (*desc != 'C') { 162 com_Bytecode(com, *desc == 'A' ? XBC_CAR : XBC_CDR); 163 --desc; 164 } 165 } 166 167 void 168 Com_Cond(LispCom *com, LispBuiltin *builtin) 169 /* 170 cond &rest body 171 */ 172 { 173 int count; 174 LispObj *code, *body; 175 CodeTree *group, *tree; 176 177 body = ARGUMENT(0); 178 179 count = 0; 180 group = NULL; 181 if (CONSP(body)) { 182 for (; CONSP(body); body = CDR(body)) { 183 code = CAR(body); 184 CHECK_CONS(code); 185 ++count; 186 ComEval(com, CAR(code)); 187 tree = NEW_TREE(CodeTreeCond); 188 if (group) 189 group->group = tree; 190 tree->code = XBC_JUMPNIL; 191 group = tree; 192 /* The code to execute if the test is true */ 193 ComProgn(com, CDR(code)); 194 /* Add a node signaling the end of the PROGN code */ 195 tree = NEW_TREE(CodeTreeCond); 196 tree->code = XBC_JUMPT; 197 if (group) 198 group->group = tree; 199 group = tree; 200 } 201 } 202 if (!count) 203 com_Bytecode(com, XBC_NIL); 204 else 205 /* Where to jump after T progn */ 206 group->code = XBC_NOOP; 207 } 208 209 void 210 Com_Cons(LispCom *com, LispBuiltin *builtin) 211 /* 212 cons car cdr 213 */ 214 { 215 LispObj *car, *cdr; 216 217 cdr = ARGUMENT(1); 218 car = ARGUMENT(0); 219 220 if (ComConstantp(com, car) && ComConstantp(com, cdr)) 221 com_BytecodeCons(com, XBC_CCONS, car, cdr); 222 else { 223 ++com->stack.cpstack; 224 if (com->stack.pstack < com->stack.cpstack) 225 com->stack.pstack = com->stack.cpstack; 226 ComEval(com, car); 227 com_Bytecode(com, XBC_CSTAR); 228 ComEval(com, cdr); 229 com_Bytecode(com, XBC_CFINI); 230 --com->stack.cpstack; 231 } 232 } 233 234 void 235 Com_Consp(LispCom *com, LispBuiltin *builtin) 236 /* 237 consp object 238 */ 239 { 240 ComPredicate(com, builtin, XBP_CONSP); 241 } 242 243 void 244 Com_Dolist(LispCom *com, LispBuiltin *builtin) 245 /* 246 dolist init &rest body 247 */ 248 { 249 int unbound, item; 250 LispObj *symbol, *list, *result; 251 LispObj *init, *body; 252 CodeTree *group, *tree; 253 254 body = ARGUMENT(1); 255 init = ARGUMENT(0); 256 257 CHECK_CONS(init); 258 symbol = CAR(init); 259 CHECK_SYMBOL(symbol); 260 CHECK_CONSTANT(symbol); 261 init = CDR(init); 262 if (CONSP(init)) { 263 list = CAR(init); 264 init = CDR(init); 265 } 266 else 267 list = NIL; 268 if (CONSP(init)) { 269 result = CAR(init); 270 if (CONSP(CDR(init))) 271 LispDestroy("%s: too many arguments %s", 272 STRFUN(builtin), STROBJ(CDR(init))); 273 } 274 else 275 result = NIL; 276 277 /* Generate code for the body of the form. 278 * The generated code uses two objects unavailable to user code, 279 * in the format: 280 * (block NIL 281 * (let ((? list) (item NIL)) 282 * (tagbody 283 * . ; the DOT object as a label 284 * (when (consp list) 285 * (setq item (car ?)) 286 * @body ; code to be executed 287 * (setq ? (cdr ?)) 288 * (go .) 289 * ) 290 * ) 291 * (setq item nil) 292 * result 293 * ) 294 * ) 295 */ 296 297 /* XXX All of the logic below should be simplified at some time 298 * by adding more opcodes for compound operations ... */ 299 300 /* Relative offsets the locally added variables will have at run time */ 301 unbound = lisp__data.env.length - lisp__data.env.lex; 302 item = unbound + 1; 303 304 /* Start BLOCK NIL */ 305 FORM_ENTER(); 306 CompileIniBlock(com, LispBlockTag, NIL); 307 308 /* Add the <?> variable */ 309 ComPush(com, UNBOUND, list, 1, 0, 0); 310 /* Add the <item> variable */ 311 ComPush(com, symbol, NIL, 0, 0, 0); 312 /* Stack length is increased */ 313 CompileStackEnter(com, 2, 0); 314 /* Bind variables */ 315 com_Bind(com, 2); 316 com->block->bind += 2; 317 lisp__data.env.head += 2; 318 319 /* Remember that iteration variable is used even if it not referenced */ 320 COM_VARIABLE_USED(symbol->data.atom); 321 322 /* Initialize the TAGBODY */ 323 FORM_ENTER(); 324 CompileIniBlock(com, LispBlockBody, NIL); 325 326 /* Create the <.> label */ 327 ComLabel(com, DOT); 328 329 /* Load <?> variable */ 330 com_BytecodeShort(com, XBC_LOAD, unbound); 331 /* Check if <?> is a list */ 332 com_BytecodeChar(com, XBC_PRED, XBP_CONSP); 333 334 /* Start WHEN block */ 335 group = NEW_TREE(CodeTreeJumpIf); 336 group->code = XBC_JUMPNIL; 337 /* Load <?> again */ 338 com_BytecodeShort(com, XBC_LOAD, unbound); 339 /* Get CAR of <?> */ 340 com_Bytecode(com, XBC_CAR); 341 /* Store it in <item> */ 342 com_BytecodeShort(com, XBC_SET, item); 343 /* Execute @BODY */ 344 ComProgn(com, body); 345 346 /* Load <?> again */ 347 com_BytecodeShort(com, XBC_LOAD, unbound); 348 /* Get CDR of <?> */ 349 com_Bytecode(com, XBC_CDR); 350 /* Change value of <?> */ 351 com_BytecodeShort(com, XBC_SET, unbound); 352 353 /* GO back to <.> */ 354 tree = NEW_TREE(CodeTreeGo); 355 tree->data.object = DOT; 356 357 /* Finish WHEN block */ 358 tree = NEW_TREE(CodeTreeJumpIf); 359 tree->code = XBC_NOOP; 360 group->group = tree; 361 362 /* Finish the TAGBODY */ 363 CompileFiniBlock(com); 364 FORM_LEAVE(); 365 366 /* Set <item> to NIL, in case result references it... 367 * Loaded value is NIL as the CONSP predicate */ 368 com_BytecodeShort(com, XBC_SET, item); 369 370 /* Evaluate <result> */ 371 ComEval(com, result); 372 373 /* Unbind variables */ 374 lisp__data.env.head -= 2; 375 lisp__data.env.length -= 2; 376 com->block->bind -= 2; 377 com_Unbind(com, 2); 378 /* Stack length is reduced. */ 379 CompileStackLeave(com, 2, 0); 380 381 /* Finish BLOCK NIL */ 382 CompileFiniBlock(com); 383 FORM_LEAVE(); 384 } 385 386 void 387 Com_Eq(LispCom *com, LispBuiltin *builtin) 388 /* 389 eq left right 390 eql left right 391 equal left right 392 equalp left right 393 */ 394 { 395 LispObj *left, *right; 396 LispByteOpcode code; 397 char *name; 398 399 right = ARGUMENT(1); 400 left = ARGUMENT(0); 401 402 CompileStackEnter(com, 1, 1); 403 /* Just like preparing to call a builtin function */ 404 ComEval(com, left); 405 com_Bytecode(com, XBC_PUSH); 406 /* The second argument is now loaded */ 407 ComEval(com, right); 408 409 /* Compare arguments and restore builtin stack */ 410 name = STRFUN(builtin); 411 switch (name[3]) { 412 case 'L': 413 code = XBC_EQL; 414 break; 415 case 'U': 416 code = name[5] == 'P' ? XBC_EQUALP : XBC_EQUAL; 417 break; 418 default: 419 code = XBC_EQ; 420 break; 421 } 422 com_Bytecode(com, code); 423 424 CompileStackLeave(com, 1, 1); 425 } 426 427 void 428 Com_Go(LispCom *com, LispBuiltin *builtin) 429 /* 430 go tag 431 */ 432 { 433 int bind; 434 LispObj *tag; 435 CodeTree *tree; 436 CodeBlock *block; 437 438 tag = ARGUMENT(0); 439 440 block = com->block; 441 bind = block->bind; 442 443 while (block) { 444 if (block->type == LispBlockClosure || block->type == LispBlockBody) 445 break; 446 block = block->prev; 447 if (block) 448 bind += block->bind; 449 } 450 451 if (!block || block->type != LispBlockBody) 452 LispDestroy("%s called not within a block", STRFUN(builtin)); 453 454 /* Unbind any local variables */ 455 com_Unbind(com, bind); 456 tree = NEW_TREE(CodeTreeGo); 457 tree->data.object = tag; 458 } 459 460 void 461 Com_If(LispCom *com, LispBuiltin *builtin) 462 /* 463 if test then &optional else 464 */ 465 { 466 CodeTree *group, *tree; 467 LispObj *test, *then, *oelse; 468 469 oelse = ARGUMENT(2); 470 then = ARGUMENT(1); 471 test = ARGUMENT(0); 472 473 /* Build code to execute test */ 474 ComEval(com, test); 475 476 /* Add jump node to use if test is NIL */ 477 group = NEW_TREE(CodeTreeJumpIf); 478 group->code = XBC_JUMPNIL; 479 480 /* Build T code */ 481 ComEval(com, then); 482 483 if (oelse != UNSPEC) { 484 /* Remember start of NIL code */ 485 tree = NEW_TREE(CodeTreeJump); 486 tree->code = XBC_JUMP; 487 group->group = tree; 488 group = tree; 489 /* Build NIL code */ 490 ComEval(com, oelse); 491 } 492 493 /* Remember jump of T code */ 494 tree = NEW_TREE(CodeTreeJumpIf); 495 tree->code = XBC_NOOP; 496 group->group = tree; 497 } 498 499 void 500 Com_Last(LispCom *com, LispBuiltin *builtin) 501 /* 502 last list &optional count 503 */ 504 { 505 LispObj *list, *count; 506 507 count = ARGUMENT(1); 508 list = ARGUMENT(0); 509 510 ComEval(com, list); 511 CompileStackEnter(com, 1, 1); 512 com_Bytecode(com, XBC_PUSH); 513 if (count == UNSPEC) 514 count = FIXNUM(1); 515 ComEval(com, count); 516 CompileStackLeave(com, 1, 1); 517 com_Bytecode(com, XBC_LAST); 518 } 519 520 void 521 Com_Length(LispCom *com, LispBuiltin *builtin) 522 /* 523 length sequence 524 */ 525 { 526 LispObj *sequence; 527 528 sequence = ARGUMENT(0); 529 530 ComEval(com, sequence); 531 com_Bytecode(com, XBC_LENGTH); 532 } 533 534 void 535 Com_Let(LispCom *com, LispBuiltin *builtin) 536 /* 537 let init &rest body 538 */ 539 { 540 int count; 541 LispObj *symbol, *value, *pair; 542 543 LispObj *init, *body; 544 545 body = ARGUMENT(1); 546 init = ARGUMENT(0); 547 548 if (init == NIL) { 549 /* If no local variables */ 550 ComProgn(com, body); 551 return; 552 } 553 CHECK_CONS(init); 554 555 /* Could optimize if the body is empty and the 556 * init form is known to have no side effects */ 557 558 for (count = 0; CONSP(init); init = CDR(init), count++) { 559 pair = CAR(init); 560 if (CONSP(pair)) { 561 symbol = CAR(pair); 562 pair = CDR(pair); 563 if (CONSP(pair)) { 564 value = CAR(pair); 565 if (CDR(pair) != NIL) 566 LispDestroy("%s: too much arguments to initialize %s", 567 STRFUN(builtin), STROBJ(symbol)); 568 } 569 else 570 value = NIL; 571 } 572 else { 573 symbol = pair; 574 value = NIL; 575 } 576 CHECK_SYMBOL(symbol); 577 CHECK_CONSTANT(symbol); 578 579 /* Add the variable */ 580 ComPush(com, symbol, value, 1, 0, 0); 581 } 582 583 /* Stack length is increased */ 584 CompileStackEnter(com, count, 0); 585 /* Bind the added variables */ 586 com_Bind(com, count); 587 com->block->bind += count; 588 lisp__data.env.head += count; 589 /* Generate code for the body of the form */ 590 ComProgn(com, body); 591 /* Unbind the added variables */ 592 lisp__data.env.head -= count; 593 lisp__data.env.length -= count; 594 com->block->bind -= count; 595 com_Unbind(com, count); 596 /* Stack length is reduced. */ 597 CompileStackLeave(com, count, 0); 598 } 599 600 void 601 Com_Letx(LispCom *com, LispBuiltin *builtin) 602 /* 603 let* init &rest body 604 */ 605 { 606 int count; 607 LispObj *symbol, *value, *pair; 608 609 LispObj *init, *body; 610 611 body = ARGUMENT(1); 612 init = ARGUMENT(0); 613 614 if (init == NIL) { 615 /* If no local variables */ 616 ComProgn(com, body); 617 return; 618 } 619 CHECK_CONS(body); 620 621 /* Could optimize if the body is empty and the 622 * init form is known to have no side effects */ 623 624 for (count = 0; CONSP(init); init = CDR(init), count++) { 625 pair = CAR(init); 626 if (CONSP(pair)) { 627 symbol = CAR(pair); 628 pair = CDR(pair); 629 if (CONSP(pair)) { 630 value = CAR(pair); 631 if (CDR(pair) != NIL) 632 LispDestroy("%s: too much arguments to initialize %s", 633 STRFUN(builtin), STROBJ(symbol)); 634 } 635 else 636 value = NIL; 637 } 638 else { 639 symbol = pair; 640 value = NIL; 641 } 642 CHECK_SYMBOL(symbol); 643 CHECK_CONSTANT(symbol); 644 645 /* LET* is identical to &AUX arguments, just bind the symbol */ 646 ComPush(com, symbol, value, 1, 0, 0); 647 /* Every added variable is binded */ 648 com_Bind(com, 1); 649 /* Must be binded at compile time also */ 650 ++lisp__data.env.head; 651 ++com->block->bind; 652 } 653 654 /* Generate code for the body of the form */ 655 CompileStackEnter(com, count, 0); 656 ComProgn(com, body); 657 com_Unbind(com, count); 658 com->block->bind -= count; 659 lisp__data.env.head -= count; 660 lisp__data.env.length -= count; 661 CompileStackLeave(com, count, 0); 662 } 663 664 void 665 Com_Listp(LispCom *com, LispBuiltin *builtin) 666 /* 667 listp object 668 */ 669 { 670 ComPredicate(com, builtin, XBP_LISTP); 671 } 672 673 void 674 Com_Loop(LispCom *com, LispBuiltin *builtin) 675 /* 676 loop &rest body 677 */ 678 { 679 CodeTree *tree, *group; 680 LispObj *body; 681 682 body = ARGUMENT(0); 683 684 /* Start NIL block */ 685 CompileIniBlock(com, LispBlockTag, NIL); 686 687 /* Insert node to mark LOOP start */ 688 tree = NEW_TREE(CodeTreeJump); 689 tree->code = XBC_NOOP; 690 691 /* Execute @BODY */ 692 if (CONSP(body)) 693 ComProgn(com, body); 694 else 695 /* XXX bytecode.c code require that blocks have at least one opcode */ 696 com_Bytecode(com, XBC_NIL); 697 698 /* Insert node to jump of start of LOOP */ 699 group = NEW_TREE(CodeTreeJump); 700 group->code = XBC_JUMP; 701 group->group = tree; 702 703 /* Finish NIL block */ 704 CompileFiniBlock(com); 705 } 706 707 void 708 Com_Nthcdr(LispCom *com, LispBuiltin *builtin) 709 /* 710 nthcdr index list 711 */ 712 { 713 LispObj *oindex, *list; 714 715 list = ARGUMENT(1); 716 oindex = ARGUMENT(0); 717 718 ComEval(com, oindex); 719 CompileStackEnter(com, 1, 1); 720 com_Bytecode(com, XBC_PUSH); 721 ComEval(com, list); 722 CompileStackLeave(com, 1, 1); 723 com_Bytecode(com, XBC_NTHCDR); 724 } 725 726 void 727 Com_Null(LispCom *com, LispBuiltin *builtin) 728 /* 729 null list 730 */ 731 { 732 LispObj *list; 733 734 list = ARGUMENT(0); 735 736 if (list == NIL) 737 com_Bytecode(com, XBC_T); 738 else if (ComConstantp(com, list)) 739 com_Bytecode(com, XBC_NIL); 740 else { 741 ComEval(com, list); 742 com_Bytecode(com, XBC_INV); 743 } 744 } 745 746 void 747 Com_Numberp(LispCom *com, LispBuiltin *builtin) 748 /* 749 numberp object 750 */ 751 { 752 ComPredicate(com, builtin, XBP_NUMBERP); 753 } 754 755 void 756 Com_Or(LispCom *com, LispBuiltin *builtin) 757 /* 758 or &rest args 759 */ 760 { 761 LispObj *args; 762 763 args = ARGUMENT(0); 764 765 if (CONSP(args)) { 766 /* Evaluate first argument */ 767 ComEval(com, CAR(args)); 768 args = CDR(args); 769 770 /* If more than one argument, create jump list */ 771 if (CONSP(args)) { 772 CodeTree *tree = NULL, *group; 773 774 group = NEW_TREE(CodeTreeJumpIf); 775 group->code = XBC_JUMPT; 776 777 for (; CONSP(args); args = CDR(args)) { 778 ComEval(com, CAR(args)); 779 tree = NEW_TREE(CodeTreeJumpIf); 780 tree->code = XBC_JUMPT; 781 group->group = tree; 782 group = tree; 783 } 784 /* Finish form the last CodeTree code is changed to sign the 785 * end of the AND list */ 786 group->code = XBC_NOOP; 787 group->group = tree; 788 } 789 } 790 else 791 /* Identity of OR is NIL */ 792 com_Bytecode(com, XBC_NIL); 793 } 794 795 void 796 Com_Progn(LispCom *com, LispBuiltin *builtin) 797 /* 798 progn &rest body 799 */ 800 { 801 LispObj *body; 802 803 body = ARGUMENT(0); 804 805 ComProgn(com, body); 806 } 807 808 void 809 Com_Return(LispCom *com, LispBuiltin *builtin) 810 /* 811 return &optional result 812 */ 813 { 814 ComReturnFrom(com, builtin, 0); 815 } 816 817 void 818 Com_ReturnFrom(LispCom *com, LispBuiltin *builtin) 819 /* 820 return-from name &optional result 821 */ 822 { 823 ComReturnFrom(com, builtin, 1); 824 } 825 826 void 827 Com_Rplac_(LispCom *com, LispBuiltin *builtin) 828 /* 829 rplac[ad] place value 830 */ 831 { 832 LispObj *place, *value; 833 834 value = ARGUMENT(1); 835 place = ARGUMENT(0); 836 837 CompileStackEnter(com, 1, 1); 838 ComEval(com, place); 839 com_Bytecode(com, XBC_PUSH); 840 ComEval(com, value); 841 com_Bytecode(com, STRFUN(builtin)[5] == 'A' ? XBC_RPLACA : XBC_RPLACD); 842 CompileStackLeave(com, 1, 1); 843 } 844 845 void 846 Com_Setq(LispCom *com, LispBuiltin *builtin) 847 /* 848 setq &rest form 849 */ 850 { 851 int offset; 852 LispObj *form, *symbol, *value; 853 854 form = ARGUMENT(0); 855 856 for (; CONSP(form); form = CDR(form)) { 857 symbol = CAR(form); 858 CHECK_SYMBOL(symbol); 859 CHECK_CONSTANT(symbol); 860 form = CDR(form); 861 if (!CONSP(form)) 862 LispDestroy("%s: odd number of arguments", STRFUN(builtin)); 863 value = CAR(form); 864 /* Generate code to load value */ 865 ComEval(com, value); 866 offset = ComGetVariable(com, symbol); 867 if (offset >= 0) 868 com_Set(com, offset); 869 else 870 com_SetSym(com, symbol->data.atom); 871 } 872 } 873 874 void 875 Com_Tagbody(LispCom *com, LispBuiltin *builtin) 876 /* 877 tagbody &rest body 878 */ 879 { 880 LispObj *body; 881 882 body = ARGUMENT(0); 883 884 if (CONSP(body)) { 885 CompileIniBlock(com, LispBlockBody, NIL); 886 ComProgn(com, body); 887 /* Tagbody returns NIL */ 888 com_Bytecode(com, XBC_NIL); 889 CompileFiniBlock(com); 890 } 891 else 892 /* Tagbody always returns NIL */ 893 com_Bytecode(com, XBC_NIL); 894 } 895 896 void 897 Com_Unless(LispCom *com, LispBuiltin *builtin) 898 /* 899 unless test &rest body 900 */ 901 { 902 CodeTree *group, *tree; 903 LispObj *test, *body; 904 905 body = ARGUMENT(1); 906 test = ARGUMENT(0); 907 908 /* Generate code to evaluate test */ 909 ComEval(com, test); 910 /* Add node after test */ 911 group = NEW_TREE(CodeTreeJumpIf); 912 group->code = XBC_JUMPT; 913 /* Generate NIL code */ 914 ComProgn(com, body); 915 /* Insert node to know where to jump if test is T */ 916 tree = NEW_TREE(CodeTreeJumpIf); 917 tree->code = XBC_NOOP; 918 group->group = tree; 919 } 920 921 void 922 Com_Until(LispCom *com, LispBuiltin *builtin) 923 /* 924 until test &rest body 925 */ 926 { 927 CodeTree *tree, *group, *ltree, *lgroup; 928 LispObj *test, *body; 929 930 body = ARGUMENT(1); 931 test = ARGUMENT(0); 932 933 /* Insert node to mark LOOP start */ 934 ltree = NEW_TREE(CodeTreeJump); 935 ltree->code = XBC_NOOP; 936 937 /* Build code for test */ 938 ComEval(com, test); 939 group = NEW_TREE(CodeTreeJumpIf); 940 group->code = XBC_JUMPT; 941 942 /* Execute @BODY */ 943 ComProgn(com, body); 944 945 /* Insert node to jump to test again */ 946 lgroup = NEW_TREE(CodeTreeJump); 947 lgroup->code = XBC_JUMP; 948 lgroup->group = ltree; 949 950 /* Insert node to know where to jump if test is T */ 951 tree = NEW_TREE(CodeTreeJumpIf); 952 tree->code = XBC_NOOP; 953 group->group = tree; 954 } 955 956 void 957 Com_When(LispCom *com, LispBuiltin *builtin) 958 /* 959 when test &rest body 960 */ 961 { 962 CodeTree *group, *tree; 963 LispObj *test, *body; 964 965 body = ARGUMENT(1); 966 test = ARGUMENT(0); 967 968 /* Generate code to evaluate test */ 969 ComEval(com, test); 970 /* Add node after test */ 971 group = NEW_TREE(CodeTreeJumpIf); 972 group->code = XBC_JUMPNIL; 973 /* Generate T code */ 974 ComProgn(com, body); 975 /* Insert node to know where to jump if test is NIL */ 976 tree = NEW_TREE(CodeTreeJumpIf); 977 tree->code = XBC_NOOP; 978 group->group = tree; 979 } 980 981 void 982 Com_While(LispCom *com, LispBuiltin *builtin) 983 /* 984 while test &rest body 985 */ 986 { 987 CodeTree *tree, *group, *ltree, *lgroup; 988 LispObj *test, *body; 989 990 body = ARGUMENT(1); 991 test = ARGUMENT(0); 992 993 /* Insert node to mark LOOP start */ 994 ltree = NEW_TREE(CodeTreeJump); 995 ltree->code = XBC_NOOP; 996 997 /* Build code for test */ 998 ComEval(com, test); 999 group = NEW_TREE(CodeTreeJumpIf); 1000 group->code = XBC_JUMPNIL; 1001 1002 /* Execute @BODY */ 1003 ComProgn(com, body); 1004 1005 /* Insert node to jump to test again */ 1006 lgroup = NEW_TREE(CodeTreeJump); 1007 lgroup->code = XBC_JUMP; 1008 lgroup->group = ltree; 1009 1010 /* Insert node to know where to jump if test is NIL */ 1011 tree = NEW_TREE(CodeTreeJumpIf); 1012 tree->code = XBC_NOOP; 1013 group->group = tree; 1014 } 1015 1016 1017 /*********************************************************************** 1018 * Com_XXX helper functions 1019 ***********************************************************************/ 1020 static void 1021 ComPredicate(LispCom *com, LispBuiltin *builtin, LispBytePredicate predicate) 1022 { 1023 LispObj *object; 1024 1025 object = ARGUMENT(0); 1026 1027 if (ComConstantp(com, object)) { 1028 switch (predicate) { 1029 case XBP_CONSP: 1030 com_Bytecode(com, CONSP(object) ? XBC_T : XBC_NIL); 1031 break; 1032 case XBP_LISTP: 1033 com_Bytecode(com, CONSP(object) || object == NIL ? 1034 XBC_T : XBC_NIL); 1035 break; 1036 case XBP_NUMBERP: 1037 com_Bytecode(com, NUMBERP(object) ? XBC_T : XBC_NIL); 1038 break; 1039 } 1040 } 1041 else { 1042 ComEval(com, object); 1043 com_BytecodeChar(com, XBC_PRED, predicate); 1044 } 1045 } 1046 1047 /* XXX Could receive an argument telling if is the last statement in the 1048 * block(s), i.e. if a jump opcode should be generated or just the 1049 * evaluation of the returned value. Probably this is better done in 1050 * an optimization step. */ 1051 static void 1052 ComReturnFrom(LispCom *com, LispBuiltin *builtin, int from) 1053 { 1054 int bind; 1055 CodeTree *tree; 1056 LispObj *name, *result; 1057 CodeBlock *block = com->block; 1058 1059 if (from) { 1060 result = ARGUMENT(1); 1061 name = ARGUMENT(0); 1062 } 1063 else { 1064 result = ARGUMENT(0); 1065 name = NIL; 1066 } 1067 if (result == UNSPEC) 1068 result = NIL; 1069 1070 bind = block->bind; 1071 while (block) { 1072 if (block->type == LispBlockClosure) 1073 /* A function call */ 1074 break; 1075 else if (block->type == LispBlockTag && block->tag == name) 1076 break; 1077 block = block->prev; 1078 if (block) 1079 bind += block->bind; 1080 } 1081 1082 if (!block || block->tag != name) 1083 LispDestroy("%s: no visible %s block", STRFUN(builtin), STROBJ(name)); 1084 1085 /* Generate code to load result */ 1086 ComEval(com, result); 1087 1088 /* Check for added variables that the jump is skiping the unbind opcode */ 1089 com_Unbind(com, bind); 1090 1091 tree = NEW_TREE(CodeTreeReturn); 1092 tree->data.block = block; 1093 } 1094 1095 /*********************************************************************** 1096 * Helper functions 1097 ***********************************************************************/ 1098 static int 1099 ComConstantp(LispCom *com, LispObj *object) 1100 { 1101 switch (OBJECT_TYPE(object)) { 1102 case LispAtom_t: 1103 /* Keywords are guaranteed to evaluate to itself */ 1104 if (object->data.atom->package == lisp__data.keyword) 1105 break; 1106 return (0); 1107 1108 /* Function call */ 1109 case LispCons_t: 1110 1111 /* Need macro expansion, these are special abstract objects */ 1112 case LispQuote_t: 1113 case LispBackquote_t: 1114 case LispComma_t: 1115 case LispFunctionQuote_t: 1116 return (0); 1117 1118 /* Anything else is a literal constant */ 1119 default: 1120 break; 1121 } 1122 1123 return (1); 1124 } 1125 1126 static int 1127 FindIndex(void *item, void **table, int length) 1128 { 1129 long cmp; 1130 int left, right, i; 1131 1132 left = 0; 1133 right = length - 1; 1134 while (left <= right) { 1135 i = (left + right) >> 1; 1136 cmp = (char*)item - (char*)table[i]; 1137 if (cmp == 0) 1138 return (i); 1139 else if (cmp < 0) 1140 right = i - 1; 1141 else 1142 left = i + 1; 1143 } 1144 1145 return (-1); 1146 } 1147 1148 static int 1149 compare(const void *left, const void *right) 1150 { 1151 long cmp = *(char**)left - *(char**)right; 1152 1153 return (cmp < 0 ? -1 : 1); 1154 } 1155 1156 static int 1157 BuildTablePointer(void *pointer, void ***pointers, int *num_pointers) 1158 { 1159 int i; 1160 1161 if ((i = FindIndex(pointer, *pointers, *num_pointers)) < 0) { 1162 *pointers = LispRealloc(*pointers, 1163 sizeof(void*) * (*num_pointers + 1)); 1164 (*pointers)[*num_pointers] = pointer; 1165 if (++*num_pointers > 1) 1166 qsort(*pointers, *num_pointers, sizeof(void*), compare); 1167 i = FindIndex(pointer, *pointers, *num_pointers); 1168 } 1169 1170 return (i); 1171 } 1172 1173 static void 1174 ComAddVariable(LispCom *com, LispObj *symbol, LispObj *value) 1175 { 1176 LispAtom *atom = symbol->data.atom; 1177 1178 if (atom && atom->key && !com->macro) { 1179 int i, length = com->block->variables.length; 1180 1181 i = BuildTablePointer(atom, (void***)&com->block->variables.symbols, 1182 &com->block->variables.length); 1183 1184 if (com->block->variables.length != length) { 1185 com->block->variables.flags = 1186 LispRealloc(com->block->variables.flags, 1187 com->block->variables.length * sizeof(int)); 1188 1189 /* Variable was inserted in the middle of the list */ 1190 if (i < length) 1191 memmove(com->block->variables.flags + i + 1, 1192 com->block->variables.flags + i, 1193 (length - i) * sizeof(int)); 1194 1195 com->block->variables.flags[i] = 0; 1196 } 1197 } 1198 1199 LispAddVar(symbol, value); 1200 } 1201 1202 static int 1203 ComGetVariable(LispCom *com, LispObj *symbol) 1204 { 1205 LispAtom *name; 1206 int i, base, offset; 1207 Atom_id id; 1208 1209 name = symbol->data.atom; 1210 if (name->constant) { 1211 if (name->package == lisp__data.keyword) 1212 /* Just load <symbol> from the byte stream, keywords are 1213 * guaranteed to evaluate to itself. */ 1214 return (SYMBOL_KEYWORD); 1215 return (SYMBOL_CONSTANT); 1216 } 1217 1218 offset = name->offset; 1219 id = name->key; 1220 base = lisp__data.env.lex; 1221 i = lisp__data.env.head - 1; 1222 1223 /* If variable is local */ 1224 if (offset <= i && offset >= com->lex && lisp__data.env.names[offset] == id) { 1225 COM_VARIABLE_USED(name); 1226 /* Relative offset */ 1227 return (offset - base); 1228 } 1229 1230 /* name->offset may have been changed in a macro expansion */ 1231 for (; i >= com->lex; i--) 1232 if (lisp__data.env.names[i] == id) { 1233 name->offset = i; 1234 COM_VARIABLE_USED(name); 1235 return (i - base); 1236 } 1237 1238 if (!name->a_object) { 1239 ++com->warnings; 1240 LispWarning("variable %s is neither declared nor bound", 1241 name->key->value); 1242 } 1243 1244 /* Not found, resolve <symbol> at run time */ 1245 return (SYMBOL_UNBOUND); 1246 } 1247 1248 static void 1249 ComVariableSetFlag(LispCom *com, LispAtom *atom, int flag) 1250 { 1251 int i; 1252 CodeBlock *block = com->block; 1253 1254 while (block) { 1255 i = FindIndex(atom, (void**)block->variables.symbols, 1256 block->variables.length); 1257 if (i >= 0) { 1258 block->variables.flags[i] |= flag; 1259 /* Descend block list if an argument to function being called 1260 * has the same name as a bound variable in the current function. 1261 */ 1262 if ((flag & VARIABLE_ARGUMENT) || 1263 !(block->variables.flags[i] & VARIABLE_ARGUMENT)) 1264 break; 1265 } 1266 block = block->prev; 1267 } 1268 } 1269 1270 /*********************************************************************** 1271 * Bytecode compiler functions 1272 ***********************************************************************/ 1273 static void 1274 ComLabel(LispCom *com, LispObj *label) 1275 { 1276 int i; 1277 CodeTree *tree; 1278 1279 for (i = 0; i < com->block->tagbody.length; i++) 1280 if (label == com->block->tagbody.labels[i]) 1281 LispDestroy("TAGBODY: tag %s specified more than once", 1282 STROBJ(label)); 1283 1284 if (com->block->tagbody.length >= com->block->tagbody.space) { 1285 com->block->tagbody.labels = 1286 LispRealloc(com->block->tagbody.labels, 1287 sizeof(LispObj*) * (com->block->tagbody.space + 8)); 1288 /* Reserve space, will be used at link time when 1289 * resolving GO jumps. */ 1290 com->block->tagbody.codes = 1291 LispRealloc(com->block->tagbody.codes, 1292 sizeof(CodeTree*) * (com->block->tagbody.space + 8)); 1293 com->block->tagbody.space += 8; 1294 } 1295 1296 com->block->tagbody.labels[com->block->tagbody.length++] = label; 1297 tree = NEW_TREE(CodeTreeLabel); 1298 tree->data.object = label; 1299 } 1300 1301 static void 1302 ComPush(LispCom *com, LispObj *symbol, LispObj *value, 1303 int eval, int builtin, int compile) 1304 { 1305 /* If <compile> is set, it is pushing an argument to one of 1306 * Com_XXX functions. */ 1307 if (compile) { 1308 if (builtin) 1309 lisp__data.stack.values[lisp__data.stack.length++] = value; 1310 else 1311 ComAddVariable(com, symbol, value); 1312 return; 1313 } 1314 1315 /* If <com->macro> is set, it is expanding a macro, just add the local 1316 * variable <symbol> bounded to <value>, so that it will be available 1317 * when calling the interpreter to expand the macro. */ 1318 else if (com->macro) { 1319 ComAddVariable(com, symbol, value); 1320 return; 1321 } 1322 1323 /* If <eval> is set, it must generate the opcodes to evaluate <value>. 1324 * If <value> is a constant, just generate the opcodes to load it. */ 1325 else if (eval && !ComConstantp(com, value)) { 1326 switch (OBJECT_TYPE(value)) { 1327 case LispAtom_t: { 1328 int offset = ComGetVariable(com, value); 1329 1330 if (offset >= 0) { 1331 /* Load <value> from user stack at the relative offset */ 1332 if (builtin) 1333 com_LoadPush(com, offset); 1334 else 1335 com_LoadLet(com, offset, symbol->data.atom); 1336 } 1337 /* ComConstantp() does not return true for this, as the 1338 * current value must be computed. */ 1339 else if (offset == SYMBOL_CONSTANT) { 1340 value = value->data.atom->property->value; 1341 if (builtin) 1342 com_LoadConPush(com, value); 1343 else 1344 com_LoadConLet(com, value, symbol->data.atom); 1345 } 1346 else { 1347 /* Load value bound to <value> at run time */ 1348 if (builtin) 1349 com_LoadSymPush(com, value->data.atom); 1350 else 1351 com_LoadSymLet(com, value->data.atom, 1352 symbol->data.atom); 1353 } 1354 } break; 1355 1356 default: 1357 /* Generate code to evaluate <value> */ 1358 ComEval(com, value); 1359 if (builtin) 1360 com_Bytecode(com, XBC_PUSH); 1361 else 1362 com_Let(com, symbol->data.atom); 1363 break; 1364 } 1365 1366 /* Remember <symbol> will be bound, <value> only matters for 1367 * the Com_XXX functions */ 1368 if (builtin) 1369 lisp__data.stack.values[lisp__data.stack.length++] = value; 1370 else 1371 ComAddVariable(com, symbol, value); 1372 return; 1373 } 1374 1375 if (builtin) { 1376 /* Load <value> as a constant in builtin stack */ 1377 com_LoadConPush(com, value); 1378 lisp__data.stack.values[lisp__data.stack.length++] = value; 1379 } 1380 else { 1381 /* Load <value> as a constant in stack */ 1382 com_LoadConLet(com, value, symbol->data.atom); 1383 /* Remember <symbol> will be bound */ 1384 ComAddVariable(com, symbol, value); 1385 } 1386 } 1387 1388 /* This function does almost the same job as LispMakeEnvironment, but 1389 * it is not optimized for speed, as it is not building argument lists 1390 * to user code, but to Com_XXX functions, or helping in generating the 1391 * opcodes to load arguments at bytecode run time. */ 1392 static int 1393 ComCall(LispCom *com, LispArgList *alist, 1394 LispObj *name, LispObj *values, 1395 int eval, int builtin, int compile) 1396 { 1397 char *desc; 1398 int i, count, base; 1399 LispObj **symbols, **defaults, **sforms; 1400 1401 if (builtin) { 1402 base = lisp__data.stack.length; 1403 /* This should never be executed, but make the check for safety */ 1404 if (base + alist->num_arguments > lisp__data.stack.space) { 1405 do 1406 LispMoreStack(); 1407 while (base + alist->num_arguments > lisp__data.stack.space); 1408 } 1409 } 1410 else 1411 base = lisp__data.env.length; 1412 1413 desc = alist->description; 1414 switch (*desc++) { 1415 case '.': 1416 goto normal_label; 1417 case 'o': 1418 goto optional_label; 1419 case 'k': 1420 goto key_label; 1421 case 'r': 1422 goto rest_label; 1423 case 'a': 1424 goto aux_label; 1425 default: 1426 goto done_label; 1427 } 1428 1429 1430 /* Normal arguments */ 1431 normal_label: 1432 i = 0; 1433 symbols = alist->normals.symbols; 1434 count = alist->normals.num_symbols; 1435 for (; i < count && CONSP(values); i++, values = CDR(values)) { 1436 ComPush(com, symbols[i], CAR(values), eval, builtin, compile); 1437 if (!builtin && !com->macro) 1438 COM_VARIABLE_ARGUMENT(symbols[i]->data.atom); 1439 } 1440 if (i < count) 1441 LispDestroy("%s: too few arguments", STROBJ(name)); 1442 1443 switch (*desc++) { 1444 case 'o': 1445 goto optional_label; 1446 case 'k': 1447 goto key_label; 1448 case 'r': 1449 goto rest_label; 1450 case 'a': 1451 goto aux_label; 1452 default: 1453 goto done_label; 1454 } 1455 1456 1457 /* &OPTIONAL */ 1458 optional_label: 1459 i = 0; 1460 count = alist->optionals.num_symbols; 1461 symbols = alist->optionals.symbols; 1462 defaults = alist->optionals.defaults; 1463 sforms = alist->optionals.sforms; 1464 for (; i < count && CONSP(values); i++, values = CDR(values)) { 1465 ComPush(com, symbols[i], CAR(values), eval, builtin, compile); 1466 if (!builtin && !com->macro) 1467 COM_VARIABLE_ARGUMENT(symbols[i]->data.atom); 1468 if (sforms[i]) { 1469 ComPush(com, sforms[i], T, 0, builtin, compile); 1470 if (!builtin && !com->macro) 1471 COM_VARIABLE_ARGUMENT(sforms[i]->data.atom); 1472 } 1473 } 1474 for (; i < count; i++) { 1475 if (!builtin) { 1476 int lex = com->lex; 1477 int head = lisp__data.env.head; 1478 1479 com->lex = base; 1480 lisp__data.env.head = lisp__data.env.length; 1481 /* default arguments are evaluated for macros */ 1482 ComPush(com, symbols[i], defaults[i], 1, 0, compile); 1483 if (!com->macro) 1484 COM_VARIABLE_ARGUMENT(symbols[i]->data.atom); 1485 lisp__data.env.head = head; 1486 com->lex = lex; 1487 } 1488 else 1489 ComPush(com, symbols[i], defaults[i], eval, 1, compile); 1490 if (sforms[i]) { 1491 ComPush(com, sforms[i], NIL, 0, builtin, compile); 1492 if (!builtin && !com->macro) 1493 COM_VARIABLE_ARGUMENT(sforms[i]->data.atom); 1494 } 1495 } 1496 1497 switch (*desc++) { 1498 case 'k': 1499 goto key_label; 1500 case 'r': 1501 goto rest_label; 1502 case 'a': 1503 goto aux_label; 1504 default: 1505 goto done_label; 1506 } 1507 1508 1509 /* &KEY */ 1510 key_label: 1511 { 1512 int varset; 1513 LispObj *val, *karg, **keys; 1514 1515 count = alist->keys.num_symbols; 1516 symbols = alist->keys.symbols; 1517 defaults = alist->keys.defaults; 1518 sforms = alist->keys.sforms; 1519 keys = alist->keys.keys; 1520 1521 /* Check if arguments are correctly specified */ 1522 for (karg = values; CONSP(karg); karg = CDR(karg)) { 1523 val = CAR(karg); 1524 if (KEYWORDP(val)) { 1525 for (i = 0; i < alist->keys.num_symbols; i++) 1526 if (!keys[i] && symbols[i] == val) 1527 break; 1528 } 1529 1530 else if (!builtin && 1531 QUOTEP(val) && SYMBOLP(val->data.quote)) { 1532 for (i = 0; i < alist->keys.num_symbols; i++) 1533 if (keys[i] && ATOMID(keys[i]) == ATOMID(val->data.quote)) 1534 break; 1535 } 1536 1537 else 1538 /* Just make the error test true */ 1539 i = alist->keys.num_symbols; 1540 1541 if (i == alist->keys.num_symbols) { 1542 /* If not in argument specification list... */ 1543 char function_name[36]; 1544 1545 strcpy(function_name, STROBJ(name)); 1546 LispDestroy("%s: invalid keyword %s", 1547 function_name, STROBJ(val)); 1548 } 1549 1550 karg = CDR(karg); 1551 if (!CONSP(karg)) 1552 LispDestroy("%s: &KEY needs arguments as pairs", 1553 STROBJ(name)); 1554 } 1555 1556 /* Add variables */ 1557 for (i = 0; i < alist->keys.num_symbols; i++) { 1558 val = defaults[i]; 1559 varset = 0; 1560 if (!builtin && keys[i]) { 1561 Atom_id atom = ATOMID(keys[i]); 1562 1563 /* Special keyword specification, need to compare ATOMID 1564 * and keyword specification must be a quoted object */ 1565 for (karg = values; CONSP(karg); karg = CDR(karg)) { 1566 val = CAR(karg); 1567 if (QUOTEP(val) && atom == ATOMID(val->data.quote)) { 1568 val = CADR(karg); 1569 varset = 1; 1570 break; 1571 } 1572 karg = CDR(karg); 1573 } 1574 } 1575 1576 else { 1577 /* Normal keyword specification, can compare object pointers, 1578 * as they point to the same object in the keyword package */ 1579 for (karg = values; CONSP(karg); karg = CDR(karg)) { 1580 /* Don't check if argument is a valid keyword or 1581 * special quoted keyword */ 1582 if (symbols[i] == CAR(karg)) { 1583 val = CADR(karg); 1584 varset = 1; 1585 break; 1586 } 1587 karg = CDR(karg); 1588 } 1589 } 1590 1591 /* Add the variable to environment */ 1592 if (varset) { 1593 ComPush(com, symbols[i], val, eval, builtin, compile); 1594 if (sforms[i]) 1595 ComPush(com, sforms[i], T, 0, builtin, compile); 1596 } 1597 else { 1598 /* default arguments are evaluated for macros */ 1599 if (!builtin) { 1600 int lex = com->lex; 1601 int head = lisp__data.env.head; 1602 1603 com->lex = base; 1604 lisp__data.env.head = lisp__data.env.length; 1605 ComPush(com, symbols[i], val, eval, 0, compile); 1606 lisp__data.env.head = head; 1607 com->lex = lex; 1608 } 1609 else 1610 ComPush(com, symbols[i], val, eval, builtin, compile); 1611 if (sforms[i]) 1612 ComPush(com, sforms[i], NIL, 0, builtin, compile); 1613 } 1614 if (!builtin && !com->macro) { 1615 COM_VARIABLE_ARGUMENT(symbols[i]->data.atom); 1616 if (sforms[i]) 1617 COM_VARIABLE_ARGUMENT(sforms[i]->data.atom); 1618 } 1619 } 1620 } 1621 1622 if (*desc == 'a') { 1623 /* &KEY uses all remaining arguments */ 1624 values = NIL; 1625 goto aux_label; 1626 } 1627 goto finished_label; 1628 1629 1630 /* &REST */ 1631 rest_label: 1632 if (!eval || !CONSP(values) || (compile && !builtin)) 1633 ComPush(com, alist->rest, values, eval, builtin, compile); 1634 else { 1635 char *string; 1636 LispObj *list, *car = NIL; 1637 int count, constantp; 1638 1639 /* Count number of arguments and check if it is a list of constants */ 1640 for (count = 0, constantp = 1, list = values; 1641 CONSP(list); 1642 list = CDR(list), count++) { 1643 car = CAR(list); 1644 if (!ComConstantp(com, car)) 1645 constantp = 0; 1646 } 1647 1648 string = builtin ? ATOMID(name)->value : NULL; 1649 /* XXX FIXME should have a flag indicating if function call 1650 * change the &REST arguments even if it is a constant list 1651 * (or if the returned value may be changed). */ 1652 if (string && (count < MAX_BCONS || constantp) && 1653 strcmp(string, "LIST") && 1654 strcmp(string, "APPLY") && /* XXX depends on function argument */ 1655 strcmp(string, "VECTOR") && 1656 /* Append does not copy the last/single list */ 1657 (strcmp(string, "APPEND") || !CONSP(car))) { 1658 if (constantp) { 1659 /* If the builtin function changes the &REST parameters, must 1660 * define a Com_XXX function for it. */ 1661 ComPush(com, alist->rest, values, 0, builtin, compile); 1662 } 1663 else { 1664 CompileStackEnter(com, count - 1, 1); 1665 for (; CONSP(CDR(values)); values = CDR(values)) { 1666 /* Evaluate this argument */ 1667 ComEval(com, CAR(values)); 1668 /* Save result in builtin stack */ 1669 com_Bytecode(com, XBC_PUSH); 1670 } 1671 CompileStackLeave(com, count - 1, 1); 1672 /* The last argument is not saved in the stack */ 1673 ComEval(com, CAR(values)); 1674 values = NIL; 1675 com_Bytecode(com, (LispByteOpcode)(XBC_BCONS + (count - 1))); 1676 } 1677 } 1678 else { 1679 /* Allocate a fresh list of cons */ 1680 1681 /* Generate code to load object */ 1682 ComEval(com, CAR(values)); 1683 1684 com->stack.cpstack += 2; 1685 if (com->stack.pstack < com->stack.cpstack) 1686 com->stack.pstack = com->stack.cpstack; 1687 /* Start building a gc protected list, with the loaded value */ 1688 com_Bytecode(com, XBC_LSTAR); 1689 1690 for (values = CDR(values); CONSP(values); values = CDR(values)) { 1691 /* Generate code to load object */ 1692 ComEval(com, CAR(values)); 1693 1694 /* Add loaded value to gc protected list */ 1695 com_Bytecode(com, XBC_LCONS); 1696 } 1697 1698 /* Finish gc protected list */ 1699 com_Bytecode(com, XBC_LFINI); 1700 1701 /* Push loaded value */ 1702 if (builtin) 1703 com_Bytecode(com, XBC_PUSH); 1704 else { 1705 com_Let(com, alist->rest->data.atom); 1706 1707 /* Remember this symbol will be bound */ 1708 ComAddVariable(com, alist->rest, values); 1709 } 1710 com->stack.cpstack -= 2; 1711 } 1712 } 1713 if (!builtin && !com->macro) 1714 COM_VARIABLE_ARGUMENT(alist->rest->data.atom); 1715 if (*desc != 'a') 1716 goto finished_label; 1717 1718 1719 /* &AUX */ 1720 aux_label: 1721 i = 0; 1722 count = alist->auxs.num_symbols; 1723 symbols = alist->auxs.symbols; 1724 defaults = alist->auxs.initials; 1725 if (!builtin && !compile) { 1726 int lex = com->lex; 1727 1728 com->lex = base; 1729 lisp__data.env.head = lisp__data.env.length; 1730 for (; i < count; i++) { 1731 ComPush(com, symbols[i], defaults[i], 1, 0, 0); 1732 if (!com->macro) 1733 COM_VARIABLE_ARGUMENT(symbols[i]->data.atom); 1734 ++lisp__data.env.head; 1735 } 1736 com->lex = lex; 1737 } 1738 else { 1739 for (; i < count; i++) { 1740 ComPush(com, symbols[i], defaults[i], eval, builtin, compile); 1741 if (!builtin && !com->macro) 1742 COM_VARIABLE_ARGUMENT(symbols[i]->data.atom); 1743 } 1744 } 1745 1746 done_label: 1747 if (CONSP(values)) 1748 LispDestroy("%s: too many arguments", STROBJ(name)); 1749 1750 finished_label: 1751 if (builtin) 1752 lisp__data.stack.base = base; 1753 else 1754 lisp__data.env.head = lisp__data.env.length; 1755 1756 return (base); 1757 } 1758 1759 static void 1760 ComFuncall(LispCom *com, LispObj *function, LispObj *arguments, int eval) 1761 { 1762 int base, compile; 1763 LispAtom *atom; 1764 LispArgList *alist; 1765 LispBuiltin *builtin; 1766 LispObj *lambda; 1767 1768 switch (OBJECT_TYPE(function)) { 1769 case LispFunction_t: 1770 function = function->data.atom->object; 1771 case LispAtom_t: 1772 atom = function->data.atom; 1773 alist = atom->property->alist; 1774 1775 if (atom->a_builtin) { 1776 builtin = atom->property->fun.builtin; 1777 compile = builtin->compile != NULL; 1778 1779 /* If one of: 1780 * o expanding a macro 1781 * o calling a builtin special form 1782 * o builtin function is a macro 1783 * don't evaluate arguments. */ 1784 if (com->macro || compile || builtin->type == LispMacro) 1785 eval = 0; 1786 1787 if (!com->macro && builtin->type == LispMacro) { 1788 /* Set flag of variable used, in case variable is only 1789 * used as a builtin macro argument. */ 1790 LispObj *obj; 1791 1792 for (obj = arguments; CONSP(obj); obj = CDR(obj)) { 1793 if (SYMBOLP(CAR(obj))) 1794 COM_VARIABLE_USED(CAR(obj)->data.atom); 1795 } 1796 } 1797 1798 FORM_ENTER(); 1799 if (!compile && !com->macro) 1800 CompileStackEnter(com, alist->num_arguments, 1); 1801 1802 /* Build argument list in the interpreter stacks */ 1803 base = ComCall(com, alist, function, arguments, 1804 eval, 1, compile); 1805 1806 /* If <compile> is set, it is a special form */ 1807 if (compile) 1808 builtin->compile(com, builtin); 1809 1810 /* Else, generate opcodes to call builtin function */ 1811 else { 1812 com_Call(com, alist->num_arguments, builtin); 1813 CompileStackLeave(com, alist->num_arguments, 1); 1814 } 1815 lisp__data.stack.base = lisp__data.stack.length = base; 1816 FORM_LEAVE(); 1817 } 1818 else if (atom->a_function) { 1819 int macro; 1820 1821 lambda = atom->property->fun.function; 1822 macro = lambda->funtype == LispMacro; 1823 1824 /* If <macro> is set, expand macro */ 1825 if (macro) 1826 ComMacroCall(com, alist, function, lambda, arguments); 1827 1828 else { 1829 if (com->toplevel->type == LispBlockClosure && 1830 com->toplevel->tag == function) 1831 ComRecursiveCall(com, alist, function, arguments); 1832 else { 1833 #if 0 1834 ComInlineCall(com, alist, function, arguments, 1835 lambda->data.lambda.code); 1836 #else 1837 com_Funcall(com, function, arguments); 1838 #endif 1839 } 1840 } 1841 } 1842 else if (atom->a_defstruct && 1843 atom->property->structure.function != STRUCT_NAME && 1844 atom->property->structure.function != STRUCT_CONSTRUCTOR) { 1845 LispObj *definition = atom->property->structure.definition; 1846 1847 if (!CONSP(arguments) || CONSP(CDR(arguments))) 1848 LispDestroy("%s: too %s arguments", atom->key->value, 1849 CONSP(arguments) ? "many" : "few"); 1850 1851 ComEval(com, CAR(arguments)); 1852 if (atom->property->structure.function == STRUCT_CHECK) 1853 com_Structp(com, definition); 1854 else 1855 com_Struct(com, 1856 atom->property->structure.function, definition); 1857 } 1858 else if (atom->a_compiled) { 1859 FORM_ENTER(); 1860 CompileStackEnter(com, alist->num_arguments, 0); 1861 1862 /* Build argument list in the interpreter stacks */ 1863 base = ComCall(com, alist, function, arguments, 1, 0, 0); 1864 com_Bytecall(com, alist->num_arguments, 1865 atom->property->fun.function); 1866 CompileStackLeave(com, alist->num_arguments, 0); 1867 lisp__data.env.head = lisp__data.env.length = base; 1868 FORM_LEAVE(); 1869 } 1870 else { 1871 /* Not yet defined function/macro. */ 1872 ++com->warnings; 1873 LispWarning("call to undefined function %s", atom->key->value); 1874 com_Funcall(com, function, arguments); 1875 } 1876 break; 1877 1878 case LispLambda_t: 1879 lambda = function->data.lambda.code; 1880 alist = (LispArgList*)function->data.lambda.name->data.opaque.data; 1881 ComInlineCall(com, alist, NIL, arguments, lambda->data.lambda.code); 1882 break; 1883 1884 case LispCons_t: 1885 if (CAR(function) == Olambda) { 1886 function = EVAL(function); 1887 if (LAMBDAP(function)) { 1888 GC_ENTER(); 1889 1890 GC_PROTECT(function); 1891 lambda = function->data.lambda.code; 1892 alist = (LispArgList*)function->data.lambda.name->data.opaque.data; 1893 ComInlineCall(com, alist, NIL, arguments, lambda->data.lambda.code); 1894 GC_LEAVE(); 1895 break; 1896 } 1897 } 1898 1899 default: 1900 /* XXX If bytecode objects are made available, should 1901 * handle it here. */ 1902 LispDestroy("EVAL: %s is invalid as a function", 1903 STROBJ(function)); 1904 /*NOTREACHED*/ 1905 break; 1906 } 1907 } 1908 1909 /* Generate opcodes for an implicit PROGN */ 1910 static void 1911 ComProgn(LispCom *com, LispObj *code) 1912 { 1913 if (CONSP(code)) { 1914 for (; CONSP(code); code = CDR(code)) 1915 ComEval(com, CAR(code)); 1916 } 1917 else 1918 /* If no code to execute, empty PROGN returns NIL */ 1919 com_Bytecode(com, XBC_NIL); 1920 } 1921 1922 /* Generate opcodes to evaluate <object>. */ 1923 static void 1924 ComEval(LispCom *com, LispObj *object) 1925 { 1926 int offset; 1927 LispObj *form; 1928 1929 switch (OBJECT_TYPE(object)) { 1930 case LispAtom_t: 1931 if (IN_TAGBODY()) 1932 ComLabel(com, object); 1933 else { 1934 offset = ComGetVariable(com, object); 1935 if (offset >= 0) 1936 /* Load from user stack at relative offset */ 1937 com_Load(com, offset); 1938 else if (offset == SYMBOL_KEYWORD) 1939 com_LoadCon(com, object); 1940 else if (offset == SYMBOL_CONSTANT) 1941 /* Symbol defined as constant, just load it's value */ 1942 com_LoadCon(com, LispGetVar(object)); 1943 else 1944 /* Load value bound to symbol at run time */ 1945 com_LoadSym(com, object->data.atom); 1946 } 1947 break; 1948 1949 case LispCons_t: { 1950 /* Macro expansion may be done in the object form */ 1951 form = com->form; 1952 com->form = object; 1953 ComFuncall(com, CAR(object), CDR(object), 1); 1954 com->form = form; 1955 } break; 1956 1957 case LispQuote_t: 1958 com_LoadCon(com, object->data.quote); 1959 break; 1960 1961 case LispBackquote_t: 1962 /* Macro expansion is stored in the current value of com->form */ 1963 ComMacroBackquote(com, object); 1964 break; 1965 1966 case LispComma_t: 1967 LispDestroy("EVAL: comma outside of backquote"); 1968 break; 1969 1970 case LispFunctionQuote_t: 1971 object = object->data.quote; 1972 if (SYMBOLP(object)) 1973 object = LispSymbolFunction(object); 1974 else if (CONSP(object) && CAR(object) == Olambda) { 1975 /* object will only be associated with bytecode later, 1976 * so, make sure it is protected until compilation finishes */ 1977 object = EVAL(object); 1978 RPLACD(com->plist, CONS(CAR(com->plist), CDR(com->plist))); 1979 RPLACA(com->plist, object); 1980 } 1981 else 1982 LispDestroy("FUNCTION: %s is not a function", STROBJ(object)); 1983 com_LoadCon(com, object); 1984 break; 1985 1986 case LispFixnum_t: 1987 if (IN_TAGBODY()) { 1988 ComLabel(com, object); 1989 break; 1990 } 1991 /*FALLTROUGH*/ 1992 1993 default: 1994 /* Constant object */ 1995 com_LoadCon(com, object); 1996 break; 1997 } 1998 } 1999 2000 /*********************************************************************** 2001 * Lambda expansion helper functions 2002 ***********************************************************************/ 2003 static void 2004 ComRecursiveCall(LispCom *com, LispArgList *alist, 2005 LispObj *name, LispObj *arguments) 2006 { 2007 int base, lex; 2008 2009 /* Save state */ 2010 lex = lisp__data.env.lex; 2011 2012 FORM_ENTER(); 2013 2014 /* Generate code to push function arguments in the stack */ 2015 base = ComCall(com, alist, name, arguments, 1, 0, 0); 2016 2017 /* Stack will grow this amount */ 2018 CompileStackEnter(com, alist->num_arguments, 0); 2019 2020 #if 0 2021 /* Make the variables available at run time */ 2022 com_Bind(com, alist->num_arguments); 2023 com->block->bind += alist->num_arguments; 2024 #endif 2025 2026 com_BytecodeChar(com, XBC_LETREC, alist->num_arguments); 2027 2028 #if 0 2029 /* The variables are now unbound */ 2030 com_Unbind(com, alist->num_arguments); 2031 com->block->bind -= alist->num_arguments; 2032 #endif 2033 2034 /* Stack length is reduced */ 2035 CompileStackLeave(com, alist->num_arguments, 0); 2036 FORM_LEAVE(); 2037 2038 /* Restore state */ 2039 lisp__data.env.lex = lex; 2040 lisp__data.env.head = lisp__data.env.length = base; 2041 } 2042 2043 static void 2044 ComInlineCall(LispCom *com, LispArgList *alist, 2045 LispObj *name, LispObj *arguments, LispObj *lambda) 2046 { 2047 int base, lex; 2048 2049 /* Save state */ 2050 lex = lisp__data.env.lex; 2051 2052 FORM_ENTER(); 2053 /* Start the inline function block */ 2054 CompileIniBlock(com, LispBlockClosure, name); 2055 2056 /* Generate code to push function arguments in the stack */ 2057 base = ComCall(com, alist, name, arguments, 1, 0, 0); 2058 2059 /* Stack will grow this amount */ 2060 CompileStackEnter(com, alist->num_arguments, 0); 2061 2062 /* Make the variables available at run time */ 2063 com_Bind(com, alist->num_arguments); 2064 com->block->bind += alist->num_arguments; 2065 2066 /* Expand the lambda list */ 2067 ComProgn(com, lambda); 2068 2069 /* The variables are now unbound */ 2070 com_Unbind(com, alist->num_arguments); 2071 com->block->bind -= alist->num_arguments; 2072 2073 /* Stack length is reduced */ 2074 CompileStackLeave(com, alist->num_arguments, 0); 2075 2076 /* Finish the inline function block */ 2077 CompileFiniBlock(com); 2078 FORM_LEAVE(); 2079 2080 /* Restore state */ 2081 lisp__data.env.lex = lex; 2082 lisp__data.env.head = lisp__data.env.length = base; 2083 } 2084 2085 /*********************************************************************** 2086 * Macro expansion helper functions. 2087 ***********************************************************************/ 2088 static LispObj * 2089 ComMacroExpandBackquote(LispCom *com, LispObj *object) 2090 { 2091 return (LispEvalBackquote(object->data.quote, 1)); 2092 } 2093 2094 static LispObj * 2095 ComMacroExpandFuncall(LispCom *com, LispObj *function, LispObj *arguments) 2096 { 2097 return (LispFuncall(function, arguments, 1)); 2098 } 2099 2100 static LispObj * 2101 ComMacroExpandEval(LispCom *com, LispObj *object) 2102 { 2103 LispObj *result; 2104 2105 switch (OBJECT_TYPE(object)) { 2106 case LispAtom_t: 2107 result = LispGetVar(object); 2108 2109 /* Macro expansion requires bounded symbols */ 2110 if (result == NULL) 2111 LispDestroy("EVAL: the variable %s is unbound", 2112 STROBJ(object)); 2113 break; 2114 2115 case LispCons_t: 2116 result = ComMacroExpandFuncall(com, CAR(object), CDR(object)); 2117 break; 2118 2119 case LispQuote_t: 2120 result = object->data.quote; 2121 break; 2122 2123 case LispBackquote_t: 2124 result = ComMacroExpandBackquote(com, object); 2125 break; 2126 2127 case LispComma_t: 2128 LispDestroy("EVAL: comma outside of backquote"); 2129 2130 case LispFunctionQuote_t: 2131 result = EVAL(object); 2132 break; 2133 2134 default: 2135 result = object; 2136 break; 2137 } 2138 2139 return (result); 2140 } 2141 2142 static LispObj * 2143 ComMacroExpand(LispCom *com, LispObj *lambda) 2144 { 2145 LispObj *result, **presult = &result; 2146 int jumped, *pjumped = &jumped, backquote, *pbackquote = &backquote; 2147 LispBlock *block; 2148 2149 int interpreter_lex, interpreter_head, interpreter_base; 2150 2151 /* Save interpreter state */ 2152 interpreter_base = lisp__data.stack.length; 2153 interpreter_head = lisp__data.env.length; 2154 interpreter_lex = lisp__data.env.lex; 2155 2156 /* Use the variables */ 2157 *presult = NIL; 2158 *pjumped = 1; 2159 *pbackquote = !CONSP(lambda); 2160 2161 block = LispBeginBlock(NIL, LispBlockProtect); 2162 if (setjmp(block->jmp) == 0) { 2163 if (!backquote) { 2164 for (; CONSP(lambda); lambda = CDR(lambda)) 2165 result = ComMacroExpandEval(com, CAR(lambda)); 2166 } 2167 else 2168 result = ComMacroExpandBackquote(com, lambda); 2169 2170 *pjumped = 0; 2171 } 2172 LispEndBlock(block); 2173 2174 /* If tried to jump out of the macro expansion block */ 2175 if (!lisp__data.destroyed && jumped) 2176 LispDestroy("*** EVAL: bad jump in macro expansion"); 2177 2178 /* Macro expansion did something wrong */ 2179 if (lisp__data.destroyed) { 2180 LispMessage("*** EVAL: aborting macro expansion"); 2181 LispDestroy("."); 2182 } 2183 2184 /* Restore interpreter state */ 2185 lisp__data.env.lex = interpreter_lex; 2186 lisp__data.stack.length = interpreter_base; 2187 lisp__data.env.head = lisp__data.env.length = interpreter_head; 2188 2189 return (result); 2190 } 2191 2192 static void 2193 ComMacroCall(LispCom *com, LispArgList *alist, 2194 LispObj *name, LispObj *lambda, LispObj *arguments) 2195 { 2196 int base; 2197 LispObj *body; 2198 2199 ++com->macro; 2200 base = ComCall(com, alist, name, arguments, 0, 0, 0); 2201 body = lambda->data.lambda.code; 2202 body = ComMacroExpand(com, body); 2203 --com->macro; 2204 lisp__data.env.head = lisp__data.env.length = base; 2205 2206 /* Macro is expanded, store the result */ 2207 CAR(com->form) = body; 2208 ComEval(com, body); 2209 } 2210 2211 static void 2212 ComMacroBackquote(LispCom *com, LispObj *lambda) 2213 { 2214 LispObj *body; 2215 2216 ++com->macro; 2217 body = ComMacroExpand(com, lambda); 2218 --com->macro; 2219 2220 /* Macro is expanded, store the result */ 2221 CAR(com->form) = body; 2222 2223 com_LoadCon(com, body); 2224 } 2225
Indexes created Wed Jul 01 00:25:26 UTC 2026