home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / cmpint.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  123KB  |  4,143 lines
  1. /* -*-C-*-
  2.  
  3. $Id: cmpint.c,v 1.92 2000/12/05 21:23:43 cph Exp $
  4.  
  5. Copyright (c) 1989-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /*
  23.  *
  24.  * Compiled code interface.  Portable version.
  25.  * This file requires a bit of assembly language from cmpaux-md.m4
  26.  * See also the files cmpint.txt, cmpgc.h, and cmpint-md.h .
  27.  *
  28.  */
  29.  
  30. /*
  31.  * Procedures in this file belong to the following categories:
  32.  *
  33.  * Local C procedures.  These are local procedures called only by
  34.  * other procedures in this file, and have been separated only for
  35.  * modularity reasons.  They are tagged with the C keyword `static'.
  36.  * They can return any C type.
  37.  *
  38.  * C utility procedures.  These procedures are called from C
  39.  * primitives and other subsystems and never leave the C world.  They
  40.  * constitute the compiled code data abstraction as far as other C
  41.  * parts of the Scheme "microcode" are concerned.  They are tagged
  42.  * with the noise word `C_UTILITY'.  They can return any C type.
  43.  *
  44.  * C interface entries.  These procedures are called from the
  45.  * interpreter (written in C) and ultimately enter the Scheme compiled
  46.  * code world by using the assembly language utility
  47.  * `C_to_interface'.  They are tagged with the noise word
  48.  * `C_TO_SCHEME'.  They MUST return a C long indicating what
  49.  * the interpreter should do next.
  50.  *
  51.  * Scheme interface utilities.  These procedures are called from the
  52.  * assembly language interface and return to it, and perform all the
  53.  * tasks that the compiler does not code inline.  They are referenced
  54.  * by compiled scheme code by index, and the assembly language
  55.  * interface fetches them from an array.  They are tagged with the
  56.  * noise word `SCHEME_UTILITY'.  They return a C structure (struct
  57.  * utility_result) which describes whether computation should proceed
  58.  * in the interpreter or in compiled code, and how.
  59.  *
  60.  */
  61.  
  62. /* Macro imports */
  63.  
  64. #include "config.h"
  65. #include <stdio.h>
  66. #ifdef STDC_HEADERS
  67. #  include <stdlib.h>
  68. #endif
  69. #include "dstack.h"    /* Dynamic-stack support */
  70. #include "outf.h"    /* error reporting */
  71. #include "types.h"      /* Needed by const.h */
  72. #include "const.h"      /* REGBLOCK_MINIMUM_LENGTH and PRIM_... codes */
  73. #include "object.h"     /* Making and destructuring Scheme objects */
  74. #include "intrpt.h"    /* Interrupt processing macros */
  75. #include "gc.h"        /* Request_GC, etc. */
  76. #include "sdata.h"    /* ENTITY_OPERATOR */
  77. #include "errors.h"     /* Error codes and Termination codes */
  78. #include "returns.h"    /* Return addresses in the interpreter */
  79. #include "fixobj.h"    /* To find the error handlers */
  80. #include "stack.h"    /* Stacks and stacklets */
  81. #include "interp.h"     /* Interpreter state and primitive destructuring */
  82. #include "default.h"    /* various definitions */
  83. #include "extern.h"    /* External decls (missing Cont_Debug, etc.) */
  84. #include "trap.h"       /* UNASSIGNED_OBJECT, TRAP_EXTENSION_TYPE */
  85. #include "prims.h"      /* LEXPR */
  86. #include "prim.h"    /* Primitive_Procedure_Table, etc. */
  87.  
  88. #define ENTRY_TO_OBJECT(entry)                        \
  89.   (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) (entry))))
  90.  
  91. #define IN_CMPINT_C
  92. #include "cmpgc.h"      /* Compiled code object relocation */
  93.  
  94. #ifdef HAS_COMPILER_SUPPORT
  95.  
  96. /* ASM_ENTRY_POINT, EXFNX, and DEFNX are for OS/2.  The IBM C Set++/2
  97.    compiler has several different external calling conventions.  The
  98.    default calling convention is called _Optlink, uses a combination
  99.    of registers and the stack, and is complicated.  The calling
  100.    convention used for operating system interface procedures is called
  101.    _System, uses only the stack, and is very similar to the calling
  102.    conventions used with our DOS compilers.  So, in order to simplify
  103.    the changes to the assembly language, we use _System conventions
  104.    for calling C procedures from the assembly language file.
  105.  
  106.    Since _Optlink is the default, we must somehow cause the relevant
  107.    procedures to be compiled using _System.  The easiest way to do
  108.    this is to force the use of _System everywhere, but that's
  109.    undesirable since _Optlink is generally more efficient.  Instead,
  110.    we use the ASM_ENTRY_POINT wrapper to cause each of the relevant
  111.    procedures to be tagged with the compiler's _System keyword.  The
  112.    relevant procedures are all of the SCHEME_UTILITY procedures,
  113.    C_to_interface, interface_to_C, and interface_to_scheme.  */
  114.  
  115. #ifndef ASM_ENTRY_POINT
  116. #  define ASM_ENTRY_POINT(name) name
  117. #endif
  118.  
  119. #ifdef STDC_HEADERS
  120. #define EXFNX(name, proto) ASM_ENTRY_POINT (name) proto
  121. #define DEFNX(name, arglist, args) ASM_ENTRY_POINT (name) (args)
  122. #define DEFNX_VOID(name) ASM_ENTRY_POINT (name) (void)
  123. #else
  124. #define EXFNX(name, proto) ASM_ENTRY_POINT (name) ()
  125. #define DEFNX(name, arglist, args) ASM_ENTRY_POINT (name) arglist args;
  126. #define DEFNX_VOID(name) ASM_ENTRY_POINT (name) ()
  127. #endif
  128.  
  129. /* Make noise words invisible to the C compiler. */
  130.  
  131. #define C_UTILITY
  132. #define C_TO_SCHEME
  133. #define SCHEME_UTILITY
  134.  
  135. /* For clarity */
  136.  
  137. typedef char instruction;
  138.  
  139. #ifndef CMPINT_USE_STRUCS
  140.  
  141. typedef instruction * utility_result;
  142.  
  143. /* Imports from assembly language */
  144.  
  145. extern void EXFNX (C_to_interface, (void *));
  146. extern utility_result interface_to_C_hook;
  147.  
  148. extern long C_return_value;
  149. long C_return_value;
  150.  
  151. /* Convenience macros */
  152.  
  153. #define RETURN_TO_C(code) do                        \
  154. {                                    \
  155.   C_return_value = (code);                        \
  156.   return (interface_to_C_hook);                        \
  157. } while (false)
  158.  
  159. #define RETURN_TO_SCHEME(ep)    return ((utility_result) (ep))
  160.  
  161. #define ENTER_SCHEME(ep) do                        \
  162. {                                    \
  163.   C_to_interface ((void *) (ep));                    \
  164.   return (C_return_value);                        \
  165. } while (false)
  166.  
  167. #else /* CMPINT_USE_STRUCS */
  168.  
  169. #ifdef C_FUNC_PTR_IS_CLOSURE
  170. #  define REFENTRY(name) (name)
  171. #  define VARENTRY(name) instruction *name
  172. #  define EXTENTRY(name) extern instruction *name
  173. #else
  174. #  define REFENTRY(name) ((void (*)()) name)
  175. #  define VARENTRY(name) void (*name)()
  176. #  define EXTENTRY(name) extern void EXFNX (name, (void))
  177. #endif
  178.  
  179. /* Structure returned by SCHEME_UTILITYs */
  180.  
  181. struct utility_result_s
  182. {
  183.   VARENTRY (interface_dispatch);
  184.   union additional_info
  185.   {
  186.     long                code_to_interpreter;
  187.     instruction        *entry_point;
  188.   } extra;
  189. };
  190.  
  191. typedef struct utility_result_s utility_result;
  192.  
  193. /* Imports from assembly language */
  194.  
  195. extern long EXFNX (C_to_interface, (void *));
  196.  
  197. EXTENTRY (interface_to_C);
  198. EXTENTRY (interface_to_scheme);
  199.  
  200. /* Convenience macros */
  201.  
  202. #define RETURN_TO_C(code) do                        \
  203. {                                    \
  204.   struct utility_result_s temp;                        \
  205.                                     \
  206.   temp.interface_dispatch = (REFENTRY (interface_to_C));        \
  207.   temp.extra.code_to_interpreter = (code);                \
  208.                                     \
  209.   return (temp);                            \
  210. } while (false)
  211.  
  212. #define RETURN_TO_SCHEME(ep) do                        \
  213. {                                    \
  214.   struct utility_result_s temp;                        \
  215.                                     \
  216.   temp.interface_dispatch = (REFENTRY (interface_to_scheme));        \
  217.   temp.extra.entry_point = ((instruction *) (ep));            \
  218.                                     \
  219.   return (temp);                            \
  220. } while (false)
  221.  
  222. #define ENTER_SCHEME(ep)    return (C_to_interface ((void *) (ep)))
  223.  
  224. #endif /* CMPINT_USE_STRUCS */
  225.  
  226. /* utility table entries. */
  227.  
  228. typedef utility_result EXFUN
  229.   ((*ASM_ENTRY_POINT(utility_table_entry)), (long, long, long, long));
  230.  
  231. #define RETURN_UNLESS_EXCEPTION(code, entry_point)                      \
  232. {                                                                       \
  233.   int return_code;                                                      \
  234.                                                                         \
  235.   return_code = (code);                                                 \
  236.   if (return_code == PRIM_DONE)                                         \
  237.   {                                                                     \
  238.     RETURN_TO_SCHEME (entry_point);                                     \
  239.   }                                                                     \
  240.   else                                                                  \
  241.   {                                                                     \
  242.     RETURN_TO_C (return_code);                                          \
  243.   }                                                                     \
  244. }
  245.  
  246. #define MAKE_CC_BLOCK(block_addr)                    \
  247.   (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr))
  248.  
  249. /* Imports from the rest of the "microcode" */
  250.  
  251. extern long
  252.   EXFUN (compiler_cache_assignment, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
  253.   EXFUN (compiler_cache_lookup, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
  254.   EXFUN (compiler_cache_global_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
  255.   EXFUN (compiler_cache_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long));
  256.  
  257. /* Exports to the rest of the "microcode" */
  258.  
  259. extern long
  260.   compiler_interface_version,
  261.   compiler_processor_type;
  262.  
  263. extern SCHEME_OBJECT
  264.   compiler_utilities,
  265.   return_to_interpreter;
  266.  
  267. extern C_UTILITY long
  268.   EXFUN (make_fake_uuo_link,
  269.      (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
  270.   EXFUN (make_uuo_link,
  271.      (SCHEME_OBJECT value, SCHEME_OBJECT extension,
  272.       SCHEME_OBJECT block, long offset)),
  273.   EXFUN (compiled_block_closure_p, (SCHEME_OBJECT block)),
  274.   EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT entry)),
  275.   EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT entry)),
  276.   EXFUN (coerce_to_compiled,
  277.      (SCHEME_OBJECT object, long arity, SCHEME_OBJECT *location));
  278.  
  279. extern C_UTILITY SCHEME_OBJECT
  280.   EXFUN (extract_uuo_link, (SCHEME_OBJECT block, long offset)),
  281.   EXFUN (extract_variable_cache,
  282.      (SCHEME_OBJECT extension, long offset)),
  283.   EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT block)),
  284.   EXFUN (compiled_block_environment, (SCHEME_OBJECT block)),
  285.   EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)),
  286.   EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)),
  287.   EXFUN (apply_compiled_from_primitive, (int)),
  288.   EXFUN (compiled_with_interrupt_mask, (unsigned long,
  289.                     SCHEME_OBJECT,
  290.                     unsigned long)),
  291.   EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT)),
  292.   * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
  293.  
  294. extern C_UTILITY Boolean
  295.   EXFUN (install_c_code_table, (SCHEME_OBJECT *, long));
  296.  
  297. extern C_UTILITY void
  298.   EXFUN (compiler_initialize, (long fasl_p)),
  299.   EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
  300.   EXFUN (store_variable_cache,
  301.      (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
  302.   EXFUN (declare_compiled_code_block, (SCHEME_OBJECT block));  
  303.  
  304. extern utility_table_entry utility_table[];
  305.  
  306. static SCHEME_OBJECT reflect_to_interface;
  307.  
  308. /* Breakpoint stuff. */
  309.  
  310. extern C_UTILITY SCHEME_OBJECT EXFUN (bkpt_install, (PTR));
  311. extern C_UTILITY SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR));
  312. extern C_UTILITY Boolean EXFUN (bkpt_p, (PTR));
  313. extern C_UTILITY SCHEME_OBJECT EXFUN
  314.   (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT));
  315. extern C_UTILITY void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT));
  316.  
  317. /* These definitions reflect the indices into the table above. */
  318.  
  319. #define TRAMPOLINE_K_RETURN            0x0
  320. #define TRAMPOLINE_K_APPLY            0x1
  321. #define TRAMPOLINE_K_ARITY            0x2
  322. #define TRAMPOLINE_K_ENTITY            0x3
  323. #define TRAMPOLINE_K_INTERPRETED        0x4
  324. #define TRAMPOLINE_K_LEXPR_PRIMITIVE        0x5
  325. #define TRAMPOLINE_K_PRIMITIVE            0x6
  326. #define TRAMPOLINE_K_LOOKUP            0x7
  327. #define TRAMPOLINE_K_1_0            0x8
  328. #define TRAMPOLINE_K_2_1            0x9
  329. #define TRAMPOLINE_K_2_0            0xa
  330. #define TRAMPOLINE_K_3_2            0xb
  331. #define TRAMPOLINE_K_3_1            0xc
  332. #define TRAMPOLINE_K_3_0            0xd
  333. #define TRAMPOLINE_K_4_3            0xe
  334. #define TRAMPOLINE_K_4_2            0xf
  335. #define TRAMPOLINE_K_4_1            0x10
  336. #define TRAMPOLINE_K_4_0            0x11
  337. #define TRAMPOLINE_K_REFLECT_TO_INTERFACE    0x3a
  338.  
  339. #define TRAMPOLINE_K_OTHER            TRAMPOLINE_K_INTERPRETED
  340.  
  341. /* Ways to bypass the interpreter */
  342.  
  343. #define REFLECT_CODE_INTERNAL_APPLY        0
  344. #define REFLECT_CODE_RESTORE_INTERRUPT_MASK    1
  345. #define REFLECT_CODE_STACK_MARKER        2
  346. #define REFLECT_CODE_CC_BKPT            3
  347.  
  348. /* Markers for special entry points */
  349.  
  350. #ifndef FORMAT_BYTE_EXPR
  351. #define FORMAT_BYTE_EXPR                    0xFF
  352. #endif
  353. #ifndef FORMAT_BYTE_COMPLR
  354. #define FORMAT_BYTE_COMPLR                  0xFE
  355. #endif
  356. #ifndef FORMAT_BYTE_CMPINT
  357. #define FORMAT_BYTE_CMPINT                  0xFD
  358. #endif
  359. #ifndef FORMAT_BYTE_DLINK
  360. #define FORMAT_BYTE_DLINK                   0xFC
  361. #endif
  362. #ifndef FORMAT_BYTE_RETURN
  363. #define FORMAT_BYTE_RETURN                  0xFB
  364. #endif
  365. #ifndef FORMAT_BYTE_CLOSURE
  366. #define FORMAT_BYTE_CLOSURE            0xFA
  367. #endif
  368. #ifndef FORMAT_BYTE_FRAMEMAX
  369. #define FORMAT_BYTE_FRAMEMAX                0x7F
  370. #endif
  371.  
  372. #ifndef FORMAT_WORD_EXPR
  373. #define FORMAT_WORD_EXPR        (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_EXPR))
  374. #endif
  375. #ifndef FORMAT_WORD_CMPINT
  376. #define FORMAT_WORD_CMPINT      (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_CMPINT))
  377. #endif
  378. #ifndef FORMAT_WORD_RETURN
  379. #define FORMAT_WORD_RETURN      (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_RETURN))
  380. #endif
  381.  
  382. /* Utilities for application of compiled procedures. */
  383.  
  384. /* NOTE: In this file, the number of arguments (or minimum
  385.    number of arguments, etc.) is always 1 greater than the number of
  386.    arguments (it includes the procedure object).
  387.  */
  388.  
  389. /* open_gap: Default some optional parameters, and return the location
  390.    of the return address (one past the last actual argument location).
  391.  */
  392.  
  393. static SCHEME_OBJECT *
  394. DEFUN (open_gap,
  395.        (nactuals, delta),
  396.        register long nactuals AND register long delta)
  397. {
  398.   register SCHEME_OBJECT *gap_location, *source_location;
  399.  
  400.   /* Need to fill in optionals */
  401.  
  402.   gap_location = STACK_LOC (delta);
  403.   source_location = STACK_LOC (0);
  404.   Stack_Pointer = gap_location;
  405.   while ((--nactuals) > 0)
  406.   {
  407.     STACK_LOCATIVE_POP (gap_location) = STACK_LOCATIVE_POP (source_location);
  408.   }
  409.   delta = (- delta);
  410.   while ((--delta) >= 0)
  411.   {
  412.     STACK_LOCATIVE_POP (gap_location) = UNASSIGNED_OBJECT;
  413.   }
  414.   return (source_location);
  415. }
  416.  
  417. /* setup_lexpr_invocation: Setup a rest argument as appropriate. */
  418.  
  419. static long
  420. DEFUN (setup_lexpr_invocation,
  421.        (nactuals, nmax, entry_address),
  422.        register long nactuals AND register long nmax
  423.        AND instruction * entry_address)
  424. {
  425.   register long delta;
  426.  
  427.   /* nmax is negative! */
  428.  
  429.   delta = (nactuals + nmax);
  430.  
  431.   if (delta < 0)
  432.   {
  433.     /* Not enough arguments have been passed to allocate a list.
  434.        The missing optional arguments must be defaulted, and the
  435.        rest parameter needs to be set to the empty list.
  436.      */
  437.  
  438.     SCHEME_OBJECT *last_loc;
  439.  
  440.     last_loc = open_gap (nactuals, delta);
  441.     (STACK_LOCATIVE_PUSH (last_loc)) = EMPTY_LIST;
  442.     return (PRIM_DONE);
  443.   }
  444.   else if (delta == 0)
  445.   {
  446.     /* The number of arguments passed matches exactly the number of
  447.        formal paramters.  The last argument needs to be replaced by
  448.        a list containing it, but there is no need to pop anything
  449.        since the frame has the right size.
  450.        This does not check for gc!
  451.        The procedure should (and currently will) on entry.
  452.      */
  453.  
  454.     register SCHEME_OBJECT temp, *gap_location, *local_free;
  455.  
  456.     local_free = Free;
  457.     Free += 2;
  458.     gap_location = STACK_LOC (nactuals - 2);
  459.     temp = *gap_location;
  460.     *gap_location = (MAKE_POINTER_OBJECT (TC_LIST, local_free));
  461.     *local_free++ = temp;
  462.     *local_free = EMPTY_LIST;
  463.     return (PRIM_DONE);
  464.   }
  465.   else /* (delta > 0) */
  466.   {
  467.     /* The number of arguments passed is greater than the number of
  468.        formal parameters named by the procedure.  Excess arguments
  469.        need to be placed in a list passed at the last parameter
  470.        location. The extra arguments must then be popped from the stack.
  471.      */
  472.     long list_size;
  473.     register SCHEME_OBJECT *gap_location, *source_location;
  474.  
  475.     /* Allocate the list, and GC if necessary. */
  476.  
  477.     list_size = (2 * (delta + 1));
  478.     if (GC_Check (list_size))
  479.     {
  480.       Request_GC (list_size);
  481.       STACK_PUSH (ENTRY_TO_OBJECT (entry_address));
  482.       STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  483.       return (PRIM_APPLY_INTERRUPT);
  484.     }
  485.     gap_location = &Free[list_size];
  486.     Free = gap_location;
  487.  
  488.     /* Place the arguments in the list, and link it. */
  489.  
  490.     source_location = (STACK_LOC (nactuals - 1));
  491.     (*(--gap_location)) = EMPTY_LIST;
  492.  
  493.     while ((--delta) >= 0)
  494.     {
  495.       gap_location -= 2;
  496.       (*(gap_location + 1)) = (STACK_LOCATIVE_PUSH (source_location));
  497.       (*(gap_location)) = (MAKE_POINTER_OBJECT (TC_LIST, (gap_location + 1)));
  498.     }
  499.  
  500.     (*(--gap_location)) = (STACK_LOCATIVE_PUSH (source_location));
  501.  
  502.     /* Place the list at the appropriate location in the stack. */
  503.  
  504.     STACK_LOCATIVE_REFERENCE (source_location, 0) =
  505.       (MAKE_POINTER_OBJECT (TC_LIST, (gap_location)));
  506.  
  507.     /* Now move the arguments into their correct location in the stack
  508.        popping any unneeded locations.
  509.      */
  510.  
  511.     gap_location = (STACK_LOC (nactuals - 1));
  512.     STACK_LOCATIVE_INCREMENT (source_location);
  513.  
  514.     /* Remember that nmax is originally negative! */
  515.  
  516.     for (nmax = ((-nmax) - 1); ((--nmax) >= 0); )
  517.     {
  518.       (STACK_LOCATIVE_PUSH (gap_location)) =
  519.         (STACK_LOCATIVE_PUSH (source_location));
  520.     }
  521.     Stack_Pointer = gap_location;
  522.     return (PRIM_DONE);
  523.   }
  524. }
  525.  
  526. /* setup_compiled_invocation: Prepare the application frame the way that
  527.    the called procedure expects it (optional arguments and rest argument
  528.    initialized.
  529.  */
  530.  
  531. static long
  532. DEFUN (setup_compiled_invocation,
  533.        (nactuals, compiled_entry_address),
  534.        long nactuals AND instruction * compiled_entry_address)
  535. {
  536.   long nmin, nmax, delta;               /* all +1 */
  537.  
  538.   nmax = (COMPILED_ENTRY_MAXIMUM_ARITY (compiled_entry_address));
  539.   if (nactuals == nmax)
  540.   {
  541.     /* Either the procedure takes exactly the number of arguments
  542.        given, or it has optional arguments, no rest argument, and
  543.        all the optional arguments have been provided.  Thus the
  544.        frame is in the right format and we are done.
  545.      */
  546.     return (PRIM_DONE);
  547.   }
  548.   nmin = (COMPILED_ENTRY_MINIMUM_ARITY (compiled_entry_address));
  549.   if (nmin < 0)
  550.   {
  551.     /* Not a procedure. */
  552.     STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address));
  553.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  554.     return (ERR_INAPPLICABLE_OBJECT);
  555.   }
  556.   if (nactuals < nmin)
  557.   {
  558.     /* Too few arguments. */
  559.     STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address));
  560.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  561.     return (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  562.   }
  563.   delta = (nactuals - nmax);
  564.   if (delta <= 0)
  565.   {
  566.     /* The procedure takes optional arguments but no rest argument
  567.        and not all the optional arguments have been provided.
  568.        They must be defaulted.
  569.      */
  570.     ((void) (open_gap (nactuals, delta)));
  571.     return (PRIM_DONE);
  572.   }
  573.   if (nmax > 0)
  574.   {
  575.     /* Too many arguments */
  576.     STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address));
  577.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  578.     return (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  579.   }
  580.   /* The procedure can take arbitrarily many arguments, ie.
  581.      it is a lexpr.
  582.    */
  583.   return (setup_lexpr_invocation (nactuals, nmax, compiled_entry_address));
  584. }
  585.  
  586. /* Main compiled code entry points.
  587.  
  588.    These are the primary entry points that the interpreter
  589.    uses to execute compiled code.
  590.    The other entry points are special purpose return
  591.    points to compiled code invoked after the interpreter has been
  592.    employed to take corrective action (interrupt, error, etc).
  593.    They are coded adjacent to the place where the interpreter
  594.    is invoked.
  595.  */
  596.  
  597. C_TO_SCHEME long
  598. DEFUN_VOID (enter_compiled_expression)
  599. {
  600.   instruction * compiled_entry_address;
  601.  
  602.   compiled_entry_address =
  603.     ((instruction *) (OBJECT_ADDRESS (Fetch_Expression ())));
  604.   if ((COMPILED_ENTRY_FORMAT_WORD (compiled_entry_address)) !=
  605.       FORMAT_WORD_EXPR)
  606.   {
  607.     /* It self evaluates. */
  608.     Val = (Fetch_Expression ());
  609.     ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
  610.   }
  611.   ENTER_SCHEME (compiled_entry_address);
  612. }
  613.  
  614. C_TO_SCHEME long
  615. DEFUN_VOID (apply_compiled_procedure)
  616. {
  617.   SCHEME_OBJECT nactuals, procedure;
  618.   instruction * procedure_entry;
  619.   long result;
  620.  
  621.   nactuals = (STACK_POP ());
  622.   procedure = (STACK_POP ());
  623.   procedure_entry = ((instruction *) (OBJECT_ADDRESS (procedure)));
  624.   result = setup_compiled_invocation ((OBJECT_DATUM (nactuals)),
  625.                                       procedure_entry);
  626.   if (result == PRIM_DONE)
  627.     /* Go into compiled code. */
  628.     ENTER_SCHEME (procedure_entry);
  629.   else
  630.     return (result);
  631. }
  632.  
  633. /* Note that this does not check that compiled_entry_address
  634.    is a valid return address. -- Should it?
  635.  */
  636.  
  637. C_TO_SCHEME long
  638. DEFUN_VOID (return_to_compiled_code)
  639. {
  640.   instruction *compiled_entry_address;
  641.  
  642.   compiled_entry_address =
  643.     ((instruction *) (OBJECT_ADDRESS (STACK_POP ())));
  644.   ENTER_SCHEME (compiled_entry_address);
  645. }
  646.  
  647. C_UTILITY SCHEME_OBJECT
  648. DEFUN (apply_compiled_from_primitive, (arity), int arity)
  649. {
  650.   SCHEME_OBJECT frame_size, procedure;
  651.   long result;
  652.   
  653.   frame_size = (STACK_POP ());
  654.   procedure = (STACK_POP ());
  655.  
  656.   switch (OBJECT_TYPE (procedure))
  657.   {
  658.     case TC_ENTITY:
  659.     {
  660.       SCHEME_OBJECT data, operator;
  661.       unsigned long nactuals = (OBJECT_DATUM (frame_size));
  662.  
  663.       data = (MEMORY_REF (procedure, ENTITY_DATA));
  664.       if ((VECTOR_P (data))
  665.       && (nactuals < (VECTOR_LENGTH (data)))
  666.       && (COMPILED_CODE_ADDRESS_P (VECTOR_REF (data, nactuals)))
  667.       && ((VECTOR_REF (data, 0))
  668.           == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG))))
  669.     procedure = (VECTOR_REF (data, nactuals));
  670.       else
  671.       {
  672.     operator = (MEMORY_REF (procedure, ENTITY_OPERATOR));
  673.     if (!COMPILED_CODE_ADDRESS_P (operator))
  674.       goto defer_application;
  675.     STACK_PUSH (procedure);
  676.     frame_size += 1;
  677.     procedure = operator;
  678.       }
  679.       /* fall through */
  680.     }
  681.  
  682.     case TC_COMPILED_ENTRY:
  683.     {
  684.       result = setup_compiled_invocation ((OBJECT_DATUM (frame_size)),
  685.                       ((instruction *)
  686.                        (OBJECT_ADDRESS (procedure))));
  687.       if (result == PRIM_DONE)
  688.       {
  689.     STACK_PUSH (procedure);
  690.     Stack_Pointer = (STACK_LOC (- arity));
  691.     return (SHARP_F);
  692.       }
  693.       else
  694.     break;
  695.     }
  696.  
  697.     case TC_PRIMITIVE:
  698.     /* For now, fall through */
  699.  
  700.     default:
  701. defer_application:
  702.       STACK_PUSH (procedure);
  703.       STACK_PUSH (frame_size);
  704.       break;
  705.   }
  706.  
  707.   STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY);
  708.   STACK_PUSH (reflect_to_interface);
  709.   Stack_Pointer = (STACK_LOC (- arity));
  710.   return (SHARP_F);
  711. }
  712.  
  713. C_UTILITY SCHEME_OBJECT
  714. DEFUN (compiled_with_interrupt_mask, (old_mask, receiver, new_mask),
  715.        unsigned long old_mask
  716.        AND SCHEME_OBJECT receiver
  717.        AND unsigned long new_mask)
  718. {
  719.   long result;
  720.  
  721.   STACK_PUSH (LONG_TO_FIXNUM (old_mask));
  722.   STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_RESTORE_INTERRUPT_MASK);
  723.   STACK_PUSH (reflect_to_interface);
  724.  
  725.   STACK_PUSH (LONG_TO_FIXNUM (new_mask));
  726.   result = (setup_compiled_invocation (2,
  727.                        ((instruction *)
  728.                     (OBJECT_ADDRESS (receiver)))));
  729.   STACK_PUSH (receiver);
  730.  
  731.   if (result != PRIM_DONE)
  732.   {
  733.     STACK_PUSH (STACK_FRAME_HEADER + 1);
  734.     STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY);
  735.     STACK_PUSH (reflect_to_interface);
  736.   }
  737.  
  738.   Stack_Pointer = (STACK_LOC (- 2));
  739.   return (SHARP_F);
  740. }
  741.  
  742. C_UTILITY SCHEME_OBJECT
  743. DEFUN (compiled_with_stack_marker, (thunk), SCHEME_OBJECT thunk)
  744. {
  745.   long result;
  746.  
  747.   STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_STACK_MARKER);
  748.   STACK_PUSH (reflect_to_interface);
  749.  
  750.   result = (setup_compiled_invocation (1,
  751.                        ((instruction *)
  752.                     (OBJECT_ADDRESS (thunk)))));
  753.   STACK_PUSH (thunk);
  754.  
  755.   if (result != PRIM_DONE)
  756.   {
  757.     STACK_PUSH (STACK_FRAME_HEADER);
  758.     STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_INTERNAL_APPLY);
  759.     STACK_PUSH (reflect_to_interface);
  760.   }
  761.  
  762.   Stack_Pointer = (STACK_LOC (- 3));
  763.   return (SHARP_F);
  764. }
  765.  
  766. /*
  767.   SCHEME_UTILITYs
  768.  
  769.   Here's a mass of procedures that are called (via scheme_to_interface,
  770.   an assembly language hook) by compiled code to do various jobs.
  771.  */
  772.  
  773. /*
  774.   This is how compiled Scheme code normally returns back to the
  775.   Scheme interpreter.
  776.   It is invoked by a trampoline, which passes the address of the
  777.   trampoline storage block (empty) to it.
  778.  */
  779.  
  780. SCHEME_UTILITY utility_result
  781. DEFNX (comutil_return_to_interpreter,
  782.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  783.        SCHEME_ADDR tramp_data_raw
  784.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  785. {
  786.   RETURN_TO_C (PRIM_DONE);
  787. }
  788.  
  789. #if (COMPILER_PROCESSOR_TYPE != COMPILER_IA32_TYPE)
  790.  
  791. #define INVOKE_RETURN_ADDRESS()                    \
  792.   RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()))
  793.  
  794. #else /* COMPILER_IA32_TYPE */
  795.  
  796. static utility_result
  797.   EXFUN (compiler_interrupt_common, (SCHEME_ADDR, SCHEME_OBJECT));
  798.  
  799. #define INVOKE_RETURN_ADDRESS() do                    \
  800. {                                    \
  801.   if (((long) (ADDR_TO_SCHEME_ADDR (Free)))                \
  802.       >= ((long) (Regs[REGBLOCK_MEMTOP])))                \
  803.     return (compiler_interrupt_common (0, Val));            \
  804.   else                                    \
  805.     RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()));            \
  806. } while (0)
  807.  
  808. #endif /* COMPILER_IA32_TYPE */
  809.  
  810. /*
  811.   comutil_primitive_apply is used to invoked a C primitive.
  812.   Note that some C primitives (the so called interpreter hooks)
  813.   will not return normally, but will "longjmp" to the interpreter
  814.   instead.  Thus the assembly language invoking this should have
  815.   set up the appropriate locations in case this happens.
  816.   After invoking the primitive, it pops the arguments off the
  817.   Scheme stack, and proceeds by invoking the continuation on top
  818.   of the stack.
  819.  */
  820.  
  821. SCHEME_UTILITY utility_result
  822. DEFNX (comutil_primitive_apply,
  823.        (primitive, ignore_2, ignore_3, ignore_4),
  824.        SCHEME_OBJECT primitive
  825.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  826. { 
  827.   PRIMITIVE_APPLY (Val, primitive);
  828.   POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
  829.   INVOKE_RETURN_ADDRESS ();
  830. }
  831.  
  832. /*
  833.   comutil_primitive_lexpr_apply is like comutil_primitive_apply
  834.   except that it is used to invoke primitives that take
  835.   an arbitrary number of arguments.
  836.   The number of arguments is in the REGBLOCK_LEXPR_ACTUALS slot
  837.   of the register block.
  838.  */
  839.  
  840. SCHEME_UTILITY utility_result
  841. DEFNX (comutil_primitive_lexpr_apply,
  842.        (primitive, ignore_2, ignore_3, ignore_4),
  843.        SCHEME_OBJECT primitive
  844.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  845. {
  846.   PRIMITIVE_APPLY (Val, primitive);
  847.   POP_PRIMITIVE_FRAME (((long) Regs[REGBLOCK_LEXPR_ACTUALS]));
  848.   INVOKE_RETURN_ADDRESS ();
  849. }
  850.  
  851. /*
  852.   comutil_apply is used by compiled code to invoke an unknown
  853.   procedure.  It dispatches on its type to the correct place.  It
  854.   expects the procedure to invoke, and the number of arguments (+ 1).
  855.  */
  856.  
  857. SCHEME_UTILITY utility_result
  858. DEFNX (comutil_apply,
  859.        (procedure, nactuals, ignore_3, ignore_4),
  860.        SCHEME_OBJECT procedure
  861.        AND unsigned long nactuals
  862.        AND long ignore_3 AND long ignore_4)
  863. {
  864.   SCHEME_OBJECT orig_proc = procedure;
  865.  
  866. loop:
  867.   switch (OBJECT_TYPE (procedure))
  868.   {
  869.     case TC_COMPILED_ENTRY:
  870.     callee_is_compiled:
  871.     {
  872.       instruction * entry_point;
  873.  
  874.       entry_point = ((instruction *) (OBJECT_ADDRESS (procedure)));
  875.       RETURN_UNLESS_EXCEPTION
  876.         ((setup_compiled_invocation (nactuals, entry_point)),
  877.          entry_point);
  878.     }
  879.  
  880.     case TC_ENTITY:
  881.     {
  882.       SCHEME_OBJECT data, operator;
  883.  
  884.       data = (MEMORY_REF (procedure, ENTITY_DATA));
  885.       if ((VECTOR_P (data))
  886.       && (nactuals < (VECTOR_LENGTH (data)))
  887.       && ((VECTOR_REF (data, nactuals)) != SHARP_F)
  888.       && ((VECTOR_REF (data, 0))
  889.           == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG))))
  890.       {
  891.     /* No loops allowed! */
  892.     SCHEME_OBJECT nproc = (VECTOR_REF (data, nactuals));
  893.  
  894.     if ((procedure == orig_proc) && (nproc != procedure))
  895.     {
  896.       procedure = nproc;
  897.       goto loop;
  898.     }
  899.     else
  900.       procedure = orig_proc;
  901.       }
  902.  
  903.       operator = (MEMORY_REF (procedure, ENTITY_OPERATOR));
  904.       if (!(COMPILED_CODE_ADDRESS_P (operator)))
  905.         goto callee_is_interpreted;
  906.  
  907.       STACK_PUSH (procedure);           /* The entity itself */
  908.       procedure = operator;
  909.       nactuals += 1;
  910.       goto callee_is_compiled;
  911.     }
  912.     case TC_PRIMITIVE:
  913.     {
  914.       /* This code depends on the fact that unimplemented
  915.          primitives map into a "fake" primitive which accepts
  916.          any number of arguments, thus the arity test will
  917.          fail for unimplemented primitives.
  918.        */
  919.  
  920.       long arity;
  921.  
  922.       arity = (PRIMITIVE_ARITY (procedure));
  923.       if (arity == ((long) (nactuals - 1)))
  924.         return (comutil_primitive_apply (procedure, 0, 0, 0));
  925.  
  926.       if (arity != LEXPR)
  927.       {
  928.         /* Wrong number of arguments. */
  929.         STACK_PUSH (procedure);
  930.         STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  931.         RETURN_TO_C (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  932.       }
  933.       if (!(IMPLEMENTED_PRIMITIVE_P (procedure)))
  934.         /* Let the interpreter handle it. */
  935.         goto callee_is_interpreted;
  936.  
  937.       /* "Lexpr" primitive. */
  938.       Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) (nactuals - 1));
  939.       return (comutil_primitive_lexpr_apply (procedure, 0, 0, 0));
  940.     }
  941.  
  942.     callee_is_interpreted:
  943.     default:
  944.     {
  945.       STACK_PUSH (procedure);
  946.       STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  947.       RETURN_TO_C (PRIM_APPLY);
  948.     }
  949.   }
  950. }
  951.  
  952. /*
  953.   comutil_error is used by compiled code to signal an error.  It
  954.   expects the arguments to the error procedure to be pushed on the
  955.   stack, and is passed the number of arguments (+ 1).
  956. */
  957.  
  958. SCHEME_UTILITY utility_result
  959. DEFNX (comutil_error,
  960.        (nactuals, ignore_2, ignore_3, ignore_4),
  961.        long nactuals AND
  962.        long ignore_2 AND long ignore_3 AND long ignore_4)
  963. {
  964.   SCHEME_OBJECT error_procedure;
  965.  
  966.   error_procedure = (Get_Fixed_Obj_Slot (Compiler_Err_Procedure));
  967.   return (comutil_apply (error_procedure, nactuals, 0, 0));
  968. }
  969.  
  970. /*
  971.   comutil_lexpr_apply is invoked to reformat the frame when compiled
  972.   code calls a known lexpr.  The actual arguments are on the stack,
  973.   and it is given the number of arguments (WITHOUT counting the entry
  974.   point being invoked), and the real entry point of the procedure.
  975.  
  976.   Important: This code assumes that it is always invoked with a valid
  977.   number of arguments (the compiler checked it), and will not check.
  978.  */
  979.  
  980. SCHEME_UTILITY utility_result
  981. DEFNX (comutil_lexpr_apply,
  982.        (entry_address_raw, nactuals, ignore_3, ignore_4),
  983.        SCHEME_ADDR entry_address_raw AND long nactuals
  984.        AND long ignore_3 AND long ignore_4)
  985. {
  986.   instruction * entry_address
  987.     = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_address_raw)));
  988.                  
  989.   RETURN_UNLESS_EXCEPTION
  990.     ((setup_lexpr_invocation
  991.       ((nactuals + 1),
  992.        (COMPILED_ENTRY_MAXIMUM_ARITY (entry_address)),
  993.        entry_address)),
  994.      entry_address);
  995. }
  996.  
  997. static long
  998. DEFUN (compiler_link_closure_pattern, (distance, block, offset),
  999.        SCHEME_OBJECT distance AND SCHEME_OBJECT block AND long offset)
  1000. {
  1001.   long objdist = (FIXNUM_TO_LONG (distance));
  1002.   long nmv_length = (OBJECT_DATUM (MEMORY_REF (block, 1)));
  1003.   SCHEME_OBJECT * location = (MEMORY_LOC (block, offset));
  1004.   SCHEME_OBJECT * closptr = (location - objdist);
  1005.   SCHEME_OBJECT * end_closptr = (MEMORY_LOC (block, (2 + nmv_length)));
  1006.   SCHEME_OBJECT entry_offset, * area_end;
  1007.   char * word_ptr;
  1008.   long count;
  1009.  
  1010.   nmv_length -= (end_closptr - closptr);
  1011.   while (closptr < end_closptr)
  1012.   {
  1013.     while ((* closptr) == ((SCHEME_OBJECT) 0))
  1014.       closptr ++;
  1015.     closptr ++;
  1016.     count = (MANIFEST_CLOSURE_COUNT (closptr));
  1017.     word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (closptr));
  1018.     area_end = (MANIFEST_CLOSURE_END (closptr, count));
  1019.     while ((--count) >= 0)
  1020.     {
  1021.       closptr = ((SCHEME_OBJECT *) word_ptr);
  1022.       word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
  1023.       EXTRACT_CLOSURE_ENTRY_ADDRESS (entry_offset, closptr);
  1024.       entry_offset = ((SCHEME_OBJECT)
  1025.               (((long) closptr) - ((long) entry_offset)));
  1026.       STORE_CLOSURE_ENTRY_ADDRESS (entry_offset, closptr);
  1027.     }
  1028.     closptr = &area_end[1];
  1029.   }
  1030.  
  1031.   MEMORY_SET (block, 1, (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, nmv_length)));
  1032.   return (PRIM_DONE);
  1033. }
  1034.  
  1035. static Boolean linking_cc_block_p = false;
  1036.  
  1037. static void
  1038. DEFUN (abort_link_cc_block, (ap), PTR ap)
  1039. {
  1040.   linking_cc_block_p = (* ((Boolean *) (ap)));
  1041.   return;
  1042. }
  1043.  
  1044. /* Core of comutil_link and comp_link_caches_restart. */
  1045.  
  1046. static long
  1047. DEFUN (link_cc_block,
  1048.        (block_address, offset, last_header_offset,
  1049.     sections, original_count, ret_add),
  1050.        register SCHEME_OBJECT * block_address AND
  1051.        register long offset AND
  1052.        long last_header_offset AND
  1053.        long sections AND
  1054.        long original_count AND
  1055.        instruction * ret_add)
  1056. {
  1057.   Boolean execute_p = false;
  1058.   register long entry_size, count;
  1059.   SCHEME_OBJECT block;
  1060.   SCHEME_OBJECT header;
  1061.   long result, kind, total_count;
  1062.   long EXFUN ((* cache_handler), (SCHEME_OBJECT, SCHEME_OBJECT, long));
  1063.  
  1064.   transaction_begin ();
  1065.   {
  1066.     Boolean * ap = (dstack_alloc (sizeof (Boolean)));
  1067.     *ap = linking_cc_block_p;
  1068.     transaction_record_action (tat_abort, abort_link_cc_block, ap);
  1069.   }
  1070.   linking_cc_block_p = true;
  1071.  
  1072.   result = PRIM_DONE;
  1073.   block = (MAKE_CC_BLOCK (block_address));
  1074.  
  1075.   while ((--sections) >= 0)
  1076.   {
  1077.     SCHEME_OBJECT * scan = &(block_address[last_header_offset]);
  1078.     header = (*scan);
  1079.  
  1080.     kind = (READ_LINKAGE_KIND (header));
  1081.     switch (kind)
  1082.     {
  1083.       case OPERATOR_LINKAGE_KIND:
  1084.     cache_handler = compiler_cache_operator;
  1085.  
  1086.       handle_operator:
  1087.         execute_p = true;
  1088.     entry_size = EXECUTE_CACHE_ENTRY_SIZE;
  1089.     START_OPERATOR_RELOCATION (scan);
  1090.     count = (READ_OPERATOR_LINKAGE_COUNT (header));
  1091.     break;
  1092.  
  1093.       case GLOBAL_OPERATOR_LINKAGE_KIND:
  1094.     cache_handler = compiler_cache_global_operator;
  1095.     goto handle_operator;
  1096.  
  1097.       case ASSIGNMENT_LINKAGE_KIND:
  1098.     cache_handler = compiler_cache_assignment;
  1099.     goto handle_reference;
  1100.  
  1101.       case REFERENCE_LINKAGE_KIND:
  1102.     cache_handler = compiler_cache_lookup;
  1103.       handle_reference:
  1104.     execute_p = false;
  1105.     entry_size = 1;
  1106.     count = (READ_CACHE_LINKAGE_COUNT (header));
  1107.     break;
  1108.  
  1109.       case CLOSURE_PATTERN_LINKAGE_KIND:
  1110.     cache_handler = compiler_link_closure_pattern;
  1111.     /* Not really a reference, but the same format. */
  1112.     goto handle_reference;
  1113.  
  1114.       default:
  1115.     offset += 1;
  1116.     total_count = (READ_CACHE_LINKAGE_COUNT (header));
  1117.     count = (total_count - 1);
  1118.     result = ERR_COMPILED_CODE_ERROR;
  1119.     goto back_out;
  1120.     }
  1121.  
  1122.     /* This accomodates the re-entry case after a GC.
  1123.        It undoes the effects of the "smash header" code below.
  1124.      */
  1125.  
  1126.     if ((OBJECT_TYPE (header)) == TC_LINKAGE_SECTION)
  1127.     {
  1128.       count = (original_count - count);
  1129.       total_count = original_count;
  1130.     }
  1131.     else
  1132.     {
  1133.       total_count = count;
  1134.       if (execute_p)
  1135.     offset += (FIRST_OPERATOR_LINKAGE_OFFSET - 1);
  1136.     }
  1137.  
  1138.     block_address[last_header_offset] =
  1139.       (MAKE_LINKAGE_SECTION_HEADER (kind, total_count));
  1140.     for (offset += 1; ((--count) >= 0); offset += entry_size)
  1141.     {
  1142.       SCHEME_OBJECT info;    /* A symbol or a fixnum */
  1143.  
  1144.       if (! execute_p)
  1145.     info = (block_address[offset]);
  1146.       else
  1147.     EXTRACT_EXECUTE_CACHE_SYMBOL (info, &(block_address[offset]));
  1148.  
  1149.       result = ((* cache_handler) (info, block, offset));
  1150.       if (result != PRIM_DONE)
  1151.       {
  1152.         /* Save enough state to continue.
  1153.        Note that offset is decremented to compensate for it being
  1154.        incremented by the for loop header.
  1155.        Similary sections and count are incremented to compensate
  1156.        for loop headers pre-decrementing.
  1157.        count is saved although it's not needed for re-entry to
  1158.        match the assembly language versions.
  1159.      */
  1160.  
  1161.   back_out:
  1162.     if (execute_p)
  1163.       END_OPERATOR_RELOCATION (&(block_address[offset]));
  1164.         STACK_PUSH (ENTRY_TO_OBJECT (ret_add));
  1165.         STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (sections + 1));
  1166.         STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (last_header_offset));
  1167.         STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (offset - 1));
  1168.         STACK_PUSH (block);
  1169.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (count + 1));
  1170.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (total_count));
  1171.  
  1172.         Store_Expression (SHARP_F);
  1173.         Store_Return (RC_COMP_LINK_CACHES_RESTART);
  1174.         Save_Cont ();
  1175.  
  1176.         /* Smash header for the garbage collector.
  1177.            It is smashed back on return.  See the comment above.
  1178.          */
  1179.  
  1180.         block_address[last_header_offset] =
  1181.           (MAKE_LINKAGE_SECTION_HEADER (kind, (total_count - (count + 1))));
  1182.     goto exit_proc;
  1183.       }
  1184.     }
  1185.     if (execute_p)
  1186.       END_OPERATOR_RELOCATION (&(block_address[offset - 1]));
  1187.     last_header_offset = offset;
  1188.   }
  1189.  
  1190. exit_proc:
  1191.   /* Rather than commit, since we want to undo */
  1192.   transaction_abort ();
  1193. #if defined(FLUSH_I_CACHE_REGION) || defined(PUSH_D_CACHE_REGION)
  1194.   {
  1195.     SCHEME_OBJECT * ret_add_block;
  1196.     unsigned long block_len = (((unsigned long) (* block_address)) + 1);
  1197.     
  1198.     Get_Compiled_Block (ret_add_block, ((SCHEME_OBJECT *) ret_add));
  1199.     if (ret_add_block == block_address)
  1200.       {
  1201. #ifdef FLUSH_I_CACHE_REGION
  1202.     FLUSH_I_CACHE_REGION (block_address, block_len);
  1203. #endif
  1204.       }
  1205.     else
  1206.       {
  1207. #ifdef PUSH_D_CACHE_REGION
  1208.     PUSH_D_CACHE_REGION (block_address, block_len);
  1209. #endif
  1210.       }
  1211.   }
  1212. #endif
  1213.   return (result);
  1214. }
  1215.  
  1216. /*
  1217.   comutil_link is used to initialize all the variable cache slots for
  1218.   a compiled code block.  It is called at load time, by the compiled
  1219.   code itself.  It assumes that the return address has been saved on
  1220.   the stack.
  1221.   If an error occurs during linking, or an interrupt must be processed
  1222.   (because of the need to GC, etc.), it backs out and sets up a return
  1223.   code that will invoke comp_link_caches_restart when the error/interrupt
  1224.   processing is done.
  1225. */
  1226.  
  1227. SCHEME_UTILITY utility_result
  1228. DEFNX (comutil_link,
  1229.        (ret_add_raw, block_address_raw, constant_address_raw, sections),
  1230.        SCHEME_ADDR ret_add_raw
  1231.        AND SCHEME_ADDR block_address_raw
  1232.        AND SCHEME_ADDR constant_address_raw
  1233.        AND long sections)
  1234. {
  1235.   instruction * ret_add
  1236.     = ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw)));
  1237.   SCHEME_OBJECT * block_address
  1238.     = (SCHEME_ADDR_TO_ADDR (block_address_raw));
  1239.   SCHEME_OBJECT * constant_address
  1240.     = (SCHEME_ADDR_TO_ADDR (constant_address_raw));
  1241.   long offset;
  1242.  
  1243. #ifdef AUTOCLOBBER_BUG
  1244.   block_address[OBJECT_DATUM (* block_address)] = Regs[REGBLOCK_ENV];
  1245. #endif
  1246.  
  1247.   offset = (constant_address - block_address);
  1248.  
  1249.   RETURN_UNLESS_EXCEPTION
  1250.     ((link_cc_block (block_address,
  1251.                      offset,
  1252.                      offset,
  1253.                      sections,
  1254.                      -1,
  1255.                      ret_add)),
  1256.      ret_add);
  1257. }
  1258.  
  1259. /*
  1260.   comp_link_caches_restart is used to continue the linking process
  1261.   started by comutil_link after the garbage collector has run.
  1262.   It expects the top of the stack to be as left by link_cc_block.
  1263.  */
  1264.  
  1265. C_TO_SCHEME long
  1266. DEFUN_VOID (comp_link_caches_restart)
  1267. {
  1268.   SCHEME_OBJECT block, environment;
  1269.   long original_count, offset, last_header_offset, sections, code;
  1270.   instruction * ret_add;
  1271.  
  1272.   original_count = (OBJECT_DATUM (STACK_POP()));
  1273.   (void) STACK_POP ();        /* Loop count, for debugger */
  1274.   block = (STACK_POP ());
  1275.   environment = (compiled_block_environment (block));
  1276.   Store_Env (environment);
  1277.   offset = (OBJECT_DATUM (STACK_POP ()));
  1278.   last_header_offset = (OBJECT_DATUM (STACK_POP ()));
  1279.   sections = (OBJECT_DATUM (STACK_POP ()));
  1280.   ret_add = ((instruction *) (OBJECT_ADDRESS (STACK_POP ())));
  1281.   code = (link_cc_block ((OBJECT_ADDRESS (block)),
  1282.                          offset,
  1283.                          last_header_offset,
  1284.                          sections,
  1285.                          original_count,
  1286.                          ret_add));
  1287.   if (code == PRIM_DONE)
  1288.     /* Return to the block being linked. */
  1289.     ENTER_SCHEME (ret_add);
  1290.   else
  1291.   {
  1292.     /* Another GC or error.  We should be ready for back-out. */
  1293.     return (code);
  1294.   }
  1295. }
  1296.  
  1297. /* TRAMPOLINE code
  1298.    When a free variable appears in operator position in compiled code,
  1299.    there must be a directly callable procedure in the corresponding
  1300.    execute cache cell.  If, at link time, there is no appropriate
  1301.    value for the free variable, a fake compiled Scheme procedure that
  1302.    calls one of these procedures will be placed into the cell instead.
  1303.  
  1304.    The trampolines themselves are made by make_uuo_link,
  1305.    make_fake_uuo_link, and coerce_to_compiled.  The trampoline looks
  1306.    like a Scheme closure, containing some code to jump to one of
  1307.    these procedures and additional information to be used by the
  1308.    procedure.
  1309.  
  1310.    These procedures expect a single argument, the address of the
  1311.    information block where they can find the relevant data, typically
  1312.    the procedure to invoke and the number of arguments to invoke it
  1313.    with.
  1314. */
  1315.  
  1316. SCHEME_UTILITY utility_result
  1317. DEFNX (comutil_operator_apply_trap,
  1318.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1319.        SCHEME_ADDR tramp_data_raw
  1320.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1321. {
  1322.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1323.  
  1324.   /* Used by coerce_to_compiled.  TRAMPOLINE_K_APPLY */
  1325.  
  1326.   return (comutil_apply ((tramp_data[0]),
  1327.              (OBJECT_DATUM (tramp_data[1])),
  1328.              0, 0));
  1329. }
  1330.  
  1331. SCHEME_UTILITY utility_result
  1332. DEFNX (comutil_operator_arity_trap,
  1333.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1334.        SCHEME_ADDR tramp_data_raw
  1335.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1336. {
  1337.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1338.  
  1339.   /* Linker saw an argument count mismatch. TRAMPOLINE_K_ARITY */
  1340.  
  1341.   return (comutil_apply ((tramp_data[0]),
  1342.              (OBJECT_DATUM (tramp_data[1])),
  1343.              0, 0));
  1344. }
  1345.  
  1346. SCHEME_UTILITY utility_result
  1347. DEFNX (comutil_operator_entity_trap,
  1348.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1349.        SCHEME_ADDR tramp_data_raw
  1350.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1351. {
  1352.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1353.  
  1354.   /* Linker saw an entity to be applied. TRAMPOLINE_K_ENTITY */
  1355.  
  1356.   return (comutil_apply ((tramp_data[0]),
  1357.              (OBJECT_DATUM (tramp_data[1])),
  1358.              0, 0));
  1359. }
  1360.  
  1361. SCHEME_UTILITY utility_result
  1362. DEFNX (comutil_operator_interpreted_trap,
  1363.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1364.        SCHEME_ADDR tramp_data_raw
  1365.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1366. {
  1367.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1368.  
  1369.   /* Linker saw an interpreted procedure or a procedure that it cannot
  1370.      link directly.  TRAMPOLINE_K_INTERPRETED
  1371.    */
  1372.  
  1373.   return (comutil_apply ((tramp_data[0]),
  1374.              (OBJECT_DATUM (tramp_data[1])),
  1375.              0, 0));
  1376. }
  1377.  
  1378. SCHEME_UTILITY utility_result
  1379. DEFNX (comutil_operator_lexpr_trap,
  1380.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1381.        SCHEME_ADDR tramp_data_raw
  1382.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1383. {
  1384.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1385.  
  1386.   /* Linker saw a primitive of arbitrary number of arguments.
  1387.      TRAMPOLINE_K_LEXPR_PRIMITIVE
  1388.    */
  1389.  
  1390.   Regs[REGBLOCK_LEXPR_ACTUALS] =
  1391.     ((SCHEME_OBJECT) ((OBJECT_DATUM (tramp_data[1])) - 1));
  1392.   return (comutil_primitive_lexpr_apply ((tramp_data[0]), 0, 0, 0));
  1393. }
  1394.  
  1395. SCHEME_UTILITY utility_result
  1396. DEFNX (comutil_operator_primitive_trap,
  1397.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1398.        SCHEME_ADDR tramp_data_raw
  1399.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1400. {
  1401.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1402.  
  1403.   /* Linker saw a primitive of fixed matching arity. TRAMPOLINE_K_PRIMITIVE */
  1404.  
  1405.   return (comutil_primitive_apply ((tramp_data[0]), 0, 0, 0));
  1406. }
  1407.  
  1408. extern SCHEME_OBJECT EXFUN (compiler_var_error,
  1409.                 (SCHEME_OBJECT, SCHEME_OBJECT));
  1410.  
  1411. /* The linker either couldn't find a binding or the binding was
  1412.    unassigned, unbound, or a deep-bound (parallel processor) fluid.
  1413.    This must report the correct name of the missing variable and the
  1414.    environment in which the lookup begins for the error cases, or do
  1415.    the correct deep reference for fluids.
  1416.  
  1417.    "extension" is the linker object corresponding to the operator
  1418.    variable (it contains the actual value cell, the name, and linker
  1419.    tables). code_block and offset point to the cache cell in question.
  1420.    tramp_data contains extension, code_block, offset.  TRAMPOLINE_K_LOOKUP
  1421. */
  1422.  
  1423. SCHEME_UTILITY utility_result
  1424. DEFNX (comutil_operator_lookup_trap,
  1425.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1426.        SCHEME_ADDR tramp_data_raw
  1427.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1428. {
  1429.   extern long EXFUN (complr_operator_reference_trap,
  1430.              (SCHEME_OBJECT *, SCHEME_OBJECT));
  1431.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1432.   SCHEME_OBJECT true_operator, * cache_cell;
  1433.   long code, nargs;
  1434.  
  1435.   code = (complr_operator_reference_trap (&true_operator, (tramp_data[0])));
  1436.   cache_cell = (MEMORY_LOC ((tramp_data[1]),
  1437.                 (OBJECT_DATUM (tramp_data[2]))));
  1438.   EXTRACT_EXECUTE_CACHE_ARITY (nargs, cache_cell);
  1439.   if (code == PRIM_DONE)
  1440.     return (comutil_apply (true_operator, nargs, 0, 0));
  1441.   else /* Error or interrupt */
  1442.   {
  1443.     SCHEME_OBJECT trampoline, environment, name;
  1444.  
  1445.     /* This could be done by bumpint tramp_data to the entry point.
  1446.        It would probably be better.
  1447.      */
  1448.     EXTRACT_EXECUTE_CACHE_ADDRESS (trampoline, cache_cell);
  1449.     environment = (compiled_block_environment (tramp_data[1]));
  1450.     name = (compiler_var_error ((tramp_data[0]), environment));
  1451.  
  1452.     STACK_PUSH (ENTRY_TO_OBJECT (SCHEME_ADDR_TO_ADDR (trampoline)));
  1453.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nargs));    /* For debugger */
  1454.     STACK_PUSH (environment);                /* For debugger */
  1455.     STACK_PUSH (name);                    /* For debugger */
  1456.     Store_Expression (SHARP_F);
  1457.     Store_Return (RC_COMP_OP_REF_TRAP_RESTART);
  1458.     Save_Cont ();
  1459.     RETURN_TO_C (code);
  1460.   }
  1461. }
  1462.  
  1463. /*
  1464.   Re-start after processing an error/interrupt encountered in the previous
  1465.   utility.
  1466.   Extract the new trampoline or procedure (the user may have defined the
  1467.   missing variable) and invoke it.
  1468.  */
  1469.  
  1470. C_TO_SCHEME long
  1471. DEFUN_VOID (comp_op_lookup_trap_restart)
  1472. {
  1473.   SCHEME_OBJECT * old_trampoline, code_block, new_procedure;
  1474.   long offset;
  1475.  
  1476.   /* Discard name, env. and nargs */
  1477.  
  1478.   Stack_Pointer = (STACK_LOC (3));
  1479.   old_trampoline = (OBJECT_ADDRESS (STACK_POP ()));
  1480.   code_block = ((TRAMPOLINE_STORAGE (old_trampoline))[1]);
  1481.   offset = (OBJECT_DATUM ((TRAMPOLINE_STORAGE (old_trampoline))[2]));
  1482.   EXTRACT_EXECUTE_CACHE_ADDRESS (new_procedure,
  1483.                  (MEMORY_LOC (code_block, offset)));
  1484.   ENTER_SCHEME (SCHEME_ADDR_TO_ADDR (new_procedure));
  1485. }
  1486.  
  1487. /* ARITY Mismatch handling
  1488.    These receive the entry point as an argument and must fill the
  1489.    Scheme stack with the missing unassigned values.
  1490.    They are invoked by TRAMPOLINE_K_n_m where n and m are the same
  1491.    as in the name of the procedure.
  1492.    The single item of information in the trampoline data area is
  1493.    the real procedure to invoke.  All the arguments are on the
  1494.    Scheme stack.
  1495.  */
  1496.  
  1497. SCHEME_UTILITY utility_result
  1498. DEFNX (comutil_operator_1_0_trap,
  1499.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1500.        SCHEME_ADDR tramp_data_raw
  1501.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1502. {
  1503.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1504.  
  1505.   STACK_PUSH (UNASSIGNED_OBJECT);
  1506.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1507. }
  1508.  
  1509. SCHEME_UTILITY utility_result
  1510. DEFNX (comutil_operator_2_1_trap,
  1511.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1512.        SCHEME_ADDR tramp_data_raw
  1513.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1514. {
  1515.   SCHEME_OBJECT Top;
  1516.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1517.  
  1518.   Top = (STACK_POP ());
  1519.   STACK_PUSH (UNASSIGNED_OBJECT);
  1520.   STACK_PUSH (Top);
  1521.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1522. }
  1523.  
  1524. SCHEME_UTILITY utility_result
  1525. DEFNX (comutil_operator_2_0_trap,
  1526.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1527.        SCHEME_ADDR tramp_data_raw
  1528.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1529. {
  1530.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1531.  
  1532.   STACK_PUSH (UNASSIGNED_OBJECT);
  1533.   STACK_PUSH (UNASSIGNED_OBJECT);
  1534.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1535. }
  1536.  
  1537. SCHEME_UTILITY utility_result
  1538. DEFNX (comutil_operator_3_2_trap,
  1539.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1540.        SCHEME_ADDR tramp_data_raw
  1541.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1542. {
  1543.   SCHEME_OBJECT Top, Next;
  1544.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1545.  
  1546.   Top = (STACK_POP ());
  1547.   Next = (STACK_POP ());
  1548.   STACK_PUSH (UNASSIGNED_OBJECT);
  1549.   STACK_PUSH (Next);
  1550.   STACK_PUSH (Top);
  1551.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1552. }
  1553.  
  1554. SCHEME_UTILITY utility_result
  1555. DEFNX (comutil_operator_3_1_trap,
  1556.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1557.        SCHEME_ADDR tramp_data_raw
  1558.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1559. {
  1560.   SCHEME_OBJECT Top;
  1561.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1562.  
  1563.   Top = (STACK_POP ());
  1564.   STACK_PUSH (UNASSIGNED_OBJECT);
  1565.   STACK_PUSH (UNASSIGNED_OBJECT);
  1566.   STACK_PUSH (Top);
  1567.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1568. }
  1569.  
  1570. SCHEME_UTILITY utility_result
  1571. DEFNX (comutil_operator_3_0_trap,
  1572.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1573.        SCHEME_ADDR tramp_data_raw
  1574.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1575. {
  1576.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1577.  
  1578.   STACK_PUSH (UNASSIGNED_OBJECT);
  1579.   STACK_PUSH (UNASSIGNED_OBJECT);
  1580.   STACK_PUSH (UNASSIGNED_OBJECT);
  1581.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1582. }
  1583.  
  1584. SCHEME_UTILITY utility_result
  1585. DEFNX (comutil_operator_4_3_trap,
  1586.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1587.        SCHEME_ADDR tramp_data_raw
  1588.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1589. {
  1590.   SCHEME_OBJECT Top, Middle, Bottom;
  1591.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1592.  
  1593.   Top = (STACK_POP ());
  1594.   Middle = (STACK_POP ());
  1595.   Bottom = (STACK_POP ());
  1596.  
  1597.   STACK_PUSH (UNASSIGNED_OBJECT);
  1598.   STACK_PUSH (Bottom);
  1599.   STACK_PUSH (Middle);
  1600.   STACK_PUSH (Top);
  1601.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1602. }
  1603.  
  1604. SCHEME_UTILITY utility_result
  1605. DEFNX (comutil_operator_4_2_trap,
  1606.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1607.        SCHEME_ADDR tramp_data_raw
  1608.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1609. {
  1610.   SCHEME_OBJECT Top, Next;
  1611.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1612.  
  1613.   Top = (STACK_POP ());
  1614.   Next = (STACK_POP ());
  1615.   STACK_PUSH (UNASSIGNED_OBJECT);
  1616.   STACK_PUSH (UNASSIGNED_OBJECT);
  1617.   STACK_PUSH (Next);
  1618.   STACK_PUSH (Top);
  1619.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1620. }
  1621.  
  1622. SCHEME_UTILITY utility_result
  1623. DEFNX (comutil_operator_4_1_trap,
  1624.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1625.        SCHEME_ADDR tramp_data_raw
  1626.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1627. {
  1628.   SCHEME_OBJECT Top;
  1629.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1630.  
  1631.   Top = (STACK_POP ());
  1632.   STACK_PUSH (UNASSIGNED_OBJECT);
  1633.   STACK_PUSH (UNASSIGNED_OBJECT);
  1634.   STACK_PUSH (UNASSIGNED_OBJECT);
  1635.   STACK_PUSH (Top);
  1636.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1637. }
  1638.  
  1639. SCHEME_UTILITY utility_result
  1640. DEFNX (comutil_operator_4_0_trap,
  1641.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  1642.        SCHEME_ADDR tramp_data_raw
  1643.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  1644. {
  1645.   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
  1646.  
  1647.   STACK_PUSH (UNASSIGNED_OBJECT);
  1648.   STACK_PUSH (UNASSIGNED_OBJECT);
  1649.   STACK_PUSH (UNASSIGNED_OBJECT);
  1650.   STACK_PUSH (UNASSIGNED_OBJECT);
  1651.   RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
  1652. }
  1653.  
  1654. /* INTERRUPT/GC from Scheme
  1655.  
  1656.    These procedures are called from compiled code at the start
  1657.    (respectively) of a procedure or continuation if an interrupt has
  1658.    been detected.  They must not be called unless there is an
  1659.    interrupt to be serviced.
  1660.  
  1661.    The code that handles RC_COMP_INTERRUPT_RESTART in "interp.c" will
  1662.    return control to comp_interrupt_restart (below).  This assumes
  1663.    that the Scheme stack contains a compiled code entry address
  1664.    (start of continuation, procedure, etc.).  The Expression register
  1665.    saved with the continuation is a piece of state that will be
  1666.    returned to Val and Env (both) upon return.
  1667.  */
  1668.  
  1669. #define MAYBE_REQUEST_INTERRUPTS()                    \
  1670. {                                    \
  1671.   if (Free >= MemTop)                            \
  1672.     Request_GC (Free - MemTop);                        \
  1673.   if (Stack_Pointer <= Stack_Guard)                    \
  1674.     REQUEST_INTERRUPT (INT_Stack_Overflow);                \
  1675. }
  1676.  
  1677. static utility_result
  1678. DEFUN (compiler_interrupt_common, (entry_point_raw, state),
  1679.        SCHEME_ADDR entry_point_raw AND
  1680.        SCHEME_OBJECT state)
  1681. {
  1682.   MAYBE_REQUEST_INTERRUPTS ();
  1683.   if (entry_point_raw != ((SCHEME_ADDR) 0))
  1684.   {
  1685.     instruction * entry_point
  1686.       = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw)));
  1687.     STACK_PUSH (ENTRY_TO_OBJECT (entry_point));
  1688.   }
  1689.   STACK_PUSH (state);
  1690.   Store_Expression (SHARP_F);
  1691.   Store_Return (RC_COMP_INTERRUPT_RESTART);
  1692.   Save_Cont ();
  1693.   RETURN_TO_C (PRIM_INTERRUPT);
  1694. }
  1695.  
  1696. SCHEME_UTILITY utility_result
  1697. DEFNX (comutil_interrupt_closure, (ignore_1, ignore_2, ignore_3, ignore_4),
  1698.        long ignore_1 AND
  1699.        long ignore_2 AND
  1700.        long ignore_3 AND
  1701.        long ignore_4)
  1702. {
  1703.   return (compiler_interrupt_common (0, SHARP_F));
  1704. }
  1705.  
  1706. SCHEME_UTILITY utility_result
  1707. DEFNX (comutil_interrupt_dlink,
  1708.        (entry_point_raw, dlink_raw, ignore_3, ignore_4),
  1709.        SCHEME_ADDR entry_point_raw AND
  1710.        SCHEME_ADDR dlink_raw AND
  1711.        long ignore_3 AND
  1712.        long ignore_4)
  1713. {
  1714.   SCHEME_OBJECT * dlink = (SCHEME_ADDR_TO_ADDR (dlink_raw));
  1715.   return
  1716.     (compiler_interrupt_common
  1717.      (entry_point_raw, (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, dlink))));
  1718. }
  1719.  
  1720. SCHEME_UTILITY utility_result
  1721. DEFNX (comutil_interrupt_procedure,
  1722.        (entry_point_raw, ignore_2, ignore_3, ignore_4),
  1723.        SCHEME_ADDR entry_point_raw AND
  1724.        long ignore_2 AND
  1725.        long ignore_3 AND
  1726.        long ignore_4)
  1727. {
  1728.   return (compiler_interrupt_common (entry_point_raw, SHARP_F));
  1729. }
  1730.  
  1731. /* Val has live data, and there is no entry address on the stack */
  1732.  
  1733. SCHEME_UTILITY utility_result
  1734. DEFNX (comutil_interrupt_continuation,
  1735.        (return_address_raw, ignore_2, ignore_3, ignore_4),
  1736.        SCHEME_ADDR return_address_raw AND
  1737.        long ignore_2 AND
  1738.        long ignore_3 AND
  1739.        long ignore_4)
  1740. {
  1741.   return (compiler_interrupt_common (return_address_raw, Val));
  1742. }
  1743.  
  1744. /* Env has live data; no entry point on the stack */
  1745.  
  1746. SCHEME_UTILITY utility_result
  1747. DEFNX (comutil_interrupt_ic_procedure,
  1748.        (entry_point_raw, ignore_2, ignore_3, ignore_4),
  1749.        SCHEME_ADDR entry_point_raw AND
  1750.        long ignore_2 AND
  1751.        long ignore_3 AND
  1752.        long ignore_4)
  1753. {
  1754.   return (compiler_interrupt_common (entry_point_raw, (Fetch_Env ())));
  1755. }
  1756.  
  1757. SCHEME_UTILITY utility_result
  1758. DEFNX (comutil_interrupt_continuation_2,
  1759.        (ignore_1, ignore_2, ignore_3, ignore_4),
  1760.        long ignore_1 AND
  1761.        long ignore_2 AND
  1762.        long ignore_3 AND
  1763.        long ignore_4)
  1764. {
  1765.   return (compiler_interrupt_common (0, Val));
  1766. }
  1767.  
  1768. C_TO_SCHEME long
  1769. DEFUN_VOID (comp_interrupt_restart)
  1770. {
  1771.   SCHEME_OBJECT state;
  1772.  
  1773.   state = (STACK_POP ());
  1774.   Store_Env (state);
  1775.   Val = state;
  1776.   ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
  1777. }
  1778.  
  1779. /* Other TRAPS */
  1780.  
  1781. /* Assigning a variable that has a trap in it (except unassigned) */
  1782.  
  1783. SCHEME_UTILITY utility_result
  1784. DEFNX (comutil_assignment_trap,
  1785.        (return_address_raw, extension_addr_raw, value, ignore_4),
  1786.        SCHEME_ADDR return_address_raw
  1787.        AND SCHEME_ADDR extension_addr_raw
  1788.        AND SCHEME_OBJECT value
  1789.        AND long ignore_4)
  1790. {
  1791.   extern long EXFUN (compiler_assignment_trap, (SCHEME_OBJECT, SCHEME_OBJECT));
  1792.   instruction * return_address
  1793.     = ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw)));
  1794.   SCHEME_OBJECT * extension_addr = (SCHEME_ADDR_TO_ADDR (extension_addr_raw));
  1795.   SCHEME_OBJECT extension;
  1796.   long code;
  1797.  
  1798.   extension = (MAKE_POINTER_OBJECT (TC_QUAD, extension_addr));
  1799.   code = (compiler_assignment_trap (extension, value));
  1800.   if (code == PRIM_DONE)
  1801.     RETURN_TO_SCHEME (return_address);
  1802.   else
  1803.   {
  1804.     SCHEME_OBJECT block, environment, name, sra;
  1805.  
  1806.     sra = (ENTRY_TO_OBJECT (return_address));
  1807.     STACK_PUSH (sra);
  1808.     STACK_PUSH (value);
  1809.     block = (compiled_entry_to_block (sra));
  1810.     environment = (compiled_block_environment (block));
  1811.     STACK_PUSH (environment);
  1812.     name = (compiler_var_error (extension, environment));
  1813.     STACK_PUSH (name);
  1814.     Store_Expression (SHARP_F);
  1815.     Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART);
  1816.     Save_Cont ();
  1817.     RETURN_TO_C (code);
  1818.   }
  1819. }
  1820.  
  1821. C_TO_SCHEME long
  1822. DEFUN_VOID (comp_assignment_trap_restart)
  1823. {
  1824.   extern long EXFUN (Symbol_Lex_Set,
  1825.              (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT));
  1826.   SCHEME_OBJECT name, environment, value;
  1827.   long code;
  1828.  
  1829.   name = (STACK_POP ());
  1830.   environment = (STACK_POP ());
  1831.   value = (STACK_POP ());
  1832.   code = (Symbol_Lex_Set (environment, name, value));
  1833.   if (code == PRIM_DONE)
  1834.     ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
  1835.   else
  1836.   {
  1837.     STACK_PUSH (value);
  1838.     STACK_PUSH (environment);
  1839.     STACK_PUSH (name);
  1840.     Store_Expression (SHARP_F);
  1841.     Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART);
  1842.     Save_Cont ();
  1843.     return (code);
  1844.   }
  1845. }
  1846.  
  1847. SCHEME_UTILITY utility_result
  1848. DEFNX (comutil_cache_lookup_apply,
  1849.        (extension_addr_raw, block_address_raw, nactuals, ignore_4),
  1850.        SCHEME_ADDR extension_addr_raw
  1851.        AND SCHEME_ADDR block_address_raw
  1852.        AND long nactuals
  1853.        AND long ignore_4)
  1854. {
  1855.   extern long EXFUN (compiler_lookup_trap, (SCHEME_OBJECT));
  1856.   SCHEME_OBJECT * extension_addr = (SCHEME_ADDR_TO_ADDR (extension_addr_raw));
  1857.   SCHEME_OBJECT * block_address = (SCHEME_ADDR_TO_ADDR (block_address_raw));
  1858.   SCHEME_OBJECT extension;
  1859.   long code;
  1860.  
  1861.   extension = (MAKE_POINTER_OBJECT (TC_QUAD, extension_addr));
  1862.   code = (compiler_lookup_trap (extension));
  1863.   if (code == PRIM_DONE)
  1864.     return (comutil_apply (Val, nactuals, 0, 0));
  1865.   else
  1866.   {
  1867.     SCHEME_OBJECT block, environment, name;
  1868.  
  1869.     block = (MAKE_CC_BLOCK (block_address));
  1870.     STACK_PUSH (block);
  1871.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  1872.     environment = (compiled_block_environment (block));
  1873.     STACK_PUSH (environment);
  1874.     name = (compiler_var_error (extension, environment));
  1875.     STACK_PUSH (name);
  1876.     Store_Expression (SHARP_F);
  1877.     Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART);
  1878.     Save_Cont ();
  1879.     RETURN_TO_C (code);
  1880.   }
  1881. }
  1882.  
  1883. C_TO_SCHEME long
  1884. DEFUN_VOID (comp_cache_lookup_apply_restart)
  1885. {
  1886.   extern long EXFUN (Symbol_Lex_Ref, (SCHEME_OBJECT, SCHEME_OBJECT));
  1887.   SCHEME_OBJECT name, environment;
  1888.   long code;
  1889.  
  1890.   name = (STACK_POP ());
  1891.   environment = (STACK_POP ());
  1892.   code = (Symbol_Lex_Ref (environment, name));
  1893.   if (code == PRIM_DONE)
  1894.   {
  1895.     /* Replace block with actual operator */
  1896.     (* (STACK_LOC (1))) = Val;
  1897.     if (COMPILED_CODE_ADDRESS_P (Val))
  1898.       return (apply_compiled_procedure ());
  1899.     else
  1900.       return (PRIM_APPLY);
  1901.   }
  1902.   else
  1903.   {
  1904.     STACK_PUSH (environment);
  1905.     STACK_PUSH (name);
  1906.     Store_Expression (SHARP_F);
  1907.     Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART);
  1908.     Save_Cont ();
  1909.     return (code);
  1910.   }
  1911. }
  1912.  
  1913. /* Variable reference traps:
  1914.    Reference to a free variable that has a reference trap -- either a
  1915.    fluid or an error (unassigned / unbound)
  1916.  */
  1917.  
  1918. #define CMPLR_REF_TRAP(name, c_trap, ret_code, restart, c_lookup)    \
  1919. SCHEME_UTILITY utility_result                        \
  1920. DEFNX (name,                                \
  1921.        (return_address_raw, extension_addr_raw, ignore_3, ignore_4),    \
  1922.        SCHEME_ADDR return_address_raw                    \
  1923.        AND SCHEME_ADDR extension_addr_raw                \
  1924.        AND long ignore_3 AND long ignore_4)                \
  1925. {                                    \
  1926.   extern long EXFUN (c_trap, (SCHEME_OBJECT));                \
  1927.   instruction * return_address                        \
  1928.     = ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw)));    \
  1929.   SCHEME_OBJECT * extension_addr                    \
  1930.     = (SCHEME_ADDR_TO_ADDR (extension_addr_raw));            \
  1931.   SCHEME_OBJECT extension;                        \
  1932.   long code;                                \
  1933.                                     \
  1934.   extension = (MAKE_POINTER_OBJECT (TC_QUAD, extension_addr));        \
  1935.   code = c_trap (extension);                        \
  1936.   if (code == PRIM_DONE)                        \
  1937.     RETURN_TO_SCHEME (return_address);                    \
  1938.   else                                    \
  1939.   {                                    \
  1940.     SCHEME_OBJECT block, environment, name, sra;            \
  1941.                                     \
  1942.     sra = (ENTRY_TO_OBJECT (return_address));                \
  1943.     STACK_PUSH (sra);                            \
  1944.     block = (compiled_entry_to_block (sra));                \
  1945.     environment = (compiled_block_environment (block));            \
  1946.     STACK_PUSH (environment);                        \
  1947.     name = (compiler_var_error (extension, environment));        \
  1948.     STACK_PUSH (name);                            \
  1949.     Store_Expression (SHARP_F);                        \
  1950.     Store_Return (ret_code);                        \
  1951.     Save_Cont ();                            \
  1952.     RETURN_TO_C (code);                            \
  1953.   }                                    \
  1954. }                                    \
  1955.                                     \
  1956. C_TO_SCHEME long                            \
  1957. DEFUN_VOID (restart)                            \
  1958. {                                    \
  1959.   extern long EXFUN (c_lookup, (SCHEME_OBJECT, SCHEME_OBJECT));        \
  1960.   SCHEME_OBJECT name, environment;                    \
  1961.   long code;                                \
  1962.                                     \
  1963.   name = (Fetch_Expression ());                        \
  1964.   environment = (STACK_POP ());                        \
  1965.   code = (c_lookup (environment, name));                \
  1966.   if (code == PRIM_DONE)                        \
  1967.     ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ()));            \
  1968.   else                                    \
  1969.   {                                    \
  1970.     STACK_PUSH (environment);                        \
  1971.     STACK_PUSH (name);                            \
  1972.     Store_Expression (SHARP_F);                        \
  1973.     Store_Return (ret_code);                        \
  1974.     Save_Cont ();                            \
  1975.     return (code);                            \
  1976.   }                                    \
  1977. }
  1978.  
  1979. /* Actual traps */
  1980.  
  1981. CMPLR_REF_TRAP(comutil_lookup_trap,
  1982.                compiler_lookup_trap,
  1983.                RC_COMP_LOOKUP_TRAP_RESTART,
  1984.                comp_lookup_trap_restart,
  1985.                Symbol_Lex_Ref)
  1986.  
  1987. CMPLR_REF_TRAP(comutil_safe_lookup_trap,
  1988.                compiler_safe_lookup_trap,
  1989.                RC_COMP_SAFE_REF_TRAP_RESTART,
  1990.                comp_safe_lookup_trap_restart,
  1991.                safe_symbol_lex_ref)
  1992.  
  1993. CMPLR_REF_TRAP(comutil_unassigned_p_trap,
  1994.                compiler_unassigned_p_trap,
  1995.                RC_COMP_UNASSIGNED_TRAP_RESTART,
  1996.                comp_unassigned_p_trap_restart,
  1997.                Symbol_Lex_unassigned_p)
  1998.  
  1999.  
  2000. /* NUMERIC ROUTINES
  2001.    Invoke the arithmetic primitive in the fixed objects vector.
  2002.    The Scheme arguments are expected on the Scheme stack.
  2003.  */
  2004.  
  2005. #define COMPILER_ARITH_PRIM(name, fobj_index, arity)            \
  2006. SCHEME_UTILITY utility_result                        \
  2007. DEFNX (name,                                \
  2008.        (ignore_1, ignore_2, ignore_3, ignore_4),            \
  2009.        long ignore_1 AND long ignore_2                    \
  2010.        AND long ignore_3 AND long ignore_4)                \
  2011. {                                    \
  2012.   SCHEME_OBJECT handler;                        \
  2013.                                     \
  2014.   handler = (Get_Fixed_Obj_Slot (fobj_index));                \
  2015.   return (comutil_apply (handler, (arity), 0, 0));            \
  2016. }
  2017.  
  2018. COMPILER_ARITH_PRIM (comutil_decrement, GENERIC_TRAMPOLINE_PREDECESSOR, 2)
  2019. COMPILER_ARITH_PRIM (comutil_divide, GENERIC_TRAMPOLINE_DIVIDE, 3)
  2020. COMPILER_ARITH_PRIM (comutil_equal, GENERIC_TRAMPOLINE_EQUAL_P, 3)
  2021. COMPILER_ARITH_PRIM (comutil_greater, GENERIC_TRAMPOLINE_GREATER_P, 3)
  2022. COMPILER_ARITH_PRIM (comutil_increment, GENERIC_TRAMPOLINE_SUCCESSOR, 2)
  2023. COMPILER_ARITH_PRIM (comutil_less, GENERIC_TRAMPOLINE_LESS_P, 3)
  2024. COMPILER_ARITH_PRIM (comutil_minus, GENERIC_TRAMPOLINE_SUBTRACT, 3)
  2025. COMPILER_ARITH_PRIM (comutil_modulo, GENERIC_TRAMPOLINE_MODULO, 3)
  2026. COMPILER_ARITH_PRIM (comutil_multiply, GENERIC_TRAMPOLINE_MULTIPLY, 3)
  2027. COMPILER_ARITH_PRIM (comutil_negative, GENERIC_TRAMPOLINE_NEGATIVE_P, 2)
  2028. COMPILER_ARITH_PRIM (comutil_plus, GENERIC_TRAMPOLINE_ADD, 3)
  2029. COMPILER_ARITH_PRIM (comutil_positive, GENERIC_TRAMPOLINE_POSITIVE_P, 2)
  2030. COMPILER_ARITH_PRIM (comutil_quotient, GENERIC_TRAMPOLINE_QUOTIENT, 3)
  2031. COMPILER_ARITH_PRIM (comutil_remainder, GENERIC_TRAMPOLINE_REMAINDER, 3)
  2032. COMPILER_ARITH_PRIM (comutil_zero, GENERIC_TRAMPOLINE_ZERO_P, 2)
  2033.  
  2034. /*
  2035.   Obsolete SCHEME_UTILITYs used to handle first class environments.
  2036.   They have been superseded by the variable caching code.
  2037.   They are here for completeness, and because the code in the compiler
  2038.   that uses them has not yet been spliced out, although it is switched
  2039.   off.
  2040. */
  2041.  
  2042. #define CMPLR_REFERENCE(util_name, c_proc, ret_code, restart_name)    \
  2043. SCHEME_UTILITY utility_result                        \
  2044. DEFNX (util_name,                            \
  2045.        (ret_add_raw, environment, variable, ignore_4),            \
  2046.        SCHEME_ADDR ret_add_raw                        \
  2047.        AND SCHEME_OBJECT environment AND SCHEME_OBJECT variable        \
  2048.        AND long ignore_4)                        \
  2049. {                                    \
  2050.   extern long EXFUN (c_proc, (SCHEME_OBJECT, SCHEME_OBJECT));        \
  2051.   instruction * ret_add                            \
  2052.     = ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw)));        \
  2053.   long code;                                \
  2054.                                     \
  2055.   code = (c_proc (environment, variable));                \
  2056.   if (code == PRIM_DONE)                        \
  2057.   {                                    \
  2058.     RETURN_TO_SCHEME (ret_add);                        \
  2059.   }                                    \
  2060.   else                                    \
  2061.   {                                    \
  2062.     STACK_PUSH (ENTRY_TO_OBJECT (ret_add));                \
  2063.     STACK_PUSH (variable);                        \
  2064.     STACK_PUSH (environment);                        \
  2065.     Store_Expression (SHARP_F);                        \
  2066.     Store_Return (ret_code);                        \
  2067.     Save_Cont ();                            \
  2068.     RETURN_TO_C (code);                            \
  2069.   }                                    \
  2070. }                                    \
  2071.                                     \
  2072. C_TO_SCHEME long                            \
  2073. DEFUN_VOID (restart_name)                        \
  2074. {                                    \
  2075.   extern long EXFUN (c_proc, (SCHEME_OBJECT, SCHEME_OBJECT));        \
  2076.   SCHEME_OBJECT environment, variable;                    \
  2077.   long code;                                \
  2078.                                     \
  2079.   environment = (STACK_POP ());                        \
  2080.   variable = (STACK_POP ());                        \
  2081.   code = (c_proc (environment, variable));                \
  2082.   if (code == PRIM_DONE)                        \
  2083.   {                                    \
  2084.     Regs[REGBLOCK_ENV] = environment;                    \
  2085.     ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ()));            \
  2086.   }                                    \
  2087.   else                                    \
  2088.   {                                    \
  2089.     STACK_PUSH (variable);                        \
  2090.     STACK_PUSH (environment);                        \
  2091.     Store_Expression (SHARP_F);                        \
  2092.     Store_Return (ret_code);                        \
  2093.     Save_Cont ();                            \
  2094.     return (code);                            \
  2095.   }                                    \
  2096. }
  2097.  
  2098. #define CMPLR_ASSIGNMENT(util_name, c_proc, ret_code, restart_name)    \
  2099. SCHEME_UTILITY utility_result                        \
  2100. DEFNX (util_name,                            \
  2101.        (ret_add_raw, environment, variable, value),            \
  2102.        SCHEME_ADDR ret_add_raw                        \
  2103.        AND SCHEME_OBJECT environment                    \
  2104.        AND SCHEME_OBJECT variable                    \
  2105.        AND SCHEME_OBJECT value)                        \
  2106. {                                    \
  2107.   extern long EXFUN (c_proc, (SCHEME_OBJECT, SCHEME_OBJECT,        \
  2108.                   SCHEME_OBJECT));                \
  2109.   instruction * ret_add                            \
  2110.     = ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw)));        \
  2111.   long code;                                \
  2112.                                     \
  2113.   code = (c_proc (environment, variable, value));            \
  2114.   if (code == PRIM_DONE)                        \
  2115.     RETURN_TO_SCHEME (ret_add);                        \
  2116.   else                                    \
  2117.   {                                    \
  2118.     STACK_PUSH (ENTRY_TO_OBJECT (ret_add));                \
  2119.     STACK_PUSH (value);                            \
  2120.     STACK_PUSH (variable);                        \
  2121.     STACK_PUSH (environment);                        \
  2122.     Store_Expression (SHARP_F);                        \
  2123.     Store_Return (ret_code);                        \
  2124.     Save_Cont ();                            \
  2125.     RETURN_TO_C (code);                            \
  2126.   }                                    \
  2127. }                                    \
  2128.                                     \
  2129. C_TO_SCHEME long                            \
  2130. DEFUN_VOID (restart_name)                        \
  2131. {                                    \
  2132.   extern long EXFUN (c_proc, (SCHEME_OBJECT, SCHEME_OBJECT,        \
  2133.                   SCHEME_OBJECT));                \
  2134.   SCHEME_OBJECT environment, variable, value;                \
  2135.   long code;                                \
  2136.                                     \
  2137.   environment = (Fetch_Expression ());                    \
  2138.   variable = (STACK_POP ());                        \
  2139.   value = (STACK_POP ());                        \
  2140.   code = (c_proc (environment, variable, value));            \
  2141.   if (code == PRIM_DONE)                        \
  2142.   {                                    \
  2143.     Regs[REGBLOCK_ENV] = environment;                    \
  2144.     ENTER_SCHEME (OBJECT_ADDRESS (STACK_POP ()));            \
  2145.   }                                    \
  2146.   else                                    \
  2147.   {                                    \
  2148.     STACK_PUSH (value);                            \
  2149.     STACK_PUSH (variable);                        \
  2150.     STACK_PUSH (environment);                        \
  2151.     Store_Expression (SHARP_F);                        \
  2152.     Store_Return (ret_code);                        \
  2153.     Save_Cont ();                            \
  2154.     return (code);                            \
  2155.   }                                    \
  2156. }
  2157.  
  2158. CMPLR_REFERENCE(comutil_access,
  2159.         Symbol_Lex_Ref,
  2160.         RC_COMP_ACCESS_RESTART,
  2161.         comp_access_restart)
  2162.  
  2163. CMPLR_REFERENCE(comutil_reference,
  2164.         Lex_Ref,
  2165.         RC_COMP_REFERENCE_RESTART,
  2166.         comp_reference_restart)
  2167.  
  2168. CMPLR_REFERENCE(comutil_safe_reference,
  2169.         safe_lex_ref,
  2170.         RC_COMP_SAFE_REFERENCE_RESTART,
  2171.         comp_safe_reference_restart)
  2172.  
  2173. CMPLR_REFERENCE(comutil_unassigned_p,
  2174.         Symbol_Lex_unassigned_p,
  2175.         RC_COMP_UNASSIGNED_P_RESTART,
  2176.         comp_unassigned_p_restart)
  2177.  
  2178. CMPLR_REFERENCE(comutil_unbound_p,
  2179.         Symbol_Lex_unbound_p,
  2180.         RC_COMP_UNBOUND_P_RESTART,
  2181.         comp_unbound_p_restart)
  2182.  
  2183. CMPLR_ASSIGNMENT(comutil_assignment,
  2184.          Lex_Set,
  2185.          RC_COMP_ASSIGNMENT_RESTART,
  2186.          comp_assignment_restart)
  2187.  
  2188. CMPLR_ASSIGNMENT(comutil_definition,
  2189.          Local_Set,
  2190.          RC_COMP_DEFINITION_RESTART,
  2191.          comp_definition_restart)
  2192.  
  2193. SCHEME_UTILITY utility_result
  2194. DEFNX (comutil_lookup_apply,
  2195.        (environment, variable, nactuals, ignore_4),
  2196.        SCHEME_OBJECT environment AND SCHEME_OBJECT variable
  2197.        AND long nactuals AND long ignore_4)
  2198. {
  2199.   extern long EXFUN (Lex_Ref, (SCHEME_OBJECT, SCHEME_OBJECT));
  2200.   long code;
  2201.  
  2202.   code = (Lex_Ref (environment, variable));
  2203.   if (code == PRIM_DONE)
  2204.     return (comutil_apply (Val, nactuals, 0, 0));
  2205.   else
  2206.   {
  2207.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
  2208.     STACK_PUSH (variable);
  2209.     STACK_PUSH (environment);
  2210.     Store_Expression (SHARP_F);
  2211.     Store_Return (RC_COMP_LOOKUP_APPLY_RESTART);
  2212.     Save_Cont ();
  2213.     RETURN_TO_C (code);
  2214.   }
  2215. }
  2216.  
  2217. C_TO_SCHEME long
  2218. DEFUN_VOID (comp_lookup_apply_restart)
  2219. {
  2220.   extern long EXFUN (Lex_Ref, (SCHEME_OBJECT, SCHEME_OBJECT));
  2221.   SCHEME_OBJECT environment, variable;
  2222.   long code;
  2223.  
  2224.   environment = (STACK_POP ());
  2225.   variable = (STACK_POP ());
  2226.   code = (Lex_Ref (environment, variable));
  2227.   if (code == PRIM_DONE)
  2228.   {
  2229.     SCHEME_OBJECT nactuals;
  2230.  
  2231.     nactuals = (STACK_POP ());
  2232.     STACK_PUSH (Val);
  2233.     STACK_PUSH (nactuals);
  2234.     if (COMPILED_CODE_ADDRESS_P (Val))
  2235.       return (apply_compiled_procedure ());
  2236.     else
  2237.       return (PRIM_APPLY);
  2238.   }
  2239.   else
  2240.   {
  2241.     STACK_PUSH (variable);
  2242.     STACK_PUSH (environment);
  2243.     Store_Expression (SHARP_F);
  2244.     Store_Return (RC_COMP_LOOKUP_APPLY_RESTART);
  2245.     Save_Cont ();
  2246.     return (code);
  2247.   }
  2248. }
  2249.  
  2250. SCHEME_UTILITY utility_result
  2251. DEFNX (comutil_primitive_error,
  2252.        (ret_add_raw, primitive, ignore_3, ignore_4),
  2253.        SCHEME_ADDR ret_add_raw
  2254.        AND SCHEME_OBJECT primitive
  2255.        AND long ignore_3 AND long ignore_4)
  2256. {
  2257.   instruction * ret_add =
  2258.     ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw)));
  2259.  
  2260.   STACK_PUSH (ENTRY_TO_OBJECT (ret_add));
  2261.   STACK_PUSH (primitive);
  2262.   Store_Expression (SHARP_F);
  2263.   Store_Return (RC_COMP_ERROR_RESTART);
  2264.   Save_Cont ();
  2265.   RETURN_TO_C (ERR_COMPILED_CODE_ERROR);
  2266. }
  2267.  
  2268. C_TO_SCHEME long
  2269. DEFUN_VOID (comp_error_restart)
  2270. {
  2271.   instruction * ret_add;
  2272.  
  2273.   (void) STACK_POP ();        /* primitive */
  2274.   ret_add = ((instruction *) (OBJECT_ADDRESS (STACK_POP ())));
  2275.   ENTER_SCHEME (ret_add);
  2276. }
  2277.  
  2278. /* Procedures to destructure compiled entries and closures. */
  2279.  
  2280. /*
  2281.   Extract the debugging information attached to `block'.  Usually
  2282.   this is a string which contains the filename where the debugging
  2283.   info is stored.
  2284.  */
  2285.  
  2286. C_UTILITY SCHEME_OBJECT
  2287. DEFUN (compiled_block_debugging_info,
  2288.        (block),
  2289.        SCHEME_OBJECT block)
  2290. {
  2291.   long length;
  2292.  
  2293.   length = (VECTOR_LENGTH (block));
  2294.   return (FAST_MEMORY_REF (block, (length - 1)));
  2295. }
  2296.  
  2297. /* Extract the environment where the `block' was "loaded". */
  2298.  
  2299. C_UTILITY SCHEME_OBJECT
  2300. DEFUN (compiled_block_environment,
  2301.        (block),
  2302.        SCHEME_OBJECT block)
  2303. {
  2304.   long length;
  2305.  
  2306.   length = (VECTOR_LENGTH (block));
  2307.   return (FAST_MEMORY_REF (block, length));
  2308. }
  2309.  
  2310. /*
  2311.   Given `entry', a Scheme object representing a compiled code entry point,
  2312.   it returns the address of the block to which it belongs.
  2313.  */
  2314.  
  2315. C_UTILITY SCHEME_OBJECT *
  2316. DEFUN (compiled_entry_to_block_address,
  2317.        (entry),
  2318.        SCHEME_OBJECT entry)
  2319. {
  2320.   SCHEME_OBJECT *block_address;
  2321.  
  2322.   Get_Compiled_Block (block_address, (OBJECT_ADDRESS (entry)));
  2323.   return (block_address);
  2324. }
  2325.  
  2326. C_UTILITY SCHEME_OBJECT
  2327. DEFUN (compiled_entry_to_block,
  2328.        (entry),
  2329.        SCHEME_OBJECT entry)
  2330. {
  2331.   SCHEME_OBJECT *block_address;
  2332.  
  2333.   Get_Compiled_Block (block_address, (OBJECT_ADDRESS (entry)));
  2334.   return (MAKE_CC_BLOCK (block_address));
  2335. }
  2336.  
  2337. /* Returns the offset from the block to the entry point. */
  2338.  
  2339. #ifndef CC_BLOCK_DISTANCE
  2340.  
  2341. #define CC_BLOCK_DISTANCE(block,entry)                    \
  2342.   (((char *) (entry)) - ((char *) (block)))
  2343.  
  2344. #endif /* CC_BLOCK_DISTANCE */
  2345.  
  2346. C_UTILITY long
  2347. DEFUN (compiled_entry_to_block_offset,
  2348.        (entry),
  2349.        SCHEME_OBJECT entry)
  2350. {
  2351.   SCHEME_OBJECT *entry_address, *block_address;
  2352.  
  2353.   entry_address = (OBJECT_ADDRESS (entry));
  2354.   Get_Compiled_Block (block_address, entry_address);
  2355.   return (CC_BLOCK_DISTANCE (block_address, entry_address));
  2356. }
  2357.  
  2358. /*
  2359.   Check whether the compiled code block whose address is `block_addr'
  2360.   is a compiled closure block.
  2361.  */
  2362.  
  2363. static long
  2364. DEFUN (block_address_closure_p,
  2365.        (block_addr),
  2366.        SCHEME_OBJECT * block_addr)
  2367. {
  2368.   SCHEME_OBJECT header_word;
  2369.  
  2370.   header_word = (*block_addr);
  2371.   return (((OBJECT_TYPE (header_word)) == TC_MANIFEST_CLOSURE));
  2372. }
  2373.  
  2374. /*
  2375.   Check whether the compiled code block `block' is a compiled closure block.
  2376.  */
  2377.  
  2378. C_UTILITY long
  2379. DEFUN (compiled_block_closure_p,
  2380.        (block),
  2381.        SCHEME_OBJECT block)
  2382. {
  2383.   return (block_address_closure_p (OBJECT_ADDRESS (block)));
  2384. }
  2385.  
  2386. /*
  2387.   Check whether the compiled entry point `entry' is a compiled closure.
  2388.  */
  2389.  
  2390. C_UTILITY long
  2391. DEFUN (compiled_entry_closure_p,
  2392.        (entry),
  2393.        SCHEME_OBJECT entry)
  2394. {
  2395.   return (block_address_closure_p (compiled_entry_to_block_address (entry)));
  2396. }
  2397.  
  2398. /*
  2399.   Extract the entry point ultimately invoked by the compiled closure
  2400.   represented by `entry'.
  2401.  */
  2402.  
  2403. C_UTILITY SCHEME_OBJECT
  2404. DEFUN (compiled_closure_to_entry,
  2405.        (entry),
  2406.        SCHEME_OBJECT entry)
  2407. {
  2408.   SCHEME_OBJECT real_entry;
  2409.  
  2410.   EXTRACT_CLOSURE_ENTRY_ADDRESS (real_entry, (OBJECT_ADDRESS (entry)));
  2411.   return (ENTRY_TO_OBJECT (SCHEME_ADDR_TO_ADDR (real_entry)));
  2412. }
  2413.  
  2414. /*
  2415.   Store the information for `entry' into `buffer'.
  2416.   This is used by the printer and debugging utilities.
  2417.  */
  2418.  
  2419. /* Kinds and subkinds of entries. */
  2420.  
  2421. #define KIND_PROCEDURE                          0
  2422. #define KIND_CONTINUATION                       1
  2423. #define KIND_EXPRESSION                         2
  2424. #define KIND_OTHER                              3
  2425. #define KIND_ILLEGAL                            4
  2426.  
  2427. /* Continuation subtypes */
  2428.  
  2429. #define CONTINUATION_NORMAL                     0
  2430. #define CONTINUATION_DYNAMIC_LINK               1
  2431. #define CONTINUATION_RETURN_TO_INTERPRETER      2
  2432.  
  2433. /* Other subtypes */
  2434.  
  2435. #define OTHER_CLOSURE                0
  2436. #define OTHER_RANDOM                1
  2437.  
  2438. C_UTILITY void
  2439. DEFUN (compiled_entry_type,
  2440.        (entry, buffer),
  2441.        SCHEME_OBJECT entry AND long * buffer)
  2442. {
  2443.   long kind, min_arity, max_arity, field1, field2;
  2444.   SCHEME_OBJECT * entry_address;
  2445.  
  2446.   entry_address = (OBJECT_ADDRESS (entry));
  2447.   max_arity = (COMPILED_ENTRY_MAXIMUM_ARITY (entry_address));
  2448.   min_arity = (COMPILED_ENTRY_MINIMUM_ARITY (entry_address));
  2449.   field1 = min_arity;
  2450.   field2 = max_arity;
  2451.   if (min_arity >= 0)
  2452.     kind = KIND_PROCEDURE;
  2453.   else if (max_arity >= 0)
  2454.     kind = KIND_ILLEGAL;
  2455.   else if ((((unsigned long) max_arity) & 0xff) < 0xe0)
  2456.   {
  2457.     /* Field2 is the offset to the next continuation */
  2458.  
  2459.     kind = KIND_CONTINUATION;
  2460.     field1 = CONTINUATION_NORMAL;
  2461.     field2 = (((((unsigned long) max_arity) & 0x3f) << 7)
  2462.           | (((unsigned long) min_arity) & 0x7f));
  2463.   }
  2464.   else if (min_arity != -1)
  2465.     kind = KIND_ILLEGAL;
  2466.  
  2467.   else
  2468.   {
  2469.     switch (((unsigned long) max_arity) & 0xff)
  2470.     {
  2471.       case FORMAT_BYTE_EXPR:
  2472.       {
  2473.         kind = KIND_EXPRESSION;
  2474.         break;
  2475.       }
  2476.       case FORMAT_BYTE_CLOSURE:
  2477.       {
  2478.         kind = KIND_OTHER;
  2479.     field1 = OTHER_CLOSURE;
  2480.         break;
  2481.       }
  2482.       case FORMAT_BYTE_COMPLR:
  2483.       case FORMAT_BYTE_CMPINT:
  2484.       {
  2485.         kind = KIND_OTHER;
  2486.     field1 = OTHER_RANDOM;
  2487.         break;
  2488.       }
  2489.       case FORMAT_BYTE_DLINK:
  2490.       {
  2491.         kind = KIND_CONTINUATION;
  2492.         field1 = CONTINUATION_DYNAMIC_LINK;
  2493.         field2 = -1;
  2494.         break;
  2495.       }
  2496.       case FORMAT_BYTE_RETURN:
  2497.       {
  2498.         kind = KIND_CONTINUATION;
  2499.         field1 = CONTINUATION_RETURN_TO_INTERPRETER;
  2500.         field2 = ((long) (entry != return_to_interpreter));
  2501.         break;
  2502.       }
  2503.       default:
  2504.       {
  2505.         kind = KIND_ILLEGAL;
  2506.         break;
  2507.       }
  2508.     }
  2509.   }
  2510.   buffer[0] = kind;
  2511.   buffer[1] = field1;
  2512.   buffer[2] = field2;
  2513. }
  2514.  
  2515. void
  2516. DEFUN (declare_compiled_code_block, (block), SCHEME_OBJECT block)
  2517. {
  2518. #ifdef PUSH_D_CACHE_REGION
  2519.   SCHEME_OBJECT * block_addr = (OBJECT_ADDRESS (block));
  2520.   PUSH_D_CACHE_REGION (block_addr, (1+ (OBJECT_DATUM (* block_addr))));
  2521. #endif
  2522. }
  2523.  
  2524. /* Destructuring free variable caches. */
  2525.  
  2526. C_UTILITY void
  2527. DEFUN (store_variable_cache,
  2528.        (extension, block, offset),
  2529.        SCHEME_OBJECT extension AND SCHEME_OBJECT block
  2530.        AND long offset)
  2531. {
  2532.   FAST_MEMORY_SET (block, offset,
  2533.                    ((SCHEME_OBJECT)
  2534.             (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (extension)))));
  2535. }
  2536.  
  2537. C_UTILITY SCHEME_OBJECT
  2538. DEFUN (extract_variable_cache,
  2539.        (block, offset),
  2540.        SCHEME_OBJECT block AND long offset)
  2541. {
  2542.   return (MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE,
  2543.                                ((SCHEME_OBJECT *)
  2544.                 (SCHEME_ADDR_TO_ADDR
  2545.                  (FAST_MEMORY_REF (block, offset))))));
  2546. }
  2547.  
  2548. /* Get a compiled procedure from a cached operator reference. */
  2549.  
  2550. C_UTILITY SCHEME_OBJECT
  2551. DEFUN (extract_uuo_link,
  2552.        (block, offset),
  2553.        SCHEME_OBJECT block AND long offset)
  2554. {
  2555.   SCHEME_OBJECT * cache_address, compiled_entry_address;
  2556.  
  2557.   cache_address = (MEMORY_LOC (block, offset));
  2558.   EXTRACT_EXECUTE_CACHE_ADDRESS (compiled_entry_address, cache_address);
  2559.   return (ENTRY_TO_OBJECT (SCHEME_ADDR_TO_ADDR (compiled_entry_address)));
  2560. }
  2561.  
  2562. static void
  2563. DEFUN (store_uuo_link,
  2564.        (entry, cache_address),
  2565.        SCHEME_OBJECT entry AND SCHEME_OBJECT * cache_address)
  2566. {
  2567.   SCHEME_OBJECT * entry_address;
  2568.  
  2569.   entry_address = (OBJECT_ADDRESS (entry));
  2570.   STORE_EXECUTE_CACHE_CODE (cache_address);
  2571.   STORE_EXECUTE_CACHE_ADDRESS (cache_address,
  2572.                    (ADDR_TO_SCHEME_ADDR (entry_address)));
  2573. #ifdef FLUSH_I_CACHE_REGION
  2574.   if (!linking_cc_block_p)
  2575.     {
  2576.       /* The linker will flush the whole region afterwards. */
  2577.       FLUSH_I_CACHE_REGION (cache_address, EXECUTE_CACHE_ENTRY_SIZE);
  2578.     }
  2579. #endif
  2580. }
  2581.  
  2582. /* This makes a fake compiled procedure which traps to kind handler when
  2583.    invoked.
  2584.  */
  2585.  
  2586. #define TRAMPOLINE_SIZE    (TRAMPOLINE_ENTRY_SIZE + 2)
  2587.  
  2588. /* Enabled so that the profiler can distinguish trampolines */
  2589.  
  2590. #if 1 || defined(AUTOCLOBBER_BUG)
  2591. #  define TC_TRAMPOLINE_HEADER    TC_FIXNUM
  2592. #else
  2593. #  define TC_TRAMPOLINE_HEADER    TC_MANIFEST_VECTOR
  2594. #endif
  2595.  
  2596. static void
  2597. DEFUN (fill_trampoline,
  2598.        (block, entry_point, fmt_word, kind),
  2599.        SCHEME_OBJECT * block
  2600.        AND instruction * entry_point
  2601.        AND format_word fmt_word
  2602.        AND long kind)
  2603. {
  2604.   (COMPILED_ENTRY_FORMAT_WORD (entry_point)) = fmt_word;
  2605.   (COMPILED_ENTRY_OFFSET_WORD (entry_point)) =
  2606.     (MAKE_OFFSET_WORD (entry_point, block, false));
  2607.   STORE_TRAMPOLINE_ENTRY (entry_point, kind);
  2608.   return;
  2609. }
  2610.  
  2611. static long
  2612. DEFUN (make_trampoline,
  2613.        (slot, fmt_word, kind, size, value1, value2, value3),
  2614.        SCHEME_OBJECT * slot
  2615.        AND format_word fmt_word
  2616.        AND long kind AND long size
  2617.        AND SCHEME_OBJECT value1 AND SCHEME_OBJECT value2
  2618.        AND SCHEME_OBJECT value3)
  2619. {
  2620.   instruction * entry_point;
  2621.   SCHEME_OBJECT * ptr;
  2622.  
  2623.   if (GC_Check (TRAMPOLINE_SIZE + size))
  2624.   {
  2625.     Request_GC (TRAMPOLINE_SIZE + size);
  2626.     return (PRIM_INTERRUPT);
  2627.   }
  2628.  
  2629.   ptr = Free;
  2630.   Free += (TRAMPOLINE_SIZE + size);
  2631.   ptr[0] = (MAKE_OBJECT (TC_TRAMPOLINE_HEADER,
  2632.                 ((TRAMPOLINE_SIZE - 1) + size)));
  2633.   ptr[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
  2634.                TRAMPOLINE_ENTRY_SIZE));
  2635.   entry_point = ((instruction *) (TRAMPOLINE_ENTRY_POINT (ptr)));
  2636.   fill_trampoline (ptr, entry_point, fmt_word, kind);
  2637.   *slot = (ENTRY_TO_OBJECT (entry_point));
  2638.   ptr = (TRAMPOLINE_STORAGE (entry_point));
  2639.   if ((--size) >= 0)
  2640.     *ptr++ = value1;
  2641.   if ((--size) >= 0)
  2642.     *ptr++ = value2;
  2643.   if ((--size) >= 0)
  2644.     *ptr++ = value3;
  2645.   return (PRIM_DONE);
  2646. }
  2647.  
  2648. /* Standard trampolines. */
  2649.  
  2650. static long
  2651. DEFUN (make_redirection_trampoline,
  2652.        (slot, kind, procedure),
  2653.        SCHEME_OBJECT * slot AND long kind AND SCHEME_OBJECT procedure)
  2654. {
  2655.   return (make_trampoline (slot,
  2656.                ((format_word) FORMAT_WORD_CMPINT),
  2657.                kind,
  2658.                1,
  2659.                procedure,
  2660.                SHARP_F,
  2661.                SHARP_F));
  2662. }
  2663.  
  2664. static long
  2665. DEFUN (make_apply_trampoline,
  2666.        (slot, kind, procedure, nactuals),
  2667.        SCHEME_OBJECT * slot AND long kind
  2668.        AND SCHEME_OBJECT procedure AND long nactuals)
  2669. {
  2670.   return (make_trampoline (slot,
  2671.                ((format_word) FORMAT_WORD_CMPINT),
  2672.                kind,
  2673.                2,
  2674.                procedure,
  2675.                (LONG_TO_UNSIGNED_FIXNUM (nactuals)),
  2676.                SHARP_F));
  2677. }
  2678.  
  2679. #define TRAMPOLINE_TABLE_SIZE   4
  2680.  
  2681. static long
  2682. trampoline_arity_table[TRAMPOLINE_TABLE_SIZE * TRAMPOLINE_TABLE_SIZE] =
  2683. {
  2684.   TRAMPOLINE_K_1_0,        /* 1_0 */
  2685.   TRAMPOLINE_K_ARITY,        /* 1_1 should not get here */
  2686.   TRAMPOLINE_K_ARITY,        /* 1_2 should not get here */
  2687.   TRAMPOLINE_K_ARITY,        /* 1_3 should not get here */
  2688.   TRAMPOLINE_K_2_0,        /* 2_0 */
  2689.   TRAMPOLINE_K_2_1,        /* 2_1 */
  2690.   TRAMPOLINE_K_ARITY,        /* 2_2 should not get here */
  2691.   TRAMPOLINE_K_ARITY,        /* 2_3 should not get here */
  2692.   TRAMPOLINE_K_3_0,        /* 3_0 */
  2693.   TRAMPOLINE_K_3_1,        /* 3_1 */
  2694.   TRAMPOLINE_K_3_2,        /* 3_2 */
  2695.   TRAMPOLINE_K_ARITY,        /* 3_3 should not get here */
  2696.   TRAMPOLINE_K_4_0,        /* 4_0 */
  2697.   TRAMPOLINE_K_4_1,        /* 4_1 */
  2698.   TRAMPOLINE_K_4_2,        /* 4_2 */
  2699.   TRAMPOLINE_K_4_3        /* 4_3 */
  2700. };
  2701.  
  2702. /*
  2703.   make_uuo_link is called by C and initializes a compiled procedure
  2704.   cache at a location given by a block and an offset.
  2705.  
  2706.   make_uuo_link checks its procedure argument, and:
  2707.  
  2708.   - If it is not a compiled procedure, an entity, or a primitive
  2709.   procedure with a matching number of arguments, it stores a fake
  2710.   compiled procedure which will invoke comutil_operator_interpreted_trap
  2711.   when invoked.
  2712.  
  2713.   - If its argument is an entity, it stores a fake compiled procedure
  2714.   which will invoke comutil_operator_entity_trap when invoked.
  2715.  
  2716.   - If its argument is a primitive, it stores a fake compiled procedure
  2717.   which will invoke comutil_operator_primitive_trap, or
  2718.   comutil_operator_lexpr_trap when invoked.
  2719.  
  2720.   - If its argument is a compiled procedure that expects more or
  2721.   less arguments than those provided, it stores a fake compiled
  2722.   procedure which will invoke comutil_operator_arity_trap, or one of
  2723.   its specialized versions when invoked.
  2724.  
  2725.   - Otherwise, the actual (compatible) operator is stored.
  2726. */
  2727.  
  2728. C_UTILITY long
  2729. DEFUN (make_uuo_link,
  2730.        (procedure, extension, block, offset),
  2731.        SCHEME_OBJECT procedure AND SCHEME_OBJECT extension
  2732.        AND SCHEME_OBJECT block AND long offset)
  2733. {
  2734.   long kind, result;
  2735.   unsigned long nactuals;
  2736.   SCHEME_OBJECT orig_proc, trampoline, *cache_address;
  2737.  
  2738.   cache_address = (MEMORY_LOC (block, offset));
  2739.   EXTRACT_EXECUTE_CACHE_ARITY (nactuals, cache_address);
  2740.   /* nactuals >= 0 */
  2741.  
  2742.   orig_proc = procedure;
  2743. loop:
  2744.   switch (OBJECT_TYPE (procedure))
  2745.   {
  2746.     case TC_COMPILED_ENTRY:
  2747.     {
  2748.       SCHEME_OBJECT * entry;
  2749.       long nmin, nmax;
  2750.  
  2751.       entry = (OBJECT_ADDRESS (procedure));
  2752.       nmax = (COMPILED_ENTRY_MAXIMUM_ARITY (entry));
  2753.       if (((long) nactuals) == nmax)
  2754.       {
  2755.         store_uuo_link (procedure, cache_address);
  2756.         return (PRIM_DONE);
  2757.       }
  2758.       nmin = (COMPILED_ENTRY_MINIMUM_ARITY (entry));
  2759.       if ((nmax > 1) && (nmin > 0) && (nmin <= ((long) nactuals)) &&
  2760.           (nactuals <= TRAMPOLINE_TABLE_SIZE) &&
  2761.           (nmax <= (TRAMPOLINE_TABLE_SIZE + 1)))
  2762.       {
  2763.         kind = (trampoline_arity_table[((nmax - 2) * TRAMPOLINE_TABLE_SIZE) +
  2764.                        (nactuals - 1)]);
  2765.     /* Paranoia */
  2766.     if (kind != TRAMPOLINE_K_ARITY)
  2767.     {
  2768.       nactuals = 0;
  2769.       break;
  2770.     }
  2771.       }
  2772.       kind = TRAMPOLINE_K_ARITY;
  2773.       break;
  2774.     }
  2775.  
  2776.     case TC_ENTITY:
  2777.     {
  2778.       SCHEME_OBJECT data;
  2779.  
  2780.       data = (MEMORY_REF (procedure, ENTITY_DATA));
  2781.       if ((VECTOR_P (data))
  2782.       && (nactuals < (VECTOR_LENGTH (data)))
  2783.       && ((VECTOR_REF (data, nactuals)) != SHARP_F)
  2784.       && ((VECTOR_REF (data, 0))
  2785.           == (Get_Fixed_Obj_Slot (ARITY_DISPATCHER_TAG))))
  2786.       {
  2787.     /* No loops allowed! */
  2788.     SCHEME_OBJECT nproc = (VECTOR_REF (data, nactuals));
  2789.  
  2790.     if ((procedure == orig_proc) && (nproc != procedure))
  2791.     {
  2792.       procedure = nproc;
  2793.       goto loop;
  2794.     }
  2795.     else
  2796.       procedure = orig_proc;
  2797.       }
  2798.       kind = TRAMPOLINE_K_ENTITY;
  2799.       break;
  2800.     }
  2801.  
  2802.     case TC_PRIMITIVE:
  2803.     {
  2804.       long arity;
  2805.  
  2806.       arity = (PRIMITIVE_ARITY (procedure));
  2807.       if (arity == ((long) (nactuals - 1)))
  2808.       {
  2809.     nactuals = 0;
  2810.         kind = TRAMPOLINE_K_PRIMITIVE;
  2811.       }
  2812.       else if (arity == LEXPR_PRIMITIVE_ARITY)
  2813.         kind = TRAMPOLINE_K_LEXPR_PRIMITIVE;
  2814.       else
  2815.         kind = TRAMPOLINE_K_OTHER;
  2816.       break;
  2817.     }
  2818.  
  2819.     case TC_PROCEDURE: /* and some others... */
  2820.     default:
  2821.     /* uuo_link_interpreted: */
  2822.     {
  2823.       kind = TRAMPOLINE_K_INTERPRETED;
  2824.       break;
  2825.     }
  2826.   }
  2827.   if (nactuals == 0)
  2828.     result = (make_redirection_trampoline (&trampoline, kind, procedure));
  2829.   else
  2830.     result = (make_apply_trampoline (&trampoline, kind, procedure, nactuals));
  2831.   if (result != PRIM_DONE)
  2832.     return (result);
  2833.   store_uuo_link (trampoline, cache_address);
  2834.   return (PRIM_DONE);
  2835. }
  2836.  
  2837. C_UTILITY long
  2838. DEFUN (make_fake_uuo_link,
  2839.        (extension, block, offset),
  2840.        SCHEME_OBJECT extension AND SCHEME_OBJECT block AND long offset)
  2841. {
  2842.   long result;
  2843.   SCHEME_OBJECT trampoline, *cache_address;
  2844.  
  2845.   result = (make_trampoline (&trampoline,
  2846.                  ((format_word) FORMAT_WORD_CMPINT),
  2847.                  TRAMPOLINE_K_LOOKUP,
  2848.                  3,
  2849.                  extension,
  2850.                  block,
  2851.                  (LONG_TO_UNSIGNED_FIXNUM (offset))));
  2852.   if (result != PRIM_DONE)
  2853.   {
  2854.     return (result);
  2855.   }
  2856.   cache_address = (MEMORY_LOC (block, offset));
  2857.   store_uuo_link (trampoline, cache_address);
  2858.   return (PRIM_DONE);
  2859. }
  2860.  
  2861. /* C_UTILITY long fake_uuo_link_p does not appear to be used anymore */
  2862.  
  2863. C_UTILITY long
  2864. DEFUN (coerce_to_compiled,
  2865.        (procedure, arity, location),
  2866.        SCHEME_OBJECT procedure AND long arity AND SCHEME_OBJECT * location)
  2867. {
  2868.   long frame_size;
  2869.  
  2870.   frame_size = (arity + 1);
  2871.   if ((!(COMPILED_CODE_ADDRESS_P (procedure))) ||
  2872.       (((long) (COMPILED_ENTRY_MAXIMUM_ARITY (OBJECT_ADDRESS (procedure)))) !=
  2873.        frame_size))
  2874.   {
  2875.     if (frame_size > FORMAT_BYTE_FRAMEMAX)
  2876.       return (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  2877.     return (make_trampoline (location,
  2878.                  ((format_word)
  2879.                   (MAKE_FORMAT_WORD (frame_size, frame_size))),
  2880.                  TRAMPOLINE_K_APPLY,
  2881.                  2,
  2882.                  procedure,
  2883.                  (LONG_TO_UNSIGNED_FIXNUM (frame_size)),
  2884.                  SHARP_F));
  2885.   }
  2886.   (*location) = procedure;
  2887.   return (PRIM_DONE);
  2888. }
  2889.  
  2890. #ifndef HAVE_BKPT_SUPPORT
  2891.  
  2892. C_UTILITY SCHEME_OBJECT
  2893. DEFUN (bkpt_install, (ep), PTR ep)
  2894. {
  2895.   return (SHARP_F);
  2896. }
  2897.  
  2898. C_UTILITY SCHEME_OBJECT
  2899. DEFUN (bkpt_closure_install, (ep), PTR ep)
  2900. {
  2901.   return (SHARP_F);
  2902. }
  2903.  
  2904. C_UTILITY void
  2905. DEFUN (bkpt_remove, (ep, handle), PTR ep AND SCHEME_OBJECT handle)
  2906. {
  2907.   error_external_return ();
  2908. }
  2909.  
  2910. C_UTILITY Boolean
  2911. DEFUN (bkpt_p, (ep), PTR ep)
  2912. {
  2913.   return (FALSE);
  2914. }
  2915.  
  2916. C_UTILITY SCHEME_OBJECT
  2917. DEFUN (bkpt_proceed, (ep, handle, state),
  2918.        PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state)
  2919. {
  2920.   error_external_return ();
  2921.   return (UNSPECIFIC);
  2922. }
  2923.  
  2924. C_UTILITY PTR
  2925. DEFUN (do_bkpt_proceed, (value), unsigned long * value)
  2926. {
  2927.   * value = ((unsigned long) ERR_EXTERNAL_RETURN);
  2928.   return (FALSE);
  2929. }
  2930.  
  2931. #else /* HAVE_BKPT_SUPPORT */
  2932.  
  2933. #define BKPT_PROCEED_FRAME_SIZE    3
  2934.  
  2935. C_UTILITY SCHEME_OBJECT
  2936. DEFUN (bkpt_proceed, (ep, handle, state),
  2937.        PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state)
  2938. {
  2939.   if ((! (COMPILED_CODE_ADDRESS_P (STACK_REF (BKPT_PROCEED_FRAME_SIZE))))
  2940.       || ((OBJECT_ADDRESS (STACK_REF (BKPT_PROCEED_FRAME_SIZE)))
  2941.       != ((SCHEME_OBJECT *) ep)))
  2942.     error_external_return ();
  2943.  
  2944.   STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_CC_BKPT);
  2945.   STACK_PUSH (reflect_to_interface);
  2946.   Stack_Pointer = (STACK_LOC (- BKPT_PROCEED_FRAME_SIZE));
  2947.   return (SHARP_F);
  2948. }
  2949. #endif /* HAVE_BKPT_SUPPORT */
  2950.  
  2951. SCHEME_UTILITY utility_result
  2952. DEFNX (comutil_compiled_code_bkpt,
  2953.        (entry_point_raw, state_raw, ignore_3, ignore_4),
  2954.        SCHEME_ADDR entry_point_raw AND SCHEME_ADDR state_raw
  2955.        AND long ignore_3 AND long ignore_4)
  2956. {
  2957.   long type_info[3];
  2958.   instruction * entry_point_a
  2959.     = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw)));
  2960.   SCHEME_OBJECT entry_point = (ENTRY_TO_OBJECT (entry_point_a));
  2961.   SCHEME_OBJECT state;
  2962.   SCHEME_OBJECT stack_ptr;
  2963.  
  2964.   STACK_PUSH (entry_point);    /* return address */
  2965.  
  2966.   /* Potential bug: This does not preserve the environment for
  2967.      IC procedures.  There is no way to tell that we have
  2968.      an IC procedure in our hands.  It is not safe to preserve
  2969.      it in general because the contents of the register may
  2970.      be stale (predate the last GC).
  2971.      However, the compiler no longer generates IC procedures, and
  2972.      will probably never do it again.
  2973.    */
  2974.  
  2975.   compiled_entry_type (entry_point, &type_info[0]);
  2976.   if ((type_info[0] == KIND_OTHER) && (type_info[1] == OTHER_CLOSURE))
  2977.   {
  2978.     entry_point_a = ((instruction *) (SCHEME_ADDR_TO_ADDR (state_raw)));
  2979.     state = (ENTRY_TO_OBJECT (entry_point_a));
  2980.   }
  2981.   else if (type_info[0] != KIND_CONTINUATION)
  2982.     state = SHARP_F;
  2983.   else if (type_info[1] == CONTINUATION_DYNAMIC_LINK)
  2984.     state = (MAKE_POINTER_OBJECT
  2985.          (TC_STACK_ENVIRONMENT, (SCHEME_ADDR_TO_ADDR (state_raw))));
  2986.   else
  2987.     state = Val;
  2988.  
  2989.   stack_ptr = (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, Stack_Pointer));
  2990.   STACK_PUSH (state);        /* state to preserve */
  2991.   STACK_PUSH (stack_ptr);    /* "Environment" pointer */
  2992.   STACK_PUSH (entry_point);    /* argument to handler */
  2993.   return (comutil_apply ((Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)),
  2994.              4, ignore_3, ignore_4));
  2995. }
  2996.  
  2997. SCHEME_UTILITY utility_result
  2998. DEFNX (comutil_compiled_closure_bkpt,
  2999.        (entry_point_raw, ignore_2, ignore_3, ignore_4),
  3000.        SCHEME_ADDR entry_point_raw
  3001.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  3002. {
  3003.   instruction * entry_point_a
  3004.     = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw)));
  3005.   SCHEME_OBJECT entry_point = (ENTRY_TO_OBJECT (entry_point_a));
  3006.   SCHEME_OBJECT stack_ptr;
  3007.  
  3008.   STACK_PUSH (entry_point);    /* return address */
  3009.  
  3010.   stack_ptr = (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, Stack_Pointer));
  3011.   STACK_PUSH (SHARP_F);        /* state to preserve */
  3012.   STACK_PUSH (stack_ptr);    /* "Environment" pointer */
  3013.   STACK_PUSH (entry_point);    /* argument to handler */
  3014.   return (comutil_apply ((Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)),
  3015.              4, ignore_3, ignore_4));
  3016. }
  3017.  
  3018. SCHEME_UTILITY utility_result
  3019. DEFNX (comutil_reflect_to_interface,
  3020.        (tramp_data_raw, ignore_2, ignore_3, ignore_4),
  3021.        SCHEME_ADDR tramp_data_raw
  3022.        AND long ignore_2 AND long ignore_3 AND long ignore_4)
  3023. {
  3024.   SCHEME_OBJECT code = (STACK_POP ());
  3025.  
  3026.   switch (OBJECT_DATUM (code))
  3027.   {
  3028.     case REFLECT_CODE_INTERNAL_APPLY:
  3029.     {
  3030.       long frame_size = (OBJECT_DATUM (STACK_POP ()));
  3031.       SCHEME_OBJECT procedure = (STACK_POP ());
  3032.       
  3033.       return (comutil_apply (procedure, frame_size, ignore_3, ignore_4));
  3034.     }
  3035.  
  3036.     case REFLECT_CODE_RESTORE_INTERRUPT_MASK:
  3037.     {
  3038.       SET_INTERRUPT_MASK (OBJECT_DATUM (STACK_POP ()));
  3039.       INVOKE_RETURN_ADDRESS ();
  3040.     }
  3041.  
  3042.     case REFLECT_CODE_STACK_MARKER:
  3043.     {
  3044.       (void) STACK_POP ();    /* marker1 */
  3045.       (void) STACK_POP ();    /* marker2 */
  3046.       INVOKE_RETURN_ADDRESS ();
  3047.     }
  3048.  
  3049.     case REFLECT_CODE_CC_BKPT:
  3050.     {
  3051.       unsigned long value;
  3052.  
  3053.       /* Attempt to process interrupts before really proceeding. */
  3054.  
  3055.       if (((long) (ADDR_TO_SCHEME_ADDR (Free)))
  3056.       >= ((long) (Regs[REGBLOCK_MEMTOP])))
  3057.       {
  3058.     STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_CC_BKPT);
  3059.     STACK_PUSH (reflect_to_interface);
  3060.     return (compiler_interrupt_common (0, SHARP_F));
  3061.       }
  3062.  
  3063.       if (do_bkpt_proceed (& value))
  3064.     RETURN_TO_SCHEME (value);
  3065.       else
  3066.     RETURN_TO_C (value);
  3067.     }
  3068.  
  3069.     default:
  3070.       STACK_PUSH (code);
  3071.       RETURN_TO_C (ERR_EXTERNAL_RETURN);
  3072.   }
  3073. }
  3074.  
  3075. /*
  3076.   Utility table used by the assembly language interface to invoke
  3077.   the SCHEME_UTILITY procedures that appear in this file.
  3078.  
  3079.   Important: Do NOT reorder this table without changing the indices
  3080.   defined on the following page and the corresponding table in the
  3081.   compiler.
  3082.  
  3083.   In addition, this table must be declared before compiler_reset_internal.
  3084.  */
  3085.  
  3086. #define UTE(name) ((utility_table_entry) name)
  3087.  
  3088. utility_table_entry utility_table[] =
  3089. {
  3090.   UTE(comutil_return_to_interpreter),        /* 0x0 */
  3091.   UTE(comutil_operator_apply_trap),        /* 0x1 */
  3092.   UTE(comutil_operator_arity_trap),        /* 0x2 */
  3093.   UTE(comutil_operator_entity_trap),        /* 0x3 */
  3094.   UTE(comutil_operator_interpreted_trap),    /* 0x4 */
  3095.   UTE(comutil_operator_lexpr_trap),        /* 0x5 */
  3096.   UTE(comutil_operator_primitive_trap),        /* 0x6 */
  3097.   UTE(comutil_operator_lookup_trap),        /* 0x7 */
  3098.   UTE(comutil_operator_1_0_trap),        /* 0x8 */
  3099.   UTE(comutil_operator_2_1_trap),        /* 0x9 */
  3100.   UTE(comutil_operator_2_0_trap),        /* 0xa */
  3101.   UTE(comutil_operator_3_2_trap),        /* 0xb */
  3102.   UTE(comutil_operator_3_1_trap),        /* 0xc */
  3103.   UTE(comutil_operator_3_0_trap),        /* 0xd */
  3104.   UTE(comutil_operator_4_3_trap),        /* 0xe */
  3105.   UTE(comutil_operator_4_2_trap),        /* 0xf */
  3106.   UTE(comutil_operator_4_1_trap),        /* 0x10 */
  3107.   UTE(comutil_operator_4_0_trap),        /* 0x11 */
  3108.   UTE(comutil_primitive_apply),            /* 0x12 */
  3109.   UTE(comutil_primitive_lexpr_apply),        /* 0x13 */
  3110.   UTE(comutil_apply),                /* 0x14 */
  3111.   UTE(comutil_error),                /* 0x15 */
  3112.   UTE(comutil_lexpr_apply),            /* 0x16 */
  3113.   UTE(comutil_link),                /* 0x17 */
  3114.   UTE(comutil_interrupt_closure),        /* 0x18 */
  3115.   UTE(comutil_interrupt_dlink),            /* 0x19 */
  3116.   UTE(comutil_interrupt_procedure),        /* 0x1a */
  3117.   UTE(comutil_interrupt_continuation),        /* 0x1b */
  3118.   UTE(comutil_interrupt_ic_procedure),        /* 0x1c */
  3119.   UTE(comutil_assignment_trap),            /* 0x1d */
  3120.   UTE(comutil_cache_lookup_apply),        /* 0x1e */
  3121.   UTE(comutil_lookup_trap),            /* 0x1f */
  3122.   UTE(comutil_safe_lookup_trap),        /* 0x20 */
  3123.   UTE(comutil_unassigned_p_trap),        /* 0x21 */
  3124.   UTE(comutil_decrement),            /* 0x22 */
  3125.   UTE(comutil_divide),                /* 0x23 */
  3126.   UTE(comutil_equal),                /* 0x24 */
  3127.   UTE(comutil_greater),                /* 0x25 */
  3128.   UTE(comutil_increment),            /* 0x26 */
  3129.   UTE(comutil_less),                /* 0x27 */
  3130.   UTE(comutil_minus),                /* 0x28 */
  3131.   UTE(comutil_multiply),            /* 0x29 */
  3132.   UTE(comutil_negative),            /* 0x2a */
  3133.   UTE(comutil_plus),                /* 0x2b */
  3134.   UTE(comutil_positive),            /* 0x2c */
  3135.   UTE(comutil_zero),                /* 0x2d */
  3136.   UTE(comutil_access),                /* 0x2e */
  3137.   UTE(comutil_reference),            /* 0x2f */
  3138.   UTE(comutil_safe_reference),            /* 0x30 */
  3139.   UTE(comutil_unassigned_p),            /* 0x31 */
  3140.   UTE(comutil_unbound_p),            /* 0x32 */
  3141.   UTE(comutil_assignment),            /* 0x33 */
  3142.   UTE(comutil_definition),            /* 0x34 */
  3143.   UTE(comutil_lookup_apply),            /* 0x35 */
  3144.   UTE(comutil_primitive_error),            /* 0x36 */
  3145.   UTE(comutil_quotient),            /* 0x37 */
  3146.   UTE(comutil_remainder),            /* 0x38 */
  3147.   UTE(comutil_modulo),                /* 0x39 */
  3148.   UTE(comutil_reflect_to_interface),        /* 0x3a */
  3149.   UTE(comutil_interrupt_continuation_2),    /* 0x3b */
  3150.   UTE(comutil_compiled_code_bkpt),        /* 0x3c */
  3151.   UTE(comutil_compiled_closure_bkpt)        /* 0x3d */
  3152.   };
  3153.  
  3154. extern long MAX_TRAMPOLINE;
  3155. long MAX_TRAMPOLINE = ((sizeof (utility_table))
  3156.                / (sizeof (utility_table_entry)));
  3157.  
  3158. /* Support for trap handling. */
  3159.  
  3160. static void
  3161. DEFUN_VOID (end_of_utils)
  3162. {
  3163.   return;
  3164. }
  3165.  
  3166. struct util_descriptor_s
  3167. {
  3168.   PTR pc;
  3169.   char * name;
  3170. };
  3171.  
  3172. #ifdef STDC_HEADERS
  3173. #  define UTLD(name)  { ((PTR) name), #name }
  3174. #else
  3175. /* Hope that this works. */
  3176. #  define UTLD(name)  { ((PTR) name), "name" }
  3177. #endif
  3178.  
  3179. static
  3180. struct util_descriptor_s utility_descriptor_table[] =
  3181. {
  3182. #ifdef DECLARE_CMPINTMD_UTILITIES
  3183.   DECLARE_CMPINTMD_UTILITIES(),
  3184. #endif /* DECLARE_CMPINTMD_UTILITIES */
  3185.   UTLD(C_to_interface),
  3186.   UTLD(open_gap),
  3187.   UTLD(setup_lexpr_invocation),
  3188.   UTLD(setup_compiled_invocation),
  3189.   UTLD(enter_compiled_expression),
  3190.   UTLD(apply_compiled_procedure),
  3191.   UTLD(return_to_compiled_code),
  3192.   UTLD(apply_compiled_from_primitive),
  3193.   UTLD(compiled_with_interrupt_mask),
  3194.   UTLD(compiled_with_stack_marker),
  3195.   UTLD(comutil_return_to_interpreter),
  3196.   UTLD(comutil_primitive_apply),
  3197.   UTLD(comutil_primitive_lexpr_apply),
  3198.   UTLD(comutil_apply),
  3199.   UTLD(comutil_error),
  3200.   UTLD(comutil_lexpr_apply),
  3201.   UTLD(abort_link_cc_block),
  3202.   UTLD(link_cc_block),
  3203.   UTLD(comutil_link),
  3204.   UTLD(comp_link_caches_restart),
  3205.   UTLD(comutil_operator_apply_trap),
  3206.   UTLD(comutil_operator_arity_trap),
  3207.   UTLD(comutil_operator_entity_trap),
  3208.   UTLD(comutil_operator_interpreted_trap),
  3209.   UTLD(comutil_operator_lexpr_trap),
  3210.   UTLD(comutil_operator_primitive_trap),
  3211.   UTLD(comutil_operator_lookup_trap),
  3212.   UTLD(comp_op_lookup_trap_restart),
  3213.   UTLD(comutil_operator_1_0_trap),
  3214.   UTLD(comutil_operator_2_1_trap),
  3215.   UTLD(comutil_operator_2_0_trap),
  3216.   UTLD(comutil_operator_3_2_trap),
  3217.   UTLD(comutil_operator_3_1_trap),
  3218.   UTLD(comutil_operator_3_0_trap),
  3219.   UTLD(comutil_operator_4_3_trap),
  3220.   UTLD(comutil_operator_4_2_trap),
  3221.   UTLD(comutil_operator_4_1_trap),
  3222.   UTLD(comutil_operator_4_0_trap),
  3223.   UTLD(compiler_interrupt_common),
  3224.   UTLD(comutil_interrupt_closure),
  3225.   UTLD(comutil_interrupt_dlink),
  3226.   UTLD(comutil_interrupt_procedure),
  3227.   UTLD(comutil_interrupt_continuation),
  3228.   UTLD(comutil_interrupt_ic_procedure),
  3229.   UTLD(comutil_interrupt_continuation_2),
  3230.   UTLD(comp_interrupt_restart),
  3231.  
  3232.   UTLD(comutil_assignment_trap),
  3233.   UTLD(comp_assignment_trap_restart),
  3234.   UTLD(comutil_cache_lookup_apply),
  3235.   UTLD(comp_cache_lookup_apply_restart),
  3236.   UTLD(comutil_lookup_trap),
  3237.   UTLD(comp_lookup_trap_restart),
  3238.   UTLD(comutil_safe_lookup_trap),
  3239.   UTLD(comp_safe_lookup_trap_restart),
  3240.   UTLD(comutil_unassigned_p_trap),
  3241.   UTLD(comp_unassigned_p_trap_restart),
  3242.   UTLD(comutil_decrement),
  3243.   UTLD(comutil_divide),
  3244.   UTLD(comutil_equal),
  3245.   UTLD(comutil_greater),
  3246.   UTLD(comutil_increment),
  3247.   UTLD(comutil_less),
  3248.   UTLD(comutil_minus),
  3249.   UTLD(comutil_modulo),
  3250.   UTLD(comutil_multiply),
  3251.   UTLD(comutil_negative),
  3252.   UTLD(comutil_plus),
  3253.   UTLD(comutil_positive),
  3254.   UTLD(comutil_quotient),
  3255.   UTLD(comutil_remainder),
  3256.   UTLD(comutil_zero),
  3257.   UTLD(comutil_access),
  3258.   UTLD(comp_access_restart),
  3259.   UTLD(comutil_reference),
  3260.   UTLD(comp_reference_restart),
  3261.   UTLD(comutil_safe_reference),
  3262.   UTLD(comp_safe_reference_restart),
  3263.   UTLD(comutil_unassigned_p),
  3264.   UTLD(comp_unassigned_p_restart),
  3265.   UTLD(comutil_unbound_p),
  3266.   UTLD(comp_unbound_p_restart),
  3267.   UTLD(comutil_assignment),
  3268.   UTLD(comp_assignment_restart),
  3269.   UTLD(comutil_definition),
  3270.   UTLD(comp_definition_restart),
  3271.   UTLD(comutil_lookup_apply),
  3272.   UTLD(comp_lookup_apply_restart),
  3273.   UTLD(comutil_primitive_error),
  3274.   UTLD(comp_error_restart),
  3275.   UTLD(compiled_block_debugging_info),
  3276.   UTLD(compiled_block_environment),
  3277.   UTLD(compiled_entry_to_block_address),
  3278.   UTLD(compiled_entry_to_block),
  3279.   UTLD(compiled_entry_to_block_offset),
  3280.   UTLD(block_address_closure_p),
  3281.   UTLD(compiled_block_closure_p),
  3282.   UTLD(compiled_entry_closure_p),
  3283.   UTLD(compiled_closure_to_entry),
  3284.   UTLD(compiled_entry_type),
  3285.   UTLD(declare_compiled_code_block),
  3286.   UTLD(store_variable_cache),
  3287.   UTLD(extract_variable_cache),
  3288.   UTLD(extract_uuo_link),
  3289.   UTLD(store_uuo_link),
  3290.   UTLD(fill_trampoline),
  3291.   UTLD(make_trampoline),
  3292.   UTLD(make_redirection_trampoline),
  3293.   UTLD(make_apply_trampoline),
  3294.   UTLD(make_uuo_link),
  3295.   UTLD(make_fake_uuo_link),
  3296.   UTLD(coerce_to_compiled),
  3297. #ifndef HAVE_BKPT_SUPPORT
  3298.   UTLD(bkpt_install),
  3299.   UTLD(bkpt_closure_install),
  3300.   UTLD(bkpt_remove),
  3301.   UTLD(bkpt_p),
  3302.   UTLD(do_bkpt_proceed),
  3303. #endif 
  3304.   UTLD(bkpt_proceed),
  3305.   UTLD(comutil_compiled_code_bkpt),
  3306.   UTLD(comutil_compiled_closure_bkpt),
  3307.   UTLD(comutil_reflect_to_interface),
  3308.   UTLD(end_of_utils)
  3309. };
  3310.  
  3311. extern char * EXFUN (utility_index_to_name, (int));
  3312. extern int EXFUN (pc_to_utility_index, (unsigned long));
  3313.  
  3314. #define UTIL_TABLE_PC_REF_REAL(index)                    \
  3315.   ((unsigned long) (utility_descriptor_table[index].pc))
  3316.  
  3317. #ifndef UTIL_TABLE_PC_REF
  3318. #  define UTIL_TABLE_PC_REF(index)    (UTIL_TABLE_PC_REF_REAL (index))
  3319. #endif
  3320.  
  3321. static int last_util_table_index =
  3322.   (((sizeof (utility_descriptor_table)) / (sizeof (struct util_descriptor_s)))
  3323.    - 1);
  3324.  
  3325. char *
  3326. DEFUN (utility_index_to_name, (index), int index)
  3327. {
  3328.   if ((index < 0) || (index >= last_util_table_index))
  3329.     return ((char *) NULL);
  3330.   else
  3331.     return (utility_descriptor_table[index].name);
  3332. }
  3333.  
  3334. int
  3335. DEFUN (pc_to_utility_index, (pc), unsigned long pc)
  3336. {
  3337.   /* Binary search */
  3338.  
  3339.   extern int EXFUN (pc_to_builtin_index, (unsigned long));
  3340.  
  3341.   if ((pc < (UTIL_TABLE_PC_REF (0)))
  3342.       || (pc >= (UTIL_TABLE_PC_REF (last_util_table_index))))
  3343.     return (-1);
  3344.   else if (pc < (UTIL_TABLE_PC_REF (1)))
  3345.     return (((pc_to_builtin_index (pc)) == -1) ? 0 : -1);
  3346.   else
  3347.   {
  3348.     int low, high, middle;
  3349.  
  3350.     low = 0;
  3351.     high = last_util_table_index;
  3352.     while ((low + 1) < high)
  3353.     {
  3354.       middle = ((low + high) / 2);
  3355.       if (pc < (UTIL_TABLE_PC_REF (middle)))
  3356.     high = middle;
  3357.       else if (pc > (UTIL_TABLE_PC_REF (middle)))
  3358.     low = middle;
  3359.       else
  3360.     return (middle);
  3361.     }
  3362.     return ((pc == (UTIL_TABLE_PC_REF (high))) ? high : low);
  3363.   }
  3364. }
  3365.  
  3366. extern char * EXFUN (builtin_index_to_name, (int));
  3367. extern void EXFUN (declare_builtin, (unsigned long, char *));
  3368. extern int EXFUN (pc_to_builtin_index, (unsigned long));
  3369. extern unsigned long * builtins;
  3370.  
  3371. static int n_builtins = 0;
  3372. static int s_builtins = 0;
  3373. unsigned long * builtins = ((unsigned long *) NULL);
  3374. char ** builtin_names = ((char **) NULL);
  3375.  
  3376. void
  3377. DEFUN (declare_builtin, (builtin, name),
  3378.        unsigned long builtin AND char * name)
  3379. {
  3380.   if (n_builtins == s_builtins)
  3381.   {
  3382.     if (s_builtins == 0)
  3383.     {
  3384.       s_builtins = 30;
  3385.       builtins = ((unsigned long *)
  3386.           (malloc (s_builtins * (sizeof (unsigned long)))));
  3387.       builtin_names = ((char **) (malloc (s_builtins * (sizeof (char *)))));
  3388.     }
  3389.     else
  3390.     {
  3391.       s_builtins += s_builtins;
  3392.       builtins = ((unsigned long *)
  3393.           (realloc (builtins,
  3394.                 (s_builtins * (sizeof (unsigned long))))));
  3395.       builtin_names = ((char **)
  3396.                (realloc (builtin_names,
  3397.                  (s_builtins * (sizeof (char *))))));
  3398.     }
  3399.     if ((builtins == ((unsigned long *) NULL))
  3400.     || (builtin_names == ((char **) NULL)))
  3401.     {
  3402.       outf_fatal ("declare_builtin: malloc/realloc failed (size = %d).\n",
  3403.           s_builtins);
  3404.       termination_init_error ();
  3405.     }
  3406.   }
  3407.   {
  3408.     unsigned int low = 0;
  3409.     unsigned int high = n_builtins;
  3410.     while (1)
  3411.       {
  3412.     if (low < high)
  3413.       {
  3414.         unsigned int middle = ((low + high) / 2);
  3415.         if (builtin < (builtins[middle]))
  3416.           high = middle;
  3417.         else if (builtin > (builtins[middle]))
  3418.           low = (middle + 1);
  3419.         else
  3420.           {
  3421.         (builtin_names[middle]) = name;
  3422.         return;
  3423.           }
  3424.       }
  3425.     else
  3426.       {
  3427.         unsigned int scan = n_builtins;
  3428.         while (low < scan)
  3429.           {
  3430.         (builtins [scan]) = (builtins [scan - 1]);
  3431.         (builtin_names [scan]) = (builtin_names [scan - 1]);
  3432.         scan -= 1;
  3433.           }
  3434.         (builtins [low]) = builtin;
  3435.         (builtin_names [low]) = name;
  3436.         return;
  3437.       }
  3438.       }
  3439.   }
  3440. }
  3441.  
  3442. char *
  3443. DEFUN (builtin_index_to_name, (index), int index)
  3444. {
  3445.   if ((index < 0) || (index >= n_builtins))
  3446.     return ((char *) NULL);
  3447.   else
  3448.     return (builtin_names[index]);
  3449. }
  3450.  
  3451. int
  3452. DEFUN (pc_to_builtin_index, (pc), unsigned long pc)
  3453. {
  3454.   /* Binary search */
  3455.  
  3456.   if ((builtins == ((unsigned long *) NULL))
  3457.       || (pc < (builtins[0]))
  3458.       || (pc >= (builtins[n_builtins - 1])))
  3459.     return (-1);
  3460.   else
  3461.   {
  3462.     int low, high, middle;
  3463.  
  3464.     low = 0;
  3465.     high = (n_builtins - 1);
  3466.     while ((low + 1) < high)
  3467.     {
  3468.       middle = ((low + high) / 2);
  3469.       if (pc < (builtins[middle]))
  3470.     high = middle;
  3471.       else if (pc > (builtins[middle]))
  3472.     low = middle;
  3473.       else
  3474.     return (middle);
  3475.     }
  3476.     return ((pc == (builtins[high])) ? high : low);
  3477.   }
  3478. }
  3479.  
  3480. /* Initialization */
  3481.  
  3482. #define COMPILER_INTERFACE_VERSION        3
  3483.  
  3484. #ifndef COMPILER_REGBLOCK_N_FIXED
  3485. #  define COMPILER_REGBLOCK_N_FIXED        16
  3486. #endif
  3487.  
  3488. #ifndef COMPILER_REGBLOCK_N_TEMPS
  3489. #  define COMPILER_REGBLOCK_N_TEMPS        256
  3490. #endif
  3491.  
  3492. #ifndef COMPILER_REGBLOCK_EXTRA_SIZE
  3493. #  define COMPILER_REGBLOCK_EXTRA_SIZE        0
  3494. #endif
  3495.  
  3496. #if (REGBLOCK_MINIMUM_LENGTH > COMPILER_REGBLOCK_N_FIXED)
  3497. #  include "ERROR: cmpint.c and const.h disagree on REGBLOCK_MINIMUM_LENGTH!"
  3498. #endif
  3499.  
  3500. /* ((sizeof(SCHEME_OBJECT)) / (sizeof(SCHEME_OBJECT))) */
  3501.  
  3502. #define COMPILER_FIXED_SIZE    1
  3503.  
  3504. #ifndef COMPILER_TEMP_SIZE
  3505. #  define COMPILER_TEMP_SIZE    ((sizeof (double)) / (sizeof (SCHEME_OBJECT)))
  3506. #endif
  3507.  
  3508. #define REGBLOCK_LENGTH                            \
  3509.   ((COMPILER_REGBLOCK_N_FIXED * COMPILER_FIXED_SIZE) +            \
  3510.    (COMPILER_REGBLOCK_N_TEMPS * COMPILER_TEMP_SIZE) +            \
  3511.    COMPILER_REGBLOCK_EXTRA_SIZE)
  3512.  
  3513. #ifndef ASM_RESET_HOOK
  3514. #  define ASM_RESET_HOOK() NOP()
  3515. #endif
  3516.  
  3517. long
  3518.   compiler_processor_type,
  3519.   compiler_interface_version;
  3520.  
  3521. SCHEME_OBJECT
  3522.   compiler_utilities,
  3523.   return_to_interpreter;
  3524.  
  3525. #if !defined(REGBLOCK_ALLOCATED_BY_INTERFACE) && !defined(__WIN32__)
  3526. SCHEME_OBJECT
  3527.   Registers[REGBLOCK_LENGTH];
  3528. #endif
  3529.  
  3530. static void
  3531. DEFUN_VOID (compiler_reset_internal)
  3532. {
  3533.   long len;
  3534.   SCHEME_OBJECT * block;
  3535.  
  3536.   /* Other stuff can be placed here. */
  3537.  
  3538.   block = (OBJECT_ADDRESS (compiler_utilities));
  3539.   len = (OBJECT_DATUM (block[0]));
  3540.  
  3541.   return_to_interpreter =
  3542.     (ENTRY_TO_OBJECT (((char *) block)
  3543.               + ((unsigned long) (block [len - 1]))));
  3544.  
  3545.   reflect_to_interface =
  3546.     (ENTRY_TO_OBJECT (((char *) block)
  3547.               + ((unsigned long) (block [len]))));
  3548.  
  3549.   Regs[REGBLOCK_CLOSURE_FREE] = ((SCHEME_OBJECT) NULL);
  3550.   Regs[REGBLOCK_CLOSURE_SPACE] = ((SCHEME_OBJECT) 0);
  3551.   Regs[REGBLOCK_REFLECT_TO_INTERFACE] = reflect_to_interface;
  3552.  
  3553.   ASM_RESET_HOOK();
  3554.  
  3555.   return;
  3556. }
  3557.  
  3558. #define COMPILER_UTILITIES_N_ENTRIES    2
  3559. #define COMPILER_UTILITIES_LENGTH                    \
  3560.  ((COMPILER_UTILITIES_N_ENTRIES * (TRAMPOLINE_ENTRY_SIZE + 1)) + 2)
  3561.  
  3562. C_UTILITY void
  3563. DEFUN (compiler_initialize, (fasl_p), long fasl_p)
  3564. {
  3565.   /* Start-up of whole interpreter */
  3566.  
  3567.   Regs[REGBLOCK_PRIMITIVE] = SHARP_F;
  3568.   compiler_processor_type = COMPILER_PROCESSOR_TYPE;
  3569.   compiler_interface_version = COMPILER_INTERFACE_VERSION;
  3570.   if (fasl_p)
  3571.   {
  3572.     long len;
  3573.     instruction * tramp1, * tramp2;
  3574.     SCHEME_OBJECT * block;
  3575.     extern SCHEME_OBJECT * EXFUN (copy_to_constant_space,
  3576.                   (SCHEME_OBJECT *, long));
  3577.  
  3578.     len = COMPILER_UTILITIES_LENGTH;
  3579.     if (GC_Check (len))
  3580.     {
  3581.       outf_fatal ("compiler_initialize: Not enough space!\n");
  3582.       Microcode_Termination (TERM_NO_SPACE);
  3583.     }
  3584.  
  3585.     block = Free;
  3586.     Free += len;
  3587.     block[0] = (MAKE_OBJECT (TC_MANIFEST_VECTOR, (len - 1)));
  3588.     block[1] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
  3589.                  (COMPILER_UTILITIES_N_ENTRIES
  3590.                   * TRAMPOLINE_ENTRY_SIZE)));
  3591.  
  3592.     tramp1 = ((instruction *) (TRAMPOLINE_ENTRY_POINT (block)));
  3593.     fill_trampoline (block, tramp1,
  3594.              ((format_word) FORMAT_WORD_RETURN),
  3595.              TRAMPOLINE_K_RETURN);
  3596.     block[len - 2] = (((char *) tramp1) - ((char *) block));
  3597.  
  3598.     tramp2 = ((instruction *)
  3599.           (((char *) tramp1)
  3600.            + (TRAMPOLINE_ENTRY_SIZE * (sizeof (SCHEME_OBJECT)))));
  3601.     fill_trampoline (block, tramp2,
  3602.              ((format_word) FORMAT_WORD_RETURN),
  3603.              TRAMPOLINE_K_REFLECT_TO_INTERFACE);
  3604.     block[len - 1] = (((char *) tramp2) - ((char *) block));
  3605.  
  3606.     block = (copy_to_constant_space (block, len));
  3607.     compiler_utilities = (MAKE_CC_BLOCK (block));
  3608.     compiler_reset_internal ();
  3609.   }
  3610.   else
  3611.   {
  3612.     /* Delay until after band-load, when compiler_reset will be invoked. */
  3613.     compiler_utilities = SHARP_F;
  3614.     return_to_interpreter = SHARP_F;
  3615. #ifdef sonyrisc
  3616.     /* On the Sony NEWS 3250, this procedure initializes the
  3617.        floating-point CPU control register to enable the IEEE traps.
  3618.        This is normally executed by `compiler_reset' from LOAD-BAND,
  3619.        but the Sony operating system saves the control register in
  3620.        `setjmp' and restores it on `longjmp', so we must initialize
  3621.        the register before `setjmp' is called.  */
  3622.     interface_initialize ();
  3623. #endif
  3624. #ifdef __OS2__
  3625.     /* Same as for Sony.  */
  3626.     i386_interface_initialize ();
  3627. #endif
  3628.   }
  3629.   return;
  3630. }
  3631.  
  3632. C_UTILITY void
  3633. DEFUN (compiler_reset,
  3634.        (new_block),
  3635.        SCHEME_OBJECT new_block)
  3636. {
  3637.   /* Called after a disk restore */
  3638.  
  3639.   if ((OBJECT_TYPE (new_block)) != TC_COMPILED_CODE_BLOCK)
  3640.   {
  3641.     extern void EXFUN (compiler_reset_error, (void));
  3642.  
  3643. lose:
  3644.     compiler_reset_error ();
  3645.     return;
  3646.   }
  3647.   else if ((MEMORY_REF (new_block, 0))
  3648.        != (MAKE_OBJECT (TC_MANIFEST_VECTOR,
  3649.                 (COMPILER_UTILITIES_LENGTH - 1))))
  3650.   {
  3651.     /* Backwards compatibility */
  3652.     if ((MEMORY_REF (new_block, 0))
  3653.     != (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
  3654.              (COMPILER_UTILITIES_N_ENTRIES
  3655.               * (TRAMPOLINE_ENTRY_SIZE + 1)))))
  3656.       goto lose;
  3657.   }
  3658.   else if ((MEMORY_REF (new_block, 1))
  3659.        != (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR,
  3660.                 (COMPILER_UTILITIES_N_ENTRIES
  3661.                  * TRAMPOLINE_ENTRY_SIZE))))
  3662.     goto lose;
  3663.  
  3664.   compiler_utilities = new_block;
  3665.   compiler_reset_internal ();
  3666.   return;
  3667. }
  3668.  
  3669. #ifndef NATIVE_CODE_IS_C
  3670.  
  3671. SCHEME_OBJECT *
  3672. DEFUN (cons_c_code_table, (start, limit, length),
  3673.        SCHEME_OBJECT * start
  3674.        AND SCHEME_OBJECT * limit
  3675.        AND long * length)
  3676. {
  3677.   * length = 0;
  3678.   return (start);
  3679. }
  3680.  
  3681. Boolean
  3682. DEFUN (install_c_code_table, (table, length),
  3683.        SCHEME_OBJECT * table AND long length)
  3684. {
  3685.   return (length == 0);
  3686. }
  3687.  
  3688. #endif /* NATIVE_CODE_IS_C */
  3689.  
  3690. #else    /* not HAS_COMPILER_SUPPORT */
  3691.  
  3692. /* Stubs for compiler utilities.
  3693.    All entries error out or kill the microcode.
  3694.  */
  3695.  
  3696. extern void EXFUN (Microcode_Termination, (int code));
  3697. extern void EXFUN (compiler_reset_error, (void));
  3698.  
  3699. extern long
  3700.   compiler_interface_version,
  3701.   compiler_processor_type;
  3702.  
  3703. extern SCHEME_OBJECT
  3704.   compiler_utilities,
  3705.   return_to_interpreter;
  3706.  
  3707. extern long
  3708.   EXFUN (enter_compiled_expression, (void)),
  3709.   EXFUN (apply_compiled_procedure, (void)),
  3710.   EXFUN (return_to_compiled_code, (void)),
  3711.   EXFUN (make_fake_uuo_link,
  3712.      (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
  3713.   EXFUN (make_uuo_link,
  3714.      (SCHEME_OBJECT value, SCHEME_OBJECT extension,
  3715.       SCHEME_OBJECT block, long offset)),
  3716.   EXFUN (compiled_block_closure_p, (SCHEME_OBJECT block)),
  3717.   EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT entry)),
  3718.   EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT entry)),
  3719.   EXFUN (coerce_to_compiled,
  3720.      (SCHEME_OBJECT object, long arity, SCHEME_OBJECT *location));
  3721.  
  3722. extern SCHEME_OBJECT
  3723.   EXFUN (extract_uuo_link, (SCHEME_OBJECT block, long offset)),
  3724.   EXFUN (extract_variable_cache,
  3725.      (SCHEME_OBJECT extension, long offset)),
  3726.   EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT block)),
  3727.   EXFUN (compiled_block_environment, (SCHEME_OBJECT block)),
  3728.   EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT entry)),
  3729.   * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT entry)),
  3730.   EXFUN (compiled_entry_to_block, (SCHEME_OBJECT entry)),
  3731.   EXFUN (apply_compiled_from_primitive, (int)),
  3732.   EXFUN (compiled_with_interrupt_mask, (unsigned long,
  3733.                     SCHEME_OBJECT,
  3734.                     unsigned long)),
  3735.   EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT)),
  3736.   * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
  3737.  
  3738. extern Boolean
  3739.   EXFUN (install_c_code_table, (SCHEME_OBJECT *, long));
  3740.  
  3741. extern void
  3742.   EXFUN (compiler_reset, (SCHEME_OBJECT new_block)),
  3743.   EXFUN (compiler_initialize, (long fasl_p)),
  3744.   EXFUN (store_variable_cache,
  3745.      (SCHEME_OBJECT extension, SCHEME_OBJECT block, long offset)),
  3746.   EXFUN (compiled_entry_type, (SCHEME_OBJECT entry, long *buffer)),
  3747.   EXFUN (declare_compiled_code_block, (SCHEME_OBJECT block));
  3748.  
  3749. /* Breakpoint stuff. */
  3750.  
  3751. extern SCHEME_OBJECT EXFUN (bkpt_install, (PTR));
  3752. extern SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR));
  3753. extern Boolean EXFUN (bkpt_p, (PTR));
  3754. extern SCHEME_OBJECT EXFUN (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT));
  3755. extern void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT));
  3756.  
  3757. SCHEME_OBJECT
  3758. #ifndef __WIN32__
  3759.   Registers[REGBLOCK_MINIMUM_LENGTH],
  3760. #endif
  3761.   compiler_utilities,
  3762.   return_to_interpreter;
  3763.  
  3764. long
  3765.   compiler_interface_version,
  3766.   compiler_processor_type;
  3767.  
  3768. long
  3769. DEFUN_VOID (enter_compiled_expression)
  3770. {
  3771.   return (ERR_EXECUTE_MANIFEST_VECTOR);
  3772. }
  3773.  
  3774. long
  3775. DEFUN_VOID (apply_compiled_procedure)
  3776. {
  3777.   return (ERR_INAPPLICABLE_OBJECT);
  3778. }
  3779.  
  3780. long
  3781. DEFUN_VOID (return_to_compiled_code)
  3782. {
  3783.   return (ERR_INAPPLICABLE_CONTINUATION);
  3784. }
  3785.  
  3786. SCHEME_OBJECT
  3787. DEFUN (apply_compiled_from_primitive, (arity), int arity)
  3788. {
  3789.   signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
  3790.   /*NOTREACHED*/
  3791. }
  3792.  
  3793. SCHEME_OBJECT
  3794. DEFUN (compiled_with_interrupt_mask, (old_mask, receiver, new_mask),
  3795.        unsigned long old_mask
  3796.        AND SCHEME_OBJECT receiver
  3797.        AND unsigned long new_mask)
  3798. {
  3799.   signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
  3800.   /*NOTREACHED*/
  3801. }
  3802.  
  3803. SCHEME_OBJECT
  3804. DEFUN (compiled_with_stack_marker, (thunk), SCHEME_OBJECT thunk)
  3805. {
  3806.   signal_error_from_primitive (ERR_INAPPLICABLE_CONTINUATION);
  3807.   /*NOTREACHED*/
  3808. }
  3809.  
  3810. SCHEME_OBJECT *
  3811. DEFUN (cons_c_code_table, (start, limit, length),
  3812.        SCHEME_OBJECT * start
  3813.        AND SCHEME_OBJECT * limit
  3814.        AND long * length)
  3815. {
  3816.   * length = 0;
  3817.   return (start);
  3818. }
  3819.  
  3820. Boolean
  3821. DEFUN (install_c_code_table, (table, length),
  3822.        SCHEME_OBJECT * table AND long length)
  3823. {
  3824.   return (length == 0);
  3825. }
  3826.  
  3827. /* Bad entry points. */
  3828.  
  3829. long
  3830. DEFUN (make_fake_uuo_link,
  3831.        (extension, block, offset),
  3832.        SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
  3833.        long offset)
  3834. {
  3835.   Microcode_Termination (TERM_COMPILER_DEATH);
  3836.   /*NOTREACHED*/
  3837. }
  3838.  
  3839. long
  3840. DEFUN (make_uuo_link,
  3841.        (value, extension, block, offset),
  3842.        SCHEME_OBJECT value AND SCHEME_OBJECT extension AND
  3843.        SCHEME_OBJECT block AND long offset)
  3844. {
  3845.   Microcode_Termination (TERM_COMPILER_DEATH);
  3846.   /*NOTREACHED*/
  3847. }
  3848.  
  3849. SCHEME_OBJECT
  3850. DEFUN (extract_uuo_link,
  3851.        (block, offset),
  3852.        SCHEME_OBJECT block AND long offset)
  3853. {
  3854.   Microcode_Termination (TERM_COMPILER_DEATH);
  3855.   /*NOTREACHED*/
  3856. }
  3857.  
  3858. void
  3859. DEFUN (store_variable_cache,
  3860.        (extension, block, offset),
  3861.        SCHEME_OBJECT extension AND SCHEME_OBJECT block AND
  3862.        long offset)
  3863. {
  3864.   Microcode_Termination (TERM_COMPILER_DEATH);
  3865.   /*NOTREACHED*/
  3866. }
  3867.  
  3868. SCHEME_OBJECT
  3869. DEFUN (extract_variable_cache,
  3870.        (block, offset),
  3871.        SCHEME_OBJECT block AND
  3872.        long offset)
  3873. {
  3874.   Microcode_Termination (TERM_COMPILER_DEATH);
  3875.   /*NOTREACHED*/
  3876. }
  3877.  
  3878. SCHEME_OBJECT
  3879. DEFUN (compiled_block_debugging_info,
  3880.        (block),
  3881.        SCHEME_OBJECT block)
  3882. {
  3883.   Microcode_Termination (TERM_COMPILER_DEATH);
  3884.   /*NOTREACHED*/
  3885. }
  3886.  
  3887. SCHEME_OBJECT
  3888. DEFUN (compiled_block_environment,
  3889.        (block),
  3890.        SCHEME_OBJECT block)
  3891. {
  3892.   Microcode_Termination (TERM_COMPILER_DEATH);
  3893.   /*NOTREACHED*/
  3894. }
  3895.  
  3896. long
  3897. DEFUN (compiled_block_closure_p,
  3898.        (block),
  3899.        SCHEME_OBJECT block)
  3900. {
  3901.   Microcode_Termination (TERM_COMPILER_DEATH);
  3902.   /*NOTREACHED*/
  3903. }
  3904.  
  3905. SCHEME_OBJECT *
  3906. DEFUN (compiled_entry_to_block_address,
  3907.        (entry),
  3908.        SCHEME_OBJECT entry)
  3909. {
  3910.   Microcode_Termination (TERM_COMPILER_DEATH);
  3911.   /*NOTREACHED*/
  3912. }
  3913.  
  3914. long
  3915. DEFUN (compiled_entry_to_block_offset,
  3916.        (entry),
  3917.        SCHEME_OBJECT entry)
  3918. {
  3919.   Microcode_Termination (TERM_COMPILER_DEATH);
  3920.   /*NOTREACHED*/
  3921. }
  3922.  
  3923. SCHEME_OBJECT
  3924. DEFUN (compiled_entry_to_block,
  3925.        (entry),
  3926.        SCHEME_OBJECT entry)
  3927. {
  3928.   Microcode_Termination (TERM_COMPILER_DEATH);
  3929.   /*NOTREACHED*/
  3930. }
  3931.  
  3932.  
  3933. void
  3934. DEFUN (compiled_entry_type,
  3935.        (entry, buffer),
  3936.        SCHEME_OBJECT entry AND long *buffer)
  3937. {
  3938.   Microcode_Termination (TERM_COMPILER_DEATH);
  3939.   /*NOTREACHED*/
  3940. }
  3941.  
  3942. long
  3943. DEFUN (compiled_entry_closure_p,
  3944.        (entry),
  3945.        SCHEME_OBJECT entry)
  3946. {
  3947.   Microcode_Termination (TERM_COMPILER_DEATH);
  3948.   /*NOTREACHED*/
  3949. }
  3950.  
  3951. SCHEME_OBJECT
  3952. DEFUN (compiled_closure_to_entry, (entry), SCHEME_OBJECT entry)
  3953. {
  3954.   Microcode_Termination (TERM_COMPILER_DEATH);
  3955.   /*NOTREACHED*/
  3956. }
  3957.  
  3958. void
  3959. DEFUN (declare_compiled_code_block, (block), SCHEME_OBJECT block)
  3960. {
  3961.   return;
  3962. }
  3963.  
  3964. #define LOSING_RETURN_ADDRESS(name)                    \
  3965. extern long EXFUN (name, (void));                    \
  3966. long                                    \
  3967. DEFUN_VOID (name)                            \
  3968. {                                    \
  3969.   Microcode_Termination (TERM_COMPILER_DEATH);                \
  3970.   /*NOTREACHED*/                            \
  3971. }
  3972.  
  3973. LOSING_RETURN_ADDRESS (comp_interrupt_restart)
  3974. LOSING_RETURN_ADDRESS (comp_lookup_apply_restart)
  3975. LOSING_RETURN_ADDRESS (comp_reference_restart)
  3976. LOSING_RETURN_ADDRESS (comp_access_restart)
  3977. LOSING_RETURN_ADDRESS (comp_unassigned_p_restart)
  3978. LOSING_RETURN_ADDRESS (comp_unbound_p_restart)
  3979. LOSING_RETURN_ADDRESS (comp_assignment_restart)
  3980. LOSING_RETURN_ADDRESS (comp_definition_restart)
  3981. LOSING_RETURN_ADDRESS (comp_safe_reference_restart)
  3982. LOSING_RETURN_ADDRESS (comp_lookup_trap_restart)
  3983. LOSING_RETURN_ADDRESS (comp_assignment_trap_restart)
  3984. LOSING_RETURN_ADDRESS (comp_op_lookup_trap_restart)
  3985. LOSING_RETURN_ADDRESS (comp_cache_lookup_apply_restart)
  3986. LOSING_RETURN_ADDRESS (comp_safe_lookup_trap_restart)
  3987. LOSING_RETURN_ADDRESS (comp_unassigned_p_trap_restart)
  3988. LOSING_RETURN_ADDRESS (comp_link_caches_restart)
  3989. LOSING_RETURN_ADDRESS (comp_error_restart)
  3990.  
  3991. /* NOP entry points */
  3992.  
  3993. void
  3994. DEFUN (compiler_reset, (new_block), SCHEME_OBJECT new_block)
  3995. {
  3996.   extern void EXFUN (compiler_reset_error, (void));
  3997.  
  3998.   if (new_block != SHARP_F)
  3999.     compiler_reset_error ();
  4000.   return;
  4001. }
  4002.  
  4003. void
  4004. DEFUN (compiler_initialize, (fasl_p), long fasl_p)
  4005. {
  4006.   Regs[REGBLOCK_PRIMITIVE] = SHARP_F;
  4007.   compiler_processor_type = 0;
  4008.   compiler_interface_version = 0;
  4009.   compiler_utilities = SHARP_F;
  4010.   return_to_interpreter =
  4011.     (MAKE_OBJECT (TC_RETURN_CODE, RC_POP_FROM_COMPILED_CODE));
  4012.   return;
  4013. }
  4014.  
  4015. /* Identity procedure */
  4016.  
  4017. long
  4018. DEFUN (coerce_to_compiled,
  4019.        (object, arity, location),
  4020.        SCHEME_OBJECT object AND long arity AND SCHEME_OBJECT *location)
  4021. {
  4022.   *location = object;
  4023.   return (PRIM_DONE);
  4024. }
  4025.  
  4026. extern char * EXFUN (utility_index_to_name, (int));
  4027. extern void EXFUN (declare_builtin, (unsigned long));
  4028. extern char * EXFUN (builtin_index_to_name, (int));
  4029. extern int EXFUN (pc_to_utility_index, (unsigned long));
  4030. extern int EXFUN (pc_to_builtin_index, (unsigned long));
  4031.  
  4032. char *
  4033. DEFUN (utility_index_to_name, (index), int index)
  4034. {
  4035.   return ((char *) NULL);
  4036. }
  4037.  
  4038. void
  4039. DEFUN (declare_builtin, (builtin), unsigned long builtin)
  4040. {
  4041.   return;
  4042. }
  4043.  
  4044. char *
  4045. DEFUN (builtin_index_to_name, (index), int index)
  4046. {
  4047.   return ((char *) NULL);
  4048. }
  4049.  
  4050. int
  4051. DEFUN (pc_to_utility_index, (pc), unsigned long pc)
  4052. {
  4053.   return (-1);
  4054. }
  4055.  
  4056. int
  4057. DEFUN (pc_to_builtin_index, (pc), unsigned long pc)
  4058. {
  4059.   return (-1);
  4060. }
  4061.  
  4062. SCHEME_OBJECT
  4063. DEFUN (bkpt_install, (ep), PTR ep)
  4064. {
  4065.   return (SHARP_F);
  4066. }
  4067.  
  4068. SCHEME_OBJECT
  4069. DEFUN (bkpt_closure_install, (ep), PTR ep)
  4070. {
  4071.   return (SHARP_F);
  4072. }
  4073.  
  4074. void
  4075. DEFUN (bkpt_remove, (ep, handle), PTR ep AND SCHEME_OBJECT handle)
  4076. {
  4077.   error_external_return ();
  4078. }
  4079.  
  4080. Boolean
  4081. DEFUN (bkpt_p, (ep), PTR ep)
  4082. {
  4083.   return (SHARP_F);
  4084. }
  4085.  
  4086. SCHEME_OBJECT
  4087. DEFUN (bkpt_proceed, (ep, handle, state), 
  4088.        PTR ep AND SCHEME_OBJECT handle AND SCHEME_OBJECT state)
  4089. {
  4090.   error_external_return ();
  4091. }
  4092.  
  4093. #endif    /* HAS_COMPILER_SUPPORT */
  4094.  
  4095. #ifdef __WIN32__
  4096. #include "ntscmlib.h"
  4097.  
  4098. extern unsigned long * win32_catatonia_block;
  4099. extern void EXFUN (win32_allocate_registers, (void));
  4100. extern void EXFUN (win32_allocate_registers, (void));
  4101.  
  4102. #ifndef REGBLOCK_LENGTH
  4103. #  define REGBLOCK_LENGTH REGBLOCK_MINIMUM_LENGTH
  4104. #endif
  4105.  
  4106. typedef struct register_storage
  4107. {
  4108.   /* The following must be allocated consecutively */
  4109.   unsigned long catatonia_block[3];
  4110. #if (COMPILER_PROCESSOR_TYPE == COMPILER_IA32_TYPE)
  4111.   void * Regstart[32];    /* Negative byte offsets from &Registers[0] */
  4112. #endif
  4113.   SCHEME_OBJECT Registers [REGBLOCK_LENGTH];
  4114. } REGMEM;
  4115.  
  4116. SCHEME_OBJECT * RegistersPtr = ((SCHEME_OBJECT *) NULL);
  4117. unsigned long * win32_catatonia_block = ((unsigned long *) NULL);
  4118. static REGMEM regmem;
  4119.  
  4120. void
  4121. DEFUN_VOID (win32_allocate_registers)
  4122. {
  4123.   REGMEM * mem = & regmem;
  4124.  
  4125.   win32_catatonia_block = ((unsigned long *) &mem->catatonia_block[0]);
  4126.   RegistersPtr = mem->Registers;
  4127.   if (! (win32_system_utilities.lock_memory_area (mem, (sizeof (REGMEM)))))
  4128.   {
  4129.     outf_error ("Unable to lock registers\n");
  4130.     outf_flush_error ();
  4131.   }
  4132.   return;
  4133. }
  4134.  
  4135. void
  4136. DEFUN_VOID (win32_deallocate_registers)
  4137. {
  4138.   win32_system_utilities.unlock_memory_area (®mem, (sizeof (REGMEM)));
  4139.   return;
  4140. }
  4141.  
  4142. #endif /* __WIN32__ */
  4143.