home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 541b.lha / OakLisp / src.lzh / emulator.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-06-16  |  47.8 KB  |  2,192 lines
  1. /* Copyright (C) 1987,8,9 Barak Pearlmutter and Kevin Lang. */
  2.  
  3. /* An emulator for the Oaklisp virtual machine.  */
  4.  
  5.  
  6. #include <stdio.h>
  7. #include <ctype.h>
  8.  
  9. #include "emulator.h"
  10. #include "stacks.h"
  11.  
  12. #ifdef unix
  13. #include <sys/time.h>
  14. #include <sys/resource.h>
  15. #endif
  16.  
  17.  
  18.  
  19. #define CASE_FOUR 1
  20.  
  21. #ifdef FAST
  22.  
  23. #define trace_insts    0
  24. #define trace_stcon    0
  25. #define trace_cxcon    0
  26. #define trace_meth    0
  27. #define trace_segs    0
  28. #define trace_mcache    0
  29.  
  30. #else
  31.  
  32. bool trace_insts = FALSE;    /* trace instruction execution */
  33. bool trace_stcon = FALSE;    /* trace stack contents */
  34. bool trace_cxcon = FALSE;    /* trace contents stack contents */
  35. bool trace_meth     = FALSE;    /* trace method lookup */
  36. bool trace_segs     = FALSE;    /* trace stack segment manipulation */
  37. bool trace_mcache= FALSE;    /* trace method cache hits and misses */
  38.  
  39. extern char *ArglessInstrs[], *Instrs[];
  40.  
  41. #endif
  42.  
  43. bool trace_traps = FALSE;        /* trace tag traps */
  44. bool trace_files = FALSE;        /* trace file opening */
  45. bool trace_gc     = FALSE;        /* trace gc carefully */
  46.  
  47. bool dump_after  = FALSE;        /* dump world after running */
  48. bool gc_before_dump = FALSE;        /* do a GC before dumping the world */
  49.  
  50.  
  51. #ifdef FAST
  52. #define MAYBE_PUT(v,s)
  53. #else
  54. #define MAYBE_PUT(v,s) { if ((v)) {(void)printf(s); fflush_stdout();} }
  55. #endif
  56.  
  57.  
  58. #ifdef Mac_LSC
  59. extern void    Init_Primitives();
  60. extern ref    Call_Primitive(ref primRef, ref callRef, ref retRef, ref paramList);
  61. #endif
  62.  
  63.  
  64. /*
  65.  * Processor registers
  66.  */
  67.  
  68. stack val_stk, cxt_stk;
  69.  
  70. ref *e_bp, *e_env, e_t, e_nil,
  71.   e_fixnum_type, e_loc_type, e_cons_type, e_env_type, *e_subtype_table,
  72.   e_object_type, e_segment_type, e_boot_code, e_code_segment,
  73.   *e_arged_tag_trap_table, *e_argless_tag_trap_table, e_current_method,
  74.   e_uninitialized, e_method_type;
  75.  
  76. unsigned long
  77.   e_next_newspace_size,
  78.   original_newspace_size = DEFAULT_NEW_SPACE_SIZE;
  79.  
  80. unsigned short *e_pc;
  81.  
  82. #define maybe_dump_world(dumpstackp)    \
  83. {                    \
  84.   UNOPTV(val_stk.ptr = val_stk_ptr);    \
  85.   UNOPTC(cxt_stk.ptr = cxt_stk_ptr);    \
  86.   maybe_dump_world_aux((dumpstackp));    \
  87. }
  88.  
  89.  
  90. #define NEW_STORAGE e_uninitialized
  91.  
  92. void maybe_dump_world_aux(dumpstackp)
  93.      int dumpstackp;
  94. {
  95.   if (dumpstackp > 2)        /* 0,1,2 are normal exits. */
  96.     {
  97.       printf("value ");
  98.       dump_stack_proc(&val_stk);
  99.       printf("context ");
  100.       dump_stack_proc(&cxt_stk);
  101.     }
  102.  
  103.   if (dump_after)
  104.     {
  105.       if (gc_before_dump && dumpstackp == 0)
  106.     {
  107.       gc(TRUE, TRUE, "impending world dump", 0L);
  108.       dump_world(TRUE);
  109.     }
  110.       else
  111.     dump_world(FALSE);
  112.     }
  113. }
  114.  
  115.  
  116.  
  117.  
  118. void printref(refin)
  119.      ref refin;
  120. {
  121.   unsigned long i;
  122.   char suffix = '?';
  123.  
  124.   if ((refin&PTR_MASK) != 0)
  125.     {
  126.       ref *p = ((refin&1) != 0) ? REF_TO_PTR(refin) : LOC_TO_PTR(refin);
  127.       
  128.       if (SPATIC_PTR(p))
  129.     {
  130.       i = p - spatic.start;
  131.       suffix = 's';
  132.     }
  133.       else if (NEW_PTR(p))
  134.     {
  135.       i = (p - new.start) + spatic.size;
  136.       suffix = 'n';
  137.     }
  138.       else i = (unsigned long)p >> 2;
  139.  
  140.       (void)printf("%ld~%d%c", i, refin&TAG_MASK, suffix);
  141.     }
  142.   else
  143.     (void)printf("%ld~%d", refin>>2, refin&TAG_MASK);
  144. }
  145.  
  146.  
  147.  
  148. #define TRACEMETHOD(zz) {if (trace_meth) {printf("meth-trace%ld  ",zz);          \
  149.                      printref("obj_type:%ld~%ld  ",obj_type); \
  150.                             printref("alist:%ld~%ld  ",alist);       \
  151.                          printref("mptr:%ld~%ld\n",*method_ptr);  }}
  152.  
  153. #define TRACEASSQ(zz) {if (trace_meth) {printf("aq-trace%ld  ",zz);          \
  154.                             printref("elem:%ld~%ld  ",elem);       \
  155.                          printref("list:%ld~%ld\n",list);  }}
  156.  
  157. #define TRACEPASSQ(zz) {printf("aq-trace%ld  ",zz);    \
  158.               printref("elem:%ld~%ld  ",elem);       \
  159.                 printref("l:%ld~%ld ",l);  \
  160.                 printref("cdr(l):%ld~%ld ",cdr(l));  \
  161.                 if (locl) printref("*locl:%ld~%ld\n",*locl); }
  162.  
  163.  
  164. /* these are inline coded now
  165.  
  166. ref assq(elem, list)
  167.      ref elem, list;
  168. {
  169.   while (list != e_nil && car(car(list)) != elem) {
  170.     list = cdr(list);
  171.   }
  172.   return ((list == e_nil)? e_nil : car(list));
  173. }
  174.  
  175. ref old_pseudo_assq(elem, list)
  176.      ref elem, list;
  177. {
  178.   while (list != e_nil && car(car(list)) != elem) {
  179.     list = cdr(list);
  180.   }
  181.   return list;
  182. }
  183. */
  184.  
  185.  
  186. /* The following code uses the bring-to-front heuristic,
  187.    and eventually needs a register to inhibit this behavior.
  188.    This code is now inserted inline in the one place it is used.
  189. ref pseudo_assq(elem, loclist)
  190. ref elem, *loclist;
  191. {
  192.   ref thelist = *loclist;
  193.  
  194.   register ref l = thelist;
  195.   register ref *locl = NULL;
  196.  
  197.   while (l != e_nil)
  198.     {
  199.       if (car(car(l)) == elem)
  200.     {
  201.       if (locl != NULL) {
  202.         *locl = cdr(l);
  203.         *loclist = l;
  204.         cdr(l) = thelist;
  205.       }
  206.       return l;
  207.     }
  208.       l = *(locl = &(cdr(l)));
  209.     }
  210.   return l;
  211. }
  212. */
  213.  
  214.  
  215.  
  216.  
  217. #define get_type(x)                              \
  218. ((x)&1 ?                                  \
  219.  ((x)&2 ? REF_SLOT(x, 0) : *(e_subtype_table + ((x&SUBTAG_MASK)/4))) : \
  220.  ((x)&2 ? e_loc_type : e_fixnum_type))
  221.  
  222. /* ((unsigned short *) (REF_TO_PTR(seg) + CODE_CODE_START_OFF)) */
  223. #define CODE_SEG_FIRST_INSTR(seg) \
  224.   ((unsigned short *)&REF_SLOT(seg,CODE_CODE_START_OFF))
  225.  
  226.  
  227. void old_find_method_type_pair(op, obj_type, method_ptr, type_ptr)
  228.      register ref op;
  229.      register ref obj_type;
  230.      ref *method_ptr, *type_ptr;
  231. {
  232.   register ref alist;
  233.   register ref *locl = NULL;
  234.   register ref thelist;
  235.   register ref *loclist;
  236.  
  237.   while (1)
  238.     {
  239.       /* First look for it here: */
  240.       /*alist=pseudo_assq(op,&REF_SLOT(obj_type,TYPE_OP_METHOD_ALIST_OFF));*/
  241.  
  242.       alist = thelist =
  243.     *(loclist = &REF_SLOT(obj_type, TYPE_OP_METHOD_ALIST_OFF));
  244.  
  245.       while (alist != e_nil)
  246.     {
  247.       if (car(car(alist)) == op)
  248.         {
  249.           if (locl != NULL) {
  250.         *locl = cdr(alist);
  251.         *loclist = alist;
  252.         cdr(alist) = thelist;
  253.           }
  254.           *method_ptr = cdr(car(alist));
  255.           *type_ptr = obj_type;
  256.           return;
  257.         }
  258.       alist = *(locl = &cdr(alist));
  259.     }
  260.  
  261.       /* Loop looking for it on supertypes: */
  262.       alist = REF_SLOT(obj_type, TYPE_SUPER_LIST_OFF);
  263.       if (alist == e_nil) return;
  264.  
  265.       while ((thelist = cdr(alist)) != e_nil)
  266.     {
  267.       old_find_method_type_pair(op, car(alist), method_ptr, type_ptr);
  268.  
  269.       /* If found on a supertype, we're done. */
  270.       if (*method_ptr != e_nil) return;
  271.  
  272.       alist = thelist;
  273.     }
  274.       locl = NULL;
  275.       obj_type = car(alist);
  276.     }
  277. }
  278.  
  279.  
  280.  
  281. /* This is a rewrite of find_method_type_pair that doesn't use
  282.    recursion but rather an explicit stack.  Easier to inline. */
  283.  
  284. ref later_lists[100];
  285.  
  286. void find_method_type_pair(op, obj_type, method_ptr, type_ptr)
  287.      register ref op;
  288.      ref obj_type;
  289.      ref *method_ptr, *type_ptr;
  290. {
  291.   register ref alist;
  292.   register ref *locl = NULL;
  293.   ref thelist;
  294.   ref *loclist;
  295.   register ref *llp = &later_lists[0] - 1;
  296.  
  297.   while (1)
  298.     {
  299.       /* First look for it in the local method alist of obj_type: */
  300.  
  301.       alist = thelist =
  302.     *(loclist = &REF_SLOT(obj_type, TYPE_OP_METHOD_ALIST_OFF));
  303.  
  304.       while (alist != e_nil)
  305.     {
  306.       if (car(car(alist)) == op)
  307.         {
  308.           if (locl != NULL) {
  309.         *locl = cdr(alist);
  310.         *loclist = alist;
  311.         cdr(alist) = thelist;
  312.           }
  313.           *method_ptr = cdr(car(alist));
  314.           *type_ptr = obj_type;
  315.           return;
  316.         }
  317.       alist = *(locl = &cdr(alist));
  318.     }
  319.  
  320.       /* Not there, stack the supertype list and then fetch the top guy
  321.      available from the stack. */
  322.  
  323.       *++llp = REF_SLOT(obj_type, TYPE_SUPER_LIST_OFF);
  324.  
  325.       while (*llp == e_nil)
  326.     {
  327.       if (llp == &later_lists[0]) return; /* Nothing. */
  328.       llp -= 1;
  329.     }
  330.  
  331.       locl = NULL;
  332.       obj_type = car(*llp);
  333.       *llp = cdr(*llp);
  334.     }
  335. }
  336.  
  337.  
  338.  
  339.  
  340. /* This takes a length and a pointer to the beginning of an Oaklisp
  341.    string and returns the equivalent C string.  You must remember to
  342.    free() the storage returned by this routine. */
  343.  
  344. char *oak_c_string(len, p)
  345.      unsigned int len;
  346.      unsigned long *p;
  347. {
  348.   char *stuff = my_malloc((long)(len+1));
  349.   int i=0, j=0;
  350.  
  351.   while (i+2<len)
  352.     {
  353.       unsigned long pp = *p++;
  354.       stuff[j++] = (pp >> 2) & 0xFF;
  355.       stuff[j++] = (pp >> 10) & 0xFF;
  356.       stuff[j++] = (pp >> 18) & 0xFF;
  357.       i += 3;
  358.     }
  359.   if (i+1<len)
  360.     {
  361.       unsigned long pp = *p;
  362.       stuff[j++] = (pp >> 2) & 0xFF;
  363.       stuff[j++] = (pp >> 10) & 0xFF;
  364.       i += 2;
  365.     }
  366.   else if (i<len)
  367.     {
  368.       stuff[j++] = (*p >> 2) & 0xFF;
  369.       i += 1;
  370.     }
  371.   stuff[j] = 0;
  372.   return stuff;
  373. }
  374.  
  375.  
  376.  
  377.  
  378. char *dump_file = NULL;
  379.  
  380.  
  381. void crunch_args(argc, argv)
  382.      int argc;
  383.      char **argv;
  384. {
  385.   char *program_name = argv[0];
  386.   argc -= 1;
  387.   argv += 1;
  388.   
  389.   while (argc > 1 && (*argv)[0] == '-')
  390.     {
  391.       switch ((*argv)[1])
  392.     {
  393. #ifndef FAST
  394.     case 'i':
  395.       trace_insts = 1;
  396.       break;
  397.     case 'c':
  398.       trace_stcon = 1;
  399.       break;
  400.     case 'x':
  401.       trace_cxcon = 1;
  402.       break;
  403.     case 'm':
  404.       trace_meth = 1;
  405.       break;
  406.     case 'S':
  407.       trace_segs = 1;
  408.       break;
  409.     case 'M':
  410.       trace_mcache = 1;
  411.       break;
  412. #endif
  413.     case 'T':
  414.       trace_traps = 1;
  415.       break;
  416.     case 'F':
  417.       trace_files = 1;
  418.       break;
  419.     case 'd':
  420.       dump_after = 1;
  421.       break;
  422.     case 'h':
  423.       argc -= 1;
  424.       argv += 1;
  425.       original_newspace_size = string_to_int(*argv)/sizeof(ref);
  426.       break;
  427.     case '9':
  428.       dump_decimal = 1;
  429.       break;
  430.     case 'b':
  431.       dump_binary = 1;
  432.       break;
  433.     case 'G':
  434.       gc_before_dump = 1;
  435.       break;
  436.     case 'g':
  437.       trace_gc = 1;
  438.       break;
  439.     case 'Q':
  440.       gc_shutup = TRUE;
  441.       break;
  442.     case 'f':
  443.       argc -= 1;
  444.       argv += 1;
  445.       dump_file = *argv;
  446.       break;
  447.     default:
  448.       (void)printf("Unknown option %s.\n", argv[0]);
  449.       break;
  450.     }
  451.       argc -= 1;
  452.       argv += 1;
  453.     }
  454.  
  455.   if (argc != 1)
  456.     {
  457. #ifndef FAST
  458.       (void)printf("Usage: %s [-icxmSMTFd9bGgQ] [-h bytes] oaklisp-image\n",
  459.            program_name);
  460. #else
  461.       (void)printf("Usage: %s [-TFd9bGgQ] [-h bytes] oaklisp-image\n",
  462.            program_name);
  463. #endif
  464.       exit(2);
  465.     }
  466.  
  467. #ifdef Mac_LSC
  468.   Init_Primitives();
  469. #endif
  470.  
  471.   init_wp();
  472.   read_world(argv[0]);
  473.  
  474.   new.size = e_next_newspace_size = original_newspace_size;
  475.   alloc_space(&new);
  476.   free_point = new.start;
  477.  
  478.   init_stk(&val_stk);
  479.   init_stk(&cxt_stk);
  480. }
  481.  
  482.  
  483.  
  484. #ifdef Mac_LSC
  485. _main(argc,argv)
  486. #else
  487. main(argc,argv)
  488. #endif
  489.      int argc;
  490.      char **argv;
  491. {
  492.   unsigned int e_nargs;
  493.  
  494.   crunch_args(argc, argv);
  495.  
  496.   /* Get the registers set to the boot code. */
  497.  
  498.   e_current_method = e_boot_code;
  499.   e_env = REF_TO_PTR(REF_SLOT(e_current_method, METHOD_ENV_OFF));
  500.   e_code_segment = REF_SLOT(e_current_method, METHOD_CODE_OFF);
  501.   e_pc = CODE_SEG_FIRST_INSTR(e_code_segment);
  502.  
  503.   /* Put a reasonable thing in e_bp so GC doesn't get pissed. */
  504.   e_bp = e_env;
  505.  
  506.   /* Tell the boot function the truth: */
  507.   e_nargs = 0;
  508.  
  509.   /* Okay, lets go: */
  510.  
  511.   {
  512.  
  513.     /* This is used for instructions to communicate with the trap code
  514.        when a fault is encountered. */
  515.     unsigned int trap_nargs;
  516.     register unsigned short instr;
  517.     register ref x;
  518.     ref y;
  519.     register ref *val_stk_ptr = val_stk.ptr;
  520.     ref *cxt_stk_ptr = cxt_stk.ptr;
  521.  
  522. #ifndef FAST
  523.     FILE    *debug;
  524.     char    str[255];
  525. #endif
  526.  
  527.     /* This fixes a bug in which the initial CHECK-NARGS in the boot code
  528.        tries to pop the operation and fails. */
  529.     PUSHVAL_IMM(INT_TO_REF(4321));
  530.  
  531.     /* These TRAPx(n) macros jump to the trap code, notifying it that x
  532.        arguments have been popped off the stack and need to be put back
  533.        on (these are in the variables x, ...) and that the trap operation
  534.        should be called with the top n guys on the stack as arguments. */
  535.  
  536.  
  537. #define TRAP0(N) {trap_nargs=((N)); goto arg0_tt;}
  538. #define TRAP1(N) {trap_nargs=((N)); goto arg1_tt;}
  539.  
  540. #define TRAP0_IF(C,N) {if ((C)) TRAP0((N));}
  541. #define TRAP1_IF(C,N) {if ((C)) TRAP1((N));}
  542.  
  543. #define CHECKTAG0(X,TAG,N) TRAP0_IF(!TAG_IS((X),(TAG)),(N))
  544. #define CHECKTAG1(X,TAG,N) TRAP1_IF(!TAG_IS((X),(TAG)),(N))
  545.  
  546. #define CHECKCHAR0(X,N) \
  547.     TRAP0_IF(!SUBTAG_IS((X),CHAR_SUBTAG),(N))
  548. #define CHECKCHAR1(X,N) \
  549.     TRAP1_IF(!SUBTAG_IS((X),CHAR_SUBTAG),(N))
  550.  
  551. #define CHECKTAGS1(X0,T0,X1,T1,N) \
  552.     TRAP1_IF( !TAG_IS((X0),(T0)) || !TAG_IS((X1),(T1)), (N))
  553.  
  554. #define CHECKTAGS_INT_1(X0,X1,N) \
  555.     TRAP1_IF( (((X0)|(X1)) & TAG_MASK) != 0, (N))
  556.  
  557. #ifdef SIGNALS
  558. #define POLL_SIGNALS()    if (signal_pending()) {goto intr_trap;}
  559. #else
  560. #define POLL_SIGNALS()
  561. #endif
  562.  
  563. #ifndef FAST
  564.     debug = fopen("debug", "w");
  565. #endif
  566.  
  567.     /* This is the big instruction fetch/execute loop. */
  568.  
  569. #ifdef SIGNALS
  570.     enable_signal_polling();
  571. #endif
  572.  
  573.     while (1)
  574.       {
  575.  
  576. #ifndef FAST
  577.     if (trace_stcon) dump_val_stk();
  578.     if (trace_cxcon) dump_cxt_stk();
  579. #endif
  580.  
  581.     instr = *e_pc;
  582.  
  583. #define arg_field (instr>>8)
  584. /* #define signed_arg_field SIGN_8BIT_ARG(arg_field) */
  585. #define signed_arg_field ((short)((short)instr >> 8))
  586. #define op_field  ((instr & 0xFF) >> 2)
  587.  
  588. #ifndef FAST
  589.     if (trace_insts)
  590.       {
  591.         (void)sprintf(str, "%ld: %s (%d %d)\n",
  592.               (SPATIC_PTR((ref *)e_pc) ?
  593.                e_pc - (unsigned short *)spatic.start :
  594.                e_pc - (unsigned short *)new.start
  595.                + 2*spatic.size),
  596.               ((op_field == CASE_FOUR*0) ?
  597.                ArglessInstrs[arg_field] :
  598.                Instrs[op_field/CASE_FOUR]),
  599.               op_field, arg_field);
  600.         fputs(str, debug);
  601.         fputs(str, stdout);
  602.         fflush_stdout();
  603.       }
  604. #endif
  605.     e_pc += 1;
  606.  
  607.     /* Interrupt polling belongs here, but in order to slow things down
  608.        too much it is instead put in all the instructions that can do
  609.        transfers of control, eg branches and funcalls.  This cuts all
  610.        loops without slowing down each instruction. */
  611.  
  612.     switch (op_field)
  613.       {
  614.       case (CASE_FOUR*0):    /* ARGLESS-INSTRUCTION xxxx */
  615.         switch (arg_field)
  616.           {
  617.  
  618.           case 0:        /* NOOP */
  619.         break;
  620.  
  621.           case 1:        /* PLUS */
  622.         POPVAL(x);
  623.         y = PEEKVAL();
  624.         CHECKTAGS_INT_1(x,y,2);
  625.         /* Tag trickery: */
  626. #ifdef GUARD_BIT
  627.         {
  628.           register ref z = x+y;
  629.           if (OVERFLOWN(z)) TRAP1(2);
  630.           PEEKVAL() = z;
  631.         }
  632. #else
  633. #ifdef HAVE_LONG_LONG
  634.         {
  635.           long long a = (long)x + (long)y;
  636.           long highcrap = a>>(WORDSIZE-2);
  637.           if (highcrap && (highcrap != -1L)) TRAP1(2);
  638.           PEEKVAL() = (ref)a;
  639.         }
  640. #else
  641.         {
  642.           register long a = REF_TO_INT(x) + REF_TO_INT(y);
  643.           OVERFLOWN_INT(a, TRAP1(2));
  644.           PEEKVAL() = INT_TO_REF(a);
  645.         }
  646. #endif
  647. #endif
  648.         break;
  649.  
  650.           case 2:        /* NEGATE */
  651.         x = PEEKVAL();
  652.         CHECKTAG0(x,INT_TAG,1);
  653.         /* The most negative fixnum's negation isn't a fixnum. */
  654.         if (x == MIN_REF) TRAP0(1);
  655.         /* Tag trickery: */
  656.         PEEKVAL() = -x;
  657.         break;
  658.  
  659.           case 3:        /* EQ? */
  660.         POPVAL(x);
  661.         PEEKVAL() = x==PEEKVAL() ? e_t : e_nil;
  662.         break;
  663.  
  664.           case 4:        /* NOT */
  665.         PEEKVAL() = PEEKVAL() == e_nil ? e_t : e_nil;
  666.         break;
  667.  
  668.           case 5:        /* TIMES */
  669.         POPVAL(x);
  670.         y = PEEKVAL();
  671.         CHECKTAGS_INT_1(x,y,2);
  672.         /* Tag trickery: */
  673. #ifdef HAVE_LONG_LONG
  674.         {
  675.           long long a = REF_TO_INT(x) * (long)y;
  676.           long highcrap = a >> (WORDSIZE-2);
  677.           if ((highcrap != 0L) && (highcrap != -1L)) TRAP1(2);
  678.           PEEKVAL() = (ref)a;
  679.         }
  680. #else
  681. #ifdef GUARD_BIT
  682.         {
  683.           register ref z = REF_TO_INT(x) * (long)y;
  684.           /* Ineffective: */
  685.           if (OVERFLOWN(z)) TRAP1(2);
  686.           PEEKVAL() = z;
  687.         }
  688. #else
  689. #ifdef DOUBLES_FOR_OVERFLOW
  690.         {
  691.           double a = (double)REF_TO_INT(x)*(double)REF_TO_INT(y);
  692.           if (   a<(double)((long)MIN_REF/4)
  693.               || a>(double)((long)MAX_REF/4) ) TRAP1(2);
  694.           PEEKVAL() = INT_TO_REF((long)a);
  695.         }
  696. #else
  697.         {
  698.           long a = REF_TO_INT(x), b = REF_TO_INT(y);
  699.           unsigned long al, ah, bl, bh, hh, hllh, ll;
  700.           long answer;
  701.           bool neg = FALSE;
  702.           /* MNF check */
  703.           if (a<0) { a = -a; neg = TRUE; }
  704.           if (b<0) { b = -b; neg = !neg; }
  705.           al = a&0x7FFF;
  706.           bl = b&0x7FFF;
  707.           ah = (unsigned long)a>>15;
  708.           bh = (unsigned long)b>>15;
  709.           ll = al*bl;
  710.           hllh = al*bh+ah*bl;
  711.           hh = ah*bh;
  712.           if (hh || hllh>>15) TRAP1(2);
  713.           answer = (hllh<<15) + ll;
  714.           OVERFLOWN_INT(answer, TRAP1(2));
  715.           PEEKVAL() = INT_TO_REF(neg ? -answer : answer);
  716.         }
  717. #endif
  718. #endif
  719. #endif
  720.         break;
  721.  
  722.           case 6:        /* LOAD-IMM ; INLINE-REF */
  723.         /* align pc to next word boundary: */
  724.         if ((unsigned long)e_pc & 2)
  725.           e_pc += 1;
  726.  
  727.         /*NOSTRICT*/
  728.         PUSHVAL(*(ref *)e_pc);
  729.         e_pc += sizeof(ref) / sizeof(*e_pc);
  730.         break;
  731.  
  732.           case 7:        /* DIV */
  733.         /* Sign of product of args. */
  734.         /* Round towards 0.  Obays identity w/ REMAINDER. */
  735.         POPVAL(x);
  736.         y = PEEKVAL();
  737.         CHECKTAGS_INT_1(x,y,2);
  738.         /* Can't divide by 0, or the most negative fixnum by -1. */
  739.         if (y == INT_TO_REF(0) ||
  740.             y == INT_TO_REF(-1) && x == MIN_REF) TRAP1(2);
  741.         /* Tag trickery: */
  742.         PEEKVAL() = INT_TO_REF((long)x/(long)y);
  743.         break;
  744.  
  745.           case 8:        /* =0? */
  746.         x = PEEKVAL();
  747.         CHECKTAG0(x,INT_TAG,1);
  748.         PEEKVAL() = x == INT_TO_REF(0) ? e_t : e_nil;
  749.         break;
  750.  
  751.           case 9:        /* GET-TAG */
  752.         PEEKVAL() = INT_TO_REF(PEEKVAL() & TAG_MASK);
  753.         break;
  754.  
  755.           case 10:        /* GET-DATA */
  756.         /* With the moving gc, this should *NEVER* be used.
  757.  
  758.            For ease of debugging with the multiple spaces, this
  759.            makes it seem like spatic and new spaces are contiguous,
  760.            is compatible with print_ref, and also with CRUNCH. */
  761.         x = PEEKVAL();
  762.         if (x&PTR_MASK)
  763.           {
  764.             ref *p = (x&1) ? REF_TO_PTR(x) : LOC_TO_PTR(x);
  765.  
  766.             PEEKVAL() =
  767.               INT_TO_REF(
  768.                  SPATIC_PTR(p) ?
  769.                  p - spatic.start :
  770.                  NEW_PTR(p) ?
  771.                  (p - new.start) + spatic.size :
  772.                  ( /* This is one weird reference: */
  773.                   printf("GET-DATA of "),
  774.                   printref(x),
  775.                   printf("\n"),
  776.                   -(long)p - 1 )
  777.                  );
  778.           }
  779.         else
  780.           PEEKVAL() = x&~TAG_MASKL | INT_TAG;
  781.         break;
  782.  
  783.           case 11:        /* CRUNCH */
  784.         POPVAL(x); /* data */
  785.         y = PEEKVAL(); /* tag */
  786.         CHECKTAGS_INT_1(x,y,2);
  787.         {
  788.           int tag = REF_TO_INT(y)&TAG_MASK;
  789.           ref z;
  790.  
  791.           if (tag&PTR_MASK)
  792.             {
  793.               long i = REF_TO_INT(x);
  794.             
  795.               /* For now, preclude creation of very odd references. */
  796.               TRAP1_IF(i<0, 2);
  797.               if (i < spatic.size)
  798.             z = PTR_TO_LOC(spatic.start + i);
  799.               else if (i < (spatic.size + new.size))
  800.             z = PTR_TO_LOC(new.start + (i - spatic.size));
  801.               else
  802.             { TRAP1(2); }
  803.             }
  804.           else
  805.             z = x;
  806.  
  807.           PEEKVAL() = z | tag;
  808.         }
  809.         break;
  810.  
  811.           case 12:        /* GETC */
  812.         /***************************** OBSOLETE? *********************/
  813.         /* Used in emergency cold load standard-input stream. */
  814.         PUSHVAL_IMM(CHAR_TO_REF(getc(stdin)));
  815.         break;
  816.  
  817.           case 13:        /* PUTC */
  818.         /* Used in emergency cold load standard-output stream and
  819.            for the warm boot message. */
  820.         x = PEEKVAL();
  821.         CHECKCHAR0(x,1);
  822.         (void)putc(REF_TO_CHAR(x), stdout);
  823.         fflush_stdout();
  824.         if (trace_insts || trace_stcon || trace_cxcon)
  825.           (void)printf("\n");
  826.         break;
  827.  
  828.           case 14:        /* CONTENTS */
  829.         x = PEEKVAL();
  830.         CHECKTAG0(x,LOC_TAG,1);
  831.         PEEKVAL() = *LOC_TO_PTR(x);
  832.         break;
  833.  
  834.           case 15:        /* SET-CONTENTS */
  835.         POPVAL(x);
  836.         CHECKTAG1(x,LOC_TAG,2);
  837.         *LOC_TO_PTR(x) = PEEKVAL();
  838.         break;
  839.  
  840.           case 16:        /* LOAD-TYPE */
  841.         PEEKVAL() = get_type(PEEKVAL());
  842.         break;
  843.  
  844.           case 17:        /* CONS */
  845.         {
  846.           ref *p;
  847.  
  848.           ALLOCATE_SS(p, 3L, "space crunch in CONS instruction");
  849.  
  850.           *p = e_cons_type;
  851.           POPVAL(x);
  852.           *(p+CONS_PAIR_CAR_OFF) = x;
  853.           *(p+CONS_PAIR_CDR_OFF) = PEEKVAL();
  854.           PEEKVAL() = PTR_TO_REF(p);
  855.         }
  856.         break;
  857.  
  858.           case 18:        /* <0? */
  859.         x = PEEKVAL();
  860.         CHECKTAG0(x,INT_TAG,1);
  861.         /* Tag trickery: */
  862.         PEEKVAL() = (long)x < 0 ? e_t : e_nil;
  863.         break;
  864.  
  865.           case 19:        /* MODULO */
  866.         /* Sign of divisor (thing being divided by). */
  867.         POPVAL(x);
  868.         y = PEEKVAL();
  869.         CHECKTAGS_INT_1(x,y,2);
  870.         if (y == INT_TO_REF(0)) TRAP1(2);
  871.         {
  872.           long a =  REF_TO_INT(x) % REF_TO_INT(y);
  873.           if ((a<0 && (long)y>0) || ((long)y<0 && (long)x>0 && a>0))
  874.             a += REF_TO_INT(y);
  875.           PEEKVAL() = INT_TO_REF(a);
  876.         }
  877.         break;
  878.  
  879.           case 20:        /* ASH */
  880.         POPVAL(x);
  881.         y = PEEKVAL();
  882.         CHECKTAGS_INT_1(x,y,2);
  883.         /* Tag trickery: */
  884.         {
  885.           long b = REF_TO_INT(y);
  886.           if (b<0) 
  887.             PEEKVAL() = ((long)x >> -b) & ~TAG_MASKL;
  888.           else
  889.             PEEKVAL() = x << b;
  890.         }
  891.         break;
  892.  
  893.           case 21:        /* ROT */
  894.         POPVAL(x);
  895.         y = PEEKVAL();
  896.         CHECKTAGS_INT_1(x,y,2);
  897.         /* Rotations can not overflow, but are kind of meaningless in
  898.            the infinite precision model we have.  This instr is used
  899.            only for computing string hashes and stuff like that. */
  900.         {
  901.           unsigned long a = (unsigned long)x;
  902.           long b = REF_TO_INT(y);
  903.  
  904. #ifdef GUARD_BIT
  905.           PEEKVAL()
  906.             = FIX_GUARD_BIT(( b<0 ? (a>>-b | a<<(WORDSIZE-3+b))
  907.                      : (a<<b | a>>(WORDSIZE-3-b)) )
  908.                     & ~TAG_MASKL);
  909. #else
  910.           PEEKVAL()
  911.             = (  b<0
  912.                ? (a>>-b | a<<(WORDSIZE-2+b))
  913.                : (a<<b | a>>(WORDSIZE-2-b)) )
  914.               & ~TAG_MASKL;
  915. #endif
  916.         }
  917.         break;
  918.  
  919.           case 22:        /* STORE-BP-I */
  920.         POPVAL(x);
  921.         CHECKTAG1(x,INT_TAG,2);
  922.         *(e_bp + REF_TO_INT(x)) = PEEKVAL();
  923.         break;
  924.  
  925.           case 23:        /* LOAD-BP-I */
  926.         x = PEEKVAL();
  927.         CHECKTAG0(x,INT_TAG,1);
  928.         PEEKVAL() = *(e_bp + REF_TO_INT(x));
  929.         break;
  930.  
  931.           case 24:        /* RETURN */
  932.         POP_CONTEXT();
  933.         break;
  934.  
  935.           case 25:        /* ALLOCATE */
  936.         POPVAL(x);
  937.         y = PEEKVAL();
  938.         CHECKTAG1(y,INT_TAG,2);
  939.         {
  940.           ref *p;
  941.           
  942.           ALLOCATE1(p, REF_TO_INT(y),
  943.                 "space crunch in ALLOCATE instruction", x);
  944.  
  945.           *p = x;
  946.  
  947.           PEEKVAL() = PTR_TO_REF(p++);
  948.  
  949.           while (p < free_point)
  950.             *p++ = NEW_STORAGE;
  951.         }
  952.         break;
  953.  
  954.           case 26:        /* ASSQ */
  955.         {
  956.           register ref z;
  957.           
  958.           POPVAL(z);
  959.           x = PEEKVAL();
  960.           /* y = assq(z,x); */
  961.           while (x != e_nil && car(car(x)) != z)
  962.             x = cdr(x);
  963.         }
  964.         PEEKVAL() = ((x == e_nil) ? e_nil : car(x));
  965.         break;
  966.  
  967.           case 27:        /* LOAD-LENGTH */
  968.         x = PEEKVAL();
  969.         PEEKVAL() =
  970.           (TAG_IS(x,PTR_TAG) ?
  971.            (REF_SLOT(REF_SLOT(x,0),TYPE_VAR_LEN_P_OFF) == e_nil ?
  972.             REF_SLOT(REF_SLOT(x,0),TYPE_LEN_OFF) :
  973.             REF_SLOT(x,1)) :
  974.            INT_TO_REF(0));
  975.         break;
  976.  
  977.           case 28:        /* PEEK */
  978.         PEEKVAL() = INT_TO_REF( *(short *)PEEKVAL() );
  979.         break;
  980.  
  981.           case 29:        /* POKE */
  982.         POPVAL(x);
  983.         *(short *)x = REF_TO_INT(PEEKVAL());
  984.         break;
  985.  
  986.           case 30:        /* MAKE-CELL */
  987.         {
  988.           ref *p;
  989.           
  990.           ALLOCATE_SS(p,1L,"space crunch in MAKE-CELL instruction");
  991.  
  992.           *p = PEEKVAL();
  993.           PEEKVAL() = PTR_TO_LOC(p);
  994.         }
  995.         break;
  996.  
  997.           case 31:        /* SUBTRACT */
  998.         POPVAL(x);
  999.         y = PEEKVAL();
  1000.         CHECKTAGS_INT_1(x,y,2);
  1001.         /* Tag trickery: */
  1002. #ifdef GUARD_BIT
  1003.         {
  1004.           register ref z;
  1005.           z = x-y;
  1006.           if (OVERFLOWN(z)) TRAP1(2);
  1007.           PEEKVAL() = z;
  1008.         }
  1009. #else
  1010.         {
  1011.           long a = REF_TO_INT(x) - REF_TO_INT(y);
  1012.           OVERFLOWN_INT(a, TRAP1(2));
  1013.           PEEKVAL() = INT_TO_REF(a);
  1014.         }
  1015. #endif
  1016.         break;
  1017.  
  1018.           case 32:        /* = */
  1019.         POPVAL(x);
  1020.         y = PEEKVAL();
  1021.         CHECKTAGS_INT_1(x,y,2);
  1022.         PEEKVAL() = x == y ? e_t : e_nil;
  1023.         break;
  1024.  
  1025.           case 33:        /* < */
  1026.         POPVAL(x);
  1027.         y = PEEKVAL();
  1028.         CHECKTAGS_INT_1(x,y,2);
  1029.         /* Tag trickery: */ 
  1030.         PEEKVAL() = (long)x < (long)y ? e_t : e_nil;
  1031.         break;
  1032.  
  1033.           case 34:        /* LOG-NOT */
  1034.         x = PEEKVAL();
  1035.         CHECKTAG0(x,INT_TAG,1);
  1036.         /* Tag trickery: */
  1037.         PEEKVAL() = ~x - (TAG_MASK-INT_TAG);
  1038.         break;
  1039.  
  1040.           case 35:        /* LONG-BRANCH distance (signed) */
  1041.         POLL_SIGNALS();
  1042.         e_pc += ASHR2(SIGN_16BIT_ARG(*e_pc))+1;
  1043.         break;
  1044.  
  1045.           case 36:        /* LONG-BRANCH-NIL distance (signed) */
  1046.         POLL_SIGNALS();
  1047.         POPVAL(x);
  1048.         if (x == e_nil)
  1049.           e_pc += ASHR2(SIGN_16BIT_ARG(*e_pc))+1;
  1050.         else
  1051.           e_pc += 1;
  1052.         break;
  1053.  
  1054.           case 37:        /* LONG-BRANCH-T distance (signed) */
  1055.         POLL_SIGNALS();
  1056.         POPVAL(x);
  1057.         if (x != e_nil)
  1058.           e_pc += ASHR2(SIGN_16BIT_ARG(*e_pc))+1;
  1059.         else
  1060.           e_pc += 1;
  1061.         break;
  1062.  
  1063.           case 38:        /* LOCATE-BP-I */
  1064.         x = PEEKVAL();
  1065.         CHECKTAG0(x,INT_TAG,1);
  1066.         PEEKVAL() = PTR_TO_LOC(e_bp + REF_TO_INT(x));
  1067.         break;
  1068.  
  1069.           case 39:        /* LOAD-IMM-CON ; INLINE-REF */
  1070.         /* This is like a LOAD-IMM followed by a CONTENTS. */
  1071.         /* align pc to next word boundary: */
  1072.         if ((unsigned long)e_pc & 2)
  1073.           e_pc += 1;
  1074.  
  1075.         /*NOSTRICT*/
  1076.         x = *(ref *)e_pc;
  1077.         e_pc += 2;
  1078.  
  1079.         CHECKTAG1(x,LOC_TAG,1);
  1080.         PUSHVAL(*LOC_TO_PTR(x));
  1081.         break;
  1082.  
  1083.         /* Cons instructions. */
  1084.  
  1085. #define CONSINSTR(a,ins)                    \
  1086.         {                        \
  1087.           x = PEEKVAL();                \
  1088.           CHECKTAG0(x,PTR_TAG, a);            \
  1089.           if (REF_SLOT(x,0) != e_cons_type)        \
  1090.             {                        \
  1091.               if (trace_traps)                \
  1092.             (void)printf("Type trap in ins.\n");    \
  1093.               TRAP0(a);                    \
  1094.             }                        \
  1095.         }
  1096.  
  1097.           case 40:        /* CAR */
  1098.         CONSINSTR(1,CAR);
  1099.         PEEKVAL() = car(x);
  1100.         break;
  1101.  
  1102.           case 41:        /* CDR */
  1103.         CONSINSTR(1,CDR);
  1104.         PEEKVAL() = cdr(x);
  1105.         break;
  1106.  
  1107.           case 42:        /* SET-CAR */
  1108.         CONSINSTR(2,SET-CAR);
  1109.         POPVALS(1);
  1110.         car(x) = PEEKVAL();
  1111.         break;
  1112.  
  1113.           case 43:        /* SET-CDR */
  1114.         CONSINSTR(2,SET-CDR);
  1115.         POPVALS(1);
  1116.         cdr(x) = PEEKVAL();
  1117.         break;
  1118.  
  1119.           case 44:        /* LOCATE-CAR */
  1120.         CONSINSTR(1,LOCATE-CAR);
  1121.         PEEKVAL() = PTR_TO_LOC(&car(x));
  1122.         break;
  1123.  
  1124.           case 45:        /* LOCATE-CDR */
  1125.         CONSINSTR(1,LOCATE-CDR);
  1126.         PEEKVAL() = PTR_TO_LOC(&cdr(x));
  1127.         break;
  1128.  
  1129.         /* Done with cons instructions. */
  1130.  
  1131.           case 46:        /* PUSH-CXT-LONG rel */
  1132.         PUSH_CONTEXT(ASHR2(SIGN_16BIT_ARG(*e_pc)) + 1);
  1133.         e_pc += 1;
  1134.         break;
  1135.  
  1136.           case 47:        /* Call a primitive routine. */
  1137. #ifdef Mac_LSC
  1138.         {
  1139.           ref primRef, callRef, retRef, paramList;
  1140.           POPVAL(primRef);
  1141.           POPVAL(callRef);
  1142.           POPVAL(retRef);
  1143.           paramList = PEEKVAL();
  1144.           PEEKVAL() = Call_Primitive(primRef, callRef, retRef, paramList);
  1145.         }
  1146. #else
  1147.         printf("Not configured for CALL-PRIMITIVE.\n");
  1148. #endif
  1149.         break;
  1150.  
  1151.           case 48:        /* THROW */
  1152.         POPVAL(x);
  1153.         CHECKTAG1(x,PTR_TAG,2);
  1154.         y = PEEKVAL();
  1155.         bash_val_height(REF_TO_INT(REF_SLOT(x,ESCAPE_OBJECT_VAL_OFF)));
  1156.         bash_cxt_height(REF_TO_INT(REF_SLOT(x,ESCAPE_OBJECT_CXT_OFF)));
  1157.         PUSHVAL(y);
  1158.         POP_CONTEXT();
  1159.         break;
  1160.  
  1161.           case 49:        /* GET-WP */
  1162.         PEEKVAL() = ref_to_wp(PEEKVAL());
  1163.         break;
  1164.  
  1165.           case 50:        /* WP-CONTENTS */
  1166.         x = PEEKVAL();
  1167.         CHECKTAG0(x,INT_TAG,1);
  1168.         PEEKVAL() = wp_to_ref(x);
  1169.         break;
  1170.  
  1171.           case 51:        /* GC */
  1172.         UNOPTC(cxt_stk.ptr = cxt_stk_ptr);
  1173.         UNOPTV(val_stk.ptr = val_stk_ptr);
  1174.         gc(FALSE, FALSE, "explicit call", 0L);
  1175.         UNOPTV(val_stk_ptr = val_stk.ptr);
  1176.         UNOPTC(cxt_stk_ptr = cxt_stk.ptr);
  1177.         PUSHVAL(e_nil);
  1178.         break;
  1179.  
  1180.           case 52:        /* BIG-ENDIAN? */
  1181. #ifdef BIG_ENDIAN
  1182.         PUSHVAL(e_t);
  1183. #else
  1184.         PUSHVAL(e_nil);
  1185. #endif
  1186.         break;
  1187.  
  1188.           case 53:        /* VLEN-ALLOCATE */
  1189.         POPVAL(x);
  1190.         y = PEEKVAL();
  1191.         CHECKTAG1(y,INT_TAG,2);
  1192.         {
  1193.           ref *p;
  1194.           
  1195.           ALLOCATE1(p, REF_TO_INT(y),
  1196.                 "space crunch in VARLEN-ALLOCATE instruction", x);
  1197.  
  1198.           PEEKVAL() = PTR_TO_REF(p);
  1199.  
  1200.           *p++ = x;
  1201.           *p++ = y;
  1202.  
  1203.           while (p < free_point)
  1204.             *p++ = NEW_STORAGE;
  1205.         }
  1206.         break;
  1207.  
  1208.           case 54:        /* INC-LOC */
  1209.         /* Increment a locative by an amount.  This is an instruction
  1210.            rather than (%crunch (+ (%pointer loc) index) %locative-tag)
  1211.            to avoid a window of gc vulnerability.  All such windows
  1212.            must be fully closed before engines come up. */
  1213.         POPVAL(x);
  1214.         y = PEEKVAL();
  1215.         CHECKTAGS1(x,LOC_TAG,y,INT_TAG,2);
  1216.         PEEKVAL() = PTR_TO_LOC(LOC_TO_PTR(x)+REF_TO_INT(y));
  1217.         break;
  1218.  
  1219.           case 55:        /* FILL-CONTINUATION */
  1220.         /* This instruction fills a continuation object with
  1221.            the appropriate values. */
  1222.         CHECKVAL_POP(1);
  1223.         FLUSHVAL(2);
  1224.         FLUSHCXT(0);
  1225. #ifndef FAST
  1226.         /* debugging check: */
  1227.         if (val_stk_ptr != &val_stk.data[1])
  1228.           printf("Value stack flushing error.\n");
  1229.         if (cxt_stk_ptr != &cxt_stk.data[0]-1)
  1230.           printf("Context stack flushing error.\n");
  1231. #endif
  1232.         x = PEEKVAL();
  1233.         /* CHECKTAG0(x,PTR_TAG,1); */
  1234.         REF_SLOT(x,CONTINUATION_VAL_SEGS) = val_stk.segment;
  1235.         REF_SLOT(x,CONTINUATION_VAL_OFF)
  1236.           = INT_TO_REF(val_stk.pushed_count);
  1237.         REF_SLOT(x,CONTINUATION_CXT_SEGS) = cxt_stk.segment;
  1238.         REF_SLOT(x,CONTINUATION_CXT_OFF)
  1239.           = INT_TO_REF(cxt_stk.pushed_count);
  1240.         /* Maybe it's a good idea to reload the buffer, but I'm
  1241.            not bothering and things seem to work. */
  1242.         /* CHECKCXT_POP(0); */
  1243.         break;
  1244.  
  1245.           case 56:        /* CONTINUE */
  1246.         /* Continue a continuation. */
  1247.         /* Grab the continuation. */
  1248.         
  1249.         POPVAL(x);
  1250.         /* CHECKTAG1(x,PTR_TAG,1); */
  1251.         y = PEEKVAL();
  1252.         /* Pull the crap out of it. */
  1253.  
  1254.         val_stk.segment = REF_SLOT(x,CONTINUATION_VAL_SEGS);
  1255.         val_stk.pushed_count
  1256.           = REF_TO_INT(REF_SLOT(x,CONTINUATION_VAL_OFF));
  1257.         val_stk_ptr = &val_stk.data[0]-1;
  1258.         PUSHVAL_NOCHECK(y);
  1259.  
  1260.         cxt_stk.segment = REF_SLOT(x,CONTINUATION_CXT_SEGS);
  1261.         cxt_stk.pushed_count
  1262.           = REF_TO_INT(REF_SLOT(x,CONTINUATION_CXT_OFF));
  1263.         cxt_stk_ptr = &cxt_stk.data[0]-1;
  1264.         POP_CONTEXT();
  1265.         break;
  1266.  
  1267.           case 57:        /* REVERSE-CONS */
  1268.         /* This is just like CONS except that it takes its args
  1269.            in the other order.  Makes open coded LIST better. */
  1270.         {
  1271.           ref *p;
  1272.  
  1273.           ALLOCATE_SS(p, 3L, "space crunch in CONS instruction");
  1274.  
  1275.           *p = e_cons_type;
  1276.           POPVAL(x);
  1277.           *(p+CONS_PAIR_CDR_OFF) = x;
  1278.           *(p+CONS_PAIR_CAR_OFF) = PEEKVAL();
  1279.           PEEKVAL() = PTR_TO_REF(p);
  1280.         }
  1281.         break;
  1282.  
  1283.           case 58:        /* MOST-NEGATIVE-FIXNUM? */
  1284.         PEEKVAL() = PEEKVAL()==MIN_REF ? e_t : e_nil;
  1285.         break;
  1286.  
  1287.           case 59:        /* FX-PLUS */
  1288.         POPVAL(x);
  1289.         y = PEEKVAL();
  1290.         CHECKTAGS_INT_1(x,y,2);
  1291.         /* Tag trickery: */
  1292.         PEEKVAL() = x+y;
  1293.         break;
  1294.  
  1295.           case 60:        /* FX-TIMES */
  1296.         POPVAL(x);
  1297.         y = PEEKVAL();
  1298.         CHECKTAGS_INT_1(x,y,2);
  1299.         /* Tag trickery: */
  1300.         PEEKVAL() = REF_TO_INT(x)*y;
  1301.         break;
  1302.  
  1303.           case 61:        /* GET-TIME */
  1304.         /* Return CPU time in microseconds or #f if unavailable. */
  1305. #ifdef unix
  1306.         {
  1307.           struct rusage rusage_buff;
  1308.           (void)getrusage(RUSAGE_SELF, &rusage_buff);
  1309.           PUSHVAL_IMM(INT_TO_REF(1000000 * rusage_buff.ru_utime.tv_sec
  1310.                      + rusage_buff.ru_utime.tv_usec));
  1311.         }
  1312. #else
  1313.         PUSHVAL(e_nil);
  1314. #endif
  1315.         break;
  1316.  
  1317.           case 62:        /* REMAINDER */
  1318.         /* Sign of dividend (thing being divided.) */
  1319.         POPVAL(x);
  1320.         y = PEEKVAL();
  1321.         CHECKTAGS_INT_1(x,y,2);
  1322.         if (y == INT_TO_REF(0)) TRAP1(2);
  1323.         PEEKVAL() = INT_TO_REF(REF_TO_INT(x) % REF_TO_INT(y));
  1324.         break;
  1325.  
  1326.           case 63:        /* QUOTIENTM */
  1327.         /* Round towards -inf.  Obeys identity w/ MODULO. */
  1328.         POPVAL(x);
  1329.         y = PEEKVAL();
  1330.         CHECKTAGS_INT_1(x,y,2);
  1331.         /* Can't divide by 0, or the most negative fixnum by -1. */
  1332.         if (y == INT_TO_REF(0) ||
  1333.             y == INT_TO_REF(-1) && x == MIN_REF) TRAP1(2);
  1334.         /* Tag trickery: */
  1335.         /* I can't seem to get anything like this to work: */
  1336.         PEEKVAL() = INT_TO_REF(((long)x<0 ^ (long)y<0)
  1337.                        ? -(long)x/-(long)y
  1338.                        : (long)x/(long)y);
  1339.         {
  1340.           long a = (long)x/(long)y;
  1341.           if ((long)x<0 && (long)y>0 && a*(long)y > (long)x ||
  1342.               (long)y<0 && (long)x>0 && a*(long)y < (long)x)
  1343.             a -= 1;
  1344.           PEEKVAL() = INT_TO_REF(a);
  1345.         }
  1346.         break;
  1347.  
  1348.           case 64:        /* FULL-GC */
  1349.         UNOPTC(cxt_stk.ptr = cxt_stk_ptr);
  1350.         UNOPTV(val_stk.ptr = val_stk_ptr);
  1351.         gc(FALSE, TRUE, "explicit call", 0L);
  1352.         UNOPTV(val_stk_ptr = val_stk.ptr);
  1353.         UNOPTC(cxt_stk_ptr = cxt_stk.ptr);
  1354.         PUSHVAL(e_nil);
  1355.         break;
  1356.  
  1357. #ifndef FAST
  1358.           default:
  1359.         (void)printf("\nIllegal ARGLESS instruction %d.\n", arg_field);
  1360.         maybe_dump_world(333);
  1361.         exit(333);
  1362. #endif
  1363.           }
  1364.         break;
  1365.  
  1366.       case (CASE_FOUR*1):    /* HALT n */
  1367.         {
  1368.           int halt_code = arg_field;
  1369.           maybe_dump_world(halt_code);
  1370.           exit(halt_code);
  1371.         }
  1372.  
  1373.       case (CASE_FOUR*2):    /* LOG-OP log-spec */
  1374.         POPVAL(x);
  1375.         y = PEEKVAL();
  1376.         CHECKTAGS_INT_1(x,y,2);
  1377.         /* Tag trickery: */
  1378.         PEEKVAL() = (  (instr&(1<< 8) ?  x& y : 0)
  1379.              | (instr&(1<< 9) ? ~x& y : 0)
  1380.              | (instr&(1<<10) ?  x&~y : 0)
  1381.              | (instr&(1<<11) ? ~x&~y : 0) ) & ~TAG_MASKL;
  1382.         break;
  1383.  
  1384.       case (CASE_FOUR*3):    /* BLT-STACK stuff,trash */
  1385.         {
  1386.           register int stuff = arg_field&0xF
  1387.         , trash_m1 = (instr>>(8+4));
  1388.  
  1389.           CHECKVAL_POP(stuff+trash_m1);
  1390.  
  1391.           {
  1392.         register ref *src = val_stk_ptr - stuff
  1393.           , *dest = src - (trash_m1+1);
  1394.  
  1395.         while (src < val_stk_ptr)
  1396.           *++dest = *++src;
  1397.  
  1398.         val_stk_ptr = dest;
  1399.           }
  1400.         }
  1401.         break;
  1402.  
  1403.       case (CASE_FOUR*4):    /* BRANCH-NIL distance (signed) */
  1404.         POLL_SIGNALS();
  1405.         POPVAL(x);
  1406.         if (x == e_nil)
  1407.           e_pc += signed_arg_field;
  1408.         break;
  1409.  
  1410.       case (CASE_FOUR*5):    /* BRANCH-T distance (signed) */
  1411.         POLL_SIGNALS();
  1412.         POPVAL(x);
  1413.         if (x != e_nil)
  1414.           e_pc += signed_arg_field;
  1415.         break;
  1416.  
  1417.       case (CASE_FOUR*6):    /* BRANCH distance (signed) */
  1418.         POLL_SIGNALS();
  1419.         e_pc += signed_arg_field;
  1420.         break;
  1421.  
  1422.       case (CASE_FOUR*7):    /* POP n */
  1423.         POPVALS((int)arg_field);
  1424.         break;
  1425.  
  1426.       case (CASE_FOUR*8):    /* SWAP n */
  1427.         {
  1428.           ref *other;
  1429.           MAKE_BACK_VAL_PTR(other, (int)arg_field);
  1430.           x = PEEKVAL();
  1431.           PEEKVAL() = *other;
  1432.           *other = x;
  1433.         }
  1434.         break;
  1435.  
  1436.       case (CASE_FOUR*9):    /* BLAST n */
  1437.         CHECKVAL_POP((int)arg_field);
  1438.         {
  1439.           ref *other = val_stk_ptr - arg_field;
  1440.           *other = POPVAL_NOCHECK();
  1441.         }
  1442.         break;
  1443.  
  1444.       case (CASE_FOUR*10):    /* LOAD-IMM-FIX signed-arg */
  1445.         /* Tag trickery and opcode knowledge changes this
  1446.            PUSHVAL_IMM(INT_TO_REF(signed_arg_field));
  1447.            to this: */
  1448.         PUSHVAL_IMM((ref) (((short)instr)>>6));
  1449.         break;
  1450.  
  1451.       case (CASE_FOUR*11):    /* STORE-STK n */
  1452.         {
  1453.           ref *other;
  1454.  
  1455.           MAKE_BACK_VAL_PTR(other, (int)arg_field);
  1456.           *other = PEEKVAL();
  1457.         }
  1458.         break;
  1459.  
  1460.       case (CASE_FOUR*12):    /* LOAD-BP n */
  1461.         PUSHVAL(*(e_bp + arg_field));
  1462.         break;
  1463.  
  1464.       case (CASE_FOUR*13):    /* STORE-BP n */
  1465.         *(e_bp + arg_field) = PEEKVAL();
  1466.         break;
  1467.  
  1468.       case (CASE_FOUR*14):    /* LOAD-ENV n */
  1469.         PUSHVAL(*(e_env + arg_field));
  1470.         break;
  1471.  
  1472.       case (CASE_FOUR*15):    /* STORE-ENV n */
  1473.         *(e_env + arg_field) = PEEKVAL();
  1474.         break;
  1475.  
  1476.       case (CASE_FOUR*16):    /* LOAD-STK n */
  1477.         /* All attempts to start this with if (arg_field == 0) for speed
  1478.            have failed, so benchmark carefully before trying it. */
  1479.         {
  1480.           ref *other;
  1481.           MAKE_BACK_VAL_PTR(other, (int)arg_field);
  1482.           PUSHVAL(*other);
  1483.         }
  1484.         break;
  1485.  
  1486.       case (CASE_FOUR*17):    /* MAKE-BP-LOC n */
  1487.         PUSHVAL(PTR_TO_LOC(e_bp + arg_field));
  1488.         break;
  1489.  
  1490.       case (CASE_FOUR*18):    /* MAKE-ENV-LOC n */
  1491.         PUSHVAL(PTR_TO_LOC(e_env + arg_field));
  1492.         break;
  1493.  
  1494.       case (CASE_FOUR*19):    /* STORE-REG reg */
  1495.         x = PEEKVAL();
  1496.         switch (arg_field)
  1497.           {
  1498.           case 0:
  1499.         e_t = x;
  1500.         break;
  1501.           case 1:
  1502.         e_nil = x;
  1503.         wp_table[0] = e_nil;
  1504.         rebuild_wp_hashtable();
  1505.         break;
  1506.           case 2:
  1507.         e_fixnum_type = x;
  1508.         break;
  1509.           case 3:
  1510.         e_loc_type = x;
  1511.         break;
  1512.           case 4:
  1513.         e_cons_type = x;
  1514.         break;
  1515.           case 5:
  1516.         CHECKTAG1(x,PTR_TAG,1);
  1517.         e_subtype_table = REF_TO_PTR(x) + 2;
  1518.         break;
  1519.           case 6:
  1520.         CHECKTAG1(x,LOC_TAG,1);
  1521.         e_bp = LOC_TO_PTR(x);
  1522.         break;
  1523.           case 7:
  1524.         CHECKTAG1(x,PTR_TAG,1);
  1525.         e_env = REF_TO_PTR(x);
  1526.         break;
  1527.           case 8:
  1528.         CHECKTAG1(x,INT_TAG,1);
  1529.         e_nargs = REF_TO_INT(x);
  1530.         break;
  1531.           case 9:
  1532.         e_env_type = x;
  1533.         break;
  1534.           case 10:
  1535.         CHECKTAG1(x,PTR_TAG,1);
  1536.         e_argless_tag_trap_table = REF_TO_PTR(x) + 2;
  1537.         break;
  1538.           case 11:
  1539.         CHECKTAG1(x,PTR_TAG,1);
  1540.         e_arged_tag_trap_table = REF_TO_PTR(x) + 2;
  1541.         break;
  1542.           case 12:
  1543.         e_object_type = x;
  1544.         break;
  1545.           case 13:
  1546.         e_boot_code = x;
  1547.         break;
  1548.           case 14:
  1549.         CHECKTAG1(x,LOC_TAG,1);
  1550.         free_point = LOC_TO_PTR(x);
  1551.         break;
  1552.           case 15:
  1553.         CHECKTAG1(x,LOC_TAG,1);
  1554.         new.end = LOC_TO_PTR(x);
  1555.         break;
  1556.           case 16:
  1557.         e_segment_type = x;
  1558.         BASH_SEGMENT_TYPE(x);
  1559.         break;
  1560.           case 17:
  1561.         e_uninitialized = x;
  1562.         break;
  1563.           case 18:
  1564.         CHECKTAG1(x,INT_TAG,1);
  1565.         e_next_newspace_size = REF_TO_INT(x);
  1566.         break;
  1567.           case 19:
  1568.         e_method_type = x;
  1569.         break;
  1570.           default:
  1571.         (void)printf("STORE-REG %d, unknown register.\n", arg_field);
  1572.         break;
  1573.           }
  1574.         break;
  1575.  
  1576.       case (CASE_FOUR*20):    /* LOAD-REG reg */
  1577.         {
  1578.           ref z;
  1579.           
  1580.           switch (arg_field)
  1581.         {
  1582.         case 0:
  1583.           z = e_t;
  1584.           break;
  1585.         case 1:
  1586.           z = e_nil;
  1587.           break;
  1588.         case 2:
  1589.           z = e_fixnum_type;
  1590.           break;
  1591.         case 3:
  1592.           z = e_loc_type;
  1593.           break;
  1594.         case 4:
  1595.           z = e_cons_type;
  1596.           break;
  1597.         case 5:
  1598.           z = PTR_TO_REF(e_subtype_table - 2);
  1599.           break;
  1600.         case 6:
  1601.           z = PTR_TO_LOC(e_bp);
  1602.           break;
  1603.         case 7:
  1604.           z = PTR_TO_REF(e_env);
  1605.           break;
  1606.         case 8:
  1607.           z = INT_TO_REF((long)e_nargs);
  1608.           break;
  1609.         case 9:
  1610.           z = e_env_type;
  1611.           break;
  1612.         case 10:
  1613.           z = PTR_TO_REF(e_argless_tag_trap_table - 2);
  1614.           break;
  1615.         case 11:
  1616.           z = PTR_TO_REF(e_arged_tag_trap_table - 2);
  1617.           break;
  1618.         case 12:
  1619.           z = e_object_type;
  1620.           break;
  1621.         case 13:
  1622.           z = e_boot_code;
  1623.           break;
  1624.         case 14:
  1625.           z = PTR_TO_LOC(free_point);
  1626.           break;
  1627.         case 15:
  1628.           z = PTR_TO_LOC(new.end);
  1629.           break;
  1630.         case 16:
  1631.           z = e_segment_type;
  1632.           break;
  1633.         case 17:
  1634.           z = e_uninitialized;
  1635.           break;
  1636.         case 18:
  1637.           z = INT_TO_REF(e_next_newspace_size);
  1638.           break;
  1639.         case 19:
  1640.           z = e_method_type;
  1641.           break;
  1642.         default:
  1643.           (void)printf("LOAD-REG %d, unknown register.\n", arg_field);
  1644.           z = e_nil;
  1645.           break;
  1646.         }
  1647.           PUSHVAL(z);
  1648.         }
  1649.         break;
  1650.  
  1651.       case (CASE_FOUR*21):    /* FUNCALL-CXT, FUNCALL-CXT-BR distance (signed) */
  1652.         POLL_SIGNALS();
  1653.         /* NOTE: (FUNCALL-CXT) == (FUNCALL-CXT-BR 0) */
  1654.         PUSH_CONTEXT(signed_arg_field);
  1655.  
  1656.         /* Fall through to tail recursive case: */
  1657.         goto funcall_tail;
  1658.  
  1659.       case (CASE_FOUR*22):    /* FUNCALL-TAIL */
  1660.  
  1661.         /* This polling should not be moved below the trap label, since
  1662.            the interrupt code will fail on a fake instruction failure. */
  1663.         POLL_SIGNALS();
  1664.  
  1665.         /* This label allows us to branch here from the tag trap code. */
  1666.       funcall_tail:
  1667.  
  1668.         x = PEEKVAL();
  1669.         CHECKTAG0(x,PTR_TAG,e_nargs+1);
  1670.         CHECKVAL_POP(1);
  1671.         y = PEEKVAL_UP(1);
  1672.  
  1673.         e_current_method = REF_SLOT(x,OPERATION_LAMBDA_OFF);
  1674.  
  1675.         if (e_current_method == e_nil)
  1676.           {            /* SEARCH */
  1677.         ref y_type = (e_nargs == 0) ? e_object_type : get_type(y);
  1678. #ifndef NO_METH_CACHE
  1679.         /* Check for cache hit: */
  1680.         if (y_type == REF_SLOT(x,OPERATION_CACHE_TYPE_OFF))
  1681.           {
  1682.             MAYBE_PUT(trace_mcache, "H");
  1683.             e_current_method = REF_SLOT(x,OPERATION_CACHE_METH_OFF);
  1684.             e_bp =
  1685.               REF_TO_PTR(y) +
  1686.             REF_TO_INT(REF_SLOT(x,OPERATION_CACHE_TYPE_OFF_OFF));
  1687.           }
  1688.         else
  1689. #endif
  1690.           {
  1691.             /* Search the type heirarchy. */
  1692.             ref meth_type, offset = INT_TO_REF(0);
  1693.  
  1694.             /******************************************************
  1695.             find_method_type_pair(x, y_type,
  1696.                       &e_current_method, &meth_type);
  1697.                       */
  1698.  
  1699.             {
  1700.               ref obj_type = y_type;
  1701.               register ref alist;
  1702.               register ref *locl = NULL;
  1703.               ref thelist;
  1704.               ref *loclist;
  1705.               register ref *llp = &later_lists[0] - 1;
  1706.  
  1707.               while (1)
  1708.             {
  1709.               /* First look for it in the local method alist of obj_type: */
  1710.  
  1711.               alist = thelist =
  1712.                 *(loclist = &REF_SLOT(obj_type, TYPE_OP_METHOD_ALIST_OFF));
  1713.  
  1714.               while (alist != e_nil)
  1715.                 {
  1716.                   if (car(car(alist)) == x)
  1717.                 {
  1718.                   if (locl != NULL) {
  1719.                     *locl = cdr(alist);
  1720.                     *loclist = alist;
  1721.                     cdr(alist) = thelist;
  1722.                   }
  1723.                   e_current_method = cdr(car(alist));
  1724.                   meth_type = obj_type;
  1725.                   goto found_it;
  1726.                 }
  1727.                   alist = *(locl = &cdr(alist));
  1728.                 }
  1729.  
  1730.               /* Not there, stack the supertype list and then fetch the top guy
  1731.                  available from the stack. */
  1732.  
  1733.               *++llp = REF_SLOT(obj_type, TYPE_SUPER_LIST_OFF);
  1734.  
  1735.               while (*llp == e_nil)
  1736.                 {
  1737.                   if (llp == &later_lists[0])
  1738.                 {
  1739.                   if (trace_traps)
  1740.                     (void)printf("No handler for operation!\n");
  1741.                   TRAP0(e_nargs+1);
  1742.                 }                
  1743.                   llp -= 1;
  1744.                 }
  1745.  
  1746.               locl = NULL;
  1747.               obj_type = car(*llp);
  1748.               *llp = cdr(*llp);
  1749.             }
  1750.             }
  1751.  
  1752.           found_it:
  1753.  
  1754.  
  1755.             /******************************************************/
  1756.  
  1757.             /*
  1758.             if (e_current_method == e_nil)
  1759.               {
  1760.             if (trace_traps)
  1761.               (void)printf("No handler for operation!\n");
  1762.             TRAP1(e_nargs+1);
  1763.               }
  1764.               */
  1765.  
  1766.             /* This could be dispensed with if meth_type has no
  1767.                ivars and isn't variable-length-mixin. */
  1768.             {
  1769.               ref alist
  1770.             = REF_SLOT(y_type, TYPE_TYPE_BP_ALIST_OFF);
  1771.  
  1772.               while (alist != e_nil)
  1773.             {
  1774.               if (car(car(alist)) == meth_type)
  1775.                 {
  1776.                   offset = cdr(car(alist));
  1777.                   break;
  1778.                 }
  1779.               alist = cdr(alist);
  1780.             }
  1781.             }
  1782.             e_bp = REF_TO_PTR(y) + REF_TO_INT(offset);
  1783. #ifndef NO_METH_CACHE
  1784.             MAYBE_PUT(trace_mcache, "M");
  1785.             /* Cache the results of this search. */
  1786.             REF_SLOT(x,OPERATION_CACHE_TYPE_OFF) = y_type;
  1787.             REF_SLOT(x,OPERATION_CACHE_METH_OFF) = e_current_method;
  1788.             REF_SLOT(x,OPERATION_CACHE_TYPE_OFF_OFF) = offset;
  1789. #endif
  1790.           }
  1791.           }
  1792.         else if (!TAG_IS(e_current_method, PTR_TAG)
  1793.              || REF_SLOT(e_current_method, 0) != e_method_type)
  1794.           {
  1795.         /* TAG TRAP */
  1796.         if (trace_traps)
  1797.           (void)printf("Bogus or never defined operation.\n");
  1798.         TRAP0(e_nargs+1);
  1799.           }
  1800.  
  1801.         /* else it's a LAMBDA. */
  1802.  
  1803.         x = e_current_method;
  1804.  
  1805.         e_env = REF_TO_PTR(REF_SLOT(x, METHOD_ENV_OFF));
  1806.         e_pc = CODE_SEG_FIRST_INSTR(e_code_segment =
  1807.                     REF_SLOT(x, METHOD_CODE_OFF));
  1808.         break;
  1809.  
  1810.       case (CASE_FOUR*23):    /* STORE-NARGS n */
  1811.         e_nargs = arg_field;
  1812.         break;
  1813.  
  1814.       case (CASE_FOUR*24):    /* CHECK-NARGS n */
  1815.         if (e_nargs != arg_field)
  1816.           {
  1817.         if (trace_traps)
  1818.           (void)printf("\n%d args passed; %d expected.\n",
  1819.                    e_nargs, arg_field);
  1820.         TRAP0(e_nargs+1);
  1821.           }
  1822.         POPVALS(1);
  1823.         break;
  1824.  
  1825.       case (CASE_FOUR*25):    /* CHECK-NARGS-GTE n */
  1826.         if (e_nargs < arg_field)
  1827.           {
  1828.         if (trace_traps)
  1829.           (void)printf("\n%d args passed; %d or more expected.\n", e_nargs, arg_field);
  1830.         TRAP0(e_nargs+1);
  1831.           }
  1832.         POPVALS(1);
  1833.         break;
  1834.  
  1835.       case (CASE_FOUR*26):    /* STORE-SLOT n */
  1836.         POPVAL(x);
  1837.         CHECKTAG1(x,PTR_TAG,2);
  1838.         REF_SLOT(x, arg_field) = PEEKVAL();
  1839.         break;
  1840.  
  1841.           case (CASE_FOUR*27):    /* LOAD-SLOT n */
  1842.         CHECKTAG0(PEEKVAL(),PTR_TAG,1);
  1843.         PEEKVAL() = REF_SLOT(PEEKVAL(), arg_field);
  1844.         break;
  1845.  
  1846.       case (CASE_FOUR*28):    /* MAKE-CLOSED-ENVIRONMENT n */
  1847.         /* This code might be in error if arg_field == 0, which the
  1848.            compiler should never generate. */
  1849.         {
  1850.           register ref *p;
  1851.           register int zarg_field = arg_field;
  1852.           register ref z;
  1853.  
  1854. #ifndef FAST
  1855.           if (zarg_field == 0)
  1856.         {
  1857.           fprintf(stderr, "MAKE-CLOSED-ENVIRONMENT 0.\n");
  1858.           fflush_stderr();
  1859.         }
  1860. #endif
  1861.  
  1862.           ALLOCATE_SS(p, (long)(zarg_field+2),
  1863.               "space crunch in MAKE-CLOSED-ENVIRONMENT");
  1864.  
  1865.           CHECKVAL_POP(zarg_field-1);
  1866.  
  1867.           z = PTR_TO_REF(p);
  1868.  
  1869.           *p++ = e_env_type;
  1870.           *p++ = INT_TO_REF(zarg_field+2);
  1871.  
  1872.           while (zarg_field--)
  1873.         *p++ = POPVAL_NOCHECK();
  1874.  
  1875.           PUSHVAL_NOCHECK(z);
  1876.  
  1877.           break;
  1878.         }
  1879.  
  1880.       case (CASE_FOUR*29):    /* PUSH-CXT rel */
  1881.         PUSH_CONTEXT(signed_arg_field);
  1882.         break;
  1883.  
  1884.       case (CASE_FOUR*30):    /* LOCATE-SLOT n */
  1885.         PEEKVAL()
  1886.           = PTR_TO_LOC( REF_TO_PTR( PEEKVAL() ) + arg_field );
  1887.         break;
  1888.  
  1889.       case (CASE_FOUR*31):    /* STREAM-PRIMITIVE n */
  1890.         switch (arg_field)
  1891.           {
  1892.           case 0:        /* n=0: get standard input stream. */
  1893.         PUSHVAL((ref)stdin);
  1894.         break;
  1895.           case 1:        /* n=1: get standard output stream. */
  1896.         PUSHVAL((ref)stdout);
  1897.         break;
  1898.           case 2:        /* n=2: get standard error output stream. */
  1899.         PUSHVAL((ref)stderr);
  1900.         break;
  1901.           case 3:        /* n=3: fopen, mode READ */
  1902.           case 4:        /* n=4: fopen, mode WRITE */
  1903.           case 5:        /* n=5: fopen, mode APPEND */
  1904.         POPVAL(x);
  1905.         /* How about a CHECKTAG(x,LOC_TAG,) here, eh? */
  1906.         {
  1907.           char *s = oak_c_string((unsigned int)REF_TO_INT(PEEKVAL()),
  1908.                      (unsigned long *)LOC_TO_PTR(x));
  1909.           if (trace_files) (void)printf("About to open '%s'.\n", s);
  1910.           PEEKVAL()
  1911.             = (ref)fopen(s, arg_field == 3 ? READ_MODE :
  1912.                  arg_field == 4 ? WRITE_MODE : APPEND_MODE);
  1913.           free(s);
  1914.         }
  1915.         break;
  1916.  
  1917.           case 6:        /* n=6: fclose */
  1918.         PEEKVAL()
  1919.           = fclose((FILE *)PEEKVAL()) == EOF ? e_nil : e_t;
  1920.         break;
  1921.           case 7:        /* n=7: fflush */
  1922.         PEEKVAL() =
  1923. #ifdef Mac_LSC
  1924.           ((file *)PEEKVAL() == stdout || (file *)PEEKVAL() == stderr)
  1925.             ? e_t :
  1926. #endif
  1927.               fflush((FILE *)PEEKVAL()) == EOF ? e_nil : e_t;
  1928.         break;
  1929.           case 8:        /* n=8: putc */
  1930.         POPVAL(x);
  1931.         y = PEEKVAL();
  1932.         CHECKCHAR1(y,2);
  1933.         PEEKVAL()
  1934.           = putc(REF_TO_CHAR(y), (FILE *)x) == EOF ? e_nil : e_t;
  1935.         break;
  1936.           case 9:        /* n=9: getc */
  1937.         {
  1938.           register int c = getc((FILE *)PEEKVAL());
  1939. #ifdef unix
  1940.           /* When possible, if an EOF is read from an interactive
  1941.              stream, the eof should be cleared so regular stuff
  1942.              can be read thereafter. */
  1943.           if (c == EOF)
  1944.             {
  1945.               if (isatty(fileno((FILE *)PEEKVAL())))
  1946.             {
  1947.               if (trace_files) (void)printf("Clearing EOF.\n");
  1948.               clearerr((FILE *)PEEKVAL());
  1949.             }
  1950.               PEEKVAL() = e_nil;
  1951.             }
  1952.           else
  1953.             PEEKVAL() = CHAR_TO_REF(c);
  1954. #else
  1955.           PEEKVAL() = (c==EOF) ? e_nil : CHAR_TO_REF(c);
  1956. #endif
  1957.         }
  1958.         break;
  1959.           case 10:        /* n=10: check for interactiveness */
  1960. #ifdef unix
  1961.         PEEKVAL() = isatty(fileno((FILE *)PEEKVAL())) ? e_t : e_nil;
  1962. #else
  1963.         PEEKVAL() = PEEKVAL() == (ref)stdin ? e_t : e_nil;
  1964. #endif
  1965.         break;
  1966.           case 11:        /* n=11: tell where we are */
  1967. #ifdef unix_files
  1968.         PEEKVAL() = INT_TO_REF(ftell((FILE *)PEEKVAL()));
  1969. #else
  1970.         PEEKVAL() = e_nil;
  1971. #endif
  1972.         break;
  1973.  
  1974.           case 12:        /* n=12: set where we are */
  1975.         POPVAL(x);
  1976.         {
  1977. #ifdef unix_files
  1978.           FILE *fd = (FILE *)x;
  1979.           long i = REF_TO_INT(PEEKVAL());
  1980.  
  1981.           PEEKVAL() = fseek(fd, i, 0) == 0 ? e_t : e_nil;
  1982. #else
  1983.           PEEKVAL() = e_nil;
  1984. #endif
  1985.         }
  1986.         break;
  1987.  
  1988.           case 13:        /* n=13: change working directory */
  1989.         POPVAL(x);
  1990. #ifdef unix_files
  1991.         {
  1992.           char *s = oak_c_string((unsigned int)REF_TO_INT(PEEKVAL()),
  1993.                      (unsigned long *)LOC_TO_PTR(x));
  1994.           PEEKVAL() = chdir(s) == 0 ? e_t : e_nil;
  1995.           free(s);
  1996.         }
  1997. #else
  1998.         PEEKVAL() = e_nil;
  1999. #endif
  2000.         break;
  2001.  
  2002.           default:
  2003.         (void)printf("\nNonexistent STREAM-PRIMITIVE %d.\n",
  2004.                  arg_field);
  2005.         maybe_dump_world(333);
  2006.         exit(333);
  2007.         break;
  2008.           }
  2009.         break;
  2010.  
  2011.       case (CASE_FOUR*32):    /* FILLTAG n */
  2012.         x =  PEEKVAL();
  2013.         CHECKTAG0(x,PTR_TAG,1);
  2014.         REF_SLOT(x,ESCAPE_OBJECT_VAL_OFF) = INT_TO_REF( val_height()
  2015.                                - arg_field );
  2016.         REF_SLOT(x,ESCAPE_OBJECT_CXT_OFF) = INT_TO_REF( cxt_height() );
  2017.         break;
  2018.  
  2019.       case (CASE_FOUR*33):    /* ^SUPER-CXT, ^SUPER-CXT-BR distance */
  2020.         /* Analogous to FUNCALL-CXT[-BR]. */
  2021.  
  2022.         POLL_SIGNALS();
  2023.         PUSH_CONTEXT(signed_arg_field);
  2024.  
  2025.         /* Fall through to tail recursive case: */
  2026.         goto super_tail;
  2027.  
  2028.       case (CASE_FOUR*34):    /* ^SUPER-TAIL */
  2029.  
  2030.         /* Do not move this below the label! */
  2031.         POLL_SIGNALS();
  2032.  
  2033.       super_tail:
  2034.  
  2035.         /* No cache, no LAMBDA hack, things are easy.
  2036.            Maybe not looking at the lambda hack is a bug?
  2037.  
  2038.            On stack: type, operation, self, args... */
  2039.         {
  2040.           ref the_type;
  2041.           ref y_type;
  2042.           ref meth_type;
  2043.  
  2044.           POPVAL(the_type);
  2045.           CHECKTAG1(the_type,PTR_TAG,e_nargs+2);
  2046.  
  2047.           x = PEEKVAL();    /* The operation. */
  2048.           CHECKTAG1(x,PTR_TAG,e_nargs+2);
  2049.  
  2050.           CHECKVAL_POP(1);
  2051.  
  2052.           y = PEEKVAL_UP(1); /* Self. */
  2053.  
  2054.           y_type = get_type(y);
  2055.  
  2056.           e_current_method = e_nil;
  2057.  
  2058.           find_method_type_pair(x, the_type,
  2059.                     &e_current_method, &meth_type);
  2060.  
  2061.           if (e_current_method == e_nil)
  2062.         {
  2063.           if (trace_traps)
  2064.             (void)printf("No handler for ^super operation.\n");
  2065.           PUSHVAL(the_type);
  2066.           TRAP0(e_nargs+2);
  2067.         }
  2068.  
  2069.           /* This could be dispensed with if meth_type has no
  2070.          ivars and isn't variable-length-mixin. */
  2071.           {
  2072.         ref alist = REF_SLOT(y_type, TYPE_TYPE_BP_ALIST_OFF);
  2073.         ref offset = INT_TO_REF(0);
  2074.  
  2075.         while (alist != e_nil)
  2076.           {
  2077.             if (car(car(alist)) == meth_type)
  2078.               {
  2079.             offset = cdr(car(alist));
  2080.             break;
  2081.               }
  2082.             alist = cdr(alist);
  2083.           }
  2084.         e_bp = REF_TO_PTR(y) + REF_TO_INT(offset);
  2085.           }
  2086.         }
  2087.  
  2088.         x = e_current_method;
  2089.  
  2090.         e_env = REF_TO_PTR(REF_SLOT(x, METHOD_ENV_OFF));
  2091.         e_pc = CODE_SEG_FIRST_INSTR(e_code_segment =
  2092.                     REF_SLOT(x, METHOD_CODE_OFF));
  2093.         break;
  2094.  
  2095. #ifndef FAST
  2096.       default:
  2097.         (void)printf("\nIllegal Bytecode %d.\n", op_field);
  2098.         maybe_dump_world(333);
  2099.         exit(333);
  2100. #endif
  2101.       }
  2102.       }
  2103.  
  2104.     /* The above loop is infinite; we branch down to here when instructions
  2105.        fail, normally from tag traps, and then branch back. */
  2106.  
  2107. #ifdef SIGNALS
  2108.   intr_trap:
  2109.  
  2110.     clear_signal();
  2111.  
  2112.     if (trace_traps)
  2113.       (void)printf("\nINTR: opcode %d, argfield %d.", op_field, arg_field);
  2114.  
  2115.     /* We notify Oaklisp of the user trap by telling it that a noop
  2116.        instruction failed.  The Oaklisp trap code must be careful to
  2117.        return nothing extra on the stack, and to restore NARGS
  2118.        properly.  It is passed the old NARGS. */
  2119.  
  2120.     /* the NOOP instruction. */
  2121.     instr = 0;
  2122.  
  2123.     /* Back off of the current intruction so it will get executed when
  2124.        we get back from the trap code. */
  2125.     e_pc -= 1;
  2126.  
  2127.     /* Pass the trap code the current NARGS. */
  2128.     x = INT_TO_REF(e_nargs);
  2129.     TRAP1(1);
  2130. #endif
  2131.  
  2132.   arg1_tt:
  2133.     CHECKVAL_PUSH(3);
  2134.     PUSHVAL_NOCHECK(x);
  2135.   arg0_tt:
  2136.     if (trace_traps)
  2137.       {
  2138.     (void)printf("\nTag trap: opcode %d, argfield %d.\n",
  2139.              op_field, arg_field);
  2140.     (void)printf("Top of stack: ");
  2141.     printref(x);
  2142.     (void)printf(", pc =  %ld\n",
  2143.              (/*NOSTRICT*/ SPATIC_PTR((ref *)e_pc)
  2144.               ? e_pc - (unsigned short *)spatic.start
  2145.               : e_pc - (unsigned short *)new.start
  2146.                 + 2*spatic.size));
  2147.       }
  2148.  
  2149.     /* Trick: to preserve tail recursiveness, push context only if next
  2150.        instruction isn't a RETURN and current instruction wasn't a FUNCALL.
  2151.        or a CHECK-NARGS[-GTE]. */
  2152.  
  2153.     /* NOTE: It might be worth making sure op_field isn't recomputed
  2154.        many times here if your compiler is stupid. */
  2155.  
  2156.     if (*e_pc != (24<<8) + 0 && op_field != 21 && op_field != 22
  2157.     && op_field != 24 && op_field != 25) 
  2158.       PUSH_CONTEXT(0);
  2159.  
  2160.     /* Trapping instructions stash their argument counts here: */
  2161.     e_nargs = trap_nargs;
  2162.  
  2163.     if (op_field == 0)
  2164.       {
  2165.     /* argless instruction. */
  2166.     PUSHVAL_NOCHECK(*(e_argless_tag_trap_table + arg_field));
  2167.       }
  2168.     else
  2169.       {
  2170.     /* arg'ed instruction, so push arg field as extra argument */
  2171.  
  2172.     PUSHVAL_NOCHECK(INT_TO_REF(arg_field));
  2173.     e_nargs += 1;
  2174.  
  2175.     PUSHVAL_NOCHECK(*(e_arged_tag_trap_table + op_field));
  2176.       }
  2177.  
  2178.     if (trace_traps)
  2179.       {
  2180.     (void)printf("Dispatching to ");
  2181.     printref(PEEKVAL());
  2182.     (void)printf(" with NARGS = %d.\n", e_nargs);
  2183.       }
  2184.  
  2185.     /* Set the instruction dispatch register in case the FUNCALL fails. */
  2186.  
  2187.     instr = (22<<2);
  2188.  
  2189.     goto funcall_tail;
  2190.   }
  2191. }
  2192.