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/bytecode.c,v 1.17 2003/05/27 22:27:01 tsi Exp $ */ 31 32 33 /* 34 somethings TODO: 35 36 o Write code for allowing storing the bytecode on disk. Basically 37 write a section of the bytecode with the package name of the symbol 38 pointers, and after that, the symbols used. At load time just put 39 the pointers in the bytecode. Constants can be stored as the string 40 representation. Probably just storing the gc protected code as a 41 string is enough to rebuild it. 42 43 o Write code to store tags of BLOCK/CATCH and setjump buffer stacks, 44 and, only keep track of this if non byte-compiled code is called, 45 as after byte-compilation RETURN and THROW are just jumps. 46 47 o Remove not reliable "optmization code" code from Com_XXX functions 48 and do it later, removing dead code, tests with a constant argument, 49 etc, in the "link time". Frequently joining sequential opcodes to a 50 compound version. 51 52 o Write an optimizer to do code transformation. 53 54 o Write code to know when variables can be changed in place, this 55 can save a huge time in loop counters. 56 57 o Write code for fast garbage collection of objects that can be 58 safely collected. 59 60 o Cleanup of interpreted code. Having bytecode mean that the interpreter 61 now is better having a clean and small code. If speed is important, 62 it should be byte compiled. 63 64 o Limit the stacks length. So that instead of using an index, use the 65 pointer where an object value should be read/stored as the stack address 66 would not change during the program execution. 67 68 o Optimize jump to jump. Common in code like: 69 (IF test 70 (GO somewhere) 71 (GO elsewhere) 72 ) 73 (GO there) 74 that generates a bytecode like: 75 <code to evaluate test> 76 JUMPNIL :NIL-RESULT 77 :T-RESULT 78 JUMP :SOMEWHERE 79 JUMP :END-OF-IF ;; <- this is not required, or even 80 :NIL-RESULT ;; better, notice the jump after 81 JUMP :ELSEWHERE ;; the if and transform it into 82 :END-OF-IF ;; a JUMP :THERE (assuming there 83 JUMP :THERE ;; (was no jump in the T code). 84 85 o Optimize variables that are known to not change it's value, i.e. pseudo 86 constants. Loading the value of a constant should be faster than loading 87 the current value of a variable; the constant table could fit in the 88 processor cache line and needs less calculation to find the object address. 89 90 o Fix some known problems, like when calling return or return-from while 91 building the argument list to a builtin function, or inline of recursive 92 functions. 93 */ 94 95 96 #include "lisp/bytecode.h" 97 #include "lisp/write.h" 98 99 #define SYMBOL_KEYWORD -1 /* A keyword, load as constant */ 100 #define SYMBOL_CONSTANT -2 /* Defined as constant at compile time */ 101 #define SYMBOL_UNBOUND -3 /* Not a local variable */ 102 103 #define NEW_TREE(type) CompileNewTree(com, type) 104 105 /* If in tagbody, ignore anything that is not code */ 106 #define IN_TAGBODY() (com->block->type == LispBlockBody && \ 107 com->level == com->tagbody) 108 #define FORM_ENTER() ++com->level 109 #define FORM_LEAVE() --com->level 110 111 #define COMPILE_FAILURE(message) \ 112 LispMessage("COMPILE: %s", message); \ 113 longjmp(com->jmp, 1) 114 115 /* 116 * Types 117 */ 118 typedef struct _CodeTree CodeTree; 119 typedef struct _CodeBlock CodeBlock; 120 121 typedef enum { 122 CodeTreeBytecode, 123 CodeTreeLabel, 124 CodeTreeGo, 125 CodeTreeJump, 126 CodeTreeJumpIf, 127 CodeTreeCond, 128 CodeTreeBlock, 129 CodeTreeReturn 130 } CodeTreeType; 131 132 struct _CodeTree { 133 CodeTreeType type; 134 135 /* Resolved when linking, may be adjusted while optimizing */ 136 long offset; 137 138 LispByteOpcode code; 139 140 union { 141 signed char signed_char; 142 signed short signed_short; 143 signed int signed_int; 144 LispAtom *atom; 145 LispObj *object; 146 CodeTree *tree; 147 CodeBlock *block; 148 struct { 149 unsigned char num_arguments; 150 LispBuiltin *builtin; 151 signed short offset; /* Used if opcode is XBC_CALL_SET */ 152 } builtin; 153 struct { 154 unsigned char num_arguments; 155 LispObj *name; 156 LispObj *lambda; 157 } call; 158 struct { 159 unsigned char num_arguments; 160 LispObj *code; 161 } bytecall; 162 struct { 163 short offset; 164 LispAtom *name; 165 } let; 166 struct { 167 LispAtom *symbol; 168 LispAtom *name; 169 } let_sym; 170 struct { 171 LispObj *object; 172 LispAtom *name; 173 } let_con; 174 struct { 175 signed short load; 176 signed short set; 177 } load_set; 178 struct { 179 LispObj *object; 180 signed short offset; 181 } load_con_set; 182 struct { 183 LispObj *car; 184 LispObj *cdr; 185 } cons; 186 struct { 187 short offset; 188 LispObj *definition; 189 } struc; 190 } data; 191 192 CodeTree *next; 193 CodeTree *group; 194 CodeBlock *block; 195 }; 196 197 struct _CodeBlock { 198 LispBlockType type; 199 LispObj *tag; 200 201 struct { 202 LispObj **labels; 203 CodeTree **codes; /* Filled at link time */ 204 int length; 205 int space; 206 } tagbody; 207 208 struct { 209 LispAtom **symbols; /* Identifiers of variables in a block */ 210 int *flags; /* Information about usage of the variable */ 211 int length; 212 } variables; 213 214 int bind; /* Used in case of RETURN from LET */ 215 int level; /* Nesting level block was created */ 216 217 CodeTree *tree, *tail; 218 CodeBlock *prev; /* Linked list as a stack */ 219 CodeTree *parent; /* Back reference */ 220 }; 221 222 struct _LispCom { 223 unsigned char *bytecode; /* Bytecode generated so far */ 224 long length; 225 226 CodeBlock *block, *toplevel; 227 228 int tagbody; /* Inside a tagbody block? */ 229 int level; /* Nesting level */ 230 int macro; /* Expanding a macro? */ 231 232 int lex; 233 234 int warnings; 235 236 LispObj *form, *plist; 237 238 jmp_buf jmp; /* Used if compilation cannot be finished */ 239 240 struct { 241 int cstack; /* Current number of objects in forms evaluation */ 242 int cbstack; 243 int cpstack; 244 int stack; /* max number of objects will be loaded in stack */ 245 int bstack; 246 int pstack; 247 } stack; 248 249 struct { 250 /* Constant table */ 251 LispObj **constants; 252 int num_constants; 253 /* Symbol table */ 254 LispAtom **symbols; 255 int num_symbols; 256 /* Builtin table */ 257 LispBuiltin **builtins; 258 int num_builtins; 259 /* Bytecode table */ 260 LispObj **bytecodes; 261 int num_bytecodes; 262 } table; 263 }; 264 265 /* 266 * Prototypes 267 */ 268 static LispObj *MakeBytecodeObject(LispCom*, LispObj*, LispObj*); 269 270 static CodeTree *CompileNewTree(LispCom*, CodeTreeType); 271 static void CompileFreeState(LispCom*); 272 static void CompileFreeBlock(CodeBlock*); 273 static void CompileFreeTree(CodeTree*); 274 275 static void CompileIniBlock(LispCom*, LispBlockType, LispObj*); 276 static void CompileFiniBlock(LispCom*); 277 278 static void com_BytecodeChar(LispCom*, LispByteOpcode, char); 279 static void com_BytecodeShort(LispCom*, LispByteOpcode, short); 280 static void com_BytecodeObject(LispCom*, LispByteOpcode, LispObj*); 281 static void com_BytecodeCons(LispCom*, LispByteOpcode, LispObj*, LispObj*); 282 283 static void com_BytecodeAtom(LispCom*, LispByteOpcode, LispAtom*); 284 285 static void com_Bytecode(LispCom*, LispByteOpcode); 286 287 static void com_Load(LispCom*, short); 288 static void com_LoadLet(LispCom*, short, LispAtom*); 289 static void com_LoadPush(LispCom*, short); 290 291 static void com_Let(LispCom*, LispAtom*); 292 293 static void com_Bind(LispCom*, short); 294 static void com_Unbind(LispCom*, short); 295 296 static void com_LoadSym(LispCom*, LispAtom*); 297 static void com_LoadSymLet(LispCom*, LispAtom*, LispAtom*); 298 static void com_LoadSymPush(LispCom*, LispAtom*); 299 300 static void com_LoadCon(LispCom*, LispObj*); 301 static void com_LoadConLet(LispCom*, LispObj*, LispAtom*); 302 static void com_LoadConPush(LispCom*, LispObj*); 303 304 static void com_Set(LispCom*, short); 305 static void com_SetSym(LispCom*, LispAtom*); 306 307 static void com_Struct(LispCom*, short, LispObj*); 308 static void com_Structp(LispCom*, LispObj*); 309 310 static void com_Call(LispCom*, unsigned char, LispBuiltin*); 311 static void com_Bytecall(LispCom*, unsigned char, LispObj*); 312 static void com_Funcall(LispCom*, LispObj*, LispObj*); 313 314 static void CompileStackEnter(LispCom*, int, int); 315 static void CompileStackLeave(LispCom*, int, int); 316 317 static void LinkBytecode(LispCom*); 318 319 static LispObj *ExecuteBytecode(unsigned char*); 320 321 322 /* Defined in lisp.c */ 323 void LispMoreStack(void); 324 void LispMoreEnvironment(void); 325 void LispMoreGlobals(LispPackage*); 326 LispObj *LispEvalBackquote(LispObj*, int); 327 void LispSetAtomObjectProperty(LispAtom*, LispObj*); 328 329 /* 330 * Initialization 331 */ 332 extern int pagesize; 333 334 LispObj x_cons[8]; 335 static LispObj *cons, *cons1, *cons2, *cons3, *cons4, *cons5, *cons6, *cons7; 336 337 /* 338 * Implementation 339 */ 340 #include "lisp/compile.c" 341 342 void 343 LispBytecodeInit(void) 344 { 345 cons = &x_cons[7]; 346 cons->type = LispCons_t; 347 CDR(cons) = NIL; 348 cons1 = &x_cons[6]; 349 cons1->type = LispCons_t; 350 CDR(cons1) = cons; 351 cons2 = &x_cons[5]; 352 cons2->type = LispCons_t; 353 CDR(cons2) = cons1; 354 cons3 = &x_cons[4]; 355 cons3->type = LispCons_t; 356 CDR(cons3) = cons2; 357 cons4 = &x_cons[3]; 358 cons4->type = LispCons_t; 359 CDR(cons4) = cons3; 360 cons5 = &x_cons[2]; 361 cons5->type = LispCons_t; 362 CDR(cons5) = cons4; 363 cons6 = &x_cons[1]; 364 cons6->type = LispCons_t; 365 CDR(cons6) = cons5; 366 cons7 = &x_cons[0]; 367 cons7->type = LispCons_t; 368 CDR(cons7) = cons6; 369 } 370 371 LispObj * 372 Lisp_Compile(LispBuiltin *builtin) 373 /* 374 compile name &optional definition 375 */ 376 { 377 GC_ENTER(); 378 LispObj *result, *warnings_p, *failure_p; 379 380 LispObj *name, *definition; 381 382 definition = ARGUMENT(1); 383 name = ARGUMENT(0); 384 385 result = name; 386 warnings_p = NIL; 387 failure_p = T; 388 389 if (name != NIL) { 390 LispAtom *atom; 391 392 CHECK_SYMBOL(name); 393 atom = name->data.atom; 394 if (atom->a_builtin || atom->a_compiled) 395 goto finished_compilation; 396 else if (atom->a_function) { 397 LispCom com; 398 int failed; 399 int lex = 0, base; 400 LispArgList *alist; 401 LispObj *lambda, *form, *arguments; 402 403 lambda = atom->property->fun.function; 404 if (definition != UNSPEC || lambda->funtype != LispFunction) 405 /* XXX TODO replace definition etc. */ 406 goto finished_compilation; 407 alist = atom->property->alist; 408 409 memset(&com, 0, sizeof(LispCom)); 410 com.toplevel = com.block = LispCalloc(1, sizeof(CodeBlock)); 411 com.block->type = LispBlockClosure; 412 com.block->tag = name; 413 414 /* Create a fake argument list to avoid yet another flag 415 * for ComCall. The value does not matter, just the fact 416 * that the symbol will be bound or not in the implicit 417 * PROGN of the function body. */ 418 base = alist->num_arguments - alist->auxs.num_symbols; 419 if (base) { 420 LispObj *argument; 421 int i, sforms; 422 423 for (i = sforms = 0; i < alist->optionals.num_symbols; i++) 424 if (alist->optionals.sforms[i]) 425 ++sforms; 426 427 arguments = form = NIL; 428 i = sforms + 429 alist->normals.num_symbols + alist->optionals.num_symbols; 430 431 if (i) { 432 arguments = form = CONS(NIL, NIL); 433 GC_PROTECT(arguments); 434 for (--i; i > 0; i--) { 435 RPLACD(form, CONS(NIL, NIL)); 436 form = CDR(form); 437 } 438 } 439 440 for (i = 0; i < alist->keys.num_symbols; i++) { 441 /* key symbol */ 442 if (alist->keys.keys[i]) 443 argument = QUOTE(alist->keys.keys[i]); 444 else 445 argument = alist->keys.symbols[i]; 446 447 /* add key */ 448 if (arguments == NIL) { 449 arguments = form = CONS(argument, NIL); 450 GC_PROTECT(arguments); 451 } 452 else { 453 RPLACD(form, CONS(argument, NIL)); 454 form = CDR(form); 455 } 456 457 /* add value */ 458 RPLACD(form, CONS(NIL, NIL)); 459 form = CDR(form); 460 461 if (alist->keys.sforms[i]) { 462 RPLACD(form, CONS(NIL, NIL)); 463 form = CDR(form); 464 } 465 } 466 467 if (alist->rest) { 468 if (arguments == NIL) { 469 arguments = form = CONS(NIL, NIL); 470 GC_PROTECT(arguments); 471 } 472 else { 473 RPLACD(form, CONS(NIL, NIL)); 474 form = CDR(form); 475 } 476 } 477 } 478 else 479 arguments = NIL; 480 481 form = CONS(lambda->data.lambda.code, NIL); 482 GC_PROTECT(form); 483 com.form = form; 484 com.plist = CONS(NIL, NIL); 485 GC_PROTECT(com.plist); 486 487 failed = 1; 488 if (setjmp(com.jmp) == 0) { 489 /* Save interpreter state */ 490 lex = com.lex = lisp__data.env.lex; 491 base = ComCall(&com, alist, name, arguments, 1, 0, 1); 492 493 /* Generate code tree */ 494 lisp__data.env.lex = base; 495 ComProgn(&com, CAR(form)); 496 failed = 0; 497 } 498 499 /* Restore interpreter state */ 500 lisp__data.env.lex = lex; 501 lisp__data.env.head = lisp__data.env.length = base; 502 503 if (!failed) { 504 failure_p = NIL; 505 result = MakeBytecodeObject(&com, name, 506 lambda->data.lambda.data); 507 LispSetAtomCompiledProperty(atom, result); 508 result = name; 509 } 510 if (com.warnings) 511 warnings_p = FIXNUM(com.warnings); 512 goto finished_compilation; 513 } 514 else 515 goto undefined_function; 516 } 517 518 undefined_function: 519 LispDestroy("%s: the function %s is undefined", 520 STRFUN(builtin), STROBJ(name)); 521 522 finished_compilation: 523 RETURN(0) = warnings_p; 524 RETURN(1) = failure_p; 525 RETURN_COUNT = 2; 526 GC_LEAVE(); 527 528 return (result); 529 } 530 531 LispObj * 532 Lisp_Disassemble(LispBuiltin *builtin) 533 /* 534 disassemble function 535 */ 536 { 537 int macro; 538 char buffer[128]; 539 LispAtom *atom; 540 LispArgList *alist; 541 LispBuiltin *xbuiltin; 542 LispObj *name, *lambda, *bytecode; 543 544 LispObj *function; 545 546 function = ARGUMENT(0); 547 548 macro = 0; 549 alist = NULL; 550 xbuiltin = NULL; 551 name = bytecode = NULL; 552 553 switch (OBJECT_TYPE(function)) { 554 case LispFunction_t: 555 function = function->data.atom->object; 556 case LispAtom_t: 557 name = function; 558 atom = function->data.atom; 559 alist = atom->property->alist; 560 if (atom->a_builtin) { 561 xbuiltin = atom->property->fun.builtin; 562 macro = xbuiltin->type == LispMacro; 563 } 564 else if (atom->a_compiled) 565 bytecode = atom->property->fun.function; 566 else if (atom->a_function) { 567 lambda = atom->property->fun.function; 568 macro = lambda->funtype == LispMacro; 569 } 570 else if (atom->a_defstruct && 571 atom->property->structure.function != STRUCT_NAME) { 572 if (atom->property->structure.function == STRUCT_CONSTRUCTOR) 573 atom = Omake_struct->data.atom; 574 else if (atom->property->structure.function == STRUCT_CHECK) 575 atom = Ostruct_type->data.atom; 576 else 577 atom = Ostruct_access->data.atom; 578 xbuiltin = atom->property->fun.builtin; 579 } 580 else 581 LispDestroy("%s: the function %s is not defined", 582 STRFUN(builtin), STROBJ(function)); 583 break; 584 case LispBytecode_t: 585 name = Olambda; 586 bytecode = function; 587 break; 588 case LispLambda_t: 589 name = Olambda; 590 alist = (LispArgList*)function->data.lambda.name->data.opaque.data; 591 break; 592 case LispCons_t: 593 if (CAR(function) == Olambda) { 594 function = EVAL(function); 595 if (OBJECT_TYPE(function) == LispLambda_t) { 596 name = Olambda; 597 alist = (LispArgList*) 598 function->data.lambda.name->data.opaque.data; 599 break; 600 } 601 } 602 default: 603 LispDestroy("%s: %s is not a function", 604 STRFUN(builtin), STROBJ(function)); 605 break; 606 } 607 608 if (xbuiltin) { 609 LispWriteStr(NIL, "Builtin ", 8); 610 if (macro) 611 LispWriteStr(NIL, "macro ", 6); 612 else 613 LispWriteStr(NIL, "function ", 9); 614 } 615 else if (macro) 616 LispWriteStr(NIL, "Macro ", 6); 617 else 618 LispWriteStr(NIL, "Function ", 9); 619 LispWriteObject(NIL, name); 620 LispWriteStr(NIL, ":\n", 2); 621 622 if (alist) { 623 int i; 624 625 sprintf(buffer, "%d required argument%s", 626 alist->normals.num_symbols, 627 alist->normals.num_symbols != 1 ? "s" : ""); 628 LispWriteStr(NIL, buffer, strlen(buffer)); 629 for (i = 0; i < alist->normals.num_symbols; i++) { 630 LispWriteChar(NIL, i ? ',' : ':'); 631 LispWriteChar(NIL, ' '); 632 LispWriteStr(NIL, ATOMID(alist->normals.symbols[i])->value, 633 ATOMID(alist->normals.symbols[i])->length); 634 } 635 LispWriteChar(NIL, '\n'); 636 637 sprintf(buffer, "%d optional argument%s", 638 alist->optionals.num_symbols, 639 alist->optionals.num_symbols != 1 ? "s" : ""); 640 LispWriteStr(NIL, buffer, strlen(buffer)); 641 for (i = 0; i < alist->optionals.num_symbols; i++) { 642 LispWriteChar(NIL, i ? ',' : ':'); 643 LispWriteChar(NIL, ' '); 644 LispWriteStr(NIL, ATOMID(alist->optionals.symbols[i])->value, 645 ATOMID(alist->optionals.symbols[i])->length); 646 } 647 LispWriteChar(NIL, '\n'); 648 649 sprintf(buffer, "%d keyword parameter%s", 650 alist->keys.num_symbols, 651 alist->keys.num_symbols != 1 ? "s" : ""); 652 LispWriteStr(NIL, buffer, strlen(buffer)); 653 for (i = 0; i < alist->keys.num_symbols; i++) { 654 LispWriteChar(NIL, i ? ',' : ':'); 655 LispWriteChar(NIL, ' '); 656 LispWriteObject(NIL, alist->keys.symbols[i]); 657 } 658 LispWriteChar(NIL, '\n'); 659 660 if (alist->rest) { 661 LispWriteStr(NIL, "Rest argument: ", 15); 662 LispWriteStr(NIL, ATOMID(alist->rest)->value, 663 ATOMID(alist->rest)->length); 664 LispWriteChar(NIL, '\n'); 665 } 666 else 667 LispWriteStr(NIL, "No rest argument\n", 17); 668 } 669 670 if (bytecode) { 671 Atom_id id; 672 char *ptr; 673 int *offsets[4]; 674 int i, done, j, sym0, sym1, con0, con1, bui0, byt0, strd, strf; 675 LispObj **constants; 676 LispAtom **symbols; 677 LispBuiltin **builtins; 678 LispObj **names; 679 short stack, num_constants, num_symbols, num_builtins, num_bytecodes; 680 unsigned char *base, *stream = bytecode->data.bytecode.bytecode->code; 681 682 LispWriteStr(NIL, "\nBytecode header:\n", 18); 683 684 /* Header information */ 685 stack = *(short*)stream; 686 stream += sizeof(short); 687 sprintf(buffer, "%d element%s used in the stack\n", 688 stack, stack != 1 ? "s" : ""); 689 LispWriteStr(NIL, buffer, strlen(buffer)); 690 stack = *(short*)stream; 691 stream += sizeof(short); 692 sprintf(buffer, "%d element%s used in the builtin stack\n", 693 stack, stack != 1 ? "s" : ""); 694 LispWriteStr(NIL, buffer, strlen(buffer)); 695 stack = *(short*)stream; 696 stream += sizeof(short); 697 sprintf(buffer, "%d element%s used in the protected stack\n", 698 stack, stack != 1 ? "s" : ""); 699 LispWriteStr(NIL, buffer, strlen(buffer)); 700 701 num_constants = *(short*)stream; 702 stream += sizeof(short); 703 num_symbols = *(short*)stream; 704 stream += sizeof(short); 705 num_builtins = *(short*)stream; 706 stream += sizeof(short); 707 num_bytecodes = *(short*)stream; 708 stream += sizeof(short); 709 710 constants = (LispObj**)stream; 711 stream += num_constants * sizeof(LispObj*); 712 symbols = (LispAtom**)stream; 713 stream += num_symbols * sizeof(LispAtom*); 714 builtins = (LispBuiltin**)stream; 715 stream += num_builtins * sizeof(LispBuiltin*); 716 stream += num_bytecodes * sizeof(unsigned char*); 717 names = (LispObj**)stream; 718 stream += num_bytecodes * sizeof(LispObj*); 719 720 for (i = 0; i < num_constants; i++) { 721 sprintf(buffer, "Constant %d = %s\n", i, STROBJ(constants[i])); 722 LispWriteStr(NIL, buffer, strlen(buffer)); 723 } 724 725 /* Macro XSTRING avoids some noisy in the output, if it were defined as 726 * #define XSTRING(object) object ? STROBJ(object) : #<UNBOUND> 727 * and called as XSTRING(atom->object) 728 * it would also print the package name were the symbol was first defined, 729 * but for local variables, only the symbol string is important. */ 730 #define XSTRING(key) key ? key->value : "#<UNBOUND>" 731 732 for (i = 0; i < num_symbols; i++) { 733 sprintf(buffer, "Symbol %d = %s\n", 734 i, XSTRING(symbols[i]->key)); 735 LispWriteStr(NIL, buffer, strlen(buffer)); 736 } 737 for (i = 0; i < num_builtins; i++) { 738 sprintf(buffer, "Builtin %d = %s\n", 739 i, STROBJ(builtins[i]->symbol)); 740 LispWriteStr(NIL, buffer, strlen(buffer)); 741 } 742 for (i = 0; i < num_bytecodes; i++) { 743 sprintf(buffer, "Bytecode %d = %s\n", 744 i, STROBJ(names[i])); 745 LispWriteStr(NIL, buffer, strlen(buffer)); 746 } 747 748 /* Make readability slightly easier printing the names of local 749 * variables where it's offset is known, i.e. function arguments. */ 750 if (alist) { 751 if (alist->num_arguments == 0) 752 LispWriteStr(NIL, "\nNo initial stack\n", 18); 753 else { 754 int len1, len2; 755 756 j = 0; 757 LispWriteStr(NIL, "\nInitial stack:\n", 16); 758 759 for (i = 0; i < alist->normals.num_symbols; i++, j++) { 760 sprintf(buffer, "%d = ", j); 761 LispWriteStr(NIL, buffer, strlen(buffer)); 762 id = alist->normals.symbols[i]->data.atom->key; 763 LispWriteStr(NIL, id->value, id->length); 764 LispWriteChar(NIL, '\n'); 765 } 766 767 for (i = 0; i < alist->optionals.num_symbols; i++, j++) { 768 sprintf(buffer, "%d = ", j); 769 LispWriteStr(NIL, buffer, strlen(buffer)); 770 id = alist->optionals.symbols[i]->data.atom->key; 771 LispWriteStr(NIL, id->value, id->length); 772 LispWriteChar(NIL, '\n'); 773 if (alist->optionals.sforms[i]) { 774 sprintf(buffer, "%d = ", j); 775 len1 = strlen(buffer); 776 LispWriteStr(NIL, buffer, len1); 777 id = alist->optionals.sforms[i]->data.atom->key; 778 len2 = id->length; 779 LispWriteStr(NIL, id->value, len2); 780 LispWriteChars(NIL, ' ', 28 - (len1 + len2)); 781 LispWriteStr(NIL, "; sform\n", 9); 782 j++; 783 } 784 } 785 786 for (i = 0; i < alist->keys.num_symbols; i++, j++) { 787 sprintf(buffer, "%d = ", j); 788 len1 = strlen(buffer); 789 LispWriteStr(NIL, buffer, len1); 790 if (alist->keys.keys[i]) { 791 id = alist->keys.keys[i]->data.atom->key; 792 len2 = id->length; 793 LispWriteStr(NIL, id->value, id->length); 794 LispWriteChars(NIL, ' ', 28 - (len1 + len2)); 795 LispWriteStr(NIL, "; special key", 14); 796 } 797 else { 798 id = alist->keys.symbols[i]->data.atom->key; 799 LispWriteStr(NIL, id->value, id->length); 800 } 801 LispWriteChar(NIL, '\n'); 802 if (alist->keys.sforms[i]) { 803 sprintf(buffer, "%d = ", j); 804 len1 = strlen(buffer); 805 LispWriteStr(NIL, buffer, len1); 806 id = alist->keys.sforms[i]->data.atom->key; 807 len2 = id->length; 808 LispWriteStr(NIL, id->value, len2); 809 LispWriteChars(NIL, ' ', 28 - (len1 + len2)); 810 LispWriteStr(NIL, "; sform\n", 9); 811 j++; 812 } 813 } 814 815 if (alist->rest) { 816 sprintf(buffer, "%d = ", j); 817 len1 = strlen(buffer); 818 LispWriteStr(NIL, buffer, len1); 819 id = alist->rest->data.atom->key; 820 len2 = id->length; 821 LispWriteStr(NIL, id->value, len2); 822 LispWriteChar(NIL, '\n'); 823 j++; 824 } 825 826 for (i = 0; i < alist->auxs.num_symbols; i++, j++) { 827 sprintf(buffer, "%d = ", j); 828 len1 = strlen(buffer); 829 LispWriteStr(NIL, buffer, len1); 830 id = alist->auxs.symbols[i]->data.atom->key; 831 len2 = id->length; 832 LispWriteStr(NIL, id->value, len2); 833 LispWriteChars(NIL, ' ', 28 - (len1 + len2)); 834 LispWriteStr(NIL, "; aux\n", 7); 835 } 836 } 837 } 838 839 LispWriteStr(NIL, "\nBytecode stream:\n", 18); 840 841 base = stream; 842 for (done = j = 0; !done; j = 0) { 843 sym0 = sym1 = con0 = con1 = bui0 = byt0 = strd = strf = -1; 844 sprintf(buffer, "%4ld ", (long)(stream - base)); 845 ptr = buffer + strlen(buffer); 846 switch (*stream++) { 847 case XBC_NOOP: strcpy(ptr, "NOOP"); break; 848 case XBC_PRED: 849 strcpy(ptr, "PRED:"); 850 ptr += strlen(ptr); 851 goto predicate; 852 case XBC_INV: strcpy(ptr, "INV"); break; 853 case XBC_NIL: strcpy(ptr, "NIL"); break; 854 case XBC_T: strcpy(ptr, "T"); break; 855 case XBC_CAR: strcpy(ptr, "CAR"); break; 856 case XBC_CDR: strcpy(ptr, "CDR"); break; 857 case XBC_RPLACA:strcpy(ptr, "RPLACA"); break; 858 case XBC_RPLACD:strcpy(ptr, "RPLACD"); break; 859 case XBC_EQ: strcpy(ptr, "EQ"); break; 860 case XBC_EQL: strcpy(ptr, "EQL"); break; 861 case XBC_EQUAL: strcpy(ptr, "EQUAL"); break; 862 case XBC_EQUALP:strcpy(ptr, "EQUALP"); break; 863 case XBC_LENGTH:strcpy(ptr, "LENGTH"); break; 864 case XBC_LAST: strcpy(ptr, "LAST"); break; 865 case XBC_NTHCDR:strcpy(ptr, "NTHCDR"); break; 866 case XBC_PUSH: strcpy(ptr, "PUSH"); break; 867 case XBC_CAR_PUSH: 868 strcpy(ptr, "CAR&PUSH"); 869 break; 870 case XBC_CDR_PUSH: 871 strcpy(ptr, "CDR&PUSH"); 872 break; 873 case XBC_PUSH_NIL: 874 strcpy(ptr, "PUSH NIL"); 875 break; 876 case XBC_PUSH_UNSPEC: 877 strcpy(ptr, "PUSH #<UNSPEC>"); 878 break; 879 case XBC_PUSH_T: 880 strcpy(ptr, "PUSH T"); 881 break; 882 case XBC_PUSH_NIL_N: 883 strcpy(ptr, "PUSH NIL "); 884 ptr += strlen(ptr); 885 sprintf(ptr, "%d", (int)(*stream++)); 886 break; 887 case XBC_PUSH_UNSPEC_N: 888 strcpy(ptr, "PUSH #<UNSPEC> "); 889 ptr += strlen(ptr); 890 sprintf(ptr, "%d", (int)(*stream++)); 891 break; 892 case XBC_LET: 893 strcpy(ptr, "LET"); 894 /* update sym0 */ 895 symbol: 896 offsets[j++] = &sym0; 897 /* update <offsets> - print [byte] */ 898 offset: 899 ptr += strlen(ptr); 900 i = *stream++; 901 *(offsets[j - 1]) = i; 902 sprintf(ptr, " [%d]", i); 903 break; 904 case XBC_LETX: 905 strcpy(ptr, "LET*"); 906 goto symbol; 907 case XBC_LET_NIL: 908 strcpy(ptr, "LET NIL"); 909 goto symbol; 910 case XBC_LETX_NIL: 911 strcpy(ptr, "LET* NIL"); 912 goto symbol; 913 case XBC_LETBIND: 914 strcpy(ptr, "LETBIND"); 915 /* print byte */ 916 value: 917 ptr += strlen(ptr); 918 sprintf(ptr, " %d", (int)(*stream++)); 919 break; 920 case XBC_UNLET:strcpy(ptr, "UNLET"); goto value; 921 case XBC_LOAD: 922 strcpy(ptr, "LOAD"); 923 /* print (byte) */ 924 reference: 925 ptr += strlen(ptr); 926 i = *stream++; 927 sprintf(ptr, " (%d)", i); 928 break; 929 case XBC_LOAD_CAR: 930 strcpy(ptr, "LOAD&CAR"); 931 goto reference; 932 case XBC_LOAD_CDR: 933 strcpy(ptr, "LOAD&CDR"); 934 goto reference; 935 case XBC_LOAD_CAR_STORE: 936 strcpy(ptr, "LOAD&CAR&STORE"); 937 goto reference; 938 case XBC_LOAD_CDR_STORE: 939 strcpy(ptr, "LOAD&CDR&STORE"); 940 goto reference; 941 case XBC_LOAD_LET: 942 strcpy(ptr, "LOAD&LET"); 943 load_let: 944 offsets[j++] = &sym0; 945 i = *stream++; 946 ptr += strlen(ptr); 947 sprintf(ptr, " (%d)", i); 948 goto offset; 949 case XBC_LOAD_LETX: 950 strcpy(ptr, "LOAD&LET*"); 951 goto load_let; 952 case XBC_STRUCT: 953 strcpy(ptr, "STRUCT"); 954 offsets[j++] = &strf; 955 offsets[j++] = &strd; 956 /* update <offsets> - print [byte] - update <offsets> - print [byte] */ 957 offset_offset: 958 ptr += strlen(ptr); 959 i = *stream++; 960 *(offsets[j - 2]) = i; 961 sprintf(ptr, " [%d]", i); 962 goto offset; 963 case XBC_LOAD_PUSH: 964 strcpy(ptr, "LOAD&PUSH"); 965 goto reference; 966 case XBC_LOADCON: 967 strcpy(ptr, "LOADCON"); 968 constant: 969 offsets[j++] = &con0; 970 goto offset; 971 case XBC_LOADCON_SET: 972 strcpy(ptr, "LOADCON&SET"); 973 offsets[j++] = &con0; 974 /* update <offsets> - print [byte] - print (byte) */ 975 offset_reference: 976 i = *stream++; 977 *(offsets[j - 1]) = i; 978 ptr += strlen(ptr); 979 sprintf(ptr, " [%d]", i); 980 goto reference; 981 case XBC_STRUCTP: 982 strcpy(ptr, "STRUCTP"); 983 offsets[j++] = &strd; 984 goto offset; 985 case XBC_LOADCON_LET: 986 strcpy(ptr, "LOADCON&LET"); 987 loadcon_let: 988 offsets[j++] = &con0; 989 offsets[j++] = &sym0; 990 goto offset_offset; 991 case XBC_LOADCON_LETX: 992 strcpy(ptr, "LOADCON&LET*"); 993 goto loadcon_let; 994 case XBC_LOADCON_PUSH: 995 strcpy(ptr, "LOADCON&PUSH"); 996 goto constant; 997 case XBC_LOADSYM: 998 strcpy(ptr, "LOADSYM"); 999 goto symbol; 1000 case XBC_LOADSYM_LET: 1001 strcpy(ptr, "LOADSYM&LET"); 1002 loadsym_let: 1003 offsets[j++] = &sym0; 1004 offsets[j++] = &sym1; 1005 goto offset_offset; 1006 case XBC_LOADSYM_LETX: 1007 strcpy(ptr, "LOADSYM&LET*"); 1008 goto loadsym_let; 1009 case XBC_LOADSYM_PUSH: 1010 strcpy(ptr, "LOADSYM&PUSH"); 1011 goto symbol; 1012 case XBC_LOAD_SET: 1013 strcpy(ptr, "LOAD&SET"); 1014 /* print (byte) - print (byte) */ 1015 reference_reference: 1016 ptr += strlen(ptr); 1017 i = *stream++; 1018 sprintf(ptr, " (%d)", i); 1019 goto reference; 1020 case XBC_LOAD_CAR_SET: 1021 strcpy(ptr, "LOAD&CAR&SET"); 1022 goto reference_reference; 1023 case XBC_LOAD_CDR_SET: 1024 strcpy(ptr, "LOAD&CDR&SET"); 1025 goto reference_reference; 1026 case XBC_CAR_SET: 1027 strcpy(ptr, "CAR&SET"); 1028 goto reference; 1029 case XBC_CDR_SET: 1030 strcpy(ptr, "CDR&SET"); 1031 goto reference; 1032 case XBC_SET: 1033 strcpy(ptr, "SET"); 1034 goto reference; 1035 case XBC_SETSYM: 1036 strcpy(ptr, "SETSYM"); 1037 goto symbol; 1038 case XBC_SET_NIL: 1039 strcpy(ptr, "SET NIL"); 1040 goto reference; 1041 case XBC_CALL: 1042 strcpy(ptr, "CALL"); 1043 ptr += strlen(ptr); 1044 sprintf(ptr, " %d", (int)(*stream++)); 1045 offsets[j++] = &bui0; 1046 goto offset; 1047 case XBC_CALL_SET: 1048 strcpy(ptr, "CALL&SET"); 1049 ptr += strlen(ptr); 1050 sprintf(ptr, " %d", (int)(*stream++)); 1051 offsets[j++] = &bui0; 1052 goto offset_reference; 1053 case XBC_BYTECALL: 1054 strcpy(ptr, "BYTECALL"); 1055 ptr += strlen(ptr); 1056 sprintf(ptr, " %d", (int)(*stream++)); 1057 offsets[j++] = &byt0; 1058 goto offset; 1059 case XBC_FUNCALL: 1060 strcpy(ptr, "FUNCALL"); 1061 constant_constant: 1062 offsets[j++] = &con0; 1063 offsets[j++] = &con1; 1064 goto offset_offset; 1065 case XBC_CCONS: 1066 strcpy(ptr, "CCONS"); 1067 goto constant_constant; 1068 case XBC_CSTAR: strcpy(ptr, "CSTAR"); break; 1069 case XBC_CFINI: strcpy(ptr, "CFINI"); break; 1070 case XBC_LSTAR: strcpy(ptr, "LSTAR"); break; 1071 case XBC_LCONS: strcpy(ptr, "LCONS"); break; 1072 case XBC_LFINI: strcpy(ptr, "LFINI"); break; 1073 case XBC_BCONS: strcpy(ptr, "BCONS"); break; 1074 case XBC_BCONS1: case XBC_BCONS2: case XBC_BCONS3: 1075 case XBC_BCONS4: case XBC_BCONS5: case XBC_BCONS6: 1076 case XBC_BCONS7: 1077 strcpy(ptr, "BCONS"); 1078 ptr += strlen(ptr); 1079 sprintf(ptr, "%d", (int)(stream[-1] - XBC_BCONS)); 1080 break; 1081 case XBC_JUMP: 1082 strcpy(ptr, "JUMP"); 1083 integer: 1084 ptr += strlen(ptr); 1085 sprintf(ptr, " %d", *(signed short*)stream); 1086 stream += sizeof(short); 1087 break; 1088 case XBC_JUMPT: 1089 strcpy(ptr, "JUMPT"); 1090 goto integer; 1091 case XBC_JUMPNIL: 1092 strcpy(ptr, "JUMPNIL"); 1093 goto integer; 1094 case XBC_LETREC: 1095 strcpy(ptr, "LETREC"); 1096 ptr += strlen(ptr); 1097 sprintf(ptr, " %d", (int)*stream++); 1098 break; 1099 case XBC_RETURN: 1100 strcpy(ptr, "RETURN"); 1101 done = 1; 1102 break; 1103 } 1104 i = ptr - buffer + strlen(ptr); 1105 LispWriteStr(NIL, buffer, i); 1106 if (j) { 1107 1108 /* Pad */ 1109 LispWriteChars(NIL, ' ', 28 - i); 1110 LispWriteChar(NIL, ';'); 1111 1112 ptr = buffer; 1113 1114 /* Structure */ 1115 if (strf >= 0) { 1116 /* strd is valid if strf set */ 1117 LispObj *fields = constants[strd]; 1118 1119 for (; strf >= 0; strf--) 1120 fields = CDR(fields); 1121 strcpy(ptr, " "); ptr += 2; 1122 strcpy(ptr, CAR(fields)->data.atom->key->value); 1123 ptr += strlen(ptr); 1124 } 1125 if (strd >= 0) { 1126 strcpy(ptr, " "); ptr += 2; 1127 strcpy(ptr, STROBJ(CAR(constants[strd]))); 1128 ptr += strlen(ptr); 1129 } 1130 1131 /* Constants */ 1132 if (con0 >= 0) { 1133 strcpy(ptr, " "); ptr += 2; 1134 strcpy(ptr, STROBJ(constants[con0])); 1135 ptr += strlen(ptr); 1136 if (con1 >= 0) { 1137 strcpy(ptr, " "); ptr += 2; 1138 strcpy(ptr, STROBJ(constants[con1])); 1139 ptr += strlen(ptr); 1140 } 1141 } 1142 1143 /* Builtin */ 1144 if (bui0 >= 0) { 1145 strcpy(ptr, " "); ptr += 2; 1146 strcpy(ptr, STROBJ(builtins[bui0]->symbol)); 1147 ptr += strlen(ptr); 1148 } 1149 1150 /* Bytecode */ 1151 if (byt0 >= 0) { 1152 strcpy(ptr, " "); ptr += 2; 1153 strcpy(ptr, STROBJ(names[byt0])); 1154 ptr += strlen(ptr); 1155 } 1156 1157 /* Symbols */ 1158 if (sym0 >= 0) { 1159 strcpy(ptr, " "); ptr += 2; 1160 strcpy(ptr, XSTRING(symbols[sym0]->key)); 1161 ptr += strlen(ptr); 1162 if (sym1 >= 0) { 1163 strcpy(ptr, " "); ptr += 2; 1164 strcpy(ptr, XSTRING(symbols[sym1]->key)); 1165 ptr += strlen(ptr); 1166 } 1167 } 1168 1169 i = ptr - buffer; 1170 LispWriteStr(NIL, buffer, i); 1171 } 1172 LispWriteChar(NIL, '\n'); 1173 continue; 1174 predicate: 1175 switch (*stream++) { 1176 case XBP_CONSP: strcpy(ptr, "CONSP"); break; 1177 case XBP_LISTP: strcpy(ptr, "LISTP"); break; 1178 case XBP_NUMBERP: strcpy(ptr, "NUMBERP"); break; 1179 } 1180 LispWriteStr(NIL, buffer, ptr - buffer + strlen(ptr)); 1181 LispWriteChar(NIL, '\n'); 1182 } 1183 #undef XSTRING 1184 } 1185 1186 return (function); 1187 } 1188 1189 1190 1191 LispObj * 1192 LispCompileForm(LispObj *form) 1193 { 1194 GC_ENTER(); 1195 int failed; 1196 LispCom com; 1197 1198 if (!CONSP(form)) 1199 /* Incorrect call or NIL */ 1200 return (form); 1201 1202 memset(&com, 0, sizeof(LispCom)); 1203 1204 com.toplevel = com.block = LispCalloc(1, sizeof(CodeBlock)); 1205 com.block->type = LispBlockNone; 1206 com.lex = lisp__data.env.lex; 1207 1208 com.plist = CONS(NIL, NIL); 1209 GC_PROTECT(com.plist); 1210 1211 failed = 1; 1212 if (setjmp(com.jmp) == 0) { 1213 for (; CONSP(form); form = CDR(form)) { 1214 com.form = form; 1215 ComEval(&com, CAR(form)); 1216 } 1217 failed = 0; 1218 } 1219 GC_LEAVE(); 1220 1221 return (failed ? NIL : MakeBytecodeObject(&com, NIL, NIL)); 1222 } 1223 1224 LispObj * 1225 LispExecuteBytecode(LispObj *object) 1226 { 1227 if (!BYTECODEP(object)) 1228 return (EVAL(object)); 1229 1230 return (ExecuteBytecode(object->data.bytecode.bytecode->code)); 1231 } 1232 1233 static LispObj * 1234 MakeBytecodeObject(LispCom *com, LispObj *name, LispObj *plist) 1235 { 1236 LispObj *object; 1237 LispBytecode *bytecode; 1238 1239 GC_ENTER(); 1240 unsigned char *stream; 1241 short i, num_constants; 1242 LispObj **constants, *code, *cons, *prev; 1243 1244 /* Resolve dependencies, optimize and create byte stream */ 1245 LinkBytecode(com); 1246 1247 object = LispNew(NIL, NIL); 1248 GC_PROTECT(object); 1249 bytecode = LispMalloc(sizeof(LispBytecode)); 1250 bytecode->code = com->bytecode; 1251 bytecode->length = com->length; 1252 1253 1254 stream = bytecode->code; 1255 1256 /* Skip stack information */ 1257 stream += sizeof(short) * 3; 1258 1259 /* Get information */ 1260 num_constants = *(short*)stream; 1261 stream += sizeof(short) * 4; 1262 constants = (LispObj**)stream; 1263 1264 GC_PROTECT(plist); 1265 code = cons = prev = NIL; 1266 for (i = 0; i < num_constants; i++) { 1267 if (POINTERP(constants[i]) && !XSYMBOLP(constants[i])) { 1268 if (code == NIL) { 1269 code = cons = prev = CONS(constants[i], NIL); 1270 GC_PROTECT(code); 1271 } 1272 else { 1273 RPLACD(cons, CONS(constants[i], NIL)); 1274 prev = cons; 1275 cons = CDR(cons); 1276 } 1277 } 1278 } 1279 1280 /* Protect this in case the function is redefined */ 1281 for (i = 0; i < com->table.num_bytecodes; i++) { 1282 if (code == NIL) { 1283 code = cons = prev = CONS(com->table.bytecodes[i], NIL); 1284 GC_PROTECT(code); 1285 } 1286 else { 1287 RPLACD(cons, CONS(com->table.bytecodes[i], NIL)); 1288 prev = cons; 1289 cons = CDR(cons); 1290 } 1291 } 1292 1293 /* Free everything, but the LispCom structure and the generated bytecode */ 1294 CompileFreeState(com); 1295 1296 /* Allocate the minimum required number of cons cells to protect objects */ 1297 if (!CONSP(code)) 1298 code = plist; 1299 else if (CONSP(plist)) { 1300 if (code == cons) 1301 RPLACD(code, plist); 1302 else 1303 RPLACD(cons, plist); 1304 } 1305 else { 1306 if (code == cons) 1307 code = CAR(code); 1308 else 1309 CDR(prev) = CAR(cons); 1310 } 1311 1312 object->data.bytecode.bytecode = bytecode; 1313 /* Byte code references this object, so it cannot be garbage collected */ 1314 object->data.bytecode.code = code; 1315 object->data.bytecode.name = name; 1316 object->type = LispBytecode_t; 1317 1318 LispMused(bytecode); 1319 LispMused(bytecode->code); 1320 GC_LEAVE(); 1321 1322 return (object); 1323 } 1324 1325 static void 1326 CompileFreeTree(CodeTree *tree) 1327 { 1328 if (tree->type == CodeTreeBlock) 1329 CompileFreeBlock(tree->data.block); 1330 LispFree(tree); 1331 } 1332 1333 static void 1334 CompileFreeBlock(CodeBlock *block) 1335 { 1336 CodeTree *tree = block->tree, *next; 1337 1338 while (tree) { 1339 next = tree->next; 1340 CompileFreeTree(tree); 1341 tree = next; 1342 } 1343 if (block->type == LispBlockBody) { 1344 LispFree(block->tagbody.labels); 1345 LispFree(block->tagbody.codes); 1346 } 1347 LispFree(block->variables.symbols); 1348 LispFree(block->variables.flags); 1349 LispFree(block); 1350 } 1351 1352 static void 1353 CompileFreeState(LispCom *com) 1354 { 1355 CompileFreeBlock(com->block); 1356 LispFree(com->table.constants); 1357 LispFree(com->table.symbols); 1358 LispFree(com->table.builtins); 1359 LispFree(com->table.bytecodes); 1360 } 1361 1362 /* XXX Put a breakpoint here when changing the macro expansion code. 1363 * No opcodes should be generated during macro expansion. */ 1364 static CodeTree * 1365 CompileNewTree(LispCom *com, CodeTreeType type) 1366 { 1367 CodeTree *tree = LispMalloc(sizeof(CodeTree)); 1368 1369 tree->type = type; 1370 tree->next = NULL; 1371 tree->block = com->block; 1372 if (com->block->tree == NULL) 1373 com->block->tree = tree; 1374 else 1375 com->block->tail->next = tree; 1376 com->block->tail = tree; 1377 1378 return (tree); 1379 } 1380 1381 static void 1382 CompileIniBlock(LispCom *com, LispBlockType type, LispObj *tag) 1383 { 1384 CodeTree *tree = NEW_TREE(CodeTreeBlock); 1385 CodeBlock *block = LispCalloc(1, sizeof(CodeBlock)); 1386 1387 tree->data.block = block; 1388 1389 block->type = type; 1390 block->tag = tag; 1391 block->prev = com->block; 1392 block->parent = tree; 1393 block->level = com->level; 1394 com->block = block; 1395 1396 if (type == LispBlockBody) 1397 com->tagbody = com->level; 1398 } 1399 1400 static void 1401 CompileFiniBlock(LispCom *com) 1402 { 1403 com->block = com->block->prev; 1404 if (com->block && com->block->type == LispBlockBody) 1405 com->tagbody = com->block->level; 1406 } 1407 1408 static void 1409 com_BytecodeChar(LispCom *com, LispByteOpcode code, char value) 1410 { 1411 CodeTree *tree = NEW_TREE(CodeTreeBytecode); 1412 1413 tree->code = code; 1414 tree->data.signed_char = value; 1415 } 1416 1417 static void 1418 com_BytecodeShort(LispCom *com, LispByteOpcode code, short value) 1419 { 1420 CodeTree *tree = NEW_TREE(CodeTreeBytecode); 1421 1422 tree->code = code; 1423 tree->data.signed_short = value; 1424 } 1425 1426 static void 1427 com_BytecodeAtom(LispCom *com, LispByteOpcode code, LispAtom *atom) 1428 { 1429 CodeTree *tree = NEW_TREE(CodeTreeBytecode); 1430 1431 tree->code = code; 1432 tree->data.atom = atom; 1433 } 1434 1435 static void 1436 com_BytecodeObject(LispCom *com, LispByteOpcode code, LispObj *object) 1437 { 1438 CodeTree *tree = NEW_TREE(CodeTreeBytecode); 1439 1440 tree->code = code; 1441 tree->data.object = object; 1442 } 1443 1444 static void 1445 com_BytecodeCons(LispCom *com, LispByteOpcode code, LispObj *car, LispObj *cdr) 1446 { 1447 CodeTree *tree = NEW_TREE(CodeTreeBytecode); 1448 1449 tree->code = code; 1450 tree->data.cons.car = car; 1451 tree->data.cons.cdr = cdr; 1452 } 1453 1454 static void 1455 com_Bytecode(LispCom *com, LispByteOpcode code) 1456 { 1457 CodeTree *tree = NEW_TREE(CodeTreeBytecode); 1458 1459 tree->code = code; 1460 } 1461 1462 static void 1463 com_Load(LispCom *com, short offset) 1464 { 1465 com_BytecodeShort(com, XBC_LOAD, offset); 1466 } 1467 1468 static void 1469 com_LoadLet(LispCom *com, short offset, LispAtom *name) 1470 { 1471 CodeTree *tree = NEW_TREE(CodeTreeBytecode); 1472 1473 tree->code = XBC_LOAD_LET; 1474 tree->data.let.offset = offset; 1475 tree->data.let.name = name; 1476 } 1477 1478 static void 1479 com_LoadPush(LispCom *com, short offset) 1480 { 1481 com_BytecodeShort(com, XBC_LOAD_PUSH, offset); 1482 } 1483 1484 static void 1485 com_Let(LispCom *com, LispAtom *name) 1486 { 1487 com_BytecodeAtom(com, XBC_LET, name); 1488 } 1489 1490 static void 1491 com_Bind(LispCom *com, short count) 1492 { 1493 if (count) 1494 com_BytecodeShort(com, XBC_LETBIND, count); 1495 } 1496 1497 static void 1498 com_Unbind(LispCom *com, short count) 1499 { 1500 if (count) 1501 com_BytecodeShort(com, XBC_UNLET, count); 1502 } 1503 1504 static void 1505 com_LoadSym(LispCom *com, LispAtom *atom) 1506 { 1507 com_BytecodeAtom(com, XBC_LOADSYM, atom); 1508 } 1509 1510 static void 1511 com_LoadSymLet(LispCom *com, LispAtom *symbol, LispAtom *name) 1512 { 1513 CodeTree *tree = NEW_TREE(CodeTreeBytecode); 1514 1515 tree->code = XBC_LOADSYM_LET; 1516 tree->data.let_sym.symbol = symbol; 1517 tree->data.let_sym.name = name; 1518 } 1519 1520 static void 1521 com_LoadSymPush(LispCom *com, LispAtom *name) 1522 { 1523 com_BytecodeAtom(com, XBC_LOADSYM_PUSH, name); 1524 } 1525 1526 static void 1527 com_LoadCon(LispCom *com, LispObj *constant) 1528 { 1529 if (constant == NIL) 1530 com_Bytecode(com, XBC_NIL); 1531 else if (constant == T) 1532 com_Bytecode(com, XBC_T); 1533 else if (constant == UNSPEC) { 1534 COMPILE_FAILURE("internal error: loading #<UNSPEC>"); 1535 } 1536 else 1537 com_BytecodeObject(com, XBC_LOADCON, constant); 1538 } 1539 1540 static void 1541 com_LoadConLet(LispCom *com, LispObj *constant, LispAtom *name) 1542 { 1543 if (constant == NIL) 1544 com_BytecodeAtom(com, XBC_LET_NIL, name); 1545 else { 1546 CodeTree *tree = NEW_TREE(CodeTreeBytecode); 1547 1548 tree->code = XBC_LOADCON_LET; 1549 tree->data.let_con.object = constant; 1550 tree->data.let_con.name = name; 1551 } 1552 } 1553 1554 static void 1555 com_LoadConPush(LispCom *com, LispObj *constant) 1556 { 1557 if (constant == NIL) 1558 com_Bytecode(com, XBC_PUSH_NIL); 1559 else if (constant == T) 1560 com_Bytecode(com, XBC_PUSH_T); 1561 else if (constant == UNSPEC) 1562 com_Bytecode(com, XBC_PUSH_UNSPEC); 1563 else 1564 com_BytecodeObject(com, XBC_LOADCON_PUSH, constant); 1565 } 1566 1567 static void 1568 com_Set(LispCom *com, short offset) 1569 { 1570 com_BytecodeShort(com, XBC_SET, offset); 1571 } 1572 1573 static void 1574 com_SetSym(LispCom *com, LispAtom *symbol) 1575 { 1576 com_BytecodeAtom(com, XBC_SETSYM, symbol); 1577 } 1578 1579 static void 1580 com_Struct(LispCom *com, short offset, LispObj *definition) 1581 { 1582 CodeTree *tree = NEW_TREE(CodeTreeBytecode); 1583 1584 tree->code = XBC_STRUCT; 1585 tree->data.struc.offset = offset; 1586 tree->data.struc.definition = definition; 1587 } 1588 1589 static void 1590 com_Structp(LispCom *com, LispObj *definition) 1591 { 1592 com_BytecodeObject(com, XBC_STRUCTP, definition); 1593 } 1594 1595 static void 1596 com_Call(LispCom *com, unsigned char num_arguments, LispBuiltin *builtin) 1597 { 1598 CodeTree *tree = NEW_TREE(CodeTreeBytecode); 1599 1600 tree->code = XBC_CALL; 1601 tree->data.builtin.num_arguments = num_arguments; 1602 tree->data.builtin.builtin = builtin; 1603 } 1604 1605 static void 1606 com_Bytecall(LispCom *com, unsigned char num_arguments, LispObj *code) 1607 { 1608 CodeTree *tree = NEW_TREE(CodeTreeBytecode); 1609 1610 tree->code = XBC_BYTECALL; 1611 tree->data.bytecall.num_arguments = num_arguments; 1612 tree->data.bytecall.code = code; 1613 } 1614 1615 static void 1616 com_Funcall(LispCom *com, LispObj *function, LispObj *arguments) 1617 { 1618 com_BytecodeCons(com, XBC_FUNCALL, function, arguments); 1619 } 1620 1621 static void 1622 CompileStackEnter(LispCom *com, int count, int builtin) 1623 { 1624 if (!com->macro) { 1625 if (builtin) { 1626 com->stack.cbstack += count; 1627 if (com->stack.bstack < com->stack.cbstack) 1628 com->stack.bstack = com->stack.cbstack; 1629 } 1630 else { 1631 com->stack.cstack += count; 1632 if (com->stack.stack < com->stack.cstack) 1633 com->stack.stack = com->stack.cstack; 1634 } 1635 } 1636 } 1637 1638 static void 1639 CompileStackLeave(LispCom *com, int count, int builtin) 1640 { 1641 if (!com->macro) { 1642 if (builtin) 1643 com->stack.cbstack -= count; 1644 else 1645 com->stack.cstack -= count; 1646 } 1647 } 1648 1649 static void 1650 LinkWarnUnused(LispCom *com, CodeBlock *block) 1651 { 1652 int i; 1653 CodeTree *tree; 1654 1655 for (tree = block->tree; tree; tree = tree->next) { 1656 if (tree->type == CodeTreeBlock) 1657 LinkWarnUnused(com, tree->data.block); 1658 } 1659 1660 for (i = 0; i < block->variables.length; i++) 1661 if (!(block->variables.flags[i] & (VARIABLE_USED | VARIABLE_ARGUMENT))) { 1662 ++com->warnings; 1663 LispWarning("the variable %s is unused", 1664 block->variables.symbols[i]->key->value); 1665 } 1666 } 1667 1668 #define INTERNAL_ERROR_STRING "COMPILE: internal error #%d" 1669 #define INTERNAL_ERROR(value) LispDestroy(INTERNAL_ERROR_STRING, value) 1670 static long 1671 LinkBuildOffsets(LispCom *com, CodeTree *tree, long offset) 1672 { 1673 for (; tree; tree = tree->next) { 1674 tree->offset = offset; 1675 switch (tree->type) { 1676 case CodeTreeBytecode: 1677 switch (tree->code) { 1678 case XBC_NOOP: 1679 INTERNAL_ERROR(__LINE__); 1680 break; 1681 1682 /* byte */ 1683 case XBC_BCONS: 1684 case XBC_BCONS1: 1685 case XBC_BCONS2: 1686 case XBC_BCONS3: 1687 case XBC_BCONS4: 1688 case XBC_BCONS5: 1689 case XBC_BCONS6: 1690 case XBC_BCONS7: 1691 case XBC_INV: 1692 case XBC_NIL: 1693 case XBC_T: 1694 case XBC_PUSH: 1695 case XBC_CAR_PUSH: 1696 case XBC_CDR_PUSH: 1697 case XBC_PUSH_NIL: 1698 case XBC_PUSH_UNSPEC: 1699 case XBC_PUSH_T: 1700 case XBC_LSTAR: 1701 case XBC_LCONS: 1702 case XBC_LFINI: 1703 case XBC_RETURN: 1704 case XBC_CSTAR: 1705 case XBC_CFINI: 1706 case XBC_CAR: 1707 case XBC_CDR: 1708 case XBC_RPLACA: 1709 case XBC_RPLACD: 1710 case XBC_EQ: 1711 case XBC_EQL: 1712 case XBC_EQUAL: 1713 case XBC_EQUALP: 1714 case XBC_LENGTH: 1715 case XBC_LAST: 1716 case XBC_NTHCDR: 1717 ++offset; 1718 break; 1719 1720 /* byte + byte */ 1721 case XBC_PUSH_NIL_N: 1722 case XBC_PUSH_UNSPEC_N: 1723 case XBC_PRED: 1724 case XBC_LETREC: 1725 case XBC_LOAD_PUSH: 1726 case XBC_CAR_SET: 1727 case XBC_CDR_SET: 1728 case XBC_SET: 1729 case XBC_SET_NIL: 1730 case XBC_LETBIND: 1731 case XBC_UNLET: 1732 case XBC_LOAD: 1733 case XBC_LOAD_CAR: 1734 case XBC_LOAD_CDR: 1735 case XBC_LOAD_CAR_STORE: 1736 case XBC_LOAD_CDR_STORE: 1737 case XBC_LET: 1738 case XBC_LETX: 1739 case XBC_LET_NIL: 1740 case XBC_LETX_NIL: 1741 case XBC_STRUCTP: 1742 case XBC_SETSYM: 1743 case XBC_LOADCON_PUSH: 1744 case XBC_LOADSYM_PUSH: 1745 case XBC_LOADCON: 1746 case XBC_LOADSYM: 1747 offset += 2; 1748 break; 1749 1750 /* byte + byte + byte */ 1751 case XBC_CALL: 1752 case XBC_BYTECALL: 1753 case XBC_LOAD_SET: 1754 case XBC_LOAD_CAR_SET: 1755 case XBC_LOAD_CDR_SET: 1756 case XBC_LOADCON_SET: 1757 case XBC_LOAD_LET: 1758 case XBC_LOAD_LETX: 1759 case XBC_STRUCT: 1760 case XBC_LOADCON_LET: 1761 case XBC_LOADCON_LETX: 1762 case XBC_LOADSYM_LET: 1763 case XBC_LOADSYM_LETX: 1764 case XBC_CCONS: 1765 case XBC_FUNCALL: 1766 offset += 3; 1767 break; 1768 1769 /* byte + short */ 1770 case XBC_JUMP: 1771 case XBC_JUMPT: 1772 case XBC_JUMPNIL: 1773 /* XXX this is likely a jump to random address here */ 1774 INTERNAL_ERROR(__LINE__); 1775 offset += sizeof(short) + 1; 1776 break; 1777 1778 /* byte + byte + byte + byte */ 1779 case XBC_CALL_SET: 1780 offset += 4; 1781 break; 1782 } 1783 break; 1784 case CodeTreeLabel: 1785 /* Labels are not loaded */ 1786 break; 1787 case CodeTreeJump: 1788 case CodeTreeJumpIf: 1789 case CodeTreeCond: 1790 /* If not the point where the conditional block finishes */ 1791 if (tree->code != XBC_NOOP) 1792 /* Reserve space for the jump opcode */ 1793 offset += sizeof(short) + 1; 1794 break; 1795 case CodeTreeGo: 1796 case CodeTreeReturn: 1797 /* Reserve space for the jump opcode */ 1798 offset += sizeof(short) + 1; 1799 break; 1800 case CodeTreeBlock: 1801 offset = LinkBuildOffsets(com, tree->data.block->tree, offset); 1802 break; 1803 } 1804 } 1805 1806 return (offset); 1807 } 1808 1809 static void 1810 LinkDoOptimize_0(LispCom *com, CodeBlock *block) 1811 { 1812 CodeTree *tree, *prev, *next; 1813 1814 /* Remove redundant or join opcodes that can be joined. Do it here 1815 * because some of these are hard to detect earlier, and/or would 1816 * require a lot of duplicated code or more time. */ 1817 tree = prev = block->tree; 1818 while (tree) { 1819 next = tree->next; 1820 1821 /* LET -> LET* */ 1822 if (next && 1823 next->type == CodeTreeBytecode && 1824 next->code == XBC_LETBIND && 1825 next->data.signed_short == 1) { 1826 switch (tree->code) { 1827 case XBC_LET: 1828 tree->code = XBC_LETX; 1829 goto remove_next_label; 1830 case XBC_LET_NIL: 1831 tree->code = XBC_LETX_NIL; 1832 goto remove_next_label; 1833 case XBC_LOAD_LET: 1834 tree->code = XBC_LOAD_LETX; 1835 goto remove_next_label; 1836 case XBC_LOADCON_LET: 1837 tree->code = XBC_LOADCON_LETX; 1838 goto remove_next_label; 1839 case XBC_LOADSYM_LET: 1840 tree->code = XBC_LOADSYM_LETX; 1841 goto remove_next_label; 1842 default: 1843 break; 1844 } 1845 } 1846 1847 switch (tree->type) { 1848 case CodeTreeBytecode: 1849 switch (tree->code) { 1850 case XBC_LOADCON: 1851 if (next && next->type == CodeTreeBytecode) { 1852 switch (next->code) { 1853 case XBC_LET: 1854 next->code = XBC_LOADCON_LET; 1855 next->data.let_con.name = 1856 next->data.atom; 1857 next->data.let_con.object = 1858 tree->data.object; 1859 goto remove_label; 1860 case XBC_PUSH: 1861 next->code = XBC_LOADCON_PUSH; 1862 next->data.object = tree->data.object; 1863 goto remove_label; 1864 case XBC_CAR: 1865 if (tree->data.object != NIL) { 1866 if (!CONSP(tree->data.object)) 1867 LispDestroy("CAR: %s is not a list", 1868 STROBJ( 1869 tree->data.object)); 1870 next->code = XBC_LOADCON; 1871 next->data.object = 1872 CAR(tree->data.object); 1873 } 1874 goto remove_label; 1875 case XBC_CDR: 1876 if (tree->data.object != NIL) { 1877 if (!CONSP(tree->data.object)) 1878 LispDestroy("CAR: %s is not a list", 1879 STROBJ( 1880 tree->data.object)); 1881 next->code = XBC_LOADCON; 1882 next->data.object = 1883 CDR(tree->data.object); 1884 } 1885 goto remove_label; 1886 case XBC_SET: 1887 next->code = XBC_LOADCON_SET; 1888 next->data.load_con_set.offset = 1889 next->data.signed_short; 1890 next->data.load_con_set.object = 1891 tree->data.object; 1892 goto remove_label; 1893 default: 1894 break; 1895 } 1896 } 1897 break; 1898 case XBC_LOADSYM: 1899 if (next && next->type == CodeTreeBytecode) { 1900 switch (next->code) { 1901 case XBC_LET: 1902 next->code = XBC_LOADSYM_LET; 1903 next->data.let_sym.name = 1904 next->data.atom; 1905 next->data.let_sym.symbol = 1906 tree->data.atom; 1907 goto remove_label; 1908 case XBC_PUSH: 1909 next->code = XBC_LOADSYM_PUSH; 1910 next->data.atom = tree->data.atom; 1911 goto remove_label; 1912 default: 1913 break; 1914 } 1915 } 1916 break; 1917 case XBC_LOAD: 1918 if (next && next->type == CodeTreeBytecode) { 1919 switch (next->code) { 1920 case XBC_SET: 1921 next->code = XBC_LOAD_SET; 1922 next->data.load_set.set = 1923 next->data.signed_short; 1924 next->data.load_set.load = 1925 tree->data.signed_short; 1926 goto remove_label; 1927 /* TODO add XBC_LOAD_SETSYM */ 1928 case XBC_CAR: 1929 next->code = XBC_LOAD_CAR; 1930 next->data.signed_short = 1931 tree->data.signed_short; 1932 goto remove_label; 1933 case XBC_CDR: 1934 next->code = XBC_LOAD_CDR; 1935 next->data.signed_short = 1936 tree->data.signed_short; 1937 goto remove_label; 1938 case XBC_PUSH: 1939 tree->code = XBC_LOAD_PUSH; 1940 goto remove_next_label; 1941 case XBC_LET: 1942 next->code = XBC_LOAD_LET; 1943 next->data.let.name = next->data.atom; 1944 next->data.let.offset = 1945 tree->data.signed_short; 1946 goto remove_label; 1947 default: 1948 break; 1949 } 1950 } 1951 break; 1952 case XBC_LOAD_CAR: 1953 if (next && next->type == CodeTreeBytecode && 1954 next->code == XBC_SET) { 1955 if (next->data.signed_short == 1956 tree->data.signed_short) 1957 next->code = XBC_LOAD_CAR_STORE; 1958 else { 1959 next->code = XBC_LOAD_CAR_SET; 1960 next->data.load_set.set = 1961 next->data.signed_short; 1962 next->data.load_set.load = 1963 tree->data.signed_short; 1964 } 1965 goto remove_label; 1966 } 1967 break; 1968 case XBC_LOAD_CDR: 1969 if (next && next->type == CodeTreeBytecode && 1970 next->code == XBC_SET) { 1971 if (next->data.signed_short == 1972 tree->data.signed_short) 1973 next->code = XBC_LOAD_CDR_STORE; 1974 else { 1975 next->code = XBC_LOAD_CDR_SET; 1976 next->data.load_set.set = 1977 next->data.signed_short; 1978 next->data.load_set.load = 1979 tree->data.signed_short; 1980 } 1981 goto remove_label; 1982 } 1983 break; 1984 case XBC_CALL: 1985 if (next && next->type == CodeTreeBytecode) { 1986 switch (next->code) { 1987 case XBC_SET: 1988 next->code = XBC_CALL_SET; 1989 next->data.builtin.offset = 1990 next->data.signed_short; 1991 next->data.builtin.num_arguments = 1992 tree->data.builtin.num_arguments; 1993 next->data.builtin.builtin = 1994 tree->data.builtin.builtin; 1995 goto remove_label; 1996 /* TODO add XBC_CALL_SETSYM */ 1997 default: 1998 break; 1999 } 2000 } 2001 break; 2002 case XBC_CAR: 2003 if (next && next->type == CodeTreeBytecode) { 2004 switch (next->code) { 2005 case XBC_SET: 2006 next->code = XBC_CAR_SET; 2007 goto remove_label; 2008 /* TODO add XBC_CAR_SETSYM */ 2009 case XBC_PUSH: 2010 next->code = XBC_CAR_PUSH; 2011 goto remove_label; 2012 default: 2013 break; 2014 } 2015 } 2016 break; 2017 case XBC_CDR: 2018 if (next && next->type == CodeTreeBytecode) { 2019 switch (next->code) { 2020 case XBC_SET: 2021 next->code = XBC_CDR_SET; 2022 goto remove_label; 2023 /* TODO add XBC_CDR_SETSYM */ 2024 case XBC_PUSH: 2025 next->code = XBC_CDR_PUSH; 2026 goto remove_label; 2027 default: 2028 break; 2029 } 2030 } 2031 break; 2032 case XBC_NIL: 2033 if (next && next->type == CodeTreeBytecode) { 2034 switch (next->code) { 2035 case XBC_SET: 2036 next->code = XBC_SET_NIL; 2037 goto remove_label; 2038 /* TODO add XBC_SETSYM_NIL */ 2039 default: 2040 break; 2041 } 2042 } 2043 break; 2044 case XBC_PUSH_NIL: 2045 if (next && next->type == CodeTreeBytecode && 2046 next->code == XBC_PUSH_NIL) { 2047 next->code = XBC_PUSH_NIL_N; 2048 next->data.signed_char = 2; 2049 goto remove_label; 2050 } 2051 break; 2052 case XBC_PUSH_NIL_N: 2053 if (next && next->type == CodeTreeBytecode && 2054 next->code == XBC_PUSH_NIL) { 2055 next->code = XBC_PUSH_NIL_N; 2056 next->data.signed_char = tree->data.signed_char + 1; 2057 goto remove_label; 2058 } 2059 break; 2060 case XBC_PUSH_UNSPEC: 2061 if (next && next->type == CodeTreeBytecode && 2062 next->code == XBC_PUSH_UNSPEC) { 2063 next->code = XBC_PUSH_UNSPEC_N; 2064 next->data.signed_char = 2; 2065 goto remove_label; 2066 } 2067 break; 2068 case XBC_PUSH_UNSPEC_N: 2069 if (next && next->type == CodeTreeBytecode && 2070 next->code == XBC_PUSH_UNSPEC) { 2071 next->code = XBC_PUSH_UNSPEC_N; 2072 next->data.signed_char = tree->data.signed_char + 1; 2073 goto remove_label; 2074 } 2075 break; 2076 default: 2077 break; 2078 } 2079 break; 2080 case CodeTreeBlock: 2081 LinkDoOptimize_0(com, tree->data.block); 2082 break; 2083 default: 2084 break; 2085 } 2086 goto update_label; 2087 remove_label: 2088 if (tree == block->tree) { 2089 block->tree = prev = next; 2090 if (tree == block->tail) 2091 block->tail = tree; 2092 } 2093 else 2094 prev->next = next; 2095 CompileFreeTree(tree); 2096 tree = next; 2097 continue; 2098 remove_next_label: 2099 tree->next = next->next; 2100 CompileFreeTree(next); 2101 continue; 2102 update_label: 2103 prev = tree; 2104 tree = tree->next; 2105 } 2106 } 2107 2108 static void 2109 LinkOptimize_0(LispCom *com) 2110 { 2111 /* Recursive */ 2112 LinkDoOptimize_0(com, com->block); 2113 } 2114 2115 static void 2116 LinkResolveLabels(LispCom *com, CodeBlock *block) 2117 { 2118 int i; 2119 CodeTree *tree = block->tree; 2120 2121 for (; tree; tree = tree->next) { 2122 if (tree->type == CodeTreeBlock) 2123 LinkResolveLabels(com, tree->data.block); 2124 else if (tree->type == CodeTreeLabel) { 2125 for (i = 0; i < block->tagbody.length; i++) 2126 if (tree->data.object == block->tagbody.labels[i]) { 2127 block->tagbody.codes[i] = tree; 2128 break; 2129 } 2130 } 2131 } 2132 } 2133 2134 static void 2135 LinkResolveJumps(LispCom *com, CodeBlock *block) 2136 { 2137 int i; 2138 CodeBlock *body = block; 2139 CodeTree *ptr, *tree = block->tree; 2140 2141 /* Check if there is a tagbody. Error checking already done */ 2142 while (body && body->type != LispBlockBody) 2143 body = body->prev; 2144 2145 for (; tree; tree = tree->next) { 2146 switch (tree->type) { 2147 case CodeTreeBytecode: 2148 case CodeTreeLabel: 2149 break; 2150 2151 case CodeTreeBlock: 2152 LinkResolveJumps(com, tree->data.block); 2153 break; 2154 2155 case CodeTreeGo: 2156 for (i = 0; i < body->tagbody.length; i++) 2157 if (tree->data.object == body->tagbody.labels[i]) 2158 break; 2159 if (i == body->tagbody.length) 2160 LispDestroy("COMPILE: no visible tag %s to GO", 2161 STROBJ(tree->data.object)); 2162 /* Now the jump code is known */ 2163 tree->data.tree = body->tagbody.codes[i]; 2164 break; 2165 2166 case CodeTreeCond: 2167 if (tree->code == XBC_JUMPNIL) 2168 /* If test is NIL, go to next test */ 2169 tree->data.tree = tree->group->next; 2170 else if (tree->code == XBC_JUMPT) { 2171 /* After executing code, test was T */ 2172 for (ptr = tree->group; 2173 ptr->code != XBC_NOOP; 2174 ptr = ptr->group) 2175 ; 2176 tree->data.tree = ptr; 2177 } 2178 break; 2179 2180 case CodeTreeJumpIf: 2181 if (tree->code != XBC_NOOP) { 2182 for (ptr = tree->group; 2183 ptr->code != XBC_NOOP; 2184 ptr = ptr->group) { 2185 if (ptr->type == CodeTreeJump) { 2186 /* ELSE code of IF */ 2187 ptr = ptr->next; 2188 /* Skip inconditional jump node */ 2189 break; 2190 } 2191 } 2192 tree->data.tree = ptr; 2193 } 2194 break; 2195 2196 case CodeTreeJump: 2197 if (tree->code != XBC_NOOP) 2198 tree->data.tree = tree->group; 2199 break; 2200 2201 case CodeTreeReturn: 2202 /* One bytecode is guaranteed to exist in the code tree */ 2203 if (tree->data.block->parent == NULL) 2204 /* Returning from the function or toplevel form */ 2205 tree->data.tree = tree->data.block->tail; 2206 else { 2207 for (;;) { 2208 ptr = tree->data.block->parent->next; 2209 if (ptr) { 2210 tree->data.tree = ptr; 2211 break; 2212 } 2213 else 2214 /* Move one BLOCK up */ 2215 tree->data.block = tree->data.block->prev; 2216 } 2217 } 2218 break; 2219 } 2220 } 2221 } 2222 2223 static long 2224 LinkPad(long offset, long adjust, int preffix, int datalen) 2225 { 2226 /* If byte or aligned data */ 2227 if (datalen <= preffix || ((offset + adjust + preffix) % datalen) == 0) 2228 return (adjust); 2229 2230 return (adjust + (datalen - ((offset + adjust + preffix) % datalen))); 2231 } 2232 2233 static long 2234 LinkFixupOffsets(LispCom *com, CodeTree *tree, long adjust) 2235 { 2236 for (; tree; tree = tree->next) { 2237 switch (tree->type) { 2238 case CodeTreeBytecode: 2239 switch (tree->code) { 2240 /* byte + short */ 2241 case XBC_JUMP: 2242 case XBC_JUMPT: 2243 case XBC_JUMPNIL: 2244 adjust = LinkPad(tree->offset, adjust, 1, 2245 sizeof(short)); 2246 /*FALLTROUGH*/ 2247 default: 2248 tree->offset += adjust; 2249 break; 2250 } 2251 break; 2252 case CodeTreeLabel: 2253 /* Labels are not loaded, just adjust offset */ 2254 tree->offset += adjust; 2255 break; 2256 case CodeTreeJump: 2257 case CodeTreeCond: 2258 case CodeTreeJumpIf: 2259 /* If an opcode will be generated. */ 2260 if (tree->code != XBC_NOOP) 2261 adjust = LinkPad(tree->offset, adjust, 1, sizeof(short)); 2262 tree->offset += adjust; 2263 break; 2264 case CodeTreeGo: 2265 case CodeTreeReturn: 2266 adjust = LinkPad(tree->offset, adjust, 1, sizeof(short)); 2267 tree->offset += adjust; 2268 break; 2269 case CodeTreeBlock: 2270 adjust = LinkFixupOffsets(com, tree->data.block->tree, adjust); 2271 break; 2272 } 2273 } 2274 2275 return (adjust); 2276 } 2277 2278 static void 2279 LinkSkipPadding(LispCom *com, CodeTree *tree) 2280 { 2281 int found; 2282 CodeTree *ptr; 2283 2284 /* Recurse to adjust forward jumps or jumps to the start of the block */ 2285 for (ptr = tree; ptr; ptr = ptr->next) { 2286 if (ptr->type == CodeTreeBlock) { 2287 LinkSkipPadding(com, ptr->data.block->tree); 2288 ptr->offset = ptr->data.block->tree->offset; 2289 } 2290 } 2291 2292 /* Adjust the nodes offsets */ 2293 for (; tree; tree = tree->next) { 2294 switch (tree->type) { 2295 case CodeTreeBytecode: 2296 case CodeTreeBlock: 2297 case CodeTreeGo: 2298 case CodeTreeReturn: 2299 break; 2300 case CodeTreeJump: 2301 case CodeTreeCond: 2302 case CodeTreeJumpIf: 2303 if (tree->code != XBC_NOOP) 2304 /* If code will be generated */ 2305 break; 2306 case CodeTreeLabel: 2307 /* This should be done in reversed order, but to avoid 2308 * the requirement of a prev pointer, do the job in a 2309 * harder way here. */ 2310 for (found = 0, ptr = tree->next; ptr; ptr = ptr->next) { 2311 switch (ptr->type) { 2312 case CodeTreeBytecode: 2313 case CodeTreeBlock: 2314 case CodeTreeGo: 2315 case CodeTreeReturn: 2316 found = 1; 2317 break; 2318 case CodeTreeJump: 2319 case CodeTreeCond: 2320 case CodeTreeJumpIf: 2321 if (ptr->code != XBC_NOOP) 2322 found = 1; 2323 break; 2324 case CodeTreeLabel: 2325 break; 2326 } 2327 if (found) 2328 break; 2329 } 2330 if (found) 2331 tree->offset = ptr->offset; 2332 break; 2333 } 2334 } 2335 } 2336 2337 static void 2338 LinkCalculateJump(LispCom *com, CodeTree *tree, LispByteOpcode code) 2339 { 2340 long jumpto, offset, distance; 2341 2342 tree->type = CodeTreeBytecode; 2343 /* After the opcode */ 2344 offset = tree->offset + 1; 2345 jumpto = tree->data.tree->offset; 2346 /* Effective distance */ 2347 distance = jumpto - offset; 2348 tree->code = code; 2349 if (distance < -32768 || distance > 32767) { 2350 COMPILE_FAILURE("jump too long"); 2351 } 2352 tree->data.signed_int = distance; 2353 } 2354 2355 static void 2356 LinkFixupJumps(LispCom *com, CodeTree *tree) 2357 { 2358 for (; tree; tree = tree->next) { 2359 switch (tree->type) { 2360 case CodeTreeBytecode: 2361 case CodeTreeLabel: 2362 break; 2363 case CodeTreeCond: 2364 if (tree->code == XBC_JUMPNIL) 2365 /* Go to next test if NIL */ 2366 LinkCalculateJump(com, tree, XBC_JUMPNIL); 2367 else if (tree->code == XBC_JUMPT) 2368 /* After executing T code */ 2369 LinkCalculateJump(com, tree, XBC_JUMP); 2370 break; 2371 case CodeTreeJumpIf: 2372 if (tree->code != XBC_NOOP) 2373 LinkCalculateJump(com, tree, tree->code); 2374 break; 2375 case CodeTreeGo: 2376 /* Inconditional jump */ 2377 LinkCalculateJump(com, tree, XBC_JUMP); 2378 break; 2379 case CodeTreeReturn: 2380 /* Inconditional jump */ 2381 if (tree->data.tree != tree) 2382 /* If need to skip something */ 2383 LinkCalculateJump(com, tree, XBC_JUMP); 2384 break; 2385 case CodeTreeBlock: 2386 LinkFixupJumps(com, tree->data.block->tree); 2387 break; 2388 case CodeTreeJump: 2389 if (tree->code != XBC_NOOP) 2390 LinkCalculateJump(com, tree, tree->code); 2391 } 2392 } 2393 } 2394 2395 static void 2396 LinkBuildTableSymbol(LispCom *com, LispAtom *symbol) 2397 { 2398 if (BuildTablePointer(symbol, (void***)&com->table.symbols, 2399 &com->table.num_symbols) > 0xff) { 2400 COMPILE_FAILURE("more than 256 symbols"); 2401 } 2402 } 2403 2404 static void 2405 LinkBuildTableConstant(LispCom *com, LispObj *constant) 2406 { 2407 if (BuildTablePointer(constant, (void***)&com->table.constants, 2408 &com->table.num_constants) > 0xff) { 2409 COMPILE_FAILURE("more than 256 constants"); 2410 } 2411 } 2412 2413 static void 2414 LinkBuildTableBuiltin(LispCom *com, LispBuiltin *builtin) 2415 { 2416 if (BuildTablePointer(builtin, (void***)&com->table.builtins, 2417 &com->table.num_builtins) > 0xff) { 2418 COMPILE_FAILURE("more than 256 functions"); 2419 } 2420 } 2421 2422 static void 2423 LinkBuildTableBytecode(LispCom *com, LispObj *bytecode) 2424 { 2425 if (BuildTablePointer(bytecode, (void***)&com->table.bytecodes, 2426 &com->table.num_bytecodes) > 0xff) { 2427 COMPILE_FAILURE("more than 256 bytecode functions"); 2428 } 2429 } 2430 2431 static void 2432 LinkBuildTables(LispCom *com, CodeBlock *block) 2433 { 2434 CodeTree *tree; 2435 2436 for (tree = block->tree; tree; tree = tree->next) { 2437 switch (tree->type) { 2438 case CodeTreeBytecode: 2439 switch (tree->code) { 2440 case XBC_LET: 2441 case XBC_LETX: 2442 case XBC_LET_NIL: 2443 case XBC_LETX_NIL: 2444 case XBC_SETSYM: 2445 case XBC_LOADSYM: 2446 case XBC_LOADSYM_PUSH: 2447 LinkBuildTableSymbol(com, tree->data.atom); 2448 break; 2449 case XBC_STRUCTP: 2450 case XBC_LOADCON: 2451 case XBC_LOADCON_PUSH: 2452 LinkBuildTableConstant(com, tree->data.object); 2453 break; 2454 case XBC_LOADCON_SET: 2455 LinkBuildTableConstant(com, tree->data.load_con_set.object); 2456 break; 2457 case XBC_CALL: 2458 case XBC_CALL_SET: 2459 LinkBuildTableBuiltin(com, tree->data.builtin.builtin); 2460 break; 2461 case XBC_BYTECALL: 2462 LinkBuildTableBytecode(com, tree->data.bytecall.code); 2463 break; 2464 case XBC_LOAD_LET: 2465 case XBC_LOAD_LETX: 2466 LinkBuildTableSymbol(com, tree->data.let.name); 2467 break; 2468 case XBC_STRUCT: 2469 LinkBuildTableConstant(com, tree->data.struc.definition); 2470 break; 2471 case XBC_LOADSYM_LET: 2472 case XBC_LOADSYM_LETX: 2473 LinkBuildTableSymbol(com, tree->data.let_sym.symbol); 2474 LinkBuildTableSymbol(com, tree->data.let_sym.name); 2475 break; 2476 case XBC_LOADCON_LET: 2477 case XBC_LOADCON_LETX: 2478 LinkBuildTableConstant(com, tree->data.let_con.object); 2479 LinkBuildTableSymbol(com, tree->data.let_con.name); 2480 break; 2481 case XBC_CCONS: 2482 case XBC_FUNCALL: 2483 LinkBuildTableConstant(com, tree->data.cons.car); 2484 LinkBuildTableConstant(com, tree->data.cons.cdr); 2485 break; 2486 default: 2487 break; 2488 } 2489 break; 2490 case CodeTreeBlock: 2491 LinkBuildTables(com, tree->data.block); 2492 break; 2493 default: 2494 break; 2495 } 2496 } 2497 } 2498 2499 static long 2500 LinkEmmitBytecode(LispCom *com, CodeTree *tree, 2501 unsigned char *bytecode, long offset) 2502 { 2503 short i; 2504 2505 for (; tree; tree = tree->next) { 2506 /* Fill padding */ 2507 while (offset < tree->offset) 2508 bytecode[offset++] = XBC_NOOP; 2509 2510 switch (tree->type) { 2511 case CodeTreeBytecode: 2512 bytecode[offset++] = tree->code; 2513 switch (tree->code) { 2514 /* Noop should not enter the CodeTree */ 2515 case XBC_NOOP: 2516 INTERNAL_ERROR(__LINE__); 2517 break; 2518 2519 /* byte */ 2520 case XBC_BCONS: 2521 case XBC_BCONS1: 2522 case XBC_BCONS2: 2523 case XBC_BCONS3: 2524 case XBC_BCONS4: 2525 case XBC_BCONS5: 2526 case XBC_BCONS6: 2527 case XBC_BCONS7: 2528 case XBC_INV: 2529 case XBC_NIL: 2530 case XBC_T: 2531 case XBC_PUSH_NIL: 2532 case XBC_PUSH_UNSPEC: 2533 case XBC_PUSH_T: 2534 case XBC_CAR_PUSH: 2535 case XBC_CDR_PUSH: 2536 case XBC_PUSH: 2537 case XBC_LSTAR: 2538 case XBC_LCONS: 2539 case XBC_LFINI: 2540 case XBC_RETURN: 2541 case XBC_CSTAR: 2542 case XBC_CFINI: 2543 case XBC_CAR: 2544 case XBC_CDR: 2545 case XBC_RPLACA: 2546 case XBC_RPLACD: 2547 case XBC_EQ: 2548 case XBC_EQL: 2549 case XBC_EQUAL: 2550 case XBC_EQUALP: 2551 case XBC_LENGTH: 2552 case XBC_LAST: 2553 case XBC_NTHCDR: 2554 break; 2555 2556 /* byte + byte */ 2557 case XBC_LETREC: 2558 case XBC_PRED: 2559 case XBC_PUSH_NIL_N: 2560 case XBC_PUSH_UNSPEC_N: 2561 bytecode[offset++] = tree->data.signed_char; 2562 break; 2563 2564 /* byte + byte */ 2565 case XBC_CAR_SET: 2566 case XBC_CDR_SET: 2567 case XBC_SET: 2568 case XBC_SET_NIL: 2569 case XBC_LETBIND: 2570 case XBC_UNLET: 2571 case XBC_LOAD_PUSH: 2572 case XBC_LOAD: 2573 case XBC_LOAD_CAR: 2574 case XBC_LOAD_CDR: 2575 case XBC_LOAD_CAR_STORE: 2576 case XBC_LOAD_CDR_STORE: 2577 bytecode[offset++] = tree->data.signed_short; 2578 break; 2579 2580 /* byte + byte + byte */ 2581 case XBC_LOAD_SET: 2582 case XBC_LOAD_CAR_SET: 2583 case XBC_LOAD_CDR_SET: 2584 bytecode[offset++] = tree->data.load_set.load; 2585 bytecode[offset++] = tree->data.load_set.set; 2586 break; 2587 2588 /* byte + short */ 2589 case XBC_JUMP: 2590 case XBC_JUMPT: 2591 case XBC_JUMPNIL: 2592 *(short*)(bytecode + offset) = tree->data.signed_int; 2593 offset += sizeof(short); 2594 break; 2595 2596 /* byte + byte */ 2597 case XBC_LET: 2598 case XBC_LETX: 2599 case XBC_LET_NIL: 2600 case XBC_LETX_NIL: 2601 case XBC_SETSYM: 2602 case XBC_LOADSYM: 2603 case XBC_LOADSYM_PUSH: 2604 i = FindIndex(tree->data.atom, 2605 (void**)com->table.symbols, 2606 com->table.num_symbols); 2607 bytecode[offset++] = i; 2608 break; 2609 2610 /* byte + byte */ 2611 case XBC_STRUCTP: 2612 case XBC_LOADCON: 2613 case XBC_LOADCON_PUSH: 2614 i = FindIndex(tree->data.object, 2615 (void**)com->table.constants, 2616 com->table.num_constants); 2617 bytecode[offset++] = i; 2618 break; 2619 2620 /* byte + byte + byte */ 2621 case XBC_LOADCON_SET: 2622 i = FindIndex(tree->data.load_con_set.object, 2623 (void**)com->table.constants, 2624 com->table.num_constants); 2625 bytecode[offset++] = i; 2626 bytecode[offset++] = tree->data.load_con_set.offset; 2627 break; 2628 2629 /* byte + byte + byte */ 2630 case XBC_CALL: 2631 bytecode[offset++] = tree->data.builtin.num_arguments; 2632 i = FindIndex(tree->data.builtin.builtin, 2633 (void**)com->table.builtins, 2634 com->table.num_builtins); 2635 bytecode[offset++] = i; 2636 break; 2637 2638 /* byte + byte + byte */ 2639 case XBC_BYTECALL: 2640 bytecode[offset++] = tree->data.bytecall.num_arguments; 2641 i = FindIndex(tree->data.bytecall.code, 2642 (void**)com->table.bytecodes, 2643 com->table.num_bytecodes); 2644 bytecode[offset++] = i; 2645 break; 2646 2647 /* byte + byte + byte + byte */ 2648 case XBC_CALL_SET: 2649 bytecode[offset++] = tree->data.builtin.num_arguments; 2650 i = FindIndex(tree->data.builtin.builtin, 2651 (void**)com->table.builtins, 2652 com->table.num_builtins); 2653 bytecode[offset++] = i; 2654 bytecode[offset++] = tree->data.builtin.offset; 2655 break; 2656 2657 /* byte + byte + byte */ 2658 case XBC_LOAD_LET: 2659 case XBC_LOAD_LETX: 2660 bytecode[offset++] = tree->data.let.offset; 2661 i = FindIndex(tree->data.let.name, 2662 (void**)com->table.symbols, 2663 com->table.num_symbols); 2664 bytecode[offset++] = i; 2665 break; 2666 2667 /* byte + byte + byte */ 2668 case XBC_STRUCT: 2669 bytecode[offset++] = tree->data.struc.offset; 2670 i = FindIndex(tree->data.struc.definition, 2671 (void**)com->table.constants, 2672 com->table.num_constants); 2673 bytecode[offset++] = i; 2674 break; 2675 2676 /* byte + byte + byte */ 2677 case XBC_LOADSYM_LET: 2678 case XBC_LOADSYM_LETX: 2679 i = FindIndex(tree->data.let_sym.symbol, 2680 (void**)com->table.symbols, 2681 com->table.num_symbols); 2682 bytecode[offset++] = i; 2683 i = FindIndex(tree->data.let_sym.name, 2684 (void**)com->table.symbols, 2685 com->table.num_symbols); 2686 bytecode[offset++] = i; 2687 break; 2688 2689 /* byte + byte + byte */ 2690 case XBC_LOADCON_LET: 2691 case XBC_LOADCON_LETX: 2692 i = FindIndex(tree->data.let_con.object, 2693 (void**)com->table.constants, 2694 com->table.num_constants); 2695 bytecode[offset++] = i; 2696 i = FindIndex(tree->data.let_con.name, 2697 (void**)com->table.symbols, 2698 com->table.num_symbols); 2699 bytecode[offset++] = i; 2700 break; 2701 2702 /* byte + byte + byte */ 2703 case XBC_CCONS: 2704 case XBC_FUNCALL: 2705 i = FindIndex(tree->data.cons.car, 2706 (void**)com->table.constants, 2707 com->table.num_constants); 2708 bytecode[offset++] = i; 2709 i = FindIndex(tree->data.cons.cdr, 2710 (void**)com->table.constants, 2711 com->table.num_constants); 2712 bytecode[offset++] = i; 2713 break; 2714 } 2715 break; 2716 case CodeTreeLabel: 2717 /* Labels are not loaded */ 2718 break; 2719 case CodeTreeCond: 2720 case CodeTreeJump: 2721 case CodeTreeJumpIf: 2722 if (tree->code != XBC_NOOP) 2723 INTERNAL_ERROR(__LINE__); 2724 break; 2725 case CodeTreeGo: 2726 INTERNAL_ERROR(__LINE__); 2727 break; 2728 case CodeTreeReturn: 2729 if (tree->data.tree != tree) 2730 INTERNAL_ERROR(__LINE__); 2731 break; 2732 case CodeTreeBlock: 2733 offset = LinkEmmitBytecode(com, tree->data.block->tree, 2734 bytecode, offset); 2735 break; 2736 } 2737 } 2738 2739 return (offset); 2740 } 2741 2742 static void 2743 LinkBytecode(LispCom *com) 2744 { 2745 long offset, count; 2746 unsigned char **codes; 2747 LispObj **names; 2748 2749 /* Close bytecode */ 2750 com_Bytecode(com, XBC_RETURN); 2751 2752 /* The only usage of this information for now, and still may generate 2753 * false positives because arguments to unamed functions are not being 2754 * parsed as well as arguments to yet undefined function/maros. 2755 * XXX should also add declaim/declare to let the code specify that 2756 * the argument is unused */ 2757 LinkWarnUnused(com, com->block); 2758 2759 /* First level optimization */ 2760 LinkOptimize_0(com); 2761 2762 /* Resolve tagbody labels */ 2763 LinkResolveLabels(com, com->block); 2764 2765 /* Resolve any pending jumps */ 2766 LinkResolveJumps(com, com->block); 2767 2768 /* Calculate unpadded offsets */ 2769 LinkBuildOffsets(com, com->block->tree, 0); 2770 2771 /* Do padding for aligned memory reads */ 2772 LinkFixupOffsets(com, com->block->tree, 0); 2773 2774 /* Jumps normally are to a node that does not generate code, 2775 * and due to padding, the jump may go to a address with a 2776 * XBC_NOOP, so adjust the jump to the next useful opcode. */ 2777 LinkSkipPadding(com, com->block->tree); 2778 2779 /* Now addresses are known */ 2780 LinkFixupJumps(com, com->block->tree); 2781 2782 /* Build symbol, constant and builtin tables */ 2783 LinkBuildTables(com, com->block); 2784 2785 /* Stack info */ 2786 com->length = sizeof(short) * 3; 2787 /* Tables info */ 2788 com->length += sizeof(short) * 4; 2789 com->length += com->table.num_constants * sizeof(LispObj*); 2790 com->length += com->table.num_symbols * sizeof(LispAtom*); 2791 com->length += com->table.num_builtins * sizeof(LispBuiltin*); 2792 com->length += com->table.num_bytecodes * sizeof(unsigned char*); 2793 com->length += com->table.num_bytecodes * sizeof(LispObj*); 2794 2795 /* Allocate space for the bytecode stream */ 2796 com->length += com->block->tail->offset + 1; 2797 com->bytecode = LispMalloc(com->length); 2798 2799 /* Add header */ 2800 offset = 0; 2801 *(short*)(com->bytecode + offset) = com->stack.stack; 2802 offset += sizeof(short); 2803 *(short*)(com->bytecode + offset) = com->stack.bstack; 2804 offset += sizeof(short); 2805 *(short*)(com->bytecode + offset) = com->stack.pstack; 2806 offset += sizeof(short); 2807 2808 *(short*)(com->bytecode + offset) = com->table.num_constants; 2809 offset += sizeof(short); 2810 *(short*)(com->bytecode + offset) = com->table.num_symbols; 2811 offset += sizeof(short); 2812 *(short*)(com->bytecode + offset) = com->table.num_builtins; 2813 offset += sizeof(short); 2814 *(short*)(com->bytecode + offset) = com->table.num_bytecodes; 2815 offset += sizeof(short); 2816 2817 count = sizeof(LispObj*) * com->table.num_constants; 2818 memcpy(com->bytecode + offset, com->table.constants, count); 2819 offset += count; 2820 count = sizeof(LispAtom*) * com->table.num_symbols; 2821 memcpy(com->bytecode + offset, com->table.symbols, count); 2822 offset += count; 2823 count = sizeof(LispBuiltin*) * com->table.num_builtins; 2824 memcpy(com->bytecode + offset, com->table.builtins, count); 2825 offset += count; 2826 2827 /* Store bytecode information */ 2828 for (count = 0, codes = (unsigned char**)(com->bytecode + offset); 2829 count < com->table.num_bytecodes; count++, codes++) 2830 *codes = com->table.bytecodes[count]->data.bytecode.bytecode->code; 2831 offset += com->table.num_bytecodes * sizeof(unsigned char*); 2832 /* Store names, only useful for disassemble but may also be used 2833 * to check if a function was redefined, and the bytecode is referencing 2834 * the older version, the current version can be checked looking at 2835 * <name>->data.atom */ 2836 for (count = 0, names = (LispObj**)(com->bytecode + offset); 2837 count < com->table.num_bytecodes; count++, names++) 2838 *names = com->table.bytecodes[count]->data.bytecode.name; 2839 offset += com->table.num_bytecodes * sizeof(LispObj*); 2840 2841 /* Generate it */ 2842 LinkEmmitBytecode(com, com->block->tree, com->bytecode + offset, 0); 2843 } 2844 2845 static LispObj * 2846 ExecuteBytecode(register unsigned char *stream) 2847 { 2848 register LispObj *reg0; 2849 register LispAtom *atom; 2850 register short offset; 2851 LispObj *reg1; 2852 LispBuiltin *builtin; 2853 LispObj *lambda; 2854 LispObj *arguments; 2855 unsigned char *bytecode; 2856 2857 LispObj **constants; 2858 LispAtom **symbols; 2859 LispBuiltin **builtins; 2860 unsigned char **codes; 2861 short num_constants, num_symbols, num_builtins, num_codes; 2862 2863 int lex, len; 2864 2865 /* To control gc protected slots */ 2866 int phead, pbase; 2867 2868 long fixnum = 0; 2869 2870 #if defined(__GNUC__) && !defined(ANSI_SOURCE) 2871 #define ALLOW_GOTO_ADDRESS 2872 #endif 2873 2874 #ifdef ALLOW_GOTO_ADDRESS 2875 #define JUMP_ADDRESS(label) &&label 2876 static const void *opcode_labels[] = { 2877 JUMP_ADDRESS(XBC_NOOP), 2878 JUMP_ADDRESS(XBC_INV), 2879 JUMP_ADDRESS(XBC_NIL), 2880 JUMP_ADDRESS(XBC_T), 2881 JUMP_ADDRESS(XBC_PRED), 2882 JUMP_ADDRESS(XBC_CAR), 2883 JUMP_ADDRESS(XBC_CDR), 2884 JUMP_ADDRESS(XBC_CAR_SET), 2885 JUMP_ADDRESS(XBC_CDR_SET), 2886 JUMP_ADDRESS(XBC_RPLACA), 2887 JUMP_ADDRESS(XBC_RPLACD), 2888 JUMP_ADDRESS(XBC_EQ), 2889 JUMP_ADDRESS(XBC_EQL), 2890 JUMP_ADDRESS(XBC_EQUAL), 2891 JUMP_ADDRESS(XBC_EQUALP), 2892 JUMP_ADDRESS(XBC_LENGTH), 2893 JUMP_ADDRESS(XBC_LAST), 2894 JUMP_ADDRESS(XBC_NTHCDR), 2895 JUMP_ADDRESS(XBC_CAR_PUSH), 2896 JUMP_ADDRESS(XBC_CDR_PUSH), 2897 JUMP_ADDRESS(XBC_PUSH), 2898 JUMP_ADDRESS(XBC_PUSH_NIL), 2899 JUMP_ADDRESS(XBC_PUSH_UNSPEC), 2900 JUMP_ADDRESS(XBC_PUSH_T), 2901 JUMP_ADDRESS(XBC_PUSH_NIL_N), 2902 JUMP_ADDRESS(XBC_PUSH_UNSPEC_N), 2903 JUMP_ADDRESS(XBC_LET), 2904 JUMP_ADDRESS(XBC_LETX), 2905 JUMP_ADDRESS(XBC_LET_NIL), 2906 JUMP_ADDRESS(XBC_LETX_NIL), 2907 JUMP_ADDRESS(XBC_LETBIND), 2908 JUMP_ADDRESS(XBC_UNLET), 2909 JUMP_ADDRESS(XBC_LOAD), 2910 JUMP_ADDRESS(XBC_LOAD_LET), 2911 JUMP_ADDRESS(XBC_LOAD_LETX), 2912 JUMP_ADDRESS(XBC_LOAD_PUSH), 2913 JUMP_ADDRESS(XBC_LOADCON), 2914 JUMP_ADDRESS(XBC_LOADCON_LET), 2915 JUMP_ADDRESS(XBC_LOADCON_LETX), 2916 JUMP_ADDRESS(XBC_LOADCON_PUSH), 2917 JUMP_ADDRESS(XBC_LOAD_CAR), 2918 JUMP_ADDRESS(XBC_LOAD_CDR), 2919 JUMP_ADDRESS(XBC_LOAD_CAR_STORE), 2920 JUMP_ADDRESS(XBC_LOAD_CDR_STORE), 2921 JUMP_ADDRESS(XBC_LOADCON_SET), 2922 JUMP_ADDRESS(XBC_LOADSYM), 2923 JUMP_ADDRESS(XBC_LOADSYM_LET), 2924 JUMP_ADDRESS(XBC_LOADSYM_LETX), 2925 JUMP_ADDRESS(XBC_LOADSYM_PUSH), 2926 JUMP_ADDRESS(XBC_LOAD_SET), 2927 JUMP_ADDRESS(XBC_LOAD_CAR_SET), 2928 JUMP_ADDRESS(XBC_LOAD_CDR_SET), 2929 JUMP_ADDRESS(XBC_SET), 2930 JUMP_ADDRESS(XBC_SETSYM), 2931 JUMP_ADDRESS(XBC_SET_NIL), 2932 JUMP_ADDRESS(XBC_CALL), 2933 JUMP_ADDRESS(XBC_CALL_SET), 2934 JUMP_ADDRESS(XBC_BYTECALL), 2935 JUMP_ADDRESS(XBC_FUNCALL), 2936 JUMP_ADDRESS(XBC_LETREC), 2937 JUMP_ADDRESS(XBC_BCONS), 2938 JUMP_ADDRESS(XBC_BCONS1), 2939 JUMP_ADDRESS(XBC_BCONS2), 2940 JUMP_ADDRESS(XBC_BCONS3), 2941 JUMP_ADDRESS(XBC_BCONS4), 2942 JUMP_ADDRESS(XBC_BCONS5), 2943 JUMP_ADDRESS(XBC_BCONS6), 2944 JUMP_ADDRESS(XBC_BCONS7), 2945 JUMP_ADDRESS(XBC_CCONS), 2946 JUMP_ADDRESS(XBC_CSTAR), 2947 JUMP_ADDRESS(XBC_CFINI), 2948 JUMP_ADDRESS(XBC_LSTAR), 2949 JUMP_ADDRESS(XBC_LCONS), 2950 JUMP_ADDRESS(XBC_LFINI), 2951 JUMP_ADDRESS(XBC_JUMP), 2952 JUMP_ADDRESS(XBC_JUMPT), 2953 JUMP_ADDRESS(XBC_JUMPNIL), 2954 JUMP_ADDRESS(XBC_STRUCT), 2955 JUMP_ADDRESS(XBC_STRUCTP), 2956 JUMP_ADDRESS(XBC_RETURN) 2957 }; 2958 static const void *predicate_opcode_labels[] = { 2959 JUMP_ADDRESS(XBP_CONSP), 2960 JUMP_ADDRESS(XBP_LISTP), 2961 JUMP_ADDRESS(XBP_NUMBERP) 2962 }; 2963 #endif 2964 2965 reg0 = NIL; 2966 2967 bytecode = stream; 2968 pbase = lisp__data.protect.length; 2969 2970 /* stack */ 2971 offset = *(short*)stream; 2972 stream += sizeof(short); 2973 if (lisp__data.env.length + offset > lisp__data.env.space) { 2974 do 2975 LispMoreEnvironment(); 2976 while (lisp__data.env.length + offset >= lisp__data.env.space); 2977 } 2978 /* builtin stack */ 2979 offset = *(short*)stream; 2980 stream += sizeof(short); 2981 if (lisp__data.stack.length + offset >= lisp__data.stack.space) { 2982 do 2983 LispMoreStack(); 2984 while (lisp__data.stack.length + offset >= lisp__data.stack.space); 2985 } 2986 /* protect stack */ 2987 phead = *(short*)stream; 2988 stream += sizeof(short); 2989 if (lisp__data.protect.length + phead > lisp__data.protect.space) { 2990 do 2991 LispMoreProtects(); 2992 while (lisp__data.protect.length + phead >= lisp__data.protect.space); 2993 } 2994 2995 num_constants = *(short*)stream; 2996 stream += sizeof(short); 2997 num_symbols = *(short*)stream; 2998 stream += sizeof(short); 2999 num_builtins = *(short*)stream; 3000 stream += sizeof(short); 3001 num_codes = *(short*)stream; 3002 stream += sizeof(short); 3003 3004 constants = (LispObj**)stream; 3005 stream += num_constants * sizeof(LispObj*); 3006 symbols = (LispAtom**)stream; 3007 stream += num_symbols * sizeof(LispAtom*); 3008 builtins = (LispBuiltin**)stream; 3009 stream += num_builtins * sizeof(LispBuiltin*); 3010 codes = (unsigned char**)stream; 3011 stream += num_codes * (sizeof(unsigned char*) + sizeof(LispObj*)); 3012 3013 for (; phead > 0; phead--) 3014 lisp__data.protect.objects[lisp__data.protect.length++] = NIL; 3015 phead = pbase; 3016 3017 #ifdef ALLOW_GOTO_ADDRESS 3018 #define OPCODE_LABEL(label) label 3019 #define NEXT_OPCODE() goto *opcode_labels[*stream++] 3020 #define GOTO_PREDICATE() goto *predicate_opcode_labels[*stream++] 3021 #else 3022 #define OPCODE_LABEL(label) case label 3023 #define NEXT_OPCODE() goto next_opcode 3024 #define GOTO_PREDICATE() goto predicate_label 3025 for (;;) { 3026 next_opcode: 3027 switch (*stream++) { 3028 #endif /* ALLOW_GOTO_ADDRESS */ 3029 3030 OPCODE_LABEL(XBC_NOOP): 3031 NEXT_OPCODE(); 3032 3033 OPCODE_LABEL(XBC_PRED): 3034 GOTO_PREDICATE(); 3035 3036 OPCODE_LABEL(XBC_INV): 3037 reg0 = reg0 == NIL ? T : NIL; 3038 NEXT_OPCODE(); 3039 3040 OPCODE_LABEL(XBC_NIL): 3041 reg0 = NIL; 3042 NEXT_OPCODE(); 3043 3044 OPCODE_LABEL(XBC_T): 3045 reg0 = T; 3046 NEXT_OPCODE(); 3047 3048 OPCODE_LABEL(XBC_CAR): 3049 car: 3050 if (reg0 != NIL) { 3051 if (!CONSP(reg0)) 3052 LispDestroy("CAR: %s is not a list", STROBJ(reg0)); 3053 reg0 = CAR(reg0); 3054 } 3055 NEXT_OPCODE(); 3056 3057 OPCODE_LABEL(XBC_CDR): 3058 cdr: 3059 if (reg0 != NIL) { 3060 if (!CONSP(reg0)) 3061 LispDestroy("CDR: %s is not a list", STROBJ(reg0)); 3062 reg0 = CDR(reg0); 3063 } 3064 NEXT_OPCODE(); 3065 3066 OPCODE_LABEL(XBC_RPLACA): 3067 reg1 = lisp__data.stack.values[--lisp__data.stack.length]; 3068 if (!CONSP(reg1)) 3069 LispDestroy("RPLACA: %s is not a cons", STROBJ(reg1)); 3070 RPLACA(reg1, reg0); 3071 reg0 = reg1; 3072 NEXT_OPCODE(); 3073 3074 OPCODE_LABEL(XBC_RPLACD): 3075 reg1 = lisp__data.stack.values[--lisp__data.stack.length]; 3076 if (!CONSP(reg1)) 3077 LispDestroy("RPLACD: %s is not a cons", STROBJ(reg1)); 3078 RPLACD(reg1, reg0); 3079 reg0 = reg1; 3080 NEXT_OPCODE(); 3081 3082 OPCODE_LABEL(XBC_BCONS): 3083 CAR(cons) = reg0; 3084 lisp__data.stack.values[lisp__data.stack.length++] = cons; 3085 NEXT_OPCODE(); 3086 3087 OPCODE_LABEL(XBC_BCONS1): 3088 offset = lisp__data.stack.length - 1; 3089 CAR(cons) = reg0; 3090 CAR(cons1) = lisp__data.stack.values[offset]; 3091 lisp__data.stack.values[offset] = cons1; 3092 NEXT_OPCODE(); 3093 3094 OPCODE_LABEL(XBC_BCONS2): 3095 offset = lisp__data.stack.length; 3096 CAR(cons) = reg0; 3097 CAR(cons1) = lisp__data.stack.values[--offset]; 3098 CAR(cons2) = lisp__data.stack.values[--offset]; 3099 lisp__data.stack.values[offset] = cons2; 3100 lisp__data.stack.length = offset + 1; 3101 NEXT_OPCODE(); 3102 3103 OPCODE_LABEL(XBC_BCONS3): 3104 offset = lisp__data.stack.length; 3105 CAR(cons) = reg0; 3106 CAR(cons1) = lisp__data.stack.values[--offset]; 3107 CAR(cons2) = lisp__data.stack.values[--offset]; 3108 CAR(cons3) = lisp__data.stack.values[--offset]; 3109 lisp__data.stack.values[offset] = cons3; 3110 lisp__data.stack.length = offset + 1; 3111 NEXT_OPCODE(); 3112 3113 OPCODE_LABEL(XBC_BCONS4): 3114 offset = lisp__data.stack.length; 3115 CAR(cons) = reg0; 3116 CAR(cons1) = lisp__data.stack.values[--offset]; 3117 CAR(cons2) = lisp__data.stack.values[--offset]; 3118 CAR(cons3) = lisp__data.stack.values[--offset]; 3119 CAR(cons4) = lisp__data.stack.values[--offset]; 3120 lisp__data.stack.values[offset] = cons4; 3121 lisp__data.stack.length = offset + 1; 3122 NEXT_OPCODE(); 3123 3124 OPCODE_LABEL(XBC_BCONS5): 3125 offset = lisp__data.stack.length; 3126 CAR(cons) = reg0; 3127 CAR(cons1) = lisp__data.stack.values[--offset]; 3128 CAR(cons2) = lisp__data.stack.values[--offset]; 3129 CAR(cons3) = lisp__data.stack.values[--offset]; 3130 CAR(cons4) = lisp__data.stack.values[--offset]; 3131 CAR(cons5) = lisp__data.stack.values[--offset]; 3132 lisp__data.stack.values[offset] = cons5; 3133 lisp__data.stack.length = offset + 1; 3134 NEXT_OPCODE(); 3135 3136 OPCODE_LABEL(XBC_BCONS6): 3137 offset = lisp__data.stack.length; 3138 CAR(cons) = reg0; 3139 CAR(cons1) = lisp__data.stack.values[--offset]; 3140 CAR(cons2) = lisp__data.stack.values[--offset]; 3141 CAR(cons3) = lisp__data.stack.values[--offset]; 3142 CAR(cons4) = lisp__data.stack.values[--offset]; 3143 CAR(cons5) = lisp__data.stack.values[--offset]; 3144 CAR(cons6) = lisp__data.stack.values[--offset]; 3145 lisp__data.stack.values[offset] = cons6; 3146 lisp__data.stack.length = offset + 1; 3147 NEXT_OPCODE(); 3148 3149 OPCODE_LABEL(XBC_BCONS7): 3150 offset = lisp__data.stack.length; 3151 CAR(cons) = reg0; 3152 CAR(cons1) = lisp__data.stack.values[--offset]; 3153 CAR(cons2) = lisp__data.stack.values[--offset]; 3154 CAR(cons3) = lisp__data.stack.values[--offset]; 3155 CAR(cons4) = lisp__data.stack.values[--offset]; 3156 CAR(cons5) = lisp__data.stack.values[--offset]; 3157 CAR(cons6) = lisp__data.stack.values[--offset]; 3158 CAR(cons7) = lisp__data.stack.values[--offset]; 3159 lisp__data.stack.values[offset] = cons7; 3160 lisp__data.stack.length = offset + 1; 3161 NEXT_OPCODE(); 3162 3163 OPCODE_LABEL(XBC_EQ): 3164 reg0 = reg0 == lisp__data.stack.values[--lisp__data.stack.length] ? T : NIL; 3165 NEXT_OPCODE(); 3166 3167 OPCODE_LABEL(XBC_EQL): 3168 reg1 = lisp__data.stack.values[--lisp__data.stack.length]; 3169 reg0 = XEQL(reg1, reg0); 3170 NEXT_OPCODE(); 3171 3172 OPCODE_LABEL(XBC_EQUAL): 3173 reg1 = lisp__data.stack.values[--lisp__data.stack.length]; 3174 reg0 = XEQUAL(reg1, reg0); 3175 NEXT_OPCODE(); 3176 3177 OPCODE_LABEL(XBC_EQUALP): 3178 reg1 = lisp__data.stack.values[--lisp__data.stack.length]; 3179 reg0 = XEQUALP(reg1, reg0); 3180 NEXT_OPCODE(); 3181 3182 OPCODE_LABEL(XBC_LENGTH): 3183 reg0 = FIXNUM(LispLength(reg0)); 3184 NEXT_OPCODE(); 3185 3186 OPCODE_LABEL(XBC_LAST): 3187 { 3188 long length; 3189 3190 reg1 = lisp__data.stack.values[--lisp__data.stack.length]; 3191 if (CONSP(reg1)) { 3192 if (reg0 != NIL) { 3193 if (!FIXNUMP(reg0) || (fixnum = FIXNUM_VALUE(reg0)) < 0) 3194 LispDestroy("LAST: %s is not a positive fixnum", 3195 STROBJ(reg0)); 3196 } 3197 else 3198 fixnum = 1; 3199 reg0 = reg1; 3200 for (reg0 = reg1, length = 0; 3201 CONSP(reg0); 3202 reg0 = CDR(reg0), length++) 3203 ; 3204 for (length -= fixnum, reg0 = reg1; length > 0; length--) 3205 reg0 = CDR(reg0); 3206 } 3207 else 3208 reg0 = reg1; 3209 } NEXT_OPCODE(); 3210 3211 OPCODE_LABEL(XBC_NTHCDR): 3212 reg1 = lisp__data.stack.values[--lisp__data.stack.length]; 3213 if (!FIXNUMP(reg1) || (fixnum = FIXNUM_VALUE(reg1)) < 0) 3214 LispDestroy("NTHCDR: %s is not a positive fixnum", 3215 STROBJ(reg1)); 3216 if (reg0 != NIL) { 3217 if (!CONSP(reg0)) 3218 LispDestroy("NTHCDR: %s is not a list", STROBJ(reg0)); 3219 for (; fixnum > 0; fixnum--) { 3220 if (!CONSP(reg0)) 3221 break; 3222 reg0 = CDR(reg0); 3223 } 3224 } 3225 NEXT_OPCODE(); 3226 3227 /* Push to builtin stack */ 3228 OPCODE_LABEL(XBC_CAR_PUSH): 3229 if (reg0 != NIL) { 3230 if (!CONSP(reg0)) 3231 LispDestroy("CAR: %s is not a list", STROBJ(reg0)); 3232 reg0 = CAR(reg0); 3233 } 3234 goto push_builtin; 3235 3236 OPCODE_LABEL(XBC_CDR_PUSH): 3237 if (reg0 != NIL) { 3238 if (!CONSP(reg0)) 3239 LispDestroy("CDR: %s is not a list", STROBJ(reg0)); 3240 reg0 = CDR(reg0); 3241 } 3242 /*FALLTROUGH*/ 3243 3244 OPCODE_LABEL(XBC_PUSH): 3245 push_builtin: 3246 lisp__data.stack.values[lisp__data.stack.length++] = reg0; 3247 NEXT_OPCODE(); 3248 3249 OPCODE_LABEL(XBC_PUSH_NIL): 3250 lisp__data.stack.values[lisp__data.stack.length++] = NIL; 3251 NEXT_OPCODE(); 3252 3253 OPCODE_LABEL(XBC_PUSH_UNSPEC): 3254 lisp__data.stack.values[lisp__data.stack.length++] = UNSPEC; 3255 NEXT_OPCODE(); 3256 3257 OPCODE_LABEL(XBC_PUSH_T): 3258 lisp__data.stack.values[lisp__data.stack.length++] = T; 3259 NEXT_OPCODE(); 3260 3261 OPCODE_LABEL(XBC_PUSH_NIL_N): 3262 for (offset = *stream++; offset > 0; offset--) 3263 lisp__data.stack.values[lisp__data.stack.length++] = NIL; 3264 NEXT_OPCODE(); 3265 3266 OPCODE_LABEL(XBC_PUSH_UNSPEC_N): 3267 for (offset = *stream++; offset > 0; offset--) 3268 lisp__data.stack.values[lisp__data.stack.length++] = UNSPEC; 3269 NEXT_OPCODE(); 3270 3271 OPCODE_LABEL(XBC_LET): 3272 let_argument: 3273 /* The global object value is not changed, so it does not 3274 * matter if it is a constant symbol. An error would be 3275 * generated if it was declared as constant at the time of 3276 * bytecode generation. Check can be done looking at the 3277 * atom->constant field. */ 3278 atom = symbols[*stream++]; 3279 atom->offset = lisp__data.env.length; 3280 lisp__data.env.names[lisp__data.env.length] = atom->key; 3281 lisp__data.env.values[lisp__data.env.length++] = reg0; 3282 NEXT_OPCODE(); 3283 3284 OPCODE_LABEL(XBC_LETX): 3285 letx_argument: 3286 atom = symbols[*stream++]; 3287 atom->offset = lisp__data.env.length; 3288 lisp__data.env.names[lisp__data.env.length] = atom->key; 3289 lisp__data.env.values[lisp__data.env.length++] = reg0; 3290 lisp__data.env.head++; 3291 NEXT_OPCODE(); 3292 3293 OPCODE_LABEL(XBC_LET_NIL): 3294 atom = symbols[*stream++]; 3295 atom->offset = lisp__data.env.length; 3296 lisp__data.env.names[lisp__data.env.length] = atom->key; 3297 lisp__data.env.values[lisp__data.env.length++] = NIL; 3298 NEXT_OPCODE(); 3299 3300 OPCODE_LABEL(XBC_LETX_NIL): 3301 atom = symbols[*stream++]; 3302 atom->offset = lisp__data.env.length; 3303 lisp__data.env.names[lisp__data.env.length] = atom->key; 3304 lisp__data.env.values[lisp__data.env.length++] = NIL; 3305 lisp__data.env.head++; 3306 NEXT_OPCODE(); 3307 3308 /* Bind locally added variables to a block */ 3309 OPCODE_LABEL(XBC_LETBIND): 3310 offset = *stream++; 3311 lisp__data.env.head += offset; 3312 NEXT_OPCODE(); 3313 3314 /* Unbind locally added variables to a block */ 3315 OPCODE_LABEL(XBC_UNLET): 3316 offset = *stream++; 3317 lisp__data.env.head -= offset; 3318 lisp__data.env.length -= offset; 3319 NEXT_OPCODE(); 3320 3321 /* Load value from stack */ 3322 OPCODE_LABEL(XBC_LOAD): 3323 offset = *stream++; 3324 reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; 3325 NEXT_OPCODE(); 3326 3327 OPCODE_LABEL(XBC_LOAD_CAR): 3328 offset = *stream++; 3329 reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; 3330 goto car; 3331 3332 OPCODE_LABEL(XBC_LOAD_CDR): 3333 offset = *stream++; 3334 reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; 3335 goto cdr; 3336 3337 OPCODE_LABEL(XBC_LOAD_CAR_STORE): 3338 offset = *stream++; 3339 reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; 3340 if (reg0 != NIL) { 3341 if (!CONSP(reg0)) 3342 LispDestroy("CAR: %s is not a list", STROBJ(reg0)); 3343 reg0 = CAR(reg0); 3344 lisp__data.env.values[lisp__data.env.lex + offset] = reg0; 3345 } 3346 NEXT_OPCODE(); 3347 3348 OPCODE_LABEL(XBC_LOAD_CDR_STORE): 3349 offset = *stream++; 3350 reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; 3351 if (reg0 != NIL) { 3352 if (!CONSP(reg0)) 3353 LispDestroy("CDR: %s is not a list", STROBJ(reg0)); 3354 reg0 = CDR(reg0); 3355 lisp__data.env.values[lisp__data.env.lex + offset] = reg0; 3356 } 3357 NEXT_OPCODE(); 3358 3359 OPCODE_LABEL(XBC_LOAD_LET): 3360 offset = *stream++; 3361 reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; 3362 goto let_argument; 3363 3364 OPCODE_LABEL(XBC_LOAD_LETX): 3365 offset = *stream++; 3366 reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; 3367 goto letx_argument; 3368 3369 OPCODE_LABEL(XBC_LOAD_PUSH): 3370 offset = *stream++; 3371 reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; 3372 lisp__data.stack.values[lisp__data.stack.length++] = reg0; 3373 NEXT_OPCODE(); 3374 3375 /* Load pointer to constant */ 3376 OPCODE_LABEL(XBC_LOADCON): 3377 reg0 = constants[*stream++]; 3378 NEXT_OPCODE(); 3379 3380 OPCODE_LABEL(XBC_LOADCON_LET): 3381 reg0 = constants[*stream++]; 3382 goto let_argument; 3383 3384 OPCODE_LABEL(XBC_LOADCON_LETX): 3385 reg0 = constants[*stream++]; 3386 goto letx_argument; 3387 3388 OPCODE_LABEL(XBC_LOADCON_PUSH): 3389 reg0 = constants[*stream++]; 3390 lisp__data.stack.values[lisp__data.stack.length++] = reg0; 3391 NEXT_OPCODE(); 3392 3393 OPCODE_LABEL(XBC_LOADCON_SET): 3394 reg0 = constants[*stream++]; 3395 offset = *stream++; 3396 lisp__data.env.values[lisp__data.env.lex + offset] = reg0; 3397 NEXT_OPCODE(); 3398 3399 /* Change value of local variable */ 3400 OPCODE_LABEL(XBC_CAR_SET): 3401 car_set: 3402 if (reg0 != NIL) { 3403 if (!CONSP(reg0)) 3404 LispDestroy("CAR: %s is not a list", STROBJ(reg0)); 3405 reg0 = CAR(reg0); 3406 } 3407 goto set_local_variable; 3408 3409 OPCODE_LABEL(XBC_CDR_SET): 3410 cdr_set: 3411 if (reg0 != NIL) { 3412 if (!CONSP(reg0)) 3413 LispDestroy("CDR: %s is not a list", STROBJ(reg0)); 3414 reg0 = CDR(reg0); 3415 } 3416 goto set_local_variable; 3417 3418 OPCODE_LABEL(XBC_LOAD_CAR_SET): 3419 offset = *stream++; 3420 reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; 3421 goto car_set; 3422 3423 OPCODE_LABEL(XBC_LOAD_CDR_SET): 3424 offset = *stream++; 3425 reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; 3426 goto cdr_set; 3427 3428 OPCODE_LABEL(XBC_LOAD_SET): 3429 offset = *stream++; 3430 reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; 3431 /*FALLTROUGH*/ 3432 3433 OPCODE_LABEL(XBC_SET): 3434 set_local_variable: 3435 offset = *stream++; 3436 lisp__data.env.values[lisp__data.env.lex + offset] = reg0; 3437 NEXT_OPCODE(); 3438 3439 OPCODE_LABEL(XBC_SET_NIL): 3440 offset = *stream++; 3441 lisp__data.env.values[lisp__data.env.lex + offset] = NIL; 3442 NEXT_OPCODE(); 3443 3444 /* Change value of a global/special variable */ 3445 OPCODE_LABEL(XBC_SETSYM): 3446 atom = symbols[*stream++]; 3447 if (atom->dyn) { 3448 /* atom->dyn and atom->constant are exclusive, no 3449 * need to check if variable declared as constant. */ 3450 if (atom->offset < lisp__data.env.head && 3451 lisp__data.env.names[atom->offset] == atom->key) 3452 lisp__data.env.values[atom->offset] = reg0; 3453 else { 3454 if (atom->watch) 3455 LispSetAtomObjectProperty(atom, reg0); 3456 else 3457 SETVALUE(atom, reg0); 3458 } 3459 } 3460 else if (atom->a_object) { 3461 if (atom->constant) 3462 LispDestroy("EVAL: %s is a constant", 3463 STROBJ(atom->object)); 3464 else if (atom->watch) 3465 LispSetAtomObjectProperty(atom, reg0); 3466 else 3467 SETVALUE(atom, reg0); 3468 } 3469 else { 3470 /* Create new global variable */ 3471 LispPackage *pack; 3472 3473 LispWarning("the variable %s was not declared", 3474 atom->key->value); 3475 LispSetAtomObjectProperty(atom, reg0); 3476 pack = atom->package->data.package.package; 3477 if (pack->glb.length >= pack->glb.space) 3478 LispMoreGlobals(pack); 3479 pack->glb.pairs[pack->glb.length++] = atom->object; 3480 } 3481 NEXT_OPCODE(); 3482 3483 /* Resolve symbol value at runtime */ 3484 #define LOAD_SYMBOL_VALUE() \ 3485 atom = symbols[*stream++]; \ 3486 if (atom->dyn) { \ 3487 if (atom->offset < lisp__data.env.head && \ 3488 lisp__data.env.names[atom->offset] == atom->key) \ 3489 reg0 = lisp__data.env.values[atom->offset]; \ 3490 else { \ 3491 reg0 = atom->property->value; \ 3492 if (reg0 == UNBOUND) \ 3493 LispDestroy("EVAL: the symbol %s is unbound", \ 3494 STROBJ(atom->object)); \ 3495 } \ 3496 } \ 3497 else { \ 3498 if (atom->a_object) \ 3499 reg0 = atom->property->value; \ 3500 else \ 3501 LispDestroy("EVAL: the symbol %s is unbound", \ 3502 STROBJ(atom->object)); \ 3503 } 3504 3505 OPCODE_LABEL(XBC_LOADSYM): 3506 LOAD_SYMBOL_VALUE(); 3507 NEXT_OPCODE(); 3508 3509 OPCODE_LABEL(XBC_LOADSYM_LET): 3510 LOAD_SYMBOL_VALUE(); 3511 goto let_argument; 3512 3513 OPCODE_LABEL(XBC_LOADSYM_LETX): 3514 LOAD_SYMBOL_VALUE(); 3515 goto letx_argument; 3516 3517 OPCODE_LABEL(XBC_LOADSYM_PUSH): 3518 LOAD_SYMBOL_VALUE(); 3519 lisp__data.stack.values[lisp__data.stack.length++] = reg0; 3520 NEXT_OPCODE(); 3521 3522 /* Builtin function */ 3523 OPCODE_LABEL(XBC_CALL): 3524 offset = *stream++; 3525 lisp__data.stack.base = lisp__data.stack.length - offset; 3526 builtin = builtins[*stream++]; 3527 if (builtin->multiple_values) { 3528 RETURN_COUNT = 0; 3529 reg0 = builtin->function(builtin); 3530 } 3531 else { 3532 reg0 = builtin->function(builtin); 3533 RETURN_COUNT = 0; 3534 } 3535 lisp__data.stack.length -= offset; 3536 NEXT_OPCODE(); 3537 3538 OPCODE_LABEL(XBC_CALL_SET): 3539 offset = *stream++; 3540 lisp__data.stack.base = lisp__data.stack.length - offset; 3541 builtin = builtins[*stream++]; 3542 if (builtin->multiple_values) { 3543 RETURN_COUNT = 0; 3544 reg0 = builtin->function(builtin); 3545 } 3546 else { 3547 reg0 = builtin->function(builtin); 3548 RETURN_COUNT = 0; 3549 } 3550 lisp__data.stack.length -= offset; 3551 offset = *stream++; 3552 lisp__data.env.values[lisp__data.env.lex + offset] = reg0; 3553 NEXT_OPCODE(); 3554 3555 /* Bytecode call */ 3556 OPCODE_LABEL(XBC_BYTECALL): 3557 lex = lisp__data.env.lex; 3558 offset = *stream++; 3559 lisp__data.env.head = lisp__data.env.length; 3560 len = lisp__data.env.lex = lisp__data.env.length - offset; 3561 reg0 = ExecuteBytecode(codes[*stream++]); 3562 lisp__data.env.length = lisp__data.env.head = len; 3563 lisp__data.env.lex = lex; 3564 NEXT_OPCODE(); 3565 3566 /* Unimplemented function/macro call */ 3567 OPCODE_LABEL(XBC_FUNCALL): 3568 lambda = constants[*stream++]; 3569 arguments = constants[*stream++]; 3570 reg0 = LispFuncall(lambda, arguments, 1); 3571 NEXT_OPCODE(); 3572 3573 OPCODE_LABEL(XBC_JUMP): 3574 stream += *(signed short*)stream; 3575 NEXT_OPCODE(); 3576 3577 OPCODE_LABEL(XBC_JUMPT): 3578 if (reg0 != NIL) 3579 stream += *(signed short*)stream; 3580 else 3581 /* skip jump relative offset */ 3582 stream += sizeof(signed short); 3583 NEXT_OPCODE(); 3584 3585 OPCODE_LABEL(XBC_JUMPNIL): 3586 if (reg0 == NIL) 3587 stream += *(signed short*)stream; 3588 else 3589 /* skip jump relative offset */ 3590 stream += sizeof(signed short); 3591 NEXT_OPCODE(); 3592 3593 /* Build CONS of two constant arguments */ 3594 OPCODE_LABEL(XBC_CCONS): 3595 reg0 = constants[*stream++]; 3596 reg1 = constants[*stream++]; 3597 reg0 = CONS(reg0, reg1); 3598 NEXT_OPCODE(); 3599 3600 /* Start CONS */ 3601 OPCODE_LABEL(XBC_CSTAR): 3602 /* This the CAR of the CONS */ 3603 lisp__data.protect.objects[phead++] = reg0; 3604 NEXT_OPCODE(); 3605 3606 /* Finish CONS */ 3607 OPCODE_LABEL(XBC_CFINI): 3608 reg0 = CONS(lisp__data.protect.objects[--phead], reg0); 3609 NEXT_OPCODE(); 3610 3611 /* Start building list */ 3612 OPCODE_LABEL(XBC_LSTAR): 3613 reg1 = CONS(reg0, NIL); 3614 /* Start of list stored here */ 3615 lisp__data.protect.objects[phead++] = reg1; 3616 /* Tail of list stored here */ 3617 lisp__data.protect.objects[phead++] = reg1; 3618 NEXT_OPCODE(); 3619 3620 /* Add to list */ 3621 OPCODE_LABEL(XBC_LCONS): 3622 reg1 = lisp__data.protect.objects[phead - 2]; 3623 RPLACD(reg1, CONS(reg0, NIL)); 3624 lisp__data.protect.objects[phead - 2] = CDR(reg1); 3625 NEXT_OPCODE(); 3626 3627 /* Finish list */ 3628 OPCODE_LABEL(XBC_LFINI): 3629 phead -= 2; 3630 reg0 = lisp__data.protect.objects[phead + 1]; 3631 NEXT_OPCODE(); 3632 3633 OPCODE_LABEL(XBC_STRUCT): 3634 offset = *stream++; 3635 reg1 = constants[*stream++]; 3636 if (!STRUCTP(reg0) || reg0->data.struc.def != reg1) { 3637 char *name = ATOMID(CAR(reg1))->value; 3638 3639 for (reg1 = CDR(reg1); offset; offset--) 3640 reg1 = CDR(reg1); 3641 LispDestroy("%s-%s: %s is not a %s", 3642 name, ATOMID(CAR(reg1))->value, STROBJ(reg0), name); 3643 } 3644 for (reg0 = reg0->data.struc.fields; offset; offset--) 3645 reg0 = CDR(reg0); 3646 reg0 = CAR(reg0); 3647 NEXT_OPCODE(); 3648 3649 OPCODE_LABEL(XBC_STRUCTP): 3650 reg1 = constants[*stream++]; 3651 reg0 = STRUCTP(reg0) && reg0->data.struc.def == reg1 ? T : NIL; 3652 NEXT_OPCODE(); 3653 3654 OPCODE_LABEL(XBC_LETREC): 3655 /* XXX could/should optimize, shouldn't need to parse 3656 * the bytecode header again */ 3657 lex = lisp__data.env.lex; 3658 offset = *stream++; 3659 lisp__data.env.head = lisp__data.env.length; 3660 len = lisp__data.env.lex = lisp__data.env.length - offset; 3661 reg0 = ExecuteBytecode(bytecode); 3662 lisp__data.env.length = lisp__data.env.head = len; 3663 lisp__data.env.lex = lex; 3664 NEXT_OPCODE(); 3665 3666 OPCODE_LABEL(XBC_RETURN): 3667 lisp__data.protect.length = pbase; 3668 return (reg0); 3669 3670 #ifndef ALLOW_GOTO_ADDRESS 3671 } /* end of switch */ 3672 3673 predicate_label: 3674 switch (*stream++) { 3675 #endif 3676 3677 OPCODE_LABEL(XBP_CONSP): 3678 reg0 = CONSP(reg0) ? T : NIL; 3679 NEXT_OPCODE(); 3680 3681 OPCODE_LABEL(XBP_LISTP): 3682 reg0 = LISTP(reg0) ? T : NIL; 3683 NEXT_OPCODE(); 3684 3685 OPCODE_LABEL(XBP_NUMBERP): 3686 reg0 = NUMBERP(reg0) ? T : NIL; 3687 NEXT_OPCODE(); 3688 3689 #ifndef ALLOW_GOTO_ADDRESS 3690 } /* end of switch */ 3691 } 3692 #endif 3693 3694 /*NOTREACHED*/ 3695 return (reg0); 3696 } 3697
Indexes created Thu Jul 02 00:25:40 UTC 2026