4.3BSD - /usr/src/new/emacs/src/bytecode.c

   1: /* Execution of byte code produced by bytecomp.el.
   2:    Copyright (C) 1985 Richard M. Stallman.
   3: 
   4: This file is part of GNU Emacs.
   5: 
   6: GNU Emacs is distributed in the hope that it will be useful,
   7: but WITHOUT ANY WARRANTY.  No author or distributor
   8: accepts responsibility to anyone for the consequences of using it
   9: or for whether it serves any particular purpose or works at all,
  10: unless he says so in writing.  Refer to the GNU Emacs General Public
  11: License for full details.
  12: 
  13: Everyone is granted permission to copy, modify and redistribute
  14: GNU Emacs, but only under the conditions described in the
  15: GNU Emacs General Public License.   A copy of this license is
  16: supposed to have been given to you along with GNU Emacs so you
  17: can know your rights and responsibilities.  It should be in a
  18: file named COPYING.  Among other things, the copyright notice
  19: and this notice must be preserved on all copies.  */
  20: 
  21: 
  22: #include "config.h"
  23: #include "lisp.h"
  24: #include "buffer.h"
  25: 
  26: Lisp_Object Qbytecode;
  27: 
  28: /*  Byte codes: */
  29: 
  30: #define Bvarref 010
  31: #define Bvarset 020
  32: #define Bvarbind 030
  33: #define Bcall 040
  34: #define Bunbind 050
  35: 
  36: #define Bnth 070
  37: #define Bsymbolp 071
  38: #define Bconsp 072
  39: #define Bstringp 073
  40: #define Blistp 074
  41: #define Beq 075
  42: #define Bmemq 076
  43: #define Bnot 077
  44: #define Bcar 0100
  45: #define Bcdr 0101
  46: #define Bcons 0102
  47: #define Blist1 0103
  48: #define Blist2 0104
  49: #define Blist3 0105
  50: #define Blist4 0106
  51: #define Blength 0107
  52: #define Baref 0110
  53: #define Baset 0111
  54: #define Bsymbol_value 0112
  55: #define Bsymbol_function 0113
  56: #define Bset 0114
  57: #define Bfset 0115
  58: #define Bget 0116
  59: #define Bsubstring 0117
  60: #define Bconcat2 0120
  61: #define Bconcat3 0121
  62: #define Bconcat4 0122
  63: #define Bsub1 0123
  64: #define Badd1 0124
  65: #define Beqlsign 0125
  66: #define Bgtr 0126
  67: #define Blss 0127
  68: #define Bleq 0130
  69: #define Bgeq 0131
  70: #define Bdiff 0132
  71: #define Bnegate 0133
  72: #define Bplus 0134
  73: #define Bmax 0135
  74: #define Bmin 0136
  75: 
  76: #define Bpoint 0140
  77: #define Bmark 0141
  78: #define Bgoto_char 0142
  79: #define Binsert 0143
  80: #define Bpoint_max 0144
  81: #define Bpoint_min 0145
  82: #define Bchar_after 0146
  83: #define Bfollowing_char 0147
  84: #define Bpreceding_char 0150
  85: #define Bcurrent_column 0151
  86: #define Bindent_to 0152
  87: #define Bscan_buffer 0153
  88: #define Beolp 0154
  89: #define Beobp 0155
  90: #define Bbolp 0156
  91: #define Bbobp 0157
  92: #define Bcurrent_buffer 0160
  93: #define Bset_buffer 0161
  94: #define Bread_char 0162
  95: #define Bset_mark 0163
  96: #define Binteractive_p 0164   /* Needed since interactive-p takes unevalled args */
  97: 
  98: #define Bconstant2 0201
  99: #define Bgoto 0202
 100: #define Bgotoifnil 0203
 101: #define Bgotoifnonnil 0204
 102: #define Bgotoifnilelsepop 0205
 103: #define Bgotoifnonnilelsepop 0206
 104: #define Breturn 0207
 105: #define Bdiscard 0210
 106: #define Bdup 0211
 107: 
 108: #define Bsave_excursion 0212
 109: #define Bsave_window_excursion 0213
 110: #define Bsave_restriction 0214
 111: #define Bcatch 0215
 112: 
 113: #define Bunwind_protect 0216
 114: #define Bcondition_case 0217
 115: #define Btemp_output_buffer_setup 0220
 116: #define Btemp_output_buffer_show 0221
 117: 
 118: #define Bconstant 0300
 119: #define CONSTANTLIM 0100
 120: 
 121: /* Fetch the next byte from the bytecode stream */
 122: 
 123: #define FETCH ((unsigned char *)XSTRING (bytestr)->data)[pc++]
 124: 
 125: /* Fetch two bytes from the bytecode stream
 126:  and make a 16-bit number out of them */
 127: 
 128: #define FETCH2 (op = FETCH, op + (FETCH << 8))
 129: 
 130: /* Push x onto the execution stack. */
 131: 
 132: #define PUSH(x) (*++stackp = (x))
 133: 
 134: /* Pop a value off the execution stack.  */
 135: 
 136: #define POP (*stackp--)
 137: 
 138: /* Discard n values from the execution stack.  */
 139: 
 140: #define DISCARD(n) (stackp -= (n))
 141: 
 142: /* Get the value which is at the top of the execution stack, but don't pop it. */
 143: 
 144: #define TOP (*stackp)
 145: 
 146: 
 147: DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
 148:   "")
 149:   (bytestr, vector, maxdepth)
 150:      Lisp_Object bytestr, vector, maxdepth;
 151: {
 152:   struct gcpro gcpro1, gcpro2, gcpro3;
 153:   int count = specpdl_ptr - specpdl;
 154:   register int pc = 0;
 155:   register int op;
 156:   Lisp_Object *stack;
 157:   register Lisp_Object *stackp;
 158:   Lisp_Object *stacke;
 159:   register Lisp_Object v1, v2;
 160:   Lisp_Object *vectorp = XVECTOR (vector)->contents;
 161: 
 162:   CHECK_STRING (bytestr, 0);
 163:   if (XTYPE (vector) != Lisp_Vector)
 164:     vector = wrong_type_argument (Qvectorp, vector);
 165:   CHECK_NUMBER (maxdepth, 2);
 166: 
 167:   stackp = (Lisp_Object *) alloca (XFASTINT (maxdepth) * sizeof (Lisp_Object));
 168:   bzero (stackp, XFASTINT (maxdepth) * sizeof (Lisp_Object));
 169:   GCPRO3 (bytestr, vector, *stackp);
 170:   gcpro3.nvars = XFASTINT (maxdepth);
 171: 
 172:   --stackp;
 173:   stack = stackp;
 174:   stacke = stackp + XFASTINT (maxdepth);
 175: 
 176:   while (1)
 177:     {
 178:       if (stackp > stacke)
 179:     error ("Stack overflow in byte code (byte compiler bug!)");
 180:       if (stackp < stack)
 181:     error ("Stack underflow in byte code (byte compiler bug!)");
 182:       switch (op = FETCH)
 183:     {
 184:     case Bvarref: case Bvarref+1: case Bvarref+2: case Bvarref+3:
 185:     case Bvarref+4: case Bvarref+5:
 186:       PUSH (Fsymbol_value (vectorp[op - Bvarref]));
 187:       break;
 188: 
 189:     case Bvarref+6:
 190:       PUSH (Fsymbol_value (vectorp[FETCH]));
 191:       break;
 192: 
 193:     case Bvarref+7:
 194:       PUSH (Fsymbol_value (vectorp[FETCH2]));
 195:       break;
 196: 
 197:     case Bvarset: case Bvarset+1: case Bvarset+2: case Bvarset+3:
 198:     case Bvarset+4: case Bvarset+5:
 199:       Fset (vectorp[op - Bvarset], POP);
 200:       break;
 201: 
 202:     case Bvarset+6:
 203:       Fset (vectorp[FETCH], POP);
 204:       break;
 205: 
 206:     case Bvarset+7:
 207:       Fset (vectorp[FETCH2], POP);
 208:       break;
 209: 
 210:     case Bvarbind: case Bvarbind+1: case Bvarbind+2: case Bvarbind+3:
 211:     case Bvarbind+4: case Bvarbind+5:
 212:       specbind (vectorp[op - Bvarbind], POP);
 213:       break;
 214: 
 215:     case Bvarbind+6:
 216:       specbind (vectorp[FETCH], POP);
 217:       break;
 218: 
 219:     case Bvarbind+7:
 220:       specbind (vectorp[FETCH2], POP);
 221:       break;
 222: 
 223:     case Bcall: case Bcall+1: case Bcall+2: case Bcall+3:
 224:     case Bcall+4: case Bcall+5:
 225:       op -= Bcall;
 226:     docall:
 227:       DISCARD(op);
 228:       gcpro3.nvars = &TOP - stack;
 229:       TOP = Ffuncall (op + 1, &TOP);
 230:       gcpro3.nvars = XFASTINT (maxdepth);
 231:       break;
 232: 
 233:     case Bcall+6:
 234:       op = FETCH;
 235:       goto docall;
 236: 
 237:     case Bcall+7:
 238:       op = FETCH2;
 239:       goto docall;
 240: 
 241:     case Bunbind: case Bunbind+1: case Bunbind+2: case Bunbind+3:
 242:     case Bunbind+4: case Bunbind+5:
 243:       unbind_to (specpdl_ptr - specpdl - (op - Bunbind));
 244:       break;
 245: 
 246:     case Bunbind+6:
 247:       unbind_to (specpdl_ptr - specpdl - FETCH);
 248:       break;
 249: 
 250:     case Bunbind+7:
 251:       unbind_to (specpdl_ptr - specpdl - FETCH2);
 252:       break;
 253: 
 254:     case Bgoto:
 255:       QUIT;
 256:       op = FETCH2;    /* pc = FETCH2 loses since FETCH2 contains pc++ */
 257:       pc = op;
 258:       break;
 259: 
 260:     case Bgotoifnil:
 261:       QUIT;
 262:       op = FETCH2;
 263:       if (NULL (POP))
 264:         pc = op;
 265:       break;
 266: 
 267:     case Bgotoifnonnil:
 268:       QUIT;
 269:       op = FETCH2;
 270:       if (!NULL (POP))
 271:         pc = op;
 272:       break;
 273: 
 274:     case Bgotoifnilelsepop:
 275:       QUIT;
 276:       op = FETCH2;
 277:       if (NULL (TOP))
 278:         pc = op;
 279:       else DISCARD(1);
 280:       break;
 281: 
 282:     case Bgotoifnonnilelsepop:
 283:       QUIT;
 284:       op = FETCH2;
 285:       if (!NULL (TOP))
 286:         pc = op;
 287:       else DISCARD(1);
 288:       break;
 289: 
 290:     case Breturn:
 291:       v1 = POP;
 292:       goto exit;
 293: 
 294:     case Bdiscard:
 295:       DISCARD(1);
 296:       break;
 297: 
 298:     case Bdup:
 299:       v1 = TOP;
 300:       PUSH (v1);
 301:       break;
 302: 
 303:     case Bconstant2:
 304:       PUSH (vectorp[FETCH2]);
 305:       break;
 306: 
 307:     case Bsave_excursion:
 308:       record_unwind_protect (save_excursion_restore, save_excursion_save ());
 309:       break;
 310: 
 311:     case Bsave_window_excursion:
 312:       TOP = Fsave_window_excursion (TOP);
 313:       break;
 314: 
 315:     case Bsave_restriction:
 316:       record_unwind_protect (save_restriction_restore, save_restriction_save ());
 317:       break;
 318: 
 319:     case Bcatch:
 320:       v1 = POP;
 321:       TOP = internal_catch (TOP, Feval, v1);
 322:       break;
 323: 
 324:     case Bunwind_protect:
 325:       record_unwind_protect (0, POP);
 326:       (specpdl_ptr - 1)->symbol = Qnil;
 327:       break;
 328: 
 329:     case Bcondition_case:
 330:       v1 = POP;
 331:       v1 = Fcons (POP, v1);
 332:       TOP = Fcondition_case (Fcons (TOP, v1));
 333:       break;
 334: 
 335:     case Btemp_output_buffer_setup:
 336:       temp_output_buffer_setup (XSTRING (TOP)->data);
 337:       TOP = Vstandard_output;
 338:       break;
 339: 
 340:     case Btemp_output_buffer_show:
 341:       v1 = POP;
 342:       temp_output_buffer_show (TOP);
 343:       TOP = v1;
 344:       break;
 345: 
 346:     case Bnth:
 347:       v1 = POP;
 348:       v2 = TOP;
 349:       CHECK_NUMBER (v2, 0);
 350:       op = XINT (v2);
 351:       while (--op >= 0)
 352:         {
 353:           if (LISTP (v1))
 354:         v1 = XCONS (v1)->cdr;
 355:           else if (!NULL (v1))
 356:         {
 357:           v1 = wrong_type_argument (Qlistp, v1);
 358:           op++;
 359:         }
 360:         }
 361:       goto docar;
 362: 
 363:     case Bsymbolp:
 364:       TOP = XTYPE (TOP) == Lisp_Symbol ? Qt : Qnil;
 365:       break;
 366: 
 367:     case Bconsp:
 368:       TOP = LISTP (TOP) ? Qt : Qnil;
 369:       break;
 370: 
 371:     case Bstringp:
 372:       TOP = XTYPE (TOP) == Lisp_String ? Qt : Qnil;
 373:       break;
 374: 
 375:     case Blistp:
 376:       TOP = LISTP (TOP) || NULL (TOP) ? Qt : Qnil;
 377:       break;
 378: 
 379:     case Beq:
 380:       v1 = POP;
 381:       TOP = EQ (v1, TOP) ? Qt : Qnil;
 382:       break;
 383: 
 384:     case Bmemq:
 385:       v1 = POP;
 386:       TOP = Fmemq (TOP, v1);
 387:       break;
 388: 
 389:     case Bnot:
 390:       TOP = NULL (TOP) ? Qt : Qnil;
 391:       break;
 392: 
 393:     case Bcar:
 394:       v1 = TOP;
 395:     docar:
 396:       if (LISTP (v1)) TOP = XCONS (v1)->car;
 397:       else if (NULL (v1)) TOP = Qnil;
 398:       else Fcar (wrong_type_argument (Qlistp, v1));
 399:       break;
 400: 
 401:     case Bcdr:
 402:       v1 = TOP;
 403:       if (LISTP (v1)) TOP = XCONS (v1)->cdr;
 404:       else if (NULL (v1)) TOP = Qnil;
 405:       else Fcdr (wrong_type_argument (Qlistp, v1));
 406:       break;
 407: 
 408:     case Bcons:
 409:       v1 = POP;
 410:       TOP = Fcons (TOP, v1);
 411:       break;
 412: 
 413:     case Blist1:
 414:       TOP = Fcons (TOP, Qnil);
 415:       break;
 416: 
 417:     case Blist2:
 418:       v1 = POP;
 419:       TOP = Fcons (TOP, Fcons (v1, Qnil));
 420:       break;
 421: 
 422:     case Blist3:
 423:       DISCARD(2);
 424:       TOP = Flist (3, &TOP);
 425:       break;
 426: 
 427:     case Blist4:
 428:       DISCARD(3);
 429:       TOP = Flist (4, &TOP);
 430:       break;
 431: 
 432:     case Blength:
 433:       TOP = Flength (TOP);
 434:       break;
 435: 
 436:     case Baref:
 437:       v1 = POP;
 438:       TOP = Faref (TOP, v1);
 439:       break;
 440: 
 441:     case Baset:
 442:       v2 = POP; v1 = POP;
 443:       TOP = Faset (TOP, v1, v2);
 444:       break;
 445: 
 446:     case Bsymbol_value:
 447:       TOP = Fsymbol_value (TOP);
 448:       break;
 449: 
 450:     case Bsymbol_function:
 451:       TOP = Fsymbol_function (TOP);
 452:       break;
 453: 
 454:     case Bset:
 455:       v1 = POP;
 456:       TOP = Fset (TOP, v1);
 457:       break;
 458: 
 459:     case Bfset:
 460:       v1 = POP;
 461:       TOP = Ffset (TOP, v1);
 462:       break;
 463: 
 464:     case Bget:
 465:       v1 = POP;
 466:       TOP = Fget (TOP, v1);
 467:       break;
 468: 
 469:     case Bsubstring:
 470:       v2 = POP; v1 = POP;
 471:       TOP = Fsubstring (TOP, v1, v2);
 472:       break;
 473: 
 474:     case Bconcat2:
 475:       DISCARD(1);
 476:       TOP = Fconcat (2, &TOP);
 477:       break;
 478: 
 479:     case Bconcat3:
 480:       DISCARD(2);
 481:       TOP = Fconcat (3, &TOP);
 482:       break;
 483: 
 484:     case Bconcat4:
 485:       DISCARD(3);
 486:       TOP = Fconcat (4, &TOP);
 487:       break;
 488: 
 489:     case Bsub1:
 490:       v1 = TOP;
 491:       if (XTYPE (v1) == Lisp_Int)
 492:         {
 493:           XSETINT (v1, XINT (v1) - 1);
 494:           TOP = v1;
 495:         }
 496:       else
 497:         TOP = Fsub1 (v1);
 498:       break;
 499: 
 500:     case Badd1:
 501:       v1 = TOP;
 502:       if (XTYPE (v1) == Lisp_Int)
 503:         {
 504:           XSETINT (v1, XINT (v1) + 1);
 505:           TOP = v1;
 506:         }
 507:       else
 508:         TOP = Fadd1 (v1);
 509:       break;
 510: 
 511:     case Beqlsign:
 512:       v2 = POP; v1 = TOP;
 513:       CHECK_NUMBER_COERCE_MARKER (v1, 0);
 514:       CHECK_NUMBER_COERCE_MARKER (v2, 0);
 515:       TOP = XINT (v1) == XINT (v2) ? Qt : Qnil;
 516:       break;
 517: 
 518:     case Bgtr:
 519:       v1 = POP;
 520:       TOP = Fgtr (TOP, v1);
 521:       break;
 522: 
 523:     case Blss:
 524:       v1 = POP;
 525:       TOP = Flss (TOP, v1);
 526:       break;
 527: 
 528:     case Bleq:
 529:       v1 = POP;
 530:       TOP = Fleq (TOP, v1);
 531:       break;
 532: 
 533:     case Bgeq:
 534:       v1 = POP;
 535:       TOP = Fgeq (TOP, v1);
 536:       break;
 537: 
 538:     case Bdiff:
 539:       DISCARD(1);
 540:       TOP = Fminus (2, &TOP);
 541:       break;
 542: 
 543:     case Bnegate:
 544:       v1 = TOP;
 545:       if (XTYPE (v1) == Lisp_Int)
 546:         {
 547:           XSETINT (v1, - XINT (v1));
 548:           TOP = v1;
 549:         }
 550:       else
 551:         TOP = Fminus (1, &TOP);
 552:       break;
 553: 
 554:     case Bplus:
 555:       DISCARD(1);
 556:       TOP = Fplus (2, &TOP);
 557:       break;
 558: 
 559:     case Bmax:
 560:       DISCARD(1);
 561:       TOP = Fmax (2, &TOP);
 562:       break;
 563: 
 564:     case Bmin:
 565:       DISCARD(1);
 566:       TOP = Fmin (2, &TOP);
 567:       break;
 568: 
 569:     case Bpoint:
 570:       XFASTINT (v1) = point;
 571:       PUSH (v1);
 572:       break;
 573: 
 574:     case Bmark:
 575:       PUSH (Fmark ());
 576:       break;
 577: 
 578:     case Bgoto_char:
 579:       TOP = Fgoto_char (TOP);
 580:       break;
 581: 
 582:     case Binsert:
 583:       TOP = Finsert (1, &TOP);
 584:       break;
 585: 
 586:     case Bpoint_max:
 587:       XFASTINT (v1) = NumCharacters+1;
 588:       PUSH (v1);
 589:       break;
 590: 
 591:     case Bpoint_min:
 592:       XFASTINT (v1) = FirstCharacter;
 593:       PUSH (v1);
 594:       break;
 595: 
 596:     case Bchar_after:
 597:       TOP = Fchar_after (TOP);
 598:       break;
 599: 
 600:     case Bfollowing_char:
 601:       XFASTINT (v1) = point>NumCharacters ? 0 : CharAt(point);
 602:       PUSH (v1);
 603:       break;
 604: 
 605:     case Bpreceding_char:
 606:       XFASTINT (v1) = point<=FirstCharacter ? 0 : CharAt(point-1);
 607:       PUSH (v1);
 608:       break;
 609: 
 610:     case Bcurrent_column:
 611:       XFASTINT (v1) = current_column ();
 612:       PUSH (v1);
 613:       break;
 614: 
 615:     case Bindent_to:
 616:       TOP = Findent_to (TOP, Qnil);
 617:       break;
 618: 
 619:     case Bscan_buffer:
 620:       v2 = POP; v1 = POP;
 621:       TOP = Fscan_buffer (TOP, v1, v2);
 622:       break;
 623: 
 624:     case Beolp:
 625:       PUSH (Feolp ());
 626:       break;
 627: 
 628:     case Beobp:
 629:       PUSH (Feobp ());
 630:       break;
 631: 
 632:     case Bbolp:
 633:       PUSH (Fbolp ());
 634:       break;
 635: 
 636:     case Bbobp:
 637:       PUSH (Fbobp ());
 638:       break;
 639: 
 640:     case Bcurrent_buffer:
 641:       PUSH (Fcurrent_buffer ());
 642:       break;
 643: 
 644:     case Bset_buffer:
 645:       TOP = Fset_buffer (TOP);
 646:       break;
 647: 
 648:     case Bread_char:
 649:       PUSH (Fread_char ());
 650:       QUIT;
 651:       break;
 652: 
 653:     case Bset_mark:
 654:       TOP = Fset_mark (TOP);
 655:       break;
 656: 
 657:     case Binteractive_p:
 658:       PUSH (Finteractive_p ());
 659:       break;
 660: 
 661:     default:
 662:       if ((op -= Bconstant) < (unsigned)CONSTANTLIM)
 663:         PUSH (vectorp[op]);
 664:     }
 665:     }
 666: 
 667:  exit:
 668:   UNGCPRO;
 669:   unbind_to (count);
 670:   return v1;
 671: }
 672: 
 673: syms_of_bytecode ()
 674: {
 675:   Qbytecode = intern ("byte-code");
 676:   staticpro (&Qbytecode);
 677: 
 678:   defsubr (&Sbyte_code);
 679: }

Defined functions

Defined variables

Defined macros