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 / hooks.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  32KB  |  984 lines
  1. /* -*-C-*-
  2.  
  3. $Id: hooks.c,v 9.59 2000/12/05 21:23:44 cph Exp $
  4.  
  5. Copyright (c) 1988-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. /* This file contains various hooks and handles that connect the
  23.    primitives with the main interpreter. */
  24.  
  25. #include "scheme.h"
  26. #include "prims.h"
  27. #include "winder.h"
  28. #include "history.h"
  29.  
  30. DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2,
  31.           "(PROCEDURE LIST-OF-ARGS)\n\
  32. Invoke PROCEDURE on the arguments contained in list-of-ARGS.")
  33. {
  34.   SCHEME_OBJECT procedure;
  35.   SCHEME_OBJECT argument_list;
  36.   fast long number_of_args;
  37.   PRIMITIVE_HEADER (2);
  38.  
  39.   procedure = (ARG_REF (1));
  40.   argument_list = (ARG_REF (2));
  41.   /* Since this primitive must pop its own frame off and push a new
  42.      frame on the stack, it has to be careful.  Its own stack frame is
  43.      needed if an error or GC is required.  So these checks are done
  44.      first (at the cost of traversing the argument list twice), then
  45.      the primitive's frame is popped, and finally the new frame is
  46.      constructed.
  47.  
  48.      Originally this code tried to be clever by copying the argument
  49.      list into a linear (vector-like) form, so as to avoid the
  50.      overhead of traversing the list twice.  Unfortunately, the
  51.      overhead of maintaining this other form (e.g. PRIMITIVE_GC_If_Needed)
  52.      is sufficiently high that it probably makes up for the time saved.
  53.    */
  54.   {
  55.     fast SCHEME_OBJECT scan_list, scan_list_trail;
  56.     TOUCH_IN_PRIMITIVE (argument_list, scan_list);
  57.     if (! (PAIR_P (scan_list)))
  58.       number_of_args = 0;
  59.     else
  60.     {
  61.       number_of_args = 1;
  62.       scan_list_trail = scan_list;
  63.       TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
  64.       while (true)
  65.       {
  66.     if (scan_list == scan_list_trail)
  67.       error_bad_range_arg (2);
  68.     if (! (PAIR_P (scan_list)))
  69.       break;
  70.     TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
  71.     if (scan_list == scan_list_trail)
  72.       error_bad_range_arg (2);
  73.     if (! (PAIR_P (scan_list)))
  74.     {
  75.       number_of_args += 1;
  76.       break;
  77.     }
  78.     TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
  79.     scan_list_trail = (PAIR_CDR (scan_list_trail));
  80.     number_of_args += 2;
  81.       }
  82.     }
  83.     if (scan_list != EMPTY_LIST)
  84.       error_wrong_type_arg (2);
  85.   }
  86.  
  87. #ifdef USE_STACKLETS
  88.   /* This is conservative: if the number of arguments is large enough
  89.      the Will_Push below may try to allocate space on the heap for the
  90.      stack frame. */
  91.   Primitive_GC_If_Needed
  92.     (New_Stacklet_Size (number_of_args + STACK_ENV_EXTRA_SLOTS + 1));
  93. #endif /* USE_STACKLETS */
  94.  
  95. #ifdef USE_STACKLETS
  96.   POP_PRIMITIVE_FRAME (2);
  97.  Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1);
  98. #else
  99.   /* Don't use Will_Push for this -- if the length of the list is too
  100.      large to fit on the stack, it could cause Scheme to terminate.  */
  101.   if ((Stack_Pointer - (number_of_args + STACK_ENV_EXTRA_SLOTS + 1))
  102.       <= Stack_Guard)
  103.     error_bad_range_arg (2);
  104.   POP_PRIMITIVE_FRAME (2);
  105. #endif
  106.   {
  107.     fast long i;
  108.     fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
  109.     fast SCHEME_OBJECT scan_list;
  110.     TOUCH_IN_PRIMITIVE (argument_list, scan_list);
  111.     for (i = number_of_args; (i > 0); i -= 1)
  112.     {
  113. #ifdef LOSING_PARALLEL_PROCESSOR
  114.       /* This half-measure should be replaced by some kind of lock
  115.      or something else that guarantees that the code will win.  */
  116.       /* Check for abominable case of someone bashing the arg list. */
  117.       if (! (PAIR_P (scan_list)))
  118.       {
  119.     /* Re-push the primitive's frame. */
  120.     STACK_PUSH (argument_list);
  121.     STACK_PUSH (procedure);
  122.     error_bad_range_arg (2);
  123.       }
  124. #endif /* LOSING_PARALLEL_PROCESSOR */
  125.       (*scan_stack++) = (PAIR_CAR (scan_list));
  126.       TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
  127.     }
  128.   }
  129.   Stack_Pointer = (STACK_LOC (- number_of_args));
  130.   STACK_PUSH (procedure);
  131.   STACK_PUSH (STACK_FRAME_HEADER + number_of_args);
  132. #ifdef USE_STACKLETS
  133.  Pushed ();
  134. #endif
  135.  
  136.   if (COMPILED_CODE_ADDRESS_P (STACK_REF (number_of_args + 2)))
  137.   {
  138.     extern SCHEME_OBJECT EXFUN (apply_compiled_from_primitive, (int));
  139.     PRIMITIVE_RETURN (apply_compiled_from_primitive (2));
  140.   }
  141.  
  142.   PRIMITIVE_ABORT (PRIM_APPLY);
  143.   /*NOTREACHED*/
  144.   return (0);
  145. }
  146.  
  147. /* CALL-WITH-CURRENT-CONTINUATION
  148.  
  149.    Implementation detail: in addition to setting aside the old
  150.    stacklet on a catch, the new stacklet is cleared and a return
  151.    code is placed at the base of the (now clear) stack indicating
  152.    that a return back through here requires restoring the stacklet.
  153.    The current enabled interrupts are also saved in the old stacklet.
  154.  
  155.    >>> Temporarily (maybe) the act of doing a CATCH will disable any
  156.    >>> return hook that may be in the stack.
  157.  */
  158.  
  159. #ifdef USE_STACKLETS
  160.  
  161. #define CWCC_STACK_SIZE()        (2 * Default_Stacklet_Size)
  162. #define NON_REENTRANT_RC_RESTORE    RC_RESTORE_DONT_COPY_HISTORY
  163. #define NON_REENTRANT_FLAG        SHARP_T
  164.  
  165. #else /* not USE_STACKLETS */
  166.  
  167. #define CWCC_STACK_SIZE()                        \
  168.   ((Stack_Top - Stack_Pointer) + STACKLET_HEADER_SIZE            \
  169.    + CONTINUATION_SIZE + HISTORY_SIZE)
  170.  
  171. /* When there are no stacklets, the two versions of CWCC are identical. */
  172.  
  173. #define NON_REENTRANT_RC_RESTORE    RC_RESTORE_HISTORY
  174. #define NON_REENTRANT_FLAG        SHARP_F
  175.  
  176. #endif /* USE_STACKLETS */
  177.  
  178. void
  179. DEFUN (CWCC, (return_code, reuse_flag, receiver),
  180.        long return_code
  181.        AND SCHEME_OBJECT reuse_flag
  182.        AND SCHEME_OBJECT receiver)
  183. {
  184.   SCHEME_OBJECT control_point;
  185.  
  186.   Primitive_GC_If_Needed (CWCC_STACK_SIZE ());
  187.   POP_PRIMITIVE_FRAME (1);
  188.   if (Return_Hook_Address != NULL)
  189.   {
  190.     (* Return_Hook_Address) = Old_Return_Code;
  191.     Return_Hook_Address = NULL;
  192.   }
  193.  
  194.   /* Tail recursion hacking in CWCC.
  195.      If the current stack contains only a frame to restore
  196.      another control point that looks like the result of CWCC,
  197.      then there is no need to push anything else on the stack
  198.      or cons anything on the heap.
  199.  
  200.      This hackery would be considerably simpler if the interrupt
  201.      mask and history information were kept explicitly instead
  202.      of implicitly (pushed with appropriate restore return codes).
  203.    */
  204.  
  205.   if (((STACK_LOC (CONTINUATION_SIZE)) == (Get_End_Of_Stacklet ()))
  206.       && ((OBJECT_DATUM (STACK_REF (CONTINUATION_RETURN_CODE)))
  207.       == RC_JOIN_STACKLETS))
  208.   {
  209.     control_point = (STACK_REF (CONTINUATION_EXPRESSION));
  210.  
  211.     if (((OBJECT_TYPE (control_point)) == TC_CONTROL_POINT)
  212.     && ((reuse_flag == SHARP_F)
  213.         || ((MEMORY_REF (control_point, STACKLET_REUSE_FLAG))
  214.         == SHARP_F)))
  215.     {
  216.       SCHEME_OBJECT * prev_stack
  217.     = (MEMORY_LOC (control_point,
  218.                (STACKLET_HEADER_SIZE
  219.             + (OBJECT_DATUM (MEMORY_REF
  220.                      (control_point,
  221.                       STACKLET_UNUSED_LENGTH))))));
  222.       SCHEME_OBJECT * ret_ptr
  223.     = (STACK_LOCATIVE_OFFSET (prev_stack,
  224.                   (CONTINUATION_SIZE
  225.                    + CONTINUATION_RETURN_CODE)));
  226.  
  227.       if ((ret_ptr
  228.        <= (VECTOR_LOC (control_point, (VECTOR_LENGTH (control_point)))))
  229.       && ((OBJECT_DATUM (STACK_LOCATIVE_REFERENCE
  230.                  (prev_stack,
  231.                   CONTINUATION_RETURN_CODE)))
  232.           == RC_RESTORE_INT_MASK))
  233.       {
  234.     long ret_code = (OBJECT_DATUM (*ret_ptr));
  235.  
  236.     if ((ret_code == RC_RESTORE_HISTORY) || (ret_code == return_code))
  237.     {
  238.       History = (OBJECT_ADDRESS (Get_Fixed_Obj_Slot (Dummy_History)));
  239.       STACK_RESET ();
  240.       /* Will_Push(3); */
  241.       STACK_PUSH (control_point);
  242.       STACK_PUSH (receiver);
  243.       STACK_PUSH (STACK_FRAME_HEADER + 1);
  244.       /*  Pushed(); */
  245.  
  246.       PRIMITIVE_ABORT (PRIM_APPLY);
  247.       /*NOTREACHED*/
  248.     }
  249.       }
  250.     }
  251.   }
  252.  
  253.   /*
  254.     Put down frames to restore history and interrupts so that these
  255.     operations will be performed on a throw.
  256.    */
  257.  Will_Push (HISTORY_SIZE);
  258.   Save_History (return_code);
  259.  Pushed ();
  260.   preserve_interrupt_mask ();
  261.   /* There is no history to use since the
  262.      last control point was formed.
  263.    */
  264.   Prev_Restore_History_Stacklet = NULL;
  265.   Prev_Restore_History_Offset = 0;
  266.  
  267. #ifdef USE_STACKLETS
  268.   {
  269.     control_point = (Get_Current_Stacklet ());
  270.     Allocate_New_Stacklet (3);
  271.   }
  272. #else /* not USE_STACKLETS */
  273.   {
  274.     fast long n_words = (Stack_Top - Stack_Pointer);
  275.     control_point = (allocate_marked_vector
  276.              (TC_CONTROL_POINT,
  277.               (n_words + (STACKLET_HEADER_SIZE - 1)),
  278.               false));
  279.     FAST_MEMORY_SET (control_point, STACKLET_REUSE_FLAG, reuse_flag);
  280.     FAST_MEMORY_SET (control_point,
  281.              STACKLET_UNUSED_LENGTH,
  282.              (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)));
  283.     {
  284.       fast SCHEME_OBJECT * scan =
  285.     (MEMORY_LOC (control_point, STACKLET_HEADER_SIZE));
  286.       while ((n_words--) > 0)
  287.     (*scan++) = (STACK_POP ());
  288.     }
  289.     if (Consistency_Check && (Stack_Pointer != Stack_Top))
  290.       Microcode_Termination (TERM_BAD_STACK);
  291.     CLEAR_INTERRUPT (INT_Stack_Overflow);
  292.     STACK_RESET ();
  293.     Will_Push (CONTINUATION_SIZE);
  294.     Store_Return (RC_JOIN_STACKLETS);
  295.     Store_Expression (control_point);
  296.     Save_Cont ();
  297.     Pushed ();
  298.   }
  299. #endif /* USE_STACKLETS */
  300.  
  301.   /* we just cleared the stack so there MUST be room */
  302.   /* Will_Push(3); */
  303.   STACK_PUSH (control_point);
  304.   STACK_PUSH (receiver);
  305.   STACK_PUSH (STACK_FRAME_HEADER + 1);
  306.   /*  Pushed(); */
  307.  
  308.   PRIMITIVE_ABORT (PRIM_APPLY);
  309.   /*NOTREACHED*/
  310. }
  311.  
  312. /* (CALL-WITH-CURRENT-CONTINUATION PROCEDURE)
  313.  
  314.    Creates a control point (a pointer to the current stack) and passes
  315.    it to PROCEDURE as its only argument.  The inverse operation,
  316.    typically called THROW, is performed by using the control point as
  317.    you would a procedure.  A control point accepts one argument which
  318.    is then returned as the value of the CATCH which created the
  319.    control point.  If the reuse flag of the stacklet is clear then the
  320.    control point may be reused as often as desired since the stack
  321.    will be copied on every throw.  The user level CATCH is built on
  322.    this primitive but is not the same, since it handles dynamic state
  323.    while the primitive does not; it assumes that the microcode sets
  324.    and clears the appropriate reuse flags for copying. 
  325. */
  326.  
  327. DEFINE_PRIMITIVE ("CALL-WITH-CURRENT-CONTINUATION", Prim_catch, 1, 1,
  328.           "(RECEIVER)\n\
  329. Invoke RECEIVER with a reentrant copy of the current control stack.")
  330. {
  331.   PRIMITIVE_HEADER (1);
  332.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  333.   CWCC (RC_RESTORE_HISTORY, SHARP_F, (ARG_REF (1)));
  334.   /*NOTREACHED*/
  335.   PRIMITIVE_RETURN (UNSPECIFIC);
  336. }
  337.  
  338. DEFINE_PRIMITIVE ("NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION",
  339.           Prim_non_reentrant_catch, 1, 1,
  340.           "(RECEIVER)\n\
  341. Invoke RECEIVER with a non-reentrant copy of the current control stack.")
  342. {
  343.   PRIMITIVE_HEADER (1);
  344.   PRIMITIVE_CANONICALIZE_CONTEXT();
  345.   CWCC (NON_REENTRANT_RC_RESTORE, NON_REENTRANT_FLAG, (ARG_REF (1)));
  346.   /*NOTREACHED*/
  347.   PRIMITIVE_RETURN (UNSPECIFIC);
  348. }
  349.  
  350. /* (WITHIN-CONTROL-POINT control-point thunk)
  351.  
  352.    Invoke THUNK (a procedure of no arguments) with CONTROL-POINT as
  353.    the pending stack.  control-point is created by CWCC.
  354.    The restoration of the stack is delayed until THUNK returns.
  355.    If THUNK never returns (it diverges or throws elsewhere),
  356.    the stack is never restored.
  357.    WITHIN-CONTROL-POINT clears the current stack, pushes a frame
  358.    that restores control-point when THUNK returns, and sets up
  359.    an apply frame for THUNK.
  360.  */   
  361.  
  362. DEFINE_PRIMITIVE ("WITHIN-CONTROL-POINT", Prim_within_control_point, 2, 2,
  363.           "(CONTROL-POINT THUNK)\n\
  364. Invoke THUNK with CONTROL-POINT as its control stack.")
  365. {
  366.   SCHEME_OBJECT control_point, thunk;
  367.   PRIMITIVE_HEADER (2);
  368.  
  369.   PRIMITIVE_CANONICALIZE_CONTEXT();
  370.   CHECK_ARG (1, CONTROL_POINT_P);
  371.   control_point = (ARG_REF (1));
  372.   thunk = (ARG_REF (2));
  373.  
  374.   /* This KNOWS the direction of stack growth. */
  375.   Stack_Pointer = (Get_End_Of_Stacklet ());
  376.   /* We've discarded the history with the stack contents.  */
  377.   Prev_Restore_History_Stacklet = NULL;
  378.   Prev_Restore_History_Offset = 0;
  379.   CLEAR_INTERRUPT (INT_Stack_Overflow);
  380.  
  381.  Will_Push (CONTINUATION_SIZE);
  382.   Store_Expression (control_point);
  383.   Store_Return (RC_JOIN_STACKLETS);
  384.   Save_Cont ();
  385.  Pushed ();
  386.  
  387.  Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
  388.   STACK_PUSH (thunk);
  389.   STACK_PUSH (STACK_FRAME_HEADER);
  390.  Pushed ();
  391.  
  392.   PRIMITIVE_ABORT (PRIM_APPLY);
  393.   /*NOTREACHED*/
  394.   PRIMITIVE_RETURN (UNSPECIFIC);
  395. }
  396.  
  397. DEFINE_PRIMITIVE ("ERROR-PROCEDURE", Prim_error_procedure, 3, 3,
  398.           "(MESSAGE IRRITANTS ENVIRONMENT)\nSignal an error.")
  399. {
  400.   PRIMITIVE_HEADER (3);
  401.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  402.   {
  403.     fast SCHEME_OBJECT message = (ARG_REF (1));
  404.     fast SCHEME_OBJECT irritants = (ARG_REF (2));
  405.     fast SCHEME_OBJECT environment = (ARG_REF (3));
  406.     /* This is done outside the Will_Push because the space for it
  407.        is guaranteed by the interpreter before it gets here.
  408.        If done inside, this could break when using stacklets. */
  409.     back_out_of_primitive ();
  410.   Will_Push (HISTORY_SIZE + STACK_ENV_EXTRA_SLOTS + 4);
  411.     Stop_History ();
  412.     /* Stepping should be cleared here! */
  413.     STACK_PUSH (environment);
  414.     STACK_PUSH (irritants);
  415.     STACK_PUSH (message);
  416.     STACK_PUSH (Get_Fixed_Obj_Slot (Error_Procedure));
  417.     STACK_PUSH (STACK_FRAME_HEADER + 3);
  418.   Pushed ();
  419.     PRIMITIVE_ABORT (PRIM_APPLY);
  420.     /*NOTREACHED*/
  421.     PRIMITIVE_RETURN (UNSPECIFIC);
  422.   }
  423. }
  424.  
  425. DEFINE_PRIMITIVE ("SCODE-EVAL", Prim_scode_eval, 2, 2,
  426.           "(SCODE-EXPRESSION ENVIRONMENT)\n\
  427. Evaluate SCODE-EXPRESSION in ENVIRONMENT.")
  428. {
  429.   PRIMITIVE_HEADER (2);
  430.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  431.   CHECK_ARG (2, ENVIRONMENT_P);
  432.   {
  433.     fast SCHEME_OBJECT expression = (ARG_REF (1));
  434.     fast SCHEME_OBJECT environment = (ARG_REF (2));
  435.     POP_PRIMITIVE_FRAME (2);
  436.     Store_Env (environment);
  437.     Store_Expression (expression);
  438.   }
  439.   PRIMITIVE_ABORT (PRIM_DO_EXPRESSION);
  440.   /*NOTREACHED*/
  441.   PRIMITIVE_RETURN (UNSPECIFIC);
  442. }
  443.  
  444. DEFINE_PRIMITIVE ("FORCE", Prim_force, 1, 1,
  445.           "(PROMISE)\n\
  446. Return the value memoized in PROMISE, computing it if it has not been\n\
  447. memoized yet.")
  448. {
  449.   PRIMITIVE_HEADER (1);
  450.   CHECK_ARG (1, PROMISE_P);
  451.   {
  452.     fast SCHEME_OBJECT thunk = (ARG_REF (1));
  453.     fast SCHEME_OBJECT State = (MEMORY_REF (thunk, THUNK_SNAPPED));
  454.     if (State == SHARP_T)
  455.       PRIMITIVE_RETURN (MEMORY_REF (thunk, THUNK_VALUE));
  456.     else if (State ==  FIXNUM_ZERO)
  457.     {
  458.       /* New-style thunk used by compiled code. */
  459.       PRIMITIVE_CANONICALIZE_CONTEXT();
  460.       POP_PRIMITIVE_FRAME (1);
  461.      Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
  462.       Store_Return (RC_SNAP_NEED_THUNK);
  463.       Store_Expression (thunk);
  464.       Save_Cont ();
  465.       STACK_PUSH (MEMORY_REF (thunk, THUNK_VALUE));
  466.       STACK_PUSH (STACK_FRAME_HEADER);
  467.      Pushed ();
  468.       PRIMITIVE_ABORT (PRIM_APPLY);
  469.       /*NOTREACHED*/
  470.       PRIMITIVE_RETURN (UNSPECIFIC);
  471.     }
  472.     else
  473.     {
  474.       /* Old-style thunk used by interpreted code. */
  475.       PRIMITIVE_CANONICALIZE_CONTEXT();
  476.       POP_PRIMITIVE_FRAME (1);
  477.      Will_Push (CONTINUATION_SIZE);
  478.       Store_Return (RC_SNAP_NEED_THUNK);
  479.       Store_Expression (thunk);
  480.       Save_Cont ();
  481.      Pushed ();
  482.       Store_Env (FAST_MEMORY_REF (thunk, THUNK_ENVIRONMENT));
  483.       Store_Expression (FAST_MEMORY_REF (thunk, THUNK_PROCEDURE));
  484.       PRIMITIVE_ABORT (PRIM_DO_EXPRESSION);
  485.       /*NOTREACHED*/
  486.       PRIMITIVE_RETURN (UNSPECIFIC);
  487.     }
  488.   }
  489. }
  490.  
  491. /* State Space Implementation */
  492.  
  493. DEFINE_PRIMITIVE ("EXECUTE-AT-NEW-STATE-POINT",
  494.           Prim_execute_at_new_point, 4, 4,
  495.           "(OLD-STATE-POINT BEFORE-THUNK DURING-THUNK AFTER-THUNK)\n\
  496. Invoke DURING-THUNK in a new state point defined by the transition\n\
  497. <BEFORE-THUNK, AFTER-THUNK> from OLD-STATE-POINT.\n\
  498. If OLD-STATE-POINT is #F, the current state point in the global state\n\
  499. space is used as the starting point.")
  500. {
  501.   PRIMITIVE_HEADER (4);
  502.  
  503.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  504.   guarantee_state_point ();
  505.   {
  506.     SCHEME_OBJECT old_point;
  507.     if ((ARG_REF (1)) == SHARP_F)
  508.       old_point = Current_State_Point;
  509.     else
  510.       {
  511.     CHECK_ARG (1, STATE_SPACE_P);
  512.     old_point =
  513.       (FAST_MEMORY_REF ((ARG_REF (1)), STATE_SPACE_NEAREST_POINT));
  514.       }
  515.     {
  516.       SCHEME_OBJECT new_point =
  517.     (allocate_marked_vector (TC_VECTOR, STATE_POINT_LENGTH, true));
  518.       SCHEME_OBJECT during_thunk = (ARG_REF (3));
  519.       FAST_MEMORY_SET
  520.     (new_point, STATE_POINT_TAG, (Get_Fixed_Obj_Slot (State_Point_Tag)));
  521.       FAST_MEMORY_SET (new_point, STATE_POINT_BEFORE_THUNK, (ARG_REF (2)));
  522.       FAST_MEMORY_SET (new_point, STATE_POINT_AFTER_THUNK, (ARG_REF (4)));
  523.       FAST_MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, old_point);
  524.       FAST_MEMORY_SET
  525.     (new_point,
  526.      STATE_POINT_DISTANCE_TO_ROOT,
  527.      (1 + (FAST_MEMORY_REF (old_point, STATE_POINT_DISTANCE_TO_ROOT))));
  528.  
  529.       POP_PRIMITIVE_FRAME (4);
  530.     Will_Push((2 * CONTINUATION_SIZE) + (STACK_ENV_EXTRA_SLOTS + 1));
  531.       /* Push a continuation to go back to the current state after the
  532.      body is evaluated */
  533.       Store_Expression (old_point);
  534.       Store_Return (RC_RESTORE_TO_STATE_POINT);
  535.       Save_Cont ();
  536.       /* Push a stack frame which will call the body after we have moved
  537.      into the new state point */
  538.       STACK_PUSH (during_thunk);
  539.       STACK_PUSH (STACK_FRAME_HEADER);
  540.       /* Push the continuation to go with the stack frame */
  541.       Store_Expression (SHARP_F);
  542.       Store_Return (RC_INTERNAL_APPLY);
  543.       Save_Cont ();
  544.     Pushed ();
  545.       Translate_To_Point (new_point);
  546.       /*NOTREACHED*/
  547.       PRIMITIVE_RETURN (UNSPECIFIC);
  548.     }
  549.   }
  550. }
  551.  
  552. DEFINE_PRIMITIVE ("TRANSLATE-TO-STATE-POINT", Prim_translate_to_point, 1, 1,
  553.           "(STATE-POINT)\nRestore the dynamic state to STATE-POINT.")
  554. {
  555.   PRIMITIVE_HEADER (1);
  556.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  557.   CHECK_ARG (1, STATE_POINT_P);
  558.   {
  559.     SCHEME_OBJECT state_point = (ARG_REF (1));
  560.     POP_PRIMITIVE_FRAME (1);
  561.     Translate_To_Point (state_point);
  562.     /*NOTREACHED*/
  563.     PRIMITIVE_RETURN (UNSPECIFIC);
  564.   }
  565. }
  566.  
  567. DEFINE_PRIMITIVE ("MAKE-STATE-SPACE", Prim_make_state_space, 1, 1,
  568.           "(MUTABLE?)\n\
  569. Return a newly-allocated state-space.\n\
  570. Argument MUTABLE?, if not #F, means return a mutable state-space.\n\
  571. Otherwise, -the- immutable state-space is saved internally.")
  572. {
  573.   PRIMITIVE_HEADER (1);
  574.   {
  575.     fast SCHEME_OBJECT new_point =
  576.       (allocate_marked_vector (TC_VECTOR, STATE_POINT_LENGTH, true));
  577.     FAST_MEMORY_SET
  578.       (new_point, STATE_POINT_TAG, (Get_Fixed_Obj_Slot (State_Point_Tag)));
  579.     FAST_MEMORY_SET (new_point, STATE_POINT_BEFORE_THUNK, SHARP_F);
  580.     FAST_MEMORY_SET (new_point, STATE_POINT_AFTER_THUNK, SHARP_F);
  581.     FAST_MEMORY_SET
  582.       (new_point, STATE_POINT_DISTANCE_TO_ROOT, (LONG_TO_UNSIGNED_FIXNUM (0)));
  583.     if ((ARG_REF (1)) == SHARP_F)
  584.       {
  585.     FAST_MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, SHARP_F);
  586.     Current_State_Point = new_point;
  587.     PRIMITIVE_RETURN (SHARP_F);
  588.       }
  589.     else
  590.       {
  591.     fast SCHEME_OBJECT new_space =
  592.       (allocate_marked_vector (TC_VECTOR, STATE_SPACE_LENGTH, true));
  593.     FAST_MEMORY_SET
  594.       (new_space, STATE_SPACE_TAG, (Get_Fixed_Obj_Slot (State_Space_Tag)));
  595.     FAST_MEMORY_SET (new_space, STATE_SPACE_NEAREST_POINT, new_point);
  596.     FAST_MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, new_space);
  597.     PRIMITIVE_RETURN (new_space);
  598.       }
  599.   }
  600. }
  601.  
  602. DEFINE_PRIMITIVE ("CURRENT-DYNAMIC-STATE", Prim_current_dynamic_state, 1, 1,
  603.           "(STATE-SPACE)\n\
  604. Return the current state point in STATE-SPACE. If STATE-SPACE is #F,\n\
  605. return the current state point in the global state space.")
  606. {
  607.   PRIMITIVE_HEADER (1);
  608.  
  609.   guarantee_state_point ();
  610.   if ((ARG_REF (1)) == SHARP_F)
  611.     PRIMITIVE_RETURN (Current_State_Point);
  612.   CHECK_ARG (1, STATE_SPACE_P);
  613.   PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), STATE_SPACE_NEAREST_POINT));
  614. }
  615.  
  616. DEFINE_PRIMITIVE ("SET-CURRENT-DYNAMIC-STATE!", Prim_set_dynamic_state, 1, 1,
  617.           "(STATE-POINT)\n\
  618. Set the current dynamic state point to STATE-POINT.")
  619. {
  620.   PRIMITIVE_HEADER (1);
  621.   CHECK_ARG (1, STATE_POINT_P);
  622.   {
  623.     fast SCHEME_OBJECT state_point = (ARG_REF (1));
  624.     fast SCHEME_OBJECT state_space = (Find_State_Space (state_point));
  625.     fast SCHEME_OBJECT result;
  626.     if (state_space == SHARP_F)
  627.       {
  628.     guarantee_state_point ();
  629.     result = Current_State_Point;
  630.     Current_State_Point = state_point;
  631.       }
  632.     else
  633.       {
  634.     result = (MEMORY_REF (state_space, STATE_SPACE_NEAREST_POINT));
  635.     MEMORY_SET (state_space, STATE_SPACE_NEAREST_POINT, state_point);
  636.       }
  637.     PRIMITIVE_RETURN (result);
  638.   }
  639. }
  640.  
  641. /* Interrupts */
  642.  
  643. DEFINE_PRIMITIVE ("GET-INTERRUPT-ENABLES", Prim_get_interrupt_enables, 0, 0,
  644.           "()\n\
  645. Returns the current interrupt mask.\n\
  646. There are two interrupt bit masks:\n\
  647. - The interrupt mask has a one bit for every enabled interrupt.\n\
  648. - The interrupt code has a one bit for every interrupt pending service.\n\
  649. Interrupts are prioritized according to their bit position (LSB is highest).\n\
  650. At any interrupt polling point, the highest enabled pending interrupt is\n\
  651. serviced.  The interrupt handler is a two-argument Scheme procedure\n\
  652. invoked with all interrupts disabled and with the interrupt code and mask\n\
  653. as arguments.  The interrupt mask is restored on return from the interrupt\n\
  654. handler.  To prevent re-servicing the interrupt, the interrupt handler\n\
  655. should clear the corresponding interrupt bit.")
  656. {
  657.   PRIMITIVE_HEADER (0);
  658.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (FETCH_INTERRUPT_MASK ()));
  659. }
  660.  
  661. DEFINE_PRIMITIVE ("SET-INTERRUPT-ENABLES!", Prim_set_interrupt_enables, 1, 1,
  662.           "(INTERRUPT-MASK)\n\
  663. Sets the interrupt mask to INTERRUPT-MASK; returns previous mask value.\n\
  664. See `get-interrupt-enables' for more information on interrupts.")
  665. {
  666.   PRIMITIVE_HEADER (1);
  667.   {
  668.     long previous = (FETCH_INTERRUPT_MASK ());
  669.     SET_INTERRUPT_MASK ((arg_integer (1)) & INT_Mask);
  670.     PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (previous));
  671.   }
  672. }
  673.  
  674. DEFINE_PRIMITIVE ("CLEAR-INTERRUPTS!", Prim_clear_interrupts, 1, 1,
  675.           "(INTERRUPT-MASK)\n\
  676. Clears the interrupt bits in INTERRUPT-MASK by clearing the\n\
  677. corresponding bits in the interrupt code.\n\
  678. See `get-interrupt-enables' for more information on interrupts.")
  679. {
  680.   PRIMITIVE_HEADER (1);
  681.   CLEAR_INTERRUPT ((arg_integer (1)) & INT_Mask);
  682.   PRIMITIVE_RETURN (UNSPECIFIC);
  683. }
  684.  
  685. DEFINE_PRIMITIVE ("DISABLE-INTERRUPTS!", Prim_disable_interrupts, 1, 1, 
  686.           "(INTERRUPT-MASK)\n\
  687. Disables the interrupts specified in INTERRUPT-MASK by clearing the\n\
  688. corresponding bits in the interrupt mask. Returns previous mask value.\n\
  689. See `get-interrupt-enables' for more information on interrupts.")
  690. {
  691.   PRIMITIVE_HEADER (1);
  692.   {
  693.     fast long previous = (FETCH_INTERRUPT_MASK ());
  694.     SET_INTERRUPT_MASK (previous &~ ((arg_integer (1)) & INT_Mask));
  695.     PRIMITIVE_RETURN (LONG_TO_FIXNUM (previous));
  696.   }
  697. }
  698.  
  699. DEFINE_PRIMITIVE ("ENABLE-INTERRUPTS!", Prim_enable_interrupts, 1, 1,
  700.           "(INTERRUPT-MASK)\n\
  701. Enables the interrupts specified in INTERRUPT-MASK by setting the\n\
  702. corresponding bits in the interrupt mask. Returns previous mask value.\n\
  703. See `get-interrupt-enables' for more information on interrupts.")
  704. {
  705.   PRIMITIVE_HEADER (1);
  706.   {
  707.     fast long previous = (FETCH_INTERRUPT_MASK ());
  708.     SET_INTERRUPT_MASK (previous | ((arg_integer (1)) & INT_Mask));
  709.     PRIMITIVE_RETURN (LONG_TO_FIXNUM (previous));
  710.   }
  711. }
  712.  
  713. DEFINE_PRIMITIVE ("REQUEST-INTERRUPTS!", Prim_request_interrupts, 1, 1,
  714.           "(INTERRUPT-MASK)\n\
  715. Requests the interrupt bits in INTERRUPT-MASK by setting the\n\
  716. corresponding bits in the interrupt code.\n\
  717. See `get-interrupt-enables' for more information on interrupts.")
  718. {
  719.   PRIMITIVE_HEADER (1);
  720.   REQUEST_INTERRUPT ((arg_integer (1)) & INT_Mask);
  721.   PRIMITIVE_RETURN (UNSPECIFIC);
  722. }
  723.  
  724. DEFINE_PRIMITIVE ("RETURN-TO-APPLICATION",
  725.           Prim_return_to_application, 2, LEXPR,
  726.   "(THUNK PROCEDURE . ARGS)\n\
  727. Invokes THUNK with no arguments and a special return address.\n\
  728. The return address calls PROCEDURE on ARGS.\n\
  729. This is used by the runtime system to create stack frames that can be\n\
  730. identified by the continuation parser.")
  731. {
  732.   PRIMITIVE_HEADER (LEXPR);
  733.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  734.   {
  735.     long nargs = (LEXPR_N_ARGUMENTS ());
  736.     if (nargs < 2)
  737.       signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  738.     {
  739.       SCHEME_OBJECT thunk = (STACK_POP ());
  740.       STACK_PUSH (STACK_FRAME_HEADER + (nargs - 2));
  741.       Store_Env (MAKE_OBJECT (GLOBAL_ENV, END_OF_CHAIN));
  742.       Store_Expression (SHARP_F);
  743.       Store_Return (RC_INTERNAL_APPLY);
  744.       Save_Cont ();
  745.     Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
  746.       STACK_PUSH (thunk);
  747.       STACK_PUSH (STACK_FRAME_HEADER);
  748.     Pushed ();
  749.     }
  750.   }
  751.   PRIMITIVE_ABORT (PRIM_APPLY);
  752.   /*NOTREACHED*/
  753.   PRIMITIVE_RETURN (UNSPECIFIC);
  754. }
  755.  
  756. DEFINE_PRIMITIVE ("WITH-STACK-MARKER", Prim_with_stack_marker, 3, 3,
  757.           "(THUNK MARKER1 MARKER2)\n\
  758. Call THUNK with a continuation that has a special marker.\n\
  759. When THUNK returns, the marker is discarded.\n\
  760. The value of THUNK is returned to the continuation of this primitive.\n\
  761. The marker consists of MARKER1 and MARKER2.\n\
  762. By convention, MARKER1 is a tag identifying the kind of marker,\n\
  763. and MARKER2 is data identifying the marker instance.")
  764. {
  765.   SCHEME_OBJECT thunk;
  766.   PRIMITIVE_HEADER (3);
  767.  
  768.   thunk = (ARG_REF (1));
  769.  
  770.   if ((COMPILED_CODE_ADDRESS_P (STACK_REF (3)))
  771.       && (COMPILED_CODE_ADDRESS_P (thunk)))
  772.   {
  773.     extern SCHEME_OBJECT EXFUN (compiled_with_stack_marker, (SCHEME_OBJECT));
  774.  
  775.     (void) STACK_POP ();
  776.     return (compiled_with_stack_marker (thunk));
  777.   }
  778.   else
  779.   {
  780.     PRIMITIVE_CANONICALIZE_CONTEXT ();
  781.  
  782.     (void) STACK_POP ();
  783.     STACK_PUSH (MAKE_OBJECT (TC_RETURN_CODE, RC_STACK_MARKER));
  784.    Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
  785.     STACK_PUSH (thunk);
  786.     STACK_PUSH (STACK_FRAME_HEADER);
  787.    Pushed ();
  788.     PRIMITIVE_ABORT (PRIM_APPLY);
  789.     /*NOTREACHED*/
  790.     return (0);
  791.   }
  792. }
  793.  
  794. static SCHEME_OBJECT 
  795. DEFUN (with_new_interrupt_mask, (new_mask), unsigned long new_mask)
  796. {
  797.   SCHEME_OBJECT receiver = (ARG_REF (2));
  798.  
  799.   if ((COMPILED_CODE_ADDRESS_P (STACK_REF (2)))
  800.       && (COMPILED_CODE_ADDRESS_P (receiver)))
  801.   {
  802.     extern SCHEME_OBJECT
  803.       EXFUN (compiled_with_interrupt_mask, (unsigned long,
  804.                         SCHEME_OBJECT,
  805.                         unsigned long));
  806.     unsigned long current_mask = (FETCH_INTERRUPT_MASK ());
  807.  
  808.     POP_PRIMITIVE_FRAME (2);
  809.     SET_INTERRUPT_MASK (new_mask);
  810.  
  811.     PRIMITIVE_RETURN
  812.       (compiled_with_interrupt_mask (current_mask, receiver, new_mask));
  813.   }
  814.   else
  815.   {
  816.     PRIMITIVE_CANONICALIZE_CONTEXT ();
  817.     POP_PRIMITIVE_FRAME (2);
  818.     preserve_interrupt_mask ();
  819.   Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
  820.     STACK_PUSH (LONG_TO_FIXNUM (FETCH_INTERRUPT_MASK ()));
  821.     STACK_PUSH (receiver);
  822.     STACK_PUSH (STACK_FRAME_HEADER + 1);
  823.   Pushed ();
  824.     SET_INTERRUPT_MASK (new_mask);
  825.     PRIMITIVE_ABORT (PRIM_APPLY);
  826.     /*NOTREACHED*/
  827.     return (0);
  828.   }
  829. }
  830.  
  831. DEFINE_PRIMITIVE ("WITH-INTERRUPT-MASK", Prim_with_interrupt_mask, 2, 2,
  832.           "(MASK RECEIVER)\n\
  833. Set the interrupt mask to MASK for the duration of the call to RECEIVER.\n\
  834. RECEIVER is passed the old interrupt mask as its argument.")
  835. {
  836.   PRIMITIVE_HEADER (2);
  837.   PRIMITIVE_RETURN (with_new_interrupt_mask (INT_Mask & (arg_integer (1))));
  838. }
  839.  
  840. DEFINE_PRIMITIVE ("WITH-INTERRUPTS-REDUCED",
  841.           Prim_with_interrupts_reduced, 2, 2,
  842.           "(MASK RECEIVER)\n\
  843. Like `with-interrupt-mask', but only disables interrupts.")
  844. {
  845.   unsigned long old_mask, new_mask;
  846.   PRIMITIVE_HEADER (2);
  847.  
  848.   old_mask = (FETCH_INTERRUPT_MASK ());
  849.   new_mask = (INT_Mask & (arg_integer (1)));
  850.   PRIMITIVE_RETURN (with_new_interrupt_mask ((new_mask > old_mask) ?
  851.                          new_mask :
  852.                          (new_mask & old_mask)));
  853. }
  854.  
  855. /* History */
  856.  
  857. SCHEME_OBJECT
  858. initialize_history ()
  859. {
  860.   /* Dummy History Structure */
  861.   History = (Make_Dummy_History ());
  862.   return
  863.     (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, (Make_Dummy_History ())));
  864. }
  865.  
  866. DEFINE_PRIMITIVE ("SET-CURRENT-HISTORY!", Prim_set_current_history, 1, 1,
  867.           "(HISTORY)\n\
  868. Set the interpreter's history object to HISTORY.")
  869. {
  870.   PRIMITIVE_HEADER (1);
  871.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  872.   CHECK_ARG (1, HUNK3_P);
  873.   Val = (*History);
  874. #ifndef DISABLE_HISTORY
  875.   History = (OBJECT_ADDRESS (ARG_REF (1)));
  876. #else
  877.   History = (OBJECT_ADDRESS (Get_Fixed_Obj_Slot (Dummy_History)));
  878. #endif
  879.   POP_PRIMITIVE_FRAME (1);
  880.   PRIMITIVE_ABORT (PRIM_POP_RETURN);
  881.   /*NOTREACHED*/
  882.   PRIMITIVE_RETURN (UNSPECIFIC);
  883. }
  884.  
  885. DEFINE_PRIMITIVE ("WITH-HISTORY-DISABLED", Prim_with_history_disabled, 1, 1,
  886.           "(THUNK)\nExecute THUNK with the interpreter's history OFF.")
  887. {
  888.   PRIMITIVE_HEADER (1);
  889.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  890.   {
  891.     SCHEME_OBJECT thunk = (ARG_REF (1));
  892.     /* Remove one reduction from the history before saving it */
  893.     SCHEME_OBJECT * first_rib = (OBJECT_ADDRESS (History [HIST_RIB]));
  894.     SCHEME_OBJECT * second_rib =
  895.       (OBJECT_ADDRESS (first_rib [RIB_NEXT_REDUCTION]));
  896.     if ((first_rib != second_rib) &&
  897.     (! (HISTORY_MARKED_P (first_rib [RIB_MARK]))))
  898.       {
  899.     HISTORY_MARK (second_rib [RIB_MARK]);
  900.     {
  901.       SCHEME_OBJECT * rib = first_rib;
  902.       while (1)
  903.         {
  904.           fast SCHEME_OBJECT * next_rib =
  905.         (OBJECT_ADDRESS (rib [RIB_NEXT_REDUCTION]));
  906.           if (next_rib == first_rib)
  907.         break;
  908.           rib = next_rib;
  909.         }
  910.       /* This maintains the mark in (History [HIST_RIB]). */
  911.       (History [HIST_RIB]) =
  912.         (MAKE_POINTER_OBJECT ((OBJECT_TYPE (History [HIST_RIB])), rib));
  913.     }
  914.       }
  915.     POP_PRIMITIVE_FRAME (1);
  916.     Stop_History ();
  917.   Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
  918.     STACK_PUSH (thunk);
  919.     STACK_PUSH (STACK_FRAME_HEADER);
  920.   Pushed ();
  921.     PRIMITIVE_ABORT (PRIM_APPLY);
  922.     /*NOTREACHED*/
  923.     PRIMITIVE_RETURN (UNSPECIFIC);
  924.   }
  925. }
  926.  
  927. /* Miscellaneous State */
  928.  
  929. DEFINE_PRIMITIVE ("GET-FLUID-BINDINGS", Prim_get_fluid_bindings, 0, 0,
  930.           "()\nReturn the current deep fluid bindings.")
  931. {
  932.   PRIMITIVE_HEADER (0);
  933.   PRIMITIVE_RETURN (Fluid_Bindings);
  934. }
  935.  
  936. DEFINE_PRIMITIVE ("SET-FLUID-BINDINGS!", Prim_set_fluid_bindings, 1, 1,
  937.           "(FLUID-BINDINGS-ALIST)\n\
  938. Set the current deep fluid bindings alist to FLUID-BINDINGS-ALIST.")
  939. {
  940.   PRIMITIVE_HEADER (1);
  941.   CHECK_ARG (1, APPARENT_LIST_P);
  942.   {
  943.     SCHEME_OBJECT old_bindings = Fluid_Bindings;
  944.     Fluid_Bindings = (ARG_REF (1));
  945.     PRIMITIVE_RETURN (old_bindings);
  946.   }
  947. }
  948.  
  949. DEFINE_PRIMITIVE ("GET-FIXED-OBJECTS-VECTOR",
  950.           Prim_get_fixed_objects_vector, 0, 0,
  951.           "()\nReturn the fixed objects vector (TM).") 
  952. {
  953.   PRIMITIVE_HEADER (0);
  954.   if (Valid_Fixed_Obj_Vector ())
  955.     PRIMITIVE_RETURN (Get_Fixed_Obj_Slot (Me_Myself));
  956.   PRIMITIVE_RETURN (SHARP_F);
  957. }
  958.  
  959. #ifndef SET_FIXED_OBJ_HOOK
  960. # define SET_FIXED_OBJ_HOOK(vector) Fixed_Objects = (vector)
  961. #endif
  962.  
  963. DEFINE_PRIMITIVE ("SET-FIXED-OBJECTS-VECTOR!",
  964.           Prim_set_fixed_objects_vector, 1, 1,
  965.           "(NEW-FOV)\nSet the fixed objects vector (TM) to NEW-FOV.")
  966. {
  967.   PRIMITIVE_HEADER (1);
  968.   CHECK_ARG (1, VECTOR_P);
  969.   {
  970.     fast SCHEME_OBJECT vector = (ARG_REF (1));
  971.     if ((VECTOR_LENGTH (vector)) < NFixed_Objects)
  972.       error_bad_range_arg (1);
  973.     {
  974.       SCHEME_OBJECT result =
  975.     ((Valid_Fixed_Obj_Vector ())
  976.      ? (Get_Fixed_Obj_Slot (Me_Myself))
  977.      : SHARP_F);
  978.       SET_FIXED_OBJ_HOOK (vector);
  979.       Set_Fixed_Obj_Slot (Me_Myself, vector);
  980.       PRIMITIVE_RETURN (result);
  981.     }
  982.   }
  983. }
  984.