⟦6232e024f⟧

TextFile

/*          Hey EMACS, this is -*- C -*- code!                 */

/****************************************************************
*                                                               *
*                         Copyright (c) 1985                    *
*               Massachusetts Institute of Technology           *
*                                                               *
* This material was developed by the Scheme project at the      *
* Massachusetts Institute of Technology, Department of          *
* Electrical Engineering and Computer Science.  Permission to   *
* copy this software, to redistribute it, and to use it for any *
* purpose is granted, subject to the following restrictions and *
* understandings.                                               *
*                                                               *
* 1. Any copy made of this software must include this copyright *
* notice in full.                                               *
*                                                               *
* 2. Users of this software agree to make their best efforts (a)*
* to return to the MIT Scheme project any improvements or       *
* extensions that they make, so that these may be included in   *
* future releases; and (b) to inform MIT of noteworthy uses of  *
* this software.                                                *
*                                                               *
* 3.  All materials developed as a consequence of the use of    *
* this software shall duly acknowledge such use, in accordance  *
* with the usual standards of acknowledging credit in academic  *
* research.                                                     *
*                                                               *
* 4. MIT has made no warrantee or representation that the       *
* operation of this software will be error-free, and MIT is     *
* under no obligation to provide any services, by way of        *
* maintenance, update, or otherwise.                            *
*                                                               *
* 5.  In conjunction with products arising from the use of this *
* material, there shall be no use of the name of the            *
* Massachusetts Institute of Technology nor of any adaptation   *
* thereof in any advertising, promotional, or sales literature  *
* without prior written consent from MIT in each case.          *
*                                                               *
****************************************************************/
\f


/* File: HOOKS.C
 *
 * This file contains various hooks and handles which connect the
 * primitives with the main interpreter.
 */

#include "scheme.h"
#include "primitive.h"
\f


/* (APPLY FN LIST-OF-ARGUMENTS)
      Calls the function FN on the arguments specified in the list
      LIST-OF-ARGUMENTS. FN must be a primitive procedure, compound
      procedure, or control point.
*/

Built_In_Primitive(Prim_Apply, 2, "APPLY")
{ Pointer New_Frame, List, *Next_From_Slot, *Next_To_Slot;
  long Number_Of_Args, i;
  /* Since this primitive must pop its own frame off and push a new
   * frame on the stack, it has to be careful.  Its own stack frame is
   * needed if an error or GC is required.  So these checks are done
   * first (at the cost of traversing the argument list twice), then
   * the primitive's frame is popped, and finally the new frame is
   * constructed.
   */
  Primitive_2_Args();
  Number_Of_Args = 0;
  Touch_In_Primitive(Arg2, List);
  Next_To_Slot = Free;
  while (Type_Code(List) == TC_LIST)
  { Number_Of_Args += 1;
    *Next_To_Slot++ = Vector_Ref(List, CONS_CAR);
    Primitive_GC_If_Needed(Next_To_Slot);
    Touch_In_Primitive(Vector_Ref(List, CONS_CDR), List);
  }
  if (List != NIL)
    Primitive_Error(ERR_ARG_2_WRONG_TYPE);
  Pop_Primitive_Frame(2);
  Next_From_Slot = Free;
  Next_To_Slot = Stack_Pointer - Number_Of_Args;
 Will_Push(Number_Of_Args + STACK_ENV_EXTRA_SLOTS + 1);
			/* + 1 for the vector header */
  Stack_Pointer = Next_To_Slot;
  for (i=0; i < Number_Of_Args; i++) *Next_To_Slot++ = *Next_From_Slot++;
  Push(Arg1);		/* The function */
  Push(STACK_FRAME_HEADER+Number_Of_Args);
 Pushed();
  longjmp(*Back_To_Eval, PRIM_APPLY);
}
\f


/* (CATCH PROCEDURE)
      [Primitive number 0x03]
      Creates a control point (copy of the current stack) and passes
      it to PROCEDURE as its only argument.  The inverse operation,
      typically called THROW, is performed by using the control point
      as you would a procedure.  A control point accepts one argument
      which is then returned as the value of the CATCH which created
      the control point.  A control point may be reused as often as
      desired, since the stack is copied when it is made and then
      copied back on every throw.  The user level CATCH is built on
      this primitive but is not the same, since it handles
      dynamic-wind while the primitive does not.
*/
Built_In_Primitive(Prim_Catch, 1, "CALL-WITH-CURRENT-CONTINUATION")
{ Pointer Control_Point;
  long Length;
  fast Pointer *From_Where;
  fast long i, Stack_Cells;
  /* Implementation detail: in addition to making a copy of the stack
     as described above, the actual stack is cleared and a return
     code is placed at the base of the (now clear) stack indicating
     that a return back through here requires restoring the control
     point. The currently enabled interrupts are also saved away here
     and restored on a throw.
     >>> Temporarily (maybe) the act of doing a CATCH will disable any
     >>> return hook that may be in the stack.
  */
  Primitive_1_Arg();
  /* Should be a call to Make_Control_Point, but in-line coded */
  Stack_Cells = (Stack_Top - Stack_Pointer) - 1;
  /* The "- 1" is for the frame that is about to be popped */
  Length = Stack_Cells + REGBLOCK_NDISPLAYS + 2;
  Primitive_GC_If_Needed(Free + Length + 1);
  Pop_Primitive_Frame(1);
  if (Return_Hook_Address != NULL)
  { *Return_Hook_Address = Old_Return_Code;
    Return_Hook_Address = NULL;
  }

/* Prim_Catch continues on the next page */
\f


/* Prim_Catch, continued */

  /* Save Display Registers */
  Control_Point = Make_Pointer(TC_CONTROL_POINT, Free);
  *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Length);
  *Free++ = Make_Non_Pointer(TC_FIXNUM, IntEnb);
  if (Previous_Restore_History == NULL)
    *Free++ = FIXNUM_0;
  else
  { *Free++ = Make_Non_Pointer(TC_FIXNUM,
                               (Previous_Restore_History-Stack_Pointer));
    Previous_Restore_History[CONTINUATION_RETURN_CODE-
                             (1+CONTINUATION_SIZE)] =
      Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
  }

#ifdef COMPILER
  for(i=0, From_Where = &Registers[REGBLOCK_DISPLAYS];
      i < REGBLOCK_NDISPLAYS; i++) *Free++ = *From_Where++;
#else
  for(i=0; i < REGBLOCK_NDISPLAYS; i++) *Free++ = NIL;
#endif

  for (i=0; i < Stack_Cells; i++) *Free++ = Pop();
  if (Consistency_Check)  
    if (Stack_Pointer != Stack_Top)
      Microcode_Termination(TERM_BAD_STACK);
  Store_Expression(Control_Point);
  Store_Return(RC_RESTORE_CONTROL_POINT);
  Save_Cont();
  Previous_Restore_History = NULL;
/* End of Make_Control_Point */
/* Will_Push(3); -- we just cleared the stack so there MUST be room */
  Push(Control_Point);
  Push(Arg1);	/* Function */
  Push(STACK_FRAME_HEADER+1);
/*  Pushed(); */
  longjmp(*Back_To_Eval, PRIM_APPLY);
}
\f


/* (ENABLE-INTERRUPTS! INTERRUPTS)
      [Primitive number 0x06]
      Changes the enabled interrupt bits to bitwise-or of INTERRUPTS
      and previous value of interrupts.  Returns the previous value.
      See MASK_INTERRUPT_ENABLES for more information on interrupts.
*/
Built_In_Primitive(Prim_Enable_Interrupts, 1, "ENABLE-INTERRUPTS!")
{ Pointer Result;
  Primitive_1_Arg();
  Arg_1_Type(TC_FIXNUM);
  Result = Make_Non_Pointer(TC_FIXNUM, IntEnb);
  IntEnb = Get_Integer(Arg1) | INT_Mask;
  New_Compiler_MemTop();
  return Result;
}

/* (GET_FIXED_OBJECTS_VECTOR)
      [Primitive number 0x7A]
      Returns the current fixed objects vector.  This vector is used
      for communication between the interpreter and the runtime
      system.  See the file UTABCSCM.SCM in the runtime system for the
      names of the slots in the vector.
*/
Built_In_Primitive(Prim_Get_Fixed_Objects_Vector, 0,
		 "GET-FIXED-OBJECTS-VECTOR")
{ Primitive_0_Args();
  if (Valid_Fixed_Obj_Vector())
    return Get_Fixed_Obj_Slot(Me_Myself);
  else return NIL;
}
\f


/* (FORCE DELAYED-OBJECT)
      [Primitive number 0xAF]
      Returns the memoized value of the DELAYED-OBJECT (created by a
      DELAY special form) if it has already been calculated.
      Otherwise, it calculates the value and memoizes it for future
      use.
*/
Built_In_Primitive(Prim_Force, 1, "FORCE")
{ Primitive_1_Arg();
  Arg_1_Type(TC_DELAYED);
  if (Vector_Ref(Arg1, THUNK_SNAPPED) == TRUTH)
    return Vector_Ref(Arg1, THUNK_VALUE);
  Pop_Primitive_Frame(1);
 Will_Push(2);
  Store_Return(RC_SNAP_NEED_THUNK);
  Store_Expression(Arg1);
  Save_Cont();
 Pushed();
  Store_Env(Fast_Vector_Ref(Arg1, THUNK_ENVIRONMENT));
  Store_Expression(Fast_Vector_Ref(Arg1, THUNK_PROCEDURE));
  longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION);
}
\f


/* (EXECUTE_AT_NEW_POINT SPACE BACKWARD CONS)
      [Primitive number 0xE2]
      Create a new state point in the specified state SPACE.  To enter
      the new point you must execute the BACKWARD thunk.  The CONS has
      the forward thunk in its CAR, and the code to execute at that
      point in its CDR.
*/
Built_In_Primitive(Prim_Execute_At_New_Point, 3, "EXECUTE-AT-NEW-POINT")
{ Primitive_3_Args();
  Arg_1_Type(TC_VECTOR);
  if (Vector_Ref(Arg1, STATE_SPACE_TAG) !=
      Get_Fixed_Obj_Slot(State_Space_Tag))
    Primitive_Error(ERR_ARG_1_WRONG_TYPE);
  Arg_3_Type(TC_LIST);
  Primitive_GC_If_Needed(Free+5);
  Free[STATE_POINT_HEADER] = Make_Non_Pointer(TC_MANIFEST_VECTOR, 4);
  Free[STATE_POINT_TAG] = Get_Fixed_Obj_Slot(State_Point_Tag);
  Free[STATE_POINT_FORWARD_THUNK] = Vector_Ref(Arg3, CONS_CAR);
  Free[STATE_POINT_BACKWARD_THUNK] = Arg2;
  Free[STATE_POINT_NEARER_POINT] =
    Vector_Ref(Arg1, STATE_SPACE_NEAREST_POINT);
  Free += 5;
  Pop_Primitive_Frame(3);
 Will_Push(2*CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1));
  /* Push a continuation to go back to the current state after the
     body is evaluated */
  Store_Expression(Vector_Ref(Arg1, STATE_SPACE_NEAREST_POINT));
  Store_Return(RC_RESTORE_TO_STATE_POINT);
  Save_Cont();
  /* Push a stack frame which will call the body after we have moved
     into the new state point */
  Push(Vector_Ref(Arg3, CONS_CDR));
  Push(STACK_FRAME_HEADER);
  /* Push the continuation to go with the stack frame */
  Store_Expression(NIL);
  Store_Return(RC_INTERNAL_APPLY);
  Save_Cont();
 Pushed();
  /* And set up to go off to the requested state point */
  Store_Expression(Make_Pointer(TC_VECTOR, Free-5));
  longjmp(*Back_To_Eval, PRIM_TRANSLATE);
}
\f


/* (MASK_INTERRUPT_ENABLES MASK)
      [Primitive number 0xC9]
      ANDs the internal interrupt register with the specified value
      and returns the previous value.  The precise definition of the
      interrupt bits is available only by reference to the interpreter
      implementation.
*/
Built_In_Primitive(Prim_Mask_Interrupt_Enables, 1, "MASK-INTERRUPT-ENABLES!")
{ Pointer Result;
  /* The bits are defined in CONST.H */
  Primitive_1_Arg();
  Arg_1_Type(TC_FIXNUM);
  Result = FIXNUM_0+IntEnb;
  IntEnb &= Get_Integer(Arg1);
  New_Compiler_MemTop();
  return Result;
}

/* (MAKE_STATE_SPACE)
      [Primitive number 0xE1]
      Creates a new state space for the dynamic winder.  Used only
      internally to the dynamic wind operations.
*/
Built_In_Primitive(Prim_Make_State_Space, 0, "MAKE-STATE-SPACE")
{ Primitive_0_Args();
  Primitive_GC_If_Needed(Free+8);
  Free[STATE_POINT_HEADER] = Make_Non_Pointer(TC_MANIFEST_VECTOR, 4);
  Free[STATE_POINT_TAG] = Get_Fixed_Obj_Slot(State_Point_Tag);
  Free[STATE_POINT_FORWARD_THUNK] = NIL;
  Free[STATE_POINT_BACKWARD_THUNK] = NIL;
  Free[STATE_POINT_NEARER_POINT] = Make_Pointer(TC_VECTOR, Free+5);
  Free += 5;
  Free[STATE_SPACE_HEADER] = Make_Non_Pointer(TC_MANIFEST_VECTOR, 2);
  Free[STATE_SPACE_TAG] = Get_Fixed_Obj_Slot(State_Space_Tag);
  Free[STATE_SPACE_NEAREST_POINT] = Make_Pointer(TC_VECTOR, Free-5);
  Free += 3;
  return Make_Pointer(TC_VECTOR, Free-3);
}
\f


/* (SCODE_EVAL SCODE-EXPRESSION ENVIRONMENT)
      [Primitive number 0x04]
      Evaluate the piece of SCode (SCODE-EXPRESSION) in the
      ENVIRONMENT. This is like Eval, except that it expects its input
      to be syntaxed into SCode rather than just a list.
*/
Built_In_Primitive(Prim_Scode_Eval, 2, "SCODE-EVAL")
{ Primitive_2_Args();
  if (Type_Code(Arg2) != GLOBAL_ENV) Arg_2_Type(TC_ENVIRONMENT);
  Pop_Primitive_Frame(2);
  Store_Env(Arg2);
  Store_Expression(Arg1);
  longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION);
}

/* (SET_INTERRUPT_ENABLES NEW-INT-ENABLES)
      [Primitive number 0x06]
      Changes the enabled interrupt bits to NEW-INT-ENABLES and
      returns the previous value.  See MASK_INTERRUPT_ENABLES for more
      information on interrupts.
*/
Built_In_Primitive(Prim_Set_Interrupt_Enables, 1, "SET-INTERRUPT-ENABLES!")
{ Pointer Result;
  Primitive_1_Arg();
  Arg_1_Type(TC_FIXNUM);
  Result = FIXNUM_0+IntEnb;
  IntEnb = Get_Integer(Arg1) & INT_Mask;
  New_Compiler_MemTop();
  return Result;
}

/* Called with a mask and a thunk */
Built_In_Primitive(Prim_With_Interrupt_Mask, 2, "WITH-INTERRUPT-MASK")
{ Pointer New_Mask;
  Primitive_2_Args();
  Arg_1_Type(TC_FIXNUM);
  Pop_Primitive_Frame(2);
 Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2));
  Store_Return(RC_RESTORE_INT_MASK);
  Store_Expression(FIXNUM_0+IntEnb);
  Save_Cont();
  Push(FIXNUM_0 + IntEnb);	/* Current interrupt mask */
  Push(Arg2);			/* Function to call */
  Push(STACK_FRAME_HEADER+1);
 Pushed();
  IntEnb = INT_Mask & Get_Integer(Arg1);
  longjmp(*Back_To_Eval, PRIM_APPLY);
}
\f


/* (SET_CURRENT_HISTORY TRIPLE)
      [Primitive number 0x2F]
      Begins recording history into TRIPLE.  The history structure is
      somewhat complex and should be understood before trying to use
      this primitive.  It is used in the Read-Eval-Print loop in the
      Scheme runtime system.
*/
Built_In_Primitive(Prim_Set_Current_History, 1, "SET-CURRENT-HISTORY")
{ Pointer Result;
  Primitive_1_Arg();
  Arg_1_Type(TC_HUNK3);
  Result = *History;
#ifdef COMPILE_HISTORY
  History = Get_Pointer(Arg1);
#else
  History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History));
#endif
  return Result;
}

/* (SET_FIXED_OBJECTS_VECTOR VECTOR)
      [Primitive number 0x7B]
      Replace the current fixed objects vector with VECTOR.  The fixed
      objects vector is used for communication between the Scheme
      runtime system and the interpreter.  The file UTABCSCM.SCM
      contains the names of the slots in the vector.  Returns (bad
      style to depend on this) the previous fixed objects vector.
*/
Built_In_Primitive(Prim_Set_Fixed_Objects_Vector, 1,
		   "SET-FIXED-OBJECTS-VECTOR!")
{ Pointer Result;
  Primitive_1_Arg();
  Arg_1_Type(TC_VECTOR);

  if (Valid_Fixed_Obj_Vector())
    Result = Get_Fixed_Obj_Slot(Me_Myself);
  else Result = NIL;
  Set_Fixed_Obj_Hook(Arg1);
  Set_Fixed_Obj_Slot(Me_Myself, Arg1);
  return Result;
}
\f


/* (WITH_HISTORY_DISABLED THUNK)
      [Primitive number 0x9C]
      THUNK must be a procedure or primitive procedure which takes no
      arguments.  Turns off the history collection mechanism.  Removes
      the most recent reduction (the expression which called the
      primitive) from the current history and saves the history.  Then
      it calls the THUNK.  When (if) the THUNK returns, the history is
      restored back and collection resumes.  The net result is that the
      THUNK is called with history collection turned off.
*/
Built_In_Primitive(Prim_With_History_Disabled, 1, "WITH-HISTORY-DISABLED")
{ Pointer *First_Rib, *Rib, *Second_Rib;
  Primitive_1_Arg();
  /* Remove one reduction from the history before saving it */
  First_Rib = Get_Pointer(History[HIST_RIB]);
  Second_Rib = Get_Pointer(First_Rib[RIB_NEXT_REDUCTION]);
  if (!((Dangerous(First_Rib[RIB_MARK])) ||
       (First_Rib == Second_Rib)))
  { Set_Danger_Bit(Second_Rib[RIB_MARK]);
    for (Rib = First_Rib;
         Get_Pointer(Rib[RIB_NEXT_REDUCTION]) != First_Rib;
         Rib = Get_Pointer(Rib[RIB_NEXT_REDUCTION]))
    { /* Look for one that points to the first rib */ }
    History[HIST_RIB] = Make_Pointer(Type_Code(History[HIST_RIB]), Rib);
  }
  Pop_Primitive_Frame(1);
  Stop_History();
 Will_Push(STACK_ENV_EXTRA_SLOTS+1);
  Push(Arg1);
  Push(STACK_FRAME_HEADER);
 Pushed();
  longjmp(*Back_To_Eval, PRIM_APPLY);
}
\f


/* (WITHIN_CONTROL_POINT CONTROL-POINT THUNK)
      [Primitive number 0xBF]
      THUNK must be a procedure or primitive procedure which takes no
      arguments.  Restores the state of the machine from the control
      point, and then calls the THUNK in this new state.
*/
Built_In_Primitive(Prim_Within_Control_Point, 2, "WITHIN-CONTROL-POINT")
{ Primitive_2_Args();
  Arg_1_Type(TC_CONTROL_POINT);
  Throw(Arg1);
 Will_Push(STACK_ENV_EXTRA_SLOTS+1);
  Push(Arg2);
  Push(STACK_FRAME_HEADER);
 Pushed();
  longjmp(*Back_To_Eval, PRIM_APPLY);
}
/* (WITH_THREADED_STACK PROCEDURE THUNK)
      [Primitive number 0xBE]
      THUNK must be a procedure or primitive procedure which takes no
      arguments.  PROCEDURE must expect one argument.  Basically this
      primitive does (PROCEDURE (THUNK)) ... it calls the THUNK and
      passes the result on as an argument to PROCEDURE.  However, it
      leaves a "well-known continuation code" on the stack for use by
      the continuation parser in the Scheme runtime system.
*/
Built_In_Primitive(Prim_With_Threaded_Stack, 2, "WITH-THREADED-STACK")
{ Primitive_2_Args();
  Pop_Primitive_Frame(2);
 Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1));
  Store_Expression(Arg1);	/* Save procedure to call later */
  Store_Return(RC_INVOKE_STACK_THREAD);
  Save_Cont();
  Push(Arg2);	/* Function to call now */
  Push(STACK_FRAME_HEADER);
 Pushed();
  longjmp(*Back_To_Eval, PRIM_APPLY);
}
\f


/* (TRANSLATE_TO_POINT STATE_POINT)
      [Primitive number 0xE3]
      Move to a new dynamic wind environment by performing all of the
      necessary enter and exit forms to get form the current state to
      the new state as specified by STATE_POINT.
*/
Built_In_Primitive(Prim_Translate_To_Point, 1, "TRANSLATE-TO-POINT")
{ Primitive_1_Arg();
  Arg_1_Type(TC_VECTOR);
  if (Vector_Ref(Arg1, STATE_POINT_TAG) != Get_Fixed_Obj_Slot(State_Point_Tag))
    Primitive_Error(ERR_ARG_1_WRONG_TYPE);
  Pop_Primitive_Frame(1);
  Store_Expression(Arg1);
  longjmp(*Back_To_Eval, PRIM_TRANSLATE);
}
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦6232e024f⟧ TextFile

Derivation

TextFile
