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 / utils.c < prev    next >
C/C++ Source or Header  |  2001-03-08  |  34KB  |  1,169 lines
  1. /* -*-C-*-
  2.  
  3. $Id: utils.c,v 9.78 2001/03/08 18:24:30 cph Exp $
  4.  
  5. Copyright (c) 1987-2001 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. /* This file contains utilities for interrupts, errors, etc. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "winder.h"
  27. #include "history.h"
  28. #include "cmpint.h"
  29. #include "syscall.h"
  30.  
  31. #ifdef __OS2__
  32. extern void OS2_handle_attention_interrupt (void);
  33. #endif
  34.  
  35. /* Helper procedures for Setup_Interrupt, which follows. */
  36.  
  37. static long
  38. DEFUN (compute_interrupt_number, (masked_interrupts),
  39.        long masked_interrupts)
  40. {
  41.   long interrupt_number = 0;
  42.   long bit_mask = 1;
  43.   while ((interrupt_number <= MAX_INTERRUPT_NUMBER)
  44.      && ((masked_interrupts & bit_mask) == 0))
  45.     {
  46.       interrupt_number += 1;
  47.       bit_mask <<= 1;
  48.     }
  49.   return (interrupt_number);
  50. }
  51.  
  52. /* This default is solely for compatibility with the previous behavior
  53.    of the microcode.  It is not a good default and should be
  54.    overridden by the runtime system.  */
  55. #define DEFAULT_INTERRUPT_HANDLER_MASK(interrupt_number)        \
  56.   ((1 << (interrupt_number)) - 1)
  57.  
  58. static long
  59. DEFUN (compute_interrupt_handler_mask, (interrupt_masks, interrupt_number),
  60.        SCHEME_OBJECT interrupt_masks AND
  61.        long interrupt_number)
  62. {
  63.   if ((VECTOR_P (interrupt_masks))
  64.       && (interrupt_number <= ((long) (VECTOR_LENGTH (interrupt_masks)))))
  65.     {
  66.       SCHEME_OBJECT mask =
  67.     (VECTOR_REF (interrupt_masks, interrupt_number));
  68.       if ((INTEGER_P (mask)) && (integer_to_long_p (mask)))
  69.     /* Guarantee that the given interrupt is disabled.  */
  70.     return ((integer_to_long (mask)) &~ (1 << interrupt_number));
  71.     }
  72.   return
  73.     ((interrupt_number <= MAX_INTERRUPT_NUMBER)
  74.      ? (DEFAULT_INTERRUPT_HANDLER_MASK (interrupt_number))
  75.      : (FETCH_INTERRUPT_MASK ()));
  76. }
  77.  
  78. static void
  79. DEFUN (terminate_no_interrupt_handler, (masked_interrupts),
  80.        long masked_interrupts)
  81. {
  82.   outf_fatal("\nInterrupts = 0x%08lx, Mask = 0x%08lx, Masked = 0x%08lx\n",
  83.          (FETCH_INTERRUPT_CODE ()),
  84.          (FETCH_INTERRUPT_MASK ()),
  85.          masked_interrupts);
  86.   Microcode_Termination (TERM_NO_INTERRUPT_HANDLER);
  87. }
  88.  
  89. SCHEME_OBJECT
  90. DEFUN_VOID (initialize_interrupt_handler_vector)
  91. {
  92.   return (make_vector ((MAX_INTERRUPT_NUMBER + 2), SHARP_F, false));
  93. }
  94.  
  95. SCHEME_OBJECT
  96. DEFUN_VOID (initialize_interrupt_mask_vector)
  97. {
  98.   SCHEME_OBJECT result =
  99.     (make_vector ((MAX_INTERRUPT_NUMBER + 2), SHARP_F, false));
  100.   long interrupt_number;
  101.  
  102.   for (interrupt_number = 0;
  103.        (interrupt_number <= MAX_INTERRUPT_NUMBER);
  104.        interrupt_number += 1)
  105.     VECTOR_SET
  106.       (result, interrupt_number,
  107.        (long_to_integer (DEFAULT_INTERRUPT_HANDLER_MASK (interrupt_number))));
  108.   return (result);
  109. }
  110.  
  111. /* Setup_Interrupt is called from the Interrupt macro to do all of the
  112.    setup for calling the user's interrupt routines. */
  113.  
  114. void
  115. DEFUN (Setup_Interrupt, (masked_interrupts), long masked_interrupts)
  116. {
  117.   SCHEME_OBJECT interrupt_handlers = SHARP_F;
  118.   SCHEME_OBJECT interrupt_masks = SHARP_F;
  119.   long interrupt_number = (compute_interrupt_number (masked_interrupts));
  120.   long interrupt_mask;
  121.   SCHEME_OBJECT interrupt_handler;
  122.  
  123. #ifdef __OS2__
  124.   if ((1 << interrupt_number) == INT_Global_1)
  125.     {
  126.       OS2_handle_attention_interrupt ();
  127.       abort_to_interpreter (PRIM_POP_RETURN);
  128.     }
  129. #endif /* __OS2__ */
  130.   if (! (Valid_Fixed_Obj_Vector ()))
  131.     {
  132.       outf_fatal ("\nInvalid fixed-objects vector.");
  133.       terminate_no_interrupt_handler (masked_interrupts);
  134.     }
  135.   interrupt_handlers = (Get_Fixed_Obj_Slot (System_Interrupt_Vector));
  136.   interrupt_masks = (Get_Fixed_Obj_Slot (FIXOBJ_INTERRUPT_MASK_VECTOR));
  137.   if (! (VECTOR_P (interrupt_handlers)))
  138.     {
  139.       outf_fatal ("\nInvalid handlers vector (0x%lx).", interrupt_handlers);
  140.       terminate_no_interrupt_handler (masked_interrupts);
  141.     }
  142.   if (interrupt_number >= ((long) (VECTOR_LENGTH (interrupt_handlers))))
  143.     {
  144.       outf_fatal("\nInterrupt out of range: %ld (vector length = %ld).",
  145.          interrupt_number,
  146.          (VECTOR_LENGTH (interrupt_handlers)));
  147.       terminate_no_interrupt_handler (masked_interrupts);
  148.     }
  149.   interrupt_mask =
  150.     (compute_interrupt_handler_mask (interrupt_masks, interrupt_number));
  151.   Global_Interrupt_Hook ();
  152.   interrupt_handler = (VECTOR_REF (interrupt_handlers, interrupt_number));
  153.  
  154. #if 0
  155.   /* This label may be used in Global_Interrupt_Hook: */
  156.  passed_checks:
  157. #endif
  158.   Stop_History ();
  159.   preserve_interrupt_mask ();
  160.  Will_Push (STACK_ENV_EXTRA_SLOTS + 3);
  161.  
  162.   /* There used to be some code here for gc checks, but that is done
  163.      uniformly now by RC_NORMAL_GC_DONE. */
  164.  
  165.   /* Now make an environment frame for use in calling the
  166.      user supplied interrupt routine.  It will be given two arguments:
  167.      the UNmasked interrupt requests, and the currently enabled
  168.      interrupts.  */
  169.   STACK_PUSH (LONG_TO_FIXNUM (FETCH_INTERRUPT_MASK ()));
  170.   STACK_PUSH (LONG_TO_FIXNUM (FETCH_INTERRUPT_CODE ()));
  171.   STACK_PUSH (interrupt_handler);
  172.   STACK_PUSH (STACK_FRAME_HEADER + 2);
  173.  Pushed ();
  174.   /* Turn off interrupts: */
  175.   SET_INTERRUPT_MASK (interrupt_mask);
  176. }
  177.  
  178. /* Error processing utilities */
  179.  
  180. void
  181. DEFUN (err_print, (error_code, where), long error_code AND outf_channel where)
  182. {
  183.   extern char * Error_Names [];
  184.  
  185.   if (error_code > MAX_ERROR)
  186.     outf (where, "Unknown error code 0x%lx.\n", error_code);
  187.   else
  188.     outf (where, "Error code 0x%lx (%s).\n",
  189.          error_code,
  190.          (Error_Names [error_code]));
  191.   return;
  192. }
  193.  
  194. extern long death_blow;
  195. long death_blow;
  196.  
  197. void
  198. DEFUN (error_death, (code, message), long code AND char * message)
  199. {
  200.   death_blow = code;
  201.   outf_fatal ("\nMicrocode Error: %s.\n", message);
  202.   err_print (code, fatal_output);
  203.   outf_error ("\n**** Stack Trace ****\n\n");
  204.   Back_Trace (error_output);
  205.   termination_no_error_handler ();
  206.   /*NOTREACHED*/
  207. }
  208.  
  209. void
  210. DEFUN_VOID (Stack_Death)
  211. {
  212.   outf_fatal("\nWill_Push vs. Pushed inconsistency.\n");
  213.   Microcode_Termination (TERM_BAD_STACK);
  214.   /*NOTREACHED*/
  215. }
  216.  
  217. void
  218. DEFUN_VOID (preserve_interrupt_mask)
  219. {
  220.  Will_Push (CONTINUATION_SIZE);
  221.   Store_Return (RC_RESTORE_INT_MASK);
  222.   Store_Expression (LONG_TO_FIXNUM (FETCH_INTERRUPT_MASK ()));
  223.   Save_Cont ();
  224.  Pushed ();
  225.   return;
  226. }
  227.  
  228. /* back_out_of_primitive sets the registers up so that the backout
  229.    mechanism in interpret.c will cause the primitive to be
  230.    restarted if the error/interrupt is proceeded. */
  231.  
  232. void
  233. DEFUN_VOID (back_out_of_primitive_internal)
  234. {
  235.   long nargs;
  236.   SCHEME_OBJECT primitive;
  237.  
  238.   /* Setup a continuation to return to compiled code if the primitive is
  239.      restarted and completes successfully. */
  240.  
  241.   primitive = (Regs [REGBLOCK_PRIMITIVE]);
  242.   if (! (PRIMITIVE_P (primitive)))
  243.     {
  244.       outf_fatal(
  245.           "\nback_out_of_primitive backing out when not in primitive!\n");
  246.       Microcode_Termination (TERM_BAD_BACK_OUT);
  247.     }
  248.   nargs = (PRIMITIVE_N_ARGUMENTS (primitive));
  249.   if (COMPILED_CODE_ADDRESS_P (STACK_REF (nargs)))
  250.     compiler_apply_procedure (nargs);
  251.   STACK_PUSH (primitive);
  252.   STACK_PUSH (STACK_FRAME_HEADER + nargs);
  253.   Store_Env (MAKE_OBJECT (GLOBAL_ENV, END_OF_CHAIN));
  254.   Val = SHARP_F;
  255.   Store_Return (RC_INTERNAL_APPLY);
  256.   Store_Expression (SHARP_F);
  257.   (Regs [REGBLOCK_PRIMITIVE]) = SHARP_F;
  258.   return;
  259. }
  260.  
  261. void
  262. DEFUN_VOID (back_out_of_primitive)
  263. {
  264.   back_out_of_primitive_internal ();
  265.   Save_Cont ();
  266.   return;
  267. }
  268.  
  269. /* canonicalize_primitive_context should be used by "unsafe" primitives
  270.    to guarantee that their execution context is the expected one, ie.
  271.    they are called from the interpreter.
  272.    If they are called from compiled code, they should abort to the
  273.    interpreter and reenter.
  274.    Note: This is called only from the macro PRIMITIVE_CANONICALIZE_CONTEXT,
  275.    so that the work can be divided between them if it is an issue. */
  276.  
  277. void
  278. DEFUN_VOID (canonicalize_primitive_context)
  279. {
  280.   long nargs;
  281.   SCHEME_OBJECT primitive;
  282.  
  283.   primitive = (Regs [REGBLOCK_PRIMITIVE]);
  284.   if (! (PRIMITIVE_P (primitive)))
  285.     {
  286.       outf_fatal
  287.     ("\ncanonicalize_primitive_context invoked when not in primitive!\n");
  288.       Microcode_Termination (TERM_BAD_BACK_OUT);
  289.     }
  290.   nargs = (PRIMITIVE_N_ARGUMENTS (primitive));
  291.   if (! (COMPILED_CODE_ADDRESS_P (STACK_REF (nargs))))
  292.     return;
  293.   /* The primitive has been invoked from compiled code. */
  294.   PRIMITIVE_ABORT (PRIM_REENTER);
  295.   /*NOTREACHED*/
  296. }
  297.  
  298. /* Useful error procedures */
  299.  
  300. /* Note that backing out of the primitives happens after aborting,
  301.    not before.
  302.    This guarantees that the interpreter state is consistent, since the
  303.    longjmp restores the relevant registers even if the primitive was
  304.    invoked from compiled code. */
  305.  
  306. void
  307. DEFUN (signal_error_from_primitive, (error_code), long error_code)
  308. {
  309.   PRIMITIVE_ABORT (error_code);
  310.   /*NOTREACHED*/
  311. }
  312.  
  313. void
  314. DEFUN_VOID (signal_interrupt_from_primitive)
  315. {
  316.   PRIMITIVE_ABORT (PRIM_INTERRUPT);
  317.   /*NOTREACHED*/
  318. }
  319.  
  320. void
  321. DEFUN (error_wrong_type_arg, (n), int n)
  322. {
  323.   fast long error_code;
  324.  
  325.   switch (n)
  326.     {
  327.     case 1: error_code = ERR_ARG_1_WRONG_TYPE; break;
  328.     case 2: error_code = ERR_ARG_2_WRONG_TYPE; break;
  329.     case 3: error_code = ERR_ARG_3_WRONG_TYPE; break;
  330.     case 4: error_code = ERR_ARG_4_WRONG_TYPE; break;
  331.     case 5: error_code = ERR_ARG_5_WRONG_TYPE; break;
  332.     case 6: error_code = ERR_ARG_6_WRONG_TYPE; break;
  333.     case 7: error_code = ERR_ARG_7_WRONG_TYPE; break;
  334.     case 8: error_code = ERR_ARG_8_WRONG_TYPE; break;
  335.     case 9: error_code = ERR_ARG_9_WRONG_TYPE; break;
  336.     case 10: error_code = ERR_ARG_10_WRONG_TYPE; break;
  337.     default: error_code = ERR_EXTERNAL_RETURN; break;
  338.     }
  339.   signal_error_from_primitive (error_code);
  340. }
  341.  
  342. void
  343. DEFUN (error_bad_range_arg, (n), int n)
  344. {
  345.   fast long error_code;
  346.  
  347.   switch (n)
  348.     {
  349.     case 1: error_code = ERR_ARG_1_BAD_RANGE; break;
  350.     case 2: error_code = ERR_ARG_2_BAD_RANGE; break;
  351.     case 3: error_code = ERR_ARG_3_BAD_RANGE; break;
  352.     case 4: error_code = ERR_ARG_4_BAD_RANGE; break;
  353.     case 5: error_code = ERR_ARG_5_BAD_RANGE; break;
  354.     case 6: error_code = ERR_ARG_6_BAD_RANGE; break;
  355.     case 7: error_code = ERR_ARG_7_BAD_RANGE; break;
  356.     case 8: error_code = ERR_ARG_8_BAD_RANGE; break;
  357.     case 9: error_code = ERR_ARG_9_BAD_RANGE; break;
  358.     case 10: error_code = ERR_ARG_10_BAD_RANGE; break;
  359.     default: error_code = ERR_EXTERNAL_RETURN; break;
  360.     }
  361.   signal_error_from_primitive (error_code);
  362. }
  363.  
  364. void
  365. DEFUN_VOID (error_external_return)
  366. {
  367.   signal_error_from_primitive (ERR_EXTERNAL_RETURN);
  368. }
  369.  
  370. static SCHEME_OBJECT error_argument;
  371.  
  372. void
  373. DEFUN (error_with_argument, (argument), SCHEME_OBJECT argument)
  374. {
  375.   error_argument = argument;
  376.   signal_error_from_primitive (ERR_WITH_ARGUMENT);
  377.   /*NOTREACHED*/
  378. }
  379.  
  380. void
  381. DEFUN (error_in_system_call, (err, name),
  382.        enum syserr_names err AND enum syscall_names name)
  383. {
  384.   /* System call errors have some additional information.
  385.      Encode this as a vector in place of the error code.  */
  386.   SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 0));
  387.   VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
  388.   VECTOR_SET (v, 1, (LONG_TO_UNSIGNED_FIXNUM ((unsigned int) err)));
  389.   VECTOR_SET (v, 2, (LONG_TO_UNSIGNED_FIXNUM ((unsigned int) name)));
  390.   error_argument = v;
  391.   signal_error_from_primitive (ERR_IN_SYSTEM_CALL);
  392.   /*NOTREACHED*/
  393. }
  394.  
  395. void
  396. DEFUN (error_system_call, (code, name),
  397.        int code AND enum syscall_names name)
  398. {
  399.   error_in_system_call ((OS_error_code_to_syserr (code)), name);
  400.   /*NOTREACHED*/
  401. }
  402.  
  403. long
  404. DEFUN (arg_integer, (arg_number), int arg_number)
  405. {
  406.   fast SCHEME_OBJECT object = (ARG_REF (arg_number));
  407.   if (! (INTEGER_P (object)))
  408.     error_wrong_type_arg (arg_number);
  409.   if (! (integer_to_long_p (object)))
  410.     error_bad_range_arg (arg_number);
  411.   return (integer_to_long (object));
  412. }
  413.  
  414. long
  415. DEFUN (arg_nonnegative_integer, (arg_number), int arg_number)
  416. {
  417.   fast long result = (arg_integer (arg_number));
  418.   if (result < 0)
  419.     error_bad_range_arg (arg_number);
  420.   return (result);
  421. }
  422.  
  423. long
  424. DEFUN (arg_index_integer, (arg_number, upper_limit),
  425.        int arg_number AND long upper_limit)
  426. {
  427.   fast long result = (arg_integer (arg_number));
  428.   if ((result < 0) || (result >= upper_limit))
  429.     error_bad_range_arg (arg_number);
  430.   return (result);
  431. }
  432.  
  433. long
  434. DEFUN (arg_integer_in_range,
  435.        (arg_number, lower_limit, upper_limit),
  436.        int arg_number AND long lower_limit AND long upper_limit)
  437. {
  438.   fast long result = (arg_integer (arg_number));
  439.   if ((result < lower_limit) || (result >= upper_limit))
  440.     error_bad_range_arg (arg_number);
  441.   return (result);
  442. }
  443.  
  444. unsigned long
  445. DEFUN (arg_ulong_integer, (arg_number), int arg_number)
  446. {
  447.   fast SCHEME_OBJECT object = (ARG_REF (arg_number));
  448.   if (! (INTEGER_P (object)))
  449.     error_wrong_type_arg (arg_number);
  450.   if (! (integer_to_ulong_p (object)))
  451.     error_bad_range_arg (arg_number);
  452.   return (integer_to_ulong (object));
  453. }
  454.  
  455. unsigned long
  456. DEFUN (arg_ulong_index_integer, (arg_number, upper_limit),
  457.        int arg_number AND unsigned long upper_limit)
  458. {
  459.   fast unsigned long result = (arg_ulong_integer (arg_number));
  460.   if (result >= upper_limit)
  461.     error_bad_range_arg (arg_number);
  462.   return (result);
  463. }
  464.  
  465. Boolean
  466. DEFUN (real_number_to_double_p, (x), fast SCHEME_OBJECT x)
  467. {
  468.   return ((! (BIGNUM_P (x))) || (BIGNUM_TO_DOUBLE_P (x)));
  469. }
  470.  
  471. double
  472. DEFUN (real_number_to_double, (x), fast SCHEME_OBJECT x)
  473. {
  474.   return
  475.     ((FIXNUM_P (x))
  476.      ? (FIXNUM_TO_DOUBLE (x))
  477.      : (BIGNUM_P (x))
  478.      ? (bignum_to_double (x))
  479.      : (FLONUM_TO_DOUBLE (x)));
  480. }
  481.  
  482. double
  483. DEFUN (arg_real_number, (arg_number), int arg_number)
  484. {
  485.   fast SCHEME_OBJECT number = (ARG_REF (arg_number));
  486.   if (! (REAL_P (number)))
  487.     error_wrong_type_arg (arg_number);
  488.   if (! (real_number_to_double_p (number)))
  489.     error_bad_range_arg (arg_number);
  490.   return (real_number_to_double (number));
  491. }
  492.  
  493. double
  494. DEFUN (arg_real_in_range, (arg_number, lower_limit, upper_limit),
  495.        int arg_number AND double lower_limit AND double upper_limit)
  496. {
  497.   fast double result = (arg_real_number (arg_number));
  498.   if ((result < lower_limit) || (result > upper_limit))
  499.     error_bad_range_arg (arg_number);
  500.   return (result);
  501. }
  502.  
  503. Boolean
  504. DEFUN (interpreter_applicable_p, (object), fast SCHEME_OBJECT object)
  505. {
  506.  tail_recurse:
  507.   switch (OBJECT_TYPE (object))
  508.     {
  509.     case TC_PRIMITIVE:
  510.     case TC_PROCEDURE:
  511.     case TC_EXTENDED_PROCEDURE:
  512.     case TC_CONTROL_POINT:
  513.       return (true);
  514.  
  515.     case TC_ENTITY:
  516.       {
  517.     object = (MEMORY_REF (object, ENTITY_OPERATOR));
  518.     goto tail_recurse;
  519.       }
  520.     case TC_COMPILED_ENTRY:
  521.       {
  522.     long results [3];
  523.     compiled_entry_type (object, results);
  524.     return ((results [0]) == 0);
  525.       }
  526.     default:
  527.       return (false);
  528.     }
  529. }
  530.  
  531.                       /******************/
  532.                       /* ERROR HANDLING */
  533.                       /******************/
  534.  
  535. /* It is assumed that any caller of the error code has already
  536.  * restored its state to a situation which will make it
  537.  * restartable if the error handler returns normally.  As a
  538.  * result, the only work to be done on an error is to verify
  539.  * that there is an error handler, save the current continuation and
  540.  * create a new one if entered from Pop_Return rather than Eval,
  541.  * turn off interrupts, and call it with two arguments: Error-Code
  542.  * and Interrupt-Enables.
  543.  */
  544.  
  545. void
  546. DEFUN (Do_Micro_Error, (Err, From_Pop_Return),
  547.        long Err AND Boolean From_Pop_Return)
  548. {
  549.   SCHEME_OBJECT Error_Vector = SHARP_F;
  550.   SCHEME_OBJECT Handler;
  551.  
  552.   if (Consistency_Check)
  553.   {
  554.     err_print(Err, error_output);
  555.     Print_Expression(Fetch_Expression(), "Expression was");
  556.     outf_error ("\nEnvironment 0x%lx (#%lo).\n",
  557.         ((long) (Fetch_Env ())), ((long) (Fetch_Env ())));
  558.     Print_Return("Return code");
  559.     outf_error ("\n");
  560.   }
  561.  
  562.   Error_Exit_Hook();
  563.  
  564.   if (Trace_On_Error)
  565.   {
  566.     outf_error ("\n\n**** Stack Trace ****\n\n");
  567.     Back_Trace (error_output);
  568.   }
  569.  
  570. #ifdef ENABLE_DEBUGGING_TOOLS
  571.   {
  572.     int *From = &(local_circle[0]), *To = &(debug_circle[0]), i;
  573.  
  574.     for (i = 0; i < local_nslots; i++)
  575.       *To++ = *From++;
  576.     debug_nslots = local_nslots;
  577.     debug_slotno = local_slotno;
  578.   }
  579. #endif
  580.  
  581. /* Do_Micro_Error continues on the next page. */
  582.  
  583. /* Do_Micro_Error, continued */
  584.  
  585.   /* This can NOT be folded into the Will_Push below since we cannot
  586.      afford to have the Will_Push put down its own continuation.
  587.      There is guaranteed to be enough space for this one
  588.      continuation; in fact, the Will_Push here is really unneeded!
  589.    */
  590.  
  591.   if (From_Pop_Return)
  592.   {
  593.    Will_Push (CONTINUATION_SIZE);
  594.     Save_Cont ();
  595.    Pushed ();
  596.   }
  597.  
  598.  Will_Push (CONTINUATION_SIZE + (From_Pop_Return ? 0 : 1));
  599.   if (From_Pop_Return)
  600.     Store_Expression (Val);
  601.   else
  602.     STACK_PUSH (Fetch_Env ());
  603.   Store_Return ((From_Pop_Return) ?
  604.         RC_POP_RETURN_ERROR :
  605.         RC_EVAL_ERROR);
  606.   Save_Cont ();
  607.  Pushed ();
  608.  
  609. /* Do_Micro_Error continues on the next page. */
  610.  
  611. /* Do_Micro_Error, continued */
  612.  
  613.   if ((!Valid_Fixed_Obj_Vector()) ||
  614.       (OBJECT_TYPE ((Error_Vector =
  615.             Get_Fixed_Obj_Slot(System_Error_Vector))) !=
  616.        TC_VECTOR))
  617.   {
  618.     error_death (Err,
  619.          (((Valid_Fixed_Obj_Vector())
  620.            && (Error_Vector == SHARP_F))
  621.           ? "No error handlers"
  622.           : "No error handlers: Bad handlers vector"));
  623.     /*NOTREACHED*/
  624.   }
  625.  
  626.   if ((Err < 0) || (Err >= ((long) (VECTOR_LENGTH (Error_Vector)))))
  627.   {
  628.     if (VECTOR_LENGTH (Error_Vector) == 0)
  629.       error_death (Err, "No error handlers: Empty handlers vector");
  630.       /*NOTREACHED*/
  631.     Handler = (VECTOR_REF (Error_Vector, ERR_BAD_ERROR_CODE));
  632.   }
  633.   else
  634.     Handler = (VECTOR_REF (Error_Vector, Err));
  635.  
  636.   /* Return from error handler will re-enable interrupts & restore history */
  637.   Stop_History();
  638.   preserve_interrupt_mask ();
  639.  
  640.  Will_Push (STACK_ENV_EXTRA_SLOTS + 3);
  641.   /* Arg 2:     Int. mask */
  642.   STACK_PUSH (LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
  643.   /* Arg 1:     Err. No   */
  644.   if ((Err == ERR_WITH_ARGUMENT) || (Err == ERR_IN_SYSTEM_CALL))
  645.     STACK_PUSH (error_argument);
  646.   else if ((Err >= SMALLEST_FIXNUM) && (Err <= BIGGEST_FIXNUM))
  647.     STACK_PUSH (LONG_TO_FIXNUM (Err));
  648.   else
  649.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (ERR_BAD_ERROR_CODE));
  650.   /* Procedure: Handler   */
  651.   STACK_PUSH (Handler);
  652.   STACK_PUSH (STACK_FRAME_HEADER + 2);
  653.  Pushed();
  654.  
  655.   /* Disable all interrupts */
  656.   SET_INTERRUPT_MASK(0);
  657.   return;
  658. }
  659.  
  660. /* HISTORY manipulation */
  661.  
  662. SCHEME_OBJECT *
  663. DEFUN_VOID (Make_Dummy_History)
  664. {
  665.   SCHEME_OBJECT *History_Rib = Free;
  666.   SCHEME_OBJECT *Result;
  667.  
  668.   Free[RIB_EXP] = SHARP_F;
  669.   Free[RIB_ENV] = SHARP_F;
  670.   Free[RIB_NEXT_REDUCTION] =
  671.     MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History_Rib);
  672.   Free += 3;
  673.   Result = Free;
  674.   Free[HIST_RIB] = MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History_Rib);
  675.   Free[HIST_NEXT_SUBPROBLEM] =
  676.     MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, Result);
  677.   Free[HIST_PREV_SUBPROBLEM] =
  678.     MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, Result);
  679.   Free += 3;
  680.   return (Result);
  681. }
  682.  
  683. /* The entire trick to history is right here: it is either copied or
  684.    reused when restored.  Initially, Stop_History marks the stack so
  685.    that the history will merely be popped and reused.  On a catch,
  686.    however, the return code is changed to force the history to be
  687.    copied instead.  Thus, histories saved as part of a control point
  688.    are not side-effected in the history collection process.
  689. */
  690.  
  691. void
  692. DEFUN_VOID (Stop_History)
  693. {
  694.   SCHEME_OBJECT Saved_Expression;
  695.   long Saved_Return_Code;
  696.  
  697.   Saved_Expression = Fetch_Expression();
  698.   Saved_Return_Code = Fetch_Return();
  699.  Will_Push(HISTORY_SIZE);
  700.   Save_History(RC_RESTORE_DONT_COPY_HISTORY);
  701.  Pushed();
  702.   Prev_Restore_History_Stacklet = NULL;
  703.   Prev_Restore_History_Offset = ((Get_End_Of_Stacklet() - Stack_Pointer) +
  704.                  CONTINUATION_RETURN_CODE);
  705.   Store_Expression(Saved_Expression);
  706.   Store_Return(Saved_Return_Code);
  707.   return;
  708. }
  709.  
  710. /* This returns a history object,
  711.    or SHARP_F if it needs to GC,
  712.    or SHARP_T if it is not a valid history object.
  713.  */
  714.  
  715. SCHEME_OBJECT
  716. DEFUN (copy_history, (hist_obj), SCHEME_OBJECT hist_obj)
  717. {
  718.   long space_left, vert_type, rib_type;
  719.   SCHEME_OBJECT *fast_free;
  720.   SCHEME_OBJECT new_hunk, *last_hunk, *hist_ptr, *orig_hist, temp;
  721.   SCHEME_OBJECT *orig_rib, *source_rib, *rib_slot;
  722.  
  723.   if (!(HUNK3_P (hist_obj)))
  724.     return (SHARP_T);
  725.  
  726.   space_left = ((Space_Before_GC ()) - 3);
  727.   fast_free = Free;
  728.  
  729.   vert_type = (OBJECT_TYPE (hist_obj));
  730.   orig_hist = (OBJECT_ADDRESS (hist_obj));
  731.   hist_ptr = orig_hist;
  732.   last_hunk = (Heap_Top - 3);
  733.  
  734.   do
  735.   {
  736.     /* Allocate and link the vertebra. */
  737.  
  738.     space_left -= 3;
  739.     if (space_left < 0)
  740.       return (SHARP_F);
  741.  
  742.     new_hunk = (MAKE_POINTER_OBJECT (vert_type, fast_free));
  743.     last_hunk[HIST_NEXT_SUBPROBLEM] = new_hunk;
  744.  
  745.     fast_free[HIST_PREV_SUBPROBLEM] =
  746.       (MAKE_POINTER_OBJECT ((OBJECT_TYPE (hist_ptr[HIST_PREV_SUBPROBLEM])),
  747.                 last_hunk));
  748.     last_hunk = fast_free;
  749.     fast_free += 3;
  750.  
  751.     /* Copy the rib. */
  752.  
  753.     temp = hist_ptr[HIST_RIB];
  754.     rib_type = (OBJECT_TYPE (temp));
  755.     orig_rib = (OBJECT_ADDRESS (temp));
  756.     rib_slot = (last_hunk + HIST_RIB);
  757.     
  758.     source_rib = orig_rib;
  759.  
  760.     do
  761.     {
  762.       space_left -= 3;
  763.       if (space_left < 0)
  764.     return (SHARP_F);
  765.  
  766.       *rib_slot = (MAKE_POINTER_OBJECT (rib_type, fast_free));
  767.       fast_free[RIB_EXP] = source_rib[RIB_EXP];
  768.       fast_free[RIB_ENV] = source_rib[RIB_ENV];
  769.       rib_slot = (fast_free + RIB_NEXT_REDUCTION);
  770.       fast_free += 3;
  771.       
  772.       temp = source_rib[RIB_NEXT_REDUCTION];
  773.       rib_type = (OBJECT_TYPE (temp));
  774.       source_rib = (OBJECT_ADDRESS (temp));
  775.     } while (source_rib != orig_rib);
  776.       
  777.     *rib_slot = (OBJECT_NEW_TYPE (rib_type, last_hunk[HIST_RIB]));
  778.  
  779.     temp = hist_ptr[HIST_NEXT_SUBPROBLEM];
  780.     vert_type = (OBJECT_TYPE (temp));
  781.     hist_ptr = (OBJECT_ADDRESS (temp));
  782.   } while (hist_ptr != orig_hist);
  783.  
  784.   Free = fast_free;
  785.   new_hunk = Heap_Top[HIST_NEXT_SUBPROBLEM - 3];
  786.   last_hunk[HIST_NEXT_SUBPROBLEM] = (OBJECT_NEW_TYPE (vert_type, new_hunk));
  787.   FAST_MEMORY_SET (new_hunk, HIST_PREV_SUBPROBLEM,
  788.            (MAKE_POINTER_OBJECT
  789.             ((OBJECT_TYPE (hist_ptr[HIST_PREV_SUBPROBLEM])),
  790.              last_hunk)));
  791.   return (new_hunk);
  792. }
  793.  
  794. /* Restore_History pops a history object off the stack and
  795.    makes a COPY of it the current history collection object.
  796.    This is called only from the RC_RESTORE_HISTORY case in
  797.    interpret.c .
  798.  */
  799.  
  800. Boolean
  801. DEFUN (Restore_History, (hist_obj), SCHEME_OBJECT hist_obj)
  802. {
  803.   SCHEME_OBJECT new_hist;
  804.  
  805.   new_hist = (copy_history (hist_obj));
  806.   if (new_hist == SHARP_F)
  807.     return (false);
  808.   else if (new_hist == SHARP_T)
  809.   {
  810.     outf_fatal ("\nBad history to restore.\n");
  811.     Microcode_Termination (TERM_EXIT);
  812.     /*NOTREACHED*/
  813.     return (0);
  814.   }
  815.   else
  816.   {
  817.     History = (OBJECT_ADDRESS (new_hist));
  818.     return (true);
  819.   }
  820. }
  821.  
  822. /* If a "debugging" version of the interpreter is made, then this
  823.    procedure is called to actually invoke a primitive.  When a
  824.    "production" version is made, all of the consistency checks are
  825.    omitted and a macro from "default.h" is used to directly code the
  826.    call to the primitive function. */
  827.  
  828. #ifdef ENABLE_DEBUGGING_TOOLS
  829.  
  830. SCHEME_OBJECT
  831. DEFUN (primitive_apply_internal, (primitive), SCHEME_OBJECT primitive)
  832. {
  833.   SCHEME_OBJECT result;
  834.   if (Primitive_Debug)
  835.     Print_Primitive (primitive);
  836.   {
  837.     SCHEME_OBJECT * saved_stack = Stack_Pointer;
  838.     PRIMITIVE_APPLY_INTERNAL (result, primitive);
  839.     if (saved_stack != Stack_Pointer)
  840.       {
  841.     int arity = (PRIMITIVE_N_ARGUMENTS (primitive));
  842.     Print_Expression (primitive, "Stack bad after ");
  843.     outf_fatal ("\nStack was 0x%lx, now 0x%lx, #args=%ld.\n",
  844.             ((long) saved_stack), ((long) Stack_Pointer), ((long) arity));
  845.     Microcode_Termination (TERM_EXIT);
  846.       }
  847.   }
  848.   if (Primitive_Debug)
  849.     {
  850.       Print_Expression (result, "Primitive Result");
  851.       outf_error("\n");
  852.       outf_flush_error();
  853.     }
  854.   return (result);
  855. }
  856.  
  857. #endif /* ENABLE_DEBUGGING_TOOLS */
  858.  
  859. #ifdef ENABLE_PRIMITIVE_PROFILING
  860.  
  861. /* The profiling mechanism is enabled by storing a vector in the fixed
  862.    objects vector.  The vector should be initialized to contain all zeros
  863.  */
  864.  
  865. void
  866. DEFUN (record_primitive_entry, (primitive), SCHEME_OBJECT primitive)
  867. {
  868.   SCHEME_OBJECT table;
  869.  
  870.   if ((Fixed_Objects != SHARP_F) &&
  871.       ((table = Get_Fixed_Obj_Slot (Primitive_Profiling_Table)) != SHARP_F))
  872.   {
  873.     long index = (1 + (OBJECT_DATUM (primitive)));
  874.     MEMORY_SET
  875.       (table,
  876.        index,
  877.        (long_to_integer (1 + (integer_to_long (MEMORY_REF (table, index))))));
  878.   }
  879.   return;
  880. }
  881.  
  882. #endif /* ENABLE_PRIMITIVE_PROFILING */
  883.  
  884. #ifdef USE_STACKLETS
  885.                       /******************/
  886.                       /*   STACKLETS    */
  887.                       /******************/
  888.  
  889. void
  890. DEFUN (Allocate_New_Stacklet, (N), long N)
  891. {
  892.   SCHEME_OBJECT Old_Expression, *Old_Stacklet, Old_Return;
  893.  
  894.   Old_Stacklet = Current_Stacklet;
  895.   Terminate_Old_Stacklet();
  896.   if ((Free_Stacklets == NULL) ||
  897.       ((N + STACKLET_SLACK) >
  898.        (OBJECT_DATUM (Free_Stacklets[STACKLET_LENGTH]))))
  899.   {
  900.     long size;
  901.  
  902.     /*
  903.       Room is set aside for the header bytes of a stacklet plus
  904.       the two words required for the RC_JOIN_STACKLETS frame.
  905.      */
  906.  
  907.     size = New_Stacklet_Size(N);
  908.     if (GC_Check(size))
  909.     {
  910.       Request_GC(size);
  911.       if ((Free + size) >= Heap_Top)
  912.     Microcode_Termination(TERM_STACK_OVERFLOW);
  913.     }
  914.     Free[STACKLET_LENGTH] = MAKE_OBJECT (TC_MANIFEST_VECTOR, (size - 1));
  915.     SET_STACK_GUARD (& (Free[STACKLET_HEADER_SIZE]));
  916.     Free += size;
  917.     Stack_Pointer = Free;
  918.   }
  919.   else
  920.   {
  921.     /* Grab first one on the free list */
  922.  
  923.     SCHEME_OBJECT *New_Stacklet;
  924.  
  925.     New_Stacklet = Free_Stacklets;
  926.     Free_Stacklets =
  927.       ((SCHEME_OBJECT *) Free_Stacklets[STACKLET_FREE_LIST_LINK]);
  928.     Stack_Pointer =
  929.       &New_Stacklet[1 + (OBJECT_DATUM (New_Stacklet[STACKLET_LENGTH]))];
  930.     SET_STACK_GUARD (& (New_Stacklet[STACKLET_HEADER_SIZE]));
  931.   }
  932.   Old_Expression = Fetch_Expression();
  933.   Old_Return = Fetch_Return();
  934.   Store_Expression(MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Old_Stacklet));
  935.   Store_Return(RC_JOIN_STACKLETS);
  936.   /*
  937.     Will_Push omitted because size calculation includes enough room.
  938.    */
  939.   Save_Cont();
  940.   Store_Expression(Old_Expression);
  941.   Store_Return(Old_Return);
  942.   return;
  943. }
  944.  
  945. #endif /* USE_STACKLETS */
  946.  
  947. /* Dynamic Winder support code */
  948.  
  949. SCHEME_OBJECT
  950. DEFUN (Find_State_Space, (State_Point), SCHEME_OBJECT State_Point)
  951. {
  952.   long How_Far =
  953.     (UNSIGNED_FIXNUM_TO_LONG
  954.      (FAST_MEMORY_REF (State_Point, STATE_POINT_DISTANCE_TO_ROOT)));
  955.   long i;
  956.   fast SCHEME_OBJECT Point = State_Point;
  957.  
  958.   for (i=0; i <= How_Far; i++)
  959.   {
  960. #ifdef ENABLE_DEBUGGING_TOOLS
  961.     if (Point == SHARP_F)
  962.     {
  963.       outf_fatal(
  964.           "\nState_Point 0x%lx wrong: count was %ld, #F at %ld\n",
  965.           ((long) State_Point), ((long) How_Far), ((long) i));
  966.       Microcode_Termination(TERM_EXIT);
  967.       /*NOTREACHED*/
  968.     }
  969. #endif /* ENABLE_DEBUGGING_TOOLS */
  970.     Point = FAST_MEMORY_REF (Point, STATE_POINT_NEARER_POINT);
  971.   }
  972.   return (Point);
  973. }
  974.  
  975. /* ASSUMPTION: State points, which are created only by the interpreter,
  976.    never contain FUTUREs except possibly as the thunks (which are handled
  977.    by the apply code).
  978.  
  979.    Furthermore:
  980.      (1) On a single processor, things should work with multiple state
  981.      spaces.  The microcode variable Current_State_Point tracks
  982.      the location in the "boot" space (i.e. the one whose space is
  983.      #F) and the state spaces themselves (roots of the space
  984.      trees) track the other spaces.
  985.      (2) On multi-processors, multiple spaces DO NOT work.  Only the
  986.      initial space (#F) is tracked by the microcode (it is
  987.      swapped on every task switch), but no association with trees
  988.      is kept.  This will work since the initial tree has no space
  989.      at the root, indicating that the microcode variable rather
  990.      than the state space contains the current state space
  991.      location.
  992.  
  993.    NOTE: This procedure is invoked both by primitives and the interpreter
  994.    itself.  As such, it is using the pun that PRIMITIVE_ABORT is just a
  995.    (non-local) return to the interpreter.  This should be cleaned up.
  996.    NOTE: Any primitive that invokes this procedure must do a
  997.    PRIMITIVE_CANONICALIZE_CONTEXT() first!
  998. */
  999.  
  1000. void
  1001. DEFUN (Translate_To_Point, (Target), SCHEME_OBJECT Target)
  1002. {
  1003.   SCHEME_OBJECT State_Space, Current_Location, *Path;
  1004.   fast SCHEME_OBJECT Path_Point, *Path_Ptr;
  1005.   long Distance, Merge_Depth, From_Depth, i;
  1006.  
  1007.   State_Space = Find_State_Space(Target);
  1008.   Path = Free;
  1009.   guarantee_state_point();
  1010.   Distance =
  1011.     (UNSIGNED_FIXNUM_TO_LONG
  1012.      (FAST_MEMORY_REF (Target, STATE_POINT_DISTANCE_TO_ROOT)));
  1013.   if (State_Space == SHARP_F)
  1014.     Current_Location = Current_State_Point;
  1015.   else
  1016.     Current_Location = MEMORY_REF (State_Space, STATE_SPACE_NEAREST_POINT);
  1017.  
  1018.   if (Target == Current_Location)
  1019.   {
  1020.     PRIMITIVE_ABORT (PRIM_POP_RETURN);
  1021.     /*NOTREACHED*/
  1022.   }
  1023.  
  1024.   for (Path_Ptr = (&(Path[Distance])), Path_Point = Target, i = 0;
  1025.        i <= Distance;
  1026.        i++)
  1027.   {
  1028.     *Path_Ptr-- = Path_Point;
  1029.     Path_Point = FAST_MEMORY_REF (Path_Point, STATE_POINT_NEARER_POINT);
  1030.   }
  1031.  
  1032.   From_Depth =
  1033.     (UNSIGNED_FIXNUM_TO_LONG
  1034.      (FAST_MEMORY_REF (Current_Location, STATE_POINT_DISTANCE_TO_ROOT)));
  1035.  
  1036.   for (Path_Point = Current_Location, Merge_Depth = From_Depth;
  1037.        Merge_Depth > Distance;
  1038.        Merge_Depth--)
  1039.     Path_Point = FAST_MEMORY_REF (Path_Point, STATE_POINT_NEARER_POINT);
  1040.  
  1041.   for (Path_Ptr = (&(Path[Merge_Depth]));
  1042.        Merge_Depth >= 0;
  1043.        Merge_Depth--, Path_Ptr--)
  1044.   {
  1045.     if (*Path_Ptr == Path_Point)
  1046.       break;
  1047.     Path_Point = FAST_MEMORY_REF (Path_Point, STATE_POINT_NEARER_POINT);
  1048.   }
  1049.  
  1050. #ifdef ENABLE_DEBUGGING_TOOLS
  1051.   if (Merge_Depth < 0)
  1052.   {
  1053.     outf_fatal("\nMerge_Depth went negative: %d\n", Merge_Depth);
  1054.     Microcode_Termination (TERM_EXIT);
  1055.   }
  1056. #endif /* ENABLE_DEBUGGING_TOOLS */
  1057.  
  1058.   preserve_interrupt_mask ();
  1059.  Will_Push(CONTINUATION_SIZE + 4);
  1060.   STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM((Distance - Merge_Depth)));
  1061.   STACK_PUSH (Target);
  1062.   STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM((From_Depth - Merge_Depth)));
  1063.   STACK_PUSH (Current_Location);
  1064.   Store_Expression(State_Space);
  1065.   Store_Return(RC_MOVE_TO_ADJACENT_POINT);
  1066.   Save_Cont();
  1067.  Pushed();
  1068.  
  1069.   {
  1070.     long mask;
  1071.  
  1072.     /* Disable lower than GC level */
  1073.     mask = (FETCH_INTERRUPT_MASK() & ((INT_GC << 1) - 1));
  1074.     SET_INTERRUPT_MASK(mask);
  1075.   }
  1076.   PRIMITIVE_ABORT (PRIM_POP_RETURN);
  1077.   /*NOTREACHED*/
  1078. }
  1079.  
  1080. #ifndef __OS2__
  1081.  
  1082. SCHEME_OBJECT
  1083. DEFUN_VOID (Compiler_Get_Fixed_Objects)
  1084. {
  1085.   if (Valid_Fixed_Obj_Vector())
  1086.     return (Get_Fixed_Obj_Slot(Me_Myself));
  1087.   else
  1088.     return (SHARP_F);
  1089. }
  1090.  
  1091. extern SCHEME_OBJECT EXFUN (Re_Enter_Interpreter, (void));
  1092. extern SCHEME_OBJECT EXFUN
  1093.   (C_call_scheme, (SCHEME_OBJECT, long, SCHEME_OBJECT *));
  1094.  
  1095. #ifdef __WIN32__
  1096. #  include <windows.h>
  1097. #endif
  1098.  
  1099. SCHEME_OBJECT
  1100. DEFUN (C_call_scheme, (proc, nargs, argvec),
  1101.        SCHEME_OBJECT proc
  1102.        AND long nargs
  1103.        AND SCHEME_OBJECT * argvec)
  1104. {
  1105.   SCHEME_OBJECT primitive, prim_lexpr, * sp, result;
  1106.   SCHEME_OBJECT * callers_last_return_code;
  1107.  
  1108. #ifdef __IA32__
  1109.   extern void * C_Frame_Pointer;
  1110.   extern void * C_Stack_Pointer;
  1111.   void * cfp = C_Frame_Pointer;
  1112.   void * csp = C_Stack_Pointer;
  1113. #ifdef CL386
  1114.   __try
  1115. #endif
  1116. #endif
  1117.   {  
  1118.     primitive = (Regs [REGBLOCK_PRIMITIVE]);
  1119.     prim_lexpr = (Regs [REGBLOCK_LEXPR_ACTUALS]);
  1120.     callers_last_return_code = last_return_code;
  1121.  
  1122.     if (! (PRIMITIVE_P (primitive)))
  1123.       abort_to_interpreter (ERR_CANNOT_RECURSE);
  1124.       /*NOTREACHED*/
  1125.     sp = Stack_Pointer;
  1126.  
  1127.    Will_Push ((2 * CONTINUATION_SIZE) + (nargs + STACK_ENV_EXTRA_SLOTS + 1));
  1128.     {
  1129.       long i;
  1130.  
  1131.       Store_Return (RC_END_OF_COMPUTATION);
  1132.       Store_Expression (primitive);
  1133.       Save_Cont ();
  1134.  
  1135.       for (i = nargs; --i >= 0; )
  1136.     STACK_PUSH (argvec[i]);
  1137.       STACK_PUSH (proc);
  1138.       STACK_PUSH (STACK_FRAME_HEADER + nargs);
  1139.  
  1140.       Store_Return (RC_INTERNAL_APPLY);
  1141.       Store_Expression (SHARP_F);
  1142.       Save_Cont ();
  1143.     }
  1144.    Pushed ();
  1145.     result = (Re_Enter_Interpreter ());
  1146.  
  1147.     if (Stack_Pointer != sp)
  1148.       signal_error_from_primitive (ERR_STACK_HAS_SLIPPED);
  1149.       /*NOTREACHED*/
  1150.  
  1151.     last_return_code = callers_last_return_code;
  1152.     Regs [REGBLOCK_LEXPR_ACTUALS] = prim_lexpr;
  1153.     Regs [REGBLOCK_PRIMITIVE] = primitive;
  1154.   }
  1155. #ifdef __IA32__
  1156. #ifdef CL386
  1157.   __finally  
  1158. #endif
  1159.   {
  1160.     C_Frame_Pointer = cfp;
  1161.     C_Stack_Pointer = csp;
  1162.   }
  1163. #endif
  1164.  
  1165.   return  result;
  1166. }
  1167.  
  1168. #endif /* not __OS2__ */
  1169.