⟦fe663cf12⟧

TextFile

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

/****************************************************************
*                                                               *
*                         Copyright (c) 1984                    *
*               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: Utils.C
 *
 * This file contains a number of utility routines for use
 * in the Scheme SCode interpreter.
 */

#include "scheme.h"
#include "primitive.h"

/* Set_Up_Interrupt is called from the Interrupt
 * macro to do all of the setup for calling the user's
 * interrupt routines.
 */

void Setup_Interrupt(Masked_Interrupts)
long Masked_Interrupts;
{ Pointer Int_Vector, Handler;
  long i, Int_Number, The_Int_Code = IntCode, New_Int_Enb;

  Int_Vector = Get_Fixed_Obj_Slot(System_Interrupt_Vector);
  for (Int_Number=0, i=1; Int_Number < MAX_INTERRUPT_NUMBER;
       i = i<<1, Int_Number++) if ((Masked_Interrupts & i) != 0) goto OK;
  printf("Int_Vector %x\n", Int_Vector);
  printf("\nInterrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n",
         IntCode, IntEnb, Masked_Interrupts);
  Microcode_Termination(TERM_NO_INTERRUPT_HANDLER);
OK:
  New_Int_Enb = (1<<Int_Number)-1;
  Global_Interrupt_Hook();
  if (Int_Number > Vector_Length(Int_Vector))
  { printf("\nInterrupt out of range: 0x%x (vector length = 0x%x)\n",
           Int_Number, Vector_Length(Int_Vector));
    printf("Interrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n",
           IntCode, IntEnb, Masked_Interrupts);
    Microcode_Termination(TERM_NO_INTERRUPT_HANDLER);
  }
  else Handler = User_Vector_Ref(Int_Vector, Int_Number);

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


/* Setup_Interrupts, continued */

Passed_Checks:
  Stop_History();
 Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS+3);
  /* Return from interrupt handler will re-enable interrupts */
  Store_Return(RC_RESTORE_INT_MASK);
  Store_Expression(FIXNUM_0 + IntEnb);
  Save_Cont();

/* Now make an environment frame for use in calling the
 * user supplied interrupt routine.  It will be given
 * two arguments: the UNmasked interrupt requests, and
 * the currently enabled interrupts.
 */

  Push(FIXNUM_0+IntEnb);
  Push(FIXNUM_0+The_Int_Code);
  Push(Handler);
  Push(STACK_FRAME_HEADER+2);
 Pushed();
  IntEnb = New_Int_Enb;	/* Turn off interrupts */
  New_Compiler_MemTop();
}
\f


                      /******************/
                      /* ERROR HANDLING */
                      /******************/

/* It is assumed that any caller of the error code has already
 * restored its state to a situation which will make it
 * restartable if the error handler returns normally.  As a
 * result, the only work to be done on an error is to verify
 * that there is an error handler, save the current continuation and
 * create a new one if entered from Pop_Return rather than Eval,
 * turn off interrupts, and call it with two arguments: Error-Code
 * and Interrupt-Enables.
 */

/* Back_Out_Of_Primitive pushes the primitive number and prepares an
 * appropriate return code so that the primitive can be restarted.
 */

void Back_Out_Of_Primitive()
{ 
  /* When you come back to the primitive, the environment is
   * irrelevant .... primitives run with no real environment.
   * Similarly, the value register is meaningless. 
   */
  Store_Return(RC_REPEAT_PRIMITIVE);
  Store_Env(Make_Non_Pointer(GLOBAL_ENV, END_OF_CHAIN));
  Val = NIL;
}

void Do_Micro_Error(Err, From_Pop_Return)
long Err;
Boolean From_Pop_Return;
{ Pointer Error_Vector, Handler;

  if (Consistency_Check)
  { printf( "Error 0x%x happened.\n", Err);
    Print_Expression(Fetch_Expression(), "Expression was");
    printf("\nEnvironment 0x%x (#%o).\n", Fetch_Env(), Fetch_Env());
    Print_Return("Return code");
    printf( "\n");
  }
  Error_Exit_Hook();
  if (Trace_On_Error)
  { printf( "\n\nStack trace:\n\n");
    Back_Trace();
  }

/* Do_Micro_Error continues on the next page. */
\f


/* Do_Micro_Error, continued */

#ifdef ENABLE_DEBUGGING_TOOLS
  Copy_Trace_Circle();
#endif  
  if ((!Valid_Fixed_Obj_Vector()) ||
      (Consistency_Check &&
       (Vector_Length(Fixed_Objects) <= System_Error_Vector))  || 
      (Type_Code((Error_Vector = 
		  User_Vector_Ref(Fixed_Objects, System_Error_Vector))) !=
       TC_VECTOR))
  { printf("\nBogus Error Vector! I'm terribly confused!\n");
    Microcode_Termination(TERM_NO_ERROR_HANDLER, Err);
  }
  if (Err >= Vector_Length(Error_Vector))
  { if (Vector_Length(Error_Vector) == 0)
    { printf("\nEmpty Error Vector! I'm terribly confused!\n");
      Microcode_Termination(TERM_NO_ERROR_HANDLER, Err);
    }
    Handler = User_Vector_Ref(Error_Vector, ERR_BAD_ERROR_CODE);
  }
  else Handler = User_Vector_Ref(Error_Vector, Err);
  if (From_Pop_Return) Save_Cont();
  Stop_History();
 Will_Push(STACK_ENV_EXTRA_SLOTS+3+2*CONTINUATION_SIZE+
           (From_Pop_Return ? 0 : 1));
  if (From_Pop_Return) Store_Expression(Val);
  else Push(Fetch_Env());
  Store_Return(From_Pop_Return? RC_POP_RETURN_ERROR : RC_EVAL_ERROR);
  Save_Cont();
  /* Return from interrupt handler will re-enable interrupts */
  Store_Return(RC_RESTORE_INT_MASK);
  Store_Expression(FIXNUM_0 + IntEnb);
  Save_Cont();
  Push(FIXNUM_0+IntEnb);		    /* Arg 2:    Int. mask */
  Push(FIXNUM_0+Err);			    /* Arg 1:    Err. No   */
  Push(Handler);			    /* Function: Handler   */
  Push(STACK_FRAME_HEADER+2);
 Pushed();
  IntEnb = 0;		/* Turn off interrupts */
  New_Compiler_MemTop();
}
\f


                      /******************/
                      /* CONTROL POINTS */
                      /******************/

/* Pointer Make_Control_Point() -- this function logically
   belongs here, and is documented here, but has been coded
   in-line in the one place it is used: Prim_Catch
*/

void Throw(P)
/* Clear the stack and replace it with a copy of the contents of the
   control point. Also disables the history collection mechanism,
   since the saved history would be incorrect on the new stack.
*/
Pointer P;
{ long    NCells, Offset;
  fast Pointer *To_Where, *From_Where;
  fast long i;

  if (Consistency_Check)
    if (Type_Code(P) != TC_CONTROL_POINT)
      Microcode_Termination(TERM_BAD_STACK);
  NCells = Vector_Length(P) - (2+REGBLOCK_NDISPLAYS);
  Stack_Check(Stack_Top - NCells);
  From_Where = Nth_Vector_Loc(P, 1);
  IntEnb = Get_Integer(*From_Where++);
  Offset = Get_Integer(*From_Where++);
#ifdef COMPILER
  /* Restore Displays */
  To_Where = &Registers[REGBLOCK_DISPLAYS];
  for (i=0; i < REGBLOCK_NDISPLAYS; i++) *To_Where++ = *From_Where++;
#else
  From_Where = &From_Where[REGBLOCK_NDISPLAYS];
#endif
  To_Where = Stack_Top - NCells;
  Stack_Pointer = To_Where;
  for (i=0; i < NCells; i++) *To_Where++ = *From_Where++;
  if (Offset==0) Previous_Restore_History = NULL;
  else Previous_Restore_History = Stack_Pointer+Offset;
  New_Compiler_MemTop();
  if (Consistency_Check)
    if ((To_Where != Stack_Top) ||
        (From_Where != Nth_Vector_Loc(P, 1+Vector_Length(P))))
      Microcode_Termination(TERM_BAD_STACK);
  if ((!Valid_Fixed_Obj_Vector()) ||
      (Get_Fixed_Obj_Slot(Dummy_History) == NIL))
    History = Make_Dummy_History();
  else History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History));
}
\f


/* Make a Scheme string with the characters in C_String. */

Pointer C_String_To_Scheme_String(C_String)
fast char *C_String;
{ fast char *Next;
  fast long Length, Max_Length;
  Pointer Result;

  Result = Make_Pointer(TC_CHARACTER_STRING, Free);
  Next = (char *) Nth_Vector_Loc(Result, STRING_CHARS);
  Max_Length = ((Space_Before_GC() - STRING_CHARS) *
                sizeof(Pointer));
  if (C_String == NULL)
    Length = 0;
  else
    for (Length = 0;
	 (*C_String != '\0') && (Length < Max_Length);
	 Length += 1)
      *Next++ = *C_String++;
  if (Length >= Max_Length) 
    Primitive_GC();
  *Next = '\0';
  Free += STRING_CHARS + (Length+sizeof(Pointer))/sizeof(Pointer);
  Vector_Set(Result, STRING_LENGTH, FIXNUM_0+Length);
  Vector_Set(Result, STRING_HEADER,
    Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Free-Get_Pointer(Result))-1));
  return Result;
}
\f


Boolean Open_File(Name, Mode_String, File_Handle)
Pointer Name;
char *Mode_String;
FILE **File_Handle;
{ *File_Handle = fopen(Scheme_String_To_C_String(Name), Mode_String);
  return (Boolean) (*File_Handle != NULL);
}

Close_File(File_Handle)
FILE *File_Handle;
{ fclose(File_Handle);
  return;
}

Pointer *Make_Dummy_History()
{ Pointer *History_Rib = Free;
  Pointer *Result;

  Free[RIB_EXP] = NIL;
  Free[RIB_ENV] = NIL;
  Free[RIB_NEXT_REDUCTION] =
    Make_Pointer(TC_HUNK3, History_Rib);
  Free += 3;
  Result = Free;
  Free[HIST_RIB] = Make_Pointer(TC_HUNK3, History_Rib);
  Free[HIST_NEXT_SUBPROBLEM] =
    Make_Pointer(TC_HUNK3, Result);
  Free[HIST_PREV_SUBPROBLEM] =
    Make_Pointer(TC_HUNK3, Result);
  Free += 3;
  return Result;
}
\f


/* The entire trick to history is right here: it is either copied or
   reused when restored.  Initially, Stop_History marks the stack so
   that the history will merely be popped and reused.  On a catch,
   however, the return code is changed to force the history to be
   copied instead.  Thus, histories saved as part of a control point
   are not side-effected in the history collection process.
*/

void Stop_History()
{ long Previous = (Previous_Restore_History==NULL) ?
         0 : (Previous_Restore_History-Stack_Pointer);
  Pointer Save_Exp=Fetch_Expression(), Save_Ret=Fetch_Return();
  Previous_Restore_History = Stack_Pointer;
 Will_Push(3);
  Push(Make_Non_Pointer(TC_FIXNUM, Previous));
  Store_Expression(Make_Pointer(TC_HUNK3, History));
  Store_Return(RC_RESTORE_DONT_COPY_HISTORY);
  Save_Cont();
 Pushed();
  History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History));
  Store_Expression(Save_Exp);
  Store_Return(Save_Ret);
}

Pointer *Copy_Rib(Orig_Rib)
Pointer *Orig_Rib;
{ Pointer *Result, *This_Rib;
  for (This_Rib=NULL, Result=Free;
       (This_Rib != Orig_Rib) && (!GC_Check(Free));
       This_Rib = Get_Pointer(This_Rib[RIB_NEXT_REDUCTION]))
  { if (This_Rib==NULL) This_Rib = Orig_Rib;
    Free[RIB_EXP] = This_Rib[RIB_EXP];
    Free[RIB_ENV] = This_Rib[RIB_ENV];
    Free[RIB_NEXT_REDUCTION] = Make_Pointer(TC_HUNK3, Free+3);
    if (Dangerous(This_Rib[RIB_MARK])) Free[RIB_MARK] |= DANGER_BIT;
    Free += 3;
  }
  Store_Address((Free-3)[RIB_NEXT_REDUCTION], C_To_Scheme(Result));
  return Result;
}
\f


/* Restore_History pops a history object off the stack and
   makes a COPY of it the current history collection object.
   This is called only from the RC_RESTORE_HISTORY case in
   Basmod.
*/

Boolean Restore_History(Hist_Obj)
Pointer Hist_Obj;
{ Pointer *New_History, *Next_Vertebra, *Prev_Vertebra,
          *Orig_Vertebra;
  long Offset;
  if (Consistency_Check)
    if (Type_Code(Hist_Obj) != TC_HUNK3)
    { printf("Bad history to restore.\n");
      Microcode_Termination(TERM_EXIT);
    }
  Orig_Vertebra = Get_Pointer(Hist_Obj);
  for (Next_Vertebra=NULL, Prev_Vertebra=NULL;
       Next_Vertebra != Orig_Vertebra;
       Next_Vertebra = 
         Get_Pointer(Next_Vertebra[HIST_NEXT_SUBPROBLEM]))
  { Pointer *New_Rib;
    if (Prev_Vertebra==NULL) Next_Vertebra = Orig_Vertebra;
    New_Rib = Copy_Rib(Get_Pointer(Next_Vertebra[HIST_RIB]));
    if (Prev_Vertebra==NULL) New_History = Free;
    else Prev_Vertebra[HIST_NEXT_SUBPROBLEM] =
           Make_Pointer(TC_HUNK3, Free);
    Free[HIST_RIB] = Make_Pointer(TC_HUNK3, New_Rib);
    Free[HIST_NEXT_SUBPROBLEM] = NIL;
    Free[HIST_PREV_SUBPROBLEM] =
      Make_Pointer(TC_HUNK3, Prev_Vertebra);
    if (Dangerous(Next_Vertebra[HIST_MARK]))
      Free[HIST_MARK] |= DANGER_BIT;
    Prev_Vertebra = Free;
    Free += 3;
    if (GC_Check(Free)) return false;
  }
  Store_Address(New_History[HIST_PREV_SUBPROBLEM], C_To_Scheme(Free-3));
  Prev_Vertebra[HIST_NEXT_SUBPROBLEM] =
    Make_Pointer(TC_HUNK3, New_History); 
  if (Dangerous(Orig_Vertebra[HIST_MARK]))
    Prev_Vertebra[HIST_MARK] |= DANGER_BIT;
  History = New_History;
  return true;
}

CRLF()
{ printf( "\n");
}
\f


void Err_Print(Micro_Error)
{ switch (Micro_Error)
  { 
/*  case ERR_BAD_ERROR_CODE:
      printf("unknown error code.\n"); break;
*/
    case ERR_UNBOUND_VARIABLE:
      printf("unbound variable.\n"); break;
    case ERR_UNASSIGNED_VARIABLE:
      printf("unassigned variable.\n"); break;
    case ERR_INAPPLICABLE_OBJECT:
      printf("Inapplicable operator.\n"); break;
    case ERR_BAD_FRAME:
      printf("bad environment frame.\n"); break;
    case ERR_BROKEN_COMPILED_VARIABLE:
      printf("compiled variable invalid.\n"); break;
    case ERR_UNDEFINED_USER_TYPE:
      printf("undefined type code.\n"); break;
    case ERR_UNDEFINED_PRIMITIVE:
      printf("undefined primitive.\n"); break;
    case ERR_EXTERNAL_RETURN:
      printf("error during 'external' primitive.\n"); break;
    case ERR_EXECUTE_MANIFEST_VECTOR:
      printf("attempt to EVAL a vector.\n"); break;
    case ERR_WRONG_NUMBER_OF_ARGUMENTS:
      printf("wrong number of arguments.\n"); break;
    case ERR_ARG_1_WRONG_TYPE:
      printf("type error argument 1.\n"); break;
    case ERR_ARG_2_WRONG_TYPE:
      printf("type error argument 2.\n"); break;

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


/* Err_Print, continued */

    case ERR_ARG_3_WRONG_TYPE:
      printf("type error argument 3.\n"); break;
    case ERR_ARG_1_BAD_RANGE:
      printf("range error argument 1.\n"); break;
    case ERR_ARG_2_BAD_RANGE:
      printf("range error, argument 2.\n"); break;
    case ERR_ARG_3_BAD_RANGE:
      printf("range error, argument 3.\n"); break;
    case ERR_FASL_FILE_TOO_BIG:
      printf("FASL file too large to load.\n"); break;
    case ERR_FASL_FILE_BAD_DATA:
      printf("No such file or not FASL format.\n"); break;
    case ERR_IMPURIFY_OUT_OF_SPACE:
      printf("Not enough room to impurify object.\n"); break;
    case ERR_WRITE_INTO_PURE_SPACE:
      printf("Write into pure area\n"); break;
    case ERR_NO_HASH_TABLE:
      printf("No hash table installed.\n"); break;
    case ERR_BAD_SET:
      printf("Attempt to perform side-effect on 'self'.\n"); break;
    case ERR_ARG_1_FAILED_COERCION:
      printf("First argument couldn't be coerced.\n"); break;
    case ERR_ARG_2_FAILED_COERCION:
      printf("Second argument couldn't be coerced.\n"); break;
    case ERR_OUT_OF_FILE_HANDLES:
      printf("Too many open files.\n"); break;
    default:
      printf("Unknown error 0x%x occurred\n.", Micro_Error);
      break;
  }
  return;
}
\f


/* If a debugging version of the interpreter is made, then this
 * procedure is called to actually invoke a primitive.  When a
 * 'production' version is made, all of the consistency checks are
 * omitted and a macro from DEFAULT.H is used to directly code the
 * call to the primitive function.  This is only used in INTERPRET.C.
 */

#ifdef ENABLE_DEBUGGING_TOOLS
Pointer Apply_Primitive(Primitive_Number)
long Primitive_Number;
{ Pointer Result, *Saved_Stack;
  int NArgs;
  if (Primitive_Number > MAX_PRIMITIVE)
    Primitive_Error(ERR_UNDEFINED_PRIMITIVE);
  NArgs = Arg_Count_Table[Primitive_Number];
  if (Primitive_Debug) Print_Primitive(Primitive_Number);
  Saved_Stack = Stack_Pointer;
  Result = (*(Primitive_Table[Primitive_Number]))();
  if (Saved_Stack != Stack_Pointer)
  { Print_Expression(Make_Non_Pointer(TC_PRIMITIVE, Primitive_Number),
		     "Stack bad after ");
    printf( "\nStack was 0x%x, now 0x%x, #args=%d.\n",
            Saved_Stack, Stack_Pointer, NArgs);
    Microcode_Termination(TERM_EXIT);
  }
  if (Primitive_Debug)
  { Print_Expression(Result, "Primitive Result");
    printf( "\n");
  }
  return Result;
}
#endif

Built_In_Primitive(Prim_Unused, 0, "Unimplemented Primitive Handler")
{ printf("Ignoring missing primitive. Expression = 0x%02x|%06x\n",
         Type_Code(Fetch_Expression()), Address(Fetch_Expression()));
  Primitive_Error(ERR_UNDEFINED_PRIMITIVE);
}
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦fe663cf12⟧ TextFile

Derivation

TextFile
