home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1996 February / PCWK0296.iso / sharewar / dos / program / gs300sr1 / gs300sr1.exe / INTERP.C < prev    next >
C/C++ Source or Header  |  1994-07-27  |  41KB  |  1,303 lines
  1. /* Copyright (C) 1989, 1992, 1993, 1994 Aladdin Enterprises.  All rights reserved.
  2.   
  3.   This file is part of Aladdin Ghostscript.
  4.   
  5.   Aladdin Ghostscript is distributed with NO WARRANTY OF ANY KIND.  No author
  6.   or distributor accepts any responsibility for the consequences of using it,
  7.   or for whether it serves any particular purpose or works at all, unless he
  8.   or she says so in writing.  Refer to the Aladdin Ghostscript Free Public
  9.   License (the "License") for full details.
  10.   
  11.   Every copy of Aladdin Ghostscript must include a copy of the License,
  12.   normally in a plain ASCII text file named PUBLIC.  The License grants you
  13.   the right to copy, modify and redistribute Aladdin Ghostscript, but only
  14.   under certain conditions described in the License.  Among other things, the
  15.   License requires that the copyright notice and this notice be preserved on
  16.   all copies.
  17. */
  18.  
  19. /* interp.c */
  20. /* Ghostscript language interpreter */
  21. #include "memory_.h"
  22. #include "ghost.h"
  23. #include "gsstruct.h"            /* for iastruct.h */
  24. #include "stream.h"
  25. #include "errors.h"
  26. #include "estack.h"
  27. #include "ialloc.h"
  28. #include "iastruct.h"
  29. #include "iname.h"
  30. #include "interp.h"
  31. #include "ipacked.h"
  32. #include "ostack.h"        /* must precede iscan.h */
  33. #include "strimpl.h"        /* for sfilter.h */
  34. #include "sfilter.h"        /* for iscan.h */
  35. #include "iscan.h"
  36. #include "idict.h"
  37. #include "isave.h"
  38. #include "istack.h"
  39. #include "iutil.h"            /* for array_get */
  40. #include "dstack.h"
  41. #include "files.h"        /* for file_check_read */
  42. #include "oper.h"
  43. #include "store.h"
  44.  
  45. #define DEBUG_STACKS 0
  46.  
  47. /* Imported operator procedures */
  48. extern int zop_add(P1(os_ptr));
  49. extern int zop_def(P1(os_ptr));
  50. extern int zop_sub(P1(os_ptr));
  51. /* Other imported procedures */
  52. extern int in_stopped(P0());
  53. extern int ztokenexec_continue(P1(os_ptr));
  54.  
  55. /* 
  56.  * The procedure to call if an operator requests rescheduling.
  57.  * This causes an error unless the context machinery has been installed.
  58.  */
  59. private int
  60. no_reschedule(void)
  61. {    return_error(e_invalidcontext);
  62. }
  63. int (*gs_interp_reschedule_proc)(P0()) = no_reschedule;
  64. /*
  65.  * The procedure to call for time-slicing.
  66.  * This is a no-op unless the context machinery has been installed.
  67.  */
  68. int
  69. no_time_slice_proc(void)
  70. {    return 0;
  71. }
  72. int (*gs_interp_time_slice_proc)(P0()) = no_time_slice_proc;
  73. /*
  74.  * The number of interpreter "ticks" between calls on the time_slice_proc.
  75.  * Currently, the clock ticks before each operator, and at each
  76.  * procedure return.
  77.  */
  78. int gs_interp_time_slice_ticks = 0x7fff;
  79.  
  80. /* Forward references */
  81. private int estack_underflow(P1(os_ptr));
  82. private int interp(P2(ref *pref, ref *perror_object));
  83. private int interp_exit(P1(os_ptr));
  84. private int copy_stack(P2(const ref_stack *, ref *));
  85.  
  86. /* Stack sizes */
  87.  
  88. /*
  89.  * The minimum value of block_ostack is the larger of:
  90.  *    - the maximum number of parameters to an operator
  91.  *    (currently setcolorscreen, with 12 parameters);
  92.  *    - the maximum number of values pushed by an operator
  93.  *    (currently setcolortransfer, which calls zcolor_remap_one 4 times
  94.  *    and therefore pushes 16 values).
  95.  */
  96. #define max_ostack 800
  97. #define min_block_ostack 16
  98.  
  99. /*
  100.  * The minimum value of block_estack is the largest size of a contiguous
  101.  * block surrounding an e_stack mark, currently ???.  At least, that's
  102.  * what the minimum value would be if we supported multi-block estacks,
  103.  * which we currently don't.
  104.  */
  105. #define max_estack 150
  106. #define min_block_estack max_estack
  107.  
  108. /*
  109.  * The minimum value of block_dstack is the number of permanent entries
  110.  * on the dictionary stack, currently 3.
  111.  */
  112. #define max_dstack 20
  113. #define min_block_dstack 3
  114. uint min_dstack_size;        /* set by iinit.c */
  115.  
  116. #if DEBUG_STACKS
  117. #  define block_ostack min_block_ostack
  118. #  define block_estack min_block_estack
  119. #  define block_dstack min_block_dstack
  120. #else
  121. #  define block_ostack max_ostack
  122. #  define block_estack max_estack
  123. #  define block_dstack max_dstack
  124. #endif
  125.  
  126. /* Interpreter state variables */
  127. ref ref_systemdict;        /* set by iinit.c */
  128. ref ref_language_level;        /* 1 or 2, set by iinit.c */
  129.  
  130. /* See estack.h for a description of the execution stack. */
  131.  
  132. /* The logic for managing icount and iref below assumes that */
  133. /* there are no control operators which pop and then push */
  134. /* information on the execution stack. */
  135.  
  136. /* Stacks */
  137. /*
  138.  * We must create the stacks as legitimate 'objects' for the memory
  139.  * manager, so that the garbage collector can work with them.
  140.  */
  141. #define os_guard_under 10
  142. #define os_guard_over 10
  143. #define os_refs_size (stack_block_refs + os_guard_under + block_ostack + os_guard_over)
  144. ref_stack o_stack;
  145. #define es_guard_under 1
  146. #define es_guard_over 10
  147. #define es_refs_size (stack_block_refs + es_guard_under + block_estack + es_guard_over)
  148. ref_stack e_stack;
  149. #define ds_refs_size (stack_block_refs + block_dstack)
  150. ref_stack d_stack;
  151.  
  152. /* Allocate the top blocks statically iff we are dealing with */
  153. /* a segmented architecture where this is important. */
  154. typedef struct stack_bodies_s {
  155.     ref os_refs[os_refs_size];
  156.     ref es_refs[es_refs_size];
  157.     ref ds_refs[ds_refs_size];
  158. } stack_bodies_t;
  159. #if stacks_are_segmented
  160. private struct stk_ {
  161.     chunk_head_t head;
  162.     obj_header_t prefix;
  163.     stack_bodies_t bodies;
  164.     ref padding;        /* for GC */
  165. } static_stacks;
  166. #endif
  167. extern_st(st_ref_stack);
  168. ref ref_static_stacks;        /* exported for GC */
  169. ref ref_ref_stacks[3];        /* exported for GC */
  170.  
  171. /* Stack pointers */
  172. ref *esfile;                /* cache pointer to currentfile */
  173. /* Cached dstack values are in idict.c. */
  174.  
  175. /* Extended types.  The interpreter may replace the type of operators */
  176. /* in procedures with these, to speed up the interpretation loop. */
  177. #define tx_op t_next_index
  178. extern int zadd(P1(os_ptr));
  179. extern int zdef(P1(os_ptr));
  180. extern int zdup(P1(os_ptr));
  181. extern int zexch(P1(os_ptr));
  182. extern int zif(P1(os_ptr));
  183. extern int zifelse(P1(os_ptr));
  184. extern int zindex(P1(os_ptr));
  185. extern int zpop(P1(os_ptr));
  186. extern int zroll(P1(os_ptr));
  187. extern int zsub(P1(os_ptr));
  188. private const op_proc_p special_ops[] = {
  189.     zadd, zdef, zdup, zexch, zif, zifelse, zindex, zpop, zroll, zsub
  190. };
  191. typedef enum {
  192.     tx_op_add = tx_op,
  193.     tx_op_def,
  194.     tx_op_dup,
  195.     tx_op_exch,
  196.     tx_op_if,
  197.     tx_op_ifelse,
  198.     tx_op_index,
  199.     tx_op_pop,
  200.     tx_op_roll,
  201.     tx_op_sub,
  202.     tx_next_op
  203. } special_op_types;
  204. #define num_special_ops ((int)tx_next_op - tx_op)
  205. const int tx_next_index = tx_next_op;
  206.  
  207. /* A null procedure. */
  208. #define make_null_proc(pref)\
  209.   make_array(pref, a_executable + a_readonly, 0, NULL)
  210. static ref null_proc;
  211.  
  212. /* Initialize the interpreter */
  213. void
  214. gs_interp_init(void)
  215. {    /* Initialize the stacks. */
  216.     gs_ref_memory_t *smem = iimemory_system;
  217.     ref stk;
  218.     ref euop;
  219.  
  220. #if stacks_are_segmented
  221. #  define bods (&static_stacks.bodies)
  222.     make_array(&ref_static_stacks, 0,
  223.            sizeof(stack_bodies_t) / sizeof(ref),
  224.            (ref *)bods);
  225. #else
  226.     ref sdata;
  227.     make_array(&ref_static_stacks, 0, 0, NULL);
  228.     gs_alloc_ref_array(smem, &sdata, 0,
  229.                sizeof(stack_bodies_t) / sizeof(ref),
  230.                "interp_init");
  231. #  define bods ((stack_bodies_t *)sdata.value.refs)
  232. #endif
  233. #define alloc_init_stack(stk, i, refs)\
  234.   make_array(&stk, 0, countof(bods->refs), bods->refs),\
  235.   make_struct(&ref_ref_stacks[i], 0,\
  236.           gs_alloc_struct((gs_memory_t *)smem, ref_stack, &st_ref_stack, "alloc_init_stack"))
  237.  
  238.     alloc_init_stack(stk, 0, os_refs);
  239.     ref_stack_init(&o_stack, &stk, os_guard_under, os_guard_over, NULL,
  240.                smem);
  241.     o_stack.underflow_error = e_stackunderflow;
  242.     o_stack.overflow_error = e_stackoverflow;
  243.     ref_stack_set_max_count(&o_stack, max_ostack);
  244.  
  245.     alloc_init_stack(stk, 1, es_refs);
  246.     make_oper(&euop, 0, estack_underflow);
  247.     ref_stack_init(&e_stack, &stk, es_guard_under, es_guard_over, &euop,
  248.                smem);
  249.     e_stack.underflow_error = e_ExecStackUnderflow;
  250.     e_stack.overflow_error = e_execstackoverflow;
  251.     esfile_clear_cache();
  252.     ref_stack_set_max_count(&e_stack, max_estack);
  253.  
  254.     alloc_init_stack(stk, 2, ds_refs);
  255.     ref_stack_init(&d_stack, &stk, 0, 0, NULL, smem);
  256.     d_stack.underflow_error = e_dictstackunderflow;
  257.     d_stack.overflow_error = e_dictstackoverflow;
  258.     ref_stack_set_max_count(&d_stack, max_dstack);
  259. }
  260. void
  261. gs_interp_reset(void)
  262. {    /* Reset the stacks. */
  263.     ref_stack_clear(&o_stack);
  264.     ref_stack_clear(&e_stack);
  265.     esp++;
  266.     make_oper(esp, 0, interp_exit);
  267.     ref_stack_pop(&d_stack, ref_stack_count(&d_stack) - min_dstack_size);
  268.     dict_set_top();
  269. }
  270. /* Report an e-stack block underflow.  The bottom guard slots of */
  271. /* e-stack blocks contain a pointer to this procedure. */
  272. private int
  273. estack_underflow(os_ptr op)
  274. {    return e_ExecStackUnderflow;
  275. }
  276.  
  277. /* Look up an operator during initialization, */
  278. /* changing its type if appropriate. */
  279. void
  280. gs_interp_fix_op(ref *opref)
  281. {    register int i = num_special_ops;
  282.     op_proc_p proc = real_opproc(opref);
  283.     while ( --i >= 0 && proc != special_ops[i] ) ;
  284.     if ( i >= 0 )
  285.       make_tasv(opref, tx_op + i, a_executable, r_size(opref), opproc,
  286.             proc);
  287. }
  288.  
  289. /*
  290.  * Invoke the interpreter.  If execution completes normally, return 0.
  291.  * If an error occurs, the action depends on user_errors as follows:
  292.  *    user_errors < 0: always return an error code.
  293.  *    user_errors >= 0: let the PostScript machinery handle all errors.
  294.  *    (This will eventually result in a fatal error if no 'stopped'
  295.  *    is active.)
  296.  * In case of a quit or a fatal error, also store the exit code.
  297.  */
  298. private int gs_call_interp(P4(ref *, int, int *, ref *));
  299. int
  300. gs_interpret(ref *pref, int user_errors, int *pexit_code, ref *perror_object)
  301. {    gs_gc_root_t error_root;
  302.     int code;
  303.     gs_register_ref_root(imemory_global, &error_root,
  304.                  (void **)&perror_object, "gs_interpret");
  305.     /* Initialize the error object in case of GC. */
  306.     make_null(perror_object);
  307.     code = gs_call_interp(pref, user_errors, pexit_code, perror_object);
  308.     gs_unregister_root(imemory_global, &error_root, "gs_interpret");
  309.     return code;
  310. }
  311. private int
  312. gs_call_interp(ref *pref, int user_errors, int *pexit_code, ref *perror_object)
  313. {    ref *epref = pref;
  314.     ref doref;
  315.     ref *perrordict;
  316.     ref error_name;
  317.     int code, ccode;
  318.     ref saref;
  319.     *pexit_code = 0;
  320.     ialloc_reset_requested(idmemory);
  321. again:    o_stack.requested = e_stack.requested = d_stack.requested = 0;
  322.     code = interp(epref, perror_object);
  323.     if ( esp < esbot )            /* popped guard entry */
  324.         esp = esbot;
  325.     switch ( code )
  326.     {
  327.     case e_Fatal:
  328.         *pexit_code = 255;
  329.         return code;
  330.     case e_Quit:
  331.         *perror_object = osp[-1];
  332.         *pexit_code = code = osp->value.intval;
  333.         osp -= 2;
  334.         if ( code == 0 )
  335.           return e_Quit;
  336.         else if ( code > 0 )
  337.           return e_Fatal;
  338.         else
  339.           return code;
  340.     case e_InterpreterExit:
  341.         return 0;
  342.     case e_ExecStackUnderflow:
  343.         /****** WRONG -- must keep mark blocks intact ******/
  344.         ref_stack_pop_block(&e_stack);
  345.         doref = *perror_object;
  346.         epref = &doref;
  347.         goto again;
  348.     case e_VMreclaim:
  349.         /* Do the GC and continue. */
  350.         code = (*idmemory->reclaim)(idmemory,
  351.                         (osp->value.intval == 2 ? 1 : 0));
  352.         /****** What if code < 0? ******/
  353.         make_oper(&doref, 0, zpop);
  354.         epref = &doref;
  355.         goto again;
  356.     }
  357.     /* Adjust osp in case of operand stack underflow */
  358.     if ( osp < osbot - 1 )
  359.         osp = osbot - 1;
  360.     /* We have to handle stack over/underflow specially, because */
  361.     /* we might be able to recover by adding or removing a block. */
  362.     switch ( code )
  363.       {
  364.     case e_dictstackoverflow:
  365.         if ( ref_stack_extend(&d_stack, d_stack.requested) >= 0 )
  366.           {    dict_set_top();
  367.             doref = *perror_object;
  368.             epref = &doref;
  369.             goto again;
  370.           }
  371.         if ( osp >= ostop )
  372.           {    if ( (ccode = ref_stack_extend(&o_stack, 1)) < 0 )
  373.               return ccode;
  374.           }
  375.         ccode = copy_stack(&d_stack, &saref);
  376.         if ( ccode < 0 ) return ccode;
  377.         ref_stack_pop(&d_stack,
  378.                   ref_stack_count(&d_stack) - min_dstack_size);
  379.         dict_set_top();
  380.         *++osp = saref;
  381.         break;
  382.     case e_dictstackunderflow:
  383.         if ( ref_stack_pop_block(&d_stack) >= 0 )
  384.           {    dict_set_top();
  385.             doref = *perror_object;
  386.             epref = &doref;
  387.             goto again;
  388.           }
  389.         break;
  390.     case e_execstackoverflow:
  391.         /* We don't have to handle this specially: */
  392.         /* The only places that could generate it */
  393.         /* use check_estack, which does a ref_stack_extend, */
  394.         /* so if we get this error, it's a real one. */
  395.         if ( osp >= ostop )
  396.           {    if ( (ccode = ref_stack_extend(&o_stack, 1)) < 0 )
  397.               return ccode;
  398.           }
  399.         ccode = copy_stack(&e_stack, &saref);
  400.         if ( ccode < 0 ) return ccode;
  401.         if ( esp > esbot + (max_estack - 1) )
  402.             pop_estack(esp - (esbot + (max_estack - 1)));
  403.         *++osp = saref;
  404.         break;
  405.     case e_stackoverflow:
  406.         if ( ref_stack_extend(&o_stack, o_stack.requested) >= 0 )
  407.           {    /* We can't just re-execute the object, because */
  408.             /* it might be a procedure being pushed as a */
  409.             /* literal.  We check for this case specially. */
  410.             doref = *perror_object;
  411.             if ( r_is_proc(&doref) )
  412.               {    *++osp = doref;
  413.                 make_null_proc(&doref);
  414.               }
  415.             epref = &doref;
  416.             goto again;
  417.           }
  418.         ccode = copy_stack(&o_stack, &saref);
  419.         if ( ccode < 0 ) return ccode;
  420.         ref_stack_clear(&o_stack);
  421.         *++osp = saref;
  422.         break;
  423.     case e_stackunderflow:
  424.         if ( ref_stack_pop_block(&o_stack) >= 0 )
  425.           {    doref = *perror_object;
  426.             epref = &doref;
  427.             goto again;
  428.           }
  429.         break;
  430.       }
  431.     if ( user_errors < 0 )
  432.         return code;
  433.     if ( (code = gs_errorname(code, &error_name)) < 0 )
  434.         return code;        /* something is very wrong! */
  435.     if ( dict_find_string(systemdict, "errordict", &perrordict) <= 0 ||
  436.          dict_find(perrordict, &error_name, &epref) <= 0
  437.        )
  438.         return_error(e_undefined); /* error name not in errordict??? */
  439.     doref = *epref;
  440.     epref = &doref;
  441.     /* Push the error object on the operand stack if appropriate. */
  442.     if ( !error_is_interrupt(code) )
  443.         *++osp = *perror_object;
  444.     goto again;
  445. }    
  446. private int
  447. interp_exit(os_ptr op)
  448. {    return e_InterpreterExit;
  449. }
  450.  
  451. /* Copy the contents of an overflowed stack into a (local) array. */
  452. private int
  453. copy_stack(const ref_stack *pstack, ref *arr)
  454. {    uint size = ref_stack_count(pstack);
  455.     bool save_local = ialloc_is_local(idmemory);
  456.     int code;
  457.     ialloc_set_local(idmemory, true);
  458.     code = ialloc_ref_array(arr, a_all, size, "copy_stack");
  459.     if ( code >= 0 )
  460.       code = ref_stack_store(pstack, arr, size, 0, 1, true, "copy_stack");
  461.     ialloc_set_local(idmemory, save_local);
  462.     return code;
  463. }
  464.  
  465. /* Get the name corresponding to an error number. */
  466. int
  467. gs_errorname(int code, ref *perror_name)
  468. {    ref *perrordict, *pErrorNames;
  469.     if ( dict_find_string(systemdict, "errordict", &perrordict) <= 0 ||
  470.          dict_find_string(systemdict, "ErrorNames", &pErrorNames) <= 0
  471.        )
  472.       return_error(e_undefined); /* errordict or ErrorNames not found?! */
  473.     return array_get(pErrorNames, (long)(-code - 1), perror_name);
  474. }
  475.  
  476. /* Store an error string in $error.errorinfo. */
  477. /* This routine is here because of the proximity to the error handler. */
  478. int
  479. gs_errorinfo_put_string(const char *str)
  480. {    ref rstr;
  481.     ref *pderror;
  482.     int code = string_to_ref(str, &rstr, iimemory, "gs_errorinfo_put_string");
  483.     if ( code < 0 )
  484.         return code;
  485.     if ( dict_find_string(systemdict, "$error", &pderror) <= 0 ||
  486.          !r_has_type(pderror, t_dictionary) ||
  487.          dict_put_string(pderror, "errorinfo", &rstr) < 0
  488.        )
  489.         return_error(e_Fatal);
  490.     return 0;
  491. }
  492.  
  493. /* Main interpreter. */
  494. /* If execution terminates normally, return e_InterpreterExit. */
  495. /* If an error occurs, leave the current object in *perror_object */
  496. /* and return a (negative) error code. */
  497. private int
  498. interp(ref *pref /* object to interpret */, ref *perror_object)
  499. {    register ref *iref = pref;
  500.     register int icount = 0;    /* # of consecutive tokens at iref */
  501.     register os_ptr iosp = osp;    /* private copy of osp */
  502.     register es_ptr iesp = esp;    /* private copy of esp */
  503.     int code;
  504.     ref token;        /* token read from file or string, */
  505.                 /* must be declared in this scope */
  506.     register ref *pvalue;
  507.     os_ptr whichp;
  508.     /*
  509.      * We have to make the error information into a struct;
  510.      * otherwise, the Watcom compiler will assign it to registers
  511.      * strictly on the basis of textual frequency.
  512.      * We also have to use ref_assign_inline everywhere, and
  513.      * avoid direct assignments of refs, so that esi and edi
  514.      * will remain available on Intel processors.
  515.      */
  516.     struct interp_error_s {
  517.         int code;
  518.         int line;
  519.         ref *obj;
  520.         ref full;
  521.     } ierror;
  522. #define set_error(ecode)\
  523.   { ierror.code = ecode; ierror.line = __LINE__; }
  524. #define return_with_error(ecode, objp)\
  525.   { set_error(ecode); ierror.obj = objp; goto rwe; }
  526. #define return_with_code_iref()\
  527.   { ierror.line = __LINE__; goto rweci; }
  528. #define return_with_error_code_op(nargs)\
  529.   { if ( code == e_typecheck && iosp < osbot + (nargs - 1) )\
  530.       code = e_stackunderflow;\
  531.     return_with_code_iref();\
  532.   }
  533. #define return_with_error_short(ecode, objp)\
  534.   { set_error(ecode); ierror.obj = objp; goto rwe_short; }
  535. #define return_with_code_iref_short()\
  536.   { ierror.line = __LINE__; goto rweci_short; }
  537.     int ticks_left = gs_interp_time_slice_ticks;
  538.  
  539.     /*
  540.      * If we exceed the VMThreshold, set ticks_left to -1
  541.      * to alert the interpreter that we need to garbage collect.
  542.      */
  543.     {    gs_memory_gc_status_t stat;
  544.         gs_memory_gc_status(iimemory_local, &stat);
  545.         stat.psignal = &ticks_left;
  546.         stat.signal_value = -100;
  547.         gs_memory_set_gc_status(iimemory_local, &stat);
  548.         gs_memory_gc_status(iimemory_global, &stat);
  549.         stat.psignal = &ticks_left;
  550.         stat.signal_value = -100;
  551.         gs_memory_set_gc_status(iimemory_global, &stat);
  552.     }
  553.  
  554.     esfile_clear_cache();
  555.     /*
  556.      * From here on, if icount > 0, iref and icount correspond
  557.      * to the top entry on the execution stack: icount is the count
  558.      * of sequential entries remaining AFTER the current one.
  559.      */
  560. #define add1_short(pref) (ref *)((ushort *)(pref) + 1)
  561. #define store_state(ep)\
  562.   ( icount > 0 ? (ep->value.refs = iref + 1, r_set_size(ep, icount)) : 0 )
  563. #define store_state_short(ep)\
  564.   ( icount > 0 ? (ep->value.refs = add1_short(iref), r_set_size(ep, icount)) : 0 )
  565. #define next()\
  566.   if ( --icount > 0 ) { iref++; goto top; } else goto out
  567. #define next_short()\
  568.   if ( --icount <= 0 ) { if ( icount < 0 ) goto up; iesp--; }\
  569.   iref = add1_short(iref); goto top;
  570.     /* We want to recognize executable arrays here, */
  571.     /* so we push the argument on the estack and enter */
  572.     /* the loop at the bottom. */
  573.     if ( iesp >= estop ) return_with_error (e_execstackoverflow, pref);
  574.     ++iesp;
  575.     ref_assign_inline(iesp, pref);
  576.     goto bot;
  577. top:    /*
  578.      * This is the top of the interpreter loop.
  579.      * iref points to the ref being interpreted.
  580.      * Note that this might be an element of a packed array,
  581.      * not a real ref: we carefully arranged the first 16 bits of
  582.      * a ref and of a packed array element so they could be distinguished
  583.      * from each other.  (See ghost.h and packed.h for more detail.)
  584.      */
  585. #ifdef DEBUG
  586. if ( gs_debug['I'] ||
  587.      (gs_debug['i'] &&
  588.       (r_is_packed(iref) ?
  589.        r_packed_is_name((ref_packed *)iref) :
  590.        r_has_type(iref, t_name)))
  591.    )
  592.    {    void debug_print_ref(P1(ref *));
  593.     os_ptr save_osp = osp;        /* avoid side-effects */
  594.     es_ptr save_esp = esp;
  595.     int edepth;
  596.     char depth[10];
  597.     osp = iosp;
  598.     esp = iesp;
  599.     edepth = ref_stack_count(&e_stack);
  600.     sprintf(depth, "%2d", edepth);
  601.     dputs(depth);
  602.     edepth -= strlen(depth);
  603.     do { dputc('.'); } while ( --edepth > 0 );    /* indent */
  604.     dprintf3("0x%lx(%d)<%d>: ",
  605.          (ulong)iref, icount, ref_stack_count(&o_stack));
  606.     debug_print_ref(iref);
  607.     if ( iosp >= osbot )
  608.        {    dputs(" // ");
  609.         debug_print_ref(iosp);
  610.        }
  611.     dputc('\n');
  612.     osp = save_osp;
  613.     esp = save_esp;
  614.     fflush(dstderr);
  615.    }
  616. #endif
  617. /* Object that have attributes (arrays, dictionaries, files, and strings) */
  618. /* use lit and exec; other objects use plain and plain_exec. */
  619. #define lit(t) type_xe_value(t, a_execute)
  620. #define exec(t) type_xe_value(t, a_execute + a_executable)
  621. #define nox(t) type_xe_value(t, 0)
  622. #define nox_exec(t) type_xe_value(t, a_executable)
  623. #define plain(t) type_xe_value(t, 0)
  624. #define plain_exec(t) type_xe_value(t, a_executable)
  625.     /*
  626.      * We have to populate enough cases of the switch statement to force
  627.      * some compilers to use a dispatch rather than a testing loop.
  628.      * What a nuisance!
  629.      */
  630.     switch ( r_type_xe(iref) )
  631.        {
  632.     /* Access errors. */
  633. #define cases_invalid()\
  634.   case plain(t__invalid): case plain_exec(t__invalid)
  635.     cases_invalid():
  636.         return_with_error (e_Fatal, iref);
  637. #define cases_nox()\
  638.   case nox_exec(t_array): case nox_exec(t_dictionary):\
  639.   case nox_exec(t_file): case nox_exec(t_string):\
  640.   case nox_exec(t_mixedarray): case nox_exec(t_shortarray)
  641.     cases_nox():
  642.         return_with_error (e_invalidaccess, iref);
  643.     /*
  644.      * Literal objects.  We have to enumerate all the types.
  645.      * In fact, we have to include some extra plain_exec entries
  646.      * just to populate the switch.  We break them up into groups
  647.      * to avoid overflowing some preprocessors.
  648.      */
  649. #define cases_lit_1()\
  650.   case lit(t_array): case nox(t_array):\
  651.   case plain(t_boolean): case plain_exec(t_boolean):\
  652.   case lit(t_dictionary): case nox(t_dictionary)
  653. #define cases_lit_2()\
  654.   case lit(t_file): case nox(t_file):\
  655.   case plain(t_fontID): case plain_exec(t_fontID):\
  656.   case plain(t_integer): case plain_exec(t_integer):\
  657.   case plain(t_mark): case plain_exec(t_mark)
  658. #define cases_lit_3()\
  659.   case plain(t_name):\
  660.   case plain(t_null):\
  661.   case plain(t_oparray):\
  662.   case plain(t_operator)
  663. #define cases_lit_4()\
  664.   case plain(t_real): case plain_exec(t_real):\
  665.   case plain(t_save): case plain_exec(t_save):\
  666.   case lit(t_string): case nox(t_string)
  667. #define cases_lit_5()\
  668.   case lit(t_mixedarray): case nox(t_mixedarray):\
  669.   case lit(t_shortarray): case nox(t_shortarray):\
  670.   case plain(t_device): case plain_exec(t_device):\
  671.   case plain(t_struct): case plain_exec(t_struct):\
  672.   case plain(t_astruct): case plain_exec(t_astruct)
  673.     /* Executable arrays are treated as literals in direct execution. */
  674. #define cases_lit_array()\
  675.   case exec(t_array): case exec(t_mixedarray): case exec(t_shortarray)
  676.     cases_lit_1():
  677.     cases_lit_2():
  678.     cases_lit_3():
  679.     cases_lit_4():
  680.     cases_lit_5():
  681.     cases_lit_array():
  682.         break;
  683.     /* Special operators. */
  684.     case plain_exec(tx_op_add):
  685. x_add:        if ( (code = zop_add(iosp)) < 0 )
  686.             return_with_error_code_op(2);
  687.         iosp--;
  688.         next();
  689.     case plain_exec(tx_op_def):
  690. x_def:        if ( (code = zop_def(iosp)) < 0 )
  691.             return_with_error_code_op(2);
  692.         iosp -= 2;
  693.         next();
  694.     case plain_exec(tx_op_dup):
  695. x_dup:        if ( iosp < osbot )
  696.             return_with_error (e_stackunderflow, iref);
  697.         iosp++;
  698.         ref_assign_inline(iosp, iosp - 1);
  699.         next();
  700.     case plain_exec(tx_op_exch):
  701. x_exch:        if ( iosp <= osbot )
  702.             return_with_error (e_stackunderflow, iref);
  703.         ref_assign_inline(&token, iosp);
  704.         ref_assign_inline(iosp, iosp - 1);
  705.         ref_assign_inline(iosp - 1, &token);
  706.         next();
  707.     case plain_exec(tx_op_if):
  708. x_if:        if ( !r_has_type(iosp - 1, t_boolean) )
  709.             return_with_error ((iosp < osbot + 1 ?
  710.                 e_stackunderflow : e_typecheck), iref);
  711.         if ( !iosp[-1].value.boolval )
  712.           { iosp -= 2;
  713.             next();
  714.           }
  715.         if ( iesp >= estop )
  716.           return_with_error (e_execstackoverflow, iref);
  717.         store_state(iesp);
  718.         whichp = iosp;
  719.         iosp -= 2;
  720.         goto ifup;
  721.     case plain_exec(tx_op_ifelse):
  722. x_ifelse:    if ( !r_has_type(iosp - 2, t_boolean) )
  723.             return_with_error ((iosp < osbot + 2 ?
  724.                 e_stackunderflow : e_typecheck), iref);
  725.         if ( iesp >= estop )
  726.             return_with_error (e_execstackoverflow, iref);
  727.         store_state(iesp);
  728.         whichp = (iosp[-2].value.boolval ? iosp - 1 : iosp);
  729.         iosp -= 3;
  730.         /* Open code "up" for the array case(s) */
  731. ifup:        if ( !r_is_proc(whichp) )
  732.            {    /* This is an unusual enough case that we go ahead */
  733.             /* and clear the currentfile cache without */
  734.             /* checking whether we have an exec(t_file), */
  735.             /* just to avoid another case test. */
  736.             esfile_clear_cache();
  737.             ref_assign_inline(iesp + 1, whichp);
  738.             iref = iesp + 1;
  739.             icount = 0;
  740.             goto top;
  741.            }
  742.         if ( (icount = r_size(whichp) - 1) <= 0 )
  743.            {    if ( icount < 0 ) goto up;    /* 0-element proc */
  744.             iref = whichp->value.refs;    /* 1-element proc */
  745.             if ( --ticks_left > 0 )
  746.                 goto top;
  747.            }
  748.         ++iesp;
  749.         /* Do a ref_assign, but also set iref. */
  750.         iesp->tas = whichp->tas;
  751.         iref = iesp->value.refs = whichp->value.refs;
  752.         if ( --ticks_left > 0 )
  753.             goto top;
  754.         goto slice;
  755.     case plain_exec(tx_op_index):
  756. x_index:    osp = iosp;    /* zindex references o_stack */
  757.         if ( (code = zindex(iosp)) < 0 )
  758.             return_with_error_code_op(1);
  759.         next();
  760.     case plain_exec(tx_op_pop):
  761. x_pop:        if ( iosp < osbot )
  762.             return_with_error (e_stackunderflow, iref);
  763.         iosp--;
  764.         next();
  765.     case plain_exec(tx_op_roll):
  766. x_roll:        osp = iosp;    /* zroll references o_stack */
  767.         if ( (code = zroll(iosp)) < 0 )
  768.             return_with_error_code_op(2);
  769.         iosp -= 2;
  770.         next();
  771.     case plain_exec(tx_op_sub):
  772. x_sub:        if ( (code = zop_sub(iosp)) < 0 )
  773.             return_with_error_code_op(2);
  774.         iosp--;
  775.         next();
  776.     /* Executable types. */
  777.     case plain_exec(t_null):
  778.         goto bot;
  779.     case plain_exec(t_oparray):
  780.         /* Replace with the definition and go again. */
  781.         pvalue =
  782.           &op_array_table.value.refs[op_index(iref) - op_def_count];
  783. prst:        /* Prepare to call the procedure (array) in *pvalue. */
  784.         store_state(iesp);
  785. pr:        /* Call the array in *pvalue.  State has been stored. */
  786.         if ( (icount = r_size(pvalue) - 1) <= 0 )
  787.            {    if ( icount < 0 ) goto up;    /* 0-element proc */
  788.             iref = pvalue->value.refs;    /* 1-element proc */
  789.             if ( --ticks_left > 0 )
  790.                 goto top;
  791.            }
  792.         if ( iesp >= estop )
  793.             return_with_error (e_execstackoverflow, pvalue);
  794.         ++iesp;
  795.         /* Do a ref_assign, but also set iref. */
  796.         iesp->tas = pvalue->tas;
  797.         iref = iesp->value.refs = pvalue->value.refs;
  798.         if ( --ticks_left > 0 )
  799.             goto top;
  800.         goto slice;
  801.     case plain_exec(t_operator):
  802.         if ( --ticks_left <= 0 )
  803.           {    /* The following doesn't work, */
  804.             /* and I can't figure out why. */
  805.             /****** goto sst; ******/
  806.           }
  807.         esp = iesp;        /* save for operator */
  808.         osp = iosp;        /* ditto */
  809.         /* Operator routines take osp as an argument. */
  810.         /* This is just a convenience, since they adjust */
  811.         /* osp themselves to reflect the results. */
  812.         /* Operators that (net) push information on the */
  813.         /* operand stack must check for overflow: */
  814.         /* this normally happens automatically through */
  815.         /* the push macro (in oper.h). */
  816.         /* Operators that do not typecheck their operands, */
  817.         /* or take a variable number of arguments, */
  818.         /* must check explicitly for stack underflow. */
  819.         /* (See oper.h for more detail.) */
  820.         /* Note that each case must set iosp = osp: */
  821.         /* this is so we can switch on code without having to */
  822.         /* store it and reload it (for dumb compilers). */
  823.         switch ( code = (*real_opproc(iref))(iosp) )
  824.            {
  825.         case 0:            /* normal case */
  826.         case 1:            /* alternative success case */
  827.             iosp = osp;
  828.             next();
  829.         case o_push_estack:    /* store the state and go to up */
  830.             store_state(iesp);
  831. opush:            iosp = osp;
  832.             iesp = esp;
  833.             if ( --ticks_left > 0 )
  834.                 goto up;
  835.             goto slice;
  836.         case o_pop_estack:    /* just go to up */
  837. opop:            iosp = osp;
  838.             if ( esp == iesp ) goto bot;
  839.             iesp = esp;
  840.             goto up;
  841.         case o_reschedule:
  842.             store_state(iesp);
  843.             goto res;
  844.         case e_InsertProc:
  845.             store_state(iesp);
  846. oeinsert:        ref_assign_inline(iesp + 1, iref);
  847.             /* esp = iesp + 2; *esp = the procedure */
  848.             iesp = esp;
  849.             goto up;
  850.         case e_typecheck:
  851.             /* This might be an operand stack */
  852.             /* underflow: check the required # of */
  853.             /* operands now. */
  854.             if ( osp < osbot - 1 + op_num_args(iref) )
  855.                 code = e_stackunderflow;
  856.             /* (falls through) */
  857.            }
  858.         iosp = osp;
  859.         iesp = esp;
  860.         return_with_code_iref();
  861.     case plain_exec(t_name):
  862.         pvalue = iref->value.pname->pvalue;
  863.         if ( !pv_valid(pvalue) )
  864.         {    uint nidx = name_index(iref);
  865.             uint htemp;
  866.             if ( (pvalue = dict_find_name_by_index_inline(nidx, htemp)) == 0 )
  867.                 return_with_error (e_undefined, iref);
  868.         }
  869.         /* Dispatch on the type of the value. */
  870.         /* Again, we have to over-populate the switch. */
  871.         switch ( r_type_xe(pvalue) )
  872.            {
  873.         cases_invalid():
  874.             return_with_error (e_Fatal, iref);
  875.         cases_nox():    /* access errors */
  876.             return_with_error (e_invalidaccess, iref);
  877.         cases_lit_1():
  878.         cases_lit_2():
  879.         cases_lit_3():
  880.         cases_lit_4():
  881.         cases_lit_5():
  882.             /* Just push the value */
  883.             if ( iosp >= ostop )
  884.                 return_with_error (e_stackoverflow, pvalue);
  885.             ++iosp;
  886.             ref_assign_inline(iosp, pvalue);
  887.             next();
  888.         case exec(t_array):
  889.         case exec(t_mixedarray):
  890.         case exec(t_shortarray):
  891.             /* This is an executable procedure, execute it. */
  892.             goto prst;
  893.         case plain_exec(tx_op_add): goto x_add;
  894.         case plain_exec(tx_op_def): goto x_def;
  895.         case plain_exec(tx_op_dup): goto x_dup;
  896.         case plain_exec(tx_op_exch): goto x_exch;
  897.         case plain_exec(tx_op_if): goto x_if;
  898.         case plain_exec(tx_op_ifelse): goto x_ifelse;
  899.         case plain_exec(tx_op_index): goto x_index;
  900.         case plain_exec(tx_op_pop): goto x_pop;
  901.         case plain_exec(tx_op_roll): goto x_roll;
  902.         case plain_exec(tx_op_sub): goto x_sub;
  903.         case plain_exec(t_null):
  904.             goto bot;
  905.         case plain_exec(t_oparray):
  906.             pvalue =
  907.               &op_array_table.value.refs[op_index(pvalue) -
  908.                              op_def_count];
  909.             goto prst;
  910.         case plain_exec(t_operator):
  911.            {    /* Shortcut for operators. */
  912.             /* See above for the logic. */
  913.             if ( --ticks_left <= 0 )
  914.               {    /* The following doesn't work, */
  915.                 /* and I can't figure out why. */
  916.                 /****** goto sst; ******/
  917.               }
  918.             esp = iesp;
  919.             osp = iosp;
  920.             switch ( code = (*real_opproc(pvalue))(iosp) )
  921.                {
  922.             case 0:            /* normal case */
  923.             case 1:            /* alternative success case */
  924.                 iosp = osp;
  925.                 next();
  926.             case o_push_estack:
  927.                 store_state(iesp);
  928.                 goto opush;
  929.             case o_pop_estack:
  930.                 goto opop;
  931.             case o_reschedule:
  932.                 store_state(iesp);
  933.                 goto res;
  934.             case e_InsertProc:
  935.                 store_state(iesp);
  936.                 goto oeinsert;
  937.             case e_typecheck:
  938.                 if ( osp < osbot - 1 + op_num_args(pvalue) )
  939.                     code = e_stackunderflow;
  940.                }
  941.             iosp = osp;
  942.             iesp = esp;
  943.             return_with_error (code, pvalue);
  944.            }
  945.         case plain_exec(t_name):
  946.         case exec(t_file):
  947.         case exec(t_string):
  948.         default:
  949.             /* Not a procedure, reinterpret it. */
  950.             store_state(iesp);
  951.             icount = 0;
  952.             iref = pvalue;
  953.             goto top;
  954.            }
  955.     case exec(t_file):
  956.        {    /* Executable file.  Read the next token and interpret it. */
  957.            stream *s;
  958.         scanner_state sstate;
  959.         code = file_check_read(iref, &s);
  960.         if ( code < 0 ) return_with_code_iref();
  961. rt:        if ( iosp >= ostop )    /* check early */
  962.           return_with_error (e_stackoverflow, iref);
  963.         osp = iosp;        /* scan_token uses ostack */
  964.         scanner_state_init(&sstate, false);
  965. again:        code = scan_token(s, &token, &sstate);
  966.         iosp = osp;        /* ditto */
  967.         switch ( code )
  968.            {
  969.         case 0:            /* read a token */
  970.             /* It's worth checking for literals, which make up */
  971.             /* the majority of input tokens, before storing the */
  972.             /* state on the e-stack.  Note that because of //, */
  973.             /* the token may have *any* type and attributes. */
  974.             /* Note also that executable arrays aren't executed */
  975.             /* at the top level -- they're treated as literals. */
  976.             if ( !r_has_attr(&token, a_executable) ||
  977.                  r_is_array(&token)
  978.                )
  979.               {    /* If scan_token used the o-stack, */
  980.                 /* we know we can do a push now; if not, */
  981.                 /* the pre-check is still valid. */
  982.                 iosp++;
  983.                 ref_assign_inline(iosp, &token);
  984.                 goto rt;
  985.               }
  986.             store_state(iesp);
  987.             /* Push the file on the e-stack */
  988.             if ( iesp >= estop )
  989.                 return_with_error (e_execstackoverflow, iref);
  990.             esfile_set_cache(++iesp);
  991.             ref_assign_inline(iesp, iref);
  992.             iref = &token;
  993.             icount = 0;
  994.             goto top;
  995.         case scan_EOF:        /* end of file */
  996.             esfile_clear_cache();
  997.             goto bot;
  998.         case scan_BOS:
  999.             /* Binary object sequences */
  1000.             /* ARE executed at the top level. */
  1001.             store_state(iesp);
  1002.             /* Push the file on the e-stack */
  1003.             if ( iesp >= estop )
  1004.                 return_with_error (e_execstackoverflow, iref);
  1005.             esfile_set_cache(++iesp);
  1006.             ref_assign_inline(iesp, iref);
  1007.             pvalue = &token;
  1008.             goto pr;
  1009.         case scan_Refill:
  1010.             store_state(iesp);
  1011.             /* iref may point into the exec stack; */
  1012.             /* save its referent now. */
  1013.             ref_assign_inline(&token, iref);
  1014.             /* Push the file on the e-stack */
  1015.             if ( iesp >= estop )
  1016.                 return_with_error (e_execstackoverflow, iref);
  1017.             ++iesp;
  1018.             ref_assign_inline(iesp, &token);
  1019.             esp = iesp;
  1020.             osp = iosp;
  1021.             code = scan_handle_refill(s, &token, &sstate, true,
  1022.                           ztokenexec_continue);
  1023.             iosp = osp;
  1024.             iesp = esp;
  1025.             switch ( code )
  1026.               {
  1027.               case 0:
  1028.                 iesp--;        /* don't push the file */
  1029.                 goto again;    /* stacks are unchanged */
  1030.               case o_push_estack:
  1031.                 /* See above for why it is safe to push */
  1032.                 /* the file onto the o-stack */
  1033.                 /* (for ztokenexec_continue). */
  1034.                 esfile_clear_cache();
  1035.                 iosp++;
  1036.                 ref_assign_inline(iosp, &token);
  1037.                 if ( --ticks_left > 0 )
  1038.                     goto up;
  1039.                 goto slice;
  1040.               }
  1041.             /* must be an error */
  1042.             iesp--;        /* don't push the file */
  1043.         default:        /* error */
  1044.             return_with_code_iref();
  1045.            }
  1046.        }
  1047.     case exec(t_string):
  1048.        {    /* Executable string.  Read a token and interpret it. */
  1049.         stream ss;
  1050.         scanner_state sstate;
  1051.         scanner_state_init(&sstate, true);
  1052.         sread_string(&ss, iref->value.bytes, r_size(iref));
  1053.         osp = iosp;        /* scan_token uses ostack */
  1054.         code = scan_token(&ss, &token, &sstate);
  1055.         iosp = osp;        /* ditto */
  1056.         switch ( code )
  1057.           {
  1058.         case 0:            /* read a token */
  1059.         case scan_BOS:        /* binary object sequence */
  1060.             store_state(iesp);
  1061.             /* Push the updated string back on the e-stack */
  1062.             if ( iesp >= estop )
  1063.               return_with_error (e_execstackoverflow, iref);
  1064.             ++iesp;
  1065.             iesp->tas.type_attrs = iref->tas.type_attrs;
  1066.             iesp->value.const_bytes = sbufptr(&ss);
  1067.             r_set_size(iesp, sbufavailable(&ss));
  1068.             if ( code == 0 )
  1069.             {    iref = &token;
  1070.             icount = 0;
  1071.             goto top;
  1072.             }
  1073.             /* Handle BOS specially */
  1074.             pvalue = &token;
  1075.             goto pr;
  1076.         case scan_EOF:        /* end of string */
  1077.             goto bot;
  1078.         case scan_Refill:    /* error */
  1079.             code = gs_note_error(e_syntaxerror);
  1080.         default:        /* error */
  1081.             return_with_code_iref();
  1082.           }
  1083.        }
  1084.     /* Handle packed arrays here by re-dispatching. */
  1085.     /* This also picks up some anomalous cases of non-packed arrays. */
  1086.     default:
  1087.     {    uint nidx;
  1088.         switch ( *(ushort *)iref >> packed_type_shift )
  1089.            {
  1090.         case pt_full_ref:
  1091.         case pt_full_ref+1:
  1092.             if ( iosp >= ostop )
  1093.               return_with_error(e_stackoverflow, iref);
  1094.             ++iosp;
  1095.             /* We know that refs are properly aligned: */
  1096.             /* see packed.h for details. */
  1097.             ref_assign_inline(iosp, iref);
  1098.             next();
  1099.         case pt_executable_operator:
  1100.         {    uint index = *(ushort *)iref & packed_value_mask;
  1101.             op_index_ref(index, &token);
  1102.             if ( --ticks_left <= 0 )
  1103.               {    /* The following doesn't work, */
  1104.                 /* and I can't figure out why. */
  1105.                 /****** goto sst_short; ******/
  1106.               }
  1107.             if ( r_has_type(&token, t_oparray) )
  1108.             {    store_state_short(iesp);
  1109.                 icount = 0;
  1110.                 iref = &token;
  1111.                 goto top;
  1112.             }
  1113.             /* See the main plain_exec(t_operator) case */
  1114.             /* for details of what happens here. */
  1115.             esp = iesp;
  1116.             osp = iosp;
  1117.             switch ( code = (*real_opproc(&token))(iosp) )
  1118.                {
  1119.             case 0:
  1120.             case 1:
  1121.                 iosp = osp;
  1122.                 next_short();
  1123.             case o_push_estack:
  1124.                 store_state_short(iesp);
  1125.                 goto opush;
  1126.             case o_pop_estack:
  1127.                 iosp = osp;
  1128.                 if ( esp == iesp )
  1129.                    {    next_short();
  1130.                    }
  1131.                 iesp = esp;
  1132.                 goto up;
  1133.             case o_reschedule:
  1134.                 store_state_short(iesp);
  1135.                 goto res;
  1136.             case e_InsertProc:
  1137.                 store_state_short(iesp);
  1138.                 ref_assign_inline(iesp + 1, &token);
  1139.                 /* esp = iesp + 2; *esp = the procedure */
  1140.                 iesp = esp;
  1141.                 goto up;
  1142.             case e_typecheck:
  1143.                 if ( osp < osbot - 1 + op_num_args(&token) )
  1144.                     code = e_stackunderflow;
  1145.                 /* (falls through) */
  1146.                }
  1147.            }
  1148.             iosp = osp;
  1149.             iesp = esp;
  1150.             return_with_code_iref_short();
  1151.         case pt_integer:
  1152.             if ( iosp >= ostop )
  1153.               return_with_error_short(e_stackoverflow, iref);
  1154.             ++iosp;
  1155.             make_int(iosp, (*(short *)iref & packed_int_mask) +
  1156.                     packed_min_intval);
  1157.             next_short();
  1158.         case pt_literal_name:
  1159.             nidx = *(ushort *)iref & packed_value_mask;
  1160.             if ( iosp >= ostop )
  1161.               return_with_error_short(e_stackoverflow, iref);
  1162.             ++iosp;
  1163.             name_index_ref(nidx, iosp);
  1164.             next_short();
  1165.         case pt_executable_name:
  1166.             nidx = (uint)*(ushort *)iref & packed_value_mask;
  1167.             name_index_ref(nidx, &token);
  1168.             pvalue = token.value.pname->pvalue;
  1169.             if ( !pv_valid(pvalue) )
  1170.                {    uint htemp;
  1171.                 if ( (pvalue = dict_find_name_by_index_inline(nidx, htemp)) == 0 )
  1172.                   return_with_error_short(e_undefined, &token);
  1173.                }
  1174.             if ( r_is_proc(pvalue) )
  1175.                {    /* This is an executable procedure, */
  1176.                 /* execute it. */
  1177.                 store_state_short(iesp);
  1178.                 goto pr;
  1179.                }
  1180.             /* Not a procedure, reinterpret it. */
  1181.             store_state_short(iesp);
  1182.             icount = 0;
  1183.             iref = pvalue;
  1184.             goto top;
  1185.         /* default can't happen here */
  1186.         }
  1187.     }
  1188.     }
  1189.     /* Literal type, just push it. */
  1190.     if ( iosp >= ostop ) return_with_error (e_stackoverflow, iref);
  1191.     ++iosp;
  1192.     ref_assign_inline(iosp, iref);
  1193. bot:    next();
  1194. out:    /* At most 1 more token in the current procedure. */
  1195.     /* (We already decremented icount.) */
  1196.     if ( !icount )
  1197.        {    /* Pop the execution stack for tail recursion. */
  1198.         iesp--;
  1199.         iref++;
  1200.         goto top;
  1201.        }
  1202. up:    if ( --ticks_left < 0 )
  1203.         goto slice;
  1204.     /* See if there is anything left on the execution stack. */
  1205.     if ( !r_is_proc(iesp) )
  1206.        {    iref = iesp--;
  1207.         icount = 0;
  1208.         goto top;
  1209.        }
  1210.     iref = iesp->value.refs;        /* next element of array */
  1211.     icount = r_size(iesp) - 1;
  1212.     if ( icount <= 0 )        /* <= 1 more elements */
  1213.        {    iesp--;            /* pop, or tail recursion */
  1214.         if ( icount < 0 ) goto up;
  1215.        }
  1216.     goto top;
  1217. res:    /* Some operator has asked for context rescheduling. */
  1218.     /* We've done a store_state. */
  1219.     code = (*gs_interp_reschedule_proc)();
  1220. sched:    /* We've just called a scheduling procedure. */
  1221.     /* The interpreter state is in memory; iref is not current. */
  1222.     if ( code < 0 )
  1223.     {    set_error(code);
  1224.         make_null_proc(&null_proc);
  1225.         ierror.obj = iref = &null_proc;
  1226.         goto error_exit;
  1227.     }
  1228.     /* Reload state information from memory. */
  1229.     iosp = osp;
  1230.     iesp = esp;
  1231.     goto up;
  1232. #if 0            /****** ****** ******/
  1233. sst:    /* Time-slice, but push the current object first. */
  1234.     store_state(iesp);
  1235.     if ( iesp >= estop )
  1236.         return_with_error (e_execstackoverflow, iref);
  1237.     iesp++;
  1238.     ref_assign_inline(iesp, iref);
  1239. #endif            /****** ****** ******/
  1240. slice:    /* It's time to time-slice or garbage collect. */
  1241.     /* iref is not live, so we don't need to do a store_state. */
  1242.     osp = iosp;
  1243.     esp = iesp;
  1244.     /* If ticks_left <= -100, we need to GC now. */
  1245.     if ( ticks_left <= -100 )
  1246.       {    /* We need to garbage collect now. */
  1247.         code = (*idmemory->reclaim)(idmemory, -1);
  1248.       }
  1249.     else
  1250.         code = (*gs_interp_time_slice_proc)();
  1251.     ticks_left = gs_interp_time_slice_ticks;
  1252.     goto sched;
  1253.  
  1254.     /* Error exits. */
  1255.  
  1256. rweci:
  1257.     ierror.code = code;
  1258.     ierror.obj = iref;
  1259. rwe:
  1260.     store_state(iesp);
  1261.     goto error_exit;
  1262. rweci_short:
  1263.     ierror.code = code;
  1264.     ierror.obj = iref;
  1265. rwe_short:
  1266.     /* We need a real object to return as the error object. */
  1267.     /* (It only has to last long enough to store in *perror_object.) */
  1268.     make_tasv(&ierror.full, t_shortarray, a_readonly, 1, packed,
  1269.           (const ref_packed *)ierror.obj);
  1270.     array_get(&ierror.full, 0L, &ierror.full);
  1271.     store_state_short(iesp);
  1272.     if ( iref == ierror.obj )
  1273.         iref = &ierror.full;
  1274.     ierror.obj = &ierror.full;
  1275. error_exit:
  1276.     if ( error_is_interrupt(ierror.code) )
  1277.     {    /* We must push the current object being interpreted */
  1278.         /* back on the e-stack so it will be re-executed. */
  1279.         /* Currently, this is always an executable operator, */
  1280.         /* but it might be something else someday if we check */
  1281.         /* for interrupts in the interpreter loop itself. */
  1282.         if ( iesp >= estop )
  1283.             code = e_execstackoverflow;
  1284.         else
  1285.         {    iesp++;
  1286.             ref_assign_inline(iesp, iref);
  1287.         }
  1288.     }
  1289.     esp = iesp;
  1290.     osp = iosp;
  1291.     ref_assign_inline(perror_object, ierror.obj);
  1292.     return gs_log_error(ierror.code, __FILE__, ierror.line);
  1293.  
  1294. }
  1295.  
  1296. /* ------ Initialization procedure ------ */
  1297.  
  1298. op_def interp_op_defs[] = {
  1299.         /* Internal operators */
  1300.     {"0%interp_exit", interp_exit},
  1301.     op_def_end(0)
  1302. };
  1303.