--- /dev/null
+/* -*- C -*- */
+#include "scheme.h"
+#include "primitive.h"
+#include "flonum.h"
+#include "array.h"
+#include <math.h>
+
+/* CONTAINS: */
+/* Scheme_Array constructors, and selectors */
+/* Also procedures for converting between C_Array, and Scheme_Vector */
+
+/* See array.h for definition using NM_VECTOR, */
+/* and for many useful EXTERN */
+/* ARRAY = SEQUENCE OF REALS */
+
+/* first a useful procedure */
+
+int Scheme_Number_To_REAL(Arg, Cell) Pointer Arg; REAL *Cell;
+/* 0 means conversion ok, 1 means too big, 2 means not a number */
+{ long Value;
+ switch (Type_Code(Arg)) {
+ case TC_FIXNUM:
+ if (Get_Integer(Arg) == 0)
+ *Cell = 0.0;
+ else
+ { long Value;
+ Sign_Extend(Arg, Value);
+ *Cell = ((REAL) Value);
+ }
+ break;
+ case TC_BIG_FLONUM:
+ *Cell = ((REAL) Get_Float(Arg));
+ break;
+ case TC_BIG_FIXNUM:
+ { Pointer Result = Big_To_Float(Arg);
+ if (Type_Code(Result) == TC_BIG_FLONUM)
+ *Cell = ((REAL) Get_Float(Result));
+ else return (1);
+ }
+ break;
+ default: return (2);
+ break;
+ }
+ return (0);
+}
+\f
+int Scheme_Number_To_Double(Arg, Cell) Pointer Arg; double *Cell;
+/* 0 means conversion ok, 1 means too big, 2 means not a number */
+{ long Value;
+ switch (Type_Code(Arg)) {
+ case TC_FIXNUM:
+ if (Get_Integer(Arg) == 0)
+ *Cell = 0.0;
+ else
+ { long Value;
+ Sign_Extend(Arg, Value);
+ *Cell = ((double) Value);
+ }
+ break;
+ case TC_BIG_FLONUM:
+ *Cell = ((double) Get_Float(Arg));
+ break;
+ case TC_BIG_FIXNUM:
+ { Pointer Result = Big_To_Float(Arg);
+ if (Type_Code(Result) == TC_BIG_FLONUM)
+ *Cell = ((double) Get_Float(Result));
+ else return (1);
+ }
+ break;
+ default: return (2);
+ break;
+ }
+ return (0);
+}
+\f
+void C_Array_Copy(From_Array, To_Array, Length) REAL *From_Array, *To_Array; long Length;
+{ long i;
+ REAL *To_Here, *From_Here;
+ To_Here = To_Array;
+ From_Here = From_Array;
+ for (i=0; i < Length; i++) {
+ *To_Here++ = ((REAL) *From_Here++) ;
+ }
+}
+
+\f
+/**** Scheme Primitives *****/
+
+/* I think this is not needed, can be done at s-code ...
+Define_Primitive(Prim_Array_Predicate, 1, "ARRAY?")
+{ Primitive_1_Args();
+ if (Type_Code(Arg1)==TC_ARRAY) return TRUE;
+ else return NIL;
+}
+*/
+\f
+Define_Primitive(Prim_Vector_To_Array, 1, "VECTOR->ARRAY")
+{ Pointer Scheme_Vector_To_Scheme_Array();
+ Primitive_1_Args();
+ Arg_1_Type(TC_VECTOR);
+ return Scheme_Vector_To_Scheme_Array(Arg1);
+}
+\f
+Define_Primitive(Prim_Array_To_Vector, 1, "ARRAY->VECTOR")
+{ Pointer Scheme_Array_To_Scheme_Vector();
+ Primitive_1_Args();
+ Arg_1_Type(TC_ARRAY);
+ return Scheme_Array_To_Scheme_Vector(Arg1);
+}
+\f
+Define_Primitive(Prim_Array_Cons, 2, "ARRAY-CONS")
+{ long Length, i, allocated_cells;
+ REAL Init_Value, *Next;
+ int Error_Number;
+ Pointer Result;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Range_Check(Length, Arg1, 0, ARRAY_MAX_LENGTH, ERR_ARG_1_BAD_RANGE);
+
+ Error_Number = Scheme_Number_To_REAL(Arg2, &Init_Value);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+
+ Allocate_Array(Result,Length,allocated_cells);
+ Next = Scheme_Array_To_C_Array(Result);
+
+ for (i=0; i < Length; i++) {
+ *Next++ = Init_Value;
+ }
+ return Result;
+}
+\f
+Define_Primitive(Prim_Array_Length, 1, "ARRAY-LENGTH")
+{ Primitive_1_Args();
+ Arg_1_Type(TC_ARRAY);
+ return Make_Pointer(TC_FIXNUM, Array_Length(Arg1));
+}
+\f
+Define_Primitive(Prim_Array_Ref, 2, "ARRAY-REF")
+{ long Index;
+ REAL *Array, value;
+ Pointer *Result;
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(Index, Arg2, 0, Array_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ Array = Scheme_Array_To_C_Array(Arg1);
+ value = Array[Index];
+ Reduced_Flonum_Result((double) value);
+}
+\f
+Define_Primitive(Prim_Array_Set, 3, "ARRAY-SET!")
+{ long Index;
+ REAL *Array, Old_Value;
+ int Error_Number;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(Index, Arg2, 0, Array_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ Array = Scheme_Array_To_C_Array(Arg1);
+ Old_Value = Array[Index];
+
+ Error_Number = Scheme_Number_To_REAL(Arg3, &Array[Index]);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
+
+ Reduced_Flonum_Result((double) Old_Value);
+}
+\f
+Define_Primitive(Prim_Array_Copy, 1, "ARRAY-COPY")
+{ long Length, i, allocated_cells;
+ REAL *To_Array, *From_Array;
+ Pointer Result;
+
+ Primitive_1_Args();
+ Arg_1_Type(TC_ARRAY);
+ Length = Array_Length(Arg1);
+
+ Allocate_Array(Result, Length, allocated_cells);
+ From_Array = Scheme_Array_To_C_Array(Arg1);
+ To_Array = Scheme_Array_To_C_Array(Result);
+
+ C_Array_Copy(From_Array, To_Array, Length);
+ return Result;
+}
+\f
+Define_Primitive(Prim_SubArray, 3, "SUBARRAY")
+{ long Length, i, allocated_cells, Start, End, New_Length;
+ REAL *To_Here, *From_Here;
+ Pointer Result;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_FIXNUM);
+ Arg_3_Type(TC_FIXNUM);
+ Length = Array_Length(Arg1);
+ Range_Check(Start, Arg2, 0, Array_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ Range_Check(End, Arg3, 0, Array_Length(Arg1)-1, ERR_ARG_3_BAD_RANGE);
+ if (Start>End) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+
+ New_Length = (End - Start) + 1;
+ Allocate_Array(Result, New_Length, allocated_cells);
+ From_Here = Nth_Array_Loc(Arg1, Start);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ C_Array_Copy(From_Here, To_Here, New_Length);
+ return Result;
+}
+\f
+Define_Primitive(Prim_Array_Set_SubArray, 4, "ARRAY-SET-SUBARRAY!")
+{ long Length, i, Start, End, New_Length;
+ REAL *To_Here, *From_Here;
+ Pointer Result;
+
+ Primitive_4_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_FIXNUM);
+ Arg_3_Type(TC_FIXNUM);
+ Arg_4_Type(TC_ARRAY);
+ Length = Array_Length(Arg1);
+ Range_Check(Start, Arg2, 0, Array_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ Range_Check(End, Arg3, 0, Array_Length(Arg1)-1, ERR_ARG_3_BAD_RANGE);
+ if (Start>End) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+
+ New_Length = (End - Start) + 1;
+ if (New_Length!=Array_Length(Arg4)) Primitive_Error(ERR_ARG_4_BAD_RANGE);
+ From_Here = Scheme_Array_To_C_Array(Arg4);
+ To_Here = Nth_Array_Loc(Arg1, Start);
+
+ C_Array_Copy(From_Here, To_Here, New_Length);
+ return Arg1;
+}
+\f
+Define_Primitive(Prim_Array_Append, 2, "ARRAY-APPEND")
+{ long Length, Length1, Length2, i, allocated_cells;
+ REAL *To_Here, *From_Here;
+ Pointer Result;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_ARRAY);
+ Length1 = Array_Length(Arg1);
+ Length2 = Array_Length(Arg2);
+ Length = Length1 + Length2;
+
+ Allocate_Array(Result, Length, allocated_cells);
+ To_Here = Scheme_Array_To_C_Array(Result);
+ From_Here = Scheme_Array_To_C_Array(Arg1);
+
+ for (i=0; i < Length1; i++) {
+ *To_Here++ = *From_Here;
+ From_Here++ ;
+ }
+
+ From_Here = Scheme_Array_To_C_Array(Arg2);
+ for (i=0; i < Length2; i++) {
+ *To_Here++ = *From_Here;
+ From_Here++ ;
+ }
+
+ return Result;
+}
+\f
+Define_Primitive(Prim_Array_Reverse, 1, "ARRAY-REVERSE!")
+{ long Length, i,j, Half_Length;
+ REAL *Array, Temp;
+ Primitive_1_Args();
+ Arg_1_Type(TC_ARRAY);
+ Length = Array_Length(Arg1);
+ Half_Length = Length/2;
+ Array = Scheme_Array_To_C_Array(Arg1);
+
+ for (i=0, j=Length-1; i<Half_Length; i++, j--) {
+ Temp = Array[j];
+ Array[j] = Array[i];
+ Array[i] = Temp;
+ }
+ return Arg1;
+}
+\f
+Define_Primitive(Prim_Array_Scale, 2, "ARRAY-SCALE!")
+{ long Length, i;
+ REAL *To_Here, *From_Here, Scale;
+ Pointer Result;
+ int Error_Number;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Length = Array_Length(Arg1);
+ Error_Number = Scheme_Number_To_REAL(Arg2, &Scale);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+
+ Result = Arg1;
+ From_Here = Scheme_Array_To_C_Array(Arg1);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ for (i=0; i < Length; i++) {
+ *To_Here++ = (Scale * (*From_Here));
+ From_Here++ ;
+ }
+ return Result;
+}
+\f
+Define_Primitive(Prim_Array_Log, 1, "ARRAY-LOG!")
+{ long Length, i, allocated_cells;
+ REAL *To_Here, *From_Here;
+ Pointer Result;
+
+ Primitive_1_Args();
+ Arg_1_Type(TC_ARRAY);
+ Length = Array_Length(Arg1);
+
+ Result = Arg1;
+ From_Here = Scheme_Array_To_C_Array(Arg1);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ for (i=0; i < Length; i++) {
+ REAL Value= (*From_Here);
+ if (Value<0.0) Primitive_Error(ERR_ARG_1_BAD_RANGE); /* log of negative ? */
+ *To_Here++ = ((REAL) log((double) Value));
+ From_Here++ ;
+ }
+ return Result;
+}
+\f
+Define_Primitive(Prim_Array_Min_Max, 1, "ARRAY-MIN-MAX")
+{ long Length, nmin, nmax;
+ Pointer Result, *Orig_Free;
+ REAL *Array;
+
+ Primitive_1_Args();
+ Arg_1_Type(TC_ARRAY);
+ Array= Scheme_Array_To_C_Array(Arg1);
+ Length = Array_Length(Arg1);
+ C_Array_Find_Min_Max(Array, Length, &nmin, &nmax);
+ Primitive_GC_If_Needed(4);
+ Result = Make_Pointer(TC_LIST, Free);
+ Orig_Free = Free;
+ Free+=4;
+ My_Store_Reduced_Flonum_Result(Array[nmin], *Orig_Free);
+ Orig_Free+=1;
+ *Orig_Free++ = Make_Pointer(TC_LIST, Orig_Free+1);
+ My_Store_Reduced_Flonum_Result(Array[nmax], *Orig_Free);
+ *(++Orig_Free)=NIL;
+ return Result;
+}
+\f
+Define_Primitive(Prim_Array_Min_Max_Index, 1, "ARRAY-MIN-MAX-INDEX")
+{ long Length, nmin, nmax;
+ Pointer Result, *Orig_Free;
+ REAL *Array;
+
+ Primitive_1_Args();
+ Arg_1_Type(TC_ARRAY);
+ Array= Scheme_Array_To_C_Array(Arg1);
+ Length = Array_Length(Arg1);
+ C_Array_Find_Min_Max(Array, Length, &nmin, &nmax);
+ Primitive_GC_If_Needed(4);
+ Result = Make_Pointer(TC_LIST, Free);
+ Orig_Free = Free;
+ Free+=4;
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nmin);
+ *Orig_Free++ = Make_Pointer(TC_LIST, Orig_Free+1);
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nmax);
+ *Orig_Free=NIL;
+ return Result;
+}
+\f
+void C_Array_Find_Min_Max(x, n, nmin, nmax) REAL *x; long n, *nmax, *nmin;
+{ REAL *xold = x;
+ register REAL xmin, xmax;
+ register long nnmin, nnmax;
+ register long count;
+
+ nnmin = nnmax = 0;
+ xmin = xmax = *x++;
+ n--;
+ count = 1;
+ if(n>0)
+ {
+ do {
+ if(*x < xmin) {
+ nnmin = count++ ;
+ xmin = *x++ ;
+ } else if(*x > xmax) {
+ nnmax = count++ ;
+ xmax = *x++ ;
+ } else {
+ count++ ;
+ x++ ;
+ }
+ } while( --n > 0 ) ;
+ }
+ *nmin = nnmin ;
+ *nmax = nnmax ;
+}
+\f
+Define_Primitive(Prim_Array_Find_Average, 1, "ARRAY-AVERAGE")
+{ long Length; REAL average;
+ Primitive_1_Args();
+ Arg_1_Type(TC_ARRAY);
+ Length = Array_Length(Arg1);
+
+ C_Array_Find_Average( Scheme_Array_To_C_Array(Arg1), Length, &average);
+ Reduced_Flonum_Result((double) average);
+}
+\f
+void C_Array_Find_Average(Array, Length, pAverage)
+ long Length; REAL *Array, *pAverage;
+{ long i;
+ long array_index;
+ REAL average_n, sum;
+
+ average_n = 0.0;
+ array_index = 0;
+ while (array_index<Length) {
+ sum = 0.0;
+ for (i=0;((array_index<Length) && (i<2000));i++) {
+ sum += Array[array_index];
+ array_index++;
+ }
+ average_n += (sum / ((REAL) Length));
+ }
+ *pAverage = average_n;
+}
+\f
+Define_Primitive(Prim_Array_Make_Histogram, 2, "ARRAY-MAKE-HISTOGRAM")
+{ long Length, npoints, allocated_cells;
+ REAL *Array, *Histogram;
+ Pointer Result;
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_FIXNUM);
+ Length = Array_Length(Arg1);
+ Range_Check(npoints, Arg2, 1, (2*Length), ERR_ARG_2_BAD_RANGE);
+
+ Allocate_Array(Result, npoints, allocated_cells);
+ Array = Scheme_Array_To_C_Array(Arg1);
+ Histogram = Scheme_Array_To_C_Array(Result);
+ C_Array_Make_Histogram(Array, Length, Histogram, npoints);
+ return Result;
+}
+\f
+void C_Array_Make_Histogram(Array, Length, Histogram, npoints)
+ REAL Array[], Histogram[]; long Length, npoints;
+{ REAL Max,Min, Offset, Scale;
+ long i, nmin,nmax, index;
+ C_Array_Find_Min_Max(Array, Length, &nmin,&nmax);
+ Min=Array[nmin]; Max=Array[nmax];
+ Find_Offset_Scale_For_Linear_Map(Min,Max, 0.0, ((REAL) (npoints-1)), &Offset, &Scale);
+ for (i=0;i<npoints;i++) {
+ Histogram[i] = 0.0; }
+ for (i=0;i<Length;i++) {
+ index = (long) (floor((double) ((Scale*Array[i]) + Offset)));
+ Histogram[index] += 1.0; }
+}
+
+\f
+Define_Primitive(Prim_Array_Clip_Min_Max, 3, "ARRAY-CLIP-MIN-MAX!")
+{ long Length, i; /* , allocated_cells; */
+ REAL *To_Here, *From_Here, xmin, xmax;
+ Pointer Result;
+ int Error_Number;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_ARRAY);
+ Error_Number=Scheme_Number_To_REAL(Arg2, &xmin);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ Error_Number=Scheme_Number_To_REAL(Arg3, &xmax);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
+ Length = Array_Length(Arg1);
+ Result = Arg1;
+ From_Here = Scheme_Array_To_C_Array(Arg1);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ if (xmin>xmax) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+
+ for (i=0; i < Length; i++) {
+ if ((*From_Here)<xmin) *To_Here++ = xmin;
+ else if ((*From_Here)>xmax) *To_Here++ = xmax;
+ else *To_Here++ = *From_Here;
+ From_Here++ ;
+ }
+ return Result;
+}
+\f
+void C_Array_Clip(Length, From_Here, To_Here, Min_Val, Max_Val)
+ long Length; REAL *From_Here, *To_Here, Min_Val, Max_Val;
+{ long i;
+ for (i=0; i < Length; i++) {
+ if ((*From_Here)<Min_Val) *To_Here++ = Min_Val;
+ else if ((*From_Here)>Max_Val) *To_Here++ = Max_Val;
+ else *To_Here++ = *From_Here;
+ From_Here++ ;
+ }
+}
+
+\f
+Define_Primitive(Prim_Array_Make_Polar, 2, "ARRAY-MAKE-POLAR!")
+{ long Length, i;
+ REAL *To_Here_Mag, *To_Here_Phase;
+ REAL *From_Here_Real, *From_Here_Imag;
+ Pointer Result_Mag, Result_Phase, answer;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_ARRAY);
+ Length = Array_Length(Arg1);
+ if (Length != Array_Length(Arg2)) Primitive_Error(ERR_ARG_1_BAD_RANGE);
+
+ Result_Mag = Arg1;
+ Result_Phase = Arg2;
+
+ From_Here_Real = Scheme_Array_To_C_Array(Arg1);
+ From_Here_Imag = Scheme_Array_To_C_Array(Arg2);
+ To_Here_Mag = Scheme_Array_To_C_Array(Result_Mag);
+ To_Here_Phase = Scheme_Array_To_C_Array(Result_Phase);
+
+ for (i=0; i < Length; i++) {
+ C_Make_Polar(*From_Here_Real, *From_Here_Imag, *To_Here_Mag, *To_Here_Phase);
+ From_Here_Real++ ;
+ From_Here_Imag++ ;
+ To_Here_Mag++ ;
+ To_Here_Phase++ ;
+ }
+
+ Primitive_GC_If_Needed(4);
+ answer = Make_Pointer(TC_LIST, Free);
+ *Free++ = Result_Mag;
+ *Free = Make_Pointer(TC_LIST, Free+1);
+ Free += 1;
+ *Free++ = Result_Phase;
+ *Free++ = NIL;
+ return answer;
+}
+\f
+Define_Primitive(Prim_Array_Find_Magnitude, 2, "ARRAY-FIND-MAGNITUDE")
+{ long Length, i, allocated_cells;
+ REAL *From_Here_Real, *From_Here_Imag, *To_Here;
+ Pointer Result;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_ARRAY);
+ Length = Array_Length(Arg1);
+ if (Length != Array_Length(Arg2)) Primitive_Error(ERR_ARG_1_BAD_RANGE);
+
+ Allocate_Array(Result, Length, allocated_cells);
+ To_Here = Scheme_Array_To_C_Array(Result);
+ From_Here_Real = Scheme_Array_To_C_Array(Arg1);
+ From_Here_Imag = Scheme_Array_To_C_Array(Arg2);
+ for (i=0; i<Length; i++) {
+ C_Find_Magnitude(*From_Here_Real, *From_Here_Imag, *To_Here);
+ From_Here_Real++ ;
+ From_Here_Imag++ ;
+ To_Here++ ;
+ }
+ return Result;
+}
+
+\f
+/* ATTENTION: To1,To2 SHOULD BE Length1-1, and Length2-2 RESPECTIVELY ! */
+
+#define C_Convolution_Point_Macro(X, Y, To1, To2, N, Result) \
+{ long Min_of_N_To1=min((N),(To1)); \
+ long mi, N_minus_mi; \
+ REAL Sum=0.0; \
+ for (mi=max(0,(N)-(To2)), N_minus_mi=(N)-mi; mi <= Min_of_N_To1; mi++, N_minus_mi--) \
+ Sum += (X[mi] * Y[N_minus_mi]); \
+ (Result)=Sum; \
+}
+\f
+Define_Primitive(Prim_Convolution_Point, 3, "CONVOLUTION-POINT")
+{ long Length1, Length2, N;
+ REAL *Array1, *Array2;
+ REAL C_Result;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_ARRAY);
+ Arg_3_Type(TC_FIXNUM);
+ Length1 = Array_Length(Arg1);
+ Length2 = Array_Length(Arg2);
+ N = Get_Integer(Arg3);
+ Array1 = Scheme_Array_To_C_Array(Arg1);
+ Array2 = Scheme_Array_To_C_Array(Arg2);
+ C_Convolution_Point_Macro(Array1, Array2, Length1-1, Length2-1, N, C_Result);
+ Reduced_Flonum_Result(C_Result);
+}
+\f
+Define_Primitive(Prim_Array_Convolution, 2, "ARRAY-CONVOLUTION")
+{ long Endpoint1, Endpoint2, allocated_cells, i;
+ /* ASSUME A SIGNAL FROM INDEX 0 TO ENDPOINT=LENGTH-1 */
+ long Resulting_Length;
+ REAL *Array1, *Array2, *To_Here;
+ Pointer Result;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_ARRAY);
+ Endpoint1 = Array_Length(Arg1) - 1;
+ Endpoint2 = Array_Length(Arg2) - 1;
+ Resulting_Length = Endpoint1 + Endpoint2 + 1;
+ Array1 = Scheme_Array_To_C_Array(Arg1);
+ Array2 = Scheme_Array_To_C_Array(Arg2);
+
+ allocated_cells = (Resulting_Length * REAL_SIZE) + ARRAY_HEADER_SIZE;
+ Primitive_GC_If_Needed(allocated_cells);
+ Result = Make_Pointer(TC_ARRAY, Free);
+ Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
+ Free[ARRAY_LENGTH] = Resulting_Length;
+ Free += allocated_cells;
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ for (i=0; i<Resulting_Length; i++) {
+ C_Convolution_Point_Macro(Array1, Array2, Endpoint1, Endpoint2, i, *To_Here);
+ To_Here++;
+ }
+ return Result;
+}
+\f
+Define_Primitive(Prim_Array_Multiplication_Into_Second_One, 2, "ARRAY-MULTIPLICATION-INTO-SECOND-ONE!")
+{ long Length, i;
+ REAL *To_Here;
+ REAL *From_Here_1, *From_Here_2;
+ Pointer Result;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_ARRAY);
+ Length = Array_Length(Arg1);
+ if (Length != Array_Length(Arg2)) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+
+ Result = Arg2;
+
+ From_Here_1 = Scheme_Array_To_C_Array(Arg1);
+ From_Here_2 = Scheme_Array_To_C_Array(Arg2);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ for (i=0; i < Length; i++) {
+ *To_Here++ = (*From_Here_1) * (*From_Here_2);
+ From_Here_1++ ;
+ From_Here_2++ ;
+ }
+ return Result;
+}
+\f
+Define_Primitive(Prim_Array_Complex_Multiplication_Into_Second_One, 4, "ARRAY-COMPLEX-MULTIPLICATION-INTO-SECOND-ONE!")
+{ long Length, i;
+ REAL *To_Here_1, *To_Here_2;
+ REAL *From_Here_1, *From_Here_2, *From_Here_3, *From_Here_4;
+ REAL Temp;
+ Pointer Result_1, Result_2;
+
+ Primitive_4_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_ARRAY);
+ Arg_3_Type(TC_ARRAY);
+ Arg_4_Type(TC_ARRAY);
+ Length = Array_Length(Arg1);
+ if (Length != Array_Length(Arg2)) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if (Length != Array_Length(Arg3)) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+ if (Length != Array_Length(Arg4)) Primitive_Error(ERR_ARG_4_BAD_RANGE);
+
+ Result_1 = Arg3;
+ Result_2 = Arg4;
+
+ From_Here_1 = Scheme_Array_To_C_Array(Arg1);
+ From_Here_2 = Scheme_Array_To_C_Array(Arg2);
+ From_Here_3 = Scheme_Array_To_C_Array(Arg3);
+ From_Here_4 = Scheme_Array_To_C_Array(Arg4);
+ To_Here_1 = Scheme_Array_To_C_Array(Result_1);
+ To_Here_2 = Scheme_Array_To_C_Array(Result_2);
+
+ for (i=0; i < Length; i++) {
+ Temp = (*From_Here_1) * (*From_Here_3) - (*From_Here_2) * (*From_Here_4);
+ *To_Here_2++ = (*From_Here_1) * (*From_Here_4) + (*From_Here_2) * (*From_Here_3);
+ *To_Here_1++ = Temp;
+ From_Here_1++ ;
+ From_Here_2++ ;
+ From_Here_3++ ;
+ From_Here_4++ ;
+ }
+ return NIL;
+}
+\f
+Define_Primitive(Prim_Array_Linear_Superposition_Into_Second_One, 4, "ARRAY-LINEAR-SUPERPOSITION-INTO-SECOND-ONE!")
+{ long Length, i;
+ REAL *To_Here, Coeff1, Coeff2;
+ REAL *From_Here_1, *From_Here_2;
+ Pointer Result;
+ int Error_Number;
+
+ Primitive_4_Args();
+ Error_Number = Scheme_Number_To_REAL(Arg1, &Coeff1);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ Arg_2_Type(TC_ARRAY);
+ Error_Number = Scheme_Number_To_REAL(Arg3, &Coeff2);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
+ Arg_4_Type(TC_ARRAY);
+
+ Length = Array_Length(Arg2);
+ if (Length != Array_Length(Arg4)) Primitive_Error(ERR_ARG_4_BAD_RANGE);
+
+ Result = Arg4;
+
+ From_Here_1 = Scheme_Array_To_C_Array(Arg2);
+ From_Here_2 = Scheme_Array_To_C_Array(Arg4);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ for (i=0; i < Length; i++) {
+ *To_Here++ = (Coeff1 * (*From_Here_1)) + (Coeff2 * (*From_Here_2));
+ From_Here_1++ ;
+ From_Here_2++ ;
+ }
+ return Result;
+}
+\f
+/* m_pi = 3.14159265358979323846264338327950288419716939937510; */
+
+Define_Primitive(Prim_Sample_Periodic_Function, 4, "SAMPLE-PERIODIC-FUNCTION")
+{ long N, i, allocated_cells, Function_Number;
+ double Signal_Frequency, Sampling_Frequency, DT, DTi;
+ double twopi = 6.28318530717958;
+ Pointer Result, Pfunction_number, Psignal_frequency;
+ Pointer Pfunction_Number;
+ int Error_Number;
+ REAL *To_Here;
+ double unit_square_wave(), unit_triangle_wave();
+
+ Primitive_4_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Arg_4_Type(TC_FIXNUM);
+ Range_Check(Function_Number, Arg1, 0, 10, ERR_ARG_1_BAD_RANGE); /* fix this */
+
+ Error_Number = Scheme_Number_To_Double(Arg2, &Signal_Frequency);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ if (Signal_Frequency == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+
+ Error_Number = Scheme_Number_To_Double(Arg3, &Sampling_Frequency);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
+ if (Sampling_Frequency == 0) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+
+ Range_Check(N, Arg4, 0, ARRAY_MAX_LENGTH, ERR_ARG_4_BAD_RANGE);
+
+ Allocate_Array(Result, N, allocated_cells);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ DT = (double) (twopi * Signal_Frequency * (1 / Sampling_Frequency));
+ if (Function_Number == 0)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = (REAL) cos(DTi);
+ else if (Function_Number == 1)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = (REAL) sin(DTi);
+ else if (Function_Number == 2)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = (REAL) unit_square_wave(DTi);
+ else if (Function_Number == 3)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = (REAL) unit_triangle_wave(DTi);
+ else
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+
+ return Result;
+}
+\f
+double hamming(t, length) double t, length;
+{ double twopi = 6.28318530717958;
+ double pi = twopi/2.;
+ double t_bar = cos(twopi * (t / length));
+ if ((t<length) && (t>0.0)) return(.08 + .46 * (1 - t_bar));
+ else return (0);
+}
+\f
+double hanning(t, length) double t, length;
+{ double twopi = 6.28318530717958;
+ double pi = twopi/2.;
+ double t_bar = cos(twopi * (t / length));
+ if ((t<length) && (t>0.0)) return(.5 * (1 - t_bar));
+ else return (0);
+}
+\f
+double unit_square_wave(t) double t;
+{ double twopi = 6.28318530717958;
+ double fmod(), fabs();
+ double pi = twopi/2.;
+ double t_bar = ((REAL) fabs(fmod( ((double) t), twopi)));
+ if (t_bar < pi) return(1);
+ else return(-1);
+}
+\f
+double unit_triangle_wave(t) double t;
+{ double twopi = 6.28318530717958;
+ double pi = twopi/2.;
+ double pi_half = pi/2.;
+ double three_pi_half = pi+pi_half;
+ double t_bar = ((double) fabs(fmod( ((double) t), twopi)));
+
+ if (t_bar<pi_half) return(-(t_bar/pi));
+ else if (t_bar<pi) return(t_bar/pi);
+ else if (t_bar<three_pi_half) return((twopi-t_bar)/pi);
+ else return (-((twopi-t_bar)/pi));
+}
+\f
+Define_Primitive(Prim_Sample_Aperiodic_Function, 3, "SAMPLE-APERIODIC-FUNCTION")
+{ long N, i, allocated_cells, Function_Number;
+ double Sampling_Frequency, DT, DTi;
+ double twopi = 6.28318530717958;
+ Pointer Result;
+ int Error_Number;
+ REAL *To_Here, twopi_dt;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Arg_3_Type(TC_FIXNUM);
+ Range_Check(Function_Number, Arg1, 0, 6, ERR_ARG_1_BAD_RANGE);
+
+ Error_Number = Scheme_Number_To_Double(Arg2, &Sampling_Frequency);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ if (Sampling_Frequency == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+
+ Range_Check(N, Arg3, 0, ARRAY_MAX_LENGTH, ERR_ARG_3_BAD_RANGE);
+
+ Allocate_Array(Result, N, allocated_cells);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ DT = (twopi * (1 / Sampling_Frequency));
+ if (Function_Number == 0)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = (REAL) rand();
+ else if (Function_Number == 1)
+ { double length=DT*N;
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = (REAL) hanning(DTi, length);
+ }
+ else if (Function_Number == 2)
+ { double length=DT*N;
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = (REAL) hamming(DTi, length);
+ }
+ else if (Function_Number == 3)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = (REAL) sqrt(DTi);
+ else if (Function_Number == 4)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = (REAL) log(DTi);
+ else if (Function_Number == 5)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = (REAL) exp(DTi);
+ else
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+
+ return Result;
+}
+\f
+Define_Primitive(Prim_Array_Periodic_Downsample, 2, "ARRAY-PERIODIC-DOWNSAMPLE")
+{ long Length, Pseudo_Length, Sampling_Ratio;
+ REAL *Array, *To_Here;
+ Pointer Result;
+ long allocated_cells, i, array_index;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_FIXNUM);
+ Length = Array_Length(Arg1);
+
+ Sign_Extend(Arg2, Sampling_Ratio); /* Sampling_Ratio = integer ratio of sampling_frequencies */
+ Sampling_Ratio = Sampling_Ratio % Length; /* periodicity */
+ if (Sampling_Ratio < 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+
+ Array = Scheme_Array_To_C_Array(Arg1);
+ Allocate_Array(Result, Length, allocated_cells);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ Pseudo_Length = Length * Sampling_Ratio;
+ for (i=0; i<Pseudo_Length; i += Sampling_Ratio) { /* new Array has the same Length by assuming periodicity */
+ array_index = i % Length;
+ *To_Here++ = Array[array_index];
+ }
+
+ return Result;
+}
+\f
+/* DONE WITHOUT SIDE-EFFECTS FOR SIMPLICITY */
+Define_Primitive(Prim_Array_Periodic_Shift, 2, "ARRAY-PERIODIC-SHIFT")
+{ long Length, Shift;
+ REAL *Array, *To_Here;
+ Pointer Result;
+ long allocated_cells, i, array_index;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_FIXNUM);
+ Length = Array_Length(Arg1);
+ Sign_Extend(Arg2, Shift);
+ Shift = Shift % Length; /* periodic waveform, same sign as dividend */
+ Array = Scheme_Array_To_C_Array(Arg1);
+ Allocate_Array(Result, Length, allocated_cells);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ for (i=0; i<Length; i++) { /* new Array has the same Length by assuming periodicity */
+ array_index = (i+Shift) % Length;
+ if (array_index<0) array_index = Length + array_index; /* wrap around */
+ *To_Here++ = Array[array_index];
+ }
+
+ return Result;
+}
+\f
+/* this should really be done in SCHEME using ARRAY-MAP ! */
+
+Define_Primitive(Prim_Array_Aperiodic_Downsample, 2, "ARRAY-APERIODIC-DOWNSAMPLE")
+{ long Length, New_Length, Sampling_Ratio;
+ REAL *Array, *To_Here;
+ Pointer Result;
+ long allocated_cells, i, array_index;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_FIXNUM);
+ Length = Array_Length(Arg1);
+ Range_Check(Sampling_Ratio, Arg2, 1, Length, ERR_ARG_2_BAD_RANGE);
+
+ Array = Scheme_Array_To_C_Array(Arg1);
+ New_Length = Length / Sampling_Ratio; /* greater than zero */
+ Allocate_Array(Result, New_Length, allocated_cells);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ for (i=0; i<Length; i += Sampling_Ratio) {
+ *To_Here++ = Array[i];
+ }
+
+ return Result;
+}
+\f
+/* ARRAY-APERIODIC-SHIFT can be done in scheme using subarray, and array-append */
+
+/* for UPSAMPLING
+ if ((Length % Sampling_Ratio) != 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ UNIMPLEMENTED YET !!!
+ */
+
+/* END ARRAY PROCESSING */
+
+
+\f
+/*********** CONVERSION BETWEEN ARRAYS,VECTORS ********************/
+
+Pointer Scheme_Array_To_Scheme_Vector(Scheme_Array) Pointer Scheme_Array;
+{ REAL *Array;
+ long Length;
+ Pointer C_Array_To_Scheme_Vector();
+
+ Length = Array_Length(Scheme_Array);
+ Array = Scheme_Array_To_C_Array(Scheme_Array);
+ return C_Array_To_Scheme_Vector(Array, Length);
+}
+
+/* C_ARRAY */
+\f
+Pointer C_Array_To_Scheme_Array(Array, Length) REAL *Array; long Length;
+{ Pointer Result;
+ long allocated_cells;
+ Allocate_Array(Result, Length, allocated_cells);
+ return Result;
+}
+\f
+Pointer C_Array_To_Scheme_Vector(Array, Length) REAL *Array; long Length;
+{ Pointer Result;
+ Pointer *Now_Free;
+ long i;
+
+ Primitive_GC_If_Needed(Length+1 + Length*(FLONUM_SIZE+1));
+ Now_Free = (Pointer *) Free;
+ Free = Free + Length + 1; /* INCREMENT BEFORE ALLOCATING FLONUMS ! */
+
+ Result = Make_Pointer(TC_VECTOR, Now_Free);
+ *Now_Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Length);
+
+ for (i=0; i<Length; i++) {
+ My_Store_Reduced_Flonum_Result( Array[i], *Now_Free);
+ Now_Free++;
+ }
+ return Result;
+}
+
+\f
+/* SCHEME_VECTOR */
+
+Pointer Scheme_Vector_To_Scheme_Array(Arg1) Pointer Arg1;
+{ Pointer Result;
+ long Length, allocated_cells;
+ REAL *Array;
+
+ Length = Vector_Length(Arg1);
+ Allocate_Array(Result, Length, allocated_cells);
+ Array = Scheme_Array_To_C_Array(Result);
+
+ Scheme_Vector_To_C_Array(Arg1, Array);
+ return Result;
+}
+
+\f
+void Scheme_Vector_To_C_Array(Scheme_Vector, Array)
+ Pointer Scheme_Vector; REAL *Array;
+{ Pointer *From_Here;
+ REAL *To_Here;
+ long Length, i;
+ int Error_Number;
+
+ From_Here = Nth_Vector_Loc(Scheme_Vector, VECTOR_DATA);
+ To_Here = Array;
+ Length = Vector_Length(Scheme_Vector);
+ for (i=0; i < Length; i++, From_Here++) {
+ Error_Number = Scheme_Number_To_REAL(*From_Here, To_Here);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+
+ To_Here++; /* this gets incremented by REAL_SIZE ! */
+ }
+}
+
+/* END of ARRAY PROCESSING */
+\f
+/* one more hack for speed */
+
+/* (SOLVE-SYSTEM A B N)
+ Solves the system of equations Ax = b. A and B are
+ arrays and b is the order of the system. Returns x.
+ From the Fortran procedure in Strang.
+*/
+
+Define_Primitive(Prim_Gaussian_Elimination, 2, "SOLVE-SYSTEM")
+{ REAL *A, *B, *X;
+ long Length, allocated_cells;
+ Pointer Result;
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_ARRAY);
+ Length = Array_Length(Arg2);
+ if ((Length*Length) != Array_Length(Arg1)) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+
+ A = Scheme_Array_To_C_Array(Arg1);
+ B = Scheme_Array_To_C_Array(Arg2);
+ Allocate_Array(Result, Length, allocated_cells);
+ X = Scheme_Array_To_C_Array(Result);
+ C_Array_Copy(B, X, Length);
+ C_Gaussian_Elimination(A, X, Length);
+ return Result;
+}
+
+/*
+ C routine side-effects b.
+*/
+C_Gaussian_Elimination(a, b, n)
+REAL *a, *b;
+long n;
+{ long *pvt;
+ REAL p, t;
+ long i, j, k, m;
+ Primitive_GC_If_Needed(n);
+ pvt = ((long *) Free);
+ *(pvt+n-1) = 1;
+ if (n != 1) {
+ for (k=1; k<n; k++) {
+ m = k;
+ for (i=k+1; i<=n; i++)
+ if (fabs(*(a+i+(k-1)*n-1)) > fabs(*(a+m+(k-1)*n-1)))
+ m = i;
+ *(pvt+k-1) = m;
+ if (m != k)
+ *(pvt+n-1) = - *(pvt+n-1);
+ p = *(a+m+(k-1)*n-1);
+ *(a+m+(k-1)*n-1) = *(a+k+(k-1)*n-1);
+ *(a+k+(k-1)*n-1) = p;
+ if (p != 0.0) {
+ for (i=k+1; i<=n; i++)
+ *(a+i+(k-1)*n-1) = - *(a+i+(k-1)*n-1) / p;
+ for (j=k+1; j<=n; j++) {
+ t = *(a+m+(j-1)*n-1);
+ *(a+m+(j-1)*n-1) = *(a+k+(j-1)*n-1);
+ *(a+k+(j-1)*n-1) = t;
+ if (t != 0.0)
+ for (i=k+1; i<=n; i++)
+ *(a+i+(j-1)*n-1) = *(a+i+(j-1)*n-1) + *(a+i+(k-1)*n-1) * t;
+ }
+ }
+ }
+ for (k=1; k<n; k++) {
+ m = *(pvt+k-1);
+ t = *(b+m-1);
+ *(b+m-1) = *(b+k-1);
+ *(b+k-1) = t;
+ for (i=k+1; i<=n; i++)
+ *(b+i-1) = *(b+i-1) + *(a+i+(k-1)*n-1) * t;
+ }
+ for (j=1; j<n; j++) {
+ k = n - j + 1;
+ *(b+k-1) = *(b+k-1) / *(a+k+(k-1)*n-1);
+ t = - *(b+k-1);
+ for (i=1; i <= n-j; i++)
+ *(b+i-1) = *(b+i-1) + *(a+i+(k-1)*n-1) * t;
+ }
+ }
+ *b = *b / *a;
+ return;
+}
+
+/* END OF FILE */
--- /dev/null
+/* -*- C -*- */
+
+/* The following two macros determine what kind of arrays we deal with.
+ Use float to save space for image-processing
+ */
+
+#define REAL float
+#define REAL_SIZE ((sizeof(Pointer)+sizeof(REAL)-1)/ sizeof(Pointer))
+
+
+/****************** Scheme_Array *****************/
+/* using NON_MARKED_VECTOR */
+/* This assumes that object.h is included also */
+
+#define TC_ARRAY TC_NON_MARKED_VECTOR
+#define TC_MANIFEST_ARRAY TC_MANIFEST_NM_VECTOR
+#define ARRAY_HEADER 0 /* NM_VECTOR_HEADER */
+/* contains the number of actual cells (words) allocated, used in gc */
+#define ARRAY_LENGTH 1 /* NM_ENTRY_COUNT */
+#define ARRAY_DATA 2 /* NM_DATA */
+#define ARRAY_HEADER_SIZE 2
+
+#define Array_Ref(P,N) ((Get_Pointer(P))[N+2])
+
+#define Nth_Array_Loc(P,N) (Scheme_Array_To_C_Array(P) + N)
+
+#define Scheme_Array_To_C_Array(Scheme_Array) \
+ ((REAL *) Nth_Vector_Loc(Scheme_Array, ARRAY_DATA))
+
+#define Array_Length(Scheme_Array) \
+ ((long) Vector_Ref(Scheme_Array, ARRAY_LENGTH))
+
+#define Allocate_Array(result, Length, allocated_cells) \
+ allocated_cells = (Length*REAL_SIZE) + ARRAY_HEADER_SIZE; \
+ Primitive_GC_If_Needed(allocated_cells); \
+ result = Make_Pointer(TC_ARRAY, Free); \
+ Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1); \
+ Free[ARRAY_LENGTH] = Length; \
+ Free = Free+allocated_cells;
+
+\f
+/* SOME MORE MACROS */
+
+#define ARRAY_MAX_LENGTH 1000000 /* 4 Mbytes */
+
+#define Make_List_From_3_Pointers(pointer1, pointer2, pointer3, Result) \
+{ Primitive_GC_If_Needed(6); \
+ Result = Make_Pointer(TC_LIST, Free); \
+ *Free++ = pointer1; \
+ *Free++ = Make_Pointer(TC_LIST, Free+1); \
+ *Free++ = pointer2; \
+ *Free++ = Make_Pointer(TC_LIST, Free+1); \
+ *Free++ = pointer3; \
+ *Free++ = NIL; \
+}
+
+#define Float_Range_Check(variable, Scheme_Pointer, Low, High, Error_Message) \
+{ REAL value; \
+ int err; \
+ err = Scheme_Number_To_REAL(Scheme_Pointer, &value); \
+ if ((err == 1) || (err == 2)) Primitive_Error(Error_Message); \
+ if ((value<Low) || (value>High)) Primitive_Error(Error_Message); \
+ variable = ((float) value); \
+}
+
+#define REAL_Range_Check(variable, Scheme_Pointer, Low, High, Error_Message) \
+{ REAL value; \
+ int err; \
+ err = Scheme_Number_To_REAL(Scheme_Pointer, &value); \
+ if ((err == 1) || (err == 2)) Primitive_Error(Error_Message); \
+ if ((value<Low) || (value>High)) Primitive_Error(Error_Message); \
+ else variable = value; \
+}
+
+#define C_Make_Polar(Real, Imag, Mag_Cell, Phase_Cell) \
+{ double double_Real=((double) Real), double_Imag=((double) Imag); \
+ Mag_Cell = (REAL) sqrt((double_Real*double_Real)+(double_Imag*double_Imag)); \
+ Phase_Cell = (REAL) atan2(double_Imag, double_Real); \
+}
+/* atan has no problem with division by zero */
+
+#define Linear_Map(slope,offset,From,To) { (To) = (((slope)*(From))+offset); }
+
+#define C_Find_Magnitude(Real, Imag, Mag_Cell) \
+{ double double_Real=((double) Real), double_Imag=((double) Imag); \
+ Mag_Cell = (REAL) sqrt((double_Real*double_Real)+(double_Imag*double_Imag)); \
+}
+
+#define mabs(x) (((x)<0) ? -(x) : (x))
+#define max(x,y) (((x)<(y)) ? (y) : (x))
+#define min(x,y) (((x)<(y)) ? (x) : (y))
+
+
+/* FROM ARRAY.C */
+extern int Scheme_Number_To_REAL();
+extern int Scheme_Number_To_Double();
+extern void C_Array_Copy(); /* REAL *From_Array,*To_Array; long Length; */
+
+extern void C_Array_Find_Min_Max(); /* Find the index of the minimum (*nmin), maximum (*nmax). */
+extern void C_Array_Find_Average();
+extern void C_Array_Make_Histogram(); /* REAL *Array,*Histogram; long Length,npoints */
+
+\f
+/* DATATYPE CONVERSIONS */
+
+/* macro: REAL *Scheme_Array_To_C_Array(); */
+extern Pointer C_Array_To_Scheme_Array();
+/* there is also a macro: Allocate_Array(Result,Length,allocated_cells);
+ */
+
+extern Pointer Scheme_Vector_To_Scheme_Array();
+extern Pointer Scheme_Array_To_Scheme_Vector();
+
+extern Pointer C_Array_To_Scheme_Vector();
+extern void Scheme_Vector_To_C_Array();
+/* Pointer Scheme_Vector; REAL *Array;
+ */
+\f
+
+/* FROM BOB-XT.C */
+extern void Find_Offset_Scale_For_Linear_Map(); /* REAL Min,Max, New_Min,New_Max, *Offset,*Scale; */
+
+\f
+#define My_Store_Flonum_Result(Ans, Value_Cell) \
+ (Value_Cell) = (Allocate_Float( ((double) Ans)));
+/*
+#define Allocate_Float(Ans) \
+ Primitive_GC_If_Needed(FLONUM_SIZE + 1); \
+ *Free = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, FLONUM_SIZE); \
+ Get_Float(C_To_Scheme(Free)) = (Ans); \
+ Free += FLONUM_SIZE+1; \
+ (Value_Cell) = Make_Pointer(TC_BIG_FLONUM, Free-(1+FLONUM_SIZE));
+*/
+\f
+#define My_Store_Reduced_Flonum_Result(Ans, Value_Cell) \
+ { double Number = ((double) Ans); \
+ double floor(); \
+ Pointer result; \
+ if (floor(Number) != Number) \
+ { My_Store_Flonum_Result(Number, Value_Cell); \
+ } \
+ else if (Number == 0) (Value_Cell) = FIXNUM_0; \
+ if ((floor(Number) == Number) && (Number != 0)) \
+ { int exponent; \
+ double frexp(); \
+ frexp(Number, &exponent); \
+ if (exponent <= FIXNUM_LENGTH) \
+ { double_into_fixnum(Number, result); \
+ (Value_Cell) = result; \
+ } \
+ /* Since the float has no fraction, we will not gain \
+ precision if its mantissa has enough bits to support \
+ the exponent. */ \
+ else if (exponent <= FLONUM_MANTISSA_BITS) \
+ { result = Float_To_Big(Number); \
+ (Value_Cell) = result; \
+ } \
+ else if (Number != 0) \
+ { My_Store_Flonum_Result( (Ans), (Value_Cell)); \
+ } \
+ } \
+ }
+
+\f
+
+/* the end */
--- /dev/null
+/* 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: BIGNUM.C
+ *
+ * This file contains the procedures for handling BIGNUM Arithmetic
+ *
+ */
+
+#include "scheme.h"
+#include <math.h>
+#include "primitive.h"
+#include "bignum.h"
+#include "flonum.h"
+#include "zones.h"
+\f
+/* Bignum Comparison Primitives */
+
+/* big_compare() will return either of three cases, determining whether
+ * ARG1 is bigger, smaller, or equal to ARG2.
+ */
+
+big_compare(ARG1, ARG2)
+bigdigit *ARG1, *ARG2;
+{ switch(Categorize_Sign(ARG1, ARG2))
+ { case BOTH_NEGATIVE : return big_compare_unsigned(ARG2, ARG1);
+ case BOTH_POSITIVE : return big_compare_unsigned(ARG1, ARG2);
+ case ARG1_NEGATIVE : return TWO_BIGGER;
+ case ARG2_NEGATIVE : return ONE_BIGGER;
+ default: Sign_Error("big_compare()");
+ }
+}
+
+/* big_compare_unsigned() compares the magnitudes of two BIGNUM's.
+ * Called by big_compare() and minus_unsigned_bignum().
+ */
+
+big_compare_unsigned(ARG1, ARG2)
+fast bigdigit *ARG1, *ARG2;
+{ fast bigdigit *LIMIT;
+
+ if ((LEN(ARG1)) > (LEN(ARG2))) return ONE_BIGGER;
+ if ((LEN(ARG1)) < (LEN(ARG2))) return TWO_BIGGER;
+ if ((LEN(ARG1)) == 0) return EQUAL;
+ LIMIT = Bignum_Bottom(ARG1);
+ ARG1 = Bignum_Top(ARG1);
+ ARG2 = Bignum_Top(ARG2);
+ while (ARG1 >= LIMIT)
+ { if (*ARG1 > *ARG2) return ONE_BIGGER;
+ if (*ARG1 < *ARG2) return TWO_BIGGER;
+ ARG1 -= 1;
+ ARG2 -= 1;
+ }
+ return EQUAL;
+}
+\f
+/* Primitives for Coercion */
+
+/* (FIX_TO_BIG FIXNUM)
+ [Primitive number 0x67]
+ Returns its argument if FIXNUM isn't a fixnum. Otherwise
+ it returns the corresponding bignum.
+*/
+Built_In_Primitive(Prim_Fix_To_Big, 1, "FIX->BIG")
+{ Primitive_1_Arg();
+ Arg_1_Type(TC_FIXNUM);
+ return Fix_To_Big(Arg1);
+}
+
+Pointer Fix_To_Big(Arg1)
+Pointer Arg1;
+{ fast bigdigit *Answer, *SCAN, *size;
+ long Length, ARG1;
+ if (Type_Code(Arg1) != TC_FIXNUM) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ if (Get_Integer(Arg1) == 0)
+ { long Align_0 = Align(0);
+ bigdigit *REG;
+ Primitive_GC_If_Needed(2);
+ REG = BIGNUM(Free);
+ Prepare_Header(REG, 0, POSITIVE);
+ Free += Align_0;
+ return Make_Pointer(TC_BIG_FIXNUM, Free-Align_0);
+ }
+ Length = Align(FIXNUM_LENGTH_AS_BIGNUM);
+ Primitive_GC_If_Needed(Length);
+ Sign_Extend(Arg1, ARG1);
+ Answer = BIGNUM(Free);
+ Prepare_Header(Answer, 0, (ARG1 >= 0) ? POSITIVE : NEGATIVE);
+ size = &LEN(Answer);
+ if (ARG1 < 0) ARG1 = - ARG1;
+ for (SCAN = Bignum_Bottom(Answer); ARG1 != 0; *size += 1)
+ { *SCAN++ = Rem_Radix(ARG1);
+ ARG1 = Div_Radix(ARG1);
+ }
+ Length = Align(*size);
+ *((Pointer *) Answer) = Make_Header(Length);
+ Free += Length;
+ Debug_Test(Free-Length);
+ return Make_Pointer(TC_BIG_FIXNUM, Free-Length);
+}
+\f
+/* (BIG_TO_FIX BIGNUM)
+ [Primitive number 0x68]
+ When given a bignum, returns the equivalent fixnum if there is
+ one. If BIGNUM is out of range, or isn't a bignum, returns
+ BIGNUM.
+*/
+Built_In_Primitive(Prim_Big_To_Fix, 1, "BIG->FIX")
+{ Primitive_1_Arg();
+ Arg_1_Type(TC_BIG_FIXNUM);
+ return Big_To_Fix(Arg1);
+}
+
+Pointer Big_To_Fix(Arg1)
+Pointer Arg1;
+{ fast bigdigit *SCAN, *ARG1;
+ fast long Answer, i;
+ long Length;
+ if (Type_Code(Arg1) != TC_BIG_FIXNUM) return Arg1;
+ ARG1 = BIGNUM(Get_Pointer(Arg1));
+ Length = LEN(ARG1);
+ if (Length==0) Answer = 0;
+ else if (Length > FIXNUM_LENGTH_AS_BIGNUM) return Arg1;
+ else if (Length < FIXNUM_LENGTH_AS_BIGNUM)
+ for (SCAN=Bignum_Top(ARG1), i=0, Answer=0; i< Length; i++)
+ Answer = Mul_Radix(Answer) + *SCAN--;
+ else
+ /* Length == FIXNUM_LENGTH_AS_BIGNUM */
+ for (SCAN=Bignum_Top(ARG1), i=0, Answer=0; i< Length; i++)
+ { Answer = Mul_Radix(Answer) + *SCAN--;
+ /* This takes care of signed arithmetic */
+ if ((Answer < 0) || (!(Fixnum_Fits(Answer)))) return Arg1;
+ }
+ if NEG_BIGNUM(ARG1) Answer = - Answer;
+ return Make_Non_Pointer(TC_FIXNUM, Answer);
+}
+\f
+Boolean Fits_Into_Flonum(Bignum)
+bigdigit *Bignum;
+{ fast int k;
+ quick bigdigit top_digit;
+
+ k = (LEN(Bignum) - 1) * SHIFT;
+ for (top_digit = *Bignum_Top(Bignum); top_digit != 0; k++)
+ top_digit >>= 1;
+
+/* If precision should not be lost,
+ if (k <= FLONUM_MANTISSA_BITS) return true;
+ Otherwise,
+*/
+
+ if (k <= MAX_FLONUM_EXPONENT) return true;
+ return false;
+}
+
+Pointer Big_To_Float(Arg1)
+Pointer Arg1;
+{ fast bigdigit *ARG1, *LIMIT;
+ fast double F = 0.0;
+
+ ARG1 = BIGNUM(Get_Pointer(Arg1));
+ if (!Fits_Into_Flonum(ARG1)) return Arg1;
+ Primitive_GC_If_Needed(FLONUM_SIZE+1);
+ LIMIT = Bignum_Bottom(ARG1);
+ ARG1 = Bignum_Top(ARG1);
+ while (ARG1 >= LIMIT) F = (F * ((double) RADIX)) + ((double) *ARG1--);
+ if (NEG_BIGNUM(BIGNUM(Get_Pointer(Arg1)))) F = -F;
+ return Allocate_Float(F);
+}
+
+\f
+#ifdef HAS_FREXP
+extern double frexp(), ldexp();
+#else
+#include "missing.c"
+#endif
+
+Pointer Float_To_Big(flonum)
+double flonum;
+{ fast double mantissa;
+ fast bigdigit *Answer, size;
+ int exponent;
+ long Align_size;
+ if (flonum == 0.0) return return_bignum_zero();
+ mantissa = frexp(flonum, &exponent);
+ if (flonum < 0) mantissa = -mantissa;
+ if (mantissa >= 1.0)
+ { mantissa = mantissa/2.0;
+ exponent += 1;
+ }
+ size = (exponent + (SHIFT - 1)) / SHIFT;
+ exponent = exponent % SHIFT;
+ mantissa = ldexp(mantissa, (exponent == 0) ? 0: exponent - SHIFT);
+ Align_size = Align(size);
+ Primitive_GC_If_Needed(Align_size);
+ Answer = BIGNUM(Free);
+ Prepare_Header(Answer, size, (flonum < 0) ? NEGATIVE : POSITIVE);
+ Answer = Bignum_Top(Answer)+1;
+ while ((size > 0) && (mantissa != 0))
+ {
+ long temporary;
+
+ mantissa = mantissa * ((double) RADIX);
+ /* explicit intermediate required by compiler bug. -- cph */
+ temporary = ((long) mantissa);
+ *--Answer = ((bigdigit) temporary);
+ mantissa = mantissa - ((double) *Answer);
+ size -= 1;
+ }
+ while (size-- != 0) *--Answer = (bigdigit) 0;
+ Free += Align_size;
+ Debug_Test(Free-Align_size);
+ return Make_Pointer(TC_BIG_FIXNUM, Free-Align_size);
+}
+\f
+/* Addition */
+
+plus_signed_bignum(ARG1, ARG2)
+bigdigit *ARG1, *ARG2;
+{ /* Special Case for answer being zero */
+ if (ZERO_BIGNUM(ARG1) && ZERO_BIGNUM(ARG2))
+ return return_bignum_zero();
+ switch(Categorize_Sign(ARG1, ARG2))
+ { case BOTH_POSITIVE : return(plus_unsigned_bignum(ARG1, ARG2, POSITIVE));
+ case ARG1_NEGATIVE : return(minus_unsigned_bignum(ARG2, ARG1, POSITIVE));
+ case ARG2_NEGATIVE : return(minus_unsigned_bignum(ARG1, ARG2, POSITIVE));
+ case BOTH_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, NEGATIVE));
+ default : Sign_Error("plus_bignum()");
+ }
+}
+
+plus_unsigned_bignum(ARG1,ARG2,sign)
+fast bigdigit *ARG1, *ARG2;
+bigdigit sign;
+{ fast unsigned bigdouble Sum;
+ long Size;
+ fast bigdigit *Answer;
+ fast bigdigit *TOP2, *TOP1;
+
+/* Swap ARG1 and ARG2 so that ARG1 is always longer */
+
+ if (LEN(ARG1) < LEN(ARG2))
+ { Answer = ARG1;
+ ARG1 = ARG2;
+ ARG2 = Answer;
+ }
+
+/* Allocate Storage and do GC if needed */
+
+ Size = Align(LEN(ARG1) + 1);
+ Primitive_GC_If_Needed(Size);
+ Answer = BIGNUM(Free);
+ Prepare_Header(Answer, LEN(ARG1)+1, sign);
+
+/* plus_unsigned_bignum continues on the next page */
+\f
+/* plus_unsigned_bignum, continued */
+
+/* Prepare Scanning Pointers and delimiters */
+
+ TOP1 = Bignum_Top(ARG1);
+ TOP2 = Bignum_Top(ARG2);
+ ARG1 = Bignum_Bottom(ARG1);
+ ARG2 = Bignum_Bottom(ARG2);
+ Answer = Bignum_Bottom(Answer);
+ Sum = 0;
+/* Starts Looping */
+ while (TOP2 >= ARG2)
+ { Sum = *ARG1++ + *ARG2++ + Get_Carry(Sum);
+ *Answer++ = Get_Digit(Sum);
+ }
+/* Let remaining carry propagate */
+ while ((TOP1 >= ARG1) && (Get_Carry(Sum) != 0))
+ { Sum = *ARG1++ + 1;
+ *Answer++ = Get_Digit(Sum);
+ }
+/* Copy rest of ARG1 into Answer */
+ while (TOP1 >= ARG1) *Answer++ = *ARG1++;
+ *Answer = Get_Carry(Sum);
+/* Trims Answer. The trim function is not used because there is at
+ * most one leading zero.
+ */
+ if (*Answer == 0)
+ { Answer = BIGNUM(Free);
+ LEN(Answer) -= 1;
+ *((Pointer *) Answer) = Make_Header(Align(LEN(Answer)));
+ }
+ Free += Size;
+ return Make_Pointer(TC_BIG_FIXNUM, Free-Size);
+}
+\f
+/* Subtraction */
+
+minus_signed_bignum(ARG1, ARG2)
+bigdigit *ARG1, *ARG2;
+{ /* Special Case for answer being zero */
+ if (ZERO_BIGNUM(ARG1) && ZERO_BIGNUM(ARG2))
+ return return_bignum_zero();
+
+/* Dispatches According to Sign of Args */
+
+ switch(Categorize_Sign(ARG1, ARG2))
+ { case BOTH_POSITIVE : return(minus_unsigned_bignum(ARG1, ARG2, POSITIVE));
+ case ARG1_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, NEGATIVE));
+ case ARG2_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, POSITIVE));
+ case BOTH_NEGATIVE : return(minus_unsigned_bignum(ARG2, ARG1, POSITIVE));
+ default : Sign_Error("minus_bignum()");
+ }
+}
+
+minus_unsigned_bignum(ARG1, ARG2, sign)
+fast bigdigit *ARG1, *ARG2;
+bigdigit sign;
+{ fast bigdouble Diff;
+ fast bigdigit *Answer, *TOP2, *TOP1;
+ long Size;
+
+ if (big_compare_unsigned(ARG1, ARG2) == TWO_BIGGER)
+ { Answer = ARG1;
+ ARG1 = ARG2;
+ ARG2 = Answer;
+ sign = !sign;
+ }
+
+ Size = Align(LEN(ARG1));
+ Primitive_GC_If_Needed(Size);
+ Answer = BIGNUM(Free);
+ Prepare_Header(Answer, LEN(ARG1), sign);
+
+/* minus_unsigned_bignum continues on the next page */
+\f
+/* minus_unsigned_bignum, continued */
+
+ TOP1 = Bignum_Top(ARG1);
+ TOP2 = Bignum_Top(ARG2);
+ ARG1 = Bignum_Bottom(ARG1);
+ ARG2 = Bignum_Bottom(ARG2);
+ Answer = Bignum_Bottom(Answer);
+ Diff = RADIX;
+
+/* Main Loops for minus_unsigned_bignum */
+
+ while (TOP2 >= ARG2)
+ { Diff = *ARG1++ + (MAX_DIGIT_SIZE - *ARG2++) + Get_Carry(Diff);
+ *Answer++ = Get_Digit(Diff);
+ }
+ while ((TOP1 >= ARG1) && (Get_Carry(Diff) == 0))
+ { Diff = *ARG1++ + MAX_DIGIT_SIZE;
+ *Answer++ = Get_Digit(Diff);
+ }
+ while (TOP1 >= ARG1) *Answer++ = *ARG1++;
+ trim_bignum((bigdigit *) Free);
+ Free += Size;
+ return Make_Pointer(TC_BIG_FIXNUM, Free-Size);
+}
+\f
+/* Multiplication */
+
+multiply_signed_bignum(ARG1, ARG2)
+bigdigit *ARG1, *ARG2;
+{ if (ZERO_BIGNUM(ARG1) || ZERO_BIGNUM(ARG2))
+ return return_bignum_zero();
+
+ switch(Categorize_Sign(ARG1,ARG2))
+ { case BOTH_POSITIVE :
+ case BOTH_NEGATIVE :
+ return multiply_unsigned_bignum(ARG1, ARG2, POSITIVE);
+ case ARG1_NEGATIVE :
+ case ARG2_NEGATIVE :
+ return multiply_unsigned_bignum(ARG1, ARG2, NEGATIVE);
+ default : Sign_Error("multiply_bignum()");
+ }
+}
+
+multiply_unsigned_bignum(ARG1, ARG2, sign)
+fast bigdigit *ARG1, *ARG2;
+bigdigit sign;
+{ bigdigit *TOP1, *TOP2;
+ fast bigdigit *Answer;
+ fast bigdouble Prod;
+ fast int size;
+ long Size;
+
+ Prod = LEN(ARG1) + LEN(ARG2);
+ Size = Align(Prod);
+ Primitive_GC_If_Needed(Size);
+ Answer = BIGNUM(Free);
+ Prepare_Header(Answer, Prod, sign);
+ TOP1 = Bignum_Top(Answer);
+ TOP2 = Bignum_Bottom(Answer);
+ while (TOP1 >= TOP2) *TOP2++ = 0;
+
+/* multiply_unsigned_bignum continues */
+\f
+/* Main Loops for MULTIPLY */
+
+ size = LEN(ARG2);
+ Answer = Bignum_Bottom(Answer) + size;
+ TOP1 = Bignum_Top(ARG1);
+ TOP2 = Bignum_Top(ARG2);
+ ARG2 = TOP2;
+
+ for (ARG1 = Bignum_Bottom(ARG1); TOP1 >= ARG1; ARG1++, Answer++)
+ { if (*ARG1 != 0)
+ { Prod = 0;
+ Answer -= size;
+ for (ARG2 = TOP2 - size + 1; TOP2 >= ARG2; ++ARG2)
+ { Prod = *ARG1 * *ARG2 + *Answer + Get_Carry(Prod);
+ *Answer++ = Get_Digit(Prod);
+ }
+ *Answer = Get_Carry(Prod);
+ }
+ }
+
+/* Trims Answer */
+ Answer = BIGNUM(Free);
+ if (*(Bignum_Top(Answer)) == 0)
+ { LEN(Answer) -= 1;
+ *((Pointer *) Answer) = Make_Header(Align(LEN(Answer)));
+ }
+ Free += Size;
+ return Make_Pointer(TC_BIG_FIXNUM, Free-Size);
+}
+\f
+/* (DIVIDE-BIGNUM ONE-BIGNUM ANOTHER_BIGNUM)
+ * [Primitive number 0x4F]
+ * returns a cons of the bignum quotient and remainder of both arguments.
+ */
+
+Built_In_Primitive(Prim_Divide_Bignum, 2, "DIVIDE-BIGNUM")
+{ Pointer Result, *End_Of_First, *First, *Second, *Orig_Free=Free;
+ Primitive_2_Args();
+ Arg_1_Type(TC_BIG_FIXNUM);
+ Arg_2_Type(TC_BIG_FIXNUM);
+ Set_Time_Zone(Zone_Math);
+ Result = div_signed_bignum(BIGNUM(Get_Pointer(Arg1)),
+ BIGNUM(Get_Pointer(Arg2)));
+ if (Bignum_Debug)
+ printf("\nResult=0x%x [%x %x]\n",
+ Result, Fast_Vector_Ref(Result, 0), Fast_Vector_Ref(Result, 1));
+ First = Get_Pointer(Fast_Vector_Ref(Result, CONS_CAR));
+ Second = Get_Pointer(Fast_Vector_Ref(Result, CONS_CDR));
+ if (Bignum_Debug)
+ printf("\nFirst=0x%x [%x %x]; Second=0x%x [%x %x]\n",
+ First, First[0], First[1], Second, Second[0], Second[1]);
+ if (Consistency_Check)
+ { if (First > Second)
+ { printf("\nBignum_Divide: results swapped.\n");
+ Microcode_Termination(TERM_EXIT);
+ }
+ else if (First != Orig_Free+2)
+ { printf("\nBignum Divide: hole at start\n");
+ Microcode_Termination(TERM_EXIT);
+ }
+ }
+ End_Of_First = First+1+Get_Integer(First[0]);
+ if (Bignum_Debug) printf("\nEnd_Of_First=0x%x\n", End_Of_First);
+ if (End_Of_First != Second)
+ { *End_Of_First =
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Second-End_Of_First)-1);
+ if (Bignum_Debug) printf("\nGap=0x%x\n", (Second-End_Of_First)-1);
+ }
+ Free = Second+1+Get_Integer(Second[0]);
+ if (Bignum_Debug) printf("\nEnd=0x%x\n", Free);
+ return Result;
+}
+\f
+/* div_signed_bignum() differentiates between all the possible
+ * cases and allocates storage for the quotient, remainder, and
+ * any intrmediate storage needed.
+ */
+
+div_signed_bignum(ARG1, ARG2)
+bigdigit *ARG1, *ARG2;
+{ bigdigit *SARG2;
+ bigdigit *QUOT, *REMD;
+ Pointer *Cons_Cell;
+
+ if ZERO_BIGNUM(ARG2) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Primitive_GC_If_Needed(2);
+ Cons_Cell = Free;
+ Free += 2;
+
+ if (big_compare_unsigned(ARG1, ARG2) == TWO_BIGGER)
+/* Trivial Solution for ARG1 > ARG2
+ * Quotient is zero and the remainder is just a copy of Arg_1.
+ */
+ { Primitive_GC_If_Needed(Align(0)+Align(LEN(ARG1)));
+ QUOT = BIGNUM(Free);
+ Free += Align(0);
+ Prepare_Header(QUOT, 0, POSITIVE);
+ REMD = BIGNUM(Free);
+ Free += Align(LEN(ARG1));
+ copy_bignum(ARG1, REMD);
+ }
+ else if (LEN(ARG2)==1)
+ /* Divisor is only one digit long.
+ * unscale() is used to divide out Arg_1 and the remainder is the
+ * single digit returned by unscale(), coerced to a bignum.
+ */
+ { Primitive_GC_If_Needed(Align(LEN(ARG1))+Align(1));
+ QUOT = BIGNUM(Free);
+ Free += Align(LEN(ARG1));
+ REMD = BIGNUM(Free);
+ Free += Align(1);
+ Prepare_Header(QUOT, LEN(ARG1), POSITIVE);
+ Prepare_Header(REMD, 1, POSITIVE);
+ *(Bignum_Bottom(REMD)) =
+ unscale(ARG1, QUOT, (long) *(Bignum_Bottom(ARG2)));
+ trim_bignum(REMD);
+ trim_bignum(QUOT);
+ }
+ else
+\f
+/* Usual case. div_internal() is called. A normalized copy of Arg_1
+ * resides in REMD, which ultimately becomes the remainder. The
+ * normalized copy of Arg_2 is in SARG2.
+ */
+ { bigdouble temp;
+ temp = (Align(LEN(ARG1)-LEN(ARG2)+1) + Align(LEN(ARG1)+1)
+ + Align(LEN(ARG2)+1));
+ Primitive_GC_If_Needed(temp);
+ QUOT = BIGNUM(Free);
+ *Free = Make_Header(Align(LEN(ARG1)-LEN(ARG2)+1));
+ Free += Align(LEN(ARG1)-LEN(ARG2)+1);
+ REMD = BIGNUM(Free);
+ *Free = Make_Header(Align(LEN(ARG1)+1));
+ Free += Align(LEN(ARG1)+1);
+ SARG2 = BIGNUM(Free);
+ *Free = Make_Header(Align(LEN(ARG2)+1));
+ Free += Align(LEN(ARG2)+1);
+
+ temp = RADIX / (1 + *(Bignum_Top(ARG2)));
+ scale(ARG1, REMD, temp);
+ scale(ARG2, SARG2, temp);
+ div_internal(REMD, SARG2, QUOT);
+ unscale(REMD, REMD, temp);
+ trim_bignum(REMD);
+ trim_bignum(QUOT);
+ }
+\f
+/* Determines sign of the quotient and remainder */
+
+ SIGN(REMD) = POSITIVE;
+ SIGN(QUOT) = POSITIVE;
+ switch(Categorize_Sign(ARG1,ARG2))
+ { case ARG2_NEGATIVE :
+ SIGN(QUOT) = NEGATIVE;
+ break;
+ case ARG1_NEGATIVE :
+ SIGN(QUOT) = NEGATIVE;
+ case BOTH_NEGATIVE :
+ SIGN(REMD) = NEGATIVE;
+ break;
+ case BOTH_POSITIVE : break;
+ default : Sign_Error("divide_bignum()");
+ } /* Glue the two results in a list and return as answer */
+ Cons_Cell[CONS_CAR] = Make_Pointer(TC_BIG_FIXNUM, (Pointer *) QUOT);
+ Cons_Cell[CONS_CDR] = Make_Pointer(TC_BIG_FIXNUM, (Pointer *) REMD);
+ return Make_Pointer(TC_LIST, Cons_Cell);
+}
+\f
+/* Utility for debugging */
+
+print_digits(name, num, how_many)
+char *name;
+bigdigit *num;
+int how_many;
+{ int NDigits = LEN(num);
+ int limit;
+ printf("\n%s = 0x%08x", name, num);
+ printf("\n Sign: %c, Vector length: %d, # Digits: %d",
+ ((SIGN(num) == NEGATIVE) ? '-' :
+ ((SIGN(num) == POSITIVE) ? '+' : '?')),
+ Datum(((Pointer *) num)[VECTOR_LENGTH]),
+ NDigits);
+ if (how_many == -1) limit = NDigits;
+ else limit = ((how_many < NDigits) ? how_many : NDigits);
+ num = Bignum_Bottom(num);
+ while (--how_many >= 0) printf("\n 0x%04x", *num++);
+ if (limit < NDigits) printf("\n ...");
+ printf("\n");
+ return;
+}
+\f
+/* This is the guts of the division algorithm. The storage
+ * allocation and other hairy prep work is done in the superior
+ * routines. ARG1 and ARG2 are fresh copies, ARG1 will
+ * ultimately become the Remainder. Storage already
+ * allocated for all four parameters.
+ */
+
+static Pointer BIG_A[TEMP_SIZE], BIG_B[TEMP_SIZE];
+
+div_internal(ARG1, ARG2, Quotient)
+bigdigit *ARG1, *ARG2, *Quotient;
+{ fast bigdigit *SCAN,*PROD;
+ fast bigdouble Digit, Prod;
+ fast bigdouble guess, dvsr2, dvsr1;
+ fast bigdigit *LIMIT, *QUOT_SCAN;
+ bigdigit *Big_A = BIGNUM(BIG_A);
+ bigdigit *Big_B = BIGNUM(BIG_B);
+
+ SCAN = Bignum_Top(ARG2);
+ if (*SCAN == 0)
+ { LEN(ARG2) -= 1;
+ SCAN -= 1;
+ }
+ dvsr1 = *SCAN--;
+ dvsr2 = *SCAN;
+
+ Prepare_Header(Quotient, (LEN(ARG1)-LEN(ARG2)), POSITIVE);
+
+ QUOT_SCAN = Bignum_Top(Quotient);
+ ARG1 = Bignum_Top(ARG1);
+ SCAN = ARG1 - LEN(ARG2);
+ Quotient = Bignum_Bottom(Quotient);
+
+/* div_internal() continues */
+\f
+/* Main Loop for div_internal() */
+
+ while (QUOT_SCAN >= Quotient)
+ { if (dvsr1 <= *ARG1) guess = RADIX - 1;
+ else
+ { /* This should be
+ * guess = (Mul_Radix(*ARG1) + *(ARG1 - 1)) / dvsr1;
+ * but because of overflow problems ...
+ */
+
+ Prepare_Header(Big_A, 2, POSITIVE);
+ *Bignum_Top(Big_A) = *ARG1;
+ *Bignum_Bottom(Big_A) = *(ARG1-1);
+ unscale(Big_A, Big_A, dvsr1);
+ guess = *Bignum_Bottom(Big_A);
+ }
+ guess += 1; /* To counter first decrementing below. */
+ do
+ { guess -= 1;
+ Prepare_Header(Big_A, 3, POSITIVE);
+ LIMIT = Bignum_Top(Big_A);
+ *LIMIT-- = *ARG1;
+ *LIMIT-- = *(ARG1-1);
+ *LIMIT = *(ARG1-2);
+ Prepare_Header(Big_B, 2, POSITIVE);
+ *Bignum_Top(Big_B) = dvsr1;
+ *Bignum_Bottom(Big_B) = dvsr2;
+ scale(Big_B, Big_B, guess);
+ if ((*Bignum_Top(Big_B)) == 0) LEN(Big_B) -= 1;
+ } while (big_compare_unsigned(Big_B, Big_A) == ONE_BIGGER);
+
+/* div_internal() continues */
+\f
+/* div_internal() continued */
+
+ LIMIT = Bignum_Top(ARG2);
+ PROD = Bignum_Bottom(ARG2);
+ Digit = RADIX + *SCAN;
+ while (LIMIT >= PROD)
+ { Prod = *PROD++ * guess;
+ Digit = Digit - Get_Digit(Prod);
+ *SCAN++ = Get_Digit(Digit);
+ Digit = ((*SCAN - Get_Carry(Prod)) +
+ (MAX_DIGIT_SIZE +
+ ((Digit < 0) ? -1 : Get_Carry(Digit))));
+ }
+ *SCAN++ = Get_Digit(Digit);
+
+ if (Get_Carry(Digit) == 0)
+ /* Guess is one too big, add back. */
+ { Digit = 0;
+ guess -= 1;
+ LIMIT = Bignum_Top(ARG2);
+ SCAN = SCAN - LEN(ARG2);
+ PROD = Bignum_Bottom(ARG2);
+ while (LIMIT >= PROD)
+ { Digit = *SCAN + *PROD++ + Get_Carry(Digit);
+ *SCAN++ = Get_Digit(Digit);
+ }
+ *SCAN = 0;
+ }
+ *QUOT_SCAN-- = guess;
+ ARG1 -= 1;
+ SCAN = ARG1 - LEN(ARG2);
+ }
+}
+\f
+
+/* (LISTIFY_BIGNUM BIGNUM RADIX)
+ [Primitive number 0x50]
+ Returns a list of numbers, in the range 0 through RADIX-1, which
+ represent the BIGNUM in that radix.
+*/
+Built_In_Primitive(Prim_Listify_Bignum, 2, "LISTIFY-BIGNUM")
+{ fast bigdigit *TOP1, *size;
+ quick Pointer *RFree;
+ fast bigdigit *ARG1;
+ fast long pradix;
+ Primitive_2_Args();
+
+ Arg_1_Type(TC_BIG_FIXNUM);
+ Arg_2_Type(TC_FIXNUM);
+ Set_Time_Zone(Zone_Math);
+
+ ARG1 = BIGNUM(Get_Pointer(Arg1));
+ size = &LEN(ARG1);
+ if (*size == 0)
+ { Primitive_GC_If_Needed(2);
+ *Free++ = FIXNUM_0;
+ *Free++ = NIL;
+ return Make_Pointer(TC_LIST, Free-2);
+ }
+ Sign_Extend(Arg2, pradix);
+ Primitive_GC_If_Needed(Find_Length(pradix, *size)+Align(*size));
+ ARG1 = BIGNUM(Free);
+ copy_bignum(BIGNUM(Get_Pointer(Arg1)), ARG1);
+ Free += Align(*size);
+ RFree = Free;
+ size = &LEN(ARG1);
+ TOP1 = Bignum_Top(ARG1);
+ while (*size > 0)
+ { *RFree++ = FIXNUM_0+unscale(ARG1, ARG1, pradix);
+ *RFree = Make_Pointer(TC_LIST, RFree-3);
+ RFree += 1;
+ if (*TOP1 == 0)
+ { *size -= 1;
+ TOP1--;
+ }
+ }
+ Free[CONS_CDR] = NIL;
+ Free = RFree;
+ return Make_Pointer(TC_LIST, RFree-2);
+}
+\f
+/* General Purpose Utilities */
+
+return_bignum_zero()
+{ bigdigit *REG;
+ long Align_0 = Align(0);
+ Primitive_GC_If_Needed(Align_0);
+ REG = BIGNUM(Free);
+ Prepare_Header(REG, 0, POSITIVE);
+ Free += Align_0;
+ return Make_Pointer(TC_BIG_FIXNUM, Free-Align_0);
+}
+
+trim_bignum(ARG)
+bigdigit *ARG;
+{ fast bigdigit *SCAN;
+ fast bigdigit size;
+ bigdigit sign;
+
+ sign = SIGN(ARG);
+ size = LEN(ARG);
+
+ for (SCAN=Bignum_Top(ARG); ((size!=0)&&(*SCAN==0)); SCAN--)
+ size -= 1;
+
+ if (size == 0) sign = POSITIVE;
+ Prepare_Header(ARG, size, sign);
+}
+
+copy_bignum(SOURCE, TARGET)
+fast bigdigit *SOURCE, *TARGET;
+{ fast bigdigit *LIMIT = Bignum_Top(SOURCE);
+ while (LIMIT >= SOURCE) *TARGET++ = *SOURCE++;
+}
+
+Find_Length(pradix, length)
+fast long pradix;
+bigdigit length;
+{ fast int log_pradix = 0;
+ while (pradix != 1)
+ { pradix = pradix >> 1;
+ log_pradix += 1;
+ }
+ return(((SHIFT / log_pradix) + 1) * length);
+}
+\f
+/* scale() and unscale() used by Division and Listify */
+
+scale(SOURCE, DEST, how_much)
+fast bigdigit *SOURCE, *DEST;
+fast long how_much;
+{ fast unsigned bigdouble prod = 0;
+ bigdigit *LIMIT;
+
+ if (how_much == 1)
+ { if (SOURCE != DEST) copy_bignum(SOURCE, DEST);
+ Prepare_Header(DEST, LEN(SOURCE)+1, SIGN(SOURCE));
+ *Bignum_Top(DEST) = 0;
+ return;
+ }
+ /* This must happen before the Prepare_Header if DEST = SOURCE */
+ LIMIT = Bignum_Top(SOURCE);
+ Prepare_Header(DEST, LEN(SOURCE)+1, SIGN(SOURCE));
+ SOURCE = Bignum_Bottom(SOURCE);
+ DEST = Bignum_Bottom(DEST);
+ while (LIMIT >= SOURCE)
+ { prod = *SOURCE++ * how_much + Get_Carry(prod);
+ *DEST++ = Get_Digit(prod);
+ }
+ *DEST = Get_Carry(prod);
+}
+
+unscale(SOURCE, DEST, how_much)
+bigdigit *SOURCE;
+fast bigdigit *DEST;
+fast long how_much;
+{ bigdigit carry = 0;
+ fast unsigned bigdouble digits;
+ fast bigdigit *SCAN;
+
+ if (how_much == 1)
+ { if (SOURCE != DEST) copy_bignum(SOURCE, DEST);
+ return 0;
+ }
+ Prepare_Header(DEST, LEN(SOURCE), SIGN(DEST));
+ SCAN = Bignum_Top(SOURCE);
+ DEST = Bignum_Top(DEST);
+ SOURCE = Bignum_Bottom(SOURCE);
+ while (SCAN >= SOURCE)
+ { digits = Mul_Radix(carry) + *SCAN--;
+ *DEST = digits / how_much;
+ carry = digits - (*DEST-- * how_much);
+ }
+ return carry; /* returns remainder */
+}
+\f
+/* Top level bignum primitives */
+
+/* All the binary bignum primtives take two arguments and return NIL
+ if either of them is not a bignum. If both arguments are bignums,
+ the perform the operation and return the answer.
+*/
+
+#define Binary_Primitive(C_Name, S_Name, Op) \
+Built_In_Primitive(C_Name, 2, S_Name) \
+{ Pointer Result, *Orig_Free=Free; \
+ Primitive_2_Args(); \
+ Arg_1_Type(TC_BIG_FIXNUM); \
+ Arg_2_Type(TC_BIG_FIXNUM); \
+ Set_Time_Zone(Zone_Math); \
+ Result = Op(BIGNUM(Get_Pointer(Arg1)), BIGNUM(Get_Pointer(Arg2))); \
+ if (Consistency_Check && (Get_Pointer(Result) != Orig_Free)) \
+ { printf("\nBignum operation result at 0x%x, Free was 0x%x\n", \
+ Address(Result), Free); \
+ Microcode_Termination(TERM_EXIT); \
+ } \
+ Free = Nth_Vector_Loc(Result, Vector_Length(Result)+1); \
+ if (Consistency_Check && (Free > Heap_Top)) \
+ { printf("\nBignum operation result at 0x%x, length 0x%x\n", \
+ Address(Result), Vector_Length(Result)); \
+ Microcode_Termination(TERM_EXIT); \
+ } \
+ return Result; \
+}
+
+Binary_Primitive(Prim_Plus_Bignum, "PLUS-BIGNUM", plus_signed_bignum);
+Binary_Primitive(Prim_Minus_Bignum, "MINUS-BIGNUM", minus_signed_bignum);
+Binary_Primitive(Prim_Multiply_Bignum,
+ "TIMES-BIGNUM",
+ multiply_signed_bignum);
+\f
+/* All the unary bignum predicates take one argument and return NIL if
+ it is not a bignum. Otherwise, they return a fixnum 1 if the
+ predicate is true or a fixnum 0 if it is false. This convention of
+ NIL/0/1 is used for all numeric predicates so that the generic
+ dispatch can detect "inapplicable" as distinct from "false" answer.
+*/
+
+#define Unary_Predicate(C_Name, S_Name, Test) \
+Built_In_Primitive(C_Name, 1, S_Name) \
+{ bigdigit *ARG; \
+ Primitive_1_Arg(); \
+ Arg_1_Type(TC_BIG_FIXNUM); \
+ Set_Time_Zone(Zone_Math); \
+ ARG = BIGNUM(Get_Pointer(Arg1)); \
+ return FIXNUM_0 + ((Test) ? 1 : 0); \
+}
+
+Unary_Predicate(Prim_Zero_Bignum, "ZERO-BIGNUM?", LEN(ARG)==0)
+Unary_Predicate(Prim_Positive_Bignum,
+ "POSITIVE-BIGNUM?",
+ (LEN(ARG) != 0) && POS_BIGNUM(ARG))
+Unary_Predicate(Prim_Negative_Bignum,
+ "NEGATIVE-BIGNUM?",
+ (LEN(ARG) != 0) && NEG_BIGNUM(ARG))
+
+/* All the binary bignum predicates take two arguments and return NIL
+ if either of them is not a bignum. Otherwise, they return an
+ answer as described above for the unary predicates.
+*/
+
+#define Binary_Predicate(C_Name, S_Name, Code) \
+Built_In_Primitive(C_Name, 2, S_Name) \
+{ Primitive_2_Args(); \
+ Arg_1_Type(TC_BIG_FIXNUM); \
+ Arg_2_Type(TC_BIG_FIXNUM); \
+ Set_Time_Zone(Zone_Math); \
+ return FIXNUM_0 + \
+ ((big_compare(BIGNUM(Get_Pointer(Arg1)), \
+ BIGNUM(Get_Pointer(Arg2))) == Code) ? 1 : 0); \
+}
+
+Binary_Predicate(Prim_Equal_Bignum, "EQUAL-BIGNUM?", EQUAL)
+Binary_Predicate(Prim_Greater_Bignum, "GREATER-BIGNUM?", ONE_BIGGER)
+Binary_Predicate(Prim_Less_Bignum, "LESS-BIGNUM?", TWO_BIGGER)
--- /dev/null
+/* 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
+/* Head file for bignums. This is shared by bignum.c and generic.c. */
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+#define Debug_Test(Res) \
+{ Pointer R = Make_Pointer(TC_BIG_FIXNUM, Res); \
+ if (Nth_Vector_Loc(R, Vector_Length(R)) != (Free-1)) \
+ { printf("\nResult=%x => %x %x %x, Length=%d, Free=%x\n", \
+ R, Fast_Vector_Ref(R, 0), \
+ Fast_Vector_Ref(R, 1), Fast_Vector_Ref(R, 2), \
+ Vector_Length(R), Free); \
+ Microcode_Termination(TERM_EXIT); \
+ } \
+}
+#else
+#define Debug_Test(Res) { }
+#endif
+\f
+#define POSITIVE 1
+#define NEGATIVE 0
+
+/* The representation of a BIGNUM is machine dependent. For a VAX-11
+ * it is as follows:
+ */
+
+#ifdef pdp10
+typedef unsigned int bigdigit;
+typedef long bigdouble;
+#define SHIFT 16
+#define factor 1
+#else
+#if ((USHORT_SIZE * 2) <= ULONG_SIZE)
+#define bigdigit unsigned short
+#define bigdouble long /* Should be unsigned */
+#define SHIFT (CHAR_SIZE*sizeof(bigdigit))
+#define factor (sizeof(Pointer)/sizeof(bigdigit))
+#else
+#if ((CHAR_SIZE * 2) <= ULONG_SIZE)
+#define bigdigit unsigned char
+#define bigdouble long /* Should be unsigned */
+#define SHIFT CHAR_SIZE
+#define factor (sizeof(Pointer)/sizeof(bigdigit))
+#else
+#include "Cannot compile bignums. All types too large. See bignum.h"
+#endif
+#endif
+#endif
+
+#define DELTA \
+ ((sizeof(bigdouble)-sizeof(bigdigit))*CHAR_SIZE)
+#define SIGN(Bignum) (Bignum[factor])
+#define LEN(Bignum) (Bignum[factor+1])
+#define Bignum_Bottom(Bignum) (&(Bignum)[factor+2])
+#define Bignum_Top(Bignum) (&(Bignum)[factor+1+LEN(Bignum)])
+#define Align(ndigits) ((((ndigits) + factor + 1) / factor) + 1)
+
+/* For temporary bignums */
+
+#define TEMP_SIZE Align(4)
+
+/* Macros for making BIGNUM headers */
+
+#define Make_Header(l) Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,(l-1))
+#define Prepare_Header(Bignum,Length,Sign) \
+ { *((Pointer *) Bignum) = Make_Header(Align(Length)); \
+ SIGN(Bignum) = Sign; \
+ LEN(Bignum) = Length; \
+ }
+\f
+/* Predicates coded as macros for determining the sign of BIGNUM's */
+
+#define POS_BIGNUM(Bignum) (SIGN(Bignum) == POSITIVE)
+#define NEG_BIGNUM(Bignum) (SIGN(Bignum) == NEGATIVE)
+#define ZERO_BIGNUM(Bignum) (LEN(Bignum) == 0)
+#define NON_ZERO_BIGNUM(Bignum) (LEN(Bignum) != 0)
+
+
+/* Coerces a C pointer to point to BIGNUM digits */
+
+#define BIGNUM(ptr) ((bigdigit *) ptr)
+
+/* Macros for manipulating long BIGNUM digits */
+
+#define RADIX (1<<SHIFT)
+#define MAX_DIGIT_SIZE (RADIX-1)
+#define CARRY_MASK (MAX_DIGIT_SIZE<<SHIFT)
+#define DIGIT_MASK MAX_DIGIT_SIZE
+#define DIV_MASK ((1<<DELTA)-1)
+#define Get_Carry(lw) (((lw & CARRY_MASK) >> SHIFT) & DIGIT_MASK)
+#define Get_Digit(lw) (lw & DIGIT_MASK)
+#define Mul_Radix(sw) (sw << SHIFT)
+#define Div_Radix(lw) ((lw >> SHIFT) & DIV_MASK)
+#define Rem_Radix(lw) (lw & DIGIT_MASK)
+
+/* Length of the BIGNUM that contains the largest FIXNUM */
+
+#define FIXNUM_LENGTH_AS_BIGNUM ((FIXNUM_LENGTH+(SHIFT-1))/SHIFT)
+#define C_INTEGER_LENGTH_AS_BIGNUM ((POINTER_LENGTH+(SHIFT-1))/SHIFT)
+\f
+/* Cases returned by the comparison function big_compare() */
+
+#define EQUAL 0
+#define ONE_BIGGER 1
+#define TWO_BIGGER 2
+
+/* Categorize_Sign() takes two bignum's and classify them according
+ * to four possible cases, depending on each's sign. Depends on
+ * definition of POSITIVE and NEGATIVE, earlier!!!
+ */
+
+#define Categorize_Sign(ARG1, ARG2) ((SIGN(ARG1) << 1) | SIGN(ARG2))
+#define BOTH_NEGATIVE 0
+#define ARG1_NEGATIVE 1
+#define ARG2_NEGATIVE 2
+#define BOTH_POSITIVE 3
+#define Sign_Error(proc) \
+ { printf(proc); \
+ printf(" -- Sign Determination Error\n"); \
+ printf("Possibly Uncanonicalized Bignum\n"); \
+ return ERR_UNDEFINED_PRIMITIVE; \
+ }
+
+#define Fetch_Bignum(big) BIGNUM(Get_Pointer(big))
+
+#define Bignum_Operation(Object, Result) \
+ Result = (Object); \
+ Free = Nth_Vector_Loc(Result, Vector_Length(Result)+1); \
+ Result = Big_To_Fix(Result);
+\f
+#define Divide_Bignum_Operation(Object, Result) \
+{ Pointer *End_Of_First, *First, *Second; \
+ Result = (Object); \
+ First = Get_Pointer(Vector_Ref(Result, CONS_CAR)); \
+ Second = Get_Pointer(Vector_Ref(Result, CONS_CDR)); \
+ End_Of_First = First+1+Get_Integer(First[0]); \
+ if (End_Of_First != Second) \
+ { *End_Of_First = \
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Second-End_Of_First)-1); \
+ if (Bignum_Debug) printf("\nGap=0x%x\n", (Second-End_Of_First)-1); \
+ } \
+ Free = Second+1+Get_Integer(Second[0]); \
+ Vector_Set(Result,CONS_CAR,Big_To_Fix(Vector_Ref(Result,CONS_CAR))); \
+ Vector_Set(Result,CONS_CDR,Big_To_Fix(Vector_Ref(Result,CONS_CDR))); \
+}
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: BINTOPSB.C
+ *
+ * This File contains the code to translate internal format binary
+ * files to portable format.
+ *
+ */
+\f
+/* Cheap renames */
+
+#define Internal_File Input_File
+#define Portable_File Output_File
+
+#include "translate.h"
+
+static Boolean Shuffle_Bytes = false;
+static Boolean Padded_Strings = true;
+static Boolean Dense_Types = true;
+
+static Pointer *Mem_Base;
+static long Heap_Relocation, Constant_Relocation;
+static long Free, Scan, Free_Constant, Scan_Constant;
+static long Objects, Constant_Objects;
+static long NFlonums, NIntegers, NStrings;
+static long NBits, NChars;
+static Pointer *Free_Objects, *Free_Cobjects;
+
+Load_Data(Count, To_Where)
+long Count;
+char *To_Where;
+{ fread(To_Where, sizeof(Pointer), Count, Internal_File);
+}
+
+#define Reloc_or_Load_Debug false
+
+#include "load.c"
+\f
+/* Utility macros and procedures
+ Pointer Objects handled specially in the portable format.
+*/
+
+#ifndef isalpha
+/* Just in case the stdio library atypically contains the character
+ macros, just like the C book claims. */
+#include <ctype.h>
+#endif
+
+#ifndef ispunct
+/* This is in some libraries but not others */
+static char punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
+
+Boolean ispunct(c)
+fast char c;
+{ fast char *s = &punctuation[0];
+ while (*s != '\0') if (*s++ == c) return true;
+ return false;
+}
+#endif
+
+#define OUT(s) \
+fprintf(Portable_File, s); \
+break
+
+print_a_char(c, name)
+fast char c;
+char *name;
+{ switch(c)
+ { case '\n': OUT("\\n");
+ case '\t': OUT("\\t");
+ case '\b': OUT("\\b");
+ case '\r': OUT("\\r");
+ case '\f': OUT("\\f");
+ case '\\': OUT("\\\\");
+ case '\0': OUT("\\0");
+ case ' ' : OUT(" ");
+ default:
+ if ((isalpha(c)) || (isdigit(c)) || (ispunct(c)))
+ putc(c, Portable_File);
+ else
+ { fprintf(stderr,
+ "%s: %s: File may not be portable: c = 0x%x\n",
+ Program_Name, name, ((int) c));
+ /* This does not follow C conventions, but eliminates ambiguity */
+ fprintf(Portable_File, "\X%x ", ((int) c));
+ }
+ }
+}
+\f
+#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer((Code), Old_Contents); \
+ else \
+ { fast long i; \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = STRING_0; \
+ *(FObj)++ = Old_Contents; \
+ i = Get_Integer(Old_Contents); \
+ NStrings += 1; \
+ NChars += (Padded_Strings ? \
+ pointer_to_char(i-1) : \
+ (1 + pointer_to_char(i-1))); \
+ while(--i >= 0) *(FObj)++ = *Old_Address++; \
+ } \
+ if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \
+}
+
+print_a_string(from)
+Pointer *from;
+{ fast long len;
+ fast char *string;
+ long maxlen = pointer_to_char((Get_Integer(*from++))-1);
+ if (!Padded_Strings) maxlen += 1;
+ len = Get_Integer(*from++);
+ fprintf(Portable_File, "%02x %ld %ld ",
+ TC_CHARACTER_STRING,
+ (Compact_P ? len : maxlen),
+ len);
+ string = ((char *) from);
+ if (Shuffle_Bytes)
+ { while(len > 0)
+ { print_a_char(string[3], "print_a_string");
+ if (len > 1) print_a_char(string[2], "print_a_string");
+ if (len > 2) print_a_char(string[1], "print_a_string");
+ if (len > 3) print_a_char(string[0], "print_a_string");
+ len -= 4;
+ string += 4;
+ }
+ }
+ else while(--len >= 0) print_a_char(*string++, "print_a_string");
+ putc('\n', Portable_File);
+ return;
+}
+\f
+print_a_fixnum(val)
+long val;
+{ fast long size_in_bits;
+ fast unsigned long temp = ((val < 0) ? -val : val);
+ for (size_in_bits = 0; temp != 0; size_in_bits += 1)
+ temp = temp >> 1;
+ fprintf(Portable_File, "%02x %c ",
+ TC_FIXNUM,
+ (val < 0 ? '-' : '+'));
+ if (val == 0) fprintf(Portable_File, "0\n");
+ else
+ { fprintf(Portable_File, "%ld ", size_in_bits);
+ temp = ((val < 0) ? -val : val);
+ while (temp != 0)
+ { fprintf(Portable_File, "%01lx", (temp % 16));
+ temp = temp >> 4;
+ }
+ fprintf(Portable_File, "\n");
+ }
+ return;
+}
+\f
+#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer((Code), Old_Contents); \
+ else \
+ { fast long length; \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ NIntegers += 1; \
+ NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \
+ *(FObj)++ = Old_Contents; \
+ for (length = Get_Integer(Old_Contents); \
+ --length >= 0; ) \
+ *(FObj)++ = *Old_Address++; \
+ } \
+ if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \
+}
+
+print_a_bignum(from)
+Pointer *from;
+{ fast bigdigit *the_number, *the_top;
+ fast long size_in_bits;
+ fast unsigned long temp; /* Potential signed problems */
+
+ the_number = BIGNUM(from);
+ temp = LEN(the_number);
+ if (temp == 0)
+ fprintf(Portable_File, "%02x + 0\n",
+ (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM));
+ else
+ { fast long tail;
+ for (size_in_bits = ((temp - 1) * SHIFT),
+ temp = ((long) (*Bignum_Top(the_number)));
+ temp != 0;
+ size_in_bits += 1)
+ temp = temp >> 1;
+
+ fprintf(Portable_File, "%02x %c %ld ",
+ (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM),
+ (NEG_BIGNUM(the_number) ? '-' : '+'),
+ size_in_bits);
+ tail = size_in_bits % SHIFT;
+ if (tail == 0) tail = SHIFT;
+ temp = 0;
+ size_in_bits = 0;
+ the_top = Bignum_Top(the_number);
+ for(the_number = Bignum_Bottom(the_number);
+ the_number <= the_top;
+ the_number += 1)
+ { temp |= (((unsigned long) (*the_number)) << size_in_bits);
+ for (size_in_bits += ((the_number != the_top) ? SHIFT : tail);
+ size_in_bits > 3;
+ size_in_bits -= 4)
+ { fprintf(Portable_File, "%01lx", temp % 16);
+ temp = temp >> 4;
+ }
+ }
+ if (size_in_bits > 0) fprintf(Portable_File, "%01lx\n", temp);
+ else fprintf(Portable_File, "\n");
+ }
+ return;
+}
+\f
+#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer((Code), Old_Contents); \
+ else \
+ { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \
+ *((double *) (FObj)) = *((double *) Old_Address); \
+ (FObj) += float_to_pointer; \
+ NFlonums += 1; \
+ } \
+ if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \
+}
+
+print_a_flonum(val)
+double val;
+{ fast long size_in_bits;
+ fast double mant, temp;
+ int expt;
+ extern double frexp();
+
+ fprintf(Portable_File, "%02x %c ",
+ TC_BIG_FLONUM,
+ ((val < 0.0) ? '-' : '+'));
+ if (val == 0.0)
+ { fprintf(Portable_File, "0\n");
+ return;
+ }
+ mant = frexp(((val < 0.0) ? -val : val), &expt);
+ size_in_bits = 1;
+ for(temp = ((mant * 2.0) - 1.0);
+ temp != 0;
+ size_in_bits += 1)
+ { temp *= 2.0;
+ if (temp >= 1.0) temp -= 1.0;
+ }
+ fprintf(Portable_File, "%ld %ld ", expt, size_in_bits);
+ for (size_in_bits = hex_digits(size_in_bits);
+ size_in_bits > 0;
+ size_in_bits -= 1)
+ { fast unsigned int digit = 0;
+ for (expt = 4; --expt >= 0;)
+ { mant *= 2.0;
+ digit = digit << 1;
+ if (mant >= 1.0)
+ { mant -= 1.0;
+ digit += 1;
+ }
+ }
+ fprintf(Portable_File, "%01x", digit);
+ }
+ fprintf(Portable_File, "\n");
+ return;
+}
+\f
+/* Normal Objects */
+
+#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ } \
+}
+
+#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ } \
+}
+
+#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ } \
+}
+
+#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { fast long len = Get_Integer(Old_Contents); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ while (len > 0) \
+ { Mem_Base[(Fre)++] = *Old_Address++; \
+ len -= 1; \
+ } \
+ } \
+}
+\f
+/* Common Pointer Code */
+
+#define Do_Pointer(Scn, Action) \
+Old_Address = Get_Pointer(This); \
+if (Datum(This) < Const_Base) \
+ Action(HEAP_CODE, Heap_Relocation, Free, \
+ Scn, Objects, Free_Objects) \
+else if (Datum(This) < Dumped_Constant_Top) \
+Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \
+ Scn, Constant_Objects, Free_Cobjects) \
+else \
+{ fprintf(stderr, \
+ "%s: File is not portable: Pointer to stack.\n", \
+ Program_Name); \
+ exit(1); \
+} \
+(Scn) += 1; \
+break
+\f
+/* Processing of a single area */
+
+#define Do_Area(Code, Area, Bound, Obj, FObj) \
+ Process_Area(Code, &Area, &Bound, &Obj, &FObj)
+
+#ifdef DEBUG
+#define Show_Upgrade(This, New_Type) \
+ fprintf(stderr, "Upgrading from 0x%02x|%06x to 0x%x\n", \
+ Type_Code(This), Datum(This), New_Type);
+#else
+#define Show_Upgrade(This, New_Type)
+#endif
+
+#define Upgrade(New_Type) \
+{ Boolean Was_Dangerous = Dangerous(This); \
+ Show_Upgrade(This, New_Type); \
+ if (Dense_Types) goto Bad_Type; \
+ This = Make_New_Pointer(New_Type, Datum(This)); \
+ if (Was_Dangerous) Set_Danger_Bit(This); \
+ Mem_Base[*Area] = This; \
+ break; \
+}
+
+Process_Area(Code, Area, Bound, Obj, FObj)
+int Code;
+fast long *Area, *Bound;
+fast long *Obj;
+fast Pointer **FObj;
+{ fast Pointer This, *Old_Address, Old_Contents;
+ while(*Area != *Bound)
+ { This = Mem_Base[*Area];
+ Switch_by_GC_Type(This)
+ { case TC_MANIFEST_NM_VECTOR:
+ if (Null_NMV)
+ { fast int i = Get_Integer(This);
+ *Area += 1;
+ for ( ; --i >= 0; *Area += 1)
+ Mem_Base[*Area] = NIL;
+ break;
+ }
+ /* else, Unknown object! */
+ fprintf(stderr, "%s: File is not portable: NMH found\n",
+ Program_Name);
+ *Area += 1 + Get_Integer(This);
+ break;
+
+ case TC_BROKEN_HEART:
+ /* [Broken Heart 0] is the cdr of fasdumped symbols. */
+ if (Get_Integer(This) != 0)
+ { fprintf(stderr, "%s: Broken Heart found in scan.\n",
+ Program_Name);
+ exit(1);
+ }
+ *Area += 1;
+ break;
+
+ case TC_FIXNUM:
+ NIntegers += 1;
+ NBits += fixnum_to_bits;
+ /* Fall Through */
+ case TC_CHARACTER:
+ Process_Character:
+ Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj);
+ *Obj += 1;
+ **FObj = This;
+ if (Dangerous(This))
+ { Set_Danger_Bit(Mem_Base[*Area]);
+ Clear_Danger_Bit(**FObj);
+ }
+ *FObj += 1;
+ /* Fall through */
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ case TC_PRIMITIVE_EXTERNAL:
+ case_simple_Non_Pointer:
+ *Area += 1;
+ break;
+
+ case_compiled_entry_point:
+ fprintf(stderr,
+ "%s: File is not portable: Compiled code.\n",
+ Program_Name);
+ exit(1);
+
+ case_Cell:
+ Do_Pointer(*Area, Do_Cell);
+
+ case TC_WEAK_CONS:
+ case_Pair:
+ Do_Pointer(*Area, Do_Pair);
+
+ case TC_VARIABLE:
+ case_Triple:
+ Do_Pointer(*Area, Do_Triple);
+
+ case TC_BIG_FLONUM:
+ Do_Pointer(*Area, Do_Flonum);
+
+ case TC_BIG_FIXNUM:
+ Do_Pointer(*Area, Do_Bignum);
+
+ case TC_CHARACTER_STRING:
+ Do_Pointer(*Area, Do_String);
+
+ case TC_ENVIRONMENT:
+ case TC_FUTURE:
+ case_simple_Vector:
+ Do_Pointer(*Area, Do_Vector);
+
+/* This should be cleaned up: We can no longer do it like this
+ since we have reused the types.
+ */
+
+ case OLD_TC_BROKEN_HEART:
+ Upgrade(TC_BROKEN_HEART);
+ case OLD_TC_SPECIAL_NM_VECTOR:
+ Upgrade(TC_MANIFEST_SPECIAL_NM_VECTOR);
+#if 0
+ case OLD_TC_UNASSIGNED:
+ Upgrade(TC_UNASSIGNED);
+ case OLD_TC_RETURN_CODE:
+ Upgrade(TC_RETURN_CODE);
+#endif
+ case OLD_TC_PCOMB0:
+ Upgrade(TC_PCOMB0);
+ case OLD_TC_THE_ENVIRONMENT:
+ Upgrade(TC_THE_ENVIRONMENT);
+ case OLD_TC_CHARACTER:
+ Upgrade(TC_CHARACTER);
+ case OLD_TC_FIXNUM:
+ Upgrade(TC_FIXNUM);
+#if 0
+ case OLD_TC_SEQUENCE_3:
+ Upgrade(TC_SEQUENCE_3);
+#endif
+ case OLD_TC_MANIFEST_NM_VECTOR:
+ Upgrade(TC_MANIFEST_NM_VECTOR);
+ case OLD_TC_VECTOR:
+ Upgrade(TC_VECTOR);
+#if 0
+ case OLD_TC_ENVIRONMENT:
+ Upgrade(TC_ENVIRONMENT);
+#endif
+ case OLD_TC_CONTROL_POINT:
+ Upgrade(TC_CONTROL_POINT);
+ case OLD_TC_COMBINATION:
+ Upgrade(TC_COMBINATION);
+ case OLD_TC_PCOMB3:
+ Upgrade(TC_PCOMB3);
+ case OLD_TC_PCOMB2:
+ Upgrade(TC_PCOMB2);
+
+ default:
+ Bad_Type:
+ fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
+ Program_Name, Type_Code(This));
+ exit(1);
+ }
+ }
+}
+\f
+/* Output macros */
+
+#define print_an_object(obj) \
+fprintf(Portable_File, "%02x %lx\n", \
+ Type_Code(obj), Get_Integer(obj))
+
+#define print_external_object(from) \
+{ switch(Type_Code(*from)) \
+ { case TC_FIXNUM: \
+ { long Value; \
+ Sign_Extend(*from++, Value); \
+ print_a_fixnum(Value); \
+ break; \
+ } \
+ case TC_BIG_FIXNUM: \
+ from += 1; \
+ print_a_bignum(from); \
+ from += 1 + Get_Integer(*from); \
+ break; \
+ case TC_CHARACTER_STRING: \
+ from += 1; \
+ print_a_string(from); \
+ from += 1 + Get_Integer(*from); \
+ break; \
+ case TC_BIG_FLONUM: \
+ print_a_flonum(*((double *) (from+1))); \
+ from += 1 + float_to_pointer; \
+ break; \
+ case TC_CHARACTER: \
+ fprintf(Portable_File, "%02x %03x\n", \
+ TC_CHARACTER, (*from & MASK_EXTNDD_CHAR)); \
+ from += 1; \
+ break; \
+ default: \
+ fprintf(stderr, \
+ "%s: Bad Object to print externally %lx\n", \
+ Program_Name, *from); \
+ exit(1); \
+ } \
+}
+\f
+/* Debugging Aids and Consistency Checks */
+
+#ifdef DEBUG
+
+When(what, message)
+Boolean what;
+char *message;
+{ if (what)
+ { fprintf(stderr, "%s: Inconsistency: %s!\n",
+ Program_Name, (message));
+ exit(1);
+ }
+ return;
+}
+
+#define print_header(name, obj, format) \
+fprintf(Portable_File, (format), (obj)); \
+fprintf(stderr, "%s: ", (name)); \
+fprintf(stderr, (format), (obj))
+
+#else
+
+#define When(what, message)
+
+#define print_header(name, obj, format) \
+fprintf(Portable_File, (format), (obj))
+
+#endif
+\f
+/* The main program */
+
+do_it()
+{ Pointer *Heap;
+ long Initial_Free;
+
+ /* Load the Data */
+
+ if (!Read_Header())
+ { fprintf(stderr,
+ "%s: Input file does not appear to be in FASL format.\n",
+ Program_Name);
+ exit(1);
+ }
+
+ if ((Version != FASL_FORMAT_VERSION) ||
+ (Sub_Version > FASL_SUBVERSION) ||
+ (Sub_Version < FASL_OLDEST_SUPPORTED) ||
+ ((Machine_Type != FASL_INTERNAL_FORMAT) && (!Shuffle_Bytes)))
+ { fprintf(stderr, "%s:\n", Program_Name);
+ fprintf(stderr,
+ "FASL File Version %ld Subversion %ld Machine Type %ld\n",
+ Version, Sub_Version , Machine_Type);
+ fprintf(stderr,
+ "Expected: Version %d Subversion %d Machine Type %d\n",
+ FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
+ exit(1);
+ }
+
+ if (Machine_Type == FASL_INTERNAL_FORMAT)
+ Shuffle_Bytes = false;
+ if (Sub_Version < FASL_PADDED_STRINGS)
+ Padded_Strings = false;
+ if (Sub_Version < FASL_DENSE_TYPES)
+ Dense_Types = false;
+
+ /* Constant Space not currently supported */
+
+ if (Const_Count != 0)
+ { fprintf(stderr,
+ "%s: Input file has a constant space area.\n",
+ Program_Name);
+ exit(1);
+ }
+
+ { long Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1);
+#ifdef FLOATING_ALIGNMENT
+ Size += (FLOATING_ALIGNMENT+1)/sizeof(Pointer);
+#endif
+ Allocate_Heap_Space(Size);
+ if (Heap == NULL)
+ { fprintf(stderr,
+ "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
+ Program_Name, Size);
+ exit(1);
+ }
+ }
+ Align_Float(Heap);
+ Load_Data(Heap_Count, &Heap[0]);
+ Load_Data(Const_Count, &Heap[Heap_Count]);
+ Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base);
+ Constant_Relocation = &Heap[Heap_Count] - Get_Pointer(Const_Base);
+
+#ifdef DEBUG
+ fprintf(stderr, "Dumped Heap Base = 0x%08x\n", Heap_Base);
+ fprintf(stderr, "Dumped Constant Base = 0x%08x\n", Const_Base);
+ fprintf(stderr, "Dumped Constant Top = 0x%08x\n", Dumped_Constant_Top);
+ fprintf(stderr, "Heap Count = %6d\n", Heap_Count);
+ fprintf(stderr, "Constant Count = %6d\n", Const_Count);
+#endif
+\f
+ /* Reformat the data */
+
+ NFlonums = NIntegers = NStrings = NBits = NChars = 0;
+ Mem_Base = &Heap[Heap_Count + Const_Count];
+ if (Ext_Prim_Vector == NIL)
+ { Mem_Base[0] = Make_Non_Pointer(TC_CELL, 2);
+ Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
+ Mem_Base[2] = NIL;
+ Initial_Free = NROOTS + 1;
+ Scan = 1;
+ }
+ else
+ { Mem_Base[0] = Ext_Prim_Vector; /* Has CELL TYPE */
+ Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
+ Initial_Free = NROOTS;
+ Scan = 0;
+ }
+ Free = Initial_Free;
+ Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
+ Objects = 0;
+
+ Free_Constant = (2 * Heap_Count) + Initial_Free;
+ Scan_Constant = Free_Constant;
+ Free_Cobjects = &Mem_Base[Const_Count + Free_Constant];
+ Constant_Objects = 0;
+
+#if true
+ Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
+#else
+ /* When Constant Space finally becomes supported,
+ something like this must be done. */
+ while (true)
+ { Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
+ Do_Area(CONSTANT_CODE, Scan_Constant,
+ Free_Constant, Constant_Objects, Free_Cobjects);
+ Do_Area(PURE_CODE, Scan_Pure, Fre_Pure, Pure_Objects, Free_Pobjects);
+ if (Scan == Free) break;
+ }
+#endif
+\f
+ /* Consistency checks */
+
+ When(((Free - Initial_Free) > Heap_Count), "Free overran Heap");
+ When(((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
+ Heap_Count),
+ "Free_Objects overran Heap Object Space");
+ When(((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
+ "Free_Constant overran Constant Space");
+ When(((Free_Cobjects - &Mem_Base[Initial_Free + (2 * Heap_Count) + Const_Count]) >
+ Const_Count),
+ "Free_Cobjects overran Constant Object Space");
+\f
+ /* Output the data */
+
+ /* Header */
+
+ print_header("Portable Version", PORTABLE_VERSION, "%ld\n");
+ print_header("Flags", Make_Flags(), "%ld\n");
+ print_header("Version", FASL_FORMAT_VERSION, "%ld\n");
+ print_header("Sub Version", FASL_SUBVERSION, "%ld\n");
+ print_header("Heap Count", (Free - NROOTS), "%ld\n");
+ print_header("Heap Base", NROOTS, "%ld\n");
+ print_header("Heap Objects", Objects, "%ld\n");
+
+ /* Currently Constant and Pure not supported, but the header is ready */
+
+ print_header("Pure Count", 0, "%ld\n");
+ print_header("Pure Base", Free_Constant, "%ld\n");
+ print_header("Pure Objects", 0, "%ld\n");
+ print_header("Constant Count", 0, "%ld\n");
+ print_header("Constant Base", Free_Constant, "%ld\n");
+ print_header("Constant Objects", 0, "%ld\n");
+
+ print_header("Number of flonums", NFlonums, "%ld\n");
+ print_header("Number of integers", NIntegers, "%ld\n");
+ print_header("Number of strings", NStrings, "%ld\n");
+ print_header("Number of bits in integers", NBits, "%ld\n");
+ print_header("Number of characters in strings", NChars, "%ld\n");
+ print_header("& Dumped Object", (Get_Integer(Mem_Base[1])), "%ld\n");
+ print_header("& Ext Prim Vector", (Get_Integer(Mem_Base[0])), "%ld\n");
+\f
+ /* External Objects */
+
+ /* Heap External Objects */
+
+ Free_Objects = &Mem_Base[Initial_Free + Heap_Count];
+ for (; Objects > 0; Objects -= 1)
+ print_external_object(Free_Objects);
+
+#if false
+ /* Pure External Objects */
+
+ Free_Cobjects = &Mem_Base[Pure_Objects_Start];
+ for (; Pure_Objects > 0; Pure_Objects -= 1)
+ print_external_object(Free_Cobjects);
+
+ /* Constant External Objects */
+
+ Free_Cobjects = &Mem_Base[Constant_Objects_Start];
+ for (; Constant_Objects > 0; Constant_Objects -= 1)
+ print_external_object(Free_Cobjects);
+
+#endif
+\f
+ /* Pointer Objects */
+
+ /* Heap Objects */
+
+ Free_Cobjects = &Mem_Base[Free];
+ for (Free_Objects = &Mem_Base[NROOTS];
+ Free_Objects < Free_Cobjects;
+ Free_Objects += 1)
+ print_an_object(*Free_Objects);
+
+#if false
+ /* Pure Objects */
+
+ Free_Cobjects = &Mem_Base[Free_Pure];
+ for (Free_Objects = &Mem_Base[Pure_Start];
+ Free_Objects < Free_Cobjects;
+ Free_Objects += 1)
+ print_an_object(*Free_Objects);
+
+ /* Constant Objects */
+
+ Free_Cobjects = &Mem_Base[Free_Constant];
+ for (Free_Objects = &Mem_Base[Constant_Start];
+ Free_Objects < Free_Cobjects;
+ Free_Objects += 1)
+ print_an_object(*Free_Objects);
+#endif
+
+ return;
+}
+\f
+/* Top Level */
+
+static int Noptions = 3;
+
+static struct Option_Struct Options[] =
+ {{"Do_Not_Compact", false, &Compact_P},
+ {"Null_Out_NMVs", true, &Null_NMV},
+ {"Swap_Bytes", true, &Shuffle_Bytes}};
+
+main(argc, argv)
+int argc;
+char *argv[];
+{ Setup_Program(argc, argv, Noptions, Options);
+ return;
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: bitstr.c
+
+Bit string primitives. */
+\f
+/*
+
+Memory layout of bit strings:
+
++-------+-------+-------+-------+
+| NMV | GC size (longwords) | 0
++-------+-------+-------+-------+
+| Size in bits | 1
++-------+-------+-------+-------+
+|MSB | 2
++-------+-------+-------+-------+
+| | 3
++-------+-------+-------+-------+
+. . .
+. . .
+. . .
++-------+-------+-------+-------+
+| LSB| N
++-------+-------+-------+-------+
+
+The first data word (marked as word "2" above) is where any excess
+bits are kept.
+
+The "size in bits" is a C "long" integer.
+
+Conversions between nonnegative integers and bit strings are
+implemented here; they use the standard binary encoding, in which
+each index selects the bit corresponding to that power of 2. Thus
+bit 0 is the LSB.
+
+*/
+
+#include "scheme.h"
+#include "primitive.h"
+#include "bignum.h"
+
+#define bits_to_pointers( bits) \
+(((bits) + (POINTER_LENGTH - 1)) / POINTER_LENGTH)
+
+#define bit_string_length( bit_string) \
+(Fast_Vector_Ref( bit_string, NM_ENTRY_COUNT))
+
+#define bit_string_start_ptr( bit_string) \
+(Nth_Vector_Loc( bit_string, NM_DATA))
+
+#define bit_string_end_ptr( bit_string) \
+(Nth_Vector_Loc( bit_string, (Vector_Length( bit_string) + 1)))
+
+#define any_mask( nbits, offset) (low_mask( nbits) << (offset))
+#define low_mask( nbits) ((1 << (nbits)) - 1)
+\f
+Pointer
+allocate_bit_string( length)
+ long length;
+{
+ long total_pointers;
+ Pointer result;
+
+ total_pointers = (NM_HEADER_LENGTH + bits_to_pointers( length));
+ Primitive_GC_If_Needed( total_pointers);
+ Free[NM_VECTOR_HEADER] =
+ Make_Non_Pointer( TC_MANIFEST_NM_VECTOR, (total_pointers - 1));
+ Free[NM_ENTRY_COUNT] = length;
+ result = Make_Pointer( TC_BIT_STRING, Free);
+ Free += total_pointers;
+ return result;
+}
+
+/* (BIT-STRING-ALLOCATE length)
+ [Primitive number 0xD1]
+ Returns an uninitialized bit string of the given length. */
+
+Built_In_Primitive( Prim_bit_string_allocate, 1, "BIT-STRING-ALLOCATE")
+{
+ Primitive_1_Arg();
+
+ Arg_1_Type( TC_FIXNUM);
+ return allocate_bit_string( Get_Integer( Arg1));
+}
+
+/* (BIT-STRING? object)
+ [Primitive number 0xD3]
+ Returns true iff object is a bit string. */
+
+Built_In_Primitive( Prim_bit_string_p, 1, "BIT-STRING?")
+{
+ Primitive_1_Arg();
+
+ Touch_In_Primitive( Arg1, Arg1);
+ return ((Type_Code( Arg1) == TC_BIT_STRING) ? TRUTH : NIL);
+}
+\f
+void
+fill_bit_string( bit_string, sense)
+ Pointer bit_string;
+ Boolean sense;
+{
+ Pointer *scanner;
+ Pointer filler;
+ long i;
+
+ filler = ((Pointer) (sense ? -1 : 0));
+ scanner = bit_string_start_ptr( bit_string);
+ for (i = bits_to_pointers( bit_string_length( bit_string));
+ (i > 0); i -= 1)
+ *scanner++ = filler;
+}
+
+void
+clear_bit_string( bit_string)
+ Pointer bit_string;
+{
+ Pointer *scanner;
+ long i;
+
+ scanner = bit_string_start_ptr( bit_string);
+ for (i = bits_to_pointers( bit_string_length( bit_string));
+ (i > 0); i -= 1)
+ *scanner++ = 0;
+}
+\f
+/* (MAKE-BIT-STRING size initialization)
+ [Primitive number 0xD2]
+ Returns a bit string of the specified size with all the bits
+ set to zero if the initialization is false, one otherwise. */
+
+Built_In_Primitive( Prim_make_bit_string, 2, "MAKE-BIT-STRING")
+{
+ Pointer result;
+ Primitive_2_Args();
+
+ Arg_1_Type( TC_FIXNUM);
+ result = allocate_bit_string( Get_Integer( Arg1));
+ fill_bit_string( result, (Arg2 != NIL));
+ return result;
+}
+
+/* (BIT-STRING-FILL! bit-string initialization)
+ [Primitive number 0x197]
+ Fills the bit string with zeros if the initialization is false,
+ otherwise fills it with ones. */
+
+Built_In_Primitive( Prim_bit_string_fill_x, 2, "BIT-STRING-FILL!")
+{
+ Primitive_2_Args();
+
+ Arg_1_Type( TC_BIT_STRING);
+ fill_bit_string( Arg1, (Arg2 != NIL));
+ return NIL;
+}
+
+/* (BIT-STRING-LENGTH bit-string)
+ [Primitive number 0xD4]
+ Returns the number of bits in BIT-STRING. */
+
+Built_In_Primitive(Prim_bit_string_length, 1, "BIT-STRING-LENGTH")
+{
+ Primitive_1_Arg();
+
+ Arg_1_Type( TC_BIT_STRING);
+ return Make_Non_Pointer( TC_FIXNUM, bit_string_length( Arg1));
+}
+\f
+/* The computation of the variable `word' is especially clever. To
+ understand it, note that the index of the last pointer of a vector is
+ also the GC length of the vector, so that all we need do is subtract
+ the zero-based word index from the GC length. */
+
+#define index_check( To_Where, P, Low, High, Error) \
+{ \
+ To_Where = Get_Integer( P); \
+ if ((To_Where < (Low)) || (To_Where >= (High))) \
+ Primitive_Error( Error) \
+}
+
+#define index_to_word( bit_string, index) \
+(Vector_Length( bit_string) - (index / POINTER_LENGTH))
+
+#define ref_initialization() \
+long index, word, mask; \
+Primitive_2_Args(); \
+ \
+Arg_1_Type( TC_BIT_STRING); \
+Arg_2_Type( TC_FIXNUM); \
+index_check( index, Arg2, 0, bit_string_length( Arg1), \
+ ERR_ARG_2_BAD_RANGE); \
+ \
+word = index_to_word( Arg1, index); \
+mask = (1 << (index % POINTER_LENGTH));
+\f
+/* (BIT-STRING-REF bit-string index)
+ [Primitive number 0xD5]
+ Returns the boolean value of the indexed bit. */
+
+Built_In_Primitive( Prim_bit_string_ref, 2, "BIT-STRING-REF")
+{
+ ref_initialization();
+
+ if ((Fast_Vector_Ref( Arg1, word) & mask) == 0)
+ return NIL;
+ else
+ return TRUTH;
+}
+
+/* (BIT-STRING-CLEAR! bit-string index)
+ [Primitive number 0xD8]
+ Sets the indexed bit to zero, returning its previous value
+ as a boolean. */
+
+Built_In_Primitive( Prim_bit_string_clear_x, 2, "BIT-STRING-CLEAR!")
+{
+ ref_initialization();
+
+ if ((Fast_Vector_Ref( Arg1, word) & mask) == 0)
+ return NIL;
+ else
+ {
+ Fast_Vector_Ref( Arg1, word) &= ~mask;
+ return TRUTH;
+ }
+}
+
+/* (BIT-STRING-SET! bit-string index)
+ [Primitive number 0xD7]
+ Sets the indexed bit to one, returning its previous value
+ as a boolean. */
+
+Built_In_Primitive( Prim_bit_string_set_x, 2, "BIT-STRING-SET!")
+{
+ ref_initialization();
+
+ if ((Fast_Vector_Ref( Arg1, word) & mask) == 0)
+ {
+ Fast_Vector_Ref( Arg1, word) |= mask;
+ return NIL;
+ }
+ else
+ return TRUTH;
+}
+\f
+#define zero_section_p( start) \
+{ \
+ long i; \
+ Pointer *scan; \
+ \
+ scan = Nth_Vector_Loc( Arg1, (start)); \
+ for (i = (length / POINTER_LENGTH); (i > 0); i -= 1) \
+ if (*scan++ != 0) \
+ return NIL; \
+ return TRUTH; \
+}
+
+/* (BIT-STRING-ZERO? bit-string)
+ [Primitive number 0xD9]
+ Returns true the argument has no "set" bits. */
+
+Built_In_Primitive( Prim_bit_string_zero_p, 2, "BIT-STRING-ZERO?")
+{
+ long length, odd_bits;
+ Primitive_1_Args();
+
+ Arg_1_Type(TC_BIT_STRING);
+
+ length = bit_string_length( Arg1);
+ odd_bits = (length % POINTER_LENGTH);
+ if (odd_bits == 0)
+ zero_section_p( NM_DATA)
+ else if ((Fast_Vector_Ref( Arg1, NM_DATA) & low_mask( odd_bits)) != 0)
+ return NIL;
+ else
+ zero_section_p( NM_DATA + 1)
+}
+\f
+#define equal_sections_p( start) \
+{ \
+ long i; \
+ Pointer *scan1, *scan2; \
+ \
+ scan1 = Nth_Vector_Loc( Arg1, (start)); \
+ scan2 = Nth_Vector_Loc( Arg2, (start)); \
+ for (i = (length / POINTER_LENGTH); (i > 0); i -= 1) \
+ if (*scan1++ != *scan2++) \
+ return NIL; \
+ return TRUTH; \
+}
+
+/* (BIT-STRING=? bit-string-1 bit-string-2)
+ [Primitive number 0x19D]
+ Returns true iff the two bit strings contain the same bits. */
+
+Built_In_Primitive( Prim_bit_string_equal_p, 2, "BIT-STRING=?")
+{
+ long length;
+ Primitive_2_Args();
+
+ Arg_1_Type(TC_BIT_STRING);
+ Arg_2_Type(TC_BIT_STRING);
+
+ length = bit_string_length( Arg1);
+ if (length != bit_string_length( Arg2))
+ return NIL;
+ else
+ {
+ long odd_bits;
+
+ odd_bits = (length % POINTER_LENGTH);
+ if (odd_bits == 0)
+ equal_sections_p( NM_DATA)
+ else
+ {
+ long mask;
+
+ mask = low_mask( odd_bits);
+ if ((Fast_Vector_Ref( Arg1, NM_DATA) & mask)
+ != (Fast_Vector_Ref( Arg2, NM_DATA) & mask))
+ return NIL;
+ else
+ equal_sections_p( NM_DATA + 1)
+ }
+ }
+}
+\f
+#define bitwise_op( action) \
+{ \
+ Primitive_2_Args(); \
+ \
+ if (bit_string_length( Arg1) != bit_string_length( Arg2)) \
+ Primitive_Error( ERR_ARG_1_BAD_RANGE) \
+ else \
+ { \
+ long i; \
+ Pointer *scan1, *scan2; \
+ \
+ scan1 = bit_string_start_ptr( Arg1); \
+ scan2 = bit_string_start_ptr( Arg2); \
+ for (i = (Vector_Length( Arg1) - 1); (i > 0); i -= 1) \
+ *scan1++ action() (*scan2++); \
+ } \
+ return (NIL); \
+}
+
+#define bit_string_move_x_action() =
+#define bit_string_movec_x_action() = ~
+#define bit_string_or_x_action() |=
+#define bit_string_and_x_action() &=
+#define bit_string_andc_x_action() &= ~
+
+Built_In_Primitive( Prim_bit_string_move_x, 2, "BIT-STRING-MOVE!")
+ bitwise_op( bit_string_move_x_action)
+
+Built_In_Primitive( Prim_bit_string_movec_x, 2, "BIT-STRING-MOVEC!")
+ bitwise_op( bit_string_movec_x_action)
+
+Built_In_Primitive( Prim_bit_string_or_x, 2, "BIT-STRING-OR!")
+ bitwise_op( bit_string_or_x_action)
+
+Built_In_Primitive( Prim_bit_string_and_x, 2, "BIT-STRING-AND!")
+ bitwise_op( bit_string_and_x_action)
+
+Built_In_Primitive( Prim_bit_string_andc_x, 2, "BIT-STRING-ANDC!")
+ bitwise_op( bit_string_andc_x_action)
+\f
+/* (BIT-SUBSTRING-MOVE-RIGHT! source start1 end1 destination start2)
+ [Primitive number 0xD6]
+ Destructively copies the substring of SOURCE between START1 and
+ END1 into DESTINATION at START2. The copying is done from the
+ MSB to the LSB (which only matters when SOURCE and DESTINATION
+ are the same). */
+
+Built_In_Primitive( Prim_bit_substring_move_right_x, 5,
+ "BIT-SUBSTRING-MOVE-RIGHT!")
+{
+ long start1, end1, start2, end2, nbits;
+ long end1_mod, end2_mod;
+ void copy_bits();
+ Primitive_5_Args();
+
+ Arg_1_Type( TC_BIT_STRING);
+ Arg_2_Type( TC_FIXNUM);
+ Arg_3_Type( TC_FIXNUM);
+ Arg_4_Type( TC_BIT_STRING);
+ Arg_5_Type( TC_FIXNUM);
+
+ start1 = Get_Integer( Arg2);
+ end1 = Get_Integer( Arg3);
+ start2 = Get_Integer( Arg5);
+ nbits = (end1 - start1);
+ end2 = (start2 + nbits);
+
+ if ((start1 < 0) || (start1 > end1))
+ Primitive_Error( ERR_ARG_2_BAD_RANGE);
+ if (end1 > bit_string_length( Arg1))
+ Primitive_Error( ERR_ARG_3_BAD_RANGE);
+ if ((start2 < 0) || (end2 > bit_string_length( Arg4)))
+ Primitive_Error( ERR_ARG_5_BAD_RANGE);
+
+ end1_mod = (end1 % POINTER_LENGTH);
+ end2_mod = (end2 % POINTER_LENGTH);
+
+ /* Using `index_to_word' here with -1 offset will work in every
+ case except when the `end' is 0. In this case the result of
+ the expression `(-1 / POINTER_LENGTH)' is either 0 or -1, at
+ the discretion of the C compiler being used. This doesn't
+ matter because if `end' is zero, then no bits will be moved. */
+
+ copy_bits( Nth_Vector_Loc( Arg1, index_to_word( Arg1, (end1 - 1))),
+ ((end1_mod == 0) ? 0 : (POINTER_LENGTH - end1_mod)),
+ Nth_Vector_Loc( Arg4, index_to_word( Arg4, (end2 - 1))),
+ ((end2_mod == 0) ? 0 : (POINTER_LENGTH - end2_mod)),
+ nbits);
+ return (NIL);
+}
+\f
+#define masked_transfer( source, destination, nbits, offset) \
+{ \
+ long mask; \
+ \
+ mask = any_mask( nbits, offset); \
+ *destination = ((*source & mask) | (*destination & ~mask)); \
+}
+
+/* This procedure copies bits from one place to another.
+ The offsets are measured from the MSB of the first Pointer of
+ each of the arguments SOURCE and DESTINATION. It copies the bits
+ starting with the MSB of a bit string and moving down. */
+
+void
+copy_bits( source, source_offset, destination, destination_offset, nbits)
+ Pointer *source, *destination;
+ long source_offset, destination_offset, nbits;
+{
+
+ /* This common case can be done very quickly, by splitting the
+ bit string into three parts. Since the source and destination are
+ aligned relative to one another, the main body of bits can be
+ transferred as Pointers, and only the `head' and `tail' need be
+ treated specially. */
+
+ if (source_offset == destination_offset)
+ {
+ if (source_offset != 0)
+ {
+ long head;
+
+ head = (POINTER_LENGTH - source_offset);
+ if (nbits <= head)
+ {
+ masked_transfer( source, destination, nbits, (head - nbits));
+ nbits = 0;
+ }
+ else
+ {
+ long mask;
+
+ mask = low_mask( head);
+ *destination++ = ((*source++ & mask) | (*destination & ~mask));
+ nbits -= head;
+ }
+ }
+ if (nbits > 0)
+ {
+ long nwords, tail;
+
+ for (nwords = (nbits / POINTER_LENGTH); (nwords > 0); nwords -= 1)
+ *destination++ = *source++;
+
+ tail = (nbits % POINTER_LENGTH);
+ if (tail > 0)
+ masked_transfer( source, destination, tail,
+ (POINTER_LENGTH - tail));
+ }
+ }
+\f
+ else if (source_offset < destination_offset)
+ {
+ long offset1, offset2, head;
+
+ offset1 = (destination_offset - source_offset);
+ offset2 = (POINTER_LENGTH - offset1);
+ head = (POINTER_LENGTH - destination_offset);
+
+ if (nbits <= head)
+ {
+ long mask;
+
+ mask = any_mask( nbits, (head - nbits));
+ *destination =
+ (((*source >> offset1) & mask) | (*destination & ~mask));
+ }
+ else
+ {
+ long mask1, mask2;
+
+ {
+ long mask;
+
+ mask = low_mask( head);
+ *destination++ =
+ (((*source >> offset1) & mask) | (*destination & ~mask));
+ }
+ nbits -= head;
+ mask1 = low_mask( offset1);
+ mask2 = low_mask( offset2);
+ {
+ long nwords, i;
+
+ for (nwords = (nbits / POINTER_LENGTH); (nwords > 0); nwords -= 1)
+ {
+ i = ((*source++ & mask1) << offset2);
+ *destination++ = (((*source >> offset1) & mask2) | i);
+ }
+ }
+\f
+ {
+ long tail, dest_tail;
+
+ tail = (nbits % POINTER_LENGTH);
+ dest_tail = (*destination & low_mask( POINTER_LENGTH - tail));
+ if (tail <= offset1)
+ *destination =
+ (((*source & any_mask( tail, (offset1 - tail))) << offset2)
+ | dest_tail);
+ else
+ {
+ long i, j;
+
+ i = ((*source++ & mask1) << offset2);
+ j = (tail - offset1);
+ *destination =
+ (((*source & any_mask( j, (POINTER_LENGTH - j))) >> offset1)
+ | i | dest_tail);
+ }
+ }
+ }
+ }
+\f
+ else /* if (source_offset > destination_offset) */
+ {
+ long offset1, offset2, head;
+
+ offset1 = (source_offset - destination_offset);
+ offset2 = (POINTER_LENGTH - offset1);
+ head = (POINTER_LENGTH - source_offset);
+
+ if (nbits <= head)
+ {
+ long mask;
+
+ mask = any_mask( nbits, (offset1 + (head - nbits)));
+ *destination =
+ (((*source << offset1) & mask) | (*destination & ~mask));
+ }
+ else
+ {
+ long dest_buffer, mask1, mask2;
+
+ {
+ long mask;
+
+ mask = any_mask( head, offset1);
+ dest_buffer =
+ ((*destination & ~mask)
+ | ((*source++ << offset1) & mask));
+ }
+ nbits -= head;
+ mask1 = low_mask( offset1);
+ mask2 = any_mask( offset2, offset1);
+ {
+ long nwords;
+
+ nwords = (nbits / POINTER_LENGTH);
+ if (nwords > 0)
+ dest_buffer &= mask2;
+ for (; (nwords > 0); nwords -= 1)
+ {
+ *destination++ =
+ (dest_buffer | ((*source >> offset2) & mask1));
+ dest_buffer = (*source++ << offset1);
+ }
+ }
+\f
+ {
+ long tail;
+
+ tail = (nbits % POINTER_LENGTH);
+ if (tail <= offset1)
+ *destination =
+ (dest_buffer
+ | (*destination & low_mask( offset1 - tail))
+ | ((*source >> offset2) & any_mask( tail, (offset1 - tail))));
+ else
+ {
+ long mask;
+
+ *destination++ =
+ (dest_buffer | ((*source >> offset2) & mask1));
+ mask = low_mask( POINTER_LENGTH - tail);
+ *destination =
+ ((*destination & ~mask) | ((*source << offset1) & mask));
+ }
+ }
+ }
+ }
+}
+\f
+/* Integer <-> Bit-string Conversions */
+
+long
+count_significant_bits( number, start)
+ long number, start;
+{
+ long significant_bits, i;
+
+ significant_bits = start;
+ for (i = (1 << (start - 1)); (i >= 0); i >>= 1)
+ {
+ if (number >= i)
+ break;
+ significant_bits -= 1;
+ }
+ return significant_bits;
+}
+
+long
+long_significant_bits( number)
+ long number;
+{
+ if (number < 0)
+ return ULONG_SIZE;
+ else
+ return count_significant_bits( number, (ULONG_SIZE - 1));
+}
+
+Pointer
+zero_to_bit_string( length)
+ long length;
+{
+ Pointer result;
+
+ result = allocate_bit_string( length);
+ clear_bit_string( result);
+ return result;
+}
+
+Pointer
+long_to_bit_string( length, number)
+ long length, number;
+{
+ if (number < 0)
+ Primitive_Error( ERR_ARG_2_BAD_RANGE)
+ else if (number == 0)
+ zero_to_bit_string( length);
+ else
+ {
+ if (length < long_significant_bits( number))
+ Primitive_Error( ERR_ARG_2_BAD_RANGE)
+ else
+ {
+ Pointer result;
+
+ result = allocate_bit_string( length);
+ clear_bit_string( result);
+ Fast_Vector_Set( result, Vector_Length( result), number);
+ return result;
+ }
+ }
+}
+\f
+Pointer
+bignum_to_bit_string( length, bignum)
+ long length;
+ Pointer bignum;
+{
+ bigdigit *bigptr;
+ long ndigits;
+
+ bigptr = BIGNUM( Get_Pointer( bignum));
+ if (NEG_BIGNUM( bigptr))
+ Primitive_Error( ERR_ARG_2_BAD_RANGE);
+ ndigits = LEN( bigptr);
+ if (ndigits == 0)
+ zero_to_bit_string( length);
+ else
+ {
+ if (length <
+ (count_significant_bits( *(Bignum_Top( bigptr)), SHIFT)
+ + (SHIFT * (ndigits - 1))))
+ Primitive_Error( ERR_ARG_2_BAD_RANGE)
+ else
+ {
+ Pointer result;
+ bigdigit *scan1, *scan2;
+
+ result = allocate_bit_string( length);
+ scan1 = Bignum_Bottom( bigptr);
+ scan2 = ((bigdigit *) bit_string_end_ptr( result));
+ for (; (ndigits > 0); ndigits -= 1)
+ *--scan2 = *scan1++;
+ return result;
+ }
+ }
+}
+\f
+/* (UNSIGNED-INTEGER->BIT-STRING length integer)
+ [Primitive number 0xDC]
+ INTEGER, which must be a non-negative integer, is converted to
+ a bit-string of length LENGTH. If INTEGER is too large, an
+ error is signalled. */
+
+Built_In_Primitive( Prim_unsigned_integer_to_bit_string, 2,
+ "UNSIGNED-INTEGER->BIT-STRING")
+{
+ long length;
+ Primitive_2_Args();
+
+ Arg_1_Type( TC_FIXNUM);
+ length = Get_Integer( Arg1);
+ if (length < 0)
+ Primitive_Error( ERR_ARG_1_BAD_RANGE)
+ else if (Type_Code( Arg2) == TC_FIXNUM)
+ return long_to_bit_string( length, Get_Integer( Arg2));
+ else if (Type_Code( Arg2) == TC_BIG_FIXNUM)
+ return bignum_to_bit_string( length, Arg2);
+ else
+ Primitive_Error( ERR_ARG_2_WRONG_TYPE)
+}
+\f
+/* (BIT-STRING->UNSIGNED-INTEGER bit-string)
+ [Primitive number 0xDD]
+ BIT-STRING is converted to the appropriate non-negative integer.
+ This operation is the inverse of `integer->bit-string'. */
+
+Built_In_Primitive( Prim_bit_string_to_unsigned_integer, 1,
+ "BIT-STRING->UNSIGNED-INTEGER")
+{
+ Pointer *scan;
+ long nwords, nbits, ndigits, align_ndigits, word;
+ bigdigit *bignum, *scan1, *scan2;
+
+ Primitive_1_Arg();
+
+ Arg_1_Type( TC_BIT_STRING);
+
+ /* Count the number of significant bits.*/
+ scan = bit_string_start_ptr( Arg1);
+ nbits = (bit_string_length( Arg1) % POINTER_LENGTH);
+ word = ((nbits > 0) ? (*scan++ & low_mask( nbits)) : *scan++);
+ for (nwords = (Vector_Length( Arg1) - 1); (nwords > 0); nwords -= 1)
+ {
+ if (word != 0)
+ break;
+ else
+ word = *scan++;
+ }
+ if (nwords == 0)
+ return FIXNUM_0;
+ nbits = (((nwords - 1) * POINTER_LENGTH) + long_significant_bits( word));
+
+ /* Handle fixnum case. */
+ if (nbits < FIXNUM_LENGTH)
+ return (Make_Unsigned_Fixnum( word));
+
+ /* Now the interesting one, we must make a bignum. */
+ ndigits = ((nbits + (SHIFT - 1)) / SHIFT);
+ align_ndigits = Align( ndigits);
+ Primitive_GC_If_Needed( align_ndigits);
+ bignum = BIGNUM( Free);
+ Free += align_ndigits;
+ Prepare_Header( bignum, ndigits, POSITIVE);
+
+ scan1 = ((bigdigit *) bit_string_end_ptr( Arg1));
+ scan2 = Bignum_Bottom( bignum);
+ for (; (ndigits > 0); ndigits -= 1)
+ *scan2++ = *--scan1;
+ nbits = (nbits % SHIFT);
+ if (nbits != 0)
+ *scan2 = (*--scan2 & low_mask( nbits));
+
+ return Make_Pointer( TC_BIG_FIXNUM, bignum);
+}
+\f
+/* These primitives should test the type of their first argument to
+ verify that it is a pointer. */
+
+/* (READ-BITS! pointer offset bit-string)
+ [Primitive number 0xDF]
+ Read the contents of memory at the address (POINTER,OFFSET)
+ into BIT-STRING. */
+
+Built_In_Primitive( Prim_read_bits_x, 3, "READ-BITS!")
+{
+ long end, end_mod;
+ Primitive_3_Args();
+
+ Arg_2_Type( TC_FIXNUM);
+ Arg_3_Type( TC_BIT_STRING);
+ end = bit_string_length( Arg3);
+ end_mod = (end % POINTER_LENGTH);
+ copy_bits( Nth_Vector_Loc( Arg1, 0), Get_Integer( Arg2),
+ Nth_Vector_Loc( Arg3, index_to_word( Arg3, (end - 1))),
+ ((end_mod == 0) ? 0 : (POINTER_LENGTH - end_mod)),
+ end);
+ return (NIL);
+}
+
+/* (WRITE-BITS! pointer offset bit-string)
+ [Primitive number 0xE0]
+ Write the contents of BIT-STRING in memory at the address
+ (POINTER,OFFSET). */
+
+Built_In_Primitive( Prim_write_bits_x, 3, "WRITE-BITS!")
+{
+ long end, end_mod;
+ Primitive_3_Args();
+
+ Arg_2_Type( TC_FIXNUM);
+ Arg_3_Type( TC_BIT_STRING);
+ end = bit_string_length( Arg3);
+ end_mod = (end % POINTER_LENGTH);
+ copy_bits( Nth_Vector_Loc( Arg3, index_to_word( Arg3, (end - 1))),
+ ((end_mod == 0) ? 0 : (POINTER_LENGTH - end_mod)),
+ Nth_Vector_Loc( Arg1, 0), Get_Integer( Arg2),
+ end);
+ return (NIL);
+}
--- /dev/null
+/* Emacs -*-C-*-an't tell the language */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: BKPT.C
+ *
+ * This file contains breakpoint utilities.
+ * Disabled when not debugging the interpreter.
+ *
+ */
+\f
+#include "scheme.h"
+
+#ifndef ENABLE_DEBUGGING_TOOLS
+#include "Error: Not debugging but bkpt.c included"
+#endif
+
+sp_record_list SP_List = sp_nil;
+
+extern Boolean Add_a_Pop_Return_Breakpoint();
+
+static struct sp_record One_Before =
+{ ((Pointer *) 0),
+ sp_nil
+};
+
+Boolean Add_a_Pop_Return_Breakpoint(SP)
+Pointer *SP;
+{ sp_record_list old = SP_List;
+ SP_List = ((sp_record_list) malloc(sizeof(struct sp_record)));
+ if (SP_List == sp_nil)
+ { fprintf(stderr, "Could not allocate a breakpoint structure\n");
+ SP_List = old;
+ return false;
+ }
+ SP_List->sp = SP;
+ SP_List->next = old;
+ One_Before.next = SP_List;
+ return true;
+}
+
+/* This uses register rather than fast because it is invoked
+ * very often and would make things too slow.
+ */
+
+void Pop_Return_Break_Point()
+{ register Pointer *SP = Stack_Pointer;
+ register sp_record_list previous = &One_Before;
+ register sp_record_list this = previous->next; /* = SP_List */
+ for ( ;
+ this != sp_nil;
+ previous = this, this = this->next)
+ if (this->sp == SP)
+ { Handle_Pop_Return_Break();
+ previous->next = this->next;
+ break;
+ }
+ SP_List = One_Before.next;
+ return;
+}
+
+/* A breakpoint can be placed here from a C debugger to examine
+ the state of the world. */
+
+extern Boolean Print_One_Continuation_Frame();
+
+Handle_Pop_Return_Break()
+{ Boolean ignore;
+ Pointer *Old_Stack = Stack_Pointer;
+
+ printf("Pop Return Break: SP = 0x%x\n", Stack_Pointer);
+ ignore = Print_One_Continuation_Frame();
+ Stack_Pointer = Old_Stack;
+ return;
+}
--- /dev/null
+/* Emacs -*-C-*-an't tell the language */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: BKPT.H
+ *
+ * This file contains breakpoint utilities.
+ * Disabled when not debugging the interpreter.
+ *
+ */
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+\f
+struct sp_record
+{ Pointer *sp;
+ struct sp_record *next;
+};
+typedef struct sp_record *sp_record_list;
+
+#define sp_nil ((sp_record_list) NULL)
+#define debug_maxslots 64
+
+#define Eval_Ucode_Hook() \
+ local_circle[local_slotno++] = Fetch_Expression(); \
+ if (local_slotno >= debug_maxslots) local_slotno = 0; \
+ if (local_nslots < debug_maxslots) local_nslots++
+
+#ifdef Using_Registers
+#define Pop_Return_Ucode_Hook() \
+if (SP_List != sp_nil) \
+{ Export_Registers(); \
+ Pop_Return_Break_Point(); \
+ Import_Registers(); \
+}
+#else
+#define Pop_Return_Ucode_Hook() \
+if (SP_List != sp_nil) \
+ Pop_Return_Break_Point();
+#endif
+\f
+/* For performance metering we note the time spent handling each
+ * primitive. This MIGHT help us figure out where all the time
+ * goes. It should make the time zone kludge obselete someday.
+ */
+
+#if false
+/* This code disabled by SAS 6/24/86 */
+struct
+{ int nprims;
+ int primtime[1];
+} perfinfo_data;
+
+void Clear_Perfinfo_Data()
+{ int i;
+ perfinfo_data.nprims = MAX_PRIMITIVE_NUMBER+1;
+ for (i=0; i <= MAX_PRIMITIVE_NUMBER; i++) perfinfo_data.primtime[i]=0;
+}
+
+#define Metering_Apply_Primitive(Loc, N) \
+{ long Start_Time = Sys_Clock(); \
+ Loc = Apply_Primitive(N) \
+ perfinfo_data.primtime[N] += Sys_Clock() - Start_Time; \
+} \
+Set_Time_Zone(Zone_Working)
+#endif
+
+/* Not implemented yet */
+#define Apply_Ucode_Hook()
+#endif /* ifdef ENABLE_DEBUGGING_TOOLS */
+
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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: boot.c
+ *
+ * This file contains the code to support startup of
+ * the SCHEME interpreter.
+
+ The command line (when not running a dumped executable version) may
+ take the following forms:
+
+ scheme
+
+ or
+
+ scheme {band-name}
+
+ or
+
+ scheme {filespec}
+ {-heap heap-size}
+ {-stack stack-size}
+ {-constant constant-size}
+ {other arguments ignored by the core microcode}
+
+ with filespec either {-band band-name} or {{-}fasl file-name}
+ arguments are optional, numbers are in 1K units. Default values
+ are given above. The arguments in the long for may appear in any
+ order on the command line. The allocation arguments (heap, stack,
+ and constant) are ignored when scheme is an executable image. A
+ warning message is printed if the command line contains them.
+
+ heap-size......number of cells to allocate for user heap; this will
+ be doubled to allow for 2 space GC.
+ stack-size.....number of cells for control stack. This primarily
+ controls maximum depth of recursion. If the flag
+ USE_STACKLETS is defined, then this controls the
+ size of the stacklets (not the total stack) and
+ thus affects how often new stack segments must
+ be allocated.
+ constant-size..number of cells for constant and pure space in the
+ system.
+
+Additional arguments may exist for particular machines; see CONFIG.H
+for details. They are created by defining a macro Command_Line_Args.
+
+*/
+\f
+#include "scheme.h"
+#include "primitive.h"
+#include "prims.h"
+#include "version.h"
+#ifndef islower
+#include <ctype.h>
+#endif
+
+#define STRING_SIZE 512
+#define BLOCKSIZE 1024
+#define blocks(n) ((n)*BLOCKSIZE)
+\f
+/* Utilities for command line parsing */
+
+#define upcase(c) ((islower(c)) ? (toupper(c)) : c)
+
+void
+uppercase(to_where, from_where)
+fast char *to_where, *from_where;
+{ fast char c;
+ while((c = *from_where++) != '\0') *to_where++ = upcase(c);
+ *to_where = '\0';
+ return;
+}
+
+int
+Parse_Option(opt_key, nargs, args, casep)
+char *opt_key, **args;
+Boolean casep;
+int nargs;
+{ int i;
+ char key[STRING_SIZE], current[STRING_SIZE];
+ if (casep) uppercase(key, opt_key); else strcpy(key, opt_key);
+ for(i = 0; i < nargs; i++)
+ { if (casep) uppercase(current, args[i]); else strcpy(current, args[i]);
+ if (strcmp(key, current) == 0) return i;
+ }
+ return NOT_THERE;
+}
+
+long
+Def_Number(key, nargs, args, def)
+char *key, **args;
+long def;
+int nargs;
+{ int position = Parse_Option(key, nargs, args, true);
+ if ((position == NOT_THERE) || (position == (nargs-1))) return def;
+ else return atoi(args[position+1]);
+}
+\f
+/* Obviously, the main program */
+
+/* Used to test whether it is a dumped executable version */
+
+extern Boolean Was_Scheme_Dumped;
+Boolean Was_Scheme_Dumped = false;
+
+/* Exit is done in a different way on some operating systems (eg. VMS) */
+Exit_Scheme_Declarations;
+
+/* Main program */
+
+forward void Clear_Mem(), Start_Scheme(), Setup_Memory();
+
+void
+main(argc, argv)
+ int argc;
+ char **argv;
+{ Boolean FASL_It = false;
+ char *File_Name = NULL;
+ int Saved_Heap_Size, Saved_Stack_Size, Saved_Constant_Size;
+ extern void compiler_initialize();
+
+ Saved_argc = argc;
+ Saved_argv = argv;
+
+ Init_Exit_Scheme();
+
+ if (argc > 2)
+ { int position;
+ if (((position = Parse_Option("-band", argc, argv, true))
+ != NOT_THERE) &&
+ (position != (argc-1)))
+ File_Name = argv[position+1];
+ else if ((((position = Parse_Option("-fasl", argc, argv, true))
+ != NOT_THERE) ||
+ ((position = Parse_Option("fasl", argc, argv, true))
+ != NOT_THERE)) &&
+ (position != (argc-1)))
+ { File_Name = argv[position + 1];
+ FASL_It = true;
+ }
+ }
+ else if ((argc == 2) && (argv[1][0] != '-')) File_Name = argv[1];
+
+ if (!Was_Scheme_Dumped)
+ { Heap_Size = HEAP_SIZE;
+ Stack_Size = STACK_SIZE;
+ Constant_Size = CONSTANT_SIZE;
+ }
+ else
+ { Saved_Heap_Size = Heap_Size;
+ Saved_Stack_Size = Stack_Size;
+ Saved_Constant_Size = Constant_Size;
+ }
+
+ Heap_Size = Def_Number("-heap", argc, argv, Heap_Size);
+ Stack_Size = Def_Number("-stack", argc, argv, Stack_Size);
+ Constant_Size = Def_Number("-constant", argc, argv, Constant_Size);
+
+ if (Was_Scheme_Dumped)
+ { Boolean warned = false;
+ printf("Executable Scheme");
+ if ((Heap_Size != Saved_Heap_Size) ||
+ (Stack_Size != Saved_Stack_Size) ||
+ (Constant_Size != Saved_Constant_Size))
+ { printf(".\n");
+ fprintf(stderr,
+"Warning: Allocation parameters (heap, stack, and constant) ignored.\n");
+ Heap_Size = Saved_Heap_Size;
+ Stack_Size = Saved_Stack_Size;
+ Constant_Size = Saved_Constant_Size;
+ warned = true;
+ }
+ if (File_Name == NULL)
+ { if (!warned) printf("; ");
+ printf("Microcode Version %d.%d\n", VERSION, SUBVERSION);
+ OS_Init(true);
+ Enter_Interpreter();
+ }
+ else
+ { if (!warned) printf(".\n");
+ Clear_Mem(blocks(Heap_Size), blocks(Stack_Size),
+ blocks(Constant_Size));
+ /* We are reloading from scratch anyway. */
+ Was_Scheme_Dumped = false;
+ Start_Scheme(FASL_It ? PC_FASLOAD : PC_BAND_LOAD, File_Name);
+ }
+ }
+ if (File_Name == NULL) File_Name = DEFAULT_BAND_NAME;
+ Command_Line_Hook();
+
+/* main continues on the next page */
+\f
+/* main, continued */
+
+ Setup_Memory(blocks(Heap_Size), blocks(Stack_Size),
+ blocks(Constant_Size));
+ compiler_initialize((long) FASL_It);
+ Start_Scheme(FASL_It ? PC_FASLOAD : PC_BAND_LOAD, File_Name);
+}
+\f
+/* Memory Allocation, sequential processor:
+
+ ------------------------------------------
+ | Control Stack || |
+ | \/ |
+ ------------------------------------------
+ | Constant + Pure Space /\ |
+ | || |
+ ------------------------------------------
+ | |
+ | Heap Space |
+ ------------------------------------------
+
+ Each area has a pointer to its starting address and a pointer to the
+ next free cell. In addition, there is a pointer to the top of the
+ useable area of the heap (the heap is subdivided into two areas for
+ the purposes of GC, and this pointer indicates the top of the half
+ currently in use).
+
+*/
+\f
+/* Initialize free pointers within areas. Stack_Pointer is
+ special: it always points to a cell which is in use. */
+
+void
+Clear_Mem(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
+int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
+{ Heap_Top = Heap_Bottom + Our_Heap_Size;
+ Local_Heap_Base = Heap_Bottom;
+ Unused_Heap_Top = Heap_Bottom + 2*Our_Heap_Size;
+ Set_Mem_Top(Heap_Top - GC_Reserve);
+ Free = Heap_Bottom;
+ Free_Constant = Constant_Space;
+ Set_Pure_Top();
+ Initialize_Stack();
+ return;
+}
+\f
+/* Some machines may allocate and setup differently, thus
+ they can define Setup_Memory as an alias for their own
+ procedure and it will replace this one.
+*/
+
+#ifndef Setup_Memory
+void
+Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
+int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
+{
+/* First, assign values for the start of the areas */
+
+ if (Our_Heap_Size == 0)
+ { printf("Configuration won't hold initial data.\n");
+ exit(1);
+ }
+ Highest_Allocated_Address =
+ Allocate_Heap_Space(Stack_Allocation_Size(Our_Stack_Size) +
+ 2*Our_Heap_Size + Our_Constant_Size);
+ if (Heap == NULL)
+ { fprintf(stderr, "Not enough memory for this configuration.\n");
+ exit(1);
+ }
+ Align_Float(Heap);
+ Unused_Heap = Heap+Our_Heap_Size;
+ Align_Float(Unused_Heap);
+ Constant_Space = Heap + 2*Our_Heap_Size;
+ Align_Float(Constant_Space);
+ /* The extra word is needed by the garbage collector */
+ if (((C_To_Scheme(Highest_Allocated_Address)) & TYPE_CODE_MASK) != 0)
+ { fprintf(stderr,
+ "Largest address does not fit in datum field of Pointer.\n");
+ fprintf(stderr,
+ "Allocate less space or re-compile without Heap_In_Low_Memory.\n");
+ exit(1);
+ }
+
+/* Additional information about heap for primitives */
+
+ Heap_Bottom = Heap;
+ Clear_Mem(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size);
+ return;
+}
+#endif
+\f
+#define Default_Init_Fixed_Objects(Fixed_Objects) \
+{ Pointer Int_Vec, OB_Array, Error, Bad_Object, \
+ The_Queue, *Dummy_Hist, The_Utilities; \
+ fast long i; \
+ /* Interrupt vector */ \
+ Int_Vec = Make_Pointer(TC_VECTOR, Free); \
+ *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, \
+ MAX_INTERRUPT_NUMBER + 1); \
+ for (i=0; i <= MAX_INTERRUPT_NUMBER; i++) *Free++ = NIL; \
+ /* Error vector is not needed at boot time */ \
+ Error = NIL; \
+ /* Dummy History Structure */ \
+ History = Make_Dummy_History(); \
+ Dummy_Hist = Make_Dummy_History(); \
+ /* OBArray */ \
+ OB_Array = Make_Pointer(TC_VECTOR, Free); \
+ *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, OBARRAY_SIZE); \
+ for (i=0; i < OBARRAY_SIZE; i++) *Free++ = NIL; \
+ /* Non Object */ \
+ Bad_Object = Make_Pointer(TC_LIST, Free); \
+ *Free++ = NIL; \
+ *Free++ = NIL; \
+ /* Initial empty work queue */ \
+ The_Queue = Make_Pointer(TC_LIST, Free); \
+ *Free++ = NIL; \
+ *Free++ = NIL; \
+ /* Empty utilities vector */ \
+ The_Utilities = Make_Pointer(TC_VECTOR, Free); \
+ *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, 0); \
+ \
+ /* Now make the fixed objects vector */ \
+ Fixed_Objects = Make_Pointer(TC_VECTOR, Free); \
+ *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, NFixed_Objects); \
+ for (i=1; i <= NFixed_Objects; i++) *Free++ = NIL; \
+ User_Vector_Set(Fixed_Objects, Non_Object, Bad_Object); \
+ User_Vector_Set(Fixed_Objects, System_Interrupt_Vector, Int_Vec); \
+ User_Vector_Set(Fixed_Objects, System_Error_Vector, Error); \
+ User_Vector_Set(Fixed_Objects, OBArray, OB_Array); \
+ User_Vector_Set(Fixed_Objects, Hash_Number, FIXNUM_0); \
+ User_Vector_Set(Fixed_Objects, Dummy_History, \
+ Make_Pointer(TC_HUNK3, Dummy_Hist)); \
+ User_Vector_Set(Fixed_Objects, State_Space_Tag, TRUTH); \
+ User_Vector_Set(Fixed_Objects, Bignum_One, Fix_To_Big(FIXNUM_0+1)); \
+ User_Vector_Set(Fixed_Objects, Me_Myself, Fixed_Objects); \
+ User_Vector_Set(Fixed_Objects, The_Work_Queue, The_Queue); \
+ User_Vector_Set(Fixed_Objects, Utilities_Vector, The_Utilities); \
+}
+\f
+/* Boot Scheme */
+
+void
+Start_Scheme(Start_Prim, File_Name)
+int Start_Prim;
+char *File_Name;
+{ Pointer FName, Init_Prog, *Fasload_Call;
+ fast long i;
+ Boolean I_Am_Master = (Start_Prim != PC_GET_WORK); /* Butterfly test */
+
+ if (I_Am_Master)
+ printf("Scheme Microcode Version %d.%d\n", VERSION, SUBVERSION);
+ OS_Init(I_Am_Master);
+ if (I_Am_Master)
+ { for (i=0; i < FILE_CHANNELS; i++) Channels[i] = NULL;
+ Init_Fixed_Objects();
+ }
+
+/* The initial program to execute is
+ (SCODE-EVAL (FASLOAD <file-name>) SYSTEM-GLOBAL-ENVIRONMENT)
+ if Start_Prim is FASLOAD. Otherwise it is
+ (BAND-LOAD <file-name>)
+*/
+
+ FName = C_String_To_Scheme_String(File_Name);
+ Fasload_Call = Free;
+ switch (Start_Prim)
+ { case PC_FASLOAD: /* (SCODE-EVAL (FASLOAD <file>) GLOBAL-ENV) */
+ *Free++ = Make_Non_Pointer(TC_PRIMITIVE, PC_FASLOAD);
+ *Free++ = FName;
+ Init_Prog = Make_Pointer(TC_PCOMB2, Free);
+ *Free++ = Make_Non_Pointer(TC_PRIMITIVE, PC_SCODE_EVAL);
+ *Free++ = Make_Pointer(TC_PCOMB1, Fasload_Call);
+ *Free++ = Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL);
+ break;
+ case PC_BAND_LOAD: /* (BAND-LOAD <file>) */
+ *Free++ = Make_Non_Pointer(TC_PRIMITIVE, PC_BAND_LOAD);
+ *Free++ = FName;
+ Init_Prog = Make_Pointer(TC_PCOMB1, Fasload_Call);
+ break;
+ case PC_GET_WORK: /* ((GET-WORK)) */
+ *Free++ = Make_Non_Pointer(TC_PRIMITIVE, PC_GET_WORK);
+ *Free++ = NIL;
+ Init_Prog = Make_Pointer(TC_COMBINATION, Free);
+ *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, 1);
+ *Free++ = Make_Non_Pointer(TC_PCOMB1, Fasload_Call);
+ break;
+ }
+
+/* Start_Scheme continues on the next page */
+\f
+/* Start_Scheme, continued */
+
+ /* Setup registers */
+
+ IntEnb = INT_Mask;
+ IntCode = 0;
+ Env = Make_Non_Pointer(GLOBAL_ENV, 0);
+ Trapping = false;
+ Return_Hook_Address = NULL;
+
+ /* Give the interpreter something to chew on, and ... */
+
+ Will_Push(CONTINUATION_SIZE);
+ Store_Return(RC_END_OF_COMPUTATION);
+ Store_Expression(NIL);
+ Save_Cont();
+ Pushed();
+ Store_Expression(Init_Prog);
+
+ /* Go to it! */
+
+ if ((Stack_Pointer <= Stack_Guard) || (Free > MemTop))
+ { fprintf(stderr, "Configuration won't hold initial data.\n");
+ Microcode_Termination(TERM_EXIT);
+ }
+ Entry_Hook();
+ Enter_Interpreter();
+}
+
+Enter_Interpreter()
+{ jmp_buf Orig_Eval_Point;
+ Back_To_Eval = (jmp_buf *) Orig_Eval_Point;
+
+ Interpret(Was_Scheme_Dumped);
+ fprintf(stderr, "\nThe interpreter returned to top level!\n");
+ Microcode_Termination(TERM_EXIT);
+}
+\f
+#define IDENTITY_LENGTH 20 /* Plenty of room */
+#define ID_RELEASE 0 /* Scheme system release */
+#define ID_MICRO_VERSION 1 /* Microcode version */
+#define ID_MICRO_MOD 2 /* Microcode modification */
+#define ID_PRINTER_WIDTH 3
+#define ID_PRINTER_LENGTH 4
+#define ID_NEW_LINE_CHARACTER 5
+#define ID_FLONUM_PRECISION 6
+#define ID_FLONUM_EXPONENT 7 /* Number of bits */
+
+Built_In_Primitive(Prim_Microcode_Identify, 0, "MICROCODE-IDENTIFY")
+{ Pointer *Result = Free;
+ long i;
+ Primitive_0_Args();
+
+ Primitive_GC_If_Needed(IDENTITY_LENGTH + VECTOR_DATA);
+ *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, IDENTITY_LENGTH);
+ for (i=IDENTITY_LENGTH; --i >= 0; ) *Free++ = NIL;
+ Result[ID_RELEASE+VECTOR_DATA] =
+ C_String_To_Scheme_String(RELEASE);
+ Result[ID_MICRO_VERSION+VECTOR_DATA] =
+ FIXNUM_0+VERSION;
+ Result[ID_MICRO_MOD+VECTOR_DATA] =
+ FIXNUM_0+SUBVERSION;
+ Result[ID_PRINTER_WIDTH+VECTOR_DATA] =
+ FIXNUM_0+NColumns();
+ Result[ID_PRINTER_LENGTH+VECTOR_DATA] =
+ FIXNUM_0+NLines();
+ Result[ID_NEW_LINE_CHARACTER+VECTOR_DATA] =
+ Make_Non_Pointer(TC_CHARACTER, '\n');
+ Result[ID_FLONUM_PRECISION+VECTOR_DATA] =
+ FIXNUM_0+FLONUM_MANTISSA_BITS;
+ Result[ID_FLONUM_EXPONENT+VECTOR_DATA] =
+ FIXNUM_0+FLONUM_EXPT_SIZE;
+ return Make_Pointer(TC_VECTOR, Result);
+}
+\f
+Built_In_Primitive(Prim_Microcode_Tables_Filename,
+ 0, "MICROCODE-TABLES-FILENAME")
+{ char *From, *To,
+ *Prefix=SCHEME_SOURCES_PATH,
+ *Suffix=UCODE_TABLES_FILENAME;
+ long Count=0;
+ Pointer Result = Make_Pointer(TC_CHARACTER_STRING, Free);
+
+ Primitive_0_Args();
+ /* Might run out of room to do this, but not likely */
+ for (From = &(Prefix[0]), To = (char *) &(Free[STRING_CHARS]);
+ *From != '\0'; Count++) *To++ = *From++;
+ for (From = &(Suffix[0]); *From != '\0'; Count++) *To++ = *From++;
+ *To = '\0';
+ Free += STRING_CHARS + (Count+sizeof(Pointer))/sizeof(Pointer);
+ Vector_Set(Result, STRING_LENGTH, FIXNUM_0+Count);
+ Vector_Set(Result, STRING_HEADER,
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Free-Get_Pointer(Result))-1));
+ return Result;
+}
+\f
+/*VARARGS1*/
+term_type
+Microcode_Termination(Err, Micro_Error)
+long Err, Micro_Error;
+{ long value = 1;
+ Pointer Term_Vector;
+ if ((Err != TERM_HALT) &&
+ (Valid_Fixed_Obj_Vector()) &&
+ (Type_Code(Term_Vector =
+ Get_Fixed_Obj_Slot(Termination_Proc_Vector)) ==
+ TC_VECTOR) &&
+ (Vector_Length(Term_Vector) > Err))
+ { Pointer Handler = User_Vector_Ref(Term_Vector, Err);
+ if (Handler != NIL)
+ {
+ Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS +
+ ((Err==TERM_NO_ERROR_HANDLER) ? 5 : 4));
+ Store_Return(RC_HALT);
+ Store_Expression(FIXNUM_0 + Err);
+ Save_Cont();
+ if (Err == TERM_NO_ERROR_HANDLER) Push(FIXNUM_0 + Micro_Error);
+ Push(Val); /* Arg 3 */
+ Push(Fetch_Env()); /* Arg 2 */
+ Push(Fetch_Expression()); /* Arg 1 */
+ Push(Handler); /* The handler function */
+ Push(STACK_FRAME_HEADER + ((Err==TERM_NO_ERROR_HANDLER) ? 4 : 3));
+ Pushed();
+ longjmp(*Back_To_Eval, PRIM_NO_TRAP_APPLY);
+ }
+ }
+
+/* Microcode_Termination continues on the next page */
+\f
+/* Microcode_Termination, continued */
+
+ switch(Err)
+ { case TERM_BAD_PRIMITIVE:
+ printf("\nBad primitive invoked.\n"); break;
+ case TERM_BAD_PRIMITIVE_DURING_ERROR:
+ printf("Error during unknown primitive.\n"); break;
+ case TERM_BAD_ROOT:
+ printf("Band file isn't a control point.\n"); break;
+ case TERM_BAD_STACK:
+ printf("Control stack messed up.\n"); break;
+ case TERM_BROKEN_HEART:
+ printf("Broken heart encountered.\n"); break;
+ case TERM_COMPILER_DEATH:
+ printf("Compiled code entered without compiler support.\n"); break;
+ case TERM_DISK_RESTORE:
+ printf("DISK restore.\n"); break;
+ case TERM_EOF:
+ printf("\nEnd of input stream reached.\n"); break;
+ case TERM_END_OF_COMPUTATION:
+ Print_Expression(Val, "End of computation; final result"); break;
+ case TERM_EXIT:
+ printf("Inconsistency detected.\n"); break;
+ case TERM_GC_OUT_OF_SPACE:
+ printf("Out of space after GC. Needed %d, have %d\n",
+ Get_Integer(Fetch_Expression()), Space_Before_GC());
+ break;
+ case TERM_HALT:
+ printf("User halt code.\n"); value = 0; break;
+ case TERM_INVALID_TYPE_CODE:
+ printf("Bad Type: check GC_Type map.\n"); break;
+ case TERM_NO_ERROR_HANDLER:
+ printf("\nNo handler for error code: %d\n", Micro_Error); break;
+ case TERM_NO_INTERRUPT_HANDLER:
+ printf("No interrupt handler.\n"); break;
+ case TERM_NON_EXISTENT_CONTINUATION:
+ printf("No such return code 0x%08x.\n", Fetch_Return()); break;
+ case TERM_NON_POINTER_RELOCATION:
+ printf("Non pointer relocation!?\n"); break;
+ case TERM_STACK_ALLOCATION_FAILED:
+ printf("No space for stack!?\n"); break;
+ case TERM_STACK_OVERFLOW:
+ printf("Recursion depth exceeded.\n"); break;
+ case TERM_TERM_HANDLER:
+ printf("Termination handler returned.\n"); break;
+ case TERM_UNIMPLEMENTED_CONTINUATION:
+ printf("Return code not implemented.\n"); break;
+ case TERM_NO_SPACE:
+ printf("Not enough memory.\n"); break;
+ default: printf("Termination code 0x%x.\n", Err);
+ }
+ if ((Trace_On_Error) && (Err != TERM_HALT))
+ { printf( "\n\nStack trace:\n\n");
+ Back_Trace();
+ }
+ OS_Flush_Output_Buffer();
+ OS_Quit();
+ Exit_Hook();
+ Exit_Scheme(value);
+}
+
--- /dev/null
+#include <stdio.h>
+
+#ifndef isdigit
+#include <ctype.h>
+#endif
+
+#define boolean char
+#define false 0
+#define true 1
+
+#define isoctal(c) (isdigit(c) && (c != '8') && (c != '9'))
+
+int get_a_char()
+{ register int c;
+ register int count = 2;
+ for (c = getchar();
+ isoctal(c) && count >= 0;
+ c = getchar(), count -=1)
+ putchar(c);
+ if (count != 2) return c;
+ putchar(c);
+ return getchar();
+}
+
+main()
+{ register int c;
+ register boolean after_new_line = true;
+ while ((c = getchar()) != EOF)
+re_dispatch:
+ switch(c)
+ { case '\f':
+ break;
+ case ',':
+ putchar(c);
+ while (((c = getchar()) == ' ') || (c == '\t'))
+ if (c == EOF)
+ { fprintf(stderr, "Confused expression: ,\n");
+ exit(1);
+ }
+ if (c == '\n')
+ { putchar(c);
+ after_new_line = true;
+ break;
+ }
+ putchar(' ');
+ goto re_dispatch;
+ case ';':
+ case ':':
+ case '?':
+ case '}':
+ putchar(c);
+ putchar('\n');
+ after_new_line = true;
+ break;
+ case '\n':
+ if (!after_new_line)
+ { after_new_line = true;
+ putchar('\n');
+ }
+ break;
+ case '\'':
+ putchar(c);
+ c = getchar();
+ if (c == EOF)
+ { fprintf(stderr, "Confused character: EOF\n");
+ exit(1);
+ }
+ putchar(c);
+ if (c == '\n')
+ { fprintf(stderr, "Confused character: \\n\n");
+ after_new_line = true;
+ break;
+ }
+ if (c == '\'')
+ { fprintf(stderr, "Confused character: \\\'\n");
+ break;
+ }
+ if (c == '\\')
+ c = get_a_char();
+ else c = getchar();
+ if (c == EOF)
+ { fprintf(stderr, "Confused character: EOF\n");
+ exit(1);
+ }
+ putchar(c);
+ if (c != '\'')
+ fprintf(stderr, "Confused character: %c = 0x%x\n",
+ c);
+ break;
+ case '"':
+ after_new_line == false;
+ putchar(c);
+ c = getchar();
+ while (true)
+ { while ((c != EOF) &&
+ (c != '"') &&
+ (c != '\n') &&
+ (c != '\\'))
+ { putchar(c);
+ c = getchar();
+ }
+ if (c == EOF)
+ { fprintf(stderr, "Confused string: EOF\n");
+ exit(1);
+ }
+ putchar(c);
+ if (c == '\n')
+ { fprintf(stderr, "Confused string: \\n\n");
+ after_new_line = true;
+ break;
+ }
+ if (c == '"') break;
+ if (c == '\\')
+ c = get_a_char();
+ }
+ break;
+ case '#':
+ if (after_new_line)
+ { while (((c = getchar()) != EOF) && (c != '\n')) ;
+ if (c == EOF) exit(0);
+ break;
+ }
+ putchar(c);
+ break;
+ case '{':
+ if (!after_new_line)
+ putchar('\n');
+ /* Fall Through */
+ default:
+ after_new_line = false;
+ putchar(c);
+ }
+ fflush(stdout);
+ exit(0);
+}
--- /dev/null
+/* Emacs -*-C-*-an't tell the language */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: character.c
+ *
+ * This file contains the character primitives.
+ */
+\f
+#include <ctype.h>
+#include "scheme.h"
+#include "primitive.h"
+#include "character.h"
+
+/* pieces of characters primitives
+1. MAKE-CHAR Makes a char from its bits and its code.
+ A char is a 32
+ TC_CHARACTER typecode in the 8 bits near the
+ msb, the next 12 bits unused, the next 5 bits
+ for the bits (control, hyper, meta, etc.) and
+ the last 7, including the lsb for the code
+ field, i.e., what letter it is.
+2. CHAR-BITS Gets those 5 bits bits.
+3. CHAR-CODE Gets those 7 code bits.
+*/
+
+Built_In_Primitive(Prim_Make_Char, 2, "MAKE-CHAR")
+{
+ long bucky_bits, code;
+ Primitive_2_Args();
+
+ Arg_1_Type( TC_FIXNUM);
+ Arg_2_Type( TC_FIXNUM);
+ Range_Check( code, Arg1, 0, (MAX_CODE - 1), ERR_ARG_1_BAD_RANGE);
+ Range_Check( bucky_bits, Arg2, 0, (MAX_BITS - 1), ERR_ARG_2_BAD_RANGE);
+ return (make_char( bucky_bits, code));
+}
+
+Built_In_Primitive( Prim_Char_Bits, 1, "CHAR-BITS")
+{
+ Primitive_1_Args();
+
+ Arg_1_Type( TC_CHARACTER);
+ return (Make_Unsigned_Fixnum( char_bits( Arg1)));
+}
+
+Built_In_Primitive( Prim_Char_Code, 1, "CHAR-CODE")
+{
+ Primitive_1_Args();
+
+ Arg_1_Type( TC_CHARACTER);
+ return (Make_Unsigned_Fixnum( char_code( Arg1)));
+}
+\f
+/* Primitives for converting characters:
+1. CHAR->INTEGER Converts a char to its 12 bit numerical
+ value in extended ascii.
+2. INTEGER->CHAR Converts the other way.
+3. CHAR-UPCASE Converts a char to upcase.
+4. CHAR-DOWNCASE Converts a char to lowercase.
+5. ASCII->CHAR Converts an ascii value to a char, including
+ doing bit twiddleing to make sure
+ the control bit is set correctly.
+6. CHAR->ASCII Converts a char back to the ascii value,
+ signalling an error if there are
+ problems.
+7. CHAR-ASCII? Converts a char similarly, but signals false
+ if there are problems.
+8. CHAR->JESSE-JACKSON Converts a char to a fundamentalist preacher
+ who runs for President. Shouldn't
+ be used in the Democratic Party.
+*/
+
+Built_In_Primitive( Prim_Char_To_Integer, 1, "CHAR->INTEGER")
+{
+ Primitive_1_Args();
+
+ Arg_1_Type( TC_CHARACTER);
+ return (Make_Unsigned_Fixnum( (Arg1 & MASK_EXTNDD_CHAR)));
+}
+
+Built_In_Primitive( Prim_Integer_To_Char, 1, "INTEGER->CHAR")
+{
+ long integ;
+ Primitive_1_Args();
+
+ Arg_1_Type( TC_FIXNUM);
+ Sign_Extend_Range_Check( integ, Arg1, 0, (MAX_EXTNDD_CHAR - 1),
+ ERR_ARG_1_BAD_RANGE);
+ return (Make_Non_Pointer( TC_CHARACTER, integ));
+}
+\f
+Built_In_Primitive( Prim_Char_Downcase, 1, "CHAR-DOWNCASE")
+{
+ long ascii;
+ Primitive_1_Args();
+
+ Arg_1_Type( TC_CHARACTER);
+ return make_char( char_bits( Arg1), Real_To_Lower( char_code( Arg1)));
+}
+
+Built_In_Primitive( Prim_Char_Upcase, 1, "CHAR-UPCASE")
+{
+ Primitive_1_Args();
+
+ Arg_1_Type( TC_CHARACTER);
+ return make_char( char_bits( Arg1), Real_To_Upper( char_code( Arg1)));
+}
+
+Built_In_Primitive( Prim_Ascii_To_Char, 1, "ASCII->CHAR")
+{
+ long ascii;
+ Primitive_1_Args();
+
+ Arg_1_Type( TC_FIXNUM);
+ Range_Check( ascii, Arg1, 0, (MAX_ASCII - 1), ERR_ARG_1_BAD_RANGE);
+ return (c_char_to_scheme_char( ascii));
+}
+
+Built_In_Primitive( Prim_Char_Ascii_P, 1, "CHAR-ASCII?")
+{
+ long ascii;
+ Primitive_1_Args();
+
+ Arg_1_Type( TC_CHARACTER);
+ ascii = scheme_char_to_c_char( Arg1);
+ return ((ascii == NOT_ASCII) ? NIL : Make_Unsigned_Fixnum( ascii));
+}
+
+Built_In_Primitive( Prim_Char_To_Ascii, 1, "CHAR->ASCII")
+{
+ long ascii;
+ Primitive_1_Args();
+
+ Arg_1_Type( TC_CHARACTER);
+ ascii = scheme_char_to_c_char( Arg1);
+ if (ascii == NOT_ASCII)
+ Primitive_Error( ERR_ARG_1_BAD_RANGE);
+ return (Make_Unsigned_Fixnum( ascii));
+}
+\f
+forward Boolean ascii_control_p();
+
+long
+ascii_to_mit_ascii( ascii)
+ long ascii;
+{
+ long bucky_bits, code;
+
+ bucky_bits = (((ascii & 0200) != 0) ? CHAR_BITS_META : 0);
+ code = (ascii & 0177);
+ if (ascii_control_p( code))
+ {
+ code |= 0100; /* Convert to non-control code. */
+ bucky_bits |= CHAR_BITS_CONTROL;
+ }
+ return ((bucky_bits << CODE_LENGTH) | code);
+}
+
+long
+mit_ascii_to_ascii( mit_ascii)
+ long mit_ascii;
+{
+ long bucky_bits, code;
+
+ bucky_bits = ((mit_ascii >> CODE_LENGTH) & CHAR_MASK_BITS);
+ code = (mit_ascii & CHAR_MASK_CODE);
+ if ((bucky_bits & (~ CHAR_BITS_CONTROL_META)) != 0)
+ return (NOT_ASCII);
+ else
+ {
+ if ((bucky_bits & CHAR_BITS_CONTROL) != 0)
+ {
+ code = (Real_To_Upper( code) & (~ 0100));
+ if (!ascii_control_p( code))
+ return (NOT_ASCII);
+ }
+ else
+ {
+ if (ascii_control_p( code))
+ return (NOT_ASCII);
+ }
+ return (((bucky_bits & CHAR_BITS_META) != 0) ? (code | 0200) : code);
+ }
+}
+\f
+Boolean
+ascii_control_p( code)
+ int code;
+{
+ switch (code)
+ {
+ case 000:
+ case 001:
+ case 002:
+ case 003:
+ case 004:
+ case 005:
+ case 006:
+ case 007:
+ case 016:
+ case 017:
+ case 020:
+ case 021:
+ case 022:
+ case 023:
+ case 024:
+ case 025:
+ case 026:
+ case 027:
+ case 030:
+ case 031:
+ case 034:
+ case 035:
+ case 036:
+ return (true);
+
+ default:
+ return (false);
+ }
+}
--- /dev/null
+/* Hey EMACS, this is -*- C -*- code! */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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: CONFIG.H
+ *
+ * This file contains the configuration information and the information
+ * given on the command line on Unix.
+ *
+ */
+
+/* Default pathnames. */
+
+#ifndef DEFAULT_BAND_NAME
+#define DEFAULT_BAND_NAME "scm:scheme.bin"
+#endif
+#ifndef SCHEME_SOURCES_PATH
+#define SCHEME_SOURCES_PATH "scm:"
+#endif
+
+#ifndef butterfly
+#ifndef unix
+/* On unix, these are part of the make file. */
+
+/* Runtime debugging flags, with appropriate defaults: */
+
+/* To debug the interpreter code itself, define ENABLE_DEBUGGING_TOOLS */
+/* #define ENABLE_DEBUGGING_TOOLS */
+
+/* If runtime HISTORY recording (a Scheme code debugging tool) is desired. */
+#define COMPILE_HISTORY
+
+/* To enable the STEPPER. Incompatible with futures. */
+/* #define COMPILE_STEPPER */
+
+/* To enable FUTURES (a multiprocessor / multiprocessing extension).
+ This option is incompatible with the stepper.
+ Future.c must also be compiled. */
+/* #define COMPILE_FUTURES */
+
+/* To enable stacklets (mostly useful with FUTURES). These allow the
+ stack to be allocated in small chunks from the heap, rather than
+ in a single contiguous area at start up time. The use of the this
+ option is incompatible with the stepper and compiler.
+*/
+/* #define USE_STACKLETS */
+
+/* To enable "trap on reference" variable bindings (used by parallel processor
+ deep binding).
+*/
+/* #define TRAP_ON_REFERENCE */
+#endif
+#endif
+\f
+/* Some configuration consistency testing */
+
+#ifdef COMPILE_STEPPER
+#ifdef COMPILE_FUTURES
+#include "Error: Futures and stepping are not currently compatible."
+#endif
+#endif
+
+#ifdef USE_STACKLETS
+#ifdef COMPILE_STEPPER
+#include "Error: The stepper doesn't work with stacklets. Fix it."
+#endif
+#endif
+
+/* To enable metering of the time spent in various parts of the Scheme
+ interpreter. Collecting this data slows down the operation of the
+ interpreter, and no tools are supported for accessing the values
+ collected. Useful for collecting statistics and performance work on
+ the interpreter itself or user programs. */
+
+/* #define METERING */
+\f
+/* These C type definitions are needed by everybody.
+ They should not be here, but it is unavoidable. */
+
+typedef char Boolean;
+#define true 1
+#define false 0
+
+/* This defines it so that C will be happy.
+ The various fields are defined in OBJECT.H */
+
+typedef unsigned long Pointer;
+\f
+/* Operating System / Machine dependencies:
+
+ For each implementation, be sure to specify FASL_INTERNAL_FORMAT,
+ the various sizes, and the floating point information.
+ Make sure that there is an appropriate FASL_<machine name>.
+ If you do not know these parameters, try compiling and running the
+ wsize program ("make wsize" if on a unix variant). It may not run,
+ but if it does, it will probably compute the correct information.
+
+ Note that the C type void is used in the sources. If your version
+ of C does not have this type, you should bypass it. Look at what
+ vms (below) does.
+
+ CHAR_SIZE is the size of a character in bits.
+
+ USHORT_SIZE is the size of an unsigned short in bits. It should
+ be equivalent to (sizeof(unsigned short) * CHAR_SIZE), but is
+ available to the preprocessor.
+
+ ULONG_SIZE is the size of an unsigned long in bits.
+
+ FLONUM_EXPT_SIZE is the number of bits in the largest positive
+ exponent of a (double) floating point number.
+ Note that if excess exponents are used in the representation,
+ this number is one less than the size in bits of the exponent field.
+
+ FLONUM_MANTISSA_BITS is the number of bits in the (positive) mantissa
+ of a (double) floating point number. It includes the hidden bit if
+ the representation uses them.
+
+ Thus 2+FLONUM_EXPT_SIZE+FLONUM_MANTISSA_BITS(-1 if hidden bit is used)
+ should be the size in bits of a (double) floating point number.
+
+ FLONUM_EXPONENT_SIZE
+ MAX_FLONUM_EXPONENT = 2 - 1
+
+ Other flags (the safe option is NOT to define them, which will
+ sacrifice speed for safety):
+
+ b32 should be defined for machines whose word size
+ (CHAR_SIZE*sizeof(long)) is 32 bits. The information is redundant,
+ but some C compilers do not do constant folding when shifts are
+ involved, so it sometimes makes a big difference to define the
+ constants directly rather than in terms of other constants.
+ Similar things can be done for other word sizes.
+*/
+\f
+/* Heap_In_Low_Memory should be defined if malloc returns the lowest
+ available memory and thus all addresses will fit in the datum portion
+ of a Scheme Pointer. The datum portion of a Scheme Pointer is 8 bits
+ less than the length of a C long.
+
+ UNSIGNED_SHIFT is defined if right shifting an unsigned long
+ (i.e. Pointer) results in a logical (vs. arithmetic) shift.
+ Setting the flag allows faster type code extraction.
+
+ BELL is the character which rings the terminal bell.
+
+ The following switches are used to use the system provided library
+ routines rather than the emulated versions in the Scheme sources.
+ The system provided ones are more accurate and potentially more
+ efficient.
+
+ HAS_FLOOR should be defined if the system has the double precision
+ procedures floor and ceil. On Unix, look for floor(3M).
+
+ HAS_FREXP should be defined if the system has the double precision
+ procedures ldexp and frexp. On Unix, look for frexp(3C).
+
+ FLOATING_ALIGNMENT should be defined if the system requires
+ floating point numbers (double) to be aligned more strictly than
+ Pointers (long). The value must be a mask of the low order
+ bits which are required to be zero for the storage address.
+ For example, a value of 0x7 requires octabyte alignment on a
+ machine where addresses are specified in bytes. The alignment
+ must be an integral multiple of the length of a long, since
+ it must pad with an explicit Pointer value.
+
+*/
+
+#define FASL_UNKNOWN 0
+#define FASL_PDP10 1
+#define FASL_VAX 2
+#define FASL_HP_9000_200 3
+#define FASL_NU 4
+#define FASL_HP_9000_500 5
+#define FASL_SUN 6
+#define FASL_BFLY 7
+#define FASL_CYBER 8
+#define FASL_CELERITY 9
+#define FASL_HP_SPECTRUM 10
+\f
+/* These (pdp10 and nu) haven't worked in a while.
+ * Should be upgraded some day.
+ */
+
+#ifdef pdp10
+#define Heap_In_Low_Memory
+#define CHAR_SIZE 36 / * Ugh! Supposedly fixed in newer Cs * /
+/* #define BELL '\007' */
+#define FASL_INTERNAL_FORMAT FASL_PDP10
+#endif
+
+#ifdef nu
+#define noquick /* Bignum code fails for certain
+ variables in registers because of
+ a compiler bug! */
+#define Heap_In_Low_Memory
+#define CHAR_SIZE 8
+#define USHORT_SIZE 16
+#define ULONG_SIZE 32
+/* #define BELL '\007' */
+#define FASL_INTERNAL_FORMAT FASL_NU
+#define FLONUM_EXPT_SIZE 7
+#define FLONUM_MANTISSA_BITS 56
+#define MAX_FLONUM_EXPONENT 127
+#define HAS_FREXP
+#endif
+\f
+#ifdef vax
+/* Amazingly unix and vms agree on all these */
+#define Heap_In_Low_Memory
+#define UNSIGNED_SHIFT
+#define CHAR_SIZE 8
+#define USHORT_SIZE 16
+#define ULONG_SIZE 32
+/* #define BELL '\007' */
+#define FASL_INTERNAL_FORMAT FASL_VAX
+#define FLONUM_EXPT_SIZE 7
+#define FLONUM_MANTISSA_BITS 56 /* D format */
+#define MAX_FLONUM_EXPONENT 127
+#define HAS_FLOOR
+#define HAS_FREXP
+/* Not on these, however */
+#ifdef vms
+/* VMS C has not void type, thus make it go away */
+#define void
+/* Name conflict in VMS with system variable */
+#define Free Free_Register
+
+/* exit(0) produces horrible message on VMS */
+
+#define NORMAL_EXIT 1
+
+#define Exit_Scheme_Declarations static jmp_buf Exit_Point
+
+#define Init_Exit_Scheme() \
+{ int Which_Way = setjmp(Exit_Point); \
+ if (Which_Way == NORMAL_EXIT) return; \
+}
+
+#define Exit_Scheme(value) \
+if (value != 0) exit(value); \
+longjmp(Exit_Point, NORMAL_EXIT)
+
+#else /* not a vms */
+/* Vax Unix C compiler bug */
+#define double_into_fixnum(what, target) \
+ { long For_Vaxes_Sake = (long) what; \
+ target = Make_Non_Pointer(TC_FIXNUM, For_Vaxes_Sake); \
+ }
+#endif /* not vms */
+#endif /* vax */
+
+#ifdef hp9000s200 /* and s300, pretty indistinguishable */
+#define Heap_In_Low_Memory
+#define UNSIGNED_SHIFT
+#define CHAR_SIZE 8
+#define USHORT_SIZE 16
+#define ULONG_SIZE 32
+#define BELL '\007'
+#define FASL_INTERNAL_FORMAT FASL_HP_9000_200
+#define FLONUM_EXPT_SIZE 10
+#define FLONUM_MANTISSA_BITS 53
+#define MAX_FLONUM_EXPONENT 1023
+#define HAS_FLOOR
+#define HAS_FREXP
+#define term_type int /* C compiler bug in GC_Type */
+#endif
+
+#ifdef hp9000s500
+/* An unfortunate fact of life on this machine:
+ the C heap is in high memory thus Heap_In_Low_Memory is not
+ defined and the whole thing runs slowly. *Sigh*
+*/
+#define UNSIGNED_SHIFT
+#define CHAR_SIZE 8
+#define USHORT_SIZE 16
+#define ULONG_SIZE 32
+/* #define BELL '\007' */
+#define FASL_INTERNAL_FORMAT FASL_HP_9000_500
+#define FLONUM_EXPT_SIZE 10
+#define FLONUM_MANTISSA_BITS 53
+#define MAX_FLONUM_EXPONENT 1023
+#define HAS_FLOOR
+#define HAS_FREXP
+
+/* C Compiler bug when constant folding and anchor pointing */
+#define And2(x, y) ((x) ? (y) : false)
+#define And3(x, y, z) ((x) ? ((y) ? (z) : false) : false)
+#define Or2(x, y) ((x) ? true : (y))
+#define Or3(x, y, z) ((x) ? true : ((y) ? true : (z)))
+#endif
+\f
+#ifdef sun
+#define Heap_In_Low_Memory
+#define UNSIGNED_SHIFT
+#define CHAR_SIZE 8
+#define USHORT_SIZE 16
+#define ULONG_SIZE 32
+/* #define BELL '\007' */
+#define FASL_INTERNAL_FORMAT FASL_SUN
+#define FLONUM_EXPT_SIZE 7
+#define FLONUM_MANTISSA_BITS 56
+#define MAX_FLONUM_EXPONENT 127
+#define HAS_FLOOR
+#define HAS_FREXP
+#endif
+
+#ifdef butterfly
+#define Heap_In_Low_Memory
+#define CHAR_SIZE 8
+#define USHORT_SIZE 16
+#define ULONG_SIZE 32
+/* #define BELL '\007' */
+#define FASL_INTERNAL_FORMAT FASL_BFLY
+#define FLONUM_EXPT_SIZE 7
+#define FLONUM_MANTISSA_BITS 56
+#define MAX_FLONUM_EXPONENT 127
+#define Allow_Aux_Compilation false /* Prevent race in lookup */
+#include <public.h>
+#define HAS_FREXP
+#define STACK_SIZE 4 /* 4K objects */
+#endif
+
+#ifdef cyber180
+/* Word size is 64 bits. */
+#define Heap_In_Low_Memory
+#define CHAR_SIZE 8
+#define USHORT_SIZE ???
+#define ULONG_SIZE ???
+/* #define BELL '\007' */
+#define FASL_INTERNAL_FORMAT FASL_CYBER
+#define FLONUM_EXPT_SIZE 14
+#define FLONUM_MANTISSA_BITS 48
+/* Not the full range, or so the manual says. */
+#define MAX_FLONUM_EXPONENT 4095
+/* The Cyber180 C compiler manifests a bug in hairy conditional
+ expressions */
+#define Conditional_Bug
+#endif
+\f
+#ifdef celerity
+#define Heap_In_Low_Memory
+#define UNSIGNED_SHIFT
+#define CHAR_SIZE 8
+#define USHORT_SIZE 16
+#define ULONG_SIZE 32
+/* #define BELL '\007' */
+#define FASL_INTERNAL_FORMAT FASL_CELERITY
+#define FLONUM_EXPT_SIZE 11
+#define FLONUM_MANTISSA_BITS 53
+#define MAX_FLONUM_EXPONENT 2047
+#endif
+
+#ifdef spectrum
+/* Heap resides in "Quad 1", and hence memory addresses have a 1
+ in the second MSBit. This is taken care of in OBJECT.H, and is
+ still considered Heap_In_Low_Memory.
+*/
+#define Heap_In_Low_Memory
+#define UNSIGNED_SHIFT
+#define CHAR_SIZE 8
+#define USHORT_SIZE 16
+#define ULONG_SIZE 32
+/* #define BELL '\007' */
+#define FASL_INTERNAL_FORMAT FASL_HP_SPECTRUM
+#define FLONUM_EXPT_SIZE 10
+#define FLONUM_MANTISSA_BITS 53
+#define MAX_FLONUM_EXPONENT 1023
+#define FLOATING_ALIGNMENT 0x7 /* Low 3 MBZ for float storage */
+#define HAS_FLOOR
+#define HAS_FREXP
+#endif
+\f
+/* Make sure that some definition applies.
+ If this error occurs, and the parameters of the
+ configuration are unknown, try the Wsize program.
+*/
+
+#ifndef CHAR_SIZE
+#include "Error: config.h: Unknown configuration."
+#endif
+
+#if (ULONG_SIZE == 32)
+#define b32
+#endif
+
+/* Default "segment" sizes */
+#ifndef STACK_SIZE
+#ifndef USE_STACKLETS
+#define STACK_SIZE 30 /* Default Kcells for stack */
+#else
+#define STACK_SIZE 256 /* Default stacklet size */
+#endif
+#endif
+#ifndef CONSTANT_SIZE
+#define CONSTANT_SIZE 180 /* Default Kcells for constant */
+#endif
+#ifndef HEAP_SIZE
+#define HEAP_SIZE 250 /* Default Kcells for each heap */
+#endif
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: CONST.H
+ *
+ * Named constants used throughout the interpreter
+ *
+ */
+\f
+#if (CHAR_SIZE != 8)
+#define MAX_CHAR ((1<<CHAR_SIZE)-1)
+#else
+#define MAX_CHAR 0xFF
+#endif
+
+#define PI 3.1415926535
+#define STACK_FRAME_HEADER 1
+
+/* Precomputed typed pointers */
+#ifndef b32 /* Safe version */
+
+#define NIL Make_Non_Pointer(TC_NULL, 0)
+#define TRUTH Make_Non_Pointer(TC_TRUE, 0)
+#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_UNASSIGNED, UNASSIGNED)
+#define UNBOUND_OBJECT Make_Non_Pointer(TC_UNASSIGNED, UNBOUND)
+#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0)
+#define FIXNUM_0 Make_Non_Pointer(TC_FIXNUM, 0)
+#define LOCAL_REF_0 Make_Non_Pointer(LOCAL_REF, 0)
+#define BROKEN_HEART_0 Make_Non_Pointer(TC_BROKEN_HEART, 0)
+#define STRING_0 Make_Non_Pointer(TC_CHARACTER_STRING, 0)
+
+#else /* 32 bit word */
+#define NIL 0x00000000
+#define TRUTH 0x08000000
+#define UNASSIGNED_OBJECT 0x32000000
+#define UNBOUND_OBJECT 0x32000001
+#define UNCOMPILED_VARIABLE 0x08000000
+#define FIXNUM_0 0x1A000000
+#define LOCAL_REF_0 0x00000000
+#define BROKEN_HEART_0 0x22000000
+#define STRING_0 0x1E000000
+#endif /* b32 */
+
+/* Some names for flag values */
+
+#define SET_IT 0 /* Lookup */
+#define CLEAR_IT 1
+#define READ_IT 2
+#define TEST_IT 3
+
+#define FOUND_SLOT 1 /* Slot lookup */
+#define NO_SLOT 2
+#define FOUND_UNBOUND 4
+
+#define NOT_THERE -1 /* Command line parser */
+\f
+/* Assorted sizes used in various places */
+
+#ifdef MAXPATHLEN
+#define FILE_NAME_LENGTH MAXPATHLEN
+#else
+#define FILE_NAME_LENGTH 1024 /* Max. chars. in a file name */
+#endif
+
+#define OBARRAY_SIZE 3001 /* Interning hash table */
+#define STACK_GUARD_SIZE 500 /* Cells between constant and
+ stack before overflow
+ occurs */
+#define FILE_CHANNELS 15
+#define MAX_LIST_PRINT 10
+
+#define ILLEGAL_PRIMITIVE -1
+
+/* Hashing algorithm for interning */
+
+#define MAX_HASH_CHARS 5
+#define LENGTH_MULTIPLIER 5
+#define SHIFT_AMOUNT 2
+
+/* For looking up variable definitions */
+
+#define UNCOMPILED_REF TC_TRUE
+#define GLOBAL_REF TC_UNINTERNED_SYMBOL
+#define FORMAL_REF TC_FIXNUM
+#define AUX_REF TC_ENVIRONMENT
+#define LOCAL_REF TC_NULL
+/* LOCAL_REF must be 0 in order for code in interpret.c to work fast */
+
+/* For headers in pure / constant area */
+
+#define END_OF_BLOCK TC_FIXNUM
+#define CONSTANT_PART TC_TRUE
+#define PURE_PART TC_FALSE
+
+/* Primitive flow control codes: directs computation after
+ * processing a primitive application.
+ */
+#define PRIM_DONE -1
+#define PRIM_DO_EXPRESSION -2
+#define PRIM_APPLY -3
+#define PRIM_INTERRUPT -4
+#define PRIM_NO_TRAP_EVAL -5
+#define PRIM_NO_TRAP_APPLY -6
+#define PRIM_POP_RETURN -7
+\f
+/* Interrupt bits -- scanned from LSB (1) to MSB (16) */
+
+#define INT_Stack_Overflow 1 /* Local interrupt */
+#define INT_Global_GC 2
+#define INT_GC 4 /* Local interrupt */
+#define INT_Global_1 8
+#define INT_Character 16 /* Local interrupt */
+#define INT_Global_2 32
+#define INT_Timer 64 /* Local interrupt */
+#define INT_Global_3 128
+#define INT_Global_Mask \
+ (INT_Global_GC | INT_Global_1 | INT_Global_2 | INT_Global_3)
+#define Global_GC_Level 1
+#define Global_1_Level 3
+#define Global_2_Level 5
+#define Global_3_Level 7
+#define MAX_INTERRUPT_NUMBER 7
+
+#define INT_Mask ((1<<(MAX_INTERRUPT_NUMBER+1))-1)
+
+/* Error case detection for precomputed constants */
+/* VMS preprocessor does not like line continuations in conditionals */
+
+#define Are_The_Constants_Incompatible \
+((TC_NULL != 0x00) || (TC_TRUE != 0x08) || (TC_UNASSIGNED != 0x32) || \
+ (UNASSIGNED != 0) || (UNBOUND != 1) || (UNCOMPILED_REF != 0x08) || \
+ (TC_FIXNUM != 0x1A) || (TC_BROKEN_HEART != 0x22) || \
+ (TC_CHARACTER_STRING != 0x1E) || (LOCAL_REF != 0x00))
+
+/* The values used above are in sdata.h and types.h,
+ check for consistency if the check below fails. */
+
+#if Are_The_Constants_Incompatible
+#include "Error: disagreement in const.h"
+#endif
+
+/* These are the only entries in Registers[] needed by the microcode.
+ All other entries are used only by the compiled code interface. */
+
+#define REGBLOCK_MEMTOP 0
+#define REGBLOCK_STACKGUARD 1
+#define REGBLOCK_MINIMUM_LENGTH 2
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: daemon.c
+
+ This file contains code for the Garbage Collection daemons.
+ There are currently two daemons, one for closing files which
+ have disappeared due to GC, the other for supporting object
+ hash tables where entries disappear when the corresponding
+ object is released due to GC.
+
+*/
+
+#include "scheme.h"
+#include "primitive.h"
+#include "gccode.h"
+\f
+/* Hash Tables
+
+ The hash table support here allows the Scheme runtime system to
+ support "populations." A population is conceptually a set of
+ items, but with the special property that an item remains in the
+ population only as long as the object would remain in the system
+ were it not in the set. That is, an item is removed from all
+ populations it belongs to when a garbage collection removes the
+ item from the system.
+
+ The actual support provided is a pair of hash tables. An object
+ can be hashed to yield the current value of a constantly
+ incrementing counter. The hash table is constructed by hashing on
+ the address of the object, and both the item and the unique number
+ assigned to it are stored in the table. The unhash table is
+ constructed by hashing on the unique number and again storing both
+ the item and its unique number. Both the hash and unhash tables
+ appear to the user to be vectors, but they have a NON_MARKED header
+ so that the ordinary GC will not update pointers located within
+ them.
+
+ At every GC flip (i.e. after all objects have been moved from old
+ space to new space, but before the Scheme code runs again), the
+ Rehash Daemon is called. It goes through the hash table (all of
+ which points into old space) and reconstructs it. Whenever it
+ finds a non-pointer object or an object which points at a BROKEN
+ HEART (i.e. one which the GC copied into new space) it rehashes the
+ new address and adds it to the new table.
+
+ Thus, the hash tables provide a mapping from objects to unique
+ numbers, with the additional property that the table does not
+ retain objects that the garbage collector would otherwise release
+ from the system.
+
+*/
+
+#define Hash_It(P) \
+ (((Datum(P)>>16)&0xFF)+ \
+ ((Datum(P)>>8)&0xFF)+ \
+ (Datum(P) & 0xFF))
+
+Pointer The_Hash_Table, The_Unhash_Table;
+long HASH_TABLE_SIZE;
+\f
+/* (INITIALIZE-OBJECT-HASH FIXNUM)
+ [Primitive number 0x8A]
+ Resets the unique ID generator used in the 2-dimensional hash
+ tables which implement properties and populations. The value of
+ FIXNUM will be used for the next object put into the hash
+ tables.
+*/
+Built_In_Primitive(Prim_Initialize_Object_Hash, 1, "INITIALIZE-OBJECT-HASH")
+{ fast long i;
+ long Length;
+ Primitive_1_Arg();
+ Arg_1_Type(TC_FIXNUM);
+ HASH_TABLE_SIZE = Get_Integer(Arg1);
+ Length = 8 + (2 * HASH_TABLE_SIZE);
+ if (!Test_Pure_Space_Top(Free_Constant + Length))
+ { Update_FObj_Slot(Hash_Table, NIL);
+ Update_FObj_Slot(Unhash_Table, NIL);
+ return NIL;
+ }
+
+/* Make a Constant/Pure block to hold the two vectors */
+
+/* Constant part header */
+ *Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, Length-3);
+ *Free_Constant++ = Make_Non_Pointer(PURE_PART, Length-1);
+
+/* Constant part contains hash and unhash tables */
+ Update_FObj_Slot(Hash_Table, Make_Pointer(TC_VECTOR, Free_Constant));
+ *Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, HASH_TABLE_SIZE);
+ for (i=0; i < HASH_TABLE_SIZE; i++) *Free_Constant++ = NIL;
+ Update_FObj_Slot(Unhash_Table, Make_Pointer(TC_VECTOR, Free_Constant));
+ *Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, HASH_TABLE_SIZE);
+ for (i=0; i < HASH_TABLE_SIZE; i++) *Free_Constant++ = NIL;
+
+/* Pure part header */
+ *Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *Free_Constant++ = Make_Non_Pointer(CONSTANT_PART, Length-3);
+
+/* Block trailer */
+ *Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *Free_Constant++ = Make_Non_Pointer(END_OF_BLOCK, Length-1);
+ Update_FObj_Slot(Hash_Number, FIXNUM_0);
+ Set_Pure_Top();
+ return NIL;
+}
+\f
+Pointer Hash_One_Object(Object, New_Unique_ID, Update_UID_Count)
+Pointer Object, New_Unique_ID;
+Boolean Update_UID_Count;
+{ Pointer Bucket;
+ long UID_Hash, Obj_Hash;
+
+ Obj_Hash = Hash_It(Object) % HASH_TABLE_SIZE + 1;
+ Bucket = Vector_Ref(The_Hash_Table, Obj_Hash);
+ while (Type_Code(Bucket) == TC_LIST)
+ { Pointer This_Entry;
+ This_Entry = Vector_Ref(Bucket, CONS_CAR);
+ if (Vector_Ref(This_Entry, CONS_CAR) == Object)
+ return Vector_Ref(This_Entry, CONS_CDR);
+ Bucket = Vector_Ref(Bucket, CONS_CDR);
+ }
+ Primitive_GC_If_Needed(6);
+ UID_Hash = Hash_It(New_Unique_ID) % HASH_TABLE_SIZE + 1;
+
+ Free[CONS_CAR] = Make_Pointer(TC_LIST, Free+2);
+ Free[CONS_CDR] = Vector_Ref(The_Hash_Table, Obj_Hash);
+ Vector_Set(The_Hash_Table, Obj_Hash, Make_Pointer(TC_LIST, Free));
+ Free += 2;
+
+ Free[CONS_CAR] = Object;
+ Free[CONS_CDR] = New_Unique_ID;
+ Free += 2;
+
+ Free[CONS_CAR] = Make_Pointer(TC_LIST, Free-2);
+ Free[CONS_CDR] = Vector_Ref(The_Unhash_Table, UID_Hash);
+ Vector_Set(The_Unhash_Table, UID_Hash, Make_Pointer(TC_LIST, Free));
+ Free += 2;
+ if (Update_UID_Count)
+ Update_FObj_Slot(Hash_Number, FIXNUM_0+1+Get_Integer(New_Unique_ID));
+ return New_Unique_ID;
+}
+\f
+/* (OBJECT-HASH OBJECT)
+ [Primitive number 0x5A]
+ Returns the unique hash number associated with OBJECT. This is
+ used in the implementation of property lists and populations.
+*/
+Built_In_Primitive(Prim_Object_Hash, 1, "OBJECT-HASH")
+{ Primitive_1_Arg();
+
+ The_Hash_Table = Get_Fixed_Obj_Slot(Hash_Table);
+ The_Unhash_Table = Get_Fixed_Obj_Slot(Unhash_Table);
+ if (The_Hash_Table==NIL) Primitive_Error(ERR_NO_HASH_TABLE);
+ HASH_TABLE_SIZE = Vector_Length(The_Unhash_Table);
+ return Hash_One_Object(Arg1, Get_Fixed_Obj_Slot(Hash_Number), true);
+}
+\f
+/* (OBJECT_UNHASH NUMBER)
+ [Primitive number 0x5B]
+ Returns the object associated with a hash number (ie the inverse
+ operation of OBJECT_HASH). Returns NIL if there is no
+ associated object (which will occur if no object was ever hashed
+ to this value, or if that object has been removed by a garbage
+ collection, since these hash table are explicitly built in order
+ NOT to retain objects which would otherwise disappear.)
+*/
+Built_In_Primitive(Prim_Object_Unhash, 1, "OBJECT-UNHASH")
+{ long Obj_Hash;
+ Pointer Bucket;
+ Primitive_1_Arg();
+
+ Arg_1_Type(TC_FIXNUM);
+ The_Unhash_Table = Get_Fixed_Obj_Slot(Unhash_Table);
+ if (The_Unhash_Table==NIL) Primitive_Error(ERR_NO_HASH_TABLE);
+ HASH_TABLE_SIZE = Vector_Length(The_Unhash_Table);
+ Obj_Hash = Hash_It(Arg1) % HASH_TABLE_SIZE + 1;
+ Bucket = Vector_Ref(The_Unhash_Table, Obj_Hash);
+ while (Type_Code(Bucket) == TC_LIST)
+ { Pointer Entry;
+ Entry = Vector_Ref(Bucket, CONS_CAR);
+ if (Arg1 == Vector_Ref(Entry, CONS_CDR))
+ return Vector_Ref(Entry, CONS_CAR);
+ Bucket = Vector_Ref(Bucket, CONS_CDR);
+ }
+ return NIL;
+}
+\f
+/* (REHASH_GC_DAEMON)
+ [Primitive number 0x5C]
+ Used only immediately after a GC, this primitive creates a new
+ pair of hash tables for use with the property list and
+ population mechanisms. It depends on the broken hearts left by
+ the previous GC.
+*/
+Built_In_Primitive(Prim_Rehash_Gc_Daemon, 0, "REHASH-GC-DAEMON")
+{ fast Pointer Chain;
+ Primitive_0_Args();
+
+ The_Hash_Table = Get_Fixed_Obj_Slot(Hash_Table);
+ The_Unhash_Table = Get_Fixed_Obj_Slot(Unhash_Table);
+ if (The_Hash_Table == NIL) return NIL;
+ HASH_TABLE_SIZE = Vector_Length(The_Unhash_Table);
+ Chain = NIL;
+
+/* Create a single chain of all the entries from the hash table ...
+ clear both the hash and unhash tables on the way */
+
+ { fast Pointer Chain_End, Bucket;
+ fast long i;
+ Chain_End = NIL;
+
+ for (i=1; i <= HASH_TABLE_SIZE; i++)
+ { Fast_Vector_Set(The_Unhash_Table, i, NIL);
+ Bucket = Fast_Vector_Ref(The_Hash_Table, i);
+ if (Bucket != NIL)
+ { if (Chain==NIL) Chain = Bucket;
+ else Fast_Vector_Set(Chain_End, CONS_CDR, Bucket);
+ while (Fast_Vector_Ref(Bucket, CONS_CDR) != NIL)
+ Bucket = Fast_Vector_Ref(Bucket, CONS_CDR);
+ Chain_End = Bucket;
+ Fast_Vector_Set(The_Hash_Table, i, NIL);
+ }
+ }
+ }
+
+/* Prim_Rehash_Gc_Daemon continues on the next page */
+\f
+/* Prim_Rehash_Gc_Daemon, continued */
+
+/* Walk the chain rehashing entries that have been relocated */
+
+ { fast Pointer *Scan, Temp, *Old, *Low_Constant;
+ Low_Constant = Constant_Space;
+ while (Chain != NIL)
+ { Scan = Get_Pointer(Fast_Vector_Ref(Chain, CONS_CAR));
+ Chain = Fast_Vector_Ref(Chain, CONS_CDR);
+ Temp = *Scan;
+ switch(GC_Type(Temp))
+ { case GC_Non_Pointer:
+ Hash_One_Object(Temp, Scan[1], false);
+ continue;
+
+#define Rehash_An_Object(obj) Hash_One_Object(obj, Scan[1], false)
+
+ case GC_Cell:
+ case GC_Pair:
+ case GC_Triple:
+ case GC_Quadruple:
+ case GC_Vector:
+ Old = Get_Pointer(Temp);
+ if (Old >= Low_Constant)
+ { Rehash_An_Object(Temp);
+ continue;
+ }
+ Normal_BH(false, Rehash_An_Object(*Scan));
+ continue;
+
+ case GC_Compiled:
+ Old = Get_Pointer(Temp);
+ if (Old >= Low_Constant)
+ { Rehash_An_Object(Temp);
+ continue;
+ }
+ Compiled_BH(false, Rehash_An_Object(*Scan));
+ continue;
+
+ case GC_Special:
+ case GC_Undefined:
+ default:
+ fprintf(stderr,
+ "\nRehash-GC-Daemon: Bad Object: Type = 0x%02x; Datum = %x\n",
+ Type_Code(Temp), Datum(Temp));
+ Microcode_Termination(TERM_INVALID_TYPE_CODE);
+ }
+ }
+ }
+ return TRUTH;
+}
+\f
+/* The format of the open files vector is:
+
+ |----------------|--------|
+ |MANIFEST_VECTOR | n |
+ |----------------|--------|.
+ |FIXNUM | m | . n = length of the vector
+ |----------------|--------| | m = count of used slots
+ Lock |NULL or NM_VECT | n-2 | |
+ .|----------------|--------| | HUNK3s are formatted:
+ . |HUNK3 | ----------> |--------------------|
+ | |----------------|--------| | | Channel number |
+ | |HUNK3 | | | |--------------------|
+ | |----------------|--------| | | File Name |
+ m < |HUNK3 | | > n |--------------------|
+ | |----------------|--------| | | Input or Output |
+ | |HUNK3 | | | |--------------------|
+ | |----------------|--------| |
+ . | ... | | | If the type code of Lock
+ .|----------------|--------| | is NULL, then the vector
+ | ---UNUSED--- | | | is in use by SCHEME and
+ |----------------|--------| | cannot be accessed here.
+ | ... | | .
+ |----------------|--------|.
+ */
+
+#define OPEN_FILES_COUNT 1
+#define OPEN_FILES_INTERLOCK 2
+#define OPEN_FILES_FIRST_FILE 3
+
+#define FILE_CHANNEL 0
+#define FILE_NAME 1
+#define FILE_IN_OR_OUT 2
+\f
+/* (CLOSE_LOST_OPEN_FILES)
+ [Primitive number 0xC7]
+ This primitive can ONLY be called as one of the GC daemons. It
+ is responsible for closing and releasing any files which have
+ "disappeared" due to a garbage collection. It relies on the
+ broken hearts left behind by the GC to do its work.
+
+ Note that it depends on the fact that file blocks are hunk3s in
+ the following way: The broken heart left around is in the first
+ word of the old space copy of the file block.
+*/
+Built_In_Primitive(Prim_Close_Lost_Open_Files, 0, "CLOSE-LOST-OPEN-FILES")
+{ Pointer Open_Files_Vector, *From_File, *To_File;
+ long i, NFiles, Orig_Count;
+ Primitive_0_Args();
+ /* Close_Lost_Open_Files walks down the used entries of the
+ Open Files Vector. For each entry, it either relocates it (if
+ the Garbage Collector provided a forwarding address) or it closes
+ the file and removes the entry from the vector.
+ */
+ Open_Files_Vector = Get_Fixed_Obj_Slot(Open_Files);
+ if ((Open_Files_Vector==NIL) ||
+ (Type_Code(Vector_Ref(Open_Files_Vector,
+ OPEN_FILES_INTERLOCK)) ==
+ TC_NULL)) return NIL;
+ Orig_Count = Get_Integer(Vector_Ref(Open_Files_Vector,
+ OPEN_FILES_COUNT));
+ NFiles = Orig_Count;
+ To_File = Nth_Vector_Loc(Open_Files_Vector, OPEN_FILES_FIRST_FILE);
+
+/* Prim_Close_Lost_Open_Files continues on next page */
+\f
+/* Prim_Close_Lost_Open_Files, continued */
+
+ for (i=0, From_File=To_File; i < Orig_Count; i++, From_File++)
+ { if (Type_Code(*Get_Pointer(*From_File))==TC_BROKEN_HEART)
+ { /* The file block (hunk3) has been moved by the GC which just
+ ended. Relocate the pointer in the Open Files Vector. */
+ Store_Address(*To_File, Datum(*Get_Pointer(*From_File)));
+ To_File += 1;
+ }
+ else
+ { if (Get_Pointer(*From_File) > Constant_Space)
+ { Store_Address(*To_File, Datum(*From_File));
+ To_File += 1;
+ }
+ else
+ { /* The file is no longer accessible, since its file block
+ was not relocated by the GC. Close the file and shrink the
+ Open Files Vector */
+ long File_Number;
+ File_Number = Get_Integer(Vector_Ref(*From_File, FILE_CHANNEL));
+ fclose(Channels[File_Number]);
+ Channels[File_Number] = NULL;
+ NFiles -= 1;
+ }
+ }
+ }
+ for (i=NFiles; i < Orig_Count; i++) *To_File++ = NIL;
+ Vector_Set(Open_Files_Vector, OPEN_FILES_COUNT, FIXNUM_0+NFiles);
+ return TRUTH;
+}
--- /dev/null
+/* 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. *
+* *
+****************************************************************/
+
+/* File: DEBUG.C
+ *
+ * Utilities to help with debugging
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+\f
+void Show_Pure()
+{ Pointer *Obj_Address;
+ long Pure_Size, Total_Size;
+
+ Obj_Address = Constant_Space;
+ while (true)
+ { if (Obj_Address > Free_Constant)
+ { printf("Past end of area.\n");
+ return;
+ }
+ if (Obj_Address == Free_Constant)
+ { printf("Done.\n");
+ return;
+ }
+ Pure_Size = Get_Integer(*Obj_Address);
+ Total_Size = Get_Integer(Obj_Address[1]);
+ printf("0x%x: pure=0x%x, total=0x%x\n",
+ Obj_Address, Pure_Size, Total_Size);
+ if (Type_Code(*Obj_Address) != TC_MANIFEST_SPECIAL_NM_VECTOR)
+ { printf("Missing initial SNMV.\n");
+ return;
+ }
+ if (Type_Code(Obj_Address[1]) != PURE_PART)
+ printf("Missing subsequent pure header.\n");
+ if (Type_Code(Obj_Address[Pure_Size-1]) !=
+ TC_MANIFEST_SPECIAL_NM_VECTOR)
+ { printf("Missing internal SNMV.\n");
+ return;
+ }
+ if (Type_Code(Obj_Address[Pure_Size]) != CONSTANT_PART)
+ { printf("Missing constant header.\n");
+ return;
+ }
+ if (Get_Integer(Obj_Address[Pure_Size]) != Pure_Size)
+ printf("Pure size mismatch 0x%x.\n",
+ Get_Integer(Obj_Address[Pure_Size]));
+ if (Type_Code(Obj_Address[Total_Size-1]) !=
+ TC_MANIFEST_SPECIAL_NM_VECTOR)
+ { printf("Missing ending SNMV.\n");
+ return;
+ }
+ if (Type_Code(Obj_Address[Total_Size]) != END_OF_BLOCK)
+ { printf("Missing ending header.\n");
+ return;
+ }
+ if (Get_Integer(Obj_Address[Total_Size]) != Total_Size)
+ printf("Total size mismatch 0x%x.\n",
+ Get_Integer(Obj_Address[Total_Size]));
+ Obj_Address += Total_Size+1;
+#ifdef FLOATING_ALIGNMENT
+ while (*Obj_Address == Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0))
+ Obj_Address += 1;
+#endif
+ }
+}
+\f
+void Show_Env(The_Env)
+Pointer The_Env;
+{ Pointer *Name_Ptr, *Value_Ptr, Aux_Ptr, Aux_Slot_Ptr;
+ long Count, i;
+ Value_Ptr = Nth_Vector_Loc(The_Env, HEAP_ENV_FUNCTION);
+ if ((Type_Code(*Value_Ptr) == TC_PROCEDURE) ||
+ (Type_Code(*Value_Ptr) == TC_EXTENDED_PROCEDURE))
+ { Name_Ptr = Nth_Vector_Loc(*Value_Ptr, PROCEDURE_LAMBDA_EXPR);
+ Name_Ptr = Nth_Vector_Loc(*Name_Ptr, LAMBDA_FORMALS);
+ Count = Vector_Length(*Name_Ptr);
+ Name_Ptr = Nth_Vector_Loc(*Name_Ptr, 1);
+ for (i=0; i < Count; i++)
+ { Print_Expression(*Name_Ptr++, "Name ");
+ Print_Expression(*Value_Ptr++, " Value ");
+ printf("\n");
+ }
+ Aux_Ptr = Vector_Ref(The_Env, HEAP_ENV_AUX_SLOT);
+ if (Aux_Ptr != NIL)
+ { printf("Auxilliary Variables\n");
+ while (Aux_Ptr != NIL)
+ { Aux_Slot_Ptr = Vector_Ref(Aux_Ptr, CONS_CAR);
+ Print_Expression(Vector_Ref(Aux_Slot_Ptr, CONS_CAR),
+ "Name ");
+ Print_Expression(Vector_Ref(Aux_Slot_Ptr, CONS_CAR),
+ " Value ");
+ Aux_Ptr = Vector_Ref(Aux_Ptr, CONS_CDR);
+ printf("\n");
+ }
+ }
+ }
+ else printf("Not created by a procedure");
+}
+\f
+/* For debugging, given a String, return either a "not interned"
+ * message or the address of the symbol and its global value.
+ */
+
+void Find_Symbol(Scheme_String)
+Pointer Scheme_String;
+{ Pointer Ob_Array, The_Symbol, *Bucket;
+ char *String, *Temp_String;
+ long i, Hashed_Value;
+ String = Scheme_String_To_C_String(Scheme_String);
+ for (Temp_String=String, i=0; *Temp_String == '\0'; i++) Temp_String++;
+ Hashed_Value = Do_Hash(String, i);
+ Ob_Array = Get_Fixed_Obj_Slot(OBArray);
+ Hashed_Value %= Vector_Length(Ob_Array);
+ Bucket = Nth_Vector_Loc(Ob_Array, Hashed_Value);
+ while (*Bucket != NIL)
+ { if (String_Equal(Scheme_String,
+ Vector_Ref(Vector_Ref(*Bucket, CONS_CAR),
+ SYMBOL_NAME)))
+ { The_Symbol = Vector_Ref(*Bucket, CONS_CAR);
+ printf("\nInterned Symbol: 0x%x", The_Symbol);
+ Print_Expression(Vector_Ref(The_Symbol, SYMBOL_GLOBAL_VALUE),
+ "Value");
+ printf("\n");
+ return;
+ }
+ Bucket = Nth_Vector_Loc(*Bucket, CONS_CDR);
+ }
+ printf("\nNot interned.\n");
+}
+\f
+List_Print(Expr)
+Pointer Expr;
+{ int Count;
+ Count = 0;
+ printf("(");
+ while (((Type_Code(Expr) == TC_LIST) ||
+ (Type_Code(Expr) == TC_WEAK_CONS))
+ && Count < MAX_LIST_PRINT)
+ { Print_Expression(Vector_Ref(Expr, CONS_CAR),
+ (Type_Code(Expr)==TC_LIST) ? "" : "{weak}");
+ Expr = Vector_Ref(Expr, CONS_CDR);
+ if (Type_Code(Expr) != TC_NULL) printf(" ");
+ Count += 1;
+ }
+ if (Type_Code(Expr) != TC_NULL)
+ { if (Count==MAX_LIST_PRINT) printf("...");
+ else
+ { printf(". ");
+ Print_Expression(Expr, "");
+ }
+ }
+ printf(")");
+}
+\f
+long Print_Return_Name(Ptr)
+Pointer Ptr;
+{ long index = Get_Integer(Ptr);
+ char *name;
+ if ((index <= MAX_RETURN) &&
+ ((name = Return_Names[index]) != ((char *) NULL)))
+ printf("%s", name);
+ else
+ printf("[0x%x]", index);
+}
+
+void Print_Return(String)
+char *String;
+{ printf("%s: ", String);
+ Print_Return_Name(Fetch_Return());
+ CRLF();
+}
+\f
+extern Boolean Prt_PName();
+
+void Print_Expression(Expr, String)
+char *String;
+Pointer Expr;
+{ if (String[0] != 0) printf("%s: ", String);
+ Do_Printing(Expr, true);
+}
+
+Do_Printing(Expr, Detailed)
+Pointer Expr;
+Boolean Detailed;
+{ long Temp_Address;
+ Boolean Return_After_Print;
+ Temp_Address = Get_Integer(Expr);
+ Return_After_Print = false;
+ if (Type_Code(Expr) > MAX_SAFE_TYPE) printf("{Dangerous}");
+ switch(Safe_Type_Code(Expr))
+ { case TC_ACCESS:
+ printf("[ACCESS (");
+ Expr = Vector_Ref(Expr, ACCESS_NAME);
+ goto SPrint;
+
+ case TC_ASSIGNMENT:
+ printf("[SET! (");
+ Expr = Vector_Ref(Vector_Ref(Expr, ASSIGN_NAME),
+ VARIABLE_SYMBOL);
+ goto SPrint;
+
+ case TC_CHARACTER_STRING:
+ { long Length, i;
+ char *Next, This;
+ printf("\"");
+ Length = Get_Integer(Vector_Ref(Expr, STRING_LENGTH));
+ Next = (char *) Nth_Vector_Loc(Expr, STRING_CHARS);
+ for (i=0; i < Length; i++)
+ { This = *Next++;
+ printf((This < ' ') || (This > '|') ? "\\%03o" : "%c",
+ This);
+ }
+ printf("\"");
+ return;
+ }
+
+/* Do_Printing continues on the next page */
+\f
+/* Do_Printing, continued */
+
+ case TC_DEFINITION:
+ printf("[DEFINE (");
+ Expr = Vector_Ref(Expr, DEFINE_NAME);
+ goto SPrint;
+
+ case TC_FIXNUM:
+ { long A;
+ Sign_Extend(Expr, A);
+ printf("%d", A);
+ return;
+ }
+
+ case TC_BIG_FLONUM: printf("%f", Get_Float(Expr)); return;
+
+ case TC_WEAK_CONS:
+ case TC_LIST: List_Print(Expr); return;
+
+ case TC_NULL:
+ if (Temp_Address==0)
+ { printf("()");
+ return;
+ }
+ printf("[NULL");
+ break;
+
+/* Do_Printing continues on the next page */
+\f
+/* Do_Printing, continued */
+
+ case TC_UNINTERNED_SYMBOL:
+ printf("[UNINTERNED_SYMBOL ("); goto SPrint;
+
+ case TC_INTERNED_SYMBOL:
+ { Pointer Name;
+ char *Next_Char;
+ long Length, i;
+ Return_After_Print = true;
+SPrint:
+ Name = Vector_Ref(Expr, SYMBOL_NAME);
+ Length = Get_Integer(Vector_Ref(Name, STRING_LENGTH));
+ Next_Char = (char *) Nth_Vector_Loc(Name, STRING_CHARS);
+ for (i=0; i < Length; i++)
+ printf("%c", *Next_Char++);
+ if (Return_After_Print) return;
+ printf(")");
+ break;
+ }
+
+/* Do_Printing continues on the next page */
+\f
+/* Do_Printing, continued */
+
+ case TC_VARIABLE:
+ if (Detailed) printf("[VARIABLE (");
+ Expr = Vector_Ref(Expr, VARIABLE_SYMBOL);
+ if (!Detailed) Return_After_Print = true;
+ goto SPrint;
+
+ case TC_BIG_FIXNUM: printf("[BIG_FIXNUM"); break;
+ case TC_BROKEN_HEART: printf("[BROKEN_HEART"); break;
+ case TC_CHARACTER: printf("[CHARACTER"); break;
+ case TC_COMBINATION:
+ printf("[COMBINATION (%d args) 0x%x]",
+ Vector_Length(Expr)-1, Temp_Address);
+ if (Detailed)
+ { printf(" (");
+ Do_Printing(Vector_Ref(Expr, COMB_FN_SLOT), false);
+ printf(" ...)");
+ }
+ return;
+ case TC_COMBINATION_1:
+ printf("[COMBINATION_1 0x%x]", Temp_Address);
+ if (Detailed)
+ { printf(" (");
+ Do_Printing(Vector_Ref(Expr, COMB_1_FN), false);
+ printf(", ");
+ Do_Printing(Vector_Ref(Expr, COMB_1_ARG_1), false);
+ printf(")");
+ }
+ return;
+
+/* Do_Printing continues on the next page */
+\f
+/* Do_Printing, continued */
+
+ case TC_COMBINATION_2:
+ printf("[COMBINATION_2 0x%x]", Temp_Address);
+ if (Detailed)
+ { printf(" (");
+ Do_Printing(Vector_Ref(Expr, COMB_2_FN), false);
+ printf(", ");
+ Do_Printing(Vector_Ref(Expr, COMB_2_ARG_1), false);
+ printf(", ");
+ Do_Printing(Vector_Ref(Expr, COMB_2_ARG_2), false);
+ printf(")");
+ }
+ return;
+ case TC_CELL: printf("[CELL"); break;
+ case TC_COMMENT: printf("[COMMENT"); break;
+ case TC_COMPILED_EXPRESSION: printf("[COMPILED_EXPRESSION"); break;
+ case TC_COMPILED_PROCEDURE:
+ printf("[COMPILED_PROCEDURE"); break;
+ case TC_CONDITIONAL: printf("[CONDITIONAL"); break;
+ case TC_CONTROL_POINT: printf("[CONTROL_POINT"); break;
+ case TC_DELAY: printf("[DELAY"); break;
+ case TC_DELAYED: printf("[DELAYED"); break;
+ case TC_DISJUNCTION: printf("[DISJUNCTION"); break;
+ case TC_ENVIRONMENT:
+ printf("[ENVIRONMENT 0x%x]", Temp_Address);
+ printf(" (from ");
+ Do_Printing(Vector_Ref(Expr, HEAP_ENV_FUNCTION), false);
+ printf(")");
+ return;
+ case TC_EXTENDED_FIXNUM: printf("[EXTENDED_FIXNUM"); break;
+ case TC_EXTENDED_LAMBDA:
+ if (Detailed) printf("[EXTENDED_LAMBDA (");
+ Do_Printing(
+ Vector_Ref(
+ Vector_Ref(Expr, ELAMBDA_NAMES),
+ 1), false);
+ if (Detailed) printf(") 0x%x", Temp_Address);
+ return;
+ case TC_EXTENDED_PROCEDURE:
+ if (Detailed) printf("[EXTENDED_PROCEDURE (");
+ Do_Printing(Vector_Ref(Expr, PROCEDURE_LAMBDA_EXPR), false);
+ if (Detailed) printf(") 0x%x]", Temp_Address);
+ break;
+
+/* Do_Printing continues on the next page */
+\f
+/* Do_Printing, continued */
+
+ case TC_FUTURE: printf("[FUTURE"); break;
+ case TC_HUNK3: printf("[HUNK3"); break;
+ case TC_IN_PACKAGE: printf("[IN_PACKAGE"); break;
+ case TC_LAMBDA:
+ if (Detailed) printf("[LAMBDA (");
+ Do_Printing(
+ Vector_Ref(
+ Vector_Ref(Expr, LAMBDA_FORMALS),
+ 1), false);
+ if (Detailed) printf(") 0x%x]", Temp_Address);
+ return;
+ case TC_LEXPR: printf("[LEXPR"); break;
+ case TC_MANIFEST_NM_VECTOR: printf("[MANIFEST_NM_VECTOR"); break;
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ printf("[MANIFEST_SPECIAL_NM_VECTOR"); break;
+ case TC_NON_MARKED_VECTOR: printf("[NON_MARKED_VECTOR"); break;
+ case TC_PCOMB0: printf("[PCOMB0"); break;
+ case TC_PCOMB1: printf("[PCOMB1"); break;
+ case TC_PCOMB2: printf("[PCOMB2"); break;
+ case TC_PCOMB3: printf("[PCOMB3"); break;
+ case TC_PRIMITIVE:
+ printf("[PRIMITIVE "); Prt_PName(Temp_Address);
+ printf("]"); return;
+ case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE_EXTERNAL"); break;
+ case TC_PROCEDURE:
+ if (Detailed) printf("[PROCEDURE (");
+ Do_Printing(Vector_Ref(Expr, PROCEDURE_LAMBDA_EXPR), false);
+ if (Detailed) printf(") 0x%x]", Temp_Address);
+ return;
+
+/* Do_Printing continues on the next page */
+\f
+/* Do_Printing, continued */
+
+ case TC_RETURN_CODE:
+ printf("[RETURN_CODE ");
+ Print_Return_Name(Expr);
+ printf("]");
+ return;
+ case TC_SCODE_QUOTE: printf("[SCODE_QUOTE"); break;
+ case TC_SEQUENCE_2: printf("[SEQUENCE_2"); break;
+ case TC_SEQUENCE_3: printf("[SEQUENCE_3"); break;
+ case TC_THE_ENVIRONMENT: printf("[THE_ENVIRONMENT"); break;
+
+ case TC_TRAP:
+ printf("[TRAP ");
+ Print_Expression(Vector_Ref(Expr, TRAP_TAG), " tag");
+ Print_Expression(Vector_Ref(Expr, TRAP_DEFAULT), " default");
+ Print_Expression(Vector_Ref(Expr, TRAP_FROB), " frob");
+ printf("]");
+ return;
+
+ case TC_TRUE:
+ if (Temp_Address == 0)
+ { printf("#!true");
+ return;
+ }
+ printf("[TRUE");
+ break;
+ case TC_UNASSIGNED:
+ if (Temp_Address == UNBOUND)
+ { printf("#!UNBOUND");
+ return;
+ }
+ else if (Temp_Address == UNASSIGNED)
+ { printf("#!UNASSIGNED");
+ return;
+ }
+ else printf("[UNASSIGNED"); break;
+ case TC_VECTOR: printf("[VECTOR"); break;
+ case TC_VECTOR_16B: printf("[VECTOR_16B"); break;
+ case TC_VECTOR_1B: printf("[VECTOR_1B"); break;
+ default: printf("[0x%x", Type_Code(Expr));
+ }
+ printf(" 0x%x]", Temp_Address);
+}
+\f
+Boolean Print_One_Continuation_Frame(Temp)
+Pointer Temp;
+{ Pointer Expr;
+ Print_Expression(Temp, "Return code");
+ CRLF();
+ Expr = Pop();
+ Print_Expression(Expr, "Expression");
+ printf("\n");
+ if ((Datum(Temp) == RC_END_OF_COMPUTATION) ||
+ (Datum(Temp) == RC_HALT)) return true;
+ if (Datum(Temp) == RC_JOIN_STACKLETS)
+ Stack_Pointer = Previous_Stack_Pointer(Expr);
+ return false;
+}
+\f
+/* Back_Trace relies on (a) only a call to Save_Cont puts a return code on the
+ stack; (b) Save_Cont pushes the expression first. */
+
+void Back_Trace()
+{ Pointer Temp, *Old_Stack;
+ Back_Trace_Entry_Hook();
+ Old_Stack = Stack_Pointer;
+ while (true)
+ { if (Return_Hook_Address == &Top_Of_Stack())
+ { Temp = Pop();
+ if (Temp != Make_Non_Pointer(TC_RETURN_CODE, RC_RETURN_TRAP_POINT))
+ printf("\n--> Return trap is missing here <--\n");
+ else
+ { printf("\n[Return trap found here as expected]\n");
+ Temp = Old_Return_Code;
+ }
+ }
+ else Temp = Pop();
+ if (Type_Code(Temp) == TC_RETURN_CODE)
+ { if (Print_One_Continuation_Frame(Temp))
+ break;
+ }
+ else
+ { Print_Expression(Temp, " ...");
+ if (Safe_Type_Code(Temp) == TC_MANIFEST_NM_VECTOR)
+ { Stack_Pointer = Simulate_Popping(Get_Integer(Temp));
+ printf(" (skipping)");
+ }
+ printf("\n");
+ }
+ }
+ Stack_Pointer = Old_Stack;
+ Back_Trace_Exit_Hook();
+}
+
+void Print_Stack(SP)
+Pointer *SP;
+{ Pointer *Saved_SP;
+ Saved_SP = Stack_Pointer;
+ Stack_Pointer = SP;
+ Back_Trace();
+ Stack_Pointer = Saved_SP;
+ return;
+}
+\f
+Boolean Prt_PName(Number)
+long Number;
+{ if ((Number < 0) ||
+ (Number > MAX_PRIMITIVE) ||
+ (Primitive_Names[Number] == NULL))
+ { printf("Unknown primitive 0x%08x", Number);
+ return false;
+ }
+ else
+ { printf("%s", Primitive_Names[Number]);
+ return true;
+ }
+}
+
+void Print_Primitive(Number)
+long Number;
+{ short NArgs;
+
+ printf("Primitive: ");
+ if (Prt_PName(Number)) NArgs = (int) Arg_Count_Table[Number];
+ else NArgs = 3; /* Unknown primitive */
+ printf("\n");
+ if (NArgs > 0)
+ { Print_Expression(Stack_Ref(0), "...Arg 1");
+ printf("\n");
+ }
+ if (NArgs > 1)
+ { Print_Expression(Stack_Ref(1), "...Arg 2");
+ printf("\n");
+ }
+ if (NArgs > 2)
+ { Print_Expression(Stack_Ref(2), "...Arg 3");
+ printf("\n");
+ }
+}
+\f
+Debug_Printer(Expr)
+Pointer Expr;
+{ Print_Expression(Expr, "");
+ putchar('\n');
+}
+
+/* (TEMP_PRINTER OBJECT)
+ [Primitive number 0xB2]
+ A cheap, built-in printer intended for debugging the
+ interpreter.
+*/
+Built_In_Primitive(Prim_Temp_Printer, 1, "TEMP-PRINTER")
+{ Primitive_1_Arg();
+ Debug_Printer(Arg1);
+ return TRUTH;
+}
+\f
+/* Code for interactively setting and clearing the interpreter
+ debugging flags. Invoked via the "D" command to the ^B
+ handler or during each FASLOAD.
+*/
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+#define D_EVAL 0
+#define D_HEX_INPUT 1
+#define D_FILE_LOAD 2
+#define D_RELOC 3
+#define D_INTERN 4
+#define D_CONT 5
+#define D_PRIMITIVE 6
+#define D_LOOKUP 7
+#define D_DEFINE 8
+#define D_GC 9
+#define D_UPGRADE 10
+#define D_DUMP 11
+#define D_TRACE_ON_ERROR 12
+#define D_PER_FILE 13
+#define D_BIGNUM 14
+#define D_FLUIDS 15
+#define LAST_NORMAL_SWITCH 15
+
+Boolean *Find_Flag(Num)
+int Num;
+{ switch (Num)
+ { case D_EVAL: return &Eval_Debug;
+ case D_HEX_INPUT: return &Hex_Input_Debug;
+ case D_FILE_LOAD: return &File_Load_Debug;
+ case D_RELOC: return &Reloc_Debug;
+ case D_INTERN: return &Intern_Debug;
+ case D_CONT: return &Cont_Debug;
+ case D_PRIMITIVE: return &Primitive_Debug;
+ case D_LOOKUP: return &Lookup_Debug ;
+ case D_DEFINE: return &Define_Debug;
+ case D_GC: return &GC_Debug;
+ case D_UPGRADE: return &Upgrade_Debug;
+ case D_DUMP: return &Dump_Debug;
+ case D_TRACE_ON_ERROR: return &Trace_On_Error;
+ case D_PER_FILE: return &Per_File;
+ case D_BIGNUM: return &Bignum_Debug;
+ case D_FLUIDS: return &Fluids_Debug;
+ More_Debug_Flag_Cases();
+ default: show_flags(true); return NULL;
+ }
+}
+\f
+set_flag(Num, Value)
+int Num;
+Boolean Value;
+{ Boolean *Flag = Find_Flag(Num);
+ if (Flag != NULL) *Flag = Value;
+ Set_Flag_Hook();
+}
+
+char *Flag_Name(Num)
+int Num;
+{ switch(Num)
+ { case D_EVAL: return "Eval_Debug";
+ case D_HEX_INPUT: return "Hex_Input_Debug";
+ case D_FILE_LOAD: return "File_Load_Debug";
+ case D_RELOC: return "Reloc_Debug";
+ case D_INTERN: return "Intern_Debug";
+ case D_CONT: return "Cont_Debug";
+ case D_PRIMITIVE: return "Primitive_Debug";
+ case D_LOOKUP: return "Lookup_Debug";
+ case D_DEFINE: return "Define_Debug";
+ case D_GC: return "GC_Debug";
+ case D_UPGRADE: return "Upgrade_Debug";
+ case D_DUMP: return "Dump_Debug";
+ case D_TRACE_ON_ERROR: return "Trace_On_Error";
+ case D_PER_FILE: return "Per_File";
+ case D_BIGNUM: return "Bignum_Debug";
+ case D_FLUIDS: return "Fluids_Debug";
+ More_Debug_Flag_Names();
+ default: return "Unknown Debug Flag";
+ }
+}
+\f
+show_flags(All)
+Boolean All;
+{ int i;
+ for (i=0; i <= LAST_SWITCH; i++)
+ { Boolean Value = *Find_Flag(i);
+ if (All || Value)
+ { printf("Flag %d (%s) is %s.\n",
+ i, Flag_Name(i), Value? "set" : "clear");
+ }
+ }
+}
+
+extern char OS_tty_tyi();
+
+#define C_STRING_LENGTH 256
+\f
+void Handle_Debug_Flags()
+{ char c, input_string[C_STRING_LENGTH];
+ int Which, free;
+ Boolean interrupted;
+ show_flags(false);
+ while (true)
+ { interrupted = false;
+ printf("Clear<number>, Set<number>, Done, ?, or Halt: ");
+ OS_Flush_Output_Buffer();
+
+ /* Considerably haired up to go through standard (safe) interface */
+
+ c = OS_tty_tyi(false, &interrupted);
+ if (interrupted) return;
+ for (free = 0; free < C_STRING_LENGTH; free++)
+ { input_string[free] = OS_tty_tyi(false, &interrupted);
+ if (interrupted) return;
+ if (input_string[free] == '\n')
+ { input_string[free] = '\0';
+ break;
+ }
+ }
+
+/* Handle_Debug_Flags continues on the next page */
+\f
+/* Handle_Debug_Flags, continued */
+
+ switch (c)
+ { case 'c':
+ case 'C': Which=debug_getdec(input_string);
+ set_flag(Which, false);
+ break;
+ case 's':
+ case 'S': Which=debug_getdec(input_string);
+ set_flag(Which, true);
+ break;
+ case 'd':
+ case 'D': return;
+ case 'h':
+ case 'H': Microcode_Termination(TERM_HALT);
+
+ case '?':
+ default : show_flags(true);
+ break;
+ }
+ }
+}
+
+int normal_debug_getdec(str)
+{ int Result;
+ sscanf(str, "%d", &Result);
+ return Result;
+}
+
+#else /* ENABLE_DEBUGGING_TOOLS */
+void Handle_Debug_Flags()
+{ fprintf(stderr, "Not a debugging version. No flags to handle.\n");
+ return;
+}
+#endif /* not ENABLE_DEBUGGING_TOOLS */
--- /dev/null
+/* EMACS should recognize -*- C -*- code by itself. */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: DEFAULT.H
+ *
+ * This file contains default definitions for some hooks which
+ * various machines require. These machines define these hooks
+ * in CONFIG.H and this file defines them only if they remain
+ * undefined.
+ *
+ */
+\f
+/* Compiler bug fixes. */
+
+#ifndef And2
+#define And2(x, y) ((x) && (y))
+#define And3(x, y, z) ((x) && (y) && (z))
+#define Or2(x, y) ((x) || (y))
+#define Or3(x, y, z) ((x) || (y) || (z))
+#endif
+
+#ifndef Fetch
+/* These definitions allow a true multi-processor with shared memory
+ but no atomic longword operations (Butterfly and Concert,
+ for example) to supply their own atomic operators in config.h.
+*/
+#define Fetch(P) (P)
+#define Store(P, S) (P) = (S)
+#endif
+
+#ifndef Get_Fixed_Obj_Slot
+#define Get_Fixed_Obj_Slot(N) Fast_User_Vector_Ref(Fixed_Objects, N)
+#define Set_Fixed_Obj_Slot(N,S) Fast_User_Vector_Set(Fixed_Objects, N, S)
+#define Update_FObj_Slot(N, S) Set_Fixed_Obj_Slot(N, S)
+#define Declare_Fixed_Objects() Pointer Fixed_Objects;
+#define Valid_Fixed_Obj_Vector() \
+ (Type_Code(Fixed_Objects) == TC_VECTOR)
+#define Save_Fixed_Obj(Save_FO) \
+ Save_FO = Fixed_Objects; \
+ Fixed_Objects = NIL;
+#define Restore_Fixed_Obj(Save_FO) \
+ Fixed_Objects = Save_FO
+#endif
+
+
+/* Atomic swapping hook. Used extensively. */
+
+#ifndef Swap_Pointers
+extern Pointer Swap_Temp;
+#define Swap_Pointers(P, S) \
+(Swap_Temp = *(P), *(P) = (S), Swap_Temp)
+#endif
+\f
+#ifndef Set_Pure_Top
+#ifndef USE_STACKLETS
+#define Set_Pure_Top() \
+ Align_Float(Free_Constant); \
+ Set_Stack_Guard(Free_Constant+STACK_GUARD_SIZE)
+#define Test_Pure_Space_Top(New_Top) \
+ ((New_Top+STACK_GUARD_SIZE) <= Stack_Pointer)
+#define Absolute_Stack_Base Free_Constant
+
+#ifndef Initialize_Stack
+#define Initialize_Stack() \
+ Stack_Top = Highest_Allocated_Address; \
+ Stack_Pointer = Stack_Top; \
+ Set_Stack_Guard(Free_Constant + STACK_GUARD_SIZE)
+#endif
+
+#else /* Stacklets in use */
+
+#define Set_Pure_Top() Align_Float(Free_Constant)
+#define Test_Pure_Space_Top(New_Top) \
+ (New_Top <= Highest_Allocated_Address)
+#endif
+#endif
+\f
+/* Character IO hooks. Used extensively. */
+
+#ifndef OS_Put_C
+#define OS_Put_C putc
+#endif
+
+#ifndef OS_Get_C
+#define OS_Get_C getc
+#endif
+
+/* Used in BOOT.C */
+
+#ifndef term_type
+#define term_type void
+#endif
+
+#ifndef Command_Line_Hook
+#define Command_Line_Hook()
+#endif
+
+#ifndef Exit_Scheme_Declarations
+#define Exit_Scheme_Declarations
+#endif
+
+#ifndef Init_Exit_Scheme
+#define Init_Exit_Scheme()
+#endif
+
+#ifndef Exit_Scheme
+#define Exit_Scheme exit
+#endif
+\f
+/* Used in various places. */
+
+#ifndef Init_Fixed_Objects
+#define Init_Fixed_Objects() \
+ Default_Init_Fixed_Objects(Fixed_Objects)
+#endif
+
+#ifndef Set_Fixed_Obj_Hook
+#define Set_Fixed_Obj_Hook(New_Vector) \
+ Fixed_Objects = New_Vector
+#endif
+
+#ifndef Entry_Hook
+#define Entry_Hook()
+#endif
+
+#ifndef Exit_Hook
+#define Exit_Hook()
+#endif
+
+#ifndef Sys_Clock
+#define Sys_Clock() System_Clock()
+#endif
+\f
+/* Used in DEBUG.C */
+
+#ifndef Back_Trace_Entry_Hook
+#define Back_Trace_Entry_Hook()
+#endif
+
+#ifndef Back_Trace_Exit_Hook
+#define Back_Trace_Exit_Hook()
+#endif
+
+#ifndef More_Debug_Flag_Cases
+#define More_Debug_Flag_Cases()
+#endif
+
+#ifndef Set_Flag_Hook
+#define Set_Flag_Hook()
+#endif
+
+#ifndef More_Debug_Flag_Names
+#define More_Debug_Flag_Names()
+#endif
+
+#ifndef LAST_SWITCH
+#define LAST_SWITCH LAST_NORMAL_SWITCH
+#endif
+
+#ifndef debug_getdec
+#define debug_getdec normal_debug_getdec
+#endif
+\f
+/* Used in EXTERN.H */
+
+#ifndef More_Debug_Flag_Externs
+#define More_Debug_Flag_Externs()
+#endif
+
+/* Used in FASDUMP.C */
+
+#ifndef Band_Dump_Permitted
+#define Band_Dump_Permitted()
+#endif
+
+#ifndef Band_Load_Hook
+#define Band_Load_Hook()
+#endif
+
+#ifndef Fasdump_Exit_Hook
+#define Fasdump_Exit_Hook()
+#endif
+
+#ifndef Fasdump_Free_Calc
+#define Fasdump_Free_Calc(NewFree, NewMemtop, ignored) \
+ NewFree = Unused_Heap; \
+ NewMemTop = Unused_Heap_Top
+#endif
+
+/* Used in FASLOAD.C */
+
+#ifndef Open_File_Hook
+#define Open_File_Hook(ignore)
+#endif
+
+#ifndef Close_File_Hook
+#define Close_File_Hook()
+#endif
+
+/* Used in FLONUM.H and GENERIC.C */
+
+#ifndef double_into_fixnum
+#define double_into_fixnum(what, target) \
+ target = Make_Non_Pointer(TC_FIXNUM, ((long) (what)))
+#endif
+\f
+/* Used in INTERPRET.C */
+
+/* Primitive calling code. */
+
+#ifndef ENABLE_DEBUGGING_TOOLS
+#define Apply_Primitive(N) (*(Primitive_Table[N]))()
+#else
+extern Pointer Apply_Primitive();
+#endif
+
+#ifndef Metering_Apply_Primitive
+#define Metering_Apply_Primitive(Loc, N) \
+Loc = Apply_Primitive(N)
+#endif
+
+#ifndef Eval_Ucode_Hook()
+#define Eval_Ucode_Hook()
+#endif
+
+#ifndef Pop_Return_Ucode_Hook()
+#define Pop_Return_Ucode_Hook()
+#endif
+
+#ifndef Apply_Ucode_Hook()
+#define Apply_Ucode_Hook()
+#endif
+
+#ifndef End_GC_Hook
+#define End_GC_Hook()
+#endif
+\f
+/* Used in STORAGE.C */
+
+#ifndef More_Debug_Flag_Allocs
+#define More_Debug_Flag_Allocs()
+#endif
+
+/* Used in UTILS.C */
+
+#ifndef Global_Interrupt_Hook
+#define Global_Interrupt_Hook()
+#endif
+
+#ifndef Error_Exit_Hook
+#define Error_Exit_Hook()
+#endif
+
+/* Used in LOOKUP.C */
+
+/* Permit caching of incrementally defined variables */
+#ifndef Allow_Aux_Compilation
+#define Allow_Aux_Compilation true
+#endif
--- /dev/null
+/* Hey EMACS, this is -*- C -*- code! */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: DUMPWORLD.C
+ *
+ * This file contains a primitive to dump an executable version of Scheme.
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+\f
+#ifndef unix
+#include "Error: dumpworld.c does not work on non-unix machines."
+#endif
+
+/* Suns and others probably work also, but we have no machines
+ where to try them out.
+*/
+
+#if (!defined(vax) && !defined(hp9000s200) && !defined(celerity))
+#include "Error: dumpworld.c only supported for vax and hp9000s200."
+#endif
+
+/* Making sure that IO will be alright when restored. */
+
+Boolean there_are_open_files()
+{ register int i = FILE_CHANNELS;
+ while (i > 0)
+ if (Channels[--i] != NULL) return true;
+ return false;
+}
+
+/* These two procedures depend on the internal structure of a
+ FILE object. See /usr/include/stdio.h for details. */
+
+long Save_Input_Buffer()
+{ long result = (stdin)->_cnt;
+ (stdin)->_cnt = 0;
+ return result;
+}
+
+void Restore_Input_Buffer(Buflen)
+fast long Buflen;
+{ (stdin)->_cnt = Buflen;
+ return;
+}
+
+extern int end, etext, edata;
+extern int unexec();
+static jmp_buf for_error;
+\f
+/* The primitive itself. Uses unexec from GNU-EMACS */
+
+Define_Primitive(Prim_Dump_World, 1, "DUMP-WORLD")
+{ char *fname;
+ extern Boolean Was_Scheme_Dumped;
+ Boolean Saved_Dumped_Value = Was_Scheme_Dumped;
+ Boolean Saved_Photo_Open = Photo_Open;
+ int Result;
+ long Buflen;
+
+ Primitive_1_Arg();
+ Arg_1_Type(TC_CHARACTER_STRING);
+
+ if (there_are_open_files())
+ Primitive_Error(ERR_OUT_OF_FILE_HANDLES);
+
+ fname = Scheme_String_To_C_String(Arg1);
+
+ /* Set up for restore */
+
+ /* IO: flushing pending output, and flushing cached input. */
+ fflush(stdout);
+ fflush(stderr);
+ if (Photo_Open)
+ { fflush(Photo_File_Handle);
+ Photo_Open = false;
+ }
+ Buflen = Save_Input_Buffer();
+
+ Was_Scheme_Dumped = true;
+ Val = TRUTH;
+ OS_Quit();
+ Pop_Primitive_Frame(1);
+
+ /* Dump! */
+
+ Result = setjmp(for_error);
+ if (Result == 0)
+ Result = unexec(fname,
+ Saved_argv[0],
+ ((unsigned) (&etext)),
+ ((unsigned) 0),
+ ((unsigned) 0)
+ );
+
+ /* Restore State */
+
+ OS_Re_Init();
+ Val = NIL;
+ Was_Scheme_Dumped = Saved_Dumped_Value;
+ /* IO: Restoring cached input for this job. */
+ Restore_Input_Buffer(Buflen);
+ Photo_Open = Saved_Photo_Open;
+
+ if (Result != 0)
+ { Push(Arg1); /* Since popped above */
+ Primitive_Error(ERR_FASL_FILE_TOO_BIG);
+ }
+ longjmp(*Back_To_Eval, PRIM_POP_RETURN);
+}
+\f
+/* These things are needed by unexec */
+
+#ifdef hpux
+#define USG
+#define HPUX
+#endif
+
+char *start_of_text()
+{
+#if false
+ return ((char *) _start);
+#else
+ return ((char *) 0);
+#endif
+}
+
+char *start_of_data()
+{ return ((char *) (&etext));
+}
+
+#define has_error
+
+void error(msg, a1, a2)
+char *msg;
+int a1, a2;
+{ putc('\n', stderr);
+ fprintf(stderr, msg, a1, a2);
+ putc('\n', stderr);
+ longjmp(for_error, -1);
+}
+
+#include "unexec.c"
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: dump.c
+ * This file contains common code for dumping internal format binary files.
+ */
+\f
+#include "fasl.h"
+
+Write_File(Heap_Count, Heap_Relocation, Dumped_Object,
+ Constant_Count, Constant_Relocation, Prim_Exts)
+Pointer *Heap_Relocation, *Dumped_Object,
+ *Constant_Relocation, *Prim_Exts;
+long Heap_Count, Constant_Count;
+{ Pointer Buffer[FASL_HEADER_LENGTH];
+ long i;
+
+#ifdef DEBUG
+#ifndef Heap_In_Low_Memory
+ printf("\nMemory_Base = 0x%x\n", Memory_Base);
+#endif
+ printf("\nHeap_Relocation=0x%x, dumped as 0x%x\n",
+ Heap_Relocation, Make_Pointer(TC_BROKEN_HEART, Heap_Relocation));
+ printf("\nDumped object=0x%x, dumped as 0x%x\n",
+ Dumped_Object, Make_Pointer(TC_BROKEN_HEART, Dumped_Object));
+#endif
+ Buffer[FASL_Offset_Marker] = FASL_FILE_MARKER;
+ Buffer[FASL_Offset_Heap_Count] =
+ Make_Non_Pointer(TC_BROKEN_HEART, Heap_Count);
+ Buffer[FASL_Offset_Heap_Base] =
+ Make_Pointer(TC_BROKEN_HEART, Heap_Relocation);
+ Buffer[FASL_Offset_Dumped_Obj] =
+ Make_Pointer(TC_BROKEN_HEART, Dumped_Object);
+ Buffer[FASL_Offset_Const_Count] =
+ Make_Non_Pointer(TC_BROKEN_HEART, Constant_Count);
+ Buffer[FASL_Offset_Const_Base] =
+ Make_Pointer(TC_BROKEN_HEART, Constant_Relocation);
+ Buffer[FASL_Offset_Version] =
+ Make_Version(FASL_FORMAT_VERSION,
+ FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
+ Buffer[FASL_Offset_Stack_Top] =
+#ifdef USE_STACKLETS
+ Make_Pointer(TC_BROKEN_HEART, 0); /* Nothing in stack area */
+#else
+ Make_Pointer(TC_BROKEN_HEART, Stack_Top);
+#endif
+ Buffer[FASL_Offset_Ext_Loc] =
+ Make_Pointer(TC_BROKEN_HEART, Prim_Exts);
+ for (i=FASL_Offset_First_Free; i < FASL_HEADER_LENGTH; i++)
+ Buffer[i] = NIL;
+ Write_Data(FASL_HEADER_LENGTH, (char *) Buffer);
+ if (Heap_Count != 0) Write_Data(Heap_Count, (char *) Heap_Relocation);
+ if (Constant_Count != 0)
+ Write_Data(Constant_Count, (char *) Constant_Relocation);
+}
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: ERRORS.H
+ *
+ * Error and termination code declarations. This must correspond
+ * to UTABMD.SCM
+ *
+ */
+\f
+/* All error and termination codes must be positive
+ * to allow primitives to return either an error code
+ * or a primitive flow control value (see CONST.H)
+ */
+
+#define ERR_BAD_ERROR_CODE 0x00
+#define ERR_UNBOUND_VARIABLE 0x01
+#define ERR_UNASSIGNED_VARIABLE 0x02
+#define ERR_INAPPLICABLE_OBJECT 0x03
+#define ERR_OUT_OF_HASH_NUMBERS 0x04 /* Not generated */
+/* #define ERR_ENVIRONMENT_CHAIN_TOO_DEEP 0x05 */
+#define ERR_BAD_FRAME 0x06
+#define ERR_BROKEN_COMPILED_VARIABLE 0x07
+#define ERR_UNDEFINED_USER_TYPE 0x08
+#define ERR_UNDEFINED_PRIMITIVE 0x09
+#define ERR_EXTERNAL_RETURN 0x0A
+#define ERR_EXECUTE_MANIFEST_VECTOR 0x0B
+#define ERR_WRONG_NUMBER_OF_ARGUMENTS 0x0C
+#define ERR_ARG_1_WRONG_TYPE 0x0D
+#define ERR_ARG_2_WRONG_TYPE 0x0E
+#define ERR_ARG_3_WRONG_TYPE 0x0F
+#define ERR_ARG_1_BAD_RANGE 0x10
+#define ERR_ARG_2_BAD_RANGE 0x11
+#define ERR_ARG_3_BAD_RANGE 0x12
+/* #define ERR_BAD_COMBINATION 0x13 */
+/* #define ERR_FASDUMP_OVERFLOW 0x14 */
+#define ERR_BAD_INTERRUPT_CODE 0x15 /* Not generated */
+/* #define ERR_NO_ERRORS 0x16 */
+#define ERR_FASL_FILE_TOO_BIG 0x17
+#define ERR_FASL_FILE_BAD_DATA 0x18
+#define ERR_IMPURIFY_OUT_OF_SPACE 0x19
+\f
+/* The following do not exist in the 68000 version */
+#define ERR_WRITE_INTO_PURE_SPACE 0x1A
+/* #define ERR_LOSING_SPARE_HEAP 0x1B */
+#define ERR_NO_HASH_TABLE 0x1C
+#define ERR_BAD_SET 0x1D
+#define ERR_ARG_1_FAILED_COERCION 0x1E
+#define ERR_ARG_2_FAILED_COERCION 0x1F
+#define ERR_OUT_OF_FILE_HANDLES 0x20
+/* #define ERR_SHELL_DIED 0x21 */
+
+/* Late additions to both 68000 and C world */
+#define ERR_ARG_4_BAD_RANGE 0x22
+#define ERR_ARG_5_BAD_RANGE 0x23
+#define ERR_ARG_6_BAD_RANGE 0x24
+#define ERR_ARG_7_BAD_RANGE 0x25
+#define ERR_ARG_8_BAD_RANGE 0x26
+#define ERR_ARG_9_BAD_RANGE 0x27
+#define ERR_ARG_10_BAD_RANGE 0x28
+#define ERR_ARG_4_WRONG_TYPE 0x29
+#define ERR_ARG_5_WRONG_TYPE 0x2A
+#define ERR_ARG_6_WRONG_TYPE 0x2B
+#define ERR_ARG_7_WRONG_TYPE 0x2C
+#define ERR_ARG_8_WRONG_TYPE 0x2D
+#define ERR_ARG_9_WRONG_TYPE 0x2E
+#define ERR_ARG_10_WRONG_TYPE 0x2F
+#define ERR_INAPPLICABLE_CONTINUATION 0x30
+#define ERR_COMPILED_CODE_ERROR 0x31
+#define ERR_FLOATING_OVERFLOW 0x32
+
+#define MAX_ERROR 0x32
+\f
+/* Termination codes: the interpreter halts on these */
+
+#define TERM_HALT 0x00
+#define TERM_DISK_RESTORE 0x01
+#define TERM_BROKEN_HEART 0x02
+#define TERM_NON_POINTER_RELOCATION 0x03
+#define TERM_BAD_ROOT 0x04
+#define TERM_NON_EXISTENT_CONTINUATION 0x05
+#define TERM_BAD_STACK 0x06
+#define TERM_STACK_OVERFLOW 0x07
+#define TERM_STACK_ALLOCATION_FAILED 0x08
+#define TERM_NO_ERROR_HANDLER 0x09
+#define TERM_NO_INTERRUPT_HANDLER 0x0A
+#define TERM_UNIMPLEMENTED_CONTINUATION 0x0B
+#define TERM_EXIT 0x0C
+#define TERM_BAD_PRIMITIVE_DURING_ERROR 0x0D
+#define TERM_EOF 0x0E
+#define TERM_BAD_PRIMITIVE 0x0F
+#define TERM_TERM_HANDLER 0x10
+#define TERM_END_OF_COMPUTATION 0x11
+#define TERM_INVALID_TYPE_CODE 0x12
+#define TERM_COMPILER_DEATH 0x13
+#define TERM_GC_OUT_OF_SPACE 0x14
+#define TERM_NO_SPACE 0x15
--- /dev/null
+/* 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: EXTERN.C
+ *
+ * This file contains the support routines for externally supplied
+ * procedure -- that is, primitives written in C and available
+ * in Scheme, but not always present in all versions of the interpreter.
+ * Thus, these objects are always referenced externally by name and
+ * converted to numeric references only for the duration of a single
+ * Scheme session.
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+\f
+Pointer Undefined_Externals = NIL;
+
+#define NUndefined() \
+((Undefined_Externals==NIL) ? \
+ 0 : Get_Integer(User_Vector_Ref(Undefined_Externals, 0)))
+
+#define CHUNK_SIZE 20 /* Grow undefined vector by this much */
+
+/* (GET-EXTERNALS-COUNT)
+ [Primitive number 0x101]
+ Returns a CONS of the number of external primitives defined in this
+ interpreter and the number of external primitives referenced but
+ not defined.
+*/
+
+Built_In_Primitive(Prim_Get_External_Count, 0, "GET-EXTERNALS-COUNT")
+{ Primitive_0_Args();
+ *Free++ = FIXNUM_0 + (MAX_EXTERNAL_PRIMITIVE + 1);
+ *Free++ = FIXNUM_0 + NUndefined();
+ return Make_Pointer(TC_LIST, Free-2);
+}
+\f
+Pointer Get_Name_Of_Impl_External(Number)
+long Number;
+{ Pointer Result;
+ Pointer *Orig_Result, *Orig_Free = Free;
+
+ Result = C_String_To_Scheme_String(Ext_Prim_Desc[Number].name);
+ Free[SYMBOL_NAME] = Result;
+ Free[SYMBOL_GLOBAL_VALUE] = NIL;
+ Result = Make_Pointer(TC_UNINTERNED_SYMBOL, Free);
+ Orig_Result = Free;
+ Free += 2;
+ Intern(&Result);
+ if (Get_Pointer(Result) != Orig_Result) Free = Orig_Free;
+ return Result;
+}
+
+/* (GET-EXTERNAL-NAME n)
+ [Primitive number 0x102]
+ Given a number, return the string for the name of the corresponding
+ external primitive. An error if the number is out of range.
+ External primitives start at 0.
+*/
+
+Built_In_Primitive(Prim_Get_Ext_Name, 1, "GET-EXTERNAL-NAME")
+{ long Number, TC;
+ Primitive_1_Arg();
+
+ TC = Type_Code(Arg1);
+ if ((TC != TC_FIXNUM) && (TC != TC_PRIMITIVE_EXTERNAL))
+ Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ Range_Check(Number, Arg1, 0, MAX_EXTERNAL_PRIMITIVE+NUndefined(),
+ ERR_ARG_1_BAD_RANGE);
+ if (Number <= MAX_EXTERNAL_PRIMITIVE)
+ return Get_Name_Of_Impl_External(Number);
+ else return User_Vector_Ref(Undefined_Externals,
+ Number-MAX_EXTERNAL_PRIMITIVE);
+}
+\f
+Boolean PGEN_Compare(C_String, S_String)
+char *C_String;
+Pointer S_String;
+{ char *S = (char *) Nth_Vector_Loc(S_String, STRING_CHARS);
+ long N = Get_Integer(Fast_Vector_Ref(S_String, STRING_LENGTH));
+ long i;
+ for (i=0; i < N; i++) if (*S++ != *C_String++) return false;
+ return (*C_String == 0);
+}
+
+long Get_Ext_Number(Symbol, Intern_It)
+Pointer Symbol, Intern_It;
+{ Pointer *Next, Name = Fast_Vector_Ref(Symbol, SYMBOL_NAME);
+ long i, Max;
+
+ for (i=0; i <= MAX_EXTERNAL_PRIMITIVE; i++)
+ if (PGEN_Compare(Ext_Prim_Desc[i].name, Name)) return i;
+ if (Intern_It == NIL) return -1;
+ Max = NUndefined();
+ if (Max > 0) Next = Nth_Vector_Loc(Undefined_Externals, 2);
+ for (i=1; i <= Max; i++)
+ if (String_Equal(Name, Fast_Vector_Ref(*Next++, SYMBOL_NAME)))
+ return MAX_EXTERNAL_PRIMITIVE+i;
+ if (Intern_It != TRUTH) return -1;
+ /* Intern the primitive name by adding it to the vector of
+ undefined primitives */
+ if ((Max % CHUNK_SIZE) == 0)
+ { Primitive_GC_If_Needed(Max+CHUNK_SIZE+2);
+ if (Max > 0) Next = Nth_Vector_Loc(Undefined_Externals, 2);
+ Undefined_Externals = Make_Pointer(TC_VECTOR, Free);
+ *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Max+CHUNK_SIZE+1);
+ *Free++ = FIXNUM_0 + Max + 1;
+ for (i=0; i < Max; i++) *Free++ = Fetch(*Next++);
+ *Free++ = Symbol;
+ for (i=1; i < CHUNK_SIZE; i++) *Free++ = NIL;
+ }
+ else
+ { User_Vector_Set(Undefined_Externals, Max+1, Symbol);
+ User_Vector_Set(Undefined_Externals, 0, FIXNUM_0+Max+1);
+ }
+ return MAX_EXTERNAL_PRIMITIVE+Max+1;
+}
+
+/* (GET-EXTERNAL-NUMBER name intern?)
+ [Primitive number 0x103]
+ Given a symbol (name), return the external primitive object
+ corresponding to this name.
+ If intern? is true, then an external object is created if one
+ didn't exist before.
+ If intern? is false, NIL is returned if the primitive is not
+ implemented even if the name alredy exists.
+ Otherwise, NIL is returned if the primitive does not exist and
+ the name does not exist either.
+*/
+
+Built_In_Primitive(Prim_Get_Ext_Number, 2, "GET-EXTERNAL-NUMBER")
+{ long Answer;
+ Primitive_2_Args();
+
+ Arg_1_Type(TC_INTERNED_SYMBOL);
+ Touch_In_Primitive(Arg2, Arg2);
+ Answer = Get_Ext_Number(Arg1, Arg2);
+ return ((Answer == -1) ?
+ NIL : Make_Non_Pointer(TC_PRIMITIVE_EXTERNAL, Answer));
+}
+\f
+/* Called from FASDUMP and BAND_DUMP to create a vector with
+ symbols for each of the external primitives known to the system.
+*/
+
+Pointer Make_Prim_Exts()
+{ Pointer Result = Make_Pointer(TC_VECTOR, Free), *Orig_Free=Free;
+ long i, Max=NUndefined(), Count;
+
+ Count = MAX_EXTERNAL_PRIMITIVE + Max + 1;
+ Primitive_GC_If_Needed(Count+1);
+ Free += Count+1;
+ *Orig_Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Count);
+ for (i=0; i <= MAX_EXTERNAL_PRIMITIVE; i++)
+ *Orig_Free++ = Get_Name_Of_Impl_External(i);
+ for (i=1; i <= Max; i++)
+ *Orig_Free++ = User_Vector_Ref(Undefined_Externals, i);
+ return Result;
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: extern.h
+ *
+ * External declarations.
+ *
+ */
+\f
+#ifdef ENABLE_DEBUGGING_TOOLS
+
+extern Boolean Eval_Debug, Hex_Input_Debug, Cont_Debug,
+ File_Load_Debug, Reloc_Debug, Intern_Debug,
+ Primitive_Debug, Define_Debug, Lookup_Debug, GC_Debug,
+ Upgrade_Debug, Trace_On_Error, Dump_Debug, Per_File,
+ Bignum_Debug, Fluids_Debug;
+
+extern sp_record_list SP_List;
+extern void Pop_Return_Break_Point();
+extern int debug_slotno, debug_nslots, local_slotno, local_nslots,
+ debug_circle[], local_circle[];
+#else
+#define Eval_Debug false
+#define Hex_Input_Debug false
+#define File_Load_Debug false
+#define Reloc_Debug false
+#define Intern_Debug false
+#define Cont_Debug false
+#define Primitive_Debug false
+#define Lookup_Debug false
+#define Define_Debug false
+#define GC_Debug false
+#define Upgrade_Debug false
+#define Trace_On_Error false
+#define Dump_Debug false
+#define Per_File false
+#define Bignum_Debug false
+#define Fluids_Debug false
+#endif
+\f
+extern Pointer
+ Env, /* The environment */
+ Ext_Val, /* The value returned from primitives or apply */
+ Return, /* The return address code */
+ Ext_Expression, /* Expression to EVALuate */
+ *History, /* History register */
+ *Free, /* Next free word in heap */
+ *MemTop, /* Top of heap space available */
+ *Ext_Stack_Pointer, /* Next available slot in control stack */
+ *Stack_Top, /* Top of control stack */
+ *Stack_Guard, /* Guard area at end of stack */
+ *Free_Stacklets, /* Free list of stacklets */
+ *Constant_Space, /* Bottom of constant+pure space */
+ *Free_Constant, /* Next free cell in constant+pure area */
+ *Unused_Heap, /* Bottom of unused heap for GC */
+ *Unused_Heap_Top, /* Top of unused heap for GC */
+ *Heap_Top, /* Top of current heap space */
+ *Heap_Bottom, /* Bottom of current heap space */
+ *Local_Heap_Base, /* Per-processor CONSing area */
+ *Heap, /* Bottom of all heap space */
+ Current_State_Point, /* Dynamic state point */
+ Fluid_Bindings, /* Fluid bindings AList */
+ return_to_interpreter, /* Return address/code left by interpreter
+ when calling compiled code */
+ *last_return_code; /* Address of the most recent return code in the stack.
+ This is only meaningful while in compiled code.
+ *** This must be changed when stacklets are used. ***
+ */
+
+extern Declare_Fixed_Objects();
+\f
+extern long IntCode, /* Interrupts requesting */
+ IntEnb, /* Interrupts enabled */
+ GC_Reserve, /* Scheme pointer overflow space in heap */
+ GC_Space_Needed, /* Amount of space needed when GC triggered */
+ /* Used to signal microcode errors from compiled code. */
+ compiled_code_error_code;
+
+/* The lookup routines receive the slot location using these: */
+extern Pointer Lookup_Base;
+extern long Lookup_Offset;
+
+extern char *Primitive_Names[], *Return_Names[];
+extern long MAX_PRIMITIVE, MAX_RETURN;
+
+extern char Arg_Count_Table[],
+ *CONT_PRINT_RETURN_MESSAGE,
+ *CONT_PRINT_EXPR_MESSAGE,
+ *RESTORE_CONT_RETURN_MESSAGE,
+ *RESTORE_CONT_EXPR_MESSAGE;
+
+extern int GC_Type_Map[];
+
+extern Boolean Photo_Open; /* Photo file open */
+extern jmp_buf *Back_To_Eval;
+extern Boolean Trapping, Can_Do_Cursor;
+extern Pointer Old_Return_Code, *Return_Hook_Address,
+ *Previous_Restore_History_Stacklet,
+ Weak_Chain;
+extern long Previous_Restore_History_Offset;
+\f
+/* And file "channels" */
+
+extern FILE *(Channels[FILE_CHANNELS]);
+extern FILE *File_Handle; /* Used by Fasload/Fasdump */
+extern FILE *Photo_File_Handle; /* Used by Photo */
+
+extern int Saved_argc;
+extern char **Saved_argv;
+extern char *OS_Name, *OS_Variant;
+extern long Heap_Size, Constant_Size, Stack_Size;
+extern Pointer *Highest_Allocated_Address;
+
+/* External primitive data */
+
+typedef struct ext_desc /* User supplied primitive data */
+{ Pointer (*proc)(); /* Location of actual procedure */
+ int arity; /* Number of arguments */
+ char *name; /* Name of primitive */
+} External_Descriptor;
+
+extern External_Descriptor Ext_Prim_Desc[];
+extern long MAX_EXTERNAL_PRIMITIVE, Get_Ext_Number();
+extern Pointer Undefined_Externals, Make_Prim_Exts();
+\f
+/* String utilities */
+
+extern Boolean String_Equal();
+extern Pointer Make_String(), C_String_To_Scheme_String();
+#define Scheme_String_To_C_String(Scheme_String) \
+ ((char *) Nth_Vector_Loc(Scheme_String, STRING_CHARS))
+
+/* Symbol and variable utilities */
+
+extern long Lex_Ref(), Local_Set(), Lex_Set(),
+ Symbol_Lex_Ref(), Symbol_Lex_Set(), Binding_Lookup_Slot(),
+ Intern(), Lookup_Fluid(), Symbol_Lookup(), Do_Hash();
+extern Pointer Hash();
+
+/* Numeric utilities */
+
+extern int Scheme_Integer_To_C_Integer();
+extern Pointer C_Integer_To_Scheme_Integer(), Allocate_Float(),
+ Float_To_Big(), Big_To_Float(), Big_To_Fix(),
+ Fix_To_Big(), Mul();
+
+/* Random and OS utilities */
+
+extern int Parse_Option();
+extern Boolean Open_File(), Restore_History(), Open_Dump_File();
+extern long NColumns(), NLines(), System_Clock();
+extern void OS_Flush_Output_Buffer();
+extern void Load_Data(), Write_Data(), OS_Re_Init();
+
+/* Memory management utilities */
+
+extern void GCFlip(), GC();
+extern Pointer *GCLoop(), Purify_Pass_2(), Fasload();
+extern Boolean Pure_Test();
+
+/* Interpreter utilities */
+
+extern term_type Microcode_Termination();
+extern void Interpret(), Do_Micro_Error(), Setup_Interrupt(),
+ Back_Out_Of_Primitive(), Translate_To_Point(),
+ Stop_History(), Stack_Death();
+
+extern void Clear_Int_Timer(), Set_Int_Timer();
+
+#ifdef USE_STACKLETS
+extern void Allocate_New_Stacklet();
+#endif
+
+extern Pointer (*(Primitive_Table[]))(), *Make_Dummy_History(),
+ Find_State_Space();
+
+/* Debugging utilities */
+
+extern void Back_Trace(), Handle_Debug_Flags(),
+ Find_Symbol(), Show_Env(), Show_Pure(),
+ Print_Return(), Print_Expression(), Print_Primitive();
+
+/* Compiler Stuff */
+
+extern Pointer Registers[];
+\f
+/* Conditional utilities */
+
+#if false
+extern void Clear_Perfinfo_Data();
+#endif
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: fasdump.c
+ This file contains code for fasdump and dump-band.
+*/
+
+#include "scheme.h"
+#include "primitive.h"
+#define In_Fasdump
+#include "gccode.h"
+#include "dump.c"
+\f
+/* Some statics used freely in this file */
+Pointer *NewFree, *NewMemTop, *Fixup, *Orig_New_Free;
+
+/* FASDUMP:
+
+ Hair squared! ... in order to dump an object it must be traced
+ (as in a garbage collection), but with some significant differences.
+ First, the copy must have (a) the global value cell of symbols set
+ to UNBOUND; (b) the danger bits cleared in symbols; and (c)
+ variables uncompiled. Second, and worse, all the broken hearts
+ created during the process must be restored to their original
+ values. This last is done by growing the copy of the object in the
+ bottom of spare heap, keeping track of the locations of broken
+ hearts and original contents at the top of the spare heap.
+
+ FASDUMP is called with three arguments:
+ Argument 1: Base of spare heap
+ Argument 2: Top of spare heap
+ Argument 3: Hunk 3, #<Object to dump | File name | Flag>
+ where the flag is #!true for a dump into constant
+ space at reload time, () for a dump into heap.
+
+ As with Purify, dumping an object for reloading into constant space
+ requires dividing it into pure and constant parts and building a
+ standard Pure/Constant block.
+*/
+\f
+/* Copy of GCLoop, except (a) copies out of constant space into the
+ object to be dumped; (b) changes symbols and variables as
+ described; (c) clears danger bits as described; (d) keeps track of
+ broken hearts and their original contents (e) To_Pointer is now
+ NewFree.
+*/
+
+#define Dump_Pointer(Code) \
+Old = Get_Pointer(Temp); \
+Code
+
+#define Setup_Pointer_for_Dump(Extra_Code) \
+Dump_Pointer(Fasdump_Setup_Pointer(Extra_Code, Normal_BH(false, continue)))
+
+/* Dump_Mode is currently a fossil. It should be resurrected. */
+
+/* Should be big enough for the largest fixed size object (a Quad)
+ and 2 for the Fixup.
+ */
+
+#define FASDUMP_FIX_BUFFER 10
+
+Boolean DumpLoop(Scan, Dump_Mode)
+fast Pointer *Scan;
+int Dump_Mode;
+{ fast Pointer *To, *Old, Temp, New_Address, *Fixes;
+
+ To = NewFree;
+ Fixes = Fixup;
+
+ if (Dump_Debug) printf( "Starting scan at 0x%08x\n", Scan);
+
+ for ( ; Scan != To; Scan++)
+ { Temp = *Scan;
+
+ if (Dump_Debug)
+ { if (Temp != NIL)
+ fprintf(stderr, "0x%08x: %02x|%06x ... ",
+ Scan, Type_Code(Temp), Get_Integer(Temp));
+ }
+
+/* DumpLoop continues on the next page */
+\f
+/* DumpLoop, continued */
+
+ Switch_by_GC_Type(Temp)
+ { case TC_BROKEN_HEART:
+ if (Datum(Temp) != 0)
+ { fprintf(stderr, "\nDump: Broken heart in scan.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+ }
+ break;
+
+ case TC_MANIFEST_NM_VECTOR:
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ Scan += Get_Integer(Temp);
+ if (Dump_Debug)
+ fprintf(stderr, "skipping %d cells.", Get_Integer(Temp));
+ break;
+
+ /* This should really be case_Fasdump_Non_Pointer,
+ and PRIMITIVE_EXTERNAL should be handled specially
+ */
+ case_Non_Pointer:
+ if (Dump_Debug) fprintf(stderr, "not a pointer.");
+ break;
+
+ case_compiled_entry_point:
+ Dump_Pointer(Fasdump_Setup_Pointer(Transport_Compiled(),
+ Compiled_BH(false, continue)));
+
+ case_Cell:
+ Setup_Pointer_for_Dump(Transport_Cell());
+
+ case TC_WEAK_CONS:
+ case_Fasdump_Pair:
+ Setup_Pointer_for_Dump(Transport_Pair());
+
+ case TC_INTERNED_SYMBOL:
+ Setup_Pointer_for_Dump(Fasdump_Symbol(BROKEN_HEART_0));
+
+ case TC_UNINTERNED_SYMBOL:
+ Setup_Pointer_for_Dump(Fasdump_Symbol(UNBOUND_OBJECT));
+
+ case_Triple:
+ Setup_Pointer_for_Dump(Transport_Triple());
+
+ case TC_VARIABLE:
+ Setup_Pointer_for_Dump(Fasdump_Variable());
+
+/* DumpLoop continues on the next page */
+\f
+/* DumpLoop, continued */
+
+#ifdef QUADRUPLE
+ case_Quadruple:
+ Setup_Pointer_for_Dump(Transport_Quadruple());
+#endif
+
+#ifdef FLOATING_ALIGNMENT
+ case TC_BIG_FLONUM:
+ Setup_Pointer_for_Dump(Transport_Flonum());
+#else
+ case TC_BIG_FLONUM:
+ /* Fall through */
+#endif
+ case_Vector:
+ Setup_Pointer_for_Dump(Transport_Vector());
+
+ case TC_FUTURE:
+ Setup_Pointer_for_Dump(Transport_Future());
+
+ default:
+ fprintf(stderr,
+ "DumpLoop: Bad type code = 0x%02x\n",
+ Type_Code(Temp));
+ Invalid_Type_Code();
+
+ } /* Switch_by_GC_Type */
+ if (Dump_Debug) fprintf(stderr, "\n");
+ } /* For loop */
+ NewFree = To;
+ Fixup = Fixes;
+ return true;
+} /* DumpLoop */
+\f
+/* (PRIMITIVE-FASDUMP object-to-dump file-name flag)
+ [Primitive number 0x56]
+ Dump an object into a file so that it can be loaded using
+ BINARY-FASLOAD. A spare heap is required for this operation.
+ The first argument is the object to be dumped. The second is
+ the filename and the third a flag. The flag, if #!TRUE, means
+ that the object is to be dumped for reloading into constant
+ space. This is currently disabled. If the flag is NIL, it means
+ that it will be reloaded into the heap. The primitive returns
+ #!TRUE or NIL indicating whether it successfully dumped the
+ object (it can fail on an object that is too large).
+*/
+Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP")
+{ Pointer Object, File_Name, Flag, *New_Object,
+ *Addr_Of_New_Object, Prim_Exts;
+ long Pure_Length, Length;
+ Primitive_3_Args();
+
+ Object = Arg1;
+ File_Name = Arg2;
+ Flag = Arg3;
+ if (Type_Code(File_Name) != TC_CHARACTER_STRING)
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ if (!Open_Dump_File(File_Name, WRITE_FLAG))
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+#if false
+ /* Cannot dump pure at all */
+ if ((Flag != NIL) && (Flag != TRUTH))
+#else
+ if (Flag != NIL)
+#endif
+ Primitive_Error(ERR_ARG_3_WRONG_TYPE);
+
+ Fasdump_Free_Calc(NewFree, NewMemTop, Orig_New_Free);
+ Fixup = NewMemTop;
+ Prim_Exts = Make_Prim_Exts();
+ New_Object = NewFree;
+ *NewFree++ = Object;
+ *NewFree++ = Prim_Exts;
+
+/* Prim_Primitive_Fasdump continues on next page */
+\f
+/* Prim_Primitive_Fasdump, continued */
+
+#if false
+ /* This code is supposed to handle pure dumping. It is severely
+ broken. It should be removed or fixed.
+ */
+ if (Flag==TRUTH)
+ { if (!DumpLoop(New_Object, PURE_COPY))
+ { Fasdump_Exit();
+ return NIL;
+ }
+ /* Can't align.
+ Align_Float(NewFree);
+ */
+ Pure_Length = (NewFree-New_Object) + 1;
+ *NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *NewFree++ = Make_Non_Pointer(CONSTANT_PART, Pure_Length);
+ if (!DumpLoop(New_Object, CONSTANT_COPY))
+ { Fasdump_Exit();
+ return NIL;
+ }
+ Length = NewFree-New_Object+2;
+ *NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *NewFree++ = Make_Non_Pointer(END_OF_BLOCK, Length-1);
+ Addr_Of_New_Object = Get_Pointer(New_Object[0]);
+ Prim_Exts = New_Object[1];
+ New_Object[0] = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR,
+ Pure_Length);
+ New_Object[1] = Make_Non_Pointer(PURE_PART, Length-1);
+ Write_File(0, 0x000000, Addr_Of_New_Object,
+ Length, New_Object, Prim_Exts);
+ }
+
+/* Fasdump continues on the next page */
+\f
+/* Fasdump, continued */
+
+ else /* Dumping for reload into heap */
+#endif
+ { if (!DumpLoop(New_Object, NORMAL_GC))
+ { Fasdump_Exit();
+ return NIL;
+ }
+ /* Aligning might screw up some of the counters.
+ Align_Float(NewFree);
+ */
+ Length = NewFree-New_Object;
+ Write_File(Length, New_Object, New_Object,
+ 0, Constant_Space, New_Object+1);
+ }
+ Fasdump_Exit();
+ return TRUTH;
+}
+
+Fasdump_Exit()
+{ register Pointer *Fixes = Fixup;
+ fclose(File_Handle);
+ while (Fixes != NewMemTop)
+ { register Pointer *Fix_Address;
+ Fix_Address = Get_Pointer(*Fixes++); /* Where it goes. */
+ *Fix_Address = *Fixes++; /* Put it there. */
+ }
+ Fixup = Fixes;
+ Fasdump_Exit_Hook();
+}
+\f
+/* (DUMP-BAND PROCEDURE FILE-NAME)
+ [Primitive number 0xB7]
+ Saves all of the heap and pure space on FILE-NAME. When the
+ file is loaded back using BAND_LOAD, PROCEDURE is called with an
+ argument of NIL.
+*/
+Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND")
+{ Pointer Combination, Ext_Prims;
+ long Arg1Type;
+ Primitive_2_Args();
+
+ Band_Dump_Permitted();
+ Arg1Type = Type_Code(Arg1);
+ if ((Arg1Type != TC_CONTROL_POINT) &&
+ (Arg1Type != TC_PRIMITIVE) &&
+ (Arg1Type != TC_PRIMITIVE_EXTERNAL) &&
+ (Arg1Type != TC_EXTENDED_PROCEDURE)) Arg_1_Type(TC_PROCEDURE);
+ Arg_2_Type(TC_CHARACTER_STRING);
+ if (!Open_Dump_File(Arg2, WRITE_FLAG))
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ /* Free cannot be saved around this code since Make_Prim_Exts will
+ intern the undefined externals and potentially allocate space.
+ */
+ Ext_Prims = Make_Prim_Exts();
+ Combination = Make_Pointer(TC_COMBINATION_1, Free);
+ Free[COMB_1_FN] = Arg1;
+ Free[COMB_1_ARG_1] = NIL;
+ Free += 2;
+ *Free++ = Combination;
+ *Free++ = return_to_interpreter;
+ *Free++ = Make_Pointer(TC_LIST, Free-2);
+ *Free++ = Ext_Prims;
+ /* Aligning here confuses some of the counts computed.
+ Align_Float(Free);
+ */
+ Write_File(((long) (Free-Heap_Bottom)), Heap_Bottom, Free-2,
+ ((long) (Free_Constant-Constant_Space)),
+ Constant_Space, Free-1);
+ fclose(File_Handle);
+ return TRUTH;
+}
+
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: fasl.h
+ Contains information relating to the format of FASL files.
+ Some information is contained in CONFIG.H.
+*/
+\f
+/* FASL Version */
+
+#define FASL_FILE_MARKER 0XFAFAFAFA
+#define FASL_FORMAT_ADDED_STACK 1
+#define FASL_FORMAT_VERSION 1
+#define FASL_SUBVERSION 5
+
+/* The FASL file has a header which begins as follows: */
+
+#define FASL_HEADER_LENGTH 50 /* Scheme objects in header */
+#define FASL_OLD_LENGTH 8 /* Size of header earlier */
+#define FASL_Offset_Marker 0 /* Marker to indicate FASL format */
+#define FASL_Offset_Heap_Count 1 /* Count of objects in heap */
+#define FASL_Offset_Heap_Base 2 /* Address of heap when dumped */
+#define FASL_Offset_Dumped_Obj 3 /* Where dumped object was */
+#define FASL_Offset_Const_Count 4 /* Count of objects in const. area */
+#define FASL_Offset_Const_Base 5 /* Address of const. area at dump */
+#define FASL_Offset_Version 6 /* FASL format version info. */
+#define FASL_Offset_Stack_Top 7 /* Top of stack when dumped */
+#define FASL_Offset_Ext_Loc 8 /* Where ext. prims. vector is */
+
+#define FASL_Offset_First_Free 9 /* Used to clear header */
+
+/* Version information encoding */
+
+#define MACHINE_TYPE_LENGTH (POINTER_LENGTH/2)
+#define MACHINE_TYPE_MASK ((1<<MACHINE_TYPE_LENGTH)-1)
+#define The_Machine_Type(P) ((P) & MACHINE_TYPE_MASK)
+#define SUB_VERSION_LENGTH (MACHINE_TYPE_LENGTH-TYPE_CODE_LENGTH)
+#define SUB_VERSION_MASK ((1<<SUB_VERSION_LENGTH)-1)
+#define The_Sub_Version(P) (((P) >> MACHINE_TYPE_LENGTH) & SUB_VERSION_MASK)
+#define The_Version(P) Type_Code(P)
+#define Make_Version(V, S, M) \
+ Make_Non_Pointer((V), (((S) << MACHINE_TYPE_LENGTH) | (M)))
+\f
+#define WRITE_FLAG "w"
+#define OPEN_FLAG "r"
+
+/* "Memorable" FASL sub-versions -- ones where we modified something
+ and want to remain backwards compatible
+*/
+
+#define FASL_OLDEST_SUPPORTED 2
+#define FASL_LONG_HEADER 3
+#define FASL_DENSE_TYPES 4
+#define FASL_PADDED_STRINGS 5
+
+/* Old Type Codes -- used for conversion purposes */
+
+#define OLD_TC_CHARACTER 0x40
+#define OLD_TC_PCOMB2 0x44
+#define OLD_TC_VECTOR 0x46
+#define OLD_TC_RETURN_CODE 0x48
+#define OLD_TC_COMPILED_PROCEDURE 0x49
+#define OLD_TC_ENVIRONMENT 0x4E
+#define OLD_TC_FIXNUM 0x50
+#define OLD_TC_CONTROL_POINT 0x56
+#define OLD_TC_BROKEN_HEART 0x58
+#define OLD_TC_COMBINATION 0x5E
+#define OLD_TC_MANIFEST_NM_VECTOR 0x60
+#define OLD_TC_PCOMB3 0x66
+#define OLD_TC_SPECIAL_NM_VECTOR 0x68
+#define OLD_TC_THE_ENVIRONMENT 0x70
+#define OLD_TC_VECTOR_1B 0x76
+#define OLD_TC_BIT_STRING 0x76
+#define OLD_TC_PCOMB0 0x78
+#define OLD_TC_VECTOR_16B 0x7E
+#define OLD_TC_UNASSIGNED 0x38
+#define OLD_TC_SEQUENCE_3 0x3C
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: fasload.c
+
+ The "fast loader" which reads in and relocates binary files and then
+ interns symbols. It is called with one argument: the (character
+ string) name of a file to load. It is called as a primitive, and
+ returns a single object read in.
+ */
+\f
+#include "scheme.h"
+#include "primitive.h"
+#include "gccode.h"
+
+#define CCheck_or_Reloc_Debug Or2(Consistency_Check, Reloc_Debug)
+#define Reloc_or_Load_Debug Or2(Reloc_Debug, File_Load_Debug)
+
+#define print_char(C) printf(((C < ' ') || (C > '|')) ? \
+ "\\%03o" : "%c", (C && MAX_CHAR));
+
+Pointer String_To_Symbol();
+
+#include "load.c"
+\f
+/* Here is a totally randomly constructed string hashing function */
+
+long Do_Hash(String_Ptr, String_Length)
+char *String_Ptr;
+long String_Length;
+{ long i, Value, End_Count;
+
+ Value = LENGTH_MULTIPLIER*String_Length;
+ End_Count = (String_Length > MAX_HASH_CHARS) ?
+ MAX_HASH_CHARS : String_Length;
+ for (i=0; i < End_Count; i++)
+ Value = (Value << SHIFT_AMOUNT) + (MAX_CHAR & String_Ptr[i]);
+ if (Intern_Debug)
+ { char *C;
+ printf(" Hashing: %d: ", String_Length);
+ C = String_Ptr;
+ for (i=0; i < String_Length; i++, C++)
+ print_char(*C);
+ printf(" => 0x%x\n", Value);
+ }
+ return Value;
+}
+
+Pointer Hash(Ptr)
+Pointer Ptr;
+{ long String_Length;
+
+ String_Length = Get_Integer(Fast_Vector_Ref(Ptr, STRING_LENGTH));
+ return Make_Non_Pointer(TC_FIXNUM,
+ Do_Hash(Scheme_String_To_C_String(Ptr),
+ String_Length));
+}
+\f
+Pointer Hash_Chars(Ptr)
+Pointer Ptr;
+{ long Length;
+ Pointer This_Char;
+ char String[MAX_HASH_CHARS];
+
+ Touch_In_Primitive(Ptr, Ptr);
+ for (Length=0; Type_Code(Ptr)==TC_LIST; Length++)
+ { if (Length < MAX_HASH_CHARS)
+ { Touch_In_Primitive(Vector_Ref(Ptr, CONS_CAR), This_Char);
+ if (Type_Code(This_Char) != TC_CHARACTER)
+ Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ Range_Check(String[Length], This_Char,
+ (char) 0, (char) MAX_CHAR, ERR_ARG_1_WRONG_TYPE);
+ Touch_In_Primitive(Vector_Ref(Ptr, CONS_CDR), Ptr);
+ }
+ }
+ if (Ptr != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ return Make_Non_Pointer(TC_FIXNUM, Do_Hash(String, Length));
+}
+\f
+Boolean String_Equal(String1, String2)
+Pointer String1, String2;
+{ char *S1, *S2;
+ long Length1, Length2, i;
+
+ if (Address(String1)==Address(String2)) return true;
+ Length1 = Get_Integer(Fast_Vector_Ref(String1, STRING_LENGTH));
+ Length2 = Get_Integer(Fast_Vector_Ref(String2, STRING_LENGTH));
+ if (Length1 != Length2) return false;
+ S1 = (char *) Nth_Vector_Loc(String1, STRING_CHARS);
+ S2 = (char *) Nth_Vector_Loc(String2, STRING_CHARS);
+ for (i=0; i < Length1; i++) if (*S1++ != *S2++) return false;
+ return true;
+}
+
+Pointer Make_String(Orig_List)
+Pointer Orig_List;
+{ char *Next;
+ long Length;
+ Pointer Result;
+
+ Result = Make_Pointer(TC_CHARACTER_STRING, Free);
+ Next = (char *) Nth_Vector_Loc(Result, STRING_CHARS);
+ Length = 0;
+ Touch_In_Primitive(Orig_List, Orig_List);
+ while (Type_Code(Orig_List) == TC_LIST)
+ { Pointer This_Char;
+ long The_Character;
+
+ Primitive_GC_If_Needed(Free - ((Pointer *) Next));
+ Touch_In_Primitive(Vector_Ref(Orig_List, CONS_CAR), This_Char);
+ if (Type_Code(This_Char) != TC_CHARACTER)
+ Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ Range_Check(The_Character, This_Char,
+ 0, MAX_CHAR, ERR_ARG_1_BAD_RANGE);
+ *Next++ = (char) The_Character;
+ Touch_In_Primitive(Vector_Ref(Orig_List, CONS_CDR), Orig_List);
+ Length += 1;
+ }
+ if (Orig_List != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ *Next++ = '\0'; /* Add the null */
+ Free += 2 + (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
+/* Interning involves hashing the input string and either returning
+ an existing symbol with that name from the ObArray or creating a
+ new symbol and installing it in the ObArray. The resulting interned
+ symbol is stored in *Un_Interned.
+*/
+
+long Intern(Un_Interned)
+Pointer *Un_Interned;
+{ long Hashed_Value;
+ Pointer Ob_Array, *Bucket, String, Temp;
+
+ String = Fast_Vector_Ref(*Un_Interned, SYMBOL_NAME);
+ Temp = Hash(String);
+ Hashed_Value = Get_Integer(Temp);
+ Ob_Array = Get_Fixed_Obj_Slot(OBArray);
+ Hashed_Value %= Vector_Length(Ob_Array);
+ Bucket = Nth_Vector_Loc(Ob_Array, Hashed_Value + 1);
+
+ if (Intern_Debug)
+ { char *C;
+ int i, String_Length;
+ String_Length = Get_Integer(Fast_Vector_Ref(String, STRING_LENGTH));
+ C = (char *) Nth_Vector_Loc(String, STRING_CHARS);
+ printf("\nInterning ");
+ for (i=0; i < String_Length; i++, C++) print_char(*C);
+ }
+
+/* Intern continues on the next page */
+\f
+/* Intern, continued */
+
+ while (*Bucket != NIL)
+ { if (Intern_Debug)
+ printf(" Bucket #%o (0x%x) ...\n",
+ Address(*Bucket), Address(*Bucket));
+ if (String_Equal(String,
+ Fast_Vector_Ref(
+ Vector_Ref(*Bucket, CONS_CAR),
+ SYMBOL_NAME)))
+ { if (Intern_Debug) printf(" found\n");
+ *Un_Interned = Vector_Ref(*Bucket, CONS_CAR);
+ return;
+ }
+ Bucket = Nth_Vector_Loc(*Bucket, CONS_CDR);
+ }
+
+/* Symbol does not exist yet in ObArray. Bucket points to the
+ cell containing the final #!NULL in the list. Replace this
+ with the CONS of the new symbol and #!NULL (i.e. extend the
+ list in the bucket by 1 new element).
+*/
+
+ Store_Type_Code(*Un_Interned, TC_INTERNED_SYMBOL);
+ if (Intern_Debug) printf(" adding at #%o (0x%x)\n",
+ (long) Free, (long) Free);
+ *Bucket = Make_Pointer(TC_LIST, Free);
+ Free[CONS_CAR] = *Un_Interned;
+ Free[CONS_CDR] = NIL;
+ Free += 2;
+}
+\f
+Load_File(Name)
+Pointer Name;
+{ char *Char;
+ long N, i;
+ Boolean File_Opened;
+ File_Opened = Open_Dump_File(Name, OPEN_FLAG);
+ if (Per_File) Handle_Debug_Flags();
+ if (!File_Opened) Primitive_Error(ERR_ARG_1_BAD_RANGE);
+
+/* Load_File continues on next page */
+\f
+/* Load_File, continued */
+
+ if (!Read_Header())
+ { printf("\nThis file does not appear to be in FASL format.\n");
+ goto CANNOT_LOAD;
+ }
+ if (File_Load_Debug)
+ printf("\nMachine type %d, Version %d, Subversion %d\n",
+ Machine_Type, Version, Sub_Version);
+#ifdef butterfly
+ if ((Sub_Version > FASL_SUBVERSION))
+#else
+ if ((Sub_Version > FASL_SUBVERSION) ||
+ (Machine_Type != FASL_INTERNAL_FORMAT))
+#endif
+ { printf("\nFASL File Version %4d Subversion %4d Machine Type %4d\n",
+ Version, Sub_Version , Machine_Type);
+ printf("Expected: Version %4d Subversion %4d Machine Type %4d\n",
+ FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
+ printf("You may need to use the `Bintopsb' and `Psbtobin' programs.\n");
+CANNOT_LOAD:
+ fclose(File_Handle);
+ Primitive_Error(ERR_FASL_FILE_BAD_DATA);
+ }
+ if (!Test_Pure_Space_Top(Free_Constant+Const_Count))
+ { fclose(File_Handle);
+ Primitive_Error(ERR_FASL_FILE_TOO_BIG);
+ }
+ if (GC_Check(Heap_Count))
+ { fclose(File_Handle);
+ Request_GC(Heap_Count);
+ Primitive_Interrupt();
+ }
+ /* Aligning Free here confuses the counters
+ Align_Float(Free);
+ */
+ Load_Data(Heap_Count, (char *) Free);
+ Free += Heap_Count;
+ Load_Data(Const_Count, (char *) Free_Constant);
+ Free_Constant += Const_Count;
+ /* Same
+ Align_Float(Free);
+ */
+ fclose(File_Handle);
+}
+\f
+/* Statics used by Relocate, below */
+
+relocation_type Heap_Relocation, Const_Reloc, Stack_Relocation;
+
+/* Relocate a pointer as read in from the file. If the pointer used
+ to point into the heap, relocate it into the heap. If it used to
+ be constant area, relocate it to constant area. Otherwise give an
+ error.
+*/
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+static Boolean Warned = false;
+Pointer *Relocate(P)
+long P;
+{ Pointer *Result;
+ if ((P >= Heap_Base) && (P < Dumped_Heap_Top))
+ Result = (Pointer *) (P + Heap_Relocation);
+ else if ((P >= Const_Base) && (P < Dumped_Constant_Top))
+ Result = (Pointer *) (P + Const_Reloc);
+ else if (P < Dumped_Stack_Top)
+ Result = (Pointer *) (P + Stack_Relocation);
+ else
+ { printf("Pointer out of range: 0x%x\n", P, P);
+ if (!Warned)
+ { printf("Heap: %x-%x, Constant: %x-%x, Stack: ?-0x%x\n",
+ Heap_Base, Dumped_Heap_Top,
+ Const_Base, Dumped_Constant_Top, Dumped_Stack_Top);
+ Warned = true;
+ }
+ Result = (Pointer *) 0;
+ }
+ if (Reloc_Debug) printf("0x%06x => 0x%06x\n", P, Result);
+ return Result;
+}
+
+#define Relocate_Into(Loc, P) (Loc) = Relocate(P)
+
+#else
+
+#define Relocate_Into(Loc, P) \
+if ((P) < Const_Base) \
+ (Loc) = ((Pointer *) ((P) + Heap_Relocation)); \
+else if ((P) < Dumped_Constant_Top) \
+ (Loc) = ((Pointer *) ((P) + Const_Reloc)); \
+else \
+ (Loc) = ((Pointer *) ((P) + Stack_Relocation))
+
+#ifndef Conditional_Bug
+#define Relocate(P) \
+ ((P < Const_Base) ? \
+ ((Pointer *) (P + Heap_Relocation)) : \
+ ((P < Dumped_Constant_Top) ? \
+ ((Pointer *) (P + Const_Reloc)) : \
+ ((Pointer *) (P + Stack_Relocation))))
+#else
+static Pointer *Relocate_Temp;
+#define Relocate(P) \
+ (Relocate_Into(Relocate_Temp, P), Relocate_Temp)
+#endif
+#endif
+\f
+/* Next_Pointer starts by pointing to the beginning of the block of
+ memory to be handled. This loop relocates all pointers in the
+ block of memory.
+*/
+
+long Relocate_Block(Next_Pointer, Stop_At)
+fast Pointer *Next_Pointer, *Stop_At;
+{ if (Reloc_Debug)
+ fprintf(stderr,
+ "Relocation beginning, block=0x%x, length=0x%x, end=0x%x.\n",
+ Next_Pointer, (Stop_At-Next_Pointer)-1, Stop_At);
+ while (Next_Pointer < Stop_At)
+ { fast Pointer Temp = *Next_Pointer;
+ Switch_by_GC_Type(Temp)
+ { case TC_BROKEN_HEART:
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ case_Fasdump_Non_Pointer:
+ Next_Pointer += 1;
+ break;
+
+ case TC_PRIMITIVE_EXTERNAL:
+ Found_Ext_Prims = true;
+ Next_Pointer += 1;
+ break;
+
+ case TC_MANIFEST_NM_VECTOR:
+ Next_Pointer += Get_Integer(Temp)+1;
+ break;
+
+ /* These work automagically */
+ case_compiled_entry_point:
+ default:
+ { fast long Next = Datum(Temp);
+ *Next_Pointer++ = Make_Pointer(Type_Code(Temp), Relocate(Next));
+ }
+ }
+ }
+}
+\f
+Intern_Block(Next_Pointer, Stop_At)
+Pointer *Next_Pointer, *Stop_At;
+{ if (Reloc_Debug) printf("Interning a block.\n");
+ while (Next_Pointer <= Stop_At) /* BBN has < for <= */
+ { if (Reloc_Debug && Dangerous(*Next_Pointer))
+ printf("\nDangerous object at 0x%x: 0x%x",
+ Next_Pointer, *Next_Pointer);
+ switch (Safe_Type_Code(*Next_Pointer))
+ { case TC_MANIFEST_NM_VECTOR:
+ Next_Pointer += Get_Integer(*Next_Pointer)+1;
+ break;
+
+ case TC_INTERNED_SYMBOL:
+ if (Type_Code(Vector_Ref(*Next_Pointer, SYMBOL_GLOBAL_VALUE)) ==
+ TC_BROKEN_HEART)
+ { Pointer Old_Symbol = *Next_Pointer;
+ Vector_Set(*Next_Pointer, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT);
+ Intern(Next_Pointer);
+ Primitive_GC_If_Needed(0);
+ if (*Next_Pointer != Old_Symbol)
+ { Vector_Set(Old_Symbol, SYMBOL_NAME,
+ Make_New_Pointer(TC_BROKEN_HEART, *Next_Pointer));
+ }
+ }
+ else if (Type_Code(Vector_Ref(*Next_Pointer, SYMBOL_NAME)) ==
+ TC_BROKEN_HEART)
+ { *Next_Pointer =
+ Make_New_Pointer(Type_Code(*Next_Pointer),
+ Fast_Vector_Ref(*Next_Pointer,
+ SYMBOL_NAME));
+ }
+ Next_Pointer += 1;
+ break;
+
+ default: Next_Pointer += 1;
+ }
+ }
+ if (Reloc_Debug) printf("Done interning block.\n");
+ return;
+}
+\f
+/* Install the external primitives vector. This requires changing
+ the Ext_Prim_Vector from a vector of symbols (which is what is
+ in the FASL file) into a vector of (C format) numbers representing
+ the corresponding external primitives numbers for this interpreter.
+ If an external primitive is known, then the existing assigned number
+ is used. If not, the symbol is added to the list of assigned
+ numbers. In the case of a band load (as opposed to a fasload),
+ the existing vector of known but unimplemented external primitives
+ is ignored and a completely new one will be built.
+*/
+
+Install_Ext_Prims(Normal_FASLoad)
+Boolean Normal_FASLoad;
+{ long i;
+ Pointer *Next;
+
+ Vector_Set(Ext_Prim_Vector, 0,
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Ext_Prim_Count));
+ Next = Nth_Vector_Loc(Ext_Prim_Vector, 1);
+ if (Normal_FASLoad)
+ for (i=0; i < Ext_Prim_Count; i++) Intern(Next++);
+ else Undefined_Externals = NIL;
+}
+\f
+Update_Ext_Prims(Next_Pointer, Stop_At)
+fast Pointer *Next_Pointer, *Stop_At;
+{ for (;Next_Pointer < Stop_At; Next_Pointer++)
+ { switch (Safe_Type_Code(*Next_Pointer))
+ { case TC_MANIFEST_NM_VECTOR:
+ Next_Pointer += Get_Integer(*Next_Pointer);
+ break;
+
+ case TC_PRIMITIVE_EXTERNAL:
+ { long Which = Address(*Next_Pointer);
+ if (Which > Ext_Prim_Count)
+ printf("External Primitive 0x%x out of range.\n", Which);
+ else
+ { Pointer New_Value = User_Vector_Ref(Ext_Prim_Vector, Which);
+ if (Type_Code(New_Value) == TC_INTERNED_SYMBOL)
+ { New_Value = (Pointer) Get_Ext_Number(New_Value, TRUTH);
+ User_Vector_Set(Ext_Prim_Vector, Which, New_Value);
+ }
+ Store_Address(*Next_Pointer, New_Value);
+ }
+ }
+
+ default: break;
+ }
+ }
+}
+\f
+Pointer Fasload(FileName, Not_From_Band_Load)
+Pointer FileName;
+Boolean Not_From_Band_Load;
+{ Pointer *Heap_End, *Constant_End, *Orig_Heap, *Orig_Constant, *Xtemp;
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+ Warned = false;
+#endif
+
+ if (Type_Code(FileName) != TC_CHARACTER_STRING)
+ Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+
+ /* Read File */
+
+ Orig_Heap = Free;
+ Orig_Constant = Free_Constant;
+ Load_File(FileName);
+ Heap_End = Free;
+ Constant_End = Free_Constant;
+ Heap_Relocation = ((relocation_type) Orig_Heap) - Heap_Base;
+ Const_Reloc = ((relocation_type) Orig_Constant) - Const_Base;
+ Stack_Relocation = ((relocation_type) Stack_Top) - Dumped_Stack_Top;
+
+ if (Reloc_Debug)
+ printf("Heap_relocation = %d = %x; Const_Reloc = %d = %x\n",
+ Heap_Relocation, Heap_Relocation,
+ Const_Reloc, Const_Reloc);
+
+ /* Relocate the new Data */
+
+ Found_Ext_Prims = false;
+ Relocate_Block(Orig_Heap, Free);
+ Relocate_Block(Orig_Constant, Free_Constant);
+
+/* Fasload continues on the next page */
+\f
+/* Fasload, continued */
+
+ /* Intern */
+
+ if (Not_From_Band_Load)
+ { Intern_Block(Orig_Constant, Constant_End);
+ Intern_Block(Orig_Heap, Heap_End);
+ }
+
+ /* Update External Primitives */
+
+ if ((Ext_Prim_Vector != NIL) && Found_Ext_Prims)
+ { Relocate_Into(Xtemp, Address(Ext_Prim_Vector));
+ Ext_Prim_Vector = *Xtemp;
+ Ext_Prim_Count = Vector_Length(Ext_Prim_Vector);
+ Install_Ext_Prims(Not_From_Band_Load);
+ Update_Ext_Prims(Orig_Heap, Free);
+ Update_Ext_Prims(Orig_Constant, Free_Constant);
+ }
+
+ Set_Pure_Top();
+ Relocate_Into(Xtemp, Dumped_Object);
+ return *Xtemp;
+}
+\f
+/* (BINARY-FASLOAD FILE-NAME)
+ [Primitive number 0x57]
+ Load the contents of FILE-NAME into memory. The file was
+ presumably made by a call to PRIMITIVE_FASDUMP, and may contain
+ data for the heap and/or the pure area. The value returned is
+ the object which was dumped. Typically (but not always) this
+ will be a piece of SCode which is then evaluated to perform
+ definitions in some environment.
+*/
+Built_In_Primitive(Prim_Binary_Fasload, 1, "BINARY-FASLOAD")
+{ /* The code for Fasload, which does all the work, is found in the
+ file FASLOAD.C
+ */
+ Primitive_1_Arg();
+ return Fasload(Arg1, true);
+}
+\f
+/* (LOAD-BAND FILE-NAME)
+ [Primitive number 0xB9]
+ Restores the heap and pure space from the contents of FILE-NAME,
+ which is typically a file created by BAND_DUMP. The file can,
+ however, be any file which can be loaded with BINARY_FASLOAD.
+*/
+Built_In_Primitive(Prim_Band_Load, 1, "LOAD-BAND")
+{ Pointer Save_FO, *Save_Free, *Save_Free_Constant, Save_Undefined,
+ *Save_Stack_Pointer, *Save_Stack_Guard, Result;
+ long Jump_Value;
+ jmp_buf Swapped_Buf, *Saved_Buf;
+ Primitive_1_Arg();
+
+ Save_Fixed_Obj(Save_FO);
+ Save_Undefined = Undefined_Externals;
+ Undefined_Externals = NIL;
+ Save_Free = Free;
+ Free = Heap_Bottom;
+ Save_Free_Constant = Free_Constant;
+ Free_Constant = Constant_Space;
+ Save_Stack_Pointer = Stack_Pointer;
+ Save_Stack_Guard = Stack_Guard;
+
+/* Prim_Band_Load continues on next page */
+\f
+/* Prim_Band_Load, continued */
+
+ /* There is some jiggery-pokery going on here to make sure
+ that all returns from Fasload (including error exits) return to
+ the clean-up code before returning on up the C call stack.
+ */
+ Saved_Buf = Back_To_Eval;
+ Jump_Value = setjmp(Swapped_Buf);
+ if (Jump_Value == 0)
+ { Back_To_Eval = (jmp_buf *) Swapped_Buf;
+ Result = Fasload(Arg1, false);
+ Back_To_Eval = Saved_Buf;
+ History = Make_Dummy_History();
+ Initialize_Stack();
+ Store_Return(RC_END_OF_COMPUTATION);
+ Store_Expression(NIL);
+ Save_Cont();
+ Store_Expression(Vector_Ref(Result,0));
+ /* Primitive externals handled by Fasload */
+ return_to_interpreter = Vector_Ref(Result, 1);
+ Store_Env(Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL));
+ Set_Pure_Top();
+ Band_Load_Hook();
+ longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION);
+ }
+ else
+ { Back_To_Eval = Saved_Buf;
+ Free = Save_Free;
+ Free_Constant = Save_Free_Constant;
+ Stack_Pointer = Save_Stack_Pointer;
+ Set_Stack_Guard(Save_Stack_Guard);
+ Undefined_Externals = Save_Undefined;
+ Restore_Fixed_Obj(Save_FO);
+ if (Jump_Value == PRIM_INTERRUPT)
+ { printf("\nFile too large for memory.\n");
+ Jump_Value = ERR_FASL_FILE_BAD_DATA;
+ }
+ Primitive_Error(Jump_Value);
+ }
+}
+\f
+/* (CHARACTER-LIST-HASH LIST)
+ [Primitive number 0x65]
+ Takes a list of ASCII codes for characters and returns a hash
+ code for them. This uses the hashing function used to intern
+ symbols in Fasload, and is really intended only for that
+ purpose.
+*/
+Built_In_Primitive(Prim_Character_List_Hash, 1, "CHARACTER-LIST-HASH")
+{ /* The work is done in Hash_Chars.
+ A gross breach of modularity allows Hash_Chars to do the argument
+ type checking.
+ */
+ Primitive_1_Arg();
+ return Hash_Chars(Arg1);
+}
+\f
+/* (INTERN-CHARACTER-LIST LIST)
+ [Primitive number 0xAB]
+ LIST should consist of the ASCII codes for characters. Returns
+ a new (interned) symbol made out of these characters. Notice
+ that this is a fairly low-level primitive, and no checking is
+ done on the characters except that they are in the range 0 to
+ 255. Thus non-printing, lower-case, and special characters can
+ be put into symbols this way.
+*/
+Built_In_Primitive(Prim_Intern_Character_List, 1, "INTERN-CHARACTER-LIST")
+{ Primitive_1_Arg();
+ return String_To_Symbol(Make_String(Arg1));
+}
+
+/* (SYMBOL->STRING STRING)
+ [Primitive number 0x07]
+ Similar to INTERN-CHARACTER-LIST, except this one takes a string
+ instead of a list of ascii values as argument.
+ */
+Built_In_Primitive(Prim_String_To_Symbol, 1, "STRING->SYMBOL")
+{ Primitive_1_Arg();
+ Arg_1_Type(TC_CHARACTER_STRING);
+ return String_To_Symbol(Arg1);
+}
+
+Pointer String_To_Symbol(String)
+Pointer String;
+{ Pointer New_Symbol, Interned_Symbol, *Orig_Free;
+ Orig_Free = Free;
+ New_Symbol = Make_Pointer(TC_UNINTERNED_SYMBOL, Free);
+ Free[SYMBOL_NAME] = String;
+ Free[SYMBOL_GLOBAL_VALUE] = UNBOUND_OBJECT;
+ Free += 2;
+ Interned_Symbol = New_Symbol;
+ /* The work is done by Intern which returns in Interned_Symbol
+ either the same symbol we gave it (in which case we need to check
+ for GC) or an existing symbol (in which case we have to release
+ the heap space acquired to hold New_Symbol).
+ */
+ Intern(&Interned_Symbol);
+ if (Address(Interned_Symbol) == Address(New_Symbol))
+ { Primitive_GC_If_Needed(0);
+ }
+ else Free = Orig_Free;
+ return Interned_Symbol;
+}
--- /dev/null
+/* -*- C -*- */
+/* FFT scheme primitive, using YEKTA FFT */
+
+#include "scheme.h"
+#include "primitive.h"
+#include "flonum.h"
+#include "zones.h"
+#include <math.h>
+#include "array.h"
+#include "image.h"
+
+\f
+#define mult(pf1, pf2, pg1, pg2, w1, w2) \
+ { int x, y, p2, p3, p4, p5, p6, p7; \
+ REAL tmp1, tmp2; \
+ a = a / 2; \
+ p2 = - a; \
+ p3 = 0; \
+ for ( x = 1; x <= n2; x = x + a ) { \
+ p2 = p2 + a; \
+ for( y = 1; y <= a; ++y ) { \
+ ++p3; \
+ p4 = p2 + 1; \
+ p5 = p2 + p3; \
+ p5 = ((p5-1) % n) + 1; \
+ p6 = p5 + a; \
+ tmp1 = w1[p4-1] * pf1[p6-1] \
+ - w2[p4-1] * pf2[p6-1]; \
+ tmp2 = w1[p4-1] * pf2[p6-1] \
+ + w2[p4-1] * pf1[p6-1]; \
+ pg1[p3-1] = pf1[p5-1] + tmp1; \
+ pg2[p3-1] = pf2[p5-1] + tmp2; \
+ p7 = p3 + n2; \
+ pg1[p7-1] = pf1[p5-1] - tmp1; \
+ pg2[p7-1] = pf2[p5-1] - tmp2; \
+ } \
+ } \
+}
+\f
+/* n is length, nu is power, w1,w2 are locations for twiddle tables, */
+/* f1,f2,g1,g2 are locations for fft, and flag is for forward(1) or inverse(-1) */
+/* w1,w2 are half the size of f1,f2,g1,g2 */
+
+/* f1,f2 contain the real and imaginary parts of the signal */
+/* The answer is left in f1, f2 */
+\f
+C_Array_FFT(flag, nu, n, f1, f2, g1,g2,w1,w2) long flag, nu, n; REAL f1[], f2[], g1[], g2[], w1[], w2[];
+{ long n2=n>>1, a;
+ long i, l, m;
+ REAL twopi = 6.28318530717958, tm, k;
+
+ a = n; /* initially equal to length */
+ if (flag == 1) k=1.0;
+ else k = -1.0;
+ /* if ( nu > 12 ) Primitive_Error(ERR_ARG_2_BAD_RANGE); */ /* maximum power FFT */
+
+ for (m=0; m<n; m++) {
+ g1[m] = f1[m];
+ g2[m] = f2[m];
+ }
+
+ for (m=0; m<n2; m++) {
+ tm = twopi * ((REAL) m) / ((REAL) n);
+ w1[m] = cos( tm );
+ w2[m] = k * sin( tm ); /* k is the flag */
+ }
+
+ if ((nu % 2) == 1) l = 2;
+ else l = 1;
+ for ( i = l; i <= nu ; i = i + 2 ) {
+ mult(g1,g2,f1,f2,w1,w2);
+ mult(f1,f2,g1,g2,w1,w2);
+ }
+
+ if (k==1.0) { /* forward fft */
+ if (l==1) { /* even power */
+ for (m=0; m<n; m++) {
+ f1[m] = g1[m]; f2[m] = g2[m];
+ }
+ }
+ else { /* odd power ==> do one more mult */
+ mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */
+ }}
+ else { /* backward fft */
+ tm = 1. / ((REAL) n); /* normalizing factor */
+ if (l==1) { /* even power */
+ for (m=0; m<n; m++) {
+ f1[m] = tm * g1[m]; f2[m] = tm * g2[m]; }
+ }
+ else { /* odd power ==> do one more mult */
+ mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */
+ for (m=0; m<n; m++) {
+ f1[m] = tm * f1[m]; f2[m] = tm * f2[m]; }
+ }
+ }
+}
+\f
+Make_Twiddle_Tables(w1, w2, n, k) REAL *w1, *w2; long n, k; /* n is the length of FFT */
+{ long m, n2=n/2;
+ REAL tm, twopi = 6.28318530717958;
+ for (m=0; m<n2; m++) {
+ tm = twopi * ((REAL) m) / ((REAL) n);
+ w1[m] = cos( tm );
+ w2[m] = k * sin( tm ); /* k is -/+1 for forward/inverse fft */
+ }
+}
+\f
+C_Array_FFT_With_Given_Tables(flag, nu, n, f1, f2, g1,g2,w1,w2)
+ long flag, nu, n; REAL f1[], f2[], g1[], g2[], w1[], w2[];
+{ long n2=n>>1, a;
+ long i, l, m;
+ REAL twopi = 6.28318530717958, tm, k;
+
+ a = n; /* initially equal to length */
+ if (flag == 1) k=1.0;
+ else k = -1.0;
+
+ for (m=0; m<n; m++) {
+ g1[m] = f1[m];
+ g2[m] = f2[m];
+ }
+
+ if ((nu % 2) == 1) l = 2;
+ else l = 1;
+ for ( i = l; i <= nu ; i = i + 2 ) {
+ mult(g1,g2,f1,f2,w1,w2);
+ mult(f1,f2,g1,g2,w1,w2);
+ }
+
+
+
+ if (k==1.0) { /* forward fft */
+ if (l==1) { /* even power */
+ for (m=0; m<n; m++) {
+ f1[m] = g1[m]; f2[m] = g2[m];
+ }
+ }
+ else { /* odd power ==> do one more mult */
+ mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */
+ }}
+ else { /* backward fft */
+ tm = 1. / ((REAL) n); /* normalizing factor */
+ if (l==1) { /* even power */
+ for (m=0; m<n; m++) {
+ f1[m] = tm * g1[m]; f2[m] = tm * g2[m]; }
+ }
+ else { /* odd power ==> do one more mult */
+ mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */
+ for (m=0; m<n; m++) {
+ f1[m] = tm * f1[m]; f2[m] = tm * f2[m]; }
+ }
+ }
+}
+\f
+C_Array_2D_FFT_In_Scheme_Heap(flag, nrows, ncols, Real_Array, Imag_Array)
+ long flag, nrows, ncols; REAL *Real_Array, *Imag_Array;
+{ long i, j;
+ REAL *Temp_Array;
+ REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
+ long nrows_power, ncols_power, Length = nrows*ncols;
+
+ if (nrows==ncols) { /* SQUARE IMAGE, OPTIMIZE... */
+ Square_Image_2D_FFT_In_Scheme_Heap(flag, nrows, Real_Array, Imag_Array);
+ }
+ else { /* NOT A SQUARE IMAGE, CANNOT DO FAST_TRANSPOSE */
+ /* FIRST (NCOLS-1)POINT FFTS FOR EACH ROW, THEN (NROWS-1)POINT FFTS FOR EACH COLUMN */
+
+ for (ncols_power=0, i=ncols; i>1; ncols_power++) { /* FIND/CHECK POWERS OF ROWS,COLS */
+ if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ i=i/2; }
+ for (nrows_power=0, i=nrows; i>1; nrows_power++) {
+ if ( (i % 2) == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ i=i/2; }
+
+ Primitive_GC_If_Needed(Length*REAL_SIZE + ((max(nrows,ncols))*3*REAL_SIZE));
+ Work_Here = (REAL *) Free;
+ g1 = Work_Here;
+ g2 = Work_Here + ncols;
+ w1 = Work_Here + (ncols<<1);
+ w2 = Work_Here + (ncols<<1) + (ncols>>1);
+ Make_Twiddle_Tables(w1,w2,ncols, flag);
+ for (i=0;i<nrows;i++) { /* ROW-WISE */
+ f1 = Real_Array + (i*ncols);
+ f2 = Imag_Array + (i*ncols);
+ C_Array_FFT_With_Given_Tables(flag, ncols_power, ncols, f1,f2,g1,g2,w1,w2);
+ }
+
+ Temp_Array = Work_Here;
+ Work_Here = Temp_Array + Length;
+ Image_Transpose(Real_Array, Temp_Array, nrows, ncols); /* TRANSPOSE: (1) order of frequencies. (2) read columns.*/
+ Image_Transpose(Imag_Array, Real_Array, nrows, ncols);
+
+ g1 = Work_Here;
+ g2 = Work_Here + nrows;
+ w1 = Work_Here + (nrows<<1);
+ w2 = Work_Here + (nrows<<1) + (nrows>>1);
+ Make_Twiddle_Tables(w1,w2,nrows,flag);
+ for (i=0;i<ncols;i++) { /* COLUMN-WISE */
+ f1 = Temp_Array + (i*nrows); /* THIS IS REAL DATA */
+ f2 = Real_Array + (i*nrows); /* THIS IS IMAG DATA */
+ C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2);
+ }
+
+ Image_Transpose(Real_Array, Imag_Array, ncols, nrows); /* DO FIRST THIS !!!, do not screw up Real_Data !!! */
+ Image_Transpose(Temp_Array, Real_Array, ncols, nrows); /* TRANSPOSE BACK: order of frequencies. */
+ }
+}
+\f
+Square_Image_2D_FFT_In_Scheme_Heap(flag, nrows, Real_Array, Imag_Array)
+ long flag,nrows; REAL *Real_Array, *Imag_Array;
+{ REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
+ long nrows_power;
+ long i;
+
+ for (nrows_power=0, i=nrows; i>1; nrows_power++) { /* FIND/CHECK POWERS OF ROWS */
+ if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ i=i/2; }
+ Primitive_GC_If_Needed(nrows*3*REAL_SIZE);
+ Work_Here = (REAL *) Free;
+ g1 = Work_Here;
+ g2 = Work_Here + nrows;
+ w1 = Work_Here + (nrows<<1);
+ w2 = Work_Here + (nrows<<1) + (nrows>>1);
+ Make_Twiddle_Tables(w1, w2, nrows, flag); /* MAKE TABLES */
+ for (i=0;i<nrows;i++) { /* ROW-WISE */
+ f1 = Real_Array + (i*nrows);
+ f2 = Imag_Array + (i*nrows);
+ C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2);
+ }
+ Image_Fast_Transpose(Real_Array, nrows); /* MUST TRANSPOSE (1) order of frequencies. (2) read columns. */
+ Image_Fast_Transpose(Imag_Array, nrows);
+
+ for (i=0;i<nrows;i++) { /* COLUMN-WISE */
+ f1 = Real_Array + (i*nrows);
+ f2 = Imag_Array + (i*nrows);
+ C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2); /* ncols=nrows... Twiddles... */
+ }
+ Image_Fast_Transpose(Real_Array, nrows); /* TRANSPOSE BACK: order of frequencies. */
+ Image_Fast_Transpose(Imag_Array, nrows);
+}
+\f
+C_Array_3D_FFT_In_Scheme_Heap(flag, ndeps, nrows, ncols, Real_Array, Imag_Array)
+ long flag, ndeps, nrows, ncols; REAL *Real_Array, *Imag_Array;
+{ long l, m, n;
+ REAL *Temp_Array;
+ REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
+ long ndeps_power, nrows_power, ncols_power;
+
+ if ((ndeps==nrows) && (nrows==ncols)) { /* CUBIC IMAGE, OPTIMIZE... */
+ Cube_Space_3D_FFT_In_Scheme_Heap(flag, ndeps, Real_Array, Imag_Array);
+ }
+ else {
+ for (ndeps_power=0, l=ndeps; l>1; ndeps_power++) { /* FIND/CHECK POWERS OF DEPS,ROWS,COLS */
+ if ( (l % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ l=l/2; }
+ for (nrows_power=0, m=nrows; m>1; nrows_power++) {
+ if ( (m % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ m=m/2; }
+ for (ncols_power=0, n=ncols; n>1; ncols_power++) {
+ if ( (n % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ n=n/2; }
+
+ printf("3D FFT implemented only for cubic-spaces.\n");
+ printf("aborted\n.");
+ }
+}
+\f
+Cube_Space_3D_FFT_In_Scheme_Heap(flag, ndeps, Real_Array, Imag_Array)
+ long flag, ndeps; REAL *Real_Array, *Imag_Array;
+{ register long l, m, n;
+ register long ndeps_power, Surface_Length;
+ register REAL *From_Real, *From_Imag;
+ register REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
+
+ for (ndeps_power=0, l=ndeps; l>1; ndeps_power++) { /* FIND/CHECK POWER OF NDEPS */
+ if ( (l % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ l=l/2; }
+ Primitive_GC_If_Needed(ndeps*3*REAL_SIZE);
+ Work_Here = (REAL *) Free;
+ g1 = Work_Here;
+ g2 = Work_Here + ndeps;
+ w1 = Work_Here + (ndeps<<1);
+ w2 = Work_Here + (ndeps<<1) + (ndeps>>1);
+ Make_Twiddle_Tables(w1, w2, ndeps, flag); /* MAKE TABLES */
+
+ Surface_Length=ndeps*ndeps;
+ From_Real = Real_Array; From_Imag = Imag_Array;
+
+ for (l=0; l<ndeps; l++,From_Real+=Surface_Length,From_Imag+=Surface_Length) { /* DEPTH-WISE */
+
+ f1 = From_Real; f2 = From_Imag;
+ for (m=0; m<ndeps; m++,f1+=ndeps,f2+=ndeps) { /* ROW-WISE */
+ C_Array_FFT_With_Given_Tables(flag, ndeps_power, ndeps, f1,f2,g1,g2,w1,w2); }
+ Image_Fast_Transpose(From_Real, ndeps); /* MUST TRANSPOSE (1) order of frequencies. (2) read columns. */
+ Image_Fast_Transpose(From_Imag, ndeps);
+
+ /* ndeps=nrows=ncols, same Twiddle Tables */
+
+ f1 = From_Real; f2 = From_Imag;
+ for (n=0; n<ndeps; n++,f1+=ndeps,f2+=ndeps) { /* COLUMN-WISE */
+ C_Array_FFT_With_Given_Tables(flag, ndeps_power, ndeps, f1,f2,g1,g2,w1,w2); }
+ Image_Fast_Transpose(From_Real, ndeps); /* TRANSPOSE BACK: order of frequencies. */
+ Image_Fast_Transpose(From_Imag, ndeps);
+ }
+}
+
+\f
+/********************** below scheme primitives **********************/
+
+/* NOTE: IF Arg2 and Arg3 are EQ?, then it signals an error! */
+/* (Arg1 = 1 ==> forward FFT), otherwise inverse FFT */
+
+Define_Primitive(Prim_Array_FFT, 3, "ARRAY-FFT!")
+{ long length, length1, power, flag, i;
+ Pointer answer;
+ REAL *f1,*f2,*g1,*g2,*w1,*w2;
+ REAL *Work_Here;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_FIXNUM); /* flag */
+ Arg_2_Type(TC_ARRAY); /* real */
+ Arg_3_Type(TC_ARRAY); /* imag */
+ Set_Time_Zone(Zone_Math);
+
+ flag = Get_Integer(Arg1);
+ length = Array_Length(Arg2);
+ length1 = Array_Length(Arg3);
+
+ if (length != length1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ power=0;
+ for (power=0, i=length; i>1; power++) {
+ if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ i=i/2;
+ }
+
+ f1 = Scheme_Array_To_C_Array(Arg2);
+ f2 = Scheme_Array_To_C_Array(Arg3);
+ if (f1==f2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+
+ Primitive_GC_If_Needed(length*3*REAL_SIZE);
+ Work_Here = (REAL *) Free;
+ g1 = Work_Here;
+ g2 = Work_Here + length;
+ w1 = Work_Here + (length<<1);
+ w2 = Work_Here + (length<<1) + (length>>1);
+
+ C_Array_FFT(flag, power, length, f1,f2,g1,g2,w1,w2);
+
+ Primitive_GC_If_Needed(4);
+ answer = Make_Pointer(TC_LIST, Free);
+ *Free++ = Arg2;
+ *Free = Make_Pointer(TC_LIST, Free+1);
+ Free += 1;
+ *Free++ = Arg3;
+ *Free++ = NIL;
+ return answer;
+}
+\f
+Define_Primitive(Prim_Array_2D_FFT, 5, "ARRAY-2D-FFT!")
+{ long flag, i, j;
+ Pointer answer;
+ REAL *Real_Array, *Imag_Array, *Temp_Array;
+ REAL *f1,*f2,*g1,*g2,*w1,*w2;
+ REAL *Work_Here;
+ long Length, nrows, ncols, nrows_power, ncols_power;
+
+ Primitive_5_Args();
+ Arg_1_Type(TC_FIXNUM); /* flag */
+ Range_Check(nrows, Arg2, 1, 512, ERR_ARG_2_BAD_RANGE);
+ Range_Check(ncols, Arg3, 1, 512, ERR_ARG_3_BAD_RANGE);
+ Arg_4_Type(TC_ARRAY); /* real image */
+ Arg_5_Type(TC_ARRAY); /* imag image */
+ Set_Time_Zone(Zone_Math); /* for timing */
+
+ Sign_Extend(Arg1, flag); /* should be 1 or -1 */
+ Length = Array_Length(Arg4);
+ if (Length != (nrows*ncols)) Primitive_Error(ERR_ARG_5_BAD_RANGE);
+ if (Length != (Array_Length(Arg5))) Primitive_Error(ERR_ARG_5_BAD_RANGE);
+ Real_Array = Scheme_Array_To_C_Array(Arg4);
+ Imag_Array = Scheme_Array_To_C_Array(Arg5);
+ if (f1==f2) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
+
+ for (ncols_power=0, i=ncols; i>1; ncols_power++) { /* FIND/CHECK POWERS OF ROWS,COLS */
+ if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ i=i/2; }
+ for (nrows_power=0, i=nrows; i>1; nrows_power++) {
+ if ( (i % 2) == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ i=i/2; }
+\f
+ if (nrows==ncols) { /* SQUARE IMAGE, OPTIMIZE... */
+ Primitive_GC_If_Needed(nrows*3*REAL_SIZE);
+ Work_Here = (REAL *) Free;
+ g1 = Work_Here;
+ g2 = Work_Here + ncols;
+ w1 = Work_Here + (ncols<<1);
+ w2 = Work_Here + (ncols<<1) + (ncols>>1);
+ for (i=0;i<nrows;i++) { /* ROW-WISE */
+ f1 = Real_Array + (i*ncols);
+ f2 = Imag_Array + (i*ncols);
+ C_Array_FFT(flag, ncols_power, ncols, f1,f2,g1,g2,w1,w2);
+ }
+ Image_Fast_Transpose(Real_Array, nrows); /* MUST TRANSPOSE (1) order of frequencies. (2) read columns. */
+ Image_Fast_Transpose(Imag_Array, nrows);
+
+ for (i=0;i<ncols;i++) { /* COLUMN-WISE */
+ f1 = Real_Array + (i*nrows);
+ f2 = Imag_Array + (i*nrows);
+ C_Array_FFT(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2);
+ }
+ Image_Fast_Transpose(Real_Array, nrows); /* TRANSPOSE BACK: order of frequencies. */
+ Image_Fast_Transpose(Imag_Array, nrows);
+ }
+\f
+ else { /* NOT A SQUARE IMAGE, CANNOT DO FAST_TRANSPOSE */
+ /* FIRST (NCOLS-1)POINT FFTS FOR EACH ROW, THEN (NROWS-1)POINT FFTS FOR EACH COLUMN */
+
+ Primitive_GC_If_Needed(nrows*3*REAL_SIZE);
+ Primitive_GC_If_Needed(ncols*3*REAL_SIZE);
+ Primitive_GC_If_Needed(Length*REAL_SIZE);
+ Work_Here = (REAL *) Free;
+ g1 = Work_Here;
+ g2 = Work_Here + ncols;
+ w1 = Work_Here + (ncols<<1);
+ w2 = Work_Here + (ncols<<1) + (ncols>>1);
+ for (i=0;i<nrows;i++) { /* ROW-WISE */
+ f1 = Real_Array + (i*ncols);
+ f2 = Imag_Array + (i*ncols);
+ C_Array_FFT(flag, ncols_power, ncols, f1,f2,g1,g2,w1,w2);
+ }
+
+ Temp_Array = Work_Here;
+ Image_Transpose(Real_Array, Temp_Array, nrows, ncols); /* TRANSPOSE: (1) order of frequencies. (2) read columns.*/
+ Image_Transpose(Imag_Array, Real_Array, nrows, ncols);
+ C_Array_Copy(Temp_Array, Imag_Array, Length);
+ Temp_Array = Real_Array; /* JUST POINTER SWITCHING */
+ Real_Array = Imag_Array;
+ Imag_Array = Temp_Array;
+
+ g1 = Work_Here;
+ g2 = Work_Here + nrows;
+ w1 = Work_Here + (nrows<<1);
+ w2 = Work_Here + (nrows<<1) + (nrows>>1);
+ for (i=0;i<ncols;i++) { /* COLUMN-WISE */
+ f1 = Real_Array + (i*nrows);
+ f2 = Imag_Array + (i*nrows);
+ C_Array_FFT(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2);
+ }
+
+ Image_Transpose(Real_Array, Temp_Array, ncols, nrows); /* TRANSPOSE BACK: order of frequencies. */
+ Image_Transpose(Imag_Array, Real_Array, ncols, nrows); /* NOTE: switch in ncols nrows. */
+ C_Array_Copy(Temp_Array, Imag_Array, Length); /* THIS UNDOES THE SWITCHING IN ARG4,ARG5 */
+ }
+
+ Primitive_GC_If_Needed(4); /* NOW RETURN ANSWERS */
+ answer = Make_Pointer(TC_LIST, Free);
+ *Free++ = Arg4;
+ *Free = Make_Pointer(TC_LIST, Free+1);
+ Free += 1;
+ *Free++ = Arg5;
+ *Free++ = NIL;
+ return answer;
+}
+\f
+Define_Primitive(Prim_Array_2D_FFT_3, 5, "ARRAY-2D-FFT-3!")
+{ long flag, i, j;
+ Pointer answer;
+ REAL *Real_Array, *Imag_Array, *Temp_Array;
+ REAL *f1,*f2,*g1,*g2,*w1,*w2;
+ REAL *Work_Here;
+ long Length, nrows, ncols, nrows_power, ncols_power;
+
+ Primitive_5_Args();
+ Arg_1_Type(TC_FIXNUM); /* flag */
+ Range_Check(nrows, Arg2, 1, 512, ERR_ARG_2_BAD_RANGE);
+ Range_Check(ncols, Arg3, 1, 512, ERR_ARG_3_BAD_RANGE);
+ Arg_4_Type(TC_ARRAY); /* real image */
+ Arg_5_Type(TC_ARRAY); /* imag image */
+ Set_Time_Zone(Zone_Math); /* for timing */
+
+ Sign_Extend(Arg1, flag); /* should be 1 or -1 */
+ Length = Array_Length(Arg4);
+ if (Length != (nrows*ncols)) Primitive_Error(ERR_ARG_5_BAD_RANGE);
+ if (Length != (Array_Length(Arg5))) Primitive_Error(ERR_ARG_5_BAD_RANGE);
+ Real_Array = Scheme_Array_To_C_Array(Arg4);
+ Imag_Array = Scheme_Array_To_C_Array(Arg5);
+ if (f1==f2) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
+
+ for (ncols_power=0, i=ncols; i>1; ncols_power++) { /* FIND/CHECK POWERS OF ROWS,COLS */
+ if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ i=i/2; }
+ for (nrows_power=0, i=nrows; i>1; nrows_power++) {
+ if ( (i % 2) == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ i=i/2; }
+\f
+ if (nrows==ncols) { /* SQUARE IMAGE, OPTIMIZE... */
+ Primitive_GC_If_Needed(nrows*3*REAL_SIZE);
+ Work_Here = (REAL *) Free;
+ g1 = Work_Here;
+ g2 = Work_Here + ncols;
+ w1 = Work_Here + (ncols<<1);
+ w2 = Work_Here + (ncols<<1) + (ncols>>1);
+ Make_Twiddle_Tables(w1, w2, ncols, flag); /* MAKE TABLES */
+ for (i=0;i<nrows;i++) { /* ROW-WISE */
+ f1 = Real_Array + (i*ncols);
+ f2 = Imag_Array + (i*ncols);
+ C_Array_FFT_With_Given_Tables(flag, ncols_power, ncols, f1,f2,g1,g2,w1,w2);
+ }
+ Image_Fast_Transpose(Real_Array, nrows); /* MUST TRANSPOSE (1) order of frequencies. (2) read columns. */
+ Image_Fast_Transpose(Imag_Array, nrows);
+
+ for (i=0;i<ncols;i++) { /* COLUMN-WISE */
+ f1 = Real_Array + (i*nrows);
+ f2 = Imag_Array + (i*nrows);
+ C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2); /* ncols=nrows... Twiddles... */
+ }
+ Image_Fast_Transpose(Real_Array, nrows); /* TRANSPOSE BACK: order of frequencies. */
+ Image_Fast_Transpose(Imag_Array, nrows);
+ }
+\f
+ else { /* NOT A SQUARE IMAGE, CANNOT DO FAST_TRANSPOSE */
+ /* FIRST (NCOLS-1)POINT FFTS FOR EACH ROW, THEN (NROWS-1)POINT FFTS FOR EACH COLUMN */
+
+ Primitive_GC_If_Needed(nrows*3*REAL_SIZE);
+ Primitive_GC_If_Needed(ncols*3*REAL_SIZE);
+ Primitive_GC_If_Needed(Length*REAL_SIZE);
+ Work_Here = (REAL *) Free;
+ g1 = Work_Here;
+ g2 = Work_Here + ncols;
+ w1 = Work_Here + (ncols<<1);
+ w2 = Work_Here + (ncols<<1) + (ncols>>1);
+ Make_Twiddle_Tables(w1,w2,ncols, flag);
+ for (i=0;i<nrows;i++) { /* ROW-WISE */
+ f1 = Real_Array + (i*ncols);
+ f2 = Imag_Array + (i*ncols);
+ C_Array_FFT_With_Given_Tables(flag, ncols_power, ncols, f1,f2,g1,g2,w1,w2);
+ }
+
+ Temp_Array = Work_Here;
+ Image_Transpose(Real_Array, Temp_Array, nrows, ncols); /* TRANSPOSE: (1) order of frequencies. (2) read columns.*/
+ Image_Transpose(Imag_Array, Real_Array, nrows, ncols);
+ C_Array_Copy(Temp_Array, Imag_Array, Length);
+ Temp_Array = Real_Array; /* JUST POINTER SWITCHING */
+ Real_Array = Imag_Array;
+ Imag_Array = Temp_Array;
+
+ g1 = Work_Here;
+ g2 = Work_Here + nrows;
+ w1 = Work_Here + (nrows<<1);
+ w2 = Work_Here + (nrows<<1) + (nrows>>1);
+ Make_Twiddle_Tables(w1,w2,nrows,flag);
+ for (i=0;i<ncols;i++) { /* COLUMN-WISE */
+ f1 = Real_Array + (i*nrows);
+ f2 = Imag_Array + (i*nrows);
+ C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2);
+ }
+
+ Image_Transpose(Real_Array, Temp_Array, ncols, nrows); /* TRANSPOSE BACK: order of frequencies. */
+ Image_Transpose(Imag_Array, Real_Array, ncols, nrows);
+ C_Array_Copy(Temp_Array, Imag_Array, Length); /* THIS UNDOES THE SWITCHING IN ARG4,ARG5 */
+ }
+
+ Primitive_GC_If_Needed(4); /* NOW RETURN ANSWERS */
+ answer = Make_Pointer(TC_LIST, Free);
+ *Free++ = Arg4;
+ *Free = Make_Pointer(TC_LIST, Free+1);
+ Free += 1;
+ *Free++ = Arg5;
+ *Free++ = NIL;
+ return answer;
+}
+\f
+Define_Primitive(Prim_Array_2D_FFT_2, 5, "ARRAY-2D-FFT-2!")
+{ long flag;
+ Pointer answer;
+ REAL *Real_Array, *Imag_Array;
+ long Length, nrows, ncols;
+
+ Primitive_5_Args();
+ Arg_1_Type(TC_FIXNUM); /* flag */
+ Range_Check(nrows, Arg2, 1, 512, ERR_ARG_2_BAD_RANGE);
+ Range_Check(ncols, Arg3, 1, 512, ERR_ARG_3_BAD_RANGE);
+ Arg_4_Type(TC_ARRAY); /* real image */
+ Arg_5_Type(TC_ARRAY); /* imag image */
+ Set_Time_Zone(Zone_Math); /* for timing */
+
+ Sign_Extend(Arg1, flag); /* should be 1 or -1 */
+ Length = Array_Length(Arg4);
+ if (Length != (nrows*ncols)) Primitive_Error(ERR_ARG_5_BAD_RANGE);
+ if (Length != (Array_Length(Arg5))) Primitive_Error(ERR_ARG_5_BAD_RANGE);
+ Real_Array = Scheme_Array_To_C_Array(Arg4);
+ Imag_Array = Scheme_Array_To_C_Array(Arg5);
+ if (Real_Array==Imag_Array) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
+
+ C_Array_2D_FFT_In_Scheme_Heap(flag, nrows, ncols, Real_Array, Imag_Array);
+
+ Primitive_GC_If_Needed(4); /* NOW RETURN ANSWERS */
+ answer = Make_Pointer(TC_LIST, Free);
+ *Free++ = Arg4;
+ *Free = Make_Pointer(TC_LIST, Free+1);
+ Free += 1;
+ *Free++ = Arg5;
+ *Free++ = NIL;
+ return answer;
+}
+\f
+Define_Primitive(Prim_Array_3D_FFT, 6, "ARRAY-3D-FFT!")
+{ long flag;
+ Pointer answer;
+ REAL *Real_Array, *Imag_Array;
+ long Length, ndeps, nrows, ncols;
+
+ Primitive_6_Args();
+ Arg_1_Type(TC_FIXNUM); /* flag */
+ Range_Check(ndeps, Arg2, 1, 512, ERR_ARG_2_BAD_RANGE);
+ Range_Check(nrows, Arg3, 1, 512, ERR_ARG_2_BAD_RANGE);
+ Range_Check(ncols, Arg4, 1, 512, ERR_ARG_3_BAD_RANGE);
+ Arg_5_Type(TC_ARRAY); /* real image */
+ Arg_6_Type(TC_ARRAY); /* imag image */
+ Set_Time_Zone(Zone_Math); /* for timing */
+
+ Sign_Extend(Arg1, flag); /* should be 1 or -1 */
+ Length = Array_Length(Arg5);
+ if (Length != (ndeps*nrows*ncols)) Primitive_Error(ERR_ARG_6_BAD_RANGE);
+ if (Length != (Array_Length(Arg6))) Primitive_Error(ERR_ARG_6_BAD_RANGE);
+ Real_Array = Scheme_Array_To_C_Array(Arg5);
+ Imag_Array = Scheme_Array_To_C_Array(Arg6);
+ if (Real_Array==Imag_Array) Primitive_Error(ERR_ARG_6_WRONG_TYPE);
+
+ C_Array_3D_FFT_In_Scheme_Heap(flag, ndeps, nrows, ncols, Real_Array, Imag_Array);
+
+ Primitive_GC_If_Needed(4); /* NOW RETURN ANSWERS */
+ answer = Make_Pointer(TC_LIST, Free);
+ *Free++ = Arg5;
+ *Free = Make_Pointer(TC_LIST, Free+1);
+ Free += 1;
+ *Free++ = Arg6;
+ *Free++ = NIL;
+ return answer;
+}
+
+/* END */
+
--- /dev/null
+/* File: FHOOKS.C
+ *
+ * This file contains hooks and handles for the new fluid bindings
+ * scheme for multiprocessors.
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+#include "locks.h"
+
+/* (SET-FLUID-BINDINGS! NEW-BINDINGS)
+ Sets the microcode fluid-bindings variable. Returns the previous value.
+*/
+Define_Primitive(Prim_Set_Fluid_Bindings, 1, "SET-FLUID-BINDINGS!")
+{ Pointer Result;
+ Primitive_1_Arg();
+ if (Arg1 != NIL) Arg_1_Type(TC_LIST);
+ Result = Fluid_Bindings;
+ Fluid_Bindings = Arg1;
+ return Result;
+}
+
+/* (GET-FLUID-BINDINGS NEW-BINDINGS)
+ Gets the microcode fluid-bindings variable.
+*/
+Define_Primitive(Prim_Get_Fluid_Bindings, 0, "GET-FLUID-BINDINGS")
+{ Primitive_0_Args();
+ return Fluid_Bindings;
+}
+
+/* (WITH-SAVED-FLUID-BINDINGS THUNK)
+ Executes THUNK, then restores the previous fluid bindings.
+*/
+Define_Primitive(Prim_With_Saved_Fluid_Bindings,1,"WITH-SAVED-FLUID-BINDINGS")
+{ Primitive_1_Arg();
+ Pop_Primitive_Frame(1);
+ /* Save previous fluid bindings for later restore */
+ Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
+ Store_Expression(Fluid_Bindings);
+ Store_Return(RC_RESTORE_FLUIDS);
+ Save_Cont();
+ Push(Arg1);
+ Push(STACK_FRAME_HEADER);
+ Pushed();
+ longjmp(*Back_To_Eval, PRIM_APPLY);
+}
+\f
+/* (ADD-FLUID-BINDING! ENVIRONMENT SYMBOL-OR-VARIABLE VALUE)
+ Looks up symbol-or-variable in environment. If it has not been
+ fluidized, fluidizes it. A fluid binding with the specified
+ value is created in this interpreter's fluid bindings.
+*/
+Define_Primitive(Prim_Add_Fluid_Binding, 3, "ADD-FLUID-BINDING!")
+{ Pointer Trap_Obj;
+ int Temp_Obj;
+
+ Primitive_3_Args();
+ if (Arg1 != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT);
+ switch (Type_Code(Arg2))
+ { case TC_VARIABLE:
+ Temp_Obj = Lookup_Slot(Arg2, Arg1);
+ if (Temp_Obj == NO_SLOT || Temp_Obj == FOUND_UNBOUND)
+ Primitive_Error(ERR_UNBOUND_VARIABLE);
+ break;
+ case TC_INTERNED_SYMBOL:
+ case TC_UNINTERNED_SYMBOL:
+ Temp_Obj = Symbol_Lookup_Slot(Arg1, Arg2);
+ if (Temp_Obj == NO_SLOT || Temp_Obj == FOUND_UNBOUND)
+ Primitive_Error(ERR_UNBOUND_VARIABLE);
+ break;
+ default:
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ }
+ /* Lock region, check if the slot at Lookup_Base[Lookup_Offset] is
+ a fluid already. Return it if so, make a new fluid and store it
+ there if not, unlock the region. */
+ {
+#ifdef COMPILE_FUTURES
+ Lock_Handle Set_Serializer;
+#endif
+ Pointer Found_Val, Safe_Val;
+ if (Lookup_Offset == HEAP_ENV_FUNCTION) Primitive_Error(ERR_BAD_SET);
+#ifdef COMPILE_FUTURES
+ Set_Serializer = Lock_Cell(Nth_Vector_Loc(Lookup_Base, Lookup_Offset));
+#endif
+ Found_Val = Fast_Vector_Ref(Lookup_Base, Lookup_Offset);
+ Safe_Val = Found_Val & ~DANGER_BIT;
+ if (Type_Code(Safe_Val) == TC_TRAP) Trap_Obj = Found_Val;
+ else
+ { Primitive_GC_If_Needed(TRAP_SIZE);
+ Trap_Obj = (Pointer) Free;
+ *Free++ = NIL; /* Tag for fluids */
+ *Free++ = Safe_Val;
+ *Free++ = Arg2; /* For debugging purposes */
+ Store_Type_Code(Trap_Obj,
+ ((Found_Val==Safe_Val)?TC_TRAP:TC_TRAP|DANGER_TYPE));
+ Fast_Vector_Set(Lookup_Base, Lookup_Offset, Trap_Obj);
+ }
+#ifdef COMPILE_FUTURES
+ Unlock_Cell(Set_Serializer);
+#endif
+ Add_Fluid_Binding(Trap_Obj, Arg3);
+ Val = NIL;
+ return Val;
+ }
+}
+\f
+/* (MAKE-FLUID-BINDING! ENVIRONMENT SYMBOL-OR-VARIABLE VALUE)
+ Looks up symbol-or-variable in environment. If it has not been
+ fluidized, fluidizes it. A fluid binding with the specified
+ value is created in this interpreter's fluid bindings. Unlike
+ ADD-FLUID-BINDING!, it is not an error to discover no binding
+ for this variable; a fluid binding will be made anyway. This is
+ simple in the global case, since there is always a value slot
+ available in the symbol itself. If the last frame searched
+ in the environment chain is closed (does not have a parent
+ and does not allow search of the global environment), an AUX
+ binding must be established in the last frame.
+*/
+Define_Primitive(Prim_Make_Fluid_Binding, 3, "MAKE-FLUID-BINDING!")
+{ Pointer Trap_Obj;
+
+ Primitive_3_Args();
+ if (Arg1 != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT);
+ switch (Type_Code(Arg2))
+ { /* Need to check for unbound in non-global env and build
+ an AUX binding in that frame if so. Do nothing in
+ usual case, unbound in global env.
+ */
+ case TC_VARIABLE:
+ Binding_Lookup_Slot(Arg2, Arg1);
+ break;
+ case TC_INTERNED_SYMBOL:
+ case TC_UNINTERNED_SYMBOL:
+ Symbol_Binding_Lookup_Slot(Arg1, Arg2);
+ break;
+ default:
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ }
+ /* Lock region, check if the slot at Lookup_Base[Lookup_Offset] is
+ a fluid already. Return it if so, make a new fluid and store it
+ there if not, unlock the region. */
+ {
+#ifdef COMPILE_FUTURES
+ Lock_Handle Set_Serializer;
+#endif
+ Pointer Found_Val, Safe_Val;
+ if (Lookup_Offset == HEAP_ENV_FUNCTION) Primitive_Error(ERR_BAD_SET);
+#ifdef COMPILE_FUTURES
+ Set_Serializer = Lock_Cell(Nth_Vector_Loc(Lookup_Base, Lookup_Offset));
+#endif
+ Found_Val = Fast_Vector_Ref(Lookup_Base, Lookup_Offset);
+ Safe_Val = Found_Val & ~DANGER_BIT;
+ if (Type_Code(Safe_Val) == TC_TRAP) Trap_Obj = Found_Val;
+ else
+ { Primitive_GC_If_Needed(TRAP_SIZE);
+ Trap_Obj = (Pointer) Free;
+ *Free++ = NIL; /* Tag for fluids */
+ /* Binding version always makes unbounds unassigned */
+ *Free++ = (Safe_Val == UNBOUND_OBJECT) ? UNASSIGNED_OBJECT:Safe_Val;
+ *Free++ = Arg2; /* For debugging purposes */
+ Store_Type_Code(Trap_Obj,
+ ((Found_Val==Safe_Val)?TC_TRAP:TC_TRAP|DANGER_TYPE));
+ Fast_Vector_Set(Lookup_Base, Lookup_Offset, Trap_Obj);
+ }
+#ifdef COMPILE_FUTURES
+ Unlock_Cell(Set_Serializer);
+#endif
+ Add_Fluid_Binding(Trap_Obj, Arg3);
+ Val = NIL;
+ return Val;
+ }
+}
+\f
+Add_Fluid_Binding(Key, Value)
+Pointer Key, Value;
+{ Pointer New_Fluids;
+
+ Primitive_GC_If_Needed(2 + 2);
+ New_Fluids = Make_Pointer(TC_LIST, Free);
+ *Free = Make_Pointer(TC_LIST, &Free[2]);
+ Free += 1;
+ *Free++ = Fluid_Bindings;
+ *Free++ = Key;
+ *Free++ = Value;
+ Fluid_Bindings = New_Fluids;
+}
+
+Symbol_Lookup_Slot(Frame, Symbol)
+Pointer Frame, Symbol;
+{ int result;
+ Pointer *Variable = Free;
+ Free += 3;
+ Variable[VARIABLE_SYMBOL] = (Symbol);
+ Variable[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
+ result = Lookup_Slot(Make_Pointer(TC_VARIABLE, Variable), (Frame));
+ if (Free == Variable+3) Free = Variable;
+ return result;
+}
+
+Binding_Symbol_Lookup_Slot(Frame, Symbol)
+Pointer Frame, Symbol;
+{ int result;
+ Pointer *Variable = Free;
+ Free += 3;
+ Variable[VARIABLE_SYMBOL] = (Symbol);
+ Variable[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
+ result = Binding_Lookup_Slot(Make_Pointer(TC_VARIABLE, Variable), (Frame));
+ if (Free == Variable+3) Free = Variable;
+ return result;
+}
+
+/* A version which creates a new binding if unbound in last frame */
+
+Symbol_Binding_Lookup_Slot(Frame, Symbol)
+Pointer Frame, Symbol;
+{ int result;
+ Pointer *Variable = Free;
+ Free += 3;
+ Variable[VARIABLE_SYMBOL] = (Symbol);
+ Variable[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
+ result = Binding_Lookup_Slot(Make_Pointer(TC_VARIABLE, Variable), (Frame));
+ if (Free == Variable+3) Free = Variable;
+ return result;
+}
+
+
--- /dev/null
+/* Emacs, please use -*-C-*- mode */
+
+/****************************************************************
+* *
+* 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. *
+* *
+****************************************************************/
+
+/* File: Findprim.c
+ *
+ * Preprocessor to find and declare user defined primitives.
+ *
+ * Searches for a token which is a macro defined in primitive.h.
+ * For each macro invocation it creates an entry in the External
+ * Primitives descriptor used by Scheme. The entry consists of
+ * the C routine implementing the primitive, the (fixed) number of
+ * arguments it requires, and the name Scheme uses to refer to it.
+ *
+ * The output is a C source file (on stdout, must be redirected)
+ * to be compiled and linked with the Scheme microcode.
+*/
+\f
+/* In the following some output lines are done in a strange fashion
+ * because some C compilers (the vms C compiler, for example) remove
+ * comments even from within string quotes!!
+ */
+
+static char The_Token[] = "Define_Primitive";
+
+/* Maximum number of primitives that can be handled. */
+
+#ifndef BUFFER_SIZE
+#define BUFFER_SIZE 200
+#endif
+\f
+#include <stdio.h>
+
+/* For macros toupper, isalpha, etc, supposedly on the standard library */
+#include <ctype.h>
+
+#ifdef vax
+#ifdef vms
+#define normal_exit() return
+#else /* Vax, but not a VMS */
+#define normal_exit() exit(0)
+#include <strings.h>
+#endif
+#else /* Not a Vax */
+#define normal_exit() exit(0)
+#endif
+
+#define TRUE 1
+#define FALSE 0
+
+typedef int boolean;
+
+#ifdef DEBUGGING
+#define dprintf(one, two) fprintf(stderr, one, two)
+#else
+#define dprintf(one, two)
+#endif
+
+static FILE *input, *output;
+static char *name;
+static char *file_name;
+
+#define error_exit(do_it) { if (do_it) dump(TRUE); exit(1); }
+
+main(argc, argv)
+int argc;
+char *argv[];
+{ FILE *fopen();
+
+ name = argv[0];
+
+ /* Check for specified output file */
+
+ if ((argc >= 2) && (strcmp("-o", argv[1])==0))
+ { if ((output = fopen(argv[2], "w")) == NULL)
+ { fprintf(stderr, "Error: %s can't open %s\n", name, argv[2]);
+ error_exit(FALSE);
+ }
+ argv += 2;
+ argc -= 2;
+ }
+ else output = stdout;
+
+ if (argc == 1)
+ { dump(FALSE);
+ normal_exit();
+ }
+
+ while (--argc > 0)
+ { file_name = *++argv;
+ if (strcmp("-", file_name)==0)
+ { input = stdin;
+ file_name = "stdin";
+ dprintf("About to process %s\n", "STDIN");
+ process();
+ }
+ else if ((input = fopen(file_name, "r")) == NULL)
+ { fprintf(stderr, "Error: %s can't open %s\n", name, file_name);
+ error_exit(TRUE);
+ }
+ else
+ { dprintf("About to process %s\n", file_name);
+ process();
+ fclose(input);
+ }
+ }
+ dprintf("About to sort %s\n", "");
+ sort();
+ dprintf("About to dump %s\n", "");
+ dump(TRUE);
+ if (output != stdout) fclose(output);
+ normal_exit();
+ }
+\f
+#define DONE 0
+#define FOUND 1
+
+/* Search for tokens and when found, create primitive entries. */
+
+process()
+{ while ((scan() != DONE))
+ { dprintf("Process: place found.%s\n", "");
+ create_entry();
+ }
+}
+
+/* Search for token and stop when found. If you hit open comment
+ * character, read until you hit close comment character.
+ * FIX: It is not a complete C parser, thus it may be fooled,
+ * currently the token must always begin a line.
+*/
+
+scan()
+{ register char c, *temp;
+
+ c = '\n';
+ while(c != EOF)
+ {
+ switch(c)
+ { case '/':
+ if ((c = getc(input)) == '*')
+ { c = getc(input);
+ while (TRUE)
+ { while (c != '*')
+ { if (c == EOF)
+ { fprintf(stderr,
+ "Error: EOF in comment in file %s, or %s confused\n",
+ file_name, name);
+ error_exit(TRUE);
+ }
+ c = getc(input);
+ }
+ if ((c = getc(input)) == '/') break;
+ }
+ }
+ else if (c != '\n') break;
+
+ case '\n':
+ temp = &The_Token[0];
+ while ((c = getc(input)) == *temp++) {}
+ if (temp[-1] == '\0') return FOUND;
+ ungetc(c, input);
+ break;
+
+ default: {}
+ }
+ c = getc(input);
+ }
+ return DONE;
+}
+\f
+#define STRING_SIZE 80
+#define ARITY_SIZE 6
+
+typedef struct dsc
+{ char C_Name[STRING_SIZE]; /* The C name of the function */
+ char Arity[ARITY_SIZE]; /* Number of arguments */
+ char Scheme_Name[STRING_SIZE]; /* Scheme name of the primitive */
+} descriptor;
+
+/* FIX: This should really be malloced incrementally,
+ * but for the time being ... */
+
+descriptor Data_Buffer[BUFFER_SIZE]; /* New Primitives Allowed */
+static int buffer_index = 0;
+
+static int C_Size = 0;
+static int A_Size = 0;
+static int S_Size = 0;
+
+#define DONT_CAP FALSE
+#define DO_CAP TRUE
+
+create_entry()
+{ if (buffer_index >= BUFFER_SIZE)
+ { fprintf(stderr, "Error: %s cannot handle so many primitives.\n", name);
+ fprintf(stderr, "Recompile %s with BUFFER_SIZE larger than %d.\n",
+ name, BUFFER_SIZE);
+ error_exit(FALSE);
+ }
+ scan_to_token_start();
+ copy_token((Data_Buffer[buffer_index]).C_Name, DONT_CAP, &C_Size);
+ scan_to_token_start();
+ copy_token((Data_Buffer[buffer_index]).Arity, DONT_CAP, &A_Size);
+ scan_to_token_start();
+ copy_token((Data_Buffer[buffer_index]).Scheme_Name, DO_CAP, &S_Size);
+ buffer_index++;
+}
+
+scan_to_token_start()
+{ char c;
+ while (whitespace(c = getc(input))) {};
+ ungetc(c, input);
+}
+
+/* FIX: This should check for field overflow (n too small) */
+
+copy_token(s, cap, Size)
+char s[];
+boolean cap;
+int *Size;
+{ register char c;
+ register int n = 0;
+ while (!(whitespace(c = getc(input))))
+ s[n++] = ((cap && isalpha(c) && islower(c))? toupper(c) : c);
+ s[n] = '\0';
+ if (n > *Size) *Size = n;
+}
+
+whitespace(c)
+char c;
+{ switch(c)
+ { case ' ':
+ case '(':
+ case ')':
+ case ',': return TRUE;
+ default: return FALSE;
+ }
+}
+\f
+/* FIX: No-op for now */
+
+sort()
+{ return FALSE;
+}
+\f
+print_spaces(how_many)
+register int how_many;
+{ for(; --how_many >= 0;) putc(' ', output);
+}
+
+#define print_entry(index) \
+fprintf(output, " %s,", (Data_Buffer[index].C_Name)); \
+print_spaces(1+ \
+ (C_Size-(strlen(Data_Buffer[index].C_Name)))+ \
+ (A_Size-(strlen(Data_Buffer[index].Arity)))); \
+fprintf(output, "%s", (Data_Buffer[index]).Arity); \
+fprintf(output, ", %s", (Data_Buffer[index]).Scheme_Name); \
+print_spaces(S_Size-(strlen(Data_Buffer[index].Scheme_Name))); \
+fprintf(output, " /%c External %d %c/", '*', index, '*')
+
+/* Produce C source. */
+
+dump(check)
+boolean check;
+{ register int count;
+ int max = buffer_index-1;
+
+ /* Print header. */
+
+ fprintf(output, "/%c User defined primitive declarations %c/\n\n",
+ '*', '*');
+ fprintf(output, "#include \"scheme.h\"\n\n");
+
+ if (max < 0)
+ {
+ if (check) fprintf(stderr, "No User primitives found!\n");
+
+ /* C does not understand the empty array, thus it must be faked. */
+
+ fprintf(output, "/%c C does not understand the empty array, ", '*');
+ fprintf(output, "thus it must be faked. %c/\n\n", '*');
+
+ /* Dummy entry */
+
+ fprintf(output, "Pointer Dummy_Primitive()\n");
+ fprintf(output, "{ /%c This should NEVER be called. %c/\n", '*', '*');
+ fprintf(output, " Microcode_Termination(TERM_BAD_PRIMITIVE);\n");
+ fprintf(output, "}\n\n");
+
+ /* Array with Dummy entry */
+
+ fprintf(output, "External_Descriptor Ext_Prim_Desc[] = {\n");
+ fprintf(output, " Dummy_Primitive, 0, \"DUMMY-PRIMITIVE\"\n");
+ fprintf(output, "};\n\n");
+ }
+ else
+ {
+ /* Print extern declarations. */
+
+ fprintf(output, "extern Pointer\n");
+ for (count = 0; count < max; count++)
+ fprintf(output, " %s(),\n", Data_Buffer[count].C_Name);
+ fprintf(output, " %s();\n\n", Data_Buffer[max].C_Name);
+
+ /* Print structure. */
+
+ fprintf(output, "External_Descriptor Ext_Prim_Desc[] = {\n");
+
+ for (count = 0; count < max; count++)
+ { print_entry(count);
+ fprintf(output, ",\n");
+ }
+ print_entry(max);
+
+ fprintf(output, "\n};\n\n");
+ }
+
+ fprintf(output, "long MAX_EXTERNAL_PRIMITIVE = %d;\n\n", max);
+ return;
+}
--- /dev/null
+/* 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
+#include "scheme.h"
+#include "primitive.h"
+
+/* File: FIXNUM.C
+ *
+ * Support for fixed point arithmetic (24 bit). Mostly superceded
+ * by generic arithmetic.
+ */
+
+ /***************************/
+ /* UNARY FIXNUM OPERATIONS */
+ /***************************/
+
+/* These operations return NIL if their argument is not a fixnum.
+ Otherwise, they return the appropriate fixnum if the result is
+ expressible as a fixnum. If the result is out of range, they
+ return NIL.
+*/
+
+Built_In_Primitive(Prim_One_Plus_Fixnum, 1, "ONE-PLUS-FIXNUM")
+{ fast long A, Result;
+ Primitive_1_Arg();
+ Arg_1_Type(TC_FIXNUM);
+ Sign_Extend(Arg1, A);
+ Result = A + 1;
+ if (Fixnum_Fits(Result)) return Make_Non_Pointer(TC_FIXNUM, Result);
+ else return NIL;
+}
+
+Built_In_Primitive(Prim_M_1_Plus_Fixnum, 1, "MINUS-ONE-PLUS-FIXNUM")
+{ fast long A, Result;
+ Primitive_1_Arg();
+ Arg_1_Type(TC_FIXNUM);
+ Sign_Extend(Arg1, A);
+ Result = A - 1;
+ if (Fixnum_Fits(Result)) return Make_Non_Pointer(TC_FIXNUM, Result);
+ else return NIL;
+}
+\f
+ /****************************/
+ /* BINARY FIXNUM PREDICATES */
+ /****************************/
+
+/* Binary fixnum predicates return NIL if their argument is not a
+ fixnum, 1 if the predicate is true, or 0 if the predicate is false.
+*/
+
+#define Binary_Predicate_Fixnum(Op) \
+ fast long A, B; \
+ Primitive_2_Args(); \
+ Arg_1_Type(TC_FIXNUM); \
+ Arg_2_Type(TC_FIXNUM); \
+ Sign_Extend(Arg1, A); Sign_Extend(Arg2, B); \
+ return FIXNUM_0+ ((A Op B) ? 1 : 0);
+
+Built_In_Primitive(Prim_Equal_Fixnum, 2, "EQUAL-FIXNUM?")
+{ Binary_Predicate_Fixnum(==);
+}
+
+Built_In_Primitive(Prim_Greater_Fixnum, 2, "LESS-FIXNUM?")
+{ Binary_Predicate_Fixnum(>);
+}
+
+Built_In_Primitive(Prim_Less_Fixnum, 2, "GREATER-FIXNUM?")
+{ Binary_Predicate_Fixnum(<);
+}
+\f
+ /****************************/
+ /* BINARY FIXNUM OPERATIONS */
+ /****************************/
+
+/* All binary fixnum operations take two arguments and return NIL if
+ either is not a fixnum. If both arguments are fixnums and the
+ result fits as a fixnum, then the result is returned. If the
+ result will not fit as a fixnum, NIL is returned.
+*/
+
+#define Binary_Fixnum(Op) \
+ fast long A, B, Result; \
+ Primitive_2_Args(); \
+ Arg_1_Type(TC_FIXNUM); \
+ Arg_2_Type(TC_FIXNUM); \
+ Sign_Extend(Arg1, A); Sign_Extend(Arg2, B); \
+ Result = A Op B; \
+ if (Fixnum_Fits(Result)) \
+ return Make_Non_Pointer(TC_FIXNUM, Result); \
+ else return NIL; \
+
+Built_In_Primitive(Prim_Minus_Fixnum, 2, "MINUS-FIXNUM")
+{ Binary_Fixnum(-);
+}
+
+Built_In_Primitive(Prim_Plus_Fixnum, 2, "PLUS-FIXNUM")
+{ Binary_Fixnum(+);
+}
+
+Built_In_Primitive(Prim_Multiply_Fixnum, 2, "MULTIPLY-FIXNUM")
+{ /* Mul, which does the multiplication with overflow handling is
+ machine dependent. Therefore, it is in OS.C
+ */
+ Primitive_2_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Arg_2_Type(TC_FIXNUM);
+ return Mul(Arg1, Arg2);
+}
+\f
+Built_In_Primitive(Prim_Divide_Fixnum, 2, "DIVIDE-FIXNUM")
+{ fast long A, B, Quotient, Remainder;
+ /* Returns the CONS of quotient and remainder */
+ Primitive_2_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Arg_2_Type(TC_FIXNUM);
+ Sign_Extend(Arg1, A); Sign_Extend(Arg2, B);
+ if (B==0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Primitive_GC_If_Needed(2);
+ Quotient = A/B;
+ Remainder = A%B;
+ if (Fixnum_Fits(Quotient))
+ { Free[CONS_CAR] = Make_Non_Pointer(TC_FIXNUM, Quotient);
+ Free[CONS_CDR] = Make_Non_Pointer(TC_FIXNUM, Remainder);
+ Free += 2;
+ return Make_Pointer(TC_LIST, Free-2);
+ }
+ return NIL;
+}
+
+Built_In_Primitive(Prim_Gcd_Fixnum, 2, "GCD-FIXNUM")
+{ fast long A, B, C;
+ /* Returns the Greatest Common Divisor */
+ Primitive_2_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Arg_2_Type(TC_FIXNUM);
+ Sign_Extend(Arg1, A); Sign_Extend(Arg2, B);
+ while (B != 0)
+ { C = A;
+ A = B;
+ B = C % B;
+ }
+ return Make_Non_Pointer(TC_FIXNUM, A);
+}
+\f
+/* (NEGATIVE_FIXNUM NUMBER)
+ [Primitive number 0x7F]
+ Returns NIL if NUMBER isn't a fixnum. Returns 0 if NUMBER < 0, 1
+ if NUMBER >= 0.
+*/
+Built_In_Primitive(Prim_Negative_Fixnum, 1, "NEGATIVE-FIXNUM?")
+{ long Value;
+ Primitive_1_Arg();
+ Arg_1_Type(TC_FIXNUM);
+ Sign_Extend(Arg1, Value);
+ return FIXNUM_0 + ((Value < 0) ? 1 : 0);
+}
+
+/* (POSITIVE_FIXNUM NUMBER)
+ [Primitive number 0x41]
+ Returns 1 if NUMBER is a positive fixnum, 0 for other fixnums,
+ or NIL.
+*/
+Built_In_Primitive(Prim_Positive_Fixnum, 1, "POSITIVE-FIXNUM?")
+{ long Value;
+ Primitive_1_Arg();
+ Arg_1_Type(TC_FIXNUM);
+ Sign_Extend(Arg1, Value);
+ return FIXNUM_0 + ((Value > 0) ? 1 : 0);
+}
+
+/* (ZERO_FIXNUM NUMBER)
+ [Primitive number 0x46]
+ Returns NIL if NUMBER isn't a fixnum. Otherwise, returns 0 if
+ NUMBER is 0 or 1 if it is.
+*/
+Built_In_Primitive(Prim_Zero_Fixnum, 1, "ZERO-FIXNUM?")
+{ Primitive_1_Arg();
+ Arg_1_Type(TC_FIXNUM);
+ return FIXNUM_0+((Get_Integer(Arg1) == 0) ? 1 : 0);
+}
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: FIXOBJ.H
+ *
+ * Declarations of user offsets into the Fixed Objects Vector.
+ * This should correspond to the file UTABMD.SCM
+ */
+\f
+#define Non_Object 0x00 /* Value for UNBOUND variables */
+#define System_Interrupt_Vector 0x01 /* Handlers for interrups */
+#define System_Error_Vector 0x02 /* Handlers for errors */
+#define OBArray 0x03 /* Array for interning symbols */
+#define Types_Vector 0x04 /* Type number -> Name map */
+#define Returns_Vector 0x05 /* Return code -> Name map */
+#define Primitives_Vector 0x06 /* Primitive code -> Name map */
+#define Errors_Vector 0x07 /* Error code -> Name map */
+#define Hash_Number 0x08 /* Next number for hashing */
+#define Hash_Table 0x09 /* Table for hashing objects */
+#define Unhash_Table 0x0A /* Inverse hash table */
+#define GC_Daemon 0x0B /* Procedure to run after GC */
+#define Trap_Handler 0x0C /* Continue after disaster */
+#define Open_Files 0x0D /* List of open files */
+#define Stepper_State 0x0E /* NOT IMPLEMENTED YET */
+#define Fixed_Objects_Slots 0x0F /* Names of these slots */
+#define External_Primitives 0x10 /* Names of external prims */
+#define State_Space_Tag 0x11 /* Tag for state spaces */
+#define State_Point_Tag 0x12 /* Tag for state points */
+#define Dummy_History 0x13 /* Empty history structure */
+#define Bignum_One 0x14 /* Cache for bignum one */
+#define System_Scheduler 0x15 /* Scheduler for touched futures */
+#define Termination_Vector 0x16 /* Names for terminations */
+#define Termination_Proc_Vector 0x17 /* Handlers for terminations */
+#define Me_Myself 0x18 /* The actual shared vector */
+/* The next slot is used only in multiprocessor mode */
+#define The_Work_Queue 0x19 /* Where work is stored */
+/* These two slots are only used if logging futures */
+#define Future_Logger 0x1A /* Routine to log touched futures */
+#define Touched_Futures 0x1B /* Vector of touched futures */
+#define Precious_Objects 0x1C /* Objects that should not be lost! */
+#define Error_Procedure 0x1D /* User invoked error handler */
+#define Unsnapped_Link 0x1E /* Handler for call to compiled code */
+#define Utilities_Vector 0x1F /* ??? */
+#define Compiler_Err_Procedure 0x20 /* ??? */
+#define Lost_Objects_Base 0x21 /* Free at the end of the "real" gc. */
+#define State_Space_Root 0x22 /* Root of state space */
+
+#define NFixed_Objects 0x23
+
--- /dev/null
+/* 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: FLONUM.C
+ *
+ * This file contains support for floating point arithmetic. Most
+ * of these primitives have been superceded by generic arithmetic.
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+#include "flonum.h"
+#include "zones.h"
+
+ /************************************/
+ /* BINARY FLOATING POINT OPERATIONS */
+ /************************************/
+
+/* See flohead.c for floating point macros. */
+
+/* The binary floating point operations return NIL if either argument
+ is not a floating point number. Otherwise they return the
+ appropriate result.
+*/
+
+Built_In_Primitive(Prim_Divide_Flonum, 2, "DIVIDE-FLONUM")
+{ Primitive_2_Args();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Arg_2_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ if (Get_Float(Arg2) == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Flonum_Result(Get_Float(Arg1) / Get_Float(Arg2));
+}
+\f
+Built_In_Primitive(Prim_Minus_Flonum, 2, "MINUS-FLONUM")
+{ Primitive_2_Args();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Arg_2_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ Flonum_Result(Get_Float(Arg1) - Get_Float(Arg2));
+}
+
+Built_In_Primitive(Prim_Multiply_Flonum, 2, "MULTIPLY-FLONUM")
+{ Primitive_2_Args();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Arg_2_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ Flonum_Result(Get_Float(Arg1) * Get_Float(Arg2));
+}
+
+Built_In_Primitive(Prim_Plus_Flonum, 2, "PLUS-FLONUM")
+{ Primitive_2_Args();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Arg_2_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ Flonum_Result(Get_Float(Arg1) + Get_Float(Arg2));
+}
+\f
+ /************************************/
+ /* BINARY FLOATING POINT PREDICATES */
+ /************************************/
+
+/* The binary flonum predicates return NIL if either of the arguments
+ is not a flonum. Otherwise, return a fixnum 1 if the predicate is
+ true, or a fixnum 0 if it is false.
+*/
+
+Built_In_Primitive(Prim_Equal_Flonum, 2, "EQUAL-FLONUM?")
+{ Primitive_2_Args();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Arg_2_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ return FIXNUM_0+
+ (((Get_Float(Arg1)) == (Get_Float(Arg2))) ? 1 : 0);
+}
+
+Built_In_Primitive(Prim_Greater_Flonum, 2, "GREATER-FLONUM?")
+{ Primitive_2_Args();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Arg_2_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ return FIXNUM_0+
+ (((Get_Float(Arg1)) > (Get_Float(Arg2))) ? 1 : 0);
+}
+
+Built_In_Primitive(Prim_Less_Flonum, 2, "LESS-FLONUM?")
+{ Primitive_2_Args();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Arg_2_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ return FIXNUM_0+(((Get_Float(Arg1)) < (Get_Float(Arg2))) ? 1 : 0);
+}
+\f
+ /***********************************/
+ /* UNARY FLOATING POINT OPERATIONS */
+ /***********************************/
+
+/* The unary flonum operations return NIL if their argument is
+ not a flonum. Otherwise, they return the appropriate result.
+*/
+
+Built_In_Primitive(Prim_Arctan_Flonum, 1, "ARCTAN-FLONUM")
+{ double atan();
+ Primitive_1_Arg();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ Flonum_Result(atan(Get_Float(Arg1)));
+}
+
+Built_In_Primitive(Prim_Cosine_Flonum, 1, "COSINE-FLONUM")
+{ double cos();
+ Primitive_1_Arg();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ Flonum_Result(cos(Get_Float(Arg1)));
+}
+
+Built_In_Primitive(Prim_Exp_Flonum, 1, "EXP-FLONUM")
+{ double exp();
+ Primitive_1_Arg();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ Flonum_Result(exp(Get_Float(Arg1)));
+}
+\f
+Built_In_Primitive(Prim_Ln_Flonum, 1, "LN-FLONUM")
+{ double log();
+ Primitive_1_Arg();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ if (Arg1 <= 0.0)
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ Flonum_Result(log(Get_Float(Arg1)));
+}
+
+Built_In_Primitive(Prim_Sine_Flonum, 1, "SINE-FLONUM")
+{ double sin();
+ Primitive_1_Arg();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ Flonum_Result(sin(Get_Float(Arg1)));
+}
+\f
+Built_In_Primitive(Prim_Sqrt_Flonum, 1, "SQRT-FLONUM")
+{ double sqrt(), Arg;
+ Primitive_1_Arg();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ Arg = Get_Float(Arg1);
+ if (Arg < 0) return NIL;
+ Flonum_Result(sqrt(Arg));
+}
+
+Built_In_Primitive(Prim_Negative_Flonum, 1, "NEGATIVE-FLONUM?")
+{ Primitive_1_Arg();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ return FIXNUM_0+ ((Get_Float(Arg1) < 0.0) ? 1 : 0);
+}
+
+Built_In_Primitive(Prim_Positive_Flonum, 1, "POSITIVE-FLONUM?")
+{ Primitive_1_Arg();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ return FIXNUM_0+ ((Get_Float(Arg1) > 0.0) ? 1 : 0);
+}
+
+Built_In_Primitive(Prim_Zero_Flonum, 1, "ZERO-FLONUM?")
+{ Primitive_1_Arg();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ return FIXNUM_0+ ((Get_Float(Arg1) == 0.0) ? 1 : 0);
+}
+\f
+/* (INT_TO_FLOAT FIXNUM-OR-BIGNUM)
+ [Primitive number 0x72]
+ Returns the floating point number (flonum) corresponding to
+ either a bignum or a fixnum. If the bignum is too large or small
+ to be converted to floating point, or if the argument isn't of
+ the correct type, FIXNUM-OR-BIGNUM is returned unchanged.
+*/
+Built_In_Primitive(Prim_Int_To_Float, 1, "INT->FLOAT")
+{ Primitive_1_Arg();
+ Set_Time_Zone(Zone_Math);
+ if (Type_Code(Arg1)==TC_FIXNUM)
+ { long Int;
+ Sign_Extend(Arg1, Int);
+ return Allocate_Float((double) Int);
+ }
+ if (Type_Code(Arg1)==TC_BIG_FIXNUM) return Big_To_Float(Arg1);
+ return Arg1;
+}
+\f
+/* (ROUND_FLONUM FLONUM)
+ [Primitive number 0x71]
+ Returns the integer found by rounding off FLONUM (upward), if
+ FLONUM is a floating point number. Otherwise returns FLONUM.
+*/
+Built_In_Primitive(Prim_Round_Flonum, 1, "ROUND-FLONUM")
+{ fast double A;
+ long Answer; /* Faulty VAX/UNIX C optimizer */
+ Primitive_1_Arg();
+ Set_Time_Zone(Zone_Math);
+ if (Type_Code(Arg1) != TC_BIG_FLONUM) return Arg1;
+ A = Get_Float(Arg1);
+ if (A >= 0) A += 0.5; else A -= 0.5;
+ if (flonum_exceeds_fixnum(A)) return Float_To_Big(A);
+ Answer = (long) A;
+ return Make_Non_Pointer(TC_FIXNUM, Answer);
+}
+\f
+/* (TRUNCATE_FLONUM FLONUM)
+ [Primitive number 0x70]
+ Returns the integer corresponding to FLONUM when truncated.
+ Returns NIL if FLONUM isn't a floating point number
+*/
+Built_In_Primitive(Prim_Truncate_Flonum, 1, "TRUNCATE-FLONUM")
+{ fast double A;
+ long Answer; /* Faulty VAX/UNIX C optimizer */
+ Primitive_1_Arg();
+ Arg_1_Type(TC_BIG_FLONUM);
+ Set_Time_Zone(Zone_Math);
+ A = Get_Float(Arg1);
+ if (flonum_exceeds_fixnum(A)) return Float_To_Big(A);
+ Answer = (long) A;
+ return Make_Non_Pointer(TC_FIXNUM, Answer);
+}
--- /dev/null
+/* 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. *
+* *
+****************************************************************/
+
+/* File: FUTURE.C
+ Support code for futures
+*/
+
+#include "scheme.h"
+#include "primitive.h"
+#include "locks.h"
+\f
+#ifndef COMPILE_FUTURES
+#include "Error: future.c is useless without COMPILE_FUTURES"
+#endif
+
+/*
+
+A future is a VECTOR starting with <determined?>, <locked?> and
+<waiting queue / value>,
+
+where <determined?> is #!false if no value is known yet,
+ #!true if value is known and future can vanish at GC,
+ otherwise value is known, but keep the slot
+
+and where <locked> is #!true if someone wants slot kept for a time.
+
+*/
+\f
+Define_Primitive(Prim_Touch, 1, "TOUCH")
+{ Pointer Result;
+ Primitive_1_Arg();
+ Touch_In_Primitive(Arg1, Result);
+ return Result;
+}
+
+Define_Primitive(Prim_Future_P, 1, "FUTURE?")
+{ Primitive_1_Arg();
+ return (Type_Code(Arg1) == TC_FUTURE) ? TRUTH : NIL;
+}
+\f
+/* Utility setting routine for use by the various test and set if
+ equal operators.
+*/
+
+long Set_If_Equal(Base, Offset, New, Wanted)
+Pointer Base, Wanted, New;
+long Offset;
+{ Lock_Handle lock;
+ Pointer Old_Value, Desired, Remember_Value;
+ long success;
+
+ Touch_In_Primitive(Wanted, Desired);
+Try_Again:
+ Remember_Value = Vector_Ref(Base, Offset);
+ Touch_In_Primitive(Remember_Value, Old_Value);
+ lock = Lock_Cell(Nth_Vector_Loc(Base, Offset));
+ if (Remember_Value != Fast_Vector_Ref(Base, Offset))
+ { Unlock_Cell(lock);
+ goto Try_Again;
+ }
+ if (Old_Value == Desired)
+ { Do_Store_No_Lock(Nth_Vector_Loc(Base, Offset), New);
+ success = true;
+ }
+ else success = false;
+ Unlock_Cell(lock);
+ return success;
+}
+
+Define_Primitive(Prim_Set_Car_If_Eq, 3, "SET-CAR-IF-EQ?!")
+/* (SET-CAR-IF-EQ?! <CONS Cell> <New Value> <Old Value>)
+ Replaces the CAR of <CONS Cell> with <New Value> if it used to contain
+ <Old Value>. The value returned is either <CONS Cell> (if the modification
+ takes place) or '() if it does not.
+*/
+{ Primitive_3_Args();
+ Arg_1_Type(TC_LIST);
+ if (Set_If_Equal(Arg1, CONS_CAR, Arg2, Arg3)) return Arg1;
+ else return NIL;
+}
+\f
+Define_Primitive(Prim_Set_Cdr_If_Eq, 3, "SET-CDR-IF-EQ?!")
+/* (SET-CDR-IF-EQ?! <CONS Cell> <New Value> <Old Value>)
+ Replaces the CDR of <CONS Cell> with <New Value> if it used to contain
+ <Old Value>. The value returned is either <CONS Cell> (if the modification
+ takes place) or '() if it does not.
+*/
+{ Primitive_3_Args();
+ Arg_1_Type(TC_LIST);
+ if (Set_If_Equal(Arg1, CONS_CDR, Arg2, Arg3)) return Arg1;
+ else return NIL;
+}
+
+Define_Primitive(Prim_Vector_Set_If_Eq, 4, "VECTOR-SET-IF-EQ?!")
+/* (VECTOR-SET-IF-EQ?! <Vector> <Offset> <New Value> <Old Value>)
+ Replaces the <Offset>th element of <Vector> with <New Value> if it used
+ to contain <Old Value>. The value returned is either <Vector> (if
+ the modification takes place) or '() if it does not.
+*/
+{ long Offset;
+ Primitive_4_Args();
+ Arg_1_Type(TC_VECTOR);
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(Offset, Arg2,
+ 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ if (Set_If_Equal(Arg1, Offset, Arg3, Arg4)) return Arg1;
+ else return NIL;
+}
+
+Define_Primitive(Prim_Set_Cxr_If_Eq, 4, "SET-CXR-IF-EQ?!")
+/* (SET-CXR-IF-EQ?! <Triple> <Offset> <New Value> <Old Value>)
+ Replaces the <Offset>th CXR of <Triple> with <New Value> if it used to
+ contain <Old Value>. The value returned is either <Triple> (if
+ the modification takes place) or '() if it does not.
+*/
+{ Pointer Arg4;
+ long Offset;
+ Primitive_3_Args();
+ Arg4 = Stack_Ref(3);
+ Arg_1_Type(TC_HUNK3);
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE);
+ if (Set_If_Equal(Arg1, Offset, Arg3, Arg4)) return Arg1;
+ else return NIL;
+}
+\f
+Define_Primitive(Prim_Future_Ref, 2, "FUTURE-REF")
+/* (FUTURE-REF <Future> <Offset>)
+ Returns the <Offset>th slot from the future object. This is
+ the equivalent of SYSTEM-VECTOR-REF but works only on future
+ objects and doesn't touch.
+*/
+{ long Offset;
+ Primitive_2_Args();
+ Arg_1_Type(TC_FUTURE);
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(Offset, Arg2,
+ 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ return User_Vector_Ref(Arg1, Offset);
+}
+
+Define_Primitive(Prim_Future_Set, 3, "FUTURE-SET!")
+/* (FUTURE-SET! <Future> <Offset> <New Value>)
+ Modifies the <Offset>th slot from the future object. This is
+ the equivalent of SYSTEM-VECTOR-SET! but works only on future
+ objects and doesn't touch.
+*/
+{ long Offset;
+ Pointer Result;
+ Primitive_3_Args();
+ Arg_1_Type(TC_FUTURE);
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(Offset, Arg2,
+ 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ Result = User_Vector_Ref(Arg1, Offset);
+ User_Vector_Set(Arg1, Offset,Arg3);
+ return Result;
+}
+\f
+Define_Primitive(Prim_Future_Size, 1, "FUTURE-SIZE")
+/* (FUTURE-SIZE <Future>)
+ Returns the number of slots in the future object. This is
+ the equivalent of SYSTEM-VECTOR-SIZE but works only on future
+ objects and doesn't touch.
+*/
+{ Primitive_1_Arg();
+ Arg_1_Type(TC_FUTURE);
+ return FIXNUM_0+Vector_Length(Arg1);
+}
+
+Define_Primitive(Prim_Lock_Future, 1, "LOCK-FUTURE!")
+/* (LOCK-FUTURE! <Future>)
+ Sets the lock flag on the future object, so that it won't be
+ spliced-out by the garbage collector. Returns #!false if the
+ argument isn't a future (might have been determined in the
+ interim), #!TRUE if it is a future. Hangs as long as necessary
+ for the lock to take, since Scheme code operates while locked.
+ Opposite of UNLOCK-FUTURE!.
+*/
+{ Primitive_1_Arg();
+ if (Type_Code(Arg1) != TC_FUTURE) return NIL;
+ while ((IntEnb & IntCode) == 0)
+ if (Swap_Pointers(Nth_Vector_Loc(Arg1, FUTURE_LOCK),
+ TRUTH) == NIL)
+ return TRUTH;
+ else Sleep(CONTENTION_DELAY);
+ Primitive_Interrupt();
+}
+
+Define_Primitive(Prim_Unlock_Future, 1, "UNLOCK-FUTURE!")
+/* (UNLOCK-FUTURE! <Future>)
+ Clears the lock flag on a locked future object, otherwise nothing.
+*/
+{ Primitive_1_Arg();
+ if (Type_Code(Arg1) != TC_FUTURE) return NIL;
+ if (!Future_Is_Locked(Arg1))
+ Primitive_Error(ERR_ARG_1_WRONG_TYPE)
+ else
+ { Vector_Set(Arg1, FUTURE_LOCK, NIL);
+ return TRUTH;
+ };
+}
+\f
+Define_Primitive(Prim_Future_To_Vector, 1, "FUTURE->VECTOR")
+/* (FUTURE->VECTOR <Future>)
+ Create a COPY of <future> but with type code vector.
+*/
+{ Pointer Result = Make_Pointer(TC_VECTOR, Free);
+ long Size, i;
+ Primitive_1_Arg();
+ if (Type_Code(Arg1) != TC_FUTURE) return NIL;
+ Size = Vector_Length(Arg1);
+ Primitive_GC_If_Needed(Size + 1);
+ for (i=0; i <= Size; i++) *Free++ = Vector_Ref(Arg1, i);
+ return Result;
+}
+
+Define_Primitive(Prim_Future_Eq, 2, "NON-TOUCHING-EQ?")
+{ Primitive_2_Args();
+ return ((Arg1==Arg2) ? TRUTH : NIL);
+}
+
+/* MAKE-INITIAL-PROCESS is called to create a small stacklet which
+ * will just call the specified thunk and then end the computation
+ */
+
+Define_Primitive(Prim_Make_Initial_Process, 1, "MAKE-INITIAL-PROCESS")
+{ Pointer Result;
+ long Useful_Length, Allocated_Length, Waste_Length;
+ Primitive_1_Arg();
+
+ Result = Make_Pointer(TC_CONTROL_POINT, Free);
+ Useful_Length = 3*CONTINUATION_SIZE+STACK_ENV_EXTRA_SLOTS+1;
+#ifdef USE_STACKLETS
+ if ((Useful_Length+STACKLET_SLACK+STACKLET_HEADER_SIZE) <
+ Default_Stacklet_Size)
+ Allocated_Length = Default_Stacklet_Size;
+ else Allocated_Length =
+ Useful_Length+STACKLET_SLACK+STACKLET_HEADER_SIZE;
+ Primitive_GC_If_Needed(Allocated_Length+1);
+ Waste_Length = (Allocated_Length-Useful_Length-STACKLET_HEADER_SIZE)+1;
+ Free[STACKLET_LENGTH] =
+ Make_Pointer(TC_MANIFEST_VECTOR, Allocated_Length);
+ Free[STACKLET_UNUSED_LENGTH] =
+ DANGER_BIT | (Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,
+ Waste_Length));
+ Free += Allocated_Length-Useful_Length+1;
+#else
+ Free[STACKLET_LENGTH] =
+ Make_Non_Pointer(TC_MANIFEST_VECTOR,
+ Useful_Length + STACKLET_HEADER_SIZE - 1);
+ Free[STACKLET_UNUSED_LENGTH] =
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
+ Free += STACKLET_HEADER_SIZE;
+#endif
+/* Make_Initial_Process continues on the next page */
+\f
+/* Make_Initial_Process continued */
+
+ Free[CONTINUATION_EXPRESSION] = Make_Non_Pointer(TC_FIXNUM, IntEnb);
+ Free[CONTINUATION_RETURN_CODE] =
+ Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_INT_MASK);
+ Free += CONTINUATION_SIZE;
+ Free[CONTINUATION_EXPRESSION] = NIL;
+ Free[CONTINUATION_RETURN_CODE] =
+ Make_Non_Pointer(TC_RETURN_CODE, RC_INTERNAL_APPLY);
+ Free += CONTINUATION_SIZE;
+ *Free++ = STACK_FRAME_HEADER;
+ *Free++ = Arg1;
+ Free[CONTINUATION_EXPRESSION] = Arg1; /* For testing & debugging */
+ Free[CONTINUATION_RETURN_CODE] =
+ Make_Non_Pointer(TC_RETURN_CODE, RC_END_OF_COMPUTATION);
+ Free += CONTINUATION_SIZE;
+ return Result;
+}
+\f
+/*
+ Absolutely the cheapest future we can make. This includes
+ the I/O stuff and whatnot. Notice that the name is required.
+
+ (make-cheap-future orig-code user-proc name)
+
+*/
+
+Define_Primitive(Prim_Make_Cheap_Future, 3, "MAKE-CHEAP-FUTURE")
+{ Pointer The_Future;
+ Pointer IO_Vector, IO_Cons, IO_Hunk3, Empty_Queue, IO_String;
+ Primitive_3_Args();
+
+ Primitive_GC_If_Needed(20);
+
+ Empty_Queue=Make_Pointer(TC_LIST,Free);
+ *Free++=NIL;
+ *Free++=NIL;
+
+ IO_String=Make_Pointer(TC_CHARACTER_STRING,Free);
+ *Free++=Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,1);
+ *Free++=FIXNUM_0;
+
+ IO_Cons=Make_Pointer(TC_LIST,Free);
+ *Free++=FIXNUM_0;
+ *Free++=IO_String;
+
+ IO_Hunk3=Make_Pointer(TC_HUNK3,Free);
+ *Free++=NIL;
+ *Free++=Arg3;
+ *Free++=IO_Cons;
+
+ IO_Vector=Make_Pointer(TC_VECTOR,Free);
+ *Free++=Make_Non_Pointer(TC_MANIFEST_VECTOR,1);
+ *Free++=IO_Hunk3;
+
+ The_Future=Make_Pointer(TC_FUTURE,Free);
+ *Free++=Make_Non_Pointer(TC_MANIFEST_VECTOR,9);
+ *Free++=NIL; /* No value yet. */
+ *Free++=NIL; /* Not locked. */
+ *Free++=Empty_Queue; /* Put the empty queue here. */
+ *Free++=Arg1; /* The process slot. */
+ *Free++=TRUTH; /* Status slot - not used? */
+ *Free++=Arg2; /* For debugging. */
+ *Free++=IO_Vector; /* Put the I/O system stuff here. */
+ *Free++=NIL; /* Waiting on list. */
+ *Free++=NIL; /* User slot? */
+
+ return The_Future; }
+
--- /dev/null
+/* 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. *
+* *
+****************************************************************/
+
+/* File: FUTURES.H
+ *
+ * This file contains macros useful for dealing with futures
+ */
+\f
+/* Data structure definition */
+
+/* The IS_DETERMINED slot has one of the following type of values:
+ * #!FALSE if the value is not yet known
+ * #!TRUE if the value is known and the garbage collector is free
+ * to remove the future object in favor of its value everywhere
+ * else the value is known, but the GC must leave the future object
+*/
+
+#define FUTURE_VECTOR_HEADER 0
+#define FUTURE_IS_DETERMINED 1
+#define FUTURE_LOCK 2
+#define FUTURE_VALUE 3 /* if known, else */
+#define FUTURE_QUEUE 3 /* tasks waiting for value */
+#define FUTURE_EXTRA_STUFF 4 /* rest for extensibility */
+\f
+#define Future_Is_Locked(P) \
+ (Vector_Ref((P), FUTURE_LOCK) != NIL)
+
+#define Future_Has_Value(P) \
+ (Vector_Ref((P), FUTURE_IS_DETERMINED) != NIL)
+
+#define Future_Value(P) \
+ Vector_Ref((P), FUTURE_VALUE)
+
+#define Future_Spliceable(P) \
+ ((Vector_Ref((P), FUTURE_IS_DETERMINED) == TRUTH) && \
+ (Vector_Ref((P), FUTURE_LOCK) == NIL))
+
+#define Future_Is_Keep_Slot(P) \
+((Vector_Ref((P), FUTURE_IS_DETERMINED) != NIL) && \
+ (Vector_Ref((P), FUTURE_IS_DETERMINED) != TRUTH))
+
+#ifdef COMPILE_FUTURES
+/* Touch_In_Primitive is used by primitives which are not
+ * strict in an argument but which touch it none the less.
+ */
+
+#define Touch_In_Primitive(P, To_Where) \
+{ Pointer Value = (P); \
+ while (Type_Code(Value) == TC_FUTURE) \
+ { if (Future_Has_Value(Value)) \
+ { if (Future_Is_Keep_Slot(Value)) Log_Touch_Of_Future(Value);\
+ Value = Future_Value(Value); \
+ } \
+ else \
+ { Back_Out_Of_Primitive(); \
+ Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
+ Save_Cont(); \
+ Push(Value); \
+ Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
+ Push(STACK_FRAME_HEADER+1); \
+ Pushed(); \
+ longjmp(*Back_To_Eval, PRIM_APPLY); \
+ } \
+ } \
+ To_Where = Value; \
+}
+\f
+/* NOTES ON FUTURES, derived from the rest of the interpreter code */
+
+/* ASSUMPTION: The syntaxer is hereby assumed NEVER to generate primitive
+ combinations unless the primitive itself is output in the code stream.
+ Therefore, we don't have to explicitly check here that the expression
+ register has a primitive in it.
+
+ ASSUMPTION: The SYMBOL slot of a VARIABLE does NOT contain a future, nor
+ do the cached lexical address slots.
+
+ ASSUMPTION: Compiled code calls to the interpreter require the results
+ be touched before returning to the compiled code. This may be very wrong.
+
+ ASSUMPTION: History objects are never created using futures.
+
+ ASSUMPTION: State points, which are created only by the interpreter,
+ never contain FUTUREs except possibly as the thunks (which are handled
+ by the apply code).
+
+*/
+
+/* OPTIMIZATIONS (?):
+ After a lot of discussion, we decided that variable reference will check
+ whether a value stored in the environment is a determined future which
+ is marked spliceable. If so, it will splice out the future from the
+ environment slot to speed up subsequent references.
+
+ EQ? does a normal identity check and only if this fails does it touch the
+ arguments. The same thing does not speed up MEMQ or ASSQ in the normal
+ case, so it is omitted there.
+
+ The following are NOT done, but might be useful later
+ (1) Splicing on SET! operations
+ (2) Splicing at apply and/or primitive apply
+ (3) Splicing all arguments when a primitive errors on any of them
+ (4) Splicing within the Arg_n_Type macro rather than after longjmping
+ to the error handler.
+*/
+
+/* KNOWN PROBLEMS:
+ (1) Garbage collector should be modified to splice out futures.
+
+ (2) Purify should be looked at and we should decide what to do about
+ purifying an object with a reference to a future (it should probably
+ become constant but not pure).
+
+ (3) Look at Impurify and Side-Effect-Impurify to see if futures
+ affect them in any way.
+*/
+\f
+#ifdef FUTURE_LOGGING
+#define Touched_Futures_Vector() Get_Fixed_Obj_Slot(Touched_Futures)
+
+#define Logging_On() \
+(Valid_Fixed_Obj_Vector() && Touched_Futures_Vector())
+
+/* Log_Touch_Of_Future adds the future which was touched to the vector
+ of touched futures about which the scheme portion of the system has
+ not yet been informed
+*/
+#define Log_Touch_Of_Future(F) \
+if (Logging_On()) \
+{ Pointer TFV = Touched_Futures_Vector(); \
+ long Count = Get_Integer(User_Vector_Ref(TFV, 0))+1; \
+ User_Vector_Ref(TFV, 0) = FIXNUM_0 + Count; \
+ if (Count < Vector_Length(TFV)) \
+ User_Vector_Ref(TFV, Count) = Make_New_Pointer(TC_VECTOR, F); \
+}
+
+/* Call_Future_Logging calls a user defined scheme routine if the vector
+ of touched futures has a nonzero length.
+*/
+#define Must_Report_References() \
+( Logging_On() && \
+ (Get_Integer(User_Vector_Ref(Touched_Futures_Vector(), 0)) > 0))
+
+#define Call_Future_Logging() \
+{ \
+ Will_Push(STACK_ENV_EXTRA_SLOTS+2); \
+ Push(Touched_Futures_Vector()); \
+ Push(Get_Fixed_Obj_Slot(Future_Logger)); \
+ Push(STACK_FRAME_HEADER+1); \
+ Pushed(); \
+ Touched_Futures_Vector() = NIL; \
+ goto Apply_Non_Trapping; \
+}
+#else
+#define Log_Touch_Of_Future(F) { }
+#define Call_Future_Logging()
+#define Must_Report_References() (false)
+#endif /* Logging */
+
+#else /* Futures not compiled */
+#define Touch_In_Primitive(P, To_Where) To_Where = (P)
+#define Log_Touch_Of_Future(F) { }
+#define Call_Future_Logging()
+#define Must_Report_References() (false)
+#endif
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: GC.H
+ *
+ * Garbage collection related macros of sufficient utility to be
+ * included in all compilations.
+ */
+\f
+/* GC Types. */
+
+#define GC_Non_Pointer 0
+#define GC_Cell 1
+#define GC_Pair 2
+#define GC_Triple 3
+#define GC_Hunk3 3
+#define GC_Quadruple 4
+#define GC_Hunk4 4
+#define GC_Undefined -1 /* Undefined types */
+#define GC_Special -2 /* Internal GC types */
+#define GC_Vector -3
+#define GC_Compiled -4
+
+#define GC_Type_Code(TC) \
+ ((GC_Type_Map[TC] != GC_Undefined) ? \
+ GC_Type_Map[TC] : \
+ (fprintf(stderr, "Bad Type code = 0x%02x\n", TC), \
+ Invalid_Type_Code(), GC_Undefined))
+
+#define GC_Type(Object) GC_Type_Code(Safe_Type_Code(Object))
+
+#define GC_Type_Non_Pointer(Object) (GC_Type(Object) == GC_Non_Pointer)
+#define GC_Type_Cell(Object) (GC_Type(Object) == GC_Cell)
+#define GC_Type_List(Object) (GC_Type(Object) == GC_Pair)
+#define GC_Type_Triple(Object) (GC_Type(Object) == GC_Triple)
+#define GC_Type_Quadruple(Object) (GC_Type(Object) == GC_Quadruple)
+#define GC_Type_Undefined(Object) (GC_Type(Object) == GC_Undefined)
+#define GC_Type_Special(Object) (GC_Type(Object) == GC_Special)
+#define GC_Type_Vector(Object) (GC_Type(Object) == GC_Vector)
+#define GC_Type_Compiled(Object) (GC_Type(Object) == GC_Compiled)
+
+#define Invalid_Type_Code() \
+ Microcode_Termination(TERM_INVALID_TYPE_CODE)
+\f
+/* Overflow detection, various cases */
+
+#define GC_Check(Amount) (((Amount+Free) >= MemTop) && \
+ ((IntEnb & INT_GC) != 0))
+
+#define Space_Before_GC() (((IntEnb & INT_GC) != 0) ? \
+ (MemTop - Free) : \
+ (Heap_Top - Free))
+
+#define Request_Interrupt(code) \
+{ \
+ IntCode |= (code); \
+ New_Compiler_MemTop(); \
+}
+
+#define Request_GC(Amount) \
+{ \
+ Request_Interrupt( INT_GC); \
+ GC_Space_Needed = Amount; \
+}
+
+#define Set_Mem_Top(Addr) \
+ MemTop = Addr; New_Compiler_MemTop()
+
+#define Set_Stack_Guard(Addr) Stack_Guard = Addr
+
+#define New_Compiler_MemTop() \
+ Registers[REGBLOCK_MEMTOP] = \
+ ((IntCode & IntEnb)==0) ? ((Pointer) MemTop) : ((Pointer) -1)
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: gccode.h
+ *
+ * This file contains the macros for use in code which does GC-like
+ * loops over memory. It is only included in a few files, unlike
+ * GC.H which contains general purpose macros and constants.
+ *
+ */
+\f
+static Pointer *Low_Watch = ((Pointer *) NULL);
+static Pointer *High_Watch = ((Pointer *) NULL);
+static Boolean In_Range = false;
+
+/* A SWITCH on GC types, duplicates information in GC_Type_Map[], but exists
+ for efficiency reasons. Macros must be used by convention: first
+ Switch_by_GC_Type, then each of the case_ macros (in any order). The
+ default: case MUST be included in the switch.
+*/
+
+#define Switch_by_GC_Type(P) \
+ switch (Safe_Type_Code(P))
+
+#define case_simple_Non_Pointer \
+ case_simple_Non_Pointer_poppers \
+ case TC_NULL: \
+ case TC_TRUE: \
+ case TC_UNASSIGNED: \
+ case TC_THE_ENVIRONMENT: \
+ case TC_EXTENDED_FIXNUM: \
+ case TC_RETURN_CODE: \
+ case TC_PRIMITIVE: \
+ case TC_PCOMB0: \
+ case TC_STACK_ENVIRONMENT
+
+#if defined(MC68020)
+
+#define case_simple_Non_Pointer_poppers \
+ case TC_PEA_INSTRUCTION: \
+ case TC_JMP_INSTRUCTION: \
+ case TC_DBF_INSTRUCTION:
+
+#else
+
+#define case_simple_Non_Pointer_poppers
+
+#endif
+
+#define case_Fasdump_Non_Pointer \
+ case TC_FIXNUM: \
+ case TC_CHARACTER: \
+ case_simple_Non_Pointer
+
+#define case_Non_Pointer \
+ case TC_PRIMITIVE_EXTERNAL: \
+ case_Fasdump_Non_Pointer
+
+/* Missing Non Pointer types (must always be treated specially):
+ TC_BROKEN_HEART
+ TC_MANIFEST_NM_VECTOR
+ TC_MANIFEST_SPECIAL_NM_VECTOR
+*/
+
+#define case_compiled_entry_point \
+ case TC_COMPILED_EXPRESSION: \
+ case TC_RETURN_ADDRESS \
+
+#define case_Cell \
+ case TC_CELL
+
+/* No missing Cell types */
+
+/* Switch_by_GC_Type cases continue on the next page */
+\f
+/* Switch_by_GC_Type cases continued */
+
+#define case_Fasdump_Pair \
+ case TC_LIST: \
+ case TC_SCODE_QUOTE: \
+ case TC_COMBINATION_1: \
+ case TC_EXTENDED_PROCEDURE: \
+ case TC_PROCEDURE: \
+ case TC_DELAY: \
+ case TC_DELAYED: \
+ case TC_COMMENT: \
+ case TC_LAMBDA: \
+ case TC_SEQUENCE_2: \
+ case TC_PCOMB1: \
+ case TC_ACCESS: \
+ case TC_DEFINITION: \
+ case TC_ASSIGNMENT: \
+ case TC_IN_PACKAGE: \
+ case TC_LEXPR: \
+ case TC_DISJUNCTION: \
+ case TC_COMPILED_PROCEDURE: \
+ case TC_COMPILER_LINK: \
+ case TC_COMPLEX
+
+#define case_Pair \
+ case TC_INTERNED_SYMBOL: \
+ case TC_UNINTERNED_SYMBOL: \
+ case_Fasdump_Pair
+
+/* Missing pair types (must be treated specially):
+ TC_WEAK_CONS
+*/
+
+#define case_Triple \
+ case TC_COMBINATION_2: \
+ case TC_EXTENDED_LAMBDA: \
+ case TC_HUNK3: \
+ case TC_CONDITIONAL: \
+ case TC_SEQUENCE_3: \
+ case TC_PCOMB2: \
+ case TC_TRAP
+
+/* Missing Triple types (must be treated specially):
+ TC_VARIABLE
+ */
+
+/* Switch_by_GC_Type cases continue on the next page */
+\f
+/* Switch_by_GC_Type cases continued */
+
+/* There are currently no Quad types.
+ Type Code -1 should be ok for now. -SMC */
+
+#define case_Quadruple \
+ case -1
+
+#define case_simple_Vector \
+ case TC_NON_MARKED_VECTOR: \
+ case TC_VECTOR: \
+ case TC_CONTROL_POINT: \
+ case TC_COMBINATION: \
+ case TC_PCOMB3: \
+ case TC_VECTOR_1B: \
+ case TC_VECTOR_16B
+
+#define case_Purify_Vector \
+ case TC_BIG_FIXNUM: \
+ case TC_CHARACTER_STRING: \
+ case_simple_Vector
+
+#define case_Vector \
+ case TC_ENVIRONMENT: \
+ case_Purify_Vector
+
+/* Missing vector types (must be treated specially):
+ TC_FUTURE
+ TC_BIG_FLONUM
+*/
+\f
+#define NORMAL_GC 0
+#define PURE_COPY 1
+#define CONSTANT_COPY 2
+
+/* Pointer setup for the GC Type handlers. */
+
+#define Normal_BH(In_GC, then_what) \
+/* Has it already been relocated? */ \
+if (Type_Code(*Old) == TC_BROKEN_HEART) \
+{ *Scan = Make_New_Pointer(Type_Code(Temp), *Old); \
+ if And2(In_GC, GC_Debug) \
+ { if ((Get_Pointer(*Old) >= Low_Watch) && \
+ (Get_Pointer(*Old) <= High_Watch)) \
+ { fprintf(stderr, "0x%x: %x|%x ... From 0x%x", \
+ Scan, Type_Code(Temp), Get_Integer(Temp), Old); \
+ fprintf(stderr, ", To (BH) 0x%x\n", Datum(*Old)); \
+ } \
+ else if And2(In_GC, In_Range) \
+ fprintf(stderr, ", To (BH) 0x%x", Datum(*Old)); \
+ } \
+ then_what; \
+}
+\f
+#define Setup_Internal(In_GC, Extra_Code, BH_Code) \
+if And2(In_GC, Consistency_Check) \
+ if ((Old >= Highest_Allocated_Address) || (Old < Heap)) \
+ { fprintf(stderr, "Out of range pointer: %x.\n", Temp); \
+ Microcode_Termination(TERM_EXIT); \
+ } \
+ \
+/* Does it need relocation? */ \
+ \
+if (Old >= Low_Constant) \
+{ if And3(In_GC, GC_Debug, In_Range) \
+ fprintf(stderr, " (constant)"); \
+ continue; \
+} \
+ \
+if And3(In_GC, GC_Debug, In_Range) \
+ fprintf(stderr, "From 0x%x", Old); \
+ \
+BH_Code; \
+/* It must be transported to New Space */ \
+if And3(In_GC, GC_Debug, In_Range) \
+ fprintf(stderr, ", To 0x%x", To); \
+New_Address = (BROKEN_HEART_0 + C_To_Scheme(To)); \
+Extra_Code; \
+continue
+
+#define Setup_Pointer(In_GC, Extra_Code) \
+Setup_Internal(In_GC, Extra_Code, Normal_BH(In_GC, continue))
+
+#define Pointer_End() \
+*Get_Pointer(Temp) = New_Address; \
+*Scan = Make_New_Pointer(Type_Code(Temp), New_Address)
+\f
+/* GC Type handlers. These do the actual work. */
+
+#define Transport_Cell() \
+*To++ = *Old; \
+Pointer_End()
+
+#define Transport_Pair() \
+*To++ = *Old++; \
+*To++ = *Old; \
+Pointer_End()
+
+#define Transport_Triple() \
+*To++ = *Old++; \
+*To++ = *Old++; \
+*To++ = *Old; \
+Pointer_End()
+
+#define Transport_Quadruple() \
+*To++ = *Old++; \
+*To++ = *Old++; \
+*To++ = *Old++; \
+*To++ = *Old; \
+Pointer_End()
+\f
+#ifndef In_Fasdump
+
+/* The Get_Integer below gets the length of the vector.
+ Vector_Length(Temp) cannot be used because Temp does
+ not necessarily point to the first word of the object.
+ Currently only compiled entry points point to the
+ "middle" of vectors.
+ */
+
+#define Real_Transport_Vector() \
+{ Pointer *Saved_Scan = Scan; \
+ Scan = To + 1 + Get_Integer(*Old); \
+ if ((Consistency_Check) && \
+ (Scan >= Low_Constant) && \
+ (To < Low_Constant)) \
+ { fprintf(stderr, "\nVector Length %d\n", \
+ Get_Integer(*Old)); \
+ Microcode_Termination(TERM_EXIT); \
+ } \
+ while (To != Scan) *To++ = *Old++; \
+ Scan = Saved_Scan; \
+}
+
+#else In_Fasdump
+
+#define Real_Transport_Vector() \
+{ Pointer *Saved_Scan = Scan; \
+ Scan = To + 1 + Get_Integer(*Old); \
+ if (Scan >= Fixes) \
+ { Scan = Saved_Scan; \
+ NewFree = To; \
+ Fixup = Fixes; \
+ return false; \
+ } \
+ while (To != Scan) *To++ = *Old++; \
+ Scan = Saved_Scan; \
+}
+
+#endif
+\f
+#ifdef FLOATING_ALIGNMENT
+#define Transport_Flonum() \
+ Align_Float(To); \
+ New_Address = (BROKEN_HEART_0 + C_To_Scheme(To)); \
+ Real_Transport_Vector(); \
+ Pointer_End()
+#endif
+
+#define Transport_Vector() \
+Move_Vector: \
+ Real_Transport_Vector(); \
+ Pointer_End()
+
+#define Transport_Future() \
+if (!(Future_Spliceable(Temp))) \
+ goto Move_Vector; \
+*Scan = Future_Value(Temp); \
+Scan -= 1
+\f
+/* This is handled specially so the aux variable compilation
+ mechanism will not hang onto "garbage" environments.
+ */
+
+#define Transport_Variable() \
+{ Pointer Compiled_Type = Old[VARIABLE_COMPILED_TYPE]; \
+ if ((Type_Code(Compiled_Type) == AUX_REF) && \
+ (!Is_Constant(Get_Pointer(Compiled_Type))) && \
+ (Type_Code(Vector_Ref(Compiled_Type, 0)) != TC_BROKEN_HEART)) \
+ { Old[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; \
+ Old[VARIABLE_OFFSET] = NIL; \
+ } \
+} \
+Transport_Triple()
+
+#define Purify_Transport_Variable() \
+{ Pointer Compiled_Type = Old[VARIABLE_COMPILED_TYPE]; \
+ if ((Type_Code(Compiled_Type)==AUX_REF) && \
+ (GC_Mode==PURE_COPY) && \
+ ((!Is_Constant(Get_Pointer(Compiled_Type))) || \
+ (!Is_Constant(Get_Pointer(Old[VARIABLE_OFFSET]))))) \
+ { Old[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE; \
+ Old[VARIABLE_OFFSET] = NIL; \
+ } \
+} \
+Transport_Triple()
+
+/* Weak Pointer code. The idea here is to support a post-GC pass which
+ removes any objects in the CAR of a WEAK_CONS cell which is no longer
+ referenced by other objects in the system.
+
+ The idea is to maintain a (C based) list of weak conses in old
+ space. The head of this list is the variable Weak_Chain. During
+ the normal GC pass, weak cons cells are not copied in the normal
+ manner. Instead the following structure is built:
+
+ Old Space | New Space
+ _______________________ | _______________________
+ |Broken | New | | | NULL | Old CAR data |
+ |Heart | Location ======|==>| | |
+ |_______|_____________| | |______|______________|
+ |Old Car| Next in | | | Old CDR component |
+ | type | chain | | | |
+ |_____________________| | |_____________________|
+
+*/
+
+#define Transport_Weak_Cons() \
+{ long Car_Type = Type_Code(*Old); \
+ *To++ = Make_New_Pointer(TC_NULL, *Old); \
+ Old += 1; \
+ *To++ = *Old; \
+ *Old = Make_New_Pointer(Car_Type, Weak_Chain); \
+ Weak_Chain = Temp; \
+ Pointer_End(); \
+}
+\f
+/* Special versions of the above for DumpLoop in Fasdump. This code
+ only differs from the code above in that it must check whether
+ there is enough space to remember the fixup.
+ */
+
+#define Fasdump_Setup_Pointer(Extra_Code, BH_Code) \
+BH_Code; \
+/* It must be transported to New Space */ \
+New_Address = (BROKEN_HEART_0 + C_To_Scheme(To)); \
+if ((Fixes - To) < FASDUMP_FIX_BUFFER) \
+{ NewFree = To; \
+ Fixup = Fixes; \
+ return false; \
+} \
+*--Fixes = *Old; \
+*--Fixes = C_To_Scheme(Old); \
+Extra_Code; \
+continue
+
+/* Undefine Symbols */
+
+#define Fasdump_Symbol(global_value) \
+*To++ = (*Old & ~DANGER_BIT); \
+*To++ = global_value; \
+Pointer_End()
+
+#define Fasdump_Variable() \
+*To++ = *Old; \
+*To++ = UNCOMPILED_VARIABLE; \
+*To++ = NIL; \
+Pointer_End()
+\f
+/* Compiled Code Relocation Utilities */
+
+#ifdef CMPGCFILE
+#include CMPGCFILE
+#else
+
+/* Is there anything else that can be done here? */
+
+#define Get_Compiled_Block(address) \
+fprintf(stderr, \
+ "\nRelocating compiled code without compiler support!\n"); \
+Microcode_Termination(TERM_COMPILER_DEATH)
+
+#define Compiled_BH(flag, then_what) \
+fprintf(stderr, \
+ "\nRelocating compiled code without compiler support!\n"); \
+Microcode_Termination(TERM_COMPILER_DEATH)
+
+#define Transport_Compiled()
+
+#endif
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: gcloop.c
+ *
+ * This file contains the code for the most primitive part
+ * of garbage collection.
+ *
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+#include "gccode.h"
+\f
+#ifndef butterfly
+
+#define GC_Pointer(Code) \
+Old = Get_Pointer(Temp); \
+Code
+
+#define Setup_Pointer_for_GC(Extra_Code) \
+GC_Pointer(Setup_Pointer(true, Extra_Code))
+
+Pointer *GCLoop(Scan, To_Pointer)
+fast Pointer *Scan;
+Pointer **To_Pointer;
+{ fast Pointer *To, *Old, Temp, *Low_Constant, New_Address;
+
+ To = *To_Pointer;
+ Low_Constant = Constant_Space;
+ if (GC_Debug)
+ { fprintf(stderr, "Starting scan at 0x%08x\n", Scan);
+ if (Low_Watch == ((Pointer *) NULL))
+ { fprintf(stderr, "Enter low watch range and high watch range: ");
+ scanf("%x %x", &Low_Watch, &High_Watch);
+ }
+ }
+
+ for ( ; Scan != To; Scan++)
+ { Temp = *Scan;
+
+ if (GC_Debug)
+ { In_Range = (((Scan >= Low_Watch) && (Scan <= High_Watch)) ||
+ ((Free >= Low_Watch) && (Free <= High_Watch)));
+ if (In_Range)
+ fprintf(stderr, "0x%08x: %02x|%06x ... ",
+ Scan, Type_Code(Temp), Get_Integer(Temp));
+ }
+
+/* GCLoop continues on the next page */
+\f
+/* GCLoop, continued */
+
+ Switch_by_GC_Type(Temp)
+ { case TC_BROKEN_HEART:
+ if (Scan == (Get_Pointer(Temp)))
+ { *To_Pointer = To;
+ return Scan;
+ }
+ fprintf(stderr, "GC: Broken heart in scan.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+
+ case TC_MANIFEST_NM_VECTOR:
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ Scan += Get_Integer(Temp);
+ if (GC_Debug && In_Range)
+ fprintf(stderr, "skipping %d cells.", Get_Integer(Temp));
+ break;
+
+ case_Non_Pointer:
+ if (GC_Debug && In_Range) fprintf(stderr, "not a pointer.");
+ break;
+
+ case_compiled_entry_point:
+ GC_Pointer(Setup_Internal(true,
+ Transport_Compiled(),
+ Compiled_BH(true, continue)));
+
+ case_Cell:
+ Setup_Pointer_for_GC(Transport_Cell());
+
+ case_Pair:
+ Setup_Pointer_for_GC(Transport_Pair());
+
+ case_Triple:
+ Setup_Pointer_for_GC(Transport_Triple());
+
+ case TC_VARIABLE:
+ Setup_Pointer_for_GC(Transport_Variable());
+
+/* GCLoop continues on the next page */
+\f
+/* GCLoop, continued */
+
+#ifdef QUADRUPLE
+ case_Quadruple:
+ Setup_Pointer_for_GC(Transport_Quadruple());
+#endif
+
+#ifdef FLOATING_ALIGNMENT
+ case TC_BIG_FLONUM:
+ Setup_Pointer_for_GC(Transport_Flonum());
+#else
+ case TC_BIG_FLONUM:
+ /* Fall through */
+#endif
+ case_Vector:
+ Setup_Pointer_for_GC(Transport_Vector());
+
+ case TC_FUTURE:
+ Setup_Pointer_for_GC(Transport_Future());
+
+ case TC_WEAK_CONS:
+ Setup_Pointer_for_GC(Transport_Weak_Cons());
+
+ default:
+ fprintf(stderr,
+ "GCLoop: Bad type code = 0x%02x\n",
+ Type_Code(Temp));
+ Invalid_Type_Code();
+
+ } /* Switch_by_GC_Type */
+ if (GC_Debug && In_Range) fprintf(stderr, "\n");
+ } /* For loop */
+ *To_Pointer = To;
+ return To;
+} /* GCLoop */
+\f
+/* Flip into unused heap */
+
+void GCFlip()
+{ Pointer *Temp;
+ Temp = Unused_Heap;
+ Unused_Heap = Heap_Bottom;
+ Heap_Bottom = Temp;
+ Temp = Unused_Heap_Top;
+ Unused_Heap_Top = Heap_Top;
+ Heap_Top = Temp;
+ Free = Heap_Bottom;
+ Set_Mem_Top(Heap_Top - GC_Reserve);
+ Weak_Chain = NIL;
+}
+\f
+/* Here is the code which "prunes" objects from weak cons cells. See
+ the picture in gccode.h for a description of the structure built by
+ the GC. This code follows the chain of weak cells (in old space) and
+ either updates the new copy's CAR with the relocated version of the
+ object, or replaces it with NIL.
+
+ This code could be implemented as a GC daemon, just like
+ REHASH-GC-DAEMON, but there is no "good" way of getting Weak_Chain
+ to it. Note that Weak_Chain points to Old Space unless no weak
+ conses were found.
+
+ This code should be reimplemented so it does not need to look at both
+ old and new space at the same time. Only the "real" garbage collector
+ should be allowed to do that.
+*/
+
+void Fix_Weak_Chain()
+{ fast Pointer *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant;
+ Low_Constant = Constant_Space;
+ while (Weak_Chain != NIL)
+ { Old_Weak_Cell = Get_Pointer(Weak_Chain);
+ Scan = Get_Pointer(*Old_Weak_Cell++);
+ Weak_Chain = *Old_Weak_Cell;
+ Old_Car = *Scan;
+ Temp = Make_New_Pointer(Type_Code(Weak_Chain), Old_Car);
+ Weak_Chain = Make_New_Pointer(TC_NULL, Weak_Chain);
+
+ switch(GC_Type(Temp))
+ { case GC_Non_Pointer:
+ *Scan = Temp;
+ continue;
+
+ /* Normal pointer types, the broken heart is in the first word.
+ Note that most special types are treated normally here.
+ The BH code updates *Scan if the object has been relocated.
+ Otherwise it falls through and we replace it with a full NIL.
+ Eliminating this assignment would keep old data (pl. of datum).
+ */
+
+ case GC_Cell:
+ case GC_Pair:
+ case GC_Triple:
+ case GC_Quadruple:
+ case GC_Vector:
+ Old = Get_Pointer(Old_Car);
+ if (Old >= Low_Constant)
+ { *Scan = Temp;
+ continue;
+ }
+ Normal_BH(false, continue);
+ *Scan = NIL;
+ continue;
+
+ case GC_Compiled:
+ Old = Get_Pointer(Old_Car);
+ if (Old >= Low_Constant)
+ { *Scan = Temp;
+ continue;
+ }
+ Compiled_BH(false, continue);
+ *Scan = NIL;
+ continue;
+
+ case GC_Special:
+ case GC_Undefined:
+ default: /* Non Marked Headers and Broken Hearts */
+ fprintf(stderr,
+ "\nFix_Weak_Chain: Bad Object: Type = 0x%02x; Datum = %x\n",
+ Type_Code(Temp), Datum(Temp));
+ Microcode_Termination(TERM_INVALID_TYPE_CODE);
+ }
+ }
+ return;
+}
+\f
+/* Here is the set up for the full garbage collection:
+
+ - First it makes the constant space and stack into one large area
+ by "hiding" the gap between them with a non-marked header.
+
+ - Then it saves away all the relevant microcode registers into new
+ space, making this the root for garbage collection.
+
+ - Then it does the actual garbage collection in 4 steps:
+ 1) Trace constant space.
+ 2) Trace objects pointed out by the root and constant space.
+ 3) Trace the Precious objects, remembering where consing started.
+ 4) Update all weak pointers.
+
+ - Finally it restores the microcode registers from the copies in
+ new space.
+*/
+\f
+void GC()
+{ Pointer *Root, *Result, *Check_Value,
+ The_Precious_Objects, *Root2;
+
+ /* Save the microcode registers so that they can be relocated */
+ Terminate_Old_Stacklet();
+ Terminate_Constant_Space(Check_Value);
+
+ Root = Free;
+ The_Precious_Objects = Get_Fixed_Obj_Slot(Precious_Objects);
+ Set_Fixed_Obj_Slot(Precious_Objects, NIL);
+ Set_Fixed_Obj_Slot(Lost_Objects_Base, NIL);
+
+ *Free++ = Fixed_Objects;
+ *Free++ = Make_Pointer(TC_HUNK3, History);
+ *Free++ = Undefined_Externals;
+ *Free++ = Get_Current_Stacklet();
+ *Free++ = ((Previous_Restore_History_Stacklet == NULL) ?
+ NIL :
+ Make_Pointer(TC_CONTROL_POINT, Previous_Restore_History_Stacklet));
+ *Free++ = Current_State_Point;
+ *Free++ = Fluid_Bindings;
+
+ /* The 4 step GC */
+ Result = GCLoop(Constant_Space, &Free);
+ if (Result != Check_Value)
+ { fprintf(stderr, "\nGC: Constant Scan ended too early.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+ }
+ Result = GCLoop(Root, &Free);
+ if (Free != Result)
+ { fprintf(stderr, "\nGC-1: Heap Scan ended too early.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+ }
+ Root2 = Free;
+ *Free++ = The_Precious_Objects;
+ Result = GCLoop(Root2, &Free);
+ if (Free != Result)
+ { fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+ }
+ Fix_Weak_Chain();
+
+ /* Make the microcode registers point to the copies in new-space. */
+ Fixed_Objects = *Root++;
+ Set_Fixed_Obj_Slot(Precious_Objects, *Root2);
+ Set_Fixed_Obj_Slot(Lost_Objects_Base, Make_Pointer(TC_ADDRESS, Root2));
+
+ History = Get_Pointer(*Root++);
+ Undefined_Externals = *Root++;
+ Set_Current_Stacklet(*Root);
+ Root += 1; /* Set_Current_Stacklet is sometimes a No-Op! */
+ if (*Root == NIL)
+ { Previous_Restore_History_Stacklet = NULL;
+ Root += 1;
+ }
+ else Previous_Restore_History_Stacklet = Get_Pointer(*Root++);
+ Current_State_Point = *Root++;
+ Fluid_Bindings = *Root++;
+ Free_Stacklets = NULL;
+ return;
+}
+\f
+/* (GARBAGE_COLLECT SLACK)
+ [Primitive number 0x3A]
+ Requests a garbage collection leaving the specified amount of slack
+ for the top of heap check on the next GC. The primitive ends by invoking
+ the GC daemon process if there is one.
+*/
+
+Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT")
+{ Pointer GC_Daemon_Proc;
+ Primitive_1_Arg();
+
+ Arg_1_Type(TC_FIXNUM);
+ if (Free > Heap_Top)
+ { fprintf(stderr, "\nGC has been delayed too long, and you are truly out of room!\n");
+ fprintf(stderr, "Free=0x%x, MemTop=0x%x, Heap_Top=0x%x\n", Free, MemTop, Heap_Top);
+ Microcode_Termination(TERM_EXIT);
+ }
+ GC_Reserve = Get_Integer(Arg1);
+ GCFlip();
+ Weak_Chain = NULL;
+ GC();
+ IntCode &= ~INT_GC;
+ if (GC_Check(GC_Space_Needed))
+ { fprintf(stderr, "\nGC just ended. The free pointer is at 0x%x, the top of this heap\n",
+ Free);
+ fprintf(stderr, "is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n",
+ MemTop, GC_Space_Needed);
+ Microcode_Termination(TERM_EXIT);
+ }
+ GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
+ if (GC_Daemon_Proc == NIL) return FIXNUM_0 + (MemTop - Free);
+ Pop_Primitive_Frame(1);
+ Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1));
+ Store_Return(RC_NORMAL_GC_DONE);
+ Store_Expression(FIXNUM_0 + (MemTop - Free));
+ Save_Cont();
+ Push(GC_Daemon_Proc);
+ Push(STACK_FRAME_HEADER);
+ Pushed();
+ longjmp(*Back_To_Eval, PRIM_APPLY);
+ /* The following comment is by courtesy of LINT, your friendly sponsor. */
+ /*NOTREACHED*/
+}
+#endif butterfly
+\f
+/* (GET_NEXT_CONSTANT)
+ [Primitive number 0xE4]
+ Returns the next free address in constant space.
+*/
+Built_In_Primitive(Prim_Get_Next_Constant, 0, "GET-NEXT-CONSTANT")
+{ Pointer *Next_Address = Free_Constant+1;
+ Primitive_0_Args();
+ return Make_Pointer(TC_ADDRESS, Next_Address);
+}
+
+/* (GC_TYPE OBJECT)
+ [Primitive number 0xBC]
+ Returns a fixnum indicating the GC type of the object. The object
+ is NOT touched first.
+*/
+
+Built_In_Primitive(Prim_Gc_Type, 1, "GC-TYPE")
+{ Primitive_1_Arg();
+ return Make_Non_Pointer(TC_FIXNUM, GC_Type(Arg1));
+}
--- /dev/null
+/* Emacs -*-C-*-an't tell the language */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: GCTYPE.C
+ *
+ * This file contains the table which maps between Types and
+ * GC Types.
+ *
+ */
+\f
+ /*********************************/
+ /* Mapping GC_Type to Type_Codes */
+ /*********************************/
+
+int GC_Type_Map[MAX_SAFE_TYPE + 1] = {
+ GC_Non_Pointer, /* TC_NULL,etc */
+ GC_Pair, /* TC_LIST */
+ GC_Non_Pointer, /* TC_CHARACTER */
+ GC_Pair, /* TC_SCODE_QUOTE */
+ GC_Triple, /* TC_PCOMB2 */
+ GC_Pair, /* TC_UNINTERNED_SYMBOL */
+ GC_Vector, /* TC_BIG_FLONUM */
+ GC_Pair, /* TC_COMBINATION_1 */
+ GC_Non_Pointer, /* TC_TRUE */
+ GC_Pair, /* TC_EXTENDED_PROCEDURE */
+ GC_Vector, /* TC_VECTOR */
+ GC_Non_Pointer, /* TC_RETURN_CODE */
+ GC_Triple, /* TC_COMBINATION_2 */
+ GC_Pair, /* TC_COMPILED_PROCEDURE */
+ GC_Vector, /* TC_BIG_FIXNUM */
+ GC_Pair, /* TC_PROCEDURE */
+ GC_Non_Pointer, /* TC_PRIMITIVE_EXTERNAL */
+ GC_Pair, /* TC_DELAY */
+ GC_Vector, /* TC_ENVIRONMENT */
+ GC_Pair, /* TC_DELAYED */
+ GC_Triple, /* TC_EXTENDED_LAMBDA */
+ GC_Pair, /* TC_COMMENT */
+ GC_Vector, /* TC_NON_MARKED_VECTOR */
+ GC_Pair, /* TC_LAMBDA */
+ GC_Non_Pointer, /* TC_PRIMITIVE */
+ GC_Pair, /* TC_SEQUENCE_2 */
+ GC_Non_Pointer, /* TC_FIXNUM */
+ GC_Pair, /* TC_PCOMB1 */
+ GC_Vector, /* TC_CONTROL_POINT */
+ GC_Pair, /* TC_INTERNED_SYMBOL */
+ GC_Vector, /* TC_CHARACTER_STRING,TC_VECTOR_8B */
+ GC_Pair, /* TC_ACCESS */
+ GC_Non_Pointer, /* TC_EXTENDED_FIXNUM */
+ GC_Pair, /* TC_DEFINITION */
+ GC_Special, /* TC_BROKEN_HEART */
+ GC_Pair, /* TC_ASSIGNMENT */
+ GC_Triple, /* TC_HUNK3 */
+ GC_Pair, /* TC_IN_PACKAGE */
+
+/* GC_Type_Map continues on next page */
+\f
+/* GC_Type_Map continued */
+
+ GC_Vector, /* TC_COMBINATION */
+ GC_Special, /* TC_MANIFEST_NM_VECTOR */
+ GC_Compiled, /* TC_COMPILED_EXPRESSION */
+ GC_Pair, /* TC_LEXPR */
+ GC_Vector, /* TC_PCOMB3 */
+ GC_Special, /* TC_MANIFEST_SPECIAL_NM_VECTOR */
+ GC_Triple, /* TC_VARIABLE */
+ GC_Non_Pointer, /* TC_THE_ENVIRONMENT */
+ GC_Vector, /* TC_FUTURE */
+ GC_Vector, /* TC_VECTOR_1B,TC_BIT_STRING */
+ GC_Non_Pointer, /* TC_PCOMB0 */
+ GC_Vector, /* TC_VECTOR_16B */
+ GC_Non_Pointer, /* TC_UNASSIGNED */
+ GC_Triple, /* TC_SEQUENCE_3 */
+ GC_Triple, /* TC_CONDITIONAL */
+ GC_Pair, /* TC_DISJUNCTION */
+ GC_Cell, /* TC_CELL */
+ GC_Pair, /* TC_WEAK_CONS */
+ GC_Triple, /* TC_TRAP */
+ GC_Compiled, /* TC_RETURN_ADDRESS */
+ GC_Pair, /* TC_COMPILER_LINK */
+ GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */
+ GC_Pair, /* TC_COMPLEX */
+ GC_Undefined, /* 0x3D */
+ GC_Undefined, /* 0x3E */
+ GC_Undefined, /* 0x3F */
+ GC_Undefined, /* 0x40 */
+ GC_Undefined, /* 0x41 */
+ GC_Undefined, /* 0x42 */
+ GC_Undefined, /* 0x43 */
+ GC_Undefined, /* 0x44 */
+ GC_Undefined, /* 0x45 */
+ GC_Undefined, /* 0x46 */
+ GC_Undefined, /* 0x47 */
+#if defined(MC68020)
+ GC_Non_Pointer, /* TC_PEA_INSTRUCTION */
+#else
+ GC_Undefined, /* 0x48 */
+#endif
+ GC_Undefined, /* 0x49 */
+ GC_Undefined, /* 0x4A */
+ GC_Undefined, /* 0x4B */
+ GC_Undefined, /* 0x4C */
+ GC_Undefined, /* 0x4D */
+#if defined(MC68020)
+ GC_Non_Pointer, /* TC_JMP_INSTRUCTION */
+#else
+ GC_Undefined, /* 0x4E */
+#endif
+ GC_Undefined, /* 0x4F */
+ GC_Undefined, /* 0x50 */
+#if defined(MC68020)
+ GC_Non_Pointer, /* TC_DBF_INSTRUCTION */
+#else
+ GC_Undefined, /* 0x51 */
+#endif
+ GC_Undefined, /* 0x52 */
+ GC_Undefined, /* 0x53 */
+ GC_Undefined, /* 0x54 */
+
+/* GC_Type_Map continues on next page */
+\f
+/* GC_Type_Map continued */
+
+ GC_Undefined, /* 0x55 */
+ GC_Undefined, /* 0x56 */
+ GC_Undefined, /* 0x57 */
+ GC_Undefined, /* 0x58 */
+ GC_Undefined, /* 0x59 */
+ GC_Undefined, /* 0x5A */
+ GC_Undefined, /* 0x5B */
+ GC_Undefined, /* 0x5C */
+ GC_Undefined, /* 0x5D */
+ GC_Undefined, /* 0x5E */
+ GC_Undefined, /* 0x5F */
+ GC_Undefined, /* 0x60 */
+ GC_Undefined, /* 0x61 */
+ GC_Undefined, /* 0x62 */
+ GC_Undefined, /* 0x63 */
+ GC_Undefined, /* 0x64 */
+ GC_Undefined, /* 0x65 */
+ GC_Undefined, /* 0x66 */
+ GC_Undefined, /* 0x67 */
+ GC_Undefined, /* 0x68 */
+ GC_Undefined, /* 0x69 */
+ GC_Undefined, /* 0x6A */
+ GC_Undefined, /* 0x6B */
+ GC_Undefined, /* 0x6C */
+ GC_Undefined, /* 0x6D */
+ GC_Undefined, /* 0x6E */
+ GC_Undefined, /* 0x6F */
+ GC_Undefined, /* 0x70 */
+ GC_Undefined, /* 0x71 */
+ GC_Undefined, /* 0x72 */
+ GC_Undefined, /* 0x73 */
+ GC_Undefined, /* 0x74 */
+ GC_Undefined, /* 0x75 */
+ GC_Undefined, /* 0x76 */
+ GC_Undefined, /* 0x77 */
+ GC_Undefined, /* 0x78 */
+ GC_Undefined, /* 0x79 */
+ GC_Undefined, /* 0x7A */
+ GC_Undefined, /* 0x7B */
+ GC_Undefined, /* 0x7C */
+ GC_Undefined, /* 0x7D */
+ GC_Undefined, /* 0x7E */
+ GC_Undefined /* 0x7F */
+ };
+
+#if (MAX_SAFE_TYPE != 0x7F)
+#include "gctype.c and scheme.h inconsistent -- GC_Type_Map"
+#endif
--- /dev/null
+/* 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
+#include "scheme.h"
+#include "primitive.h"
+#include "bignum.h"
+#include "flonum.h"
+#include "zones.h"
+
+Pointer C_Integer_To_Scheme_Integer(C)
+long C;
+{ fast bigdigit *Answer, *SCAN, *size;
+ long Length;
+ if (Fixnum_Fits(C))
+ return Make_Non_Pointer(TC_FIXNUM, C);
+ Length = Align(C_INTEGER_LENGTH_AS_BIGNUM);
+ Primitive_GC_If_Needed(Length);
+ Answer = BIGNUM(Free);
+ Prepare_Header(Answer, 0, (C >= 0) ? POSITIVE : NEGATIVE);
+ size = &LEN(Answer);
+ if (C < 0) C = - C;
+ for (SCAN = Bignum_Bottom(Answer); C != 0; *size += 1)
+ { *SCAN++ = Rem_Radix(C);
+ C = Div_Radix(C);
+ }
+ *((Pointer *) Answer) = Make_Header(Align(*size));
+ Free += Length;
+ Debug_Test(Free-Length);
+ return Make_Pointer(TC_BIG_FIXNUM, Free-Length);
+}
+
+int Scheme_Integer_To_C_Integer(Arg1, C)
+Pointer Arg1;
+long *C;
+{ int type = Type_Code(Arg1);
+ fast bigdigit *SCAN, *ARG1;
+ fast long Answer, i;
+ long Length;
+ if (type == TC_FIXNUM)
+ { Sign_Extend(Arg1, *C);
+ return PRIM_DONE;
+ }
+ if (type != TC_BIG_FIXNUM) return ERR_ARG_1_WRONG_TYPE;
+ ARG1 = BIGNUM(Get_Pointer(Arg1));
+ Length = LEN(ARG1);
+ if (Length==0) Answer = 0;
+ else if (Length > C_INTEGER_LENGTH_AS_BIGNUM)
+ return ERR_ARG_1_BAD_RANGE;
+ else if (Length < C_INTEGER_LENGTH_AS_BIGNUM)
+ for (SCAN=Bignum_Top(ARG1), i=0, Answer=0; i< Length; i++)
+ Answer = Mul_Radix(Answer) + *SCAN--;
+ else
+ /* Length == C_INTEGER_LENGTH_AS_BIGNUM */
+ for (SCAN=Bignum_Top(ARG1), i=0, Answer=0; i< Length; i++)
+ /* Attempting to take care of overflow problems */
+ { Answer = Mul_Radix(Answer);
+ if (Answer < 0) return ERR_ARG_1_BAD_RANGE;
+ Answer = Answer + *SCAN--;
+ if (Answer < 0) return ERR_ARG_1_BAD_RANGE;
+ }
+ if NEG_BIGNUM(ARG1) Answer = - Answer;
+ *C = Answer;
+ return PRIM_DONE;
+}
+
+Pointer Fetch_Bignum_One()
+{ return Get_Fixed_Obj_Slot(Bignum_One);
+}
+
+Built_In_Primitive(Prim_Zero, 1, "ZERO?")
+{ Primitive_1_Arg();
+ Set_Time_Zone(Zone_Math);
+ switch (Type_Code(Arg1))
+ { case TC_FIXNUM: if (Get_Integer(Arg1) == 0) return TRUTH;
+ else return NIL;
+ case TC_BIG_FLONUM: if (Get_Float(Arg1) == 0.0) return TRUTH;
+ else return NIL;
+ case TC_BIG_FIXNUM: if (ZERO_BIGNUM(Fetch_Bignum(Arg1))) return TRUTH;
+ else return NIL;
+ default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ } /*NOTREACHED*/
+}
+\f
+#define Sign_Check(C_Name, S_Name, Normal_Op, Big_Op) \
+Built_In_Primitive(C_Name, 1, S_Name) \
+{ Primitive_1_Arg(); \
+ Set_Time_Zone(Zone_Math); \
+ switch (Type_Code(Arg1)) \
+ { case TC_FIXNUM: { long Value; \
+ Sign_Extend(Arg1, Value); \
+ if (Value Normal_Op 0) return TRUTH; \
+ else return NIL; \
+ } \
+ case TC_BIG_FLONUM: if (Get_Float(Arg1) Normal_Op 0.0) return TRUTH;\
+ else return NIL; \
+P2_Sign_Check(Big_Op)
+
+#define P2_Sign_Check(Big_Op) \
+ case TC_BIG_FIXNUM: if ((LEN(Fetch_Bignum(Arg1)) != 0) \
+ && Big_Op(Fetch_Bignum(Arg1))) \
+ return TRUTH; \
+ else return NIL; \
+ default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
+ }
+/* } deliberately omitted to make LINT understand about longjmp */
+
+Sign_Check(Prim_Positive, "POSITIVE?", >, POS_BIGNUM)
+/*NOTREACHED*/ }
+Sign_Check(Prim_Negative, "NEGATIVE?", <, NEG_BIGNUM)
+/*NOTREACHED*/ }
+\f
+#define Inc_Dec(C_Name, S_Name, Normal_Op, Big_Op) \
+Built_In_Primitive(C_Name, 1, S_Name) \
+{ Primitive_1_Arg(); \
+ Set_Time_Zone(Zone_Math); \
+ switch (Type_Code(Arg1)) \
+ { case TC_FIXNUM: \
+ { fast long A, Result; \
+ Sign_Extend(Arg1, A); \
+ Result = A Normal_Op 1; \
+ if (Fixnum_Fits(Result)) \
+ return Make_Non_Pointer(TC_FIXNUM, Result); \
+P2_Inc_Dec(Normal_Op, Big_Op)
+
+#define P2_Inc_Dec(Normal_Op, Big_Op) \
+ { Pointer Ans = Fix_To_Big(Arg1); \
+ Bignum_Operation(Big_Op(Fetch_Bignum(Ans), \
+ Fetch_Bignum(Fetch_Bignum_One())), \
+ Ans); \
+ return Ans; \
+ } \
+ } \
+P3_Inc_Dec(Normal_Op, Big_Op)
+
+#define P3_Inc_Dec(Normal_Op, Big_Op) \
+ case TC_BIG_FLONUM: \
+ Reduced_Flonum_Result(Get_Float(Arg1) Normal_Op 1); \
+ case TC_BIG_FIXNUM: \
+ { Pointer Ans; \
+ Bignum_Operation(Big_Op(Fetch_Bignum(Arg1), \
+ Fetch_Bignum(Fetch_Bignum_One())), \
+ Ans); \
+ return Ans; \
+ } \
+ default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
+ }
+/* } deliberately omitted to make LINT understand about longjmp */
+
+Inc_Dec(Prim_One_Plus, "ONE-PLUS", +, plus_signed_bignum)
+/*NOTREACHED*/ }
+Inc_Dec(Prim_M_1_Plus, "MINUS-ONE-PLUS", -, minus_signed_bignum)
+/*NOTREACHED*/ }
+\f
+#define Two_Op_Comparator(C_Name, S_Name, GENERAL_OP, BIG_OP) \
+Built_In_Primitive(C_Name, 2, S_Name) \
+{ Primitive_2_Args(); \
+ Set_Time_Zone(Zone_Math); \
+ switch (Type_Code(Arg1)) \
+ { case TC_FIXNUM: \
+ { switch (Type_Code(Arg2)) \
+ { case TC_FIXNUM: \
+ { long A, B; \
+ Sign_Extend(Arg1, A); \
+ Sign_Extend(Arg2, B); \
+ return (A GENERAL_OP B) ? TRUTH : NIL; \
+ } \
+P2_Two_Op_Comparator(GENERAL_OP, BIG_OP)
+
+#define P2_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
+ case TC_BIG_FLONUM: \
+ { long A; \
+ Sign_Extend(Arg1, A); \
+ return (A GENERAL_OP (Get_Float(Arg2))) ? TRUTH : NIL; \
+ } \
+ case TC_BIG_FIXNUM: \
+ { Pointer Ans = Fix_To_Big(Arg1); \
+ return (big_compare(Fetch_Bignum(Ans), \
+ Fetch_Bignum(Arg2)) == BIG_OP) ? \
+ TRUTH : NIL; \
+ } \
+P3_Two_Op_Comparator(GENERAL_OP, BIG_OP)
+\f
+#define P3_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
+ default: \
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
+ } \
+ } \
+ case TC_BIG_FLONUM: \
+ { switch (Type_Code(Arg2)) \
+ { case TC_FIXNUM: \
+ { long B; \
+ Sign_Extend(Arg2, B); \
+ return (Get_Float(Arg1) GENERAL_OP B) ? TRUTH : NIL; \
+ } \
+P4_Two_Op_Comparator(GENERAL_OP, BIG_OP)
+
+#define P4_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
+ case TC_BIG_FLONUM: \
+ return (Get_Float(Arg1) GENERAL_OP Get_Float(Arg2)) ? \
+ TRUTH : NIL; \
+ case TC_BIG_FIXNUM: \
+ { Pointer A; \
+ A = Big_To_Float(Arg2); \
+ if (Type_Code(A) == TC_BIG_FLONUM) \
+ return (Get_Float(Arg1) GENERAL_OP Get_Float(A)) ? \
+ TRUTH : NIL; \
+P5_Two_Op_Comparator(GENERAL_OP, BIG_OP)
+\f
+#define P5_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
+ Primitive_Error(ERR_ARG_2_FAILED_COERCION); \
+ } \
+ default: \
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
+ } \
+ } \
+ case TC_BIG_FIXNUM: \
+ { switch (Type_Code(Arg2)) \
+ { case TC_FIXNUM: \
+ { Pointer Ans = Fix_To_Big(Arg2); \
+ return (big_compare(Fetch_Bignum(Arg1), \
+ Fetch_Bignum(Ans)) == BIG_OP) ? \
+ TRUTH : NIL; \
+ } \
+P6_Two_Op_Comparator(GENERAL_OP, BIG_OP)
+
+#define P6_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
+ case TC_BIG_FLONUM: \
+ { Pointer A = Big_To_Float(Arg1); \
+ if (Type_Code(A) == TC_BIG_FLONUM) \
+ return (Get_Float(A) GENERAL_OP Get_Float(Arg2)) ? \
+ TRUTH : NIL; \
+ Primitive_Error(ERR_ARG_1_FAILED_COERCION); \
+ } \
+P7_Two_Op_Comparator(GENERAL_OP, BIG_OP)
+\f
+#define P7_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
+ case TC_BIG_FIXNUM: \
+ return (big_compare(Fetch_Bignum(Arg1), \
+ Fetch_Bignum(Arg2)) == BIG_OP) ? \
+ TRUTH : NIL; \
+ default: \
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
+ } \
+ } \
+ default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
+ }
+/* } deliberately omitted to make LINT understand about longjmp */
+
+Two_Op_Comparator(Prim_Equal_Number, "NUMBER-EQUAL?", ==, EQUAL)
+/*NOTREACHED*/ }
+Two_Op_Comparator(Prim_Less, "NUMBER-LESS?", <, TWO_BIGGER)
+/*NOTREACHED*/ }
+Two_Op_Comparator(Prim_Greater, "NUMBER-GREATER?", >, ONE_BIGGER)
+/*NOTREACHED*/ }
+\f
+#define Two_Op_Operator(C_Name, S_Name, GENERAL_OP, BIG_OP) \
+Built_In_Primitive(C_Name, 2, S_Name) \
+{ Primitive_2_Args(); \
+ Set_Time_Zone(Zone_Math); \
+ switch (Type_Code(Arg1)) \
+ { case TC_FIXNUM: \
+ { switch (Type_Code(Arg2)) \
+ { case TC_FIXNUM: \
+ { fast long A, B, Result; \
+ Sign_Extend(Arg1, A); \
+ Sign_Extend(Arg2, B); \
+ Result = (A GENERAL_OP B); \
+ if (Fixnum_Fits(Result)) \
+ return Make_Non_Pointer(TC_FIXNUM, Result); \
+P2_Two_Op_Operator(GENERAL_OP, BIG_OP)
+
+#define P2_Two_Op_Operator(GENERAL_OP, BIG_OP) \
+ { Pointer Big_Arg1, Big_Arg2, Big_Result; \
+ Big_Arg1 = Fix_To_Big(Arg1); \
+ Big_Arg2 = Fix_To_Big(Arg2); \
+ Bignum_Operation(BIG_OP(Fetch_Bignum(Big_Arg1), \
+ Fetch_Bignum(Big_Arg2)), \
+ Big_Result); \
+ return Big_Result; \
+ } \
+ } \
+P3_Two_Op_Operator(GENERAL_OP, BIG_OP)
+\f
+#define P3_Two_Op_Operator(GENERAL_OP, BIG_OP) \
+ case TC_BIG_FLONUM: \
+ { fast long A; \
+ Sign_Extend(Arg1, A); \
+ Reduced_Flonum_Result(A GENERAL_OP Get_Float(Arg2)); \
+ } \
+P4_Two_Op_Operator(GENERAL_OP, BIG_OP)
+
+#define P4_Two_Op_Operator(GENERAL_OP, BIG_OP) \
+ case TC_BIG_FIXNUM: \
+ { Pointer Big_Arg1 = Fix_To_Big(Arg1); \
+ Bignum_Operation(BIG_OP(Fetch_Bignum(Big_Arg1), \
+ Fetch_Bignum(Arg2)), \
+ Big_Arg1); \
+ return Big_Arg1; \
+ } \
+ default: \
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
+ } \
+ } \
+P5_Two_Op_Operator(GENERAL_OP, BIG_OP)
+\f
+#define P5_Two_Op_Operator(GENERAL_OP, BIG_OP) \
+ case TC_BIG_FLONUM: \
+ { switch (Type_Code(Arg2)) \
+ { case TC_FIXNUM: \
+ { fast long B; \
+ Sign_Extend(Arg2, B); \
+ Reduced_Flonum_Result(Get_Float(Arg1) GENERAL_OP B); \
+ } \
+ case TC_BIG_FLONUM: \
+ Reduced_Flonum_Result(Get_Float(Arg1) GENERAL_OP \
+ Get_Float(Arg2)); \
+P6_Two_Op_Operator(GENERAL_OP, BIG_OP)
+
+#define P6_Two_Op_Operator(GENERAL_OP, BIG_OP) \
+ case TC_BIG_FIXNUM: \
+ { Pointer B = Big_To_Float(Arg2); \
+ if (Type_Code(B) == TC_BIG_FLONUM) \
+ { Reduced_Flonum_Result(Get_Float(Arg1) GENERAL_OP \
+ Get_Float(B)); \
+ } \
+ Primitive_Error(ERR_ARG_2_FAILED_COERCION); \
+ } \
+ default: \
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
+ } \
+ } \
+P7_Two_Op_Operator(GENERAL_OP, BIG_OP)
+\f
+#define P7_Two_Op_Operator(GENERAL_OP, BIG_OP) \
+ case TC_BIG_FIXNUM: \
+ { switch (Type_Code(Arg2)) \
+ { case TC_FIXNUM: \
+ { Pointer Big_Arg2 = Fix_To_Big(Arg2); \
+ Bignum_Operation(BIG_OP(Fetch_Bignum(Arg1), \
+ Fetch_Bignum(Big_Arg2)), \
+ Big_Arg2); \
+ return Big_Arg2; \
+ } \
+P8_Two_Op_Operator(GENERAL_OP, BIG_OP)
+
+#define P8_Two_Op_Operator(GENERAL_OP, BIG_OP) \
+ case TC_BIG_FLONUM: \
+ { Pointer A = Big_To_Float(Arg1); \
+ if (Type_Code(A) == TC_BIG_FLONUM) \
+ { Reduced_Flonum_Result(Get_Float(A) GENERAL_OP \
+ Get_Float(Arg2)); \
+ } \
+ Primitive_Error(ERR_ARG_1_FAILED_COERCION); \
+ } \
+P9_Two_Op_Operator(GENERAL_OP, BIG_OP)
+\f
+#define P9_Two_Op_Operator(GENERAL_OP, BIG_OP) \
+ case TC_BIG_FIXNUM: \
+ { Pointer Ans; \
+ Bignum_Operation(BIG_OP(Fetch_Bignum(Arg1), \
+ Fetch_Bignum(Arg2)), \
+ Ans); \
+ return Ans; \
+ } \
+ default: \
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
+ } \
+ } \
+ default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
+ }
+/* } deliberately omitted to make LINT understand about longjmp */
+
+Two_Op_Operator(Prim_Plus, "PLUS", +, plus_signed_bignum)
+/*NOTREACHED*/ }
+Two_Op_Operator(Prim_Minus, "MINUS", -, minus_signed_bignum)
+/*NOTREACHED*/ }
+\f
+Built_In_Primitive(Prim_Multiply, 2, "MULTIPLY")
+{ Primitive_2_Args();
+ Set_Time_Zone(Zone_Math);
+ switch (Type_Code(Arg1))
+ { case TC_FIXNUM:
+ { switch (Type_Code(Arg2))
+ { case TC_FIXNUM:
+ { fast Pointer Result;
+ Result = Mul(Arg1, Arg2);
+ if (Result != NIL) return Result;
+ { Pointer Big_Arg1, Big_Arg2;
+ Big_Arg1 = Fix_To_Big(Arg1);
+ Big_Arg2 = Fix_To_Big(Arg2);
+ Bignum_Operation(multiply_signed_bignum(Fetch_Bignum(Big_Arg1),
+ Fetch_Bignum(Big_Arg2)),
+ Big_Arg1);
+ return Big_Arg1;
+ }
+ }
+ case TC_BIG_FLONUM:
+ { fast long A;
+ Sign_Extend(Arg1, A);
+ Reduced_Flonum_Result(A * Get_Float(Arg2));
+ }
+
+/* Prim_Multiply continues on the next page */
+\f
+/* Prim_Multiply, continued */
+
+ case TC_BIG_FIXNUM:
+ { Pointer Big_Arg1 = Fix_To_Big(Arg1);
+ Bignum_Operation(multiply_signed_bignum(Fetch_Bignum(Big_Arg1),
+ Fetch_Bignum(Arg2)),
+ Big_Arg1);
+ return Big_Arg1;
+ }
+ default:
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ } /*NOTREACHED*/
+ }
+ case TC_BIG_FLONUM:
+ { switch (Type_Code(Arg2))
+ { case TC_FIXNUM:
+ { fast long B;
+ Sign_Extend(Arg2, B);
+ Reduced_Flonum_Result(Get_Float(Arg1) * B);
+ }
+ case TC_BIG_FLONUM:
+ Reduced_Flonum_Result(Get_Float(Arg1) * Get_Float(Arg2));
+ case TC_BIG_FIXNUM:
+ { Pointer B = Big_To_Float(Arg2);
+ if (Type_Code(B) == TC_BIG_FLONUM)
+ { Reduced_Flonum_Result(Get_Float(Arg1) * Get_Float(B));
+ }
+ Primitive_Error(ERR_ARG_2_FAILED_COERCION);
+ } /*NOTREACHED*/
+ default:
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ } /*NOTREACHED*/
+ }
+
+/* Prim_Multiply continues on the next page */
+\f
+/* Prim_Multiply, continued */
+
+ case TC_BIG_FIXNUM:
+ { switch (Type_Code(Arg2))
+ { case TC_FIXNUM:
+ { Pointer Big_Arg2 = Fix_To_Big(Arg2);
+ Bignum_Operation(multiply_signed_bignum(Fetch_Bignum(Arg1),
+ Fetch_Bignum(Big_Arg2)),
+ Big_Arg2);
+ return Big_Arg2;
+ }
+ case TC_BIG_FLONUM:
+ { Pointer A = Big_To_Float(Arg1);
+ if (Type_Code(A) == TC_BIG_FLONUM)
+ { Reduced_Flonum_Result(Get_Float(A) * Get_Float(Arg2));
+ }
+ Primitive_Error(ERR_ARG_1_FAILED_COERCION);
+ } /*NOTREACHED*/
+ case TC_BIG_FIXNUM:
+ { Pointer Ans;
+ Bignum_Operation(multiply_signed_bignum(Fetch_Bignum(Arg1),
+ Fetch_Bignum(Arg2)),
+ Ans);
+ return Ans;
+ }
+ default:
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ } /*NOTREACHED*/
+ }
+ default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ } /*NOTREACHED*/
+}
+\f
+Built_In_Primitive(Prim_Divide, 2, "DIVIDE")
+{ Primitive_2_Args();
+ Set_Time_Zone(Zone_Math);
+ switch (Type_Code(Arg1))
+ { case TC_FIXNUM:
+ { switch (Type_Code(Arg2))
+ { case TC_FIXNUM:
+ { fast long A, B;
+ double Result;
+ Sign_Extend(Arg1, A);
+ Sign_Extend(Arg2, B);
+ if (B==0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Result = (double) A / (double) B;
+ Reduced_Flonum_Result(Result);
+ }
+ case TC_BIG_FLONUM:
+ { fast long A;
+ Sign_Extend(Arg1, A);
+ if (Get_Float(Arg2) == 0)
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Reduced_Flonum_Result(((double) A) / Get_Float(Arg2));
+ }
+
+/* Prim_Divide continues on the next page */
+\f
+/* Prim_Divide, continued */
+
+ case TC_BIG_FIXNUM:
+ { Pointer Big_Arg1, Result, B;
+ long A;
+ if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Big_Arg1 = Fix_To_Big(Arg1);
+ Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Big_Arg1),
+ Fetch_Bignum(Arg2)),
+ Result);
+ if (Vector_Ref(Result, CONS_CDR) == FIXNUM_0)
+ return (Vector_Ref(Result, CONS_CAR));
+ Sign_Extend(Arg1, A);
+ { B = Big_To_Float(Arg2);
+ if (Type_Code(B) == TC_BIG_FLONUM)
+ { Reduced_Flonum_Result(A / Get_Float(B));
+ }
+ Primitive_Error(ERR_ARG_2_FAILED_COERCION);
+ } /*NOTREACHED*/
+ }
+ default:
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ } /*NOTREACHED*/
+ }
+ case TC_BIG_FLONUM:
+ { switch (Type_Code(Arg2))
+ { case TC_FIXNUM:
+ { fast long B;
+ Sign_Extend(Arg2, B);
+ if (B == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ { Reduced_Flonum_Result(Get_Float(Arg1) / ((double) B));
+ }
+ }
+
+/* Prim_Divide continues on the next page */
+\f
+/* Prim_Divide, continued */
+
+ case TC_BIG_FLONUM:
+ if (Get_Float(Arg2) == 0)
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Reduced_Flonum_Result(Get_Float(Arg1) / Get_Float(Arg2));
+ case TC_BIG_FIXNUM:
+ { Pointer B;
+ if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ B = Big_To_Float(Arg2);
+ if (Type_Code(B) == TC_BIG_FLONUM)
+ { Reduced_Flonum_Result(Get_Float(Arg1) / Get_Float(B));
+ }
+ Primitive_Error(ERR_ARG_2_FAILED_COERCION);
+ } /*NOTREACHED*/
+ default:
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ } /*NOTREACHED*/
+ }
+
+/* Prim_Divide continues on the next page */
+\f
+/* Prim_Divide, continued */
+
+ case TC_BIG_FIXNUM:
+ { switch (Type_Code(Arg2))
+ { case TC_FIXNUM:
+ { Pointer Big_Arg2, Result, A;
+ Big_Arg2 = Fix_To_Big(Arg2);
+ if (ZERO_BIGNUM(Fetch_Bignum(Big_Arg2)))
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1),
+ Fetch_Bignum(Big_Arg2)),
+ Result);
+ if (Vector_Ref(Result, CONS_CDR) == FIXNUM_0)
+ return (Vector_Ref(Result, CONS_CAR));
+ A = Big_To_Float(Arg1);
+ if (Type_Code(A) == TC_BIG_FLONUM)
+ { long B;
+ Sign_Extend(Arg2, B);
+ Reduced_Flonum_Result(Get_Float(A) / ((double) B));
+ }
+ Primitive_Error(ERR_ARG_1_FAILED_COERCION);
+ } /*NOTREACHED*/
+ case TC_BIG_FLONUM:
+ { Pointer A;
+ if (Get_Float(Arg2) == 0.0)
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ A = Big_To_Float(Arg1);
+ if (Type_Code(A) == TC_BIG_FLONUM)
+ { Reduced_Flonum_Result(Get_Float(A) / Get_Float(Arg2));
+ }
+ Primitive_Error(ERR_ARG_1_FAILED_COERCION);
+ } /*NOTREACHED*/
+
+/* Prim_Divide continues on the next page */
+\f
+/* Prim_Divide, continued */
+
+ case TC_BIG_FIXNUM:
+ { Pointer Result, A, B;
+ if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1),
+ Fetch_Bignum(Arg2)),
+ Result);
+ if (Vector_Ref(Result, CONS_CDR) == FIXNUM_0)
+ return (Vector_Ref(Result, CONS_CAR));
+ A = Big_To_Float(Arg1);
+ if (Type_Code(A) == TC_BIG_FLONUM)
+ { B = Big_To_Float(Arg2);
+ if (Type_Code(B) == TC_BIG_FLONUM)
+ { if (Get_Float(B) == 0)
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ { Reduced_Flonum_Result(Get_Float(A) / Get_Float(B));
+ }
+ }
+ Primitive_Error(ERR_ARG_2_FAILED_COERCION);
+ } /*NOTREACHED*/
+ Primitive_Error(ERR_ARG_1_FAILED_COERCION);
+ }
+ default:
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ } /*NOTREACHED*/
+ }
+ default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ } /*NOTREACHED*/
+}
+\f
+Built_In_Primitive(Prim_Integer_Divide, 2, "INTEGER-DIVIDE")
+{ Primitive_2_Args();
+ Set_Time_Zone(Zone_Math);
+ switch (Type_Code(Arg1))
+ { case TC_FIXNUM:
+ { switch (Type_Code(Arg2))
+ { case TC_FIXNUM:
+ { fast long A, B, C, D;
+ Pointer *Cons_Cell;
+ Sign_Extend(Arg1, A);
+ Sign_Extend(Arg2, B);
+ if (B == 0)
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Primitive_GC_If_Needed(2);
+ /* These (C & D) are necessary because Make_Non_Pointer casts to
+ Pointer which is unsigned long, and then the arithmetic is wrong
+ if the operations are placed in the macro "call". */
+ C = A / B;
+ D = A % B;
+ Cons_Cell = Free;
+ Free += 2;
+ Cons_Cell[CONS_CAR] = Make_Non_Pointer(TC_FIXNUM, C);
+ Cons_Cell[CONS_CDR] = Make_Non_Pointer(TC_FIXNUM, D);
+ return Make_Pointer(TC_LIST, Cons_Cell);
+ }
+ case TC_BIG_FIXNUM:
+ { Pointer Big_Arg1, Pair;
+ if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Big_Arg1 = Fix_To_Big(Arg1);
+ Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Big_Arg1),
+ Fetch_Bignum(Arg2)),
+ Pair);
+ return Pair;
+ }
+ default:
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ } /*NOTREACHED*/
+ }
+
+/* Prim_Integer_Divide continues on the next page */
+\f
+/* Prim_Integer_Divide, continued */
+
+ case TC_BIG_FIXNUM:
+ { switch (Type_Code(Arg2))
+ { case TC_FIXNUM:
+ { Pointer Big_Arg2, Pair;
+ if (Get_Integer(Arg2) == 0)
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Big_Arg2 = Fix_To_Big(Arg2);
+ Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1),
+ Fetch_Bignum(Big_Arg2)),
+ Pair);
+ return Pair;
+ }
+ case TC_BIG_FIXNUM:
+ { Pointer Pair;
+ if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1),
+ Fetch_Bignum(Arg2)),
+ Pair);
+ return Pair;
+ }
+ default:
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ } /*NOTREACHED*/
+ }
+ default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ } /*NOTREACHED*/
+}
+\f
+/* Generic sqrt and transcendental functions are created by generalizing
+ their floating point counterparts.
+*/
+
+#define Generic_Function(Prim_Name, S_Name, Routine) \
+Built_In_Primitive(Prim_Name, 1, S_Name) \
+{ double Routine(); \
+ Primitive_1_Arg(); \
+ Set_Time_Zone(Zone_Math); \
+ switch (Type_Code(Arg1)) \
+ { case TC_FIXNUM: \
+ { long Arg; \
+ Sign_Extend(Arg1, Arg); \
+ Reduced_Flonum_Result(Routine((double) Arg)); \
+ } \
+ case TC_BIG_FLONUM: \
+ Reduced_Flonum_Result(Routine(Get_Float(Arg1))); \
+ case TC_BIG_FIXNUM: \
+ { Pointer A = Big_To_Float(Arg1); \
+ if (Type_Code(A) != TC_BIG_FLONUM) \
+ Primitive_Error(ERR_ARG_1_FAILED_COERCION); \
+ Reduced_Flonum_Result(Routine(Get_Float(A))); \
+ } \
+ default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
+ }
+/* } deliberately omitted to make LINT understand about longjmp */
+
+/* This horrible hack because there are no lambda-expressions in C. */
+
+#define Restricted_Generic(C_Name, S_Name, Routine, Lambda, Restriction)\
+double Lambda(arg) \
+fast double arg; \
+{ double Routine(); \
+ if (arg Restriction 0.0) Primitive_Error(ERR_ARG_1_BAD_RANGE); \
+ return Routine(arg); \
+} \
+Generic_Function(C_Name, S_Name, Lambda)
+\f
+/* And here the functions themselves */
+
+Restricted_Generic(Prim_Sqrt, "SQRT", sqrt, Scheme_Sqrt, <)
+/*NOTREACHED*/ }
+Generic_Function(Prim_Exp, "EXP", exp)
+/*NOTREACHED*/ }
+Restricted_Generic(Prim_Ln, "LN", log, Scheme_Ln, <=)
+/*NOTREACHED*/ }
+Generic_Function(Prim_Sine, "SINE", sin)
+/*NOTREACHED*/ }
+Generic_Function(Prim_Cosine, "COSINE", cos)
+/*NOTREACHED*/ }
+Generic_Function(Prim_Arctan, "ARCTAN", atan)
+/*NOTREACHED*/ }
+\f
+/* Coercions from Floating point to integers.
+
+ There are four possible ways to coerce:
+
+ - Truncate : towards 0.
+ - Round : towards closest integer.
+ - Floor : towards -infinity.
+ - Ceiling : towards +infinity.
+
+ All these primitives differ only in how floating point numbers
+ are mapped before they are truncated.
+
+ If the system does not provide the double precision procedures
+ floor and ceil, Floor is incorrect for negative integers in
+ floating point format, and Ceiling is incorrect for positive
+ integers in floating point format.
+*/
+
+#define Truncate_Mapping(arg) arg
+#define Round_Mapping(arg) ((arg) >= 0.0 ? (arg)+0.5 : (arg)-0.5)
+
+#ifdef HAS_FLOOR
+extern double floor(), ceil();
+#define Floor_Mapping(arg) floor(arg)
+#define Ceiling_Mapping(arg) ceil(arg)
+#else
+#define Floor_Mapping(arg) ((arg) >= 0.0 ? (arg) : (arg)-1.0)
+#define Ceiling_Mapping(arg) ((arg) >= 0.0 ? (arg)+1.0 : (arg))
+#endif
+\f
+#define Flonum_To_Integer(Prim_Name, S_Name, How_To_Do_It) \
+Built_In_Primitive(Prim_Name, 1, S_Name) \
+{ Primitive_1_Arg(); \
+ Set_Time_Zone(Zone_Math); \
+ switch (Type_Code(Arg1)) \
+ { case TC_FIXNUM : \
+ case TC_BIG_FIXNUM: return Arg1; \
+ case TC_BIG_FLONUM: \
+ { fast double Arg = Get_Float(Arg1); \
+ fast double temp = How_To_Do_It(Arg); \
+ Pointer Result; \
+ if (flonum_exceeds_fixnum(temp)) Result = Float_To_Big(temp); \
+ else double_into_fixnum(temp, Result); \
+ return Result; \
+ } \
+ default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
+ }
+/* } deliberately omitted to make LINT understand about longjmp */
+
+Flonum_To_Integer(Prim_Truncate, "TRUNCATE", Truncate_Mapping)
+/*NOTREACHED*/ }
+Flonum_To_Integer(Prim_Round, "ROUND", Round_Mapping)
+/*NOTREACHED*/ }
+Flonum_To_Integer(Prim_Floor, "FLOOR", Floor_Mapping)
+/*NOTREACHED*/ }
+Flonum_To_Integer(Prim_Ceiling, "CEILING", Ceiling_Mapping)
+/*NOTREACHED*/ }
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: history.h
+ *
+ * History maintenance data structures and support.
+ *
+ */
+
+/*
+ * The history consists of a "vertebra" which is a doubly linked ring,
+ * each entry pointing to a "rib". The rib consists of a singly
+ * linked ring whose entries contain expressions and environments.
+ */
+
+#define HIST_RIB 0
+#define HIST_NEXT_SUBPROBLEM 1
+#define HIST_PREV_SUBPROBLEM 2
+#define HIST_MARK 1
+
+#define RIB_EXP 0
+#define RIB_ENV 1
+#define RIB_NEXT_REDUCTION 2
+#define RIB_MARK 2
+
+/* Save_History places a restore history frame on the stack. Such a
+ * frame consists of a normal continuation frame plus a pointer to the
+ * stacklet on which the last restore history is located and the
+ * offset within that stacklet. If the last restore history is in
+ * this stacklet then the history pointer is NIL to signify this. If
+ * there is no previous restore history then the history pointer is
+ * NIL and the offset is 0.
+ */
+
+#define Save_History(Return_Code) \
+if (Previous_Restore_History_Stacklet == NULL) Push(NIL); \
+else \
+ Push(Make_Pointer(TC_CONTROL_POINT, \
+ Previous_Restore_History_Stacklet)); \
+Push(Make_Non_Pointer(TC_FIXNUM, \
+ Previous_Restore_History_Offset)); \
+Store_Expression(Make_Pointer(TC_HUNK3, History)); \
+Store_Return((Return_Code)); \
+Save_Cont(); \
+History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History))
+\f
+/* History manipulation in the interpreter. */
+
+#ifdef COMPILE_HISTORY
+#define New_Subproblem(Expr, Env) \
+{ fast Pointer *Rib; \
+ History = Get_Pointer(History[HIST_NEXT_SUBPROBLEM]); \
+ History[HIST_MARK] |= DANGER_BIT; \
+ Rib = Get_Pointer(History[HIST_RIB]); \
+ Rib[RIB_MARK] |= DANGER_BIT; \
+ Rib[RIB_ENV] = Env; \
+ Rib[RIB_EXP] = Expr; \
+}
+
+#define Reuse_Subproblem(Expr, Env) \
+{ fast Pointer *Rib; \
+ Rib = Get_Pointer(History[HIST_RIB]); \
+ Rib[RIB_MARK] |= DANGER_BIT; \
+ Rib[RIB_ENV] = Env; \
+ Rib[RIB_EXP] = Expr; \
+}
+
+#define New_Reduction(Expr, Env) \
+{ fast Pointer *Rib; \
+ Rib = Get_Pointer(Fast_Vector_Ref(History[HIST_RIB], \
+ RIB_NEXT_REDUCTION)); \
+ History[HIST_RIB] = Make_Pointer(TC_HUNK3, Rib); \
+ Rib[RIB_ENV] = Env; \
+ Rib[RIB_EXP] = Expr; \
+ Rib[RIB_MARK] &= ~DANGER_BIT; \
+}
+
+#define End_Subproblem() \
+ History[HIST_MARK] &= ~DANGER_BIT; \
+ History = Get_Pointer(History[HIST_PREV_SUBPROBLEM]);
+
+#else /* COMPILE_HISTORY */
+#define New_Subproblem(Expr, Env) { }
+#define Reuse_Subproblem(Expr, Env) { }
+#define New_Reduction(Expr, Env) { }
+#define End_Subproblem() { }
+#endif /* COMPILE_HISTORY */
+\f
+/* History manipulation for the compiled code interface. */
+
+#ifdef COMPILE_HISTORY
+
+#define Compiler_New_Reduction() \
+{ New_Reduction(NIL, \
+ Make_Non_Pointer(TC_RETURN_CODE, \
+ RC_POP_FROM_COMPILED_CODE)); \
+}
+
+#define Compiler_New_Subproblem() \
+{ New_Subproblem(NIL, \
+ Make_Non_Pointer(TC_RETURN_CODE, \
+ RC_POP_FROM_COMPILED_CODE)); \
+}
+
+#define Compiler_End_Subproblem() \
+{ End_Subproblem(); \
+}
+
+#else /* COMPILE_HISTORY */
+
+#define Compiler_New_Reduction()
+#define Compiler_New_Subproblem()
+#define Compiler_End_Subproblem()
+
+#endif /* COMPILE_HISTORY */
--- /dev/null
+/* Hey EMACS, this is -*- C -*- code! */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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"
+#include "winder.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")
+{
+ fast Pointer scan_list, *scan_stack;
+ fast long number_of_args, i;
+#ifdef butterfly
+ Pointer saved_stack_pointer;
+#endif
+ Primitive_2_Args();
+
+ /* 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.
+
+ Originally this code tried to be clever by copying the argument
+ list into a linear (vector-like) form, so as to avoid the
+ overhead of traversing the list twice. Unfortunately, the
+ overhead of maintaining this other form (e.g. PRIMITIVE_GC_If_Needed)
+ is sufficiently high that it probably makes up for the time saved. */
+
+ Touch_In_Primitive( Arg2, scan_list);
+ number_of_args = 0;
+ while (Type_Code( scan_list) == TC_LIST)
+ {
+ number_of_args += 1;
+ Touch_In_Primitive( Vector_Ref( scan_list, CONS_CDR), scan_list);
+ }
+ if (scan_list != NIL)
+ Primitive_Error( ERR_ARG_2_WRONG_TYPE);
+#ifdef USE_STACKLETS
+ /* This is conservative: if the number of arguments is large enough
+ the Will_Push below may try to allocate space on the heap for the
+ stack frame. */
+ Primitive_GC_If_Needed(New_Stacklet_Size(number_of_args +
+ STACK_ENV_EXTRA_SLOTS + 1));
+#endif
+ Pop_Primitive_Frame( 2);
+\f
+ Will_Push( (number_of_args + STACK_ENV_EXTRA_SLOTS + 1));
+#ifdef butterfly
+ saved_stack_pointer = Stack_Pointer;
+#endif
+ scan_stack = Simulate_Pushing( number_of_args);
+ Stack_Pointer = scan_stack;
+ i = number_of_args;
+ Touch_In_Primitive( Arg2, scan_list);
+ while (i > 0)
+ {
+#ifdef butterfly
+ /* Check for abominable case of someone bashing the arg list. */
+ if (Type_Code( scan_list) != TC_LIST)
+ {
+ Stack_Pointer = saved_stack_pointer;
+ Primitive_Error( ERR_ARG_2_BAD_RANGE);
+ }
+#endif
+ *scan_stack++ = Vector_Ref( scan_list, CONS_CAR);
+ Touch_In_Primitive( Vector_Ref( scan_list, CONS_CDR), scan_list);
+ i -= 1;
+ }
+ Push( Arg1); /* The procedure */
+ Push( (STACK_FRAME_HEADER + number_of_args));
+ Pushed();
+ longjmp( *Back_To_Eval, PRIM_APPLY);
+}
+\f
+/* This code used to be in the middle of Make_Control_Point, replaced
+ * by CWCC below. Preprocessor conditionals do not work in macros.
+ */
+
+#define CWCC(Return_Code) \
+ fast Pointer *From_Where; \
+ Primitive_1_Arg(); \
+ CWCC_1(); \
+ /* Implementation detail: in addition to setting aside the old \
+ stacklet on a catch, the new stacklet 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 stacklet. \
+ The current enabled interrupts are also saved in the old stacklet. \
+ \
+ >>> Temporarily (maybe) the act of doing a CATCH will disable any \
+ >>> return hook that may be in the stack. \
+ \
+ >>> Don't even think about adding COMPILER to this stuff! \
+ */ \
+ Pop_Primitive_Frame(1); \
+ if (Return_Hook_Address != NULL) \
+ { *Return_Hook_Address = Old_Return_Code; \
+ Return_Hook_Address = NULL; \
+ } \
+/* Put down frames to restore history and interrupts so that these \
+ * operations will be performed on a throw. \
+ */ \
+ Will_Push(CONTINUATION_SIZE + HISTORY_SIZE); \
+ Save_History(Return_Code); \
+ Store_Expression(Make_Non_Pointer(TC_FIXNUM, IntEnb)); \
+ Store_Return(RC_RESTORE_INT_MASK); \
+ Save_Cont(); \
+ Pushed(); \
+/* There is no history to use since the last control point was formed. \
+ */ \
+ Previous_Restore_History_Stacklet = NULL; \
+ Previous_Restore_History_Offset = 0; \
+ CWCC_2(); \
+/* 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(); */
+\f
+#ifdef USE_STACKLETS
+#define CWCC_1() \
+ Primitive_GC_If_Needed(2*Default_Stacklet_Size)
+
+#define CWCC_2() \
+ Control_Point = Get_Current_Stacklet(); \
+ Allocate_New_Stacklet(3)
+
+#else /* Not using stacklets, so full copy must be made */
+#define CWCC_1() \
+ Primitive_GC_If_Needed((Stack_Top-Stack_Pointer) + \
+ STACKLET_HEADER_SIZE - 1 + \
+ CONTINUATION_SIZE + \
+ HISTORY_SIZE)
+
+#define CWCC_2() \
+{ fast long i; \
+ fast long Stack_Cells = (Stack_Top-Stack_Pointer); \
+ Control_Point = Make_Pointer(TC_CONTROL_POINT, Free); \
+ Free[STACKLET_LENGTH] = \
+ Make_Non_Pointer(TC_MANIFEST_VECTOR, \
+ Stack_Cells + STACKLET_HEADER_SIZE - 1); \
+ Free[STACKLET_UNUSED_LENGTH] = \
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0); \
+ Free += STACKLET_HEADER_SIZE; \
+ for (i=0; i < Stack_Cells; i++) *Free++ = Pop(); \
+ if (Consistency_Check) \
+ if (Stack_Pointer != Stack_Top) \
+ Microcode_Termination(TERM_BAD_STACK); \
+ Will_Push(CONTINUATION_SIZE); \
+ Store_Return(RC_JOIN_STACKLETS); \
+ Store_Expression(Control_Point); \
+ Save_Cont(); \
+ Pushed(); \
+}
+#endif
+\f
+/* (CATCH PROCEDURE)
+ [Primitive number 0x03]
+
+ Creates a control point (a pointer to 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. If the dangerous bit of the
+ unused length word in the stacklet is clear then the control
+ point may be reused as often as desired since the stack will be
+ copied 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; it assumes that the microcode
+ sets and clears the appropriate danger bits for copying.
+*/
+
+Built_In_Primitive(Prim_Catch, 1, "CALL-WITH-CURRENT-CONTINUATION")
+{ fast Pointer Control_Point;
+ CWCC(RC_RESTORE_HISTORY);
+ Clear_Danger_Bit((Get_Pointer(Control_Point))[STACKLET_UNUSED_LENGTH]);
+ longjmp(*Back_To_Eval, PRIM_APPLY);
+}
+
+#ifdef USE_STACKLETS
+Built_In_Primitive(Prim_Non_Reentrant_Catch, 1, "FAST-CALL-WITH-CURRENT-CONTINUATION")
+{ Pointer Control_Point;
+ CWCC(RC_RESTORE_DONT_COPY_HISTORY);
+ longjmp(*Back_To_Eval, PRIM_APPLY);
+}
+
+#else /* Without stacklets, the two catches are identical */
+
+Built_In_Primitive(Prim_Non_Reentrant_Catch, 1, "FAST-CALL-WITH-CURRENT-CONTINUATION")
+{ Pointer Control_Point;
+ CWCC(RC_RESTORE_HISTORY);
+ Clear_Danger_Bit((Get_Pointer(Control_Point))[STACKLET_UNUSED_LENGTH]);
+ longjmp(*Back_To_Eval, PRIM_APPLY);
+}
+#endif
+\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;
+}
+
+/* (ERROR-PROCEDURE arg1 arg2 arg3)
+ Passes its arguments along to the appropriate Scheme error handler
+ after turning off history, etc.
+*/
+Built_In_Primitive(Prim_Error_Procedure, 3, "ERROR-PROCEDURE")
+{ Primitive_3_Args();
+ Will_Push(CONTINUATION_SIZE+HISTORY_SIZE+STACK_ENV_EXTRA_SLOTS+4);
+ Back_Out_Of_Primitive();
+ Save_Cont();
+ Stop_History();
+ /* Stepping should be cleared here! */
+ Push(Arg3);
+ Push(Arg2);
+ Push(Arg1);
+ Push(Get_Fixed_Obj_Slot(Error_Procedure));
+ Push(STACK_FRAME_HEADER+3);
+ Pushed();
+ longjmp(*Back_To_Eval, PRIM_APPLY);
+}
+
+/* (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(CONTINUATION_SIZE);
+ 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); /*NOTREACHED*/
+}
+\f
+/* (EXECUTE_AT_NEW_POINT SPACE BEFORE DURING AFTER)
+ [Primitive number 0xE2]
+ Create a new state point in the specified state SPACE. To enter
+ the new point you must execute the BEFORE thunk. On the way out,
+ the AFTER thunk is executed. If SPACE is NIL, then the microcode
+ variable Current_State_Point is used to find the current state
+ point and no state space is side-effected as the code runs.
+*/
+Built_In_Primitive(Prim_Execute_At_New_Point, 4, "EXECUTE-AT-NEW-POINT")
+{ Pointer New_Point, Old_Point;
+ Primitive_4_Args();
+ guarantee_state_point();
+ if (Arg1 == NIL) Old_Point = Current_State_Point;
+ else
+ { 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);
+ Old_Point = Fast_Vector_Ref(Arg1, STATE_SPACE_NEAREST_POINT);
+ }
+ Primitive_GC_If_Needed(STATE_POINT_SIZE);
+ Pop_Primitive_Frame(4);
+ New_Point = Make_Pointer(TC_VECTOR, Free);
+ Free[STATE_POINT_HEADER] =
+ Make_Non_Pointer(TC_MANIFEST_VECTOR, STATE_POINT_SIZE-1);
+ Free[STATE_POINT_TAG] = Get_Fixed_Obj_Slot(State_Point_Tag);
+ Free[STATE_POINT_BEFORE_THUNK] = Arg2;
+ Free[STATE_POINT_AFTER_THUNK] = Arg4;
+ Free[STATE_POINT_NEARER_POINT] = Old_Point;
+ Free[STATE_POINT_DISTANCE_TO_ROOT] =
+ 1 + Fast_Vector_Ref(Old_Point, STATE_POINT_DISTANCE_TO_ROOT);
+ Free += STATE_POINT_SIZE;
+ 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(Old_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(Arg3);
+ Push(STACK_FRAME_HEADER);
+ /* Push the continuation to go with the stack frame */
+ Store_Expression(NIL);
+ Store_Return(RC_INTERNAL_APPLY);
+ Save_Cont();
+ Pushed();
+ Translate_To_Point(New_Point);
+}
+\f
+/* (MAKE_STATE_SPACE MUTABLE?)
+ [Primitive number 0xE1]
+ Creates a new state space for the dynamic winder. Used only
+ internally to the dynamic wind operations. If the arugment
+ is #!TRUE, then a real, mutable state space is created.
+ Otherwise a (actually, THE) immutable space is created and
+ the microcode will track motions in this space.
+*/
+Built_In_Primitive(Prim_Make_State_Space, 1, "MAKE-STATE-SPACE")
+{ Pointer New_Point;
+ Primitive_1_Arg();
+ Primitive_GC_If_Needed(STATE_POINT_SIZE+STATE_SPACE_SIZE);
+ New_Point = Make_Pointer(TC_VECTOR, Free);
+ Free[STATE_POINT_HEADER] =
+ Make_Non_Pointer(TC_MANIFEST_VECTOR, STATE_POINT_SIZE-1);
+ Free[STATE_POINT_TAG] = Get_Fixed_Obj_Slot(State_Point_Tag);
+ Free[STATE_POINT_BEFORE_THUNK] = NIL;
+ Free[STATE_POINT_AFTER_THUNK] = NIL;
+ Free[STATE_POINT_NEARER_POINT] = NIL;
+ Free[STATE_POINT_DISTANCE_TO_ROOT] = FIXNUM_0;
+ Free += STATE_POINT_SIZE;
+ if (Arg1 == NIL)
+ { Current_State_Point = New_Point;
+ return NIL;
+ }
+ else
+ { Pointer New_Space = Make_Pointer(TC_VECTOR, Free);
+ Free[STATE_SPACE_HEADER] =
+ Make_Non_Pointer(TC_MANIFEST_VECTOR, STATE_SPACE_SIZE-1);
+ Free[STATE_SPACE_TAG] = Get_Fixed_Obj_Slot(State_Space_Tag);
+ Free[STATE_SPACE_NEAREST_POINT] = New_Point;
+ Free += STATE_SPACE_SIZE;
+ Fast_Vector_Set(New_Point, STATE_POINT_NEARER_POINT, New_Space);
+ return New_Space;
+ }
+}
+\f
+Built_In_Primitive(Prim_Current_Dynamic_State, 1, "CURRENT-DYNAMIC-STATE")
+{ Primitive_1_Arg();
+ guarantee_state_point();
+ if (Arg1 == NIL) return Current_State_Point;
+ Arg_1_Type(TC_VECTOR);
+ if (Fast_Vector_Ref(Arg1, STATE_SPACE_TAG) !=
+ Get_Fixed_Obj_Slot(State_Space_Tag))
+ Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ return Vector_Ref(Arg1, STATE_SPACE_NEAREST_POINT);
+}
+
+Built_In_Primitive(Prim_Set_Dynamic_State, 1, "SET-CURRENT-DYNAMIC-STATE!")
+{ Pointer State_Space, Result;
+ Primitive_1_Arg();
+ Arg_1_Type(TC_VECTOR);
+ if (Fast_Vector_Ref(Arg1, STATE_POINT_TAG) !=
+ Get_Fixed_Obj_Slot(State_Point_Tag))
+ Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ State_Space = Find_State_Space(Arg1);
+ if (State_Space==NIL)
+ { guarantee_state_point();
+ Result = Current_State_Point;
+ Current_State_Point = Arg1;
+ }
+ else
+ { Result = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT);
+ Vector_Set(State_Space, STATE_SPACE_NEAREST_POINT, Arg1);
+ }
+ return Result;
+}
+\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;
+}
+\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
+/* (TRANSLATE_TO_STATE_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 from the current state to
+ the new state as specified by STATE_POINT.
+*/
+Built_In_Primitive(Prim_Translate_To_Point, 1, "TRANSLATE-TO-STATE-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);
+ Translate_To_Point(Arg1);
+ /* This ends by longjmp-ing back to the interpreter */
+}
+
+/* (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
+/* Called with a mask and a thunk */
+
+Built_In_Primitive(Prim_With_Interrupt_Mask, 2, "WITH-INTERRUPT-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);
+}
+
+/* Called with a mask and a thunk */
+
+Built_In_Primitive(Prim_With_Interrupts_Reduced, 2, "WITH-INTERRUPTS-REDUCED")
+{
+ long new_interrupt_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();
+ new_interrupt_mask = (INT_Mask & Get_Integer( Arg1));
+ if (new_interrupt_mask > IntEnb)
+ IntEnb = new_interrupt_mask;
+ else
+ IntEnb = (new_interrupt_mask & IntEnb);
+ 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);
+ Our_Throw(false, Arg1);
+ Within_Stacklet_Backout();
+ Our_Throw_Part_2();
+ 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);
+}
+
--- /dev/null
+/* 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: HUNK.C
+ *
+ * Support for Hunk3s (triples)
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+
+/* (HUNK3_CONS FIRST SECOND THIRD)
+ [Primitive number 0x28]
+ Returns a triple consisting of the specified values.
+*/
+Built_In_Primitive(Prim_Hunk3_Cons, 3, "HUNK3-CONS")
+{ Primitive_3_Args();
+ Primitive_GC_If_Needed(3);
+ *Free++ = Arg1;
+ *Free++ = Arg2;
+ *Free++ = Arg3;
+ return Make_Pointer(TC_HUNK3, Free-3);
+}
+\f
+/* (HUNK3_CXR TRIPLE N)
+ [Primitive number 0x29]
+ Returns the Nth item from the TRIPLE. N must be 0, 1, or 2.
+*/
+Built_In_Primitive(Prim_Hunk3_Cxr, 2, "HUNK3-CXR")
+{ long Offset;
+ Primitive_2_Args();
+ Arg_1_Type(TC_HUNK3);
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE);
+ return Vector_Ref(Arg1, Offset);
+}
+
+/* (HUNK3_SET_CXR TRIPLE N VALUE)
+ [Primitive number 0x2A]
+ Stores VALUE in the Nth item of TRIPLE. N must be 0, 1, or 2.
+ Returns (not good style to count on this) the previous contents.
+*/
+Built_In_Primitive(Prim_Hunk3_Set_Cxr, 3, "HUNK3-SET-CXR!")
+{ long Offset;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_HUNK3);
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE);
+ Side_Effect_Impurify(Arg1, Arg3);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, Offset), Arg3);
+}
+\f
+/* (SYS_H3_0 GC-TRIPLE)
+ [Primitive number 0x8E]
+ Returns item 0 (the first item) from any object with a GC type
+ of triple. For example, this would access the operator slot of
+ a COMBINATION_2_OPERAND SCode item.
+*/
+Built_In_Primitive(Prim_Sys_H3_0, 1, "SYSTEM-HUNK3-CXR0")
+{ Primitive_1_Arg();
+ Arg_1_GC_Type(GC_Triple);
+ return Vector_Ref(Arg1, 0);
+}
+
+/* (SYS_H3_1 GC-TRIPLE)
+ [Primitive number 0x91]
+ Returns item 1 (the second item) from any object with a GC type
+ of triple. For example, this would access the first operand
+ slot of a COMBINATION_2_OPERAND SCode item.
+*/
+Built_In_Primitive(Prim_Sys_H3_1, 1, "SYSTEM-HUNK3-CXR1")
+{ Primitive_1_Arg();
+ Arg_1_GC_Type(GC_Triple);
+ return Vector_Ref(Arg1, 1);
+}
+
+/* (SYS_H3_2 GC-TRIPLE)
+ [Primitive number 0x94]
+ Returns item 2 (the third item) from any object with a GC type
+ of triple. For example, this would access the second operand
+ slot of a COMBINATION_2_OPERAND SCode item.
+*/
+Built_In_Primitive(Prim_Sys_H3_2, 1, "SYSTEM-HUNK3-CXR2")
+{ Primitive_1_Arg();
+ Arg_1_GC_Type(GC_Triple);
+ return Vector_Ref(Arg1, 2);
+}
+\f
+/* (SYS_H3_SET_0 GC-TRIPLE NEW-CONTENTS)
+ [Primitive number 0x8F]
+ Replaces item 0 (the first item) in any object with a GC type of
+ triple with NEW-CONTENTS. For example, this would modify the
+ operator slot of a COMBINATION_2_OPERAND SCode item. Returns
+ (bad style to rely on this) the previous contents.
+*/
+Built_In_Primitive(Prim_SH3_Set_0, 2, "SYSTEM-HUNK3-SET-CXR0!")
+{ Primitive_2_Args();
+ Arg_1_GC_Type(GC_Triple);
+
+ Side_Effect_Impurify(Arg1, Arg2);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, 0), Arg2);
+}
+
+/* (SYS_H3_SET_1 GC-TRIPLE NEW-CONTENTS)
+ [Primitive number 0x92]
+ Replaces item 1 (the second item) in any object with a GC type
+ of triple with NEW-CONTENTS. For example, this would modify the
+ first operand slot of a COMBINATION_2_OPERAND SCode item.
+ Returns (bad style to rely on this) the previous contents.
+*/
+Built_In_Primitive(Prim_SH3_Set_1, 2, "SYSTEM-HUNK3-SET-CXR1!")
+{ Primitive_2_Args();
+ Arg_1_GC_Type(GC_Triple);
+
+ Side_Effect_Impurify(Arg1, Arg2);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, 1), Arg2);
+}
+\f
+/* (SYS_H3_SET_2 GC-TRIPLE NEW-CONTENTS)
+ [Primitive number 0x95]
+ Replaces item 2 (the third item) in any object with a GC type of
+ triple with NEW-CONTENTS. For example, this would modify the
+ second operand slot of a COMBINATION_2_OPERAND SCode item.
+ Returns (bad style to rely on this) the previous contents.
+*/
+Built_In_Primitive(Prim_SH3_Set_2, 2, "SYSTEM-HUNK3-SET-CXR2!")
+{ Primitive_2_Args();
+ Arg_1_GC_Type(GC_Triple);
+
+ Side_Effect_Impurify(Arg1, Arg2);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, 2), Arg2);
+}
+
--- /dev/null
+/* -*- C -*- */
+#include "scheme.h"
+#include "primitive.h"
+#include "flonum.h"
+#include "array.h"
+#include <math.h>
+
+/* IMAGE PROCESSING... */
+/* (much comes from array.c) */
+
+Define_Primitive(Prim_Read_Image_From_Ascii_File, 1, "READ-IMAGE-FROM-ASCII-FILE")
+{ long Length, int_pixel_value1, int_pixel_value2, i, j;
+ long nrows, ncols, array_index;
+ FILE *fopen(), *fp;
+ char *file_string;
+ REAL *To_Here;
+ REAL *From_Here_1, *From_Here_2;
+ Pointer Result, Array_Data_Result, *Orig_Free;
+ int Error_Number;
+ long allocated_cells;
+ Boolean Open_File();
+
+ Primitive_1_Args();
+ Arg_1_Type(TC_CHARACTER_STRING);
+
+ if (!(Open_File(Arg1, "r", &fp))) Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ fscanf(fp, "%d %d \n", &nrows, &ncols);
+ if ((ncols > 512) || (nrows>512)) {
+ printf("read-image-ascii-file: ncols, nrows must be <= 512\n");
+ return(NIL);
+ }
+ Length = nrows * ncols;
+ printf("nrows is %d \n", nrows);
+ printf("ncols is %d \n", ncols);
+ printf("Reading data file ...\n");
+
+ /* ALLOCATE SPACE */
+ Primitive_GC_If_Needed(6);
+ Orig_Free = Free;
+ Free += 6;
+ Result = Make_Pointer(TC_LIST, Orig_Free);
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
+ *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
+ Orig_Free++;
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
+ *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
+ Orig_Free++;
+
+ /* Allocate_Array(Array_Data_Result, Length, allocated_cells); */
+ allocated_cells = (Length*REAL_SIZE) + ARRAY_HEADER_SIZE;
+ Primitive_GC_If_Needed(allocated_cells);
+ Array_Data_Result = Make_Pointer(TC_ARRAY, Free);
+ Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
+ Free[ARRAY_LENGTH] = Length;
+ Free = Free+allocated_cells;
+
+ *Orig_Free++ = Array_Data_Result;
+ *Orig_Free = NIL;
+ /* END ALLOCATION */
+
+ To_Here = Scheme_Array_To_C_Array(Array_Data_Result);
+
+ for (i=0; i<Length; i++)
+ { fscanf( fp, "%d%d", &int_pixel_value1, &int_pixel_value2);
+ *To_Here++ = ((REAL) int_pixel_value1);
+ *To_Here++ = ((REAL) int_pixel_value2); /* faster reading ? */
+ }
+ printf("File read. Length is %d \n", i);
+ Close_File(fp);
+
+ return Result;
+}
+\f
+Define_Primitive(Prim_Read_Image_From_Cbin_File, 1, "READ-IMAGE-FROM-CBIN-FILE")
+{ long Length, i,j;
+ long nrows, ncols, array_index;
+ FILE *fopen(), *fp;
+ char *file_string;
+ REAL *To_Here;
+ Pointer Result, Array_Data_Result, *Orig_Free;
+ int Error_Number;
+ long allocated_cells;
+ Boolean Open_File();
+
+ Primitive_1_Args();
+ Arg_1_Type(TC_CHARACTER_STRING);
+
+ if (!(Open_File(Arg1, "r", &fp))) Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ if (feof(fp)!=0) { printf("Datafile is empty!"); return NIL; }
+ nrows = getw(fp); ncols = getw(fp);
+ Length = nrows * ncols;
+
+ /* ALLOCATE SPACE */
+ Primitive_GC_If_Needed(6);
+ Orig_Free = Free;
+ Free += 6;
+ Result = Make_Pointer(TC_LIST, Orig_Free);
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
+ *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
+ Orig_Free++;
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
+ *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
+ Orig_Free++;
+ Allocate_Array(Array_Data_Result, Length, allocated_cells);
+ *Orig_Free++ = Array_Data_Result;
+ *Orig_Free = NIL;
+ /* END ALLOCATION */
+
+ To_Here = Scheme_Array_To_C_Array(Array_Data_Result);
+
+ /* READING IN BIN int FORMAT */
+ for (i=0;i<Length;i++) {
+ if (feof(fp)!=0) { printf("not enough values read, last read i-1 %d , value %d\n", (i-1), *(To_Here-1));
+ return NIL; }
+ *To_Here++ = ((REAL) getw(fp));
+ }
+
+ Close_File(fp);
+ return Result;
+}
+\f
+Define_Primitive(Prim_Read_Image_From_CTSCAN_File, 1, "READ-IMAGE-FROM-CTSCAN-FILE")
+{ long Length, i,j;
+ long nrows, ncols, array_index;
+ FILE *fopen(), *fp;
+ char *file_string;
+ REAL *Array;
+ Pointer Result, Array_Data_Result, *Orig_Free;
+ int Error_Number;
+ long allocated_cells;
+ Boolean Open_File();
+
+ Primitive_1_Args();
+ Arg_1_Type(TC_CHARACTER_STRING);
+
+ if (!(Open_File(Arg1, "r", &fp))) Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ if (feof(fp)!=0) { printf("Datafile is empty!"); return NIL; }
+ nrows = 512; ncols = 512;
+ Length = nrows * ncols;
+
+ /* ALLOCATE SPACE */
+ Primitive_GC_If_Needed(6);
+ Orig_Free = Free;
+ Free += 6;
+ Result = Make_Pointer(TC_LIST, Orig_Free);
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
+ *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
+ Orig_Free++;
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
+ *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
+ Orig_Free++;
+ Allocate_Array(Array_Data_Result, Length, allocated_cells);
+ *Orig_Free++ = Array_Data_Result;
+ *Orig_Free = NIL;
+ /* END ALLOCATION */
+
+ Array = Scheme_Array_To_C_Array(Array_Data_Result);
+ Image_Read_From_CTSCAN_File(fp,Array,nrows,ncols);
+ Close_File(fp);
+ return Result;
+}
+\f
+Image_Read_From_CTSCAN_File(fp,Array,nrows,ncols)
+ FILE *fp; REAL *Array; long nrows,ncols;
+{ int i,m;
+ long Length=nrows*ncols;
+ int first_header_bytes = 2048;
+ int second_header_bytes = 3150-(2048+1024);
+ int word1, word2;
+ long number;
+ int *Widths;
+ char ignore;
+ REAL *Temp_Row;
+ int array_index;
+
+ Primitive_GC_If_Needed(512); /* INTEGER_SIZE is = 1 scheme pointer */
+ Widths = ((int *) Free);
+ for (i=0;i<first_header_bytes;i++) ignore = getc(fp);
+ for (i = 0; i<512; i++) {
+ word1 = ((int) getc(fp));
+ word2 = ((int) getc(fp));
+ number = ((word1<<8) | word2); /* bitwise inclusive or */
+ Widths[i] = number; /* THESE ARE HALF THE NROW-WIDTHs ! */
+ }
+
+ for (i=0;i<Length;i++) Array[i] = 0; /* initialize with zeros */
+
+ for (i = 0; i<512; i++) {
+ array_index = i*512 + (256-Widths[i]); /* note the offset */
+ for (m=array_index; m<(array_index + 2*Widths[i]); m++) {
+ word1 = ((int) getc(fp)); word2 = ((int) getc(fp));
+ number = ((word1<<8) | word2); /* bitwise inclusive or */
+ Array[m] = ((REAL) number); /* do I need to explicitly sign-extend? */
+ }
+ }
+ Primitive_GC_If_Needed(512*REAL_SIZE);
+ Temp_Row = ((REAL *) Free);
+ Image_Mirror_Upside_Down(Array,nrows,ncols,Temp_Row); /* CTSCAN images are upside down */
+}
+\f
+Image_Mirror_Upside_Down(Array,nrows,ncols,Temp_Row)
+ REAL *Array, *Temp_Row; long nrows,ncols;
+{ int i;
+ REAL *M_row, *N_row;
+ for (i=0;i<(nrows/2);i++) {
+ M_row = Array + (i * ncols);
+ N_row = Array + (((nrows-1)-i) * ncols);
+ C_Array_Copy(N_row, Temp_Row, ncols);
+ C_Array_Copy(M_row, N_row, ncols);
+ C_Array_Copy(Temp_Row, M_row, ncols);
+ }
+}
+\f
+Define_Primitive(Prim_Subimage, 5, "SUBIMAGE")
+{ long Length, new_Length;
+ long i,j;
+ Pointer Pnrows, Pncols, Prest, Parray;
+ long lrow, hrow, lcol, hcol;
+ long nrows, ncols, new_nrows, new_ncols;
+
+ REAL *Array, *To_Here;
+ Pointer Result, Array_Data_Result, *Orig_Free;
+ int Error_Number;
+ long allocated_cells;
+
+ Primitive_5_Args();
+ Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
+ Pnrows = Vector_Ref(Arg1, CONS_CAR);
+ Prest = Vector_Ref(Arg1, CONS_CDR);
+ Pncols = Vector_Ref(Prest, CONS_CAR);
+ Prest = Vector_Ref(Prest, CONS_CDR);
+ Parray = Vector_Ref(Prest, CONS_CAR);
+ if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+
+ Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
+ Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
+
+ Range_Check(lrow, Arg2, 0, nrows, ERR_ARG_2_BAD_RANGE);
+ Range_Check(hrow, Arg3, lrow, nrows, ERR_ARG_3_BAD_RANGE);
+ Range_Check(lcol, Arg4, 0, ncols, ERR_ARG_4_BAD_RANGE);
+ Range_Check(hcol, Arg5, lcol, ncols, ERR_ARG_5_BAD_RANGE);
+ new_nrows = hrow - lrow +1;
+ new_ncols = hcol - lcol +1;
+ new_Length = new_nrows * new_ncols;
+
+ /* ALLOCATE SPACE */
+ Primitive_GC_If_Needed(6);
+ Orig_Free = Free;
+ Free += 6;
+ Result = Make_Pointer(TC_LIST, Orig_Free);
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, new_nrows);
+ *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
+ Orig_Free++;
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, new_ncols);
+ *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
+ Orig_Free++;
+ Allocate_Array(Array_Data_Result, new_Length, allocated_cells);
+ *Orig_Free++ = Array_Data_Result;
+ *Orig_Free = NIL;
+ /* END ALLOCATION */
+
+ Array = Scheme_Array_To_C_Array(Parray);
+ To_Here = Scheme_Array_To_C_Array(Array_Data_Result);
+ for (i=lrow; i<=hrow; i++) {
+ for (j=lcol; j<=hcol; j++) {
+ *To_Here++ = Array[i*ncols+j]; /* A(i,j)--->Array[i*ncols+j] */
+ }}
+
+ return Result;
+}
+\f
+Define_Primitive(Prim_Image_Double_To_Float, 1, "IMAGE-DOUBLE-TO-FLOAT!")
+{ long Length;
+ long i,j;
+ long nrows, ncols;
+ long allocated_cells;
+ double *Array, *From_Here;
+ register double temp_value_cell;
+ float *To_Here;
+ int Error_Number;
+ Pointer Pnrows,Pncols,Parray,Prest;
+
+ Primitive_1_Args();
+ Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
+ Pnrows = Vector_Ref(Arg1, CONS_CAR);
+ Prest = Vector_Ref(Arg1, CONS_CDR);
+ Pncols = Vector_Ref(Prest, CONS_CAR);
+ Prest = Vector_Ref(Prest, CONS_CDR);
+ Parray = Vector_Ref(Prest, CONS_CAR);
+ if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+
+ Range_Check(nrows, Pnrows, 0, 2048, ERR_ARG_1_BAD_RANGE);
+ Range_Check(ncols, Pncols, 0, 2048, ERR_ARG_1_BAD_RANGE);
+
+ Array = ((double *) (Nth_Vector_Loc(Parray, ARRAY_DATA)));
+ From_Here = Array;
+ To_Here = ((float *) (Array));
+ Length = nrows * ncols;
+
+ for (i=0;i<Length;i++) {
+ temp_value_cell = *From_Here;
+ From_Here++;
+ *To_Here = ((float) temp_value_cell);
+ To_Here++;
+ }
+
+ /* and now SIDE-EFFECT the ARRAY_HEADER */
+ allocated_cells = (Length *
+ ((sizeof(Pointer)+sizeof(float)-1) / sizeof(Pointer)) +
+ ARRAY_HEADER_SIZE);
+ *(Nth_Vector_Loc(Parray, ARRAY_HEADER)) =
+ Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
+ /* see array.h to understand the above */
+
+ return Arg1;
+}
+\f
+Define_Primitive(Prim_Image_Set_Row, 3, "IMAGE-SET-ROW!")
+{ long Length, i,j;
+ Pointer Pnrows, Pncols, Prest, Parray;
+ long nrows, ncols, row_to_set;
+ REAL *Array, *Row_Array;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
+ Pnrows = Vector_Ref(Arg1, CONS_CAR);
+ Prest = Vector_Ref(Arg1, CONS_CDR);
+ Pncols = Vector_Ref(Prest, CONS_CAR);
+ Prest = Vector_Ref(Prest, CONS_CDR);
+ Parray = Vector_Ref(Prest, CONS_CAR);
+ if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+
+ Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
+ Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
+
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(row_to_set, Arg2, 0, (nrows-1), ERR_ARG_2_BAD_RANGE);
+ Arg_3_Type(TC_ARRAY);
+ Row_Array = Scheme_Array_To_C_Array(Arg3);
+ if (Array_Length(Arg3)>ncols) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+
+ Array = Scheme_Array_To_C_Array(Parray);
+ C_Image_Set_Row(Array, row_to_set, Row_Array, nrows, ncols);
+ return Arg1;
+}
+\f
+Define_Primitive(Prim_Image_Set_Column, 3, "IMAGE-SET-COLUMN!")
+{ long Length, i,j;
+ Pointer Pnrows, Pncols, Prest, Parray;
+ long nrows, ncols, col_to_set;
+ REAL *Array, *Col_Array;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
+ Pnrows = Vector_Ref(Arg1, CONS_CAR);
+ Prest = Vector_Ref(Arg1, CONS_CDR);
+ Pncols = Vector_Ref(Prest, CONS_CAR);
+ Prest = Vector_Ref(Prest, CONS_CDR);
+ Parray = Vector_Ref(Prest, CONS_CAR);
+ if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+
+ Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
+ Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
+
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(col_to_set, Arg2, 0, (nrows-1), ERR_ARG_2_BAD_RANGE);
+ Arg_3_Type(TC_ARRAY);
+ Col_Array = Scheme_Array_To_C_Array(Arg3);
+ if (Array_Length(Arg3)>ncols) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+
+ Array = Scheme_Array_To_C_Array(Parray);
+ C_Image_Set_Col(Array, col_to_set, Col_Array, nrows, ncols);
+ return Arg1;
+}
+\f
+C_Image_Set_Row(Image_Array, row_to_set, Row_Array, nrows, ncols) REAL *Image_Array, *Row_Array;
+long nrows, ncols, row_to_set;
+{ long j;
+ REAL *From_Here, *To_Here;
+
+ To_Here = &Image_Array[row_to_set*ncols];
+ From_Here = Row_Array;
+ for (j=0;j<ncols;j++)
+ *To_Here++ = *From_Here++;
+}
+\f
+C_Image_Set_Col(Image_Array, col_to_set, Col_Array, nrows, ncols) REAL *Image_Array, *Col_Array;
+long nrows, ncols, col_to_set;
+{ long i;
+ REAL *From_Here, *To_Here;
+
+ To_Here = &Image_Array[col_to_set];
+ From_Here = Col_Array;
+ for (i=0;i<nrows;i++) {
+ *To_Here = *From_Here++;
+ To_Here += nrows;
+ }
+}
+
+\f
+Define_Primitive(Prim_Image_Make_Ring, 4, "IMAGE-MAKE-RING")
+{ long Length, i,j;
+ long nrows, ncols;
+ long Min_Cycle=0, Max_Cycle=min((nrows/2),(ncols/2));
+ long low_cycle, high_cycle;
+ REAL *Ring_Array;
+ Pointer Result, Ring_Array_Result, *Orig_Free;
+ long allocated_cells;
+
+ Primitive_4_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Range_Check(nrows, Arg1, 0, 512, ERR_ARG_1_BAD_RANGE);
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(ncols, Arg2, 0, 512, ERR_ARG_2_BAD_RANGE);
+ Length = nrows*ncols;
+ Arg_3_Type(TC_FIXNUM);
+ Range_Check(low_cycle, Arg3, Min_Cycle, Max_Cycle, ERR_ARG_2_BAD_RANGE);
+ Arg_4_Type(TC_FIXNUM);
+ Range_Check(high_cycle, Arg4, Min_Cycle, Max_Cycle, ERR_ARG_3_BAD_RANGE);
+ if (high_cycle<low_cycle) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+\f
+ /* ALLOCATE SPACE */
+ Primitive_GC_If_Needed(6);
+ Orig_Free = Free;
+ Free += 6;
+ Result = Make_Pointer(TC_LIST, Orig_Free);
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
+ *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
+ Orig_Free++;
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
+ *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
+ Orig_Free++;
+ Allocate_Array(Ring_Array_Result, Length, allocated_cells);
+ *Orig_Free++ = Ring_Array_Result;
+ *Orig_Free = NIL;
+ /* END ALLOCATION */
+
+ Ring_Array = Scheme_Array_To_C_Array(Ring_Array_Result);
+ C_Image_Make_Ring(Ring_Array, nrows, ncols, low_cycle, high_cycle);
+ return Result;
+}
+\f
+C_Image_Make_Ring(Ring_Array, nrows, ncols, low_cycle, high_cycle) REAL *Ring_Array;
+long nrows, ncols, low_cycle, high_cycle;
+{ long Square_LC=low_cycle*low_cycle, Square_HC=high_cycle*high_cycle;
+ long i, j, m, n, radial_cycle;
+ long nrows2=nrows/2, ncols2=ncols/2;
+ for (i=0; i<nrows; i++) {
+ for (j=0; j<ncols; j++) {
+ m = ((i<nrows2) ? i : (nrows-i));
+ n = ((j<ncols2) ? j : (ncols-j));
+ radial_cycle = (m*m)+(n*n);
+ if ( (radial_cycle<Square_LC) || (radial_cycle>Square_HC))
+ Ring_Array[i*ncols+j] = 0;
+ else Ring_Array[i*ncols+j] = 1;
+ }}
+}
+
+\f
+/* DONE WITHOUT SIDE-EFFECTS FOR SIMPLICITY */
+Define_Primitive(Prim_Image_Periodic_Shift, 3, "IMAGE-PERIODIC-SHIFT")
+{ long Length, i,j;
+ Pointer Pnrows, Pncols, Prest, Parray;
+ long nrows, ncols;
+ long hor_shift, ver_shift;
+ REAL *Array, *New_Array;
+ Pointer Result, Array_Data_Result, *Orig_Free;
+ long allocated_cells;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
+ Pnrows = Vector_Ref(Arg1, CONS_CAR);
+ Prest = Vector_Ref(Arg1, CONS_CDR);
+ Pncols = Vector_Ref(Prest, CONS_CAR);
+ Prest = Vector_Ref(Prest, CONS_CDR);
+ Parray = Vector_Ref(Prest, CONS_CAR);
+ if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+
+ Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
+ Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
+ Length = nrows*ncols;
+
+ Arg_2_Type(TC_FIXNUM);
+ Sign_Extend(Arg2, ver_shift);
+ ver_shift = ver_shift % nrows;
+ Arg_3_Type(TC_FIXNUM);
+ Sign_Extend(Arg3, hor_shift);
+ hor_shift = hor_shift % ncols;
+\f
+ /* ALLOCATE SPACE */
+ Primitive_GC_If_Needed(6);
+ Orig_Free = Free;
+ Free += 6;
+ Result = Make_Pointer(TC_LIST, Orig_Free);
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
+ *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
+ Orig_Free++;
+ *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
+ *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
+ Orig_Free++;
+ Allocate_Array(Array_Data_Result, Length, allocated_cells);
+ *Orig_Free++ = Array_Data_Result;
+ *Orig_Free = NIL;
+ /* END ALLOCATION */
+
+ Array = Scheme_Array_To_C_Array(Parray);
+ New_Array = Scheme_Array_To_C_Array(Array_Data_Result);
+ C_Image_Periodic_Shift(Array, New_Array, nrows, ncols, ver_shift, hor_shift);
+ return Result;
+}
+\f
+/* ASSUMES hor_shift<nrows, ver_shift<ncols */
+C_Image_Periodic_Shift(Array, New_Array, nrows, ncols, ver_shift, hor_shift)
+ REAL *Array, *New_Array; long nrows, ncols, hor_shift, ver_shift;
+{ long i, j, ver_index, hor_index;
+ REAL *To_Here;
+ To_Here = New_Array;
+ for (i=0;i<nrows;i++) {
+ for (j=0;j<ncols;j++) {
+ ver_index = (i+ver_shift) % nrows;
+ if (ver_index<0) ver_index = nrows-ver_index; /* wrapping around */
+ hor_index = (j+hor_shift) % ncols;
+ if (hor_index<0) hor_index = ncols-hor_index;
+ *To_Here++ = Array[ver_index*ncols + hor_index];
+ }}
+}
+
+\f
+/* ROTATIONS..... */
+
+Define_Primitive(Prim_Image_Transpose, 1, "IMAGE-TRANSPOSE!")
+{ long Length;
+ Pointer Pnrows, Pncols, Prest, Parray;
+ long nrows, ncols;
+ REAL *Array, *Temp_Array;
+
+ Primitive_1_Args();
+ Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
+
+ Pnrows = Vector_Ref(Arg1, CONS_CAR);
+ Prest = Vector_Ref(Arg1, CONS_CDR);
+ Pncols = Vector_Ref(Prest, CONS_CAR);
+ Prest = Vector_Ref(Prest, CONS_CDR);
+ Parray = Vector_Ref(Prest, CONS_CAR);
+ if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+
+ Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
+ Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
+
+ Array = Scheme_Array_To_C_Array(Parray);
+
+ if (nrows==ncols) {
+ Image_Fast_Transpose(Array, nrows); /* side-effecting ... */
+ }
+ else {
+ REAL *New_Array;
+ long Length=nrows*ncols;
+ Primitive_GC_If_Needed(Length*REAL_SIZE); /* making space in scheme heap */
+ New_Array = ((REAL *) Free);
+ Image_Transpose(Array, New_Array, nrows, ncols);
+ C_Array_Copy(New_Array, Array, Length);
+ }
+
+ Vector_Set(Arg1, CONS_CAR, Make_Pointer(TC_FIXNUM, ncols) ); /* swithing nrows, ncols */
+ Prest = Vector_Ref(Arg1, CONS_CDR);
+ Vector_Set(Prest, CONS_CAR, Make_Pointer(TC_FIXNUM, nrows) );
+ return Arg1;
+}
+\f
+Define_Primitive(Prim_Image_Rotate_90clw, 1, "IMAGE-ROTATE-90CLW!")
+{ long Length;
+ Pointer Pnrows, Pncols, Prest, Parray;
+ long nrows, ncols;
+ REAL *Array, *Temp_Array;
+
+ Primitive_1_Args();
+ Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
+
+ Pnrows = Vector_Ref(Arg1, CONS_CAR);
+ Prest = Vector_Ref(Arg1, CONS_CDR);
+ Pncols = Vector_Ref(Prest, CONS_CAR);
+ Prest = Vector_Ref(Prest, CONS_CDR);
+ Parray = Vector_Ref(Prest, CONS_CAR);
+ if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+
+ Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
+ Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
+ Length = nrows*ncols;
+
+ Primitive_GC_If_Needed(Length*REAL_SIZE);
+ Temp_Array = ((REAL *) Free);
+ Array = Scheme_Array_To_C_Array(Parray);
+ Image_Rotate_90clw(Array, Temp_Array, nrows, ncols);
+ C_Array_Copy(Temp_Array, Array, Length);
+
+ Vector_Set(Arg1, CONS_CAR, Make_Pointer(TC_FIXNUM, ncols) ); /* swithing nrows, ncols */
+ Prest = Vector_Ref(Arg1, CONS_CDR);
+ Vector_Set(Prest, CONS_CAR, Make_Pointer(TC_FIXNUM, nrows) );
+ return Arg1;
+}
+\f
+Define_Primitive(Prim_Image_Rotate_90cclw, 1, "IMAGE-ROTATE-90CCLW!")
+{ long Length;
+ Pointer Pnrows, Pncols, Prest, Parray;
+ long nrows, ncols;
+ REAL *Array, *Temp_Array;
+
+ Primitive_1_Args();
+ Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
+
+ Pnrows = Vector_Ref(Arg1, CONS_CAR);
+ Prest = Vector_Ref(Arg1, CONS_CDR);
+ Pncols = Vector_Ref(Prest, CONS_CAR);
+ Prest = Vector_Ref(Prest, CONS_CDR);
+ Parray = Vector_Ref(Prest, CONS_CAR);
+ if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+
+ Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
+ Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
+ Length = nrows*ncols;
+
+ Primitive_GC_If_Needed(Length*REAL_SIZE);
+ Temp_Array = ((REAL *) Free);
+ Array = Scheme_Array_To_C_Array(Parray);
+ Image_Rotate_90cclw(Array, Temp_Array, nrows, ncols);
+ C_Array_Copy(Temp_Array, Array, Length);
+
+ Vector_Set(Arg1, CONS_CAR, Make_Pointer(TC_FIXNUM, ncols) ); /* swithing nrows, ncols */
+ Prest = Vector_Ref(Arg1, CONS_CDR);
+ Vector_Set(Prest, CONS_CAR, Make_Pointer(TC_FIXNUM, nrows) );
+ return Arg1;
+}
+\f
+Define_Primitive(Prim_Image_Mirror, 1, "IMAGE-MIRROR!")
+{ long Length;
+ Pointer Pnrows, Pncols, Prest, Parray;
+ long nrows, ncols;
+ REAL *Array, *Temp_Array;
+
+ Primitive_1_Args();
+ Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
+
+ Pnrows = Vector_Ref(Arg1, CONS_CAR);
+ Prest = Vector_Ref(Arg1, CONS_CDR);
+ Pncols = Vector_Ref(Prest, CONS_CAR);
+ Prest = Vector_Ref(Prest, CONS_CDR);
+ Parray = Vector_Ref(Prest, CONS_CAR);
+ if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+
+ Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
+ Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
+ Length = nrows*ncols;
+
+ Array = Scheme_Array_To_C_Array(Parray);
+ C_Mirror_Image(Array, nrows, ncols); /* side-effecting... */
+
+ return Arg1;
+}
+\f
+
+/* THE C ROUTINES THAT DO THE REAL WORK */
+
+/*
+ IMAGE_FAST_TRANSPOSE
+ A(i,j) <-> A(j,i) .
+ UNWRAP: A(i,j) ----> Array[i*ncols + j] convention:= fix row & go by columns .
+ UNWRAP is a bijection from the compact plane to the compact interval.
+ */
+Image_Fast_Transpose(Array, nrows) /* for square images */
+ REAL *Array; long nrows;
+{ long i, j;
+ long from, to;
+ REAL temp;
+ for (i=0;i<nrows;i++) {
+ for (j=i;j<nrows;j++) {
+ from = i*nrows + j;
+ to = j*nrows + i; /* (columns transposed-image) = ncols */
+ temp = Array[from];
+ Array[from] = Array[to];
+ Array[to] = temp;
+ }}
+}
+\f
+/*
+ IMAGE_TRANSPOSE
+ A(i,j) -> B(j,i) .
+ UNWRAP: A(i,j) ----> Array[i*ncols + j] convention:= fix row & go by columns .
+ UNWRAP is a bijection from the compact plane to the compact interval.
+ */
+Image_Transpose(Array, New_Array, nrows, ncols)
+ REAL *Array, *New_Array; long nrows, ncols;
+{ long i, j;
+ for (i=0;i<nrows;i++) {
+ for (j=0;j<ncols;j++) {
+ New_Array[j*nrows + i] = Array[i*ncols + j]; /* (columns transposed-image) = nrows */
+ }}
+}
+\f
+/*
+ IMAGE_ROTATE_90CLW
+ A(i,j) <-> A(j, (nrows-1)-i) .
+ UNWRAP: A(i,j) ----> Array[i*ncols + j] convention:= fix row & go by columns
+ UNWRAP is a bijection from the compact plane to the compact interval.
+ */
+Image_Rotate_90clw(Array, Rotated_Array, nrows, ncols)
+ REAL *Array, *Rotated_Array; long nrows, ncols;
+{ long i, j;
+
+ for (i=0;i<nrows;i++) {
+ for (j=0;j<ncols;j++) {
+ Rotated_Array[(j*nrows) + ((nrows-1)-i)] = Array[i*ncols+j]; /* (columns rotated_image) =nrows */
+ }}
+}
+\f
+/*
+ ROTATION 90degrees COUNTER-CLOCK-WISE:
+ A(i,j) <-> A((nrows-1)-j, i) . (minus 1 because we start from 0).
+ UNWRAP: A(i,j) ----> Array[i*ncols + j] because of convention:= fix row & go by columns
+ UNWRAP is a bijection from the compact plane to the compact interval.
+ */
+Image_Rotate_90cclw(Array, Rotated_Array, nrows, ncols)
+ REAL *Array, *Rotated_Array; long nrows, ncols;
+{ long i, j;
+ register long from_index, to_index;
+ long Length=nrows*ncols;
+ for (i=0;i<nrows;i++) {
+ for (j=0;j<ncols;j++) {
+ from_index = i*ncols +j;
+ to_index = ((ncols-1)-j)*nrows + i; /* (columns rotated-image) = nrows */
+ Rotated_Array[to_index] = Array[from_index];
+ }}
+}
+\f
+/*
+ IMAGE_MIRROR:
+ A(i,j) <-> A(i, (ncols-1)-j) [ The -1 is there because we count from 0] .
+ A(i,j) -------> Array[i*ncols + j] fix row, read column convention.
+ */
+C_Mirror_Image(Array, nrows, ncols) REAL *Array; long nrows, ncols;
+{ long i, j;
+ long ncols2=ncols/2, Length=nrows*ncols;
+ REAL temp;
+ long from, to;
+
+ for (i=0; i<Length; i += ncols) {
+ for (j=0; j<ncols2; j++) { /* DO NOT UNDO the reflections */
+ from = i + j; /* i is really i*nrows */
+ to = i + (ncols-1)-j;
+ temp = Array[from];
+ Array[from] = Array[to];
+ Array[to] = temp;
+ }}
+}
+
+
+\f
+/*
+ IMAGE_ROTATE_90CLW_MIRROR:
+ A(i,j) <-> A(j, i) this should be identical to image_transpose (see above).
+ UNWRAP: A(i,j) ----> Array[i*ncols + j] because of convention:= fix row & go by columns
+ UNWRAP is a bijection from the compact plane to the compact interval.
+ */
+C_Rotate_90clw_Mirror_Image(Array, Rotated_Array, nrows, ncols)
+ REAL *Array, *Rotated_Array; long nrows, ncols;
+{ long i, j;
+ long from, to, Length=nrows*ncols;
+
+ for (i=0;i<nrows;i++) {
+ for (j=0;j<ncols;j++) {
+ from = i*ncols +j;
+ to = j*nrows +i; /* the columns of the rotated image are nrows! */
+ Rotated_Array[to] = Array[from];
+ }}
+}
+\f
+
+
+
+
+/* END */
+
+
+
+
+
+
+/*
+\f
+Define_Primitive(Prim_Sample_Periodic_2d_Function, 4, "SAMPLE-PERIODIC-2D-FUNCTION")
+{ long N, i, allocated_cells, Function_Number;
+ REAL Signal_Frequency, Sampling_Frequency, DT, DTi;
+ REAL twopi = 6.28318530717958, twopi_f_dt;
+ Pointer Result, Pfunction_number, Psignal_frequency;
+ Pointer Pfunction_Number;
+ int Error_Number;
+ REAL *To_Here, unit_square_wave(), unit_triangle_wave();
+
+ Primitive_4_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Arg_4_Type(TC_FIXNUM);
+ Range_Check(Function_Number, Arg1, 0, 10, ERR_ARG_1_BAD_RANGE); / * fix this * /
+
+ Error_Number = Scheme_Number_To_REAL(Arg2, &Signal_Frequency);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ if (Signal_Frequency == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+
+ Error_Number = Scheme_Number_To_REAL(Arg3, &Sampling_Frequency);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
+ if (Sampling_Frequency == 0) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+ DT = (1 / Sampling_Frequency);
+ twopi_f_dt = twopi * Signal_Frequency * DT;
+
+ Range_Check(N, Arg4, 0, ARRAY_MAX_LENGTH, ERR_ARG_4_BAD_RANGE);
+
+ allocated_cells = (N*REAL_SIZE) + ARRAY_HEADER_SIZE;
+ Primitive_GC_If_Needed(allocated_cells);
+
+ Result = Make_Pointer(TC_ARRAY, Free);
+ Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
+ Free[ARRAY_LENGTH] = N;
+ To_Here = Scheme_Array_To_C_Array(Result);
+ Free = Free+allocated_cells;
+
+ DT = twopi_f_dt;
+ if (Function_Number == 0)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = cos(DTi);
+ else if (Function_Number == 1)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = sin(DTi);
+ else if (Function_Number == 2)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = unit_square_wave(DTi);
+ else if (Function_Number == 3)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = unit_triangle_wave(DTi);
+ else
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+
+ return Result;
+}
+
+*/
+/* END IMAGE PROCESSING */
+
+
+\f
+/* Note for the macro: To1 and To2 must BE Length1-1, and Length2-2 RESPECTIVELY ! */
+/*
+#define C_Convolution_Point_Macro(X, Y, To1, To2, N, Result) \
+{ long Min_of_N_To1=min((N),(To1)); \
+ long mi, N_minus_mi; \
+ REAL Sum=0.0; \
+ for (mi=max(0,(N)-(To2)), N_minus_mi=(N)-mi; mi <= Min_of_N_To1; mi++, N_minus_mi--) \
+ Sum += (X[mi] * Y[N_minus_mi]); \
+ (Result)=Sum; \
+}
+\f
+Define_Primitive(Prim_Convolution_Point, 3, "CONVOLUTION-POINT")
+{ long Length1, Length2, N;
+ REAL *Array1, *Array2;
+ REAL C_Result;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_ARRAY);
+ Arg_3_Type(TC_FIXNUM);
+ Length1 = Array_Length(Arg1);
+ Length2 = Array_Length(Arg2);
+ N = Get_Integer(Arg3);
+ Array1 = Scheme_Array_To_C_Array(Arg1);
+ Array2 = Scheme_Array_To_C_Array(Arg2);
+ C_Convolution_Point_Macro(Array1, Array2, Length1-1, Length2-1, N, C_Result);
+ Reduced_Flonum_Result(C_Result);
+}
+\f
+Define_Primitive(Prim_Array_Convolution, 2, "ARRAY-CONVOLUTION")
+{ long Endpoint1, Endpoint2, allocated_cells, i;
+ / * ASSUME A SIGNAL FROM INDEX 0 TO ENDPOINT=LENGTH-1 * /
+ long Resulting_Length;
+ REAL *Array1, *Array2, *To_Here;
+ Pointer Result;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_ARRAY);
+ Endpoint1 = Array_Length(Arg1) - 1;
+ Endpoint2 = Array_Length(Arg2) - 1;
+ Resulting_Length = Endpoint1 + Endpoint2 + 1;
+ Array1 = Scheme_Array_To_C_Array(Arg1);
+ Array2 = Scheme_Array_To_C_Array(Arg2);
+
+ allocated_cells = (Resulting_Length * REAL_SIZE) + ARRAY_HEADER_SIZE;
+ Primitive_GC_If_Needed(allocated_cells);
+ Result = Make_Pointer(TC_ARRAY, Free);
+ Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
+ Free[ARRAY_LENGTH] = Resulting_Length;
+ Free += allocated_cells;
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ for (i=0; i<Resulting_Length; i++) {
+ C_Convolution_Point_Macro(Array1, Array2, Endpoint1, Endpoint2, i, *To_Here);
+ To_Here++;
+ }
+ return Result;
+}
+*/
+
+/* m_pi = 3.14159265358979323846264338327950288419716939937510; */
+
+/*
+Define_Primitive(Prim_Sample_Periodic_Function, 4, "SAMPLE-PERIODIC-FUNCTION")
+{ long N, i, allocated_cells, Function_Number;
+ REAL Signal_Frequency, Sampling_Frequency, DT, DTi;
+ REAL twopi = 6.28318530717958, twopi_f_dt;
+ Pointer Result, Pfunction_number, Psignal_frequency;
+ Pointer Pfunction_Number;
+ int Error_Number;
+ REAL *To_Here, unit_square_wave(), unit_triangle_wave();
+
+ Primitive_4_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Arg_4_Type(TC_FIXNUM);
+ Range_Check(Function_Number, Arg1, 0, 10, ERR_ARG_1_BAD_RANGE); / * fix this * /
+
+ Error_Number = Scheme_Number_To_REAL(Arg2, &Signal_Frequency);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ if (Signal_Frequency == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+
+ Error_Number = Scheme_Number_To_REAL(Arg3, &Sampling_Frequency);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
+ if (Sampling_Frequency == 0) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+ DT = (1 / Sampling_Frequency);
+ twopi_f_dt = twopi * Signal_Frequency * DT;
+
+ Range_Check(N, Arg4, 0, ARRAY_MAX_LENGTH, ERR_ARG_4_BAD_RANGE);
+
+ allocated_cells = (N*REAL_SIZE) + ARRAY_HEADER_SIZE;
+ Primitive_GC_If_Needed(allocated_cells);
+
+ Result = Make_Pointer(TC_ARRAY, Free);
+ Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
+ Free[ARRAY_LENGTH] = N;
+ To_Here = Scheme_Array_To_C_Array(Result);
+ Free = Free+allocated_cells;
+
+ DT = twopi_f_dt;
+ if (Function_Number == 0)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = cos(DTi);
+ else if (Function_Number == 1)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = sin(DTi);
+ else if (Function_Number == 2)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = unit_square_wave(DTi);
+ else if (Function_Number == 3)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = unit_triangle_wave(DTi);
+ else
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+
+ return Result;
+}
+\f
+REAL hamming(t, length) REAL t, length;
+{ REAL twopi = 6.28318530717958;
+ REAL pi = twopi/2.;
+ REAL t_bar = cos(twopi * (t / length));
+ if ((t<length) && (t>0.0)) return(.08 + .46 * (1 - t_bar));
+ else return (0);
+}
+\f
+REAL hanning(t, length) REAL t, length;
+{ REAL twopi = 6.28318530717958;
+ REAL pi = twopi/2.;
+ REAL t_bar = cos(twopi * (t / length));
+ if ((t<length) && (t>0.0))
+ return(.5 * (1 - t_bar));
+ else return (0);
+}
+\f
+REAL unit_square_wave(t) REAL t;
+{ REAL twopi = 6.28318530717958;
+ REAL fmod(), fabs();
+ REAL pi = twopi/2.;
+ REAL t_bar = fabs(fmod(t, twopi));
+ if (t_bar < pi) return(1);
+ else return(0);
+}
+\f
+REAL unit_triangle_wave(t) REAL t;
+{ REAL twopi = 6.28318530717958;
+ REAL pi = twopi/2.;
+ REAL t_bar = fabs(fmod(t, twopi));
+ if (t_bar < pi) return( t_bar / pi );
+ else return( (twopi - t_bar) / pi );
+}
+\f
+Define_Primitive(Prim_Sample_Aperiodic_Function, 3, "SAMPLE-APERIODIC-FUNCTION")
+{ long N, i, allocated_cells, Function_Number;
+ REAL Sampling_Frequency, DT, DTi;
+ REAL twopi = 6.28318530717958;
+ Pointer Result;
+ int Error_Number;
+ REAL *To_Here, twopi_dt;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Arg_3_Type(TC_FIXNUM);
+ Range_Check(Function_Number, Arg1, 0, 6, ERR_ARG_1_BAD_RANGE);
+
+ Error_Number = Scheme_Number_To_REAL(Arg2, &Sampling_Frequency);
+ if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ if (Sampling_Frequency == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ DT = (1 / Sampling_Frequency);
+ twopi_dt = twopi * DT;
+
+ Range_Check(N, Arg3, 0, ARRAY_MAX_LENGTH, ERR_ARG_3_BAD_RANGE);
+
+ allocated_cells = (N*REAL_SIZE) + ARRAY_HEADER_SIZE;
+ Primitive_GC_If_Needed(allocated_cells);
+
+ Result = Make_Pointer(TC_ARRAY, Free);
+ Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
+ Free[ARRAY_LENGTH] = N;
+ To_Here = Scheme_Array_To_C_Array(Result);
+ Free = Free+allocated_cells;
+
+ DT = twopi_dt;
+ if (Function_Number == 0)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = rand();
+ else if (Function_Number == 1)
+ { REAL length=DT*N;
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = hanning(DTi, length);
+ }
+ else if (Function_Number == 2)
+ { REAL length=DT*N;
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = hamming(DTi, length);
+ }
+ else if (Function_Number == 3)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = sqrt(DTi);
+ else if (Function_Number == 4)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = log(DTi);
+ else if (Function_Number == 5)
+ for (i=0, DTi=0.0; i < N; i++, DTi += DT)
+ *To_Here++ = exp(DTi);
+ else
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+
+ return Result;
+}
+\f
+Define_Primitive(Prim_Array_Periodic_Downsample, 2, "ARRAY-PERIODIC-DOWNSAMPLE")
+{ long Length, Pseudo_Length, Sampling_Ratio;
+ REAL *Array, *To_Here;
+ Pointer Result;
+ long allocated_cells, i, array_index;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_FIXNUM);
+ Length = Array_Length(Arg1);
+
+ Sign_Extend(Arg2, Sampling_Ratio); / * Sampling_Ratio = integer ratio of sampling_frequencies * /
+ Sampling_Ratio = Sampling_Ratio % Length; / * periodicity * /
+ if (Sampling_Ratio < 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+
+ Array = Scheme_Array_To_C_Array(Arg1);
+ Allocate_Array(Result, Length, allocated_cells);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ Pseudo_Length = Length * Sampling_Ratio;
+ for (i=0; i<Pseudo_Length; i += Sampling_Ratio) { / * new Array has the same Length by assuming periodicity * /
+ array_index = i % Length;
+ *To_Here++ = Array[array_index];
+ }
+
+ return Result;
+}
+\f
+Define_Primitive(Prim_Array_Periodic_Shift, 2, "ARRAY-PERIODIC-SHIFT")
+{ long Length, Shift;
+ REAL *Array, *To_Here;
+ Pointer Result;
+ long allocated_cells, i, array_index;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_FIXNUM);
+ Length = Array_Length(Arg1);
+ Sign_Extend(Arg2, Shift);
+ Shift = Shift % Length; / * periodic waveform, same sign as dividend * /
+ Array = Scheme_Array_To_C_Array(Arg1);
+ Allocate_Array(Result, Length, allocated_cells);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ for (i=0; i<Length; i++) { / * new Array has the same Length by assuming periodicity * /
+ array_index = (i+Shift) % Length;
+ if (array_index<0) array_index = Length + array_index; / * wrap around * /
+ *To_Here++ = Array[array_index];
+ }
+
+ return Result;
+}
+\f
+/ * this should really be done in SCHEME using ARRAY-MAP ! * /
+
+Define_Primitive(Prim_Array_Aperiodic_Downsample, 2, "ARRAY-APERIODIC-DOWNSAMPLE")
+{ long Length, New_Length, Sampling_Ratio;
+ REAL *Array, *To_Here;
+ Pointer Result;
+ long allocated_cells, i, array_index;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_ARRAY);
+ Arg_2_Type(TC_FIXNUM);
+ Length = Array_Length(Arg1);
+ Range_Check(Sampling_Ratio, Arg2, 1, Length, ERR_ARG_2_BAD_RANGE);
+
+ Array = Scheme_Array_To_C_Array(Arg1);
+ New_Length = Length / Sampling_Ratio;
+ / * greater than zero * /
+ Allocate_Array(Result, New_Length, allocated_cells);
+ To_Here = Scheme_Array_To_C_Array(Result);
+
+ for (i=0; i<Length; i += Sampling_Ratio) {
+ *To_Here++ = Array[i];
+ }
+
+ return Result;
+}
+
+\f
+/ * ARRAY-APERIODIC-SHIFT can be done in scheme using subarray, and array-append * /
+
+
+for UPSAMPLING
+if ((Length % Sampling_Ratio) != 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+UNIMPLEMENTED YET
+
+*/
+
+/* END OF FILE */
+
--- /dev/null
+/* C */
+
+extern Image_Fast_Transpose(); /* REAL *Array; long nrows; OPTIMIZATION for square images */
+extern Image_Transpose(); /* REAL *Array, *New_Array; long nrows, ncols; */
+extern Image_Rotate_90clw(); /* REAL *Array, *Rotated_Array; long nrows, ncols; */
+extern Image_Rotate_90cclw(); /* REAL *Array, *Rotated_Array; long nrows, ncols; */
+extern Image_Mirror(); /* REAL *Array; long nrows, ncols; */
+
+extern Image_Mirror_Upside_Down(); /* Array,nrows,ncols,Temp_Array;
+ REAL *Array,*Temp_Row; long nrows, ncols; */
+extern Image_Read_From_CTSCAN_File(); /* FILE *fp; REAL *Array; long nrows, ncols */
+
+extern Image_Rotate_90clw_Mirror(); /* REAL *Array, *Rotated_Array; long nrows, ncols; */
+
+extern Image_Draw_Magnify_N_Times_With_Offset_Scale();
+extern Image_Draw_Magnify_N_Times_With_Offset_Scale_Only();
--- /dev/null
+/* 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. *
+* *
+****************************************************************/
+
+/* File: INTERCOM.C
+ * Single-processor simulation of locking, propagating, and
+ * communicating stuff.
+ */
+\f
+#include "scheme.h"
+#include "primitive.h"
+#include "prims.h"
+#include "locks.h"
+#include "zones.h"
+
+#ifndef COMPILE_FUTURES
+#include "Error: intercom.c is useless without COMPILE_FUTURES"
+#endif
+
+/* (GLOBAL-INTERRUPT LEVEL WORK TEST)
+
+ There are 4 global interrupt levels, level 0 (highest priority)
+ being reserved for GC. See const.h for details of the dist-
+ ribution of these bits with respect to local interrupt levels.
+
+ Force all other processors to begin executing WORK (an interrupt
+ handler [procedure of two arguments]) provided that TEST returns
+ true. TEST is supplied to allow this primitive to be restarted if it
+ is unable to begin because another processor wins the race to
+ generate a global interrupt and makes it no longer necessary that
+ this processor generate one (TEST receives no arguments). This
+ primitive returns the value of the call to TEST (i.e. non-#!FALSE if
+ the interrupt was really generated), and returns only after all other
+ processors have begun execution of WORK (or TEST returns false).
+*/
+\f
+Define_Primitive(Prim_Send_Global_Interrupt, 3, "GLOBAL-INTERRUPT")
+{ long Saved_Zone, Which_Level;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Range_Check(Which_Level, Arg1, 0, 3, ERR_ARG_1_BAD_RANGE);
+ Save_Time_Zone(Zone_Global_Int);
+ Pop_Primitive_Frame(3);
+ Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
+ Store_Return(RC_FINISH_GLOBAL_INT);
+ Store_Expression(Arg1);
+ Save_Cont();
+ Push(Arg3);
+ Push(STACK_FRAME_HEADER);
+ Pushed();
+ Restore_Time_Zone();
+ longjmp(*Back_To_Eval, PRIM_APPLY);
+}
+
+Pointer Global_Int_Part_2(Which_Level, Do_It)
+Pointer Do_It, Which_Level;
+{ return Do_It;
+}
+\f
+Define_Primitive(Prim_Put_Work, 1, "PUT-WORK")
+{ Pointer The_Queue, Queue_Tail, New_Entry;
+ Primitive_1_Arg();
+
+ The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
+ if (The_Queue==NIL)
+ { Primitive_GC_If_Needed(4);
+ The_Queue = Make_Pointer(TC_LIST, Free);
+ Set_Fixed_Obj_Slot(The_Work_Queue, The_Queue);
+ *Free++ = NIL;
+ *Free++ = NIL;
+ }
+ else Primitive_GC_If_Needed(2);
+ Queue_Tail = Vector_Ref(The_Queue, CONS_CDR);
+ New_Entry = Make_Pointer(TC_WEAK_CONS, Free);
+ *Free++ = Arg1;
+ *Free++ = NIL;
+ Vector_Set(The_Queue, CONS_CDR, New_Entry);
+ if (Queue_Tail==NIL) Vector_Set(The_Queue, CONS_CAR, New_Entry);
+ else Vector_Set(Queue_Tail, CONS_CDR, New_Entry);
+ return TRUTH;
+}
+
+Define_Primitive(Prim_Drain_Queue, 0, "DRAIN-WORK-QUEUE!")
+{ Pointer The_Queue;
+ Primitive_0_Args();
+
+ The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
+ Set_Fixed_Obj_Slot(The_Work_Queue, NIL);
+ return (The_Queue != NIL) ? Vector_Ref(The_Queue, CONS_CAR) : NIL;
+}
+\f
+Define_Primitive(Prim_Await_Sync, 1, "AWAIT-SYNCHRONY")
+{ Primitive_1_Arg();
+
+ Arg_1_Type(TC_LIST);
+ if (Type_Code(Vector_Ref(Arg1, CONS_CDR)) != TC_FIXNUM)
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ return TRUTH;
+}
+
+Define_Primitive(Prim_N_Interps, 0, "N-INTERPRETERS")
+{ Primitive_0_Args();
+ return FIXNUM_0 + 1;
+}
+
+Define_Primitive(Prim_My_Proc, 0, "MY-PROCESSOR-NUMBER")
+{ Primitive_0_Args();
+ return FIXNUM_0;
+}
+
+Define_Primitive(Prim_My_Interp_Number, 0, "MY-INTERPRETER-NUMBER")
+{ Primitive_0_Args();
+ return FIXNUM_0;
+}
+
+Define_Primitive(Prim_Zero_Zones, 0, "ZERO-ZONES")
+{ long i;
+ Primitive_0_Args();
+#ifdef METERING
+ for (i=0; i < Max_Meters; i++) Time_Meters[i]=0;
+ Old_Time=Sys_Clock();
+#endif
+ return TRUTH;
+}
+\f
+/* These are really used by GC on a true parallel machine */
+
+Define_Primitive(Prim_GC_Needed, 0, "GC-NEEDED?")
+{ Primitive_0_Args();
+ if ((Free+GC_Space_Needed) >= MemTop) return TRUTH;
+ else return NIL;
+}
+
+Define_Primitive(Prim_Slave_Before, 0, "SLAVE-GC-BEFORE-SYNC")
+{ Primitive_0_Args();
+ return TRUTH;
+}
+
+Define_Primitive(Prim_Slave_After, 0, "SLAVE-GC-AFTER-SYNC")
+{ Primitive_0_Args();
+ return TRUTH;
+}
+
+Define_Primitive(Prim_Master_Before, 0, "MASTER-GC-BEFORE-SYNC")
+{ Primitive_0_Args();
+ return TRUTH;
+}
+
+Define_Primitive(Prim_Master_GC, 1, "MASTER-GC-LOOP")
+{ Primitive_1_Arg();
+ Pop_Primitive_Frame(1);
+ Will_Push(STACK_ENV_EXTRA_SLOTS + 2);
+ Push(Arg1);
+ Push(Make_Non_Pointer(TC_PRIMITIVE, PC_GARBAGE_COLLECT));
+ Push(STACK_FRAME_HEADER + 1);
+ Pushed();
+ longjmp(*Back_To_Eval, PRIM_APPLY);
+}
+
+
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: interpret.c
+ *
+ * This file contains the heart of the Scheme Scode
+ * interpreter
+ *
+ */
+
+#define In_Main_Interpreter true
+#include "scheme.h"
+#include "zones.h"
+\f
+/* In order to make the interpreter tail recursive (i.e.
+ * to avoid calling procedures and thus saving unnecessary
+ * state information), the main body of the interpreter
+ * is coded in a continuation passing style.
+ *
+ * Basically, this is done by dispatching on the type code
+ * for an Scode item. At each dispatch, some processing
+ * is done which may include setting the return address
+ * register, saving the current continuation (return address
+ * and current expression) and jumping to the start of
+ * the interpreter.
+ *
+ * It may be helpful to think of this program as being what
+ * you would get if you wrote the straightforward Scheme
+ * interpreter and then converted it into continuation
+ * passing style as follows. At every point where you would
+ * call EVAL to handle a sub-form, you put a jump back to
+ * Do_Expression. Now, if there was code after the call to
+ * EVAL you first push a "return code" (using Save_Cont) on
+ * the stack and move the code that used to be after the
+ * call down into the part of this file after the tag
+ * Pop_Return.
+ *
+ * Notice that because of the caller saves convention used
+ * here, all of the registers which are of interest have
+ * been SAVEd on the racks by the time interpretation arrives
+ * at Do_Expression (the top of EVAL).
+ *
+ * For notes on error handling and interrupts, see the file
+ * utils.c.
+ *
+ * This file is divided into two parts. The first
+ * corresponds is called the EVAL dispatch, and is ordered
+ * alphabetically by the SCode item handled. The second,
+ * called the return dispatch, begins at Pop_Return and is
+ * ordered alphabetically by return code name.
+ */
+\f
+#define Interrupt(Masked_Code) \
+ { Export_Registers(); \
+ Setup_Interrupt(Masked_Code); \
+ Import_Registers(); \
+ goto Perform_Application; \
+ }
+
+#define Immediate_GC(N) \
+ { Request_GC(N); \
+ Interrupt(IntCode & IntEnb); \
+ }
+
+#define Prepare_Eval_Repeat() \
+ {Will_Push(CONTINUATION_SIZE+1); \
+ Push(Fetch_Env()); \
+ Store_Return(RC_EVAL_ERROR); \
+ Save_Cont(); \
+ Pushed(); \
+ }
+
+#define Eval_GC_Check(Amount) \
+ if (GC_Check(Amount)) \
+ { Prepare_Eval_Repeat(); \
+ Immediate_GC(Amount); \
+ }
+
+#define Eval_Error(Err) \
+ { Export_Registers(); \
+ Do_Micro_Error(Err, false); \
+ Import_Registers(); \
+ goto Internal_Apply; \
+ }
+
+#define Pop_Return_Error(Err) \
+ { Export_Registers(); \
+ Do_Micro_Error(Err, true); \
+ Import_Registers(); \
+ goto Internal_Apply; \
+ }
+
+#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \
+ Store_Return(Return_Code); \
+ Val = Contents_of_Val; \
+ Save_Cont()
+\f
+#define Reduces_To(Expr) \
+ { Store_Expression(Expr); \
+ New_Reduction(Fetch_Expression(), Fetch_Env()); \
+ goto Do_Expression; \
+ }
+
+#define Reduces_To_Nth(N) \
+ Reduces_To(Fast_Vector_Ref(Fetch_Expression(), (N)))
+
+#define Do_Nth_Then(Return_Code, N, Extra) \
+ { Store_Return(Return_Code); \
+ Save_Cont(); \
+ Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \
+ New_Subproblem(Fetch_Expression(), Fetch_Env()); \
+ Extra; \
+ goto Do_Expression; \
+ }
+
+#define Do_Another_Then(Return_Code, N) \
+ { Store_Return(Return_Code); \
+ Save_Cont(); \
+ Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \
+ Reuse_Subproblem(Fetch_Expression(), Fetch_Env()); \
+ goto Do_Expression; \
+ }
+
+#define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT))
+
+/* This makes local variable references faster */
+
+#if (LOCAL_REF == 0)
+#define Local_Offset(Ind) Ind
+#else
+#define Local_Offset(Ind) Get_Integer(Ind)
+#endif
+\f
+#ifdef COMPILE_FUTURES
+#define Splice_Future_Value(The_Loc) \
+{ while ((Type_Code(Val) == TC_FUTURE) && (Future_Spliceable(Val))) \
+ { Pointer *Location; \
+ Val = Future_Value(Val); \
+ Location = The_Loc; \
+ if Dangerous(*Location) Set_Danger_Bit(Val); \
+ *Location = Val; \
+ Clear_Danger_Bit(Val); \
+ } \
+ Set_Time_Zone(Zone_Working); \
+ break; \
+}
+#else
+#define Splice_Future_Value(The_Loc) \
+{ Set_Time_Zone(Zone_Working); \
+ break; \
+}
+#endif
+
+#ifdef TRAP_ON_REFERENCE
+#define Trap(Value) (Safe_Type_Code(Value) == TC_TRAP)
+#else
+#define Trap(Value) false
+#endif
+
+#define MAGIC_RESERVE_SIZE 6 /* See SPMD.SCM */
+#define Reserve_Stack_Space() Will_Eventually_Push(MAGIC_RESERVE_SIZE)
+\f
+ /***********************/
+ /* Macros for Stepping */
+ /***********************/
+
+#define Fetch_Trapper(field) \
+ Vector_Ref(Get_Fixed_Obj_Slot(Stepper_State), (field))
+
+#define Fetch_Eval_Trapper() Fetch_Trapper(HUNK_CXR0)
+#define Fetch_Apply_Trapper() Fetch_Trapper(HUNK_CXR1)
+#define Fetch_Return_Trapper() Fetch_Trapper(HUNK_CXR2)
+\f
+/* Macros for handling FUTUREs */
+
+#ifdef COMPILE_FUTURES
+
+/* Arg_Type_Error handles the error returns from primitives which type check
+ their arguments and restarts them or suspends if the argument is a future. */
+
+#define Arg_Type_Error(Arg_No, Err_No) \
+{ fast Pointer *Arg = &(Stack_Ref(Arg_No-1)); \
+ fast Pointer Orig_Arg = *Arg; \
+ if (Type_Code(*Arg) != TC_FUTURE) Pop_Return_Error(Err_No); \
+ while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
+ { if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
+ *Arg = Future_Value(*Arg); \
+ } \
+ if (Type_Code(*Arg) != TC_FUTURE) goto Prim_No_Trap_Apply; \
+ Save_Cont(); \
+ Will_Push(STACK_ENV_EXTRA_SLOTS+2); \
+ Push(*Arg); /* Arg 1: The future itself */ \
+ Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
+ Push(STACK_FRAME_HEADER+1); \
+ Pushed(); \
+ *Arg = Orig_Arg; \
+ goto Apply_Non_Trapping; \
+}
+\f
+/* Apply_Future_Check is called at apply time to guarantee that certain
+ objects (the procedure itself, and its LAMBDA components for user defined
+ procedures) are not futures
+*/
+
+#define Apply_Future_Check(Name, Object) \
+{ fast Pointer *Arg = &(Object); \
+ fast Pointer Orig_Answer = *Arg; \
+ while (Type_Code(*Arg) == TC_FUTURE) \
+ { if (Future_Has_Value(*Arg)) \
+ { if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
+ *Arg = Future_Value(*Arg); \
+ } \
+ else \
+ { \
+ Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
+ Store_Return(RC_INTERNAL_APPLY); \
+ Val = NIL; \
+ Save_Cont(); \
+ Push(*Arg); \
+ Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
+ Push(STACK_FRAME_HEADER+1); \
+ Pushed(); \
+ *Arg = Orig_Answer; \
+ goto Internal_Apply; \
+ } \
+ } \
+ Name = *Arg; \
+}
+
+/* Future handling macros continue on the next page */
+\f
+/* Future handling macros, continued */
+
+/* Pop_Return_Val_Check suspends the process if the value calculated by
+ a recursive call to EVAL is an undetermined future */
+
+#define Pop_Return_Val_Check() \
+{ fast Pointer Orig_Val = Val; \
+ while (Type_Code(Val) == TC_FUTURE) \
+ { if (Future_Has_Value(Val)) \
+ { if (Future_Is_Keep_Slot(Val)) Log_Touch_Of_Future(Val); \
+ Val = Future_Value(Val); \
+ } \
+ else \
+ { Save_Cont(); \
+ Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
+ Store_Return(RC_RESTORE_VALUE); \
+ Store_Expression(Orig_Val); \
+ Save_Cont(); \
+ Push(Val); \
+ Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
+ Push(STACK_FRAME_HEADER+1); \
+ Pushed(); \
+ goto Internal_Apply; \
+ } \
+ } \
+}
+
+#else /* Not compiling FUTURES code */
+#define Pop_Return_Val_Check()
+#define Apply_Future_Check(Name, Object) Name = (Object)
+#define Arg_Type_Error(Arg_No, Err_No) Pop_Return_Error(Err_No)
+#endif
+\f
+/* The EVAL/APPLY ying/yang */
+
+void
+Interpret(dumped_p)
+ Boolean dumped_p;
+{ long Which_Way;
+ fast Pointer Reg_Val, Reg_Expression, *Reg_Stack_Pointer;
+ extern long enter_compiled_expression();
+ extern long apply_compiled_procedure();
+ extern long return_to_compiled_code();
+
+ /* Primitives jump back here for errors, requests to
+ * evaluate an expression, apply a function, or handle an
+ * interrupt request. On errors or interrupts they leave
+ * their arguments on the stack, the primitive itself in
+ * Expression, and a RESTART_PRIMITIVE continuation in the
+ * return register. In the other cases, they have removed
+ * their stack frames entirely.
+ */
+
+ Which_Way = setjmp(*Back_To_Eval);
+ Set_Time_Zone(Zone_Working);
+ Import_Registers();
+ if (Must_Report_References())
+ { Save_Cont();
+ Will_Push(CONTINUATION_SIZE + 2);
+ Push(Val);
+ Save_Env();
+ Store_Return(RC_REPEAT_DISPATCH);
+ Store_Expression(Make_Non_Pointer(TC_FIXNUM, Which_Way));
+ Save_Cont();
+ Pushed();
+ Call_Future_Logging();
+ }
+Repeat_Dispatch:
+ switch (Which_Way)
+ { case PRIM_APPLY: goto Internal_Apply;
+ case PRIM_NO_TRAP_APPLY: goto Apply_Non_Trapping;
+ case PRIM_DO_EXPRESSION: Reduces_To(Fetch_Expression());
+ case PRIM_NO_TRAP_EVAL: New_Reduction(Fetch_Expression(),Fetch_Env());
+ goto Eval_Non_Trapping;
+ case 0: if (!dumped_p) break; /* Else fall through */
+ case PRIM_POP_RETURN: goto Pop_Return;
+ default: Pop_Return_Error(Which_Way);
+ case PRIM_INTERRUPT:
+ { Save_Cont();
+ Interrupt(IntCode & IntEnb);
+ }
+ case ERR_ARG_1_WRONG_TYPE: Arg_Type_Error(1, ERR_ARG_1_WRONG_TYPE);
+ case ERR_ARG_2_WRONG_TYPE: Arg_Type_Error(2, ERR_ARG_2_WRONG_TYPE);
+ case ERR_ARG_3_WRONG_TYPE: Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE);
+ }
+\f
+ /*****************/
+ /* Do_Expression */
+ /*****************/
+
+Do_Expression:
+
+ if (Eval_Debug)
+ { Print_Expression(Fetch_Expression(), "Eval, expression");
+ CRLF();
+ }
+
+/* The expression register has an Scode item in it which
+ * should be evaluated and the result left in Val.
+ *
+ * A "break" after the code for any operation indicates that
+ * all processing for this operation has been completed, and
+ * the next step will be to pop a return code off the stack
+ * and proceed at Pop_Return. This is sometimes called
+ * "executing the continuation" since the return code can be
+ * considered the continuation to be performed after the
+ * operation.
+ *
+ * An operation can terminate with a Reduces_To or
+ * Reduces_To_Nth macro. This indicates that the value of
+ * the current S-Code item is the value returned when the
+ * new expression is evaluated. Therefore no new
+ * continuation is created and processing continues at
+ * Do_Expression with the new expression in the expression
+ * register.
+ *
+ * Finally, an operation can terminate with a Do_Nth_Then
+ * macro. This indicates that another expression must be
+ * evaluated and them some additional processing will be
+ * performed before the value of this S-Code item available.
+ * Thus a new continuation is created and placed on the
+ * stack (using Save_Cont), the new expression is placed in
+ * the Expression register, and processing continues at
+ * Do_Expression.
+ */
+\f
+/* Handling of Eval Trapping.
+
+ If we are handling traps and there is an Eval Trap set,
+ turn off all trapping and then go to Internal_Apply to call the
+ user supplied eval hook with the expression to be evaluated and the
+ environment.
+
+*/
+
+ if (Microcode_Does_Stepping && Trapping &&
+ (Fetch_Eval_Trapper() != NIL))
+ { Stop_Trapping();
+ Will_Push(4);
+ Push(Fetch_Env());
+ Push(Fetch_Expression());
+ Push(Fetch_Eval_Trapper());
+ Push(STACK_FRAME_HEADER+2);
+ Pushed();
+ goto Apply_Non_Trapping;
+ }
+\f
+Eval_Non_Trapping:
+ Eval_Ucode_Hook();
+ switch (Type_Code(Fetch_Expression()))
+ { case TC_BIG_FIXNUM: /* The self evaluating items */
+ case TC_BIG_FLONUM:
+ case TC_CHARACTER_STRING:
+ case TC_CHARACTER:
+ case TC_COMPILED_PROCEDURE:
+ case TC_CONTROL_POINT:
+ case TC_DELAYED:
+ case TC_ENVIRONMENT:
+ case TC_EXTENDED_FIXNUM:
+ case TC_EXTENDED_PROCEDURE:
+ case TC_FIXNUM:
+ case TC_HUNK3:
+ case TC_LIST:
+ case TC_NON_MARKED_VECTOR:
+ case TC_NULL:
+ case TC_PRIMITIVE:
+ case TC_PRIMITIVE_EXTERNAL:
+ case TC_PROCEDURE:
+ case TC_UNINTERNED_SYMBOL:
+ case TC_INTERNED_SYMBOL:
+ case TC_TRUE:
+ case TC_UNASSIGNED:
+ case TC_VECTOR:
+ case TC_VECTOR_16B:
+ case TC_VECTOR_1B:
+ Val = Fetch_Expression(); break;
+
+ case TC_ACCESS:
+ Will_Push(CONTINUATION_SIZE);
+ Do_Nth_Then(RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT, Pushed());
+
+ case TC_ASSIGNMENT:
+ Will_Push(CONTINUATION_SIZE + 1);
+ Save_Env();
+ Do_Nth_Then(RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE, Pushed());
+
+ case TC_BROKEN_HEART:
+ Export_Registers();
+ Microcode_Termination(TERM_BROKEN_HEART);
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_COMBINATION:
+ { long Array_Length = Vector_Length(Fetch_Expression())-1;
+ Eval_GC_Check(New_Stacklet_Size(Array_Length+1+1+CONTINUATION_SIZE));
+ Will_Push(Array_Length + 1+1+CONTINUATION_SIZE); /* Save_Env, Finger */
+ Stack_Pointer = Simulate_Pushing(Array_Length);
+ Push(Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Array_Length));
+ /* The finger: last argument number */
+ Pushed();
+ if (Array_Length == 0)
+ { Push(STACK_FRAME_HEADER); /* Frame size */
+ Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {});
+ }
+ Save_Env();
+ Do_Nth_Then(RC_COMB_SAVE_VALUE, Array_Length+1, {});
+ }
+
+ case TC_COMBINATION_1:
+ Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+2+CONTINUATION_SIZE */
+ Save_Env();
+ Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1, {});
+
+ case TC_COMBINATION_2:
+ Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+3+CONTINUATION_SIZE */
+ Save_Env();
+ Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {});
+
+ case TC_COMMENT:
+ Reduces_To_Nth(COMMENT_EXPRESSION);
+
+ case TC_CONDITIONAL:
+ Will_Push(CONTINUATION_SIZE + 1);
+ Save_Env();
+ Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE, Pushed());
+
+ case TC_COMPILED_EXPRESSION:
+ execute_compiled_setup();
+ Store_Expression( (Pointer) Get_Pointer( Fetch_Expression()));
+ Export_Registers();
+ Which_Way = enter_compiled_expression();
+ goto return_from_compiled_code;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_DEFINITION:
+ Will_Push(CONTINUATION_SIZE + 1);
+ Save_Env();
+ Do_Nth_Then(RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE, Pushed());
+
+ case TC_DELAY:
+ /* Deliberately omitted: Eval_GC_Check(2); */
+ Val = Make_Pointer(TC_DELAYED, Free);
+ Free[THUNK_ENVIRONMENT] = Fetch_Env();
+ Free[THUNK_PROCEDURE] =
+ Fast_Vector_Ref(Fetch_Expression(), DELAY_OBJECT);
+ Free += 2;
+ break;
+
+ case TC_DISJUNCTION:
+ Will_Push(CONTINUATION_SIZE + 1);
+ Save_Env();
+ Do_Nth_Then(RC_DISJUNCTION_DECIDE, OR_PREDICATE, Pushed());
+
+ case TC_EXTENDED_LAMBDA: /* Close the procedure */
+ /* Deliberately omitted: Eval_GC_Check(2); */
+ Val = Make_Pointer(TC_EXTENDED_PROCEDURE, Free);
+ Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
+ Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
+ Free += 2;
+ break;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+#ifdef COMPILE_FUTURES
+ case TC_FUTURE:
+ if (Future_Has_Value(Fetch_Expression()))
+ { Pointer Future = Fetch_Expression();
+ if (Future_Is_Keep_Slot(Future)) Log_Touch_Of_Future(Future);
+ Reduces_To_Nth(FUTURE_VALUE);
+ }
+ Prepare_Eval_Repeat();
+ Will_Push(STACK_ENV_EXTRA_SLOTS+2);
+ Push(Fetch_Expression()); /* Arg: FUTURE object */
+ Push(Get_Fixed_Obj_Slot(System_Scheduler));
+ Push(STACK_FRAME_HEADER+1);
+ Pushed();
+ goto Internal_Apply;
+#endif
+
+ case TC_IN_PACKAGE:
+ Will_Push(CONTINUATION_SIZE);
+ Do_Nth_Then(RC_EXECUTE_IN_PACKAGE_CONTINUE,
+ IN_PACKAGE_ENVIRONMENT, Pushed());
+
+ case TC_LAMBDA: /* Close the procedure */
+ case TC_LEXPR:
+ /* Deliberately omitted: Eval_GC_Check(2); */
+ Val = Make_Pointer(TC_PROCEDURE, Free);
+ Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
+ Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
+ Free += 2;
+ break;
+
+ case TC_MANIFEST_NM_VECTOR:
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ Eval_Error(ERR_EXECUTE_MANIFEST_VECTOR);
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_PCOMB0:
+ /* In case we back out */
+ Reserve_Stack_Space(); /* CONTINUATION_SIZE */
+ Finished_Eventual_Pushing(); /* of this primitive */
+/* ASSUMPTION: The syntaxer is hereby assumed NEVER to generate primitive
+ combinations unless the primitive itself is output in the code stream.
+ Therefore, we don't have to explicitly check here that the expression
+ register has a primitive in it.
+*/
+Primitive_Internal_Apply:
+ if (Microcode_Does_Stepping && Trapping &&
+ (Fetch_Apply_Trapper() != NIL))
+ {Will_Push(3);
+ Push(Fetch_Expression());
+ Push(Fetch_Apply_Trapper());
+ Push(STACK_FRAME_HEADER + 1 + N_Args_Primitive(Fetch_Expression()));
+ Pushed();
+ Stop_Trapping();
+ goto Apply_Non_Trapping;
+ }
+Prim_No_Trap_Apply:
+ Export_Registers();
+ Metering_Apply_Primitive(Val, Get_Integer(Fetch_Expression()));
+
+/* Any primitive which does not do a long jump can have it's primitive
+ frame popped off here. At this point, it is guaranteed that the
+ primitive is in the expression register in case the primitive needs
+ to back out.
+*/
+ Import_Registers_Except_Val();
+ Pop_Primitive_Frame(N_Args_Primitive(Fetch_Expression()));
+ if (Must_Report_References())
+ { Store_Expression(Val);
+ Store_Return(RC_RESTORE_VALUE);
+ Save_Cont();
+ Call_Future_Logging();
+ }
+ break;
+\f
+ case TC_PCOMB1:
+ Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */
+ Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {});
+
+ case TC_PCOMB2:
+ Reserve_Stack_Space(); /* 2+CONTINUATION_SIZE */
+ Save_Env();
+ Do_Nth_Then(RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT, {});
+
+ case TC_PCOMB3:
+ Reserve_Stack_Space(); /* 3+CONTINUATION_SIZE */
+ Save_Env();
+ Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {});
+
+ case TC_SCODE_QUOTE:
+ Val = Fast_Vector_Ref(Fetch_Expression(), SCODE_QUOTE_OBJECT);
+ break;
+
+ case TC_SEQUENCE_2:
+ Will_Push(CONTINUATION_SIZE + 1);
+ Save_Env();
+ Do_Nth_Then(RC_SEQ_2_DO_2, SEQUENCE_1, Pushed());
+
+ case TC_SEQUENCE_3:
+ Will_Push(CONTINUATION_SIZE + 1);
+ Save_Env();
+ Do_Nth_Then(RC_SEQ_3_DO_2, SEQUENCE_1, Pushed());
+
+ case TC_THE_ENVIRONMENT:
+ Val = Fetch_Env(); break;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_VARIABLE:
+/* ASSUMPTION: The SYMBOL slot does NOT contain a future */
+ { fast Pointer Compilation_Type, *Variable_Object;
+ int The_Type;
+
+ Set_Time_Zone(Zone_Lookup);
+#ifndef No_In_Line_Lookup
+
+ Variable_Object = Get_Pointer(Fetch_Expression());
+ Compilation_Type = Variable_Object[VARIABLE_COMPILED_TYPE];
+ The_Type = Type_Code(Compilation_Type);
+
+ if (The_Type == LOCAL_REF)
+ { fast Pointer *Frame;
+ Frame = Get_Pointer(Fetch_Env());
+ Val = Without_Danger_Bit(Frame[Local_Offset(Compilation_Type)]);
+ if (!Trap(Val))
+ Splice_Future_Value(&(Frame[Local_Offset(Compilation_Type)]));
+ }
+ else if (The_Type == GLOBAL_REF)
+ { Val = Vector_Ref(Compilation_Type, SYMBOL_GLOBAL_VALUE);
+ if (Dangerous(Val))
+ Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
+ else if (!Trap(Val))
+ Splice_Future_Value(Nth_Vector_Loc(Compilation_Type,
+ SYMBOL_GLOBAL_VALUE));
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ else if (The_Type == FORMAL_REF)
+ { fast long Frame_No;
+ fast Pointer *Frame;
+
+ Frame = Get_Pointer(Fetch_Env());
+ Frame_No = Get_Integer(Variable_Object[VARIABLE_FRAME_NO]);
+ while(--Frame_No >= 0)
+ Frame = Get_Pointer(Fast_Vector_Ref(Frame[HEAP_ENV_FUNCTION],
+ PROCEDURE_ENVIRONMENT));
+ Val = Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])];
+ if (Dangerous(Val))
+ Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
+ else if (!Trap(Val))
+ Splice_Future_Value(
+ &(Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])]));
+ }
+#endif
+ /* Fall through in cases not handled above */
+ { long Result;
+ Result = Lex_Ref(Fetch_Env(), Fetch_Expression());
+ Import_Val();
+ Set_Time_Zone(Zone_Working);
+ if (Result == PRIM_DONE) break;
+ Eval_Error(Result);
+ }
+ }
+
+ case TC_RETURN_CODE:
+ default: Eval_Error(ERR_UNDEFINED_USER_TYPE);
+ };
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+/* Now restore the continuation saved during an earlier part
+ * of the EVAL cycle and continue as directed.
+ */
+
+Pop_Return:
+ Pop_Return_Ucode_Hook();
+ Restore_Cont();
+ if (Consistency_Check &&
+ (Type_Code(Fetch_Return()) != TC_RETURN_CODE))
+ { Push(Val); /* For possible stack trace */
+ Save_Cont();
+ Export_Registers();
+ Microcode_Termination(TERM_BAD_STACK);
+ }
+ if (Eval_Debug)
+ { Print_Return("Pop_Return, return code");
+ Print_Expression(Val, "Pop_Return, value");
+ CRLF();
+ };
+
+ /* Dispatch on the return code. A BREAK here will cause
+ * a "goto Pop_Return" to occur, since this is the most
+ * common occurrence.
+ */
+
+ switch (Get_Integer(Fetch_Return()))
+ { case RC_COMB_1_PROCEDURE:
+ Restore_Env();
+ Push(Val); /* Arg. 1 */
+ Push(NIL); /* Operator */
+ Push(STACK_FRAME_HEADER+1);
+ Finished_Eventual_Pushing();
+ Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN);
+
+ case RC_COMB_2_FIRST_OPERAND:
+ Restore_Env();
+ Push(Val);
+ Save_Env();
+ Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_COMB_2_PROCEDURE:
+ Restore_Env();
+ Push(Val); /* Arg 1, just calculated */
+ Push(NIL); /* Function */
+ Push(STACK_FRAME_HEADER+2);
+ Finished_Eventual_Pushing();
+ Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN);
+
+ case RC_COMB_APPLY_FUNCTION:
+ End_Subproblem();
+ Stack_Ref(STACK_ENV_FUNCTION) = Val;
+ goto Internal_Apply;
+
+ case RC_COMB_SAVE_VALUE:
+ { long Arg_Number;
+
+ Restore_Env();
+ Arg_Number = Get_Integer(Stack_Ref(STACK_COMB_FINGER))-1;
+ Stack_Ref(STACK_COMB_FIRST_ARG+Arg_Number) = Val;
+ Stack_Ref(STACK_COMB_FINGER) =
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Arg_Number);
+ /* DO NOT count on the type code being NMVector here, since
+ the stack parser may create them with NIL here! */
+ if (Arg_Number > 0)
+ { Save_Env();
+ Do_Another_Then(RC_COMB_SAVE_VALUE,
+ (COMB_ARG_1_SLOT - 1) + Arg_Number);
+ }
+ Push(Fast_Vector_Ref(Fetch_Expression(), 0)); /* Frame Size */
+ Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+#define define_compiler_restart( return_code, entry) \
+ case return_code: \
+ { extern long entry(); \
+ compiled_code_restart(); \
+ Export_Registers(); \
+ Which_Way = entry(); \
+ goto return_from_compiled_code; \
+ }
+
+ define_compiler_restart( RC_COMPILER_INTERRUPT_RESTART,
+ compiler_interrupt_restart)
+
+ define_compiler_restart( RC_COMPILER_LEXPR_INTERRUPT_RESTART,
+ compiler_lexpr_interrupt_restart)
+
+ define_compiler_restart( RC_COMPILER_LOOKUP_APPLY_RESTART,
+ compiler_lookup_apply_restart)
+
+ define_compiler_restart( RC_COMPILER_REFERENCE_RESTART,
+ compiler_reference_restart)
+
+ define_compiler_restart( RC_COMPILER_ACCESS_RESTART,
+ compiler_access_restart)
+
+ define_compiler_restart( RC_COMPILER_UNASSIGNED_P_RESTART,
+ compiler_unassigned_p_restart)
+
+ define_compiler_restart( RC_COMPILER_UNBOUND_P_RESTART,
+ compiler_unbound_p_restart)
+
+ define_compiler_restart( RC_COMPILER_ASSIGNMENT_RESTART,
+ compiler_assignment_restart)
+
+ define_compiler_restart( RC_COMPILER_DEFINITION_RESTART,
+ compiler_definition_restart)
+
+ case RC_REENTER_COMPILED_CODE:
+ compiled_code_restart();
+ Export_Registers();
+ Which_Way = return_to_compiled_code();
+ goto return_from_compiled_code;
+\f
+ case RC_CONDITIONAL_DECIDE:
+ Pop_Return_Val_Check();
+ End_Subproblem();
+ Restore_Env();
+ Reduces_To_Nth((Val==NIL)? COND_ALTERNATIVE : COND_CONSEQUENT);
+
+ case RC_DISJUNCTION_DECIDE:
+ /* Return predicate if it isn't NIL; else do ALTERNATIVE */
+ Pop_Return_Val_Check();
+ End_Subproblem();
+ Restore_Env();
+ if (Val != NIL) goto Pop_Return;
+ Reduces_To_Nth(OR_ALTERNATIVE);
+
+ case RC_END_OF_COMPUTATION:
+ /* Signals bottom of stack */
+ Export_Registers();
+ Microcode_Termination(TERM_END_OF_COMPUTATION);
+
+ case RC_EVAL_ERROR:
+ Store_Env(Pop());
+ Reduces_To(Fetch_Expression());
+
+ case RC_EXECUTE_ACCESS_FINISH:
+ { long Result;
+ Pop_Return_Val_Check();
+ if (Environment_P(Val))
+ { Result = Symbol_Lex_Ref(Val,
+ Fast_Vector_Ref(Fetch_Expression(), ACCESS_NAME));
+ Import_Val();
+ if (Result != PRIM_DONE) Pop_Return_Error(Result);
+ End_Subproblem();
+ break;
+ }
+ Pop_Return_Error(ERR_BAD_FRAME);
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_EXECUTE_ASSIGNMENT_FINISH:
+ { fast Pointer Compilation_Type, *Variable_Object;
+ Pointer The_Non_Object, Store_Value;
+ int The_Type;
+
+ Set_Time_Zone(Zone_Lookup);
+ Restore_Env();
+ The_Non_Object = Get_Fixed_Obj_Slot(Non_Object);
+ Store_Value = (Val == The_Non_Object) ? UNASSIGNED_OBJECT : Val;
+
+#ifndef No_In_Line_Lookup
+
+ Variable_Object =
+ Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
+ Compilation_Type = Variable_Object[VARIABLE_COMPILED_TYPE];
+ The_Type = Type_Code(Compilation_Type);
+
+ if (The_Type == LOCAL_REF)
+ { fast Pointer *Frame;
+ Frame = Get_Pointer(Fetch_Env());
+ Val = Frame[Local_Offset(Compilation_Type)];
+ if (Dangerous(Val))
+ { Set_Danger_Bit(Store_Value);
+ Clear_Danger_Bit(Val);
+ }
+ if (!Trap(Val))
+ { Frame[Local_Offset(Compilation_Type)] = Store_Value;
+ if (Val == UNASSIGNED_OBJECT) Val = The_Non_Object;
+ Set_Time_Zone(Zone_Working);
+ End_Subproblem();
+ break;
+ }
+ }
+ else if (The_Type == GLOBAL_REF)
+ { Val = Vector_Ref(Compilation_Type, SYMBOL_GLOBAL_VALUE);
+ if (!Dangerous(Val) && !Trap(Val))
+ { Vector_Set(Compilation_Type, SYMBOL_GLOBAL_VALUE, Store_Value);
+ if (Val == UNASSIGNED_OBJECT) Val = The_Non_Object;
+ Set_Time_Zone(Zone_Working);
+ End_Subproblem();
+ break;
+ }
+ else if (Dangerous(Val))
+ Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ else if (The_Type == FORMAL_REF)
+ { fast long Frame_No;
+ fast Pointer *Frame;
+
+ Frame = Get_Pointer(Fetch_Env());
+ Frame_No = Get_Integer(Variable_Object[VARIABLE_FRAME_NO]);
+ while(--Frame_No >= 0)
+ Frame = Get_Pointer(Fast_Vector_Ref(Frame[HEAP_ENV_FUNCTION],
+ PROCEDURE_ENVIRONMENT));
+ Val = Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])];
+ if (!Dangerous(Val) && !Trap(Val))
+ { Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])] =
+ Store_Value;
+ if (Val==UNASSIGNED_OBJECT) Val = The_Non_Object;
+ Set_Time_Zone(Zone_Working);
+ End_Subproblem();
+ break;
+ }
+ else if (Dangerous(Val))
+ Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
+ }
+#endif
+ /* Fall through in cases not handled above */
+ { long Result;
+ Result = Lex_Set(Fetch_Env(),
+ Vector_Ref(Fetch_Expression(), ASSIGN_NAME),
+ Store_Value);
+ Import_Val();
+ Set_Time_Zone(Zone_Working);
+ if (Result == PRIM_DONE)
+ { End_Subproblem();
+ break;
+ }
+ Save_Env();
+ Pop_Return_Error(Result);
+ }
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_EXECUTE_DEFINITION_FINISH:
+ { Pointer Saved_Val;
+ long Result;
+
+ Saved_Val = Val;
+ Restore_Env();
+ Result = Local_Set(Fetch_Env(),
+ Fast_Vector_Ref(Fetch_Expression(), DEFINE_NAME),
+ Val);
+ Import_Val();
+ if (Result==PRIM_DONE)
+ { End_Subproblem();
+ break;
+ }
+ Save_Env();
+ if (Result==PRIM_INTERRUPT)
+ { Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH,
+ Saved_Val);
+ Interrupt(IntCode & IntEnb);
+ }
+ Pop_Return_Error(Result);
+ };
+
+ case RC_EXECUTE_IN_PACKAGE_CONTINUE:
+ Pop_Return_Val_Check();
+ if (Environment_P(Val))
+ { End_Subproblem();
+ Store_Env(Val);
+ Reduces_To_Nth(IN_PACKAGE_EXPRESSION);
+ }
+ Pop_Return_Error(ERR_BAD_FRAME);
+\f
+#ifdef COMPILE_FUTURES
+ case RC_FINISH_GLOBAL_INT:
+ Export_Registers();
+ Val = Global_Int_Part_2(Fetch_Expression(), Val);
+ Import_Registers_Except_Val();
+ break;
+#endif
+
+ case RC_GC_CHECK:
+ if (Get_Integer(Fetch_Expression()) > Space_Before_GC())
+ {
+ Export_Registers();
+ Microcode_Termination(TERM_GC_OUT_OF_SPACE);
+ }
+ break;
+
+ case RC_HALT:
+ Export_Registers();
+ Microcode_Termination(TERM_TERM_HANDLER);
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+#define Prepare_Apply_Interrupt() \
+ Prepare_Pop_Return_Interrupt(RC_INTERNAL_APPLY, NIL)
+
+#define Apply_Error(N) \
+ { Store_Return(RC_INTERNAL_APPLY); \
+ Val = NIL; \
+ Pop_Return_Error(N); \
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_INTERNAL_APPLY:
+Internal_Apply:
+
+/* Branch here to perform a function application. At this point
+ it is necessary that the top of the stack contain a frame
+ for evaluation of the function to be applied. This frame
+ DOES NOT contain "finger" and "combination" slots, although
+ if the frame is to be copied into the heap, it will have NIL's
+ in the "finger" and "combination" slots which will correspond
+ to "potentially-dangerous" and "auxilliary variables" slots.
+
+ Note, also, that unlike most return codes Val is not used here.
+ Thus, the error and interrupt macros above set it to NIL so that it
+ will not 'hold on' to anything if a GC occurs. Similarly, the
+ contents of Expression are discarded.
+*/
+ if (Microcode_Does_Stepping && Trapping &&
+ (Fetch_Apply_Trapper() != NIL))
+ { long Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER));
+ Top_Of_Stack() = Fetch_Apply_Trapper();
+ Push(STACK_FRAME_HEADER+Count);
+ Stop_Trapping();
+ }
+Apply_Non_Trapping:
+ { long Interrupts;
+ Pointer Function;
+
+ Store_Expression(NIL);
+ Interrupts = IntCode & IntEnb;
+ if (Interrupts != 0)
+ { Prepare_Apply_Interrupt();
+ Interrupt(Interrupts);
+ }
+
+Perform_Application:
+ Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION));
+ Apply_Ucode_Hook();
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ switch(Type_Code(Function))
+ { case TC_PROCEDURE:
+ { Pointer Lambda_Expr, *Temp1, Temp2;
+ long NParams, Size;
+ fast long NArgs;
+
+ Apply_Future_Check(Lambda_Expr,
+ Fast_Vector_Ref(Function,
+ PROCEDURE_LAMBDA_EXPR));
+ Temp1 = Get_Pointer(Lambda_Expr);
+ Apply_Future_Check(Temp2, Temp1[LAMBDA_FORMALS]);
+ NArgs = Get_Integer(Pop());
+ NParams = Vector_Length(Temp2);
+ if (Eval_Debug)
+ { Print_Expression(FIXNUM_0+NArgs,
+ "APPLY: Number of arguments");
+ Print_Expression(FIXNUM_0+NParams,
+ " Number of parameters");
+ }
+ if (Type_Code(Lambda_Expr) == TC_LAMBDA)
+ { if (NArgs != NParams)
+ { Push(STACK_FRAME_HEADER+NArgs-1);
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+ }
+ else if (NArgs < NParams)
+ { Push(STACK_FRAME_HEADER+NArgs-1);
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+ Size = NArgs + (HEAP_ENV_EXTRA_SLOTS - 1);
+ if (GC_Check(Size))
+ { Push(STACK_FRAME_HEADER+NArgs-1);
+ Prepare_Apply_Interrupt();
+ Immediate_GC(Size);
+ }
+ /* Store Environment Frame into heap, putting extra slots
+ for Potentially Dangerous and Auxiliaries */
+ Store_Env(Make_Pointer(TC_ENVIRONMENT, Free));
+ *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size);
+ *Free++ = NIL; /* For PD list and Aux list */
+ *Free++ = NIL;
+ for (; --NArgs >= 0; ) *Free++ = Pop();
+ Reduces_To(Temp1[LAMBDA_SCODE]);
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_CONTROL_POINT:
+ if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
+ STACK_ENV_FIRST_ARG)
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS)
+ Val = Stack_Ref(STACK_ENV_FIRST_ARG);
+ Our_Throw(false, Function);
+ Apply_Stacklet_Backout();
+ Our_Throw_Part_2();
+ goto Pop_Return;
+
+ case TC_PRIMITIVE_EXTERNAL:
+ { long NArgs, Proc = Datum(Function);
+ if (Proc > MAX_EXTERNAL_PRIMITIVE)
+ Apply_Error(ERR_UNDEFINED_PRIMITIVE);
+ NArgs = Ext_Prim_Desc[Proc].arity;
+ if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
+ STACK_ENV_FIRST_ARG+NArgs-1)
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
+ /* Remove the frame overhead, since the primitives
+ just expect arguments on the stack */
+ Store_Expression(Function);
+Repeat_External_Primitive:
+ /* Reinitialize Proc in case we "goto Repeat_External..." */
+ Proc = Get_Integer(Fetch_Expression());
+ Export_Registers();
+ Val = (*(Ext_Prim_Desc[Proc].proc))();
+ Set_Time_Zone(Zone_Working);
+ Import_Registers_Except_Val();
+ Pop_Primitive_Frame(Ext_Prim_Desc[Proc].arity);
+ goto Pop_Return;
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_EXTENDED_PROCEDURE:
+ { Pointer Lambda_Expr, *List_Car, Temp;
+ long NArgs, NParams, Formals, Params, Auxes,
+ Rest_Flag, Size, i;
+
+/* Selectors for the various parts */
+
+#define Get_Body_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_SCODE))
+#define Get_Names_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_NAMES))
+#define Get_Count_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_ARG_COUNT))
+#define Elambda_Formals_Count(Addr) \
+ ((((long) Addr) & EL_FORMALS_MASK) >> EL_FORMALS_SHIFT)
+#define Elambda_Opts_Count(Addr) \
+ (((long) Addr) & EL_OPTS_MASK)
+#define Elambda_Rest_Flag(Addr) \
+ ((((long) Addr) & EL_REST_MASK) >> EL_REST_SHIFT)
+
+ Apply_Future_Check(Lambda_Expr,
+ Fast_Vector_Ref(Function,
+ PROCEDURE_LAMBDA_EXPR));
+ Apply_Future_Check(Temp, Fast_Vector_Ref(Lambda_Expr,
+ ELAMBDA_NAMES));
+ NParams = Vector_Length(Temp) - 1;
+ Apply_Future_Check(Temp, Get_Count_Elambda(Lambda_Expr));
+ Formals = Elambda_Formals_Count(Temp);
+ /* Formals DOES NOT include the name of the lambda */
+ Params = Elambda_Opts_Count(Temp) + Formals;
+ Rest_Flag = Elambda_Rest_Flag(Temp);
+ NArgs = Get_Integer(Pop()) - 1;
+ Auxes = NParams - (Params + Rest_Flag);
+ if ((NArgs < Formals) ||
+ (!Rest_Flag && (NArgs > Params)))
+ { Push(STACK_FRAME_HEADER+NArgs);
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ Size = Params + Rest_Flag + Auxes +
+ (HEAP_ENV_EXTRA_SLOTS + 1);
+ List_Car = Free + Size;
+ if (GC_Check(Size + ((NArgs > Params) ?
+ 2 * (NArgs - Params) : 0)))
+ { Push(STACK_FRAME_HEADER+NArgs);
+ Prepare_Apply_Interrupt();
+ Immediate_GC(Size + ((NArgs > Params) ?
+ 2 * (NArgs - Params) : 0));
+ }
+ Store_Env(Make_Pointer(TC_ENVIRONMENT, Free));
+ *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size-1);
+ /* Environment Header */
+ *Free++ = NIL; /* Aux list */
+ *Free++ = NIL; /* PD list */
+ Size = 1 + ((NArgs < Params) ? NArgs : Params);
+ for (i = 0; i < Size; i++) *Free++ = Pop();
+ for (i--; i < Params; i++)
+ *Free++ = UNASSIGNED_OBJECT;
+ if (Rest_Flag)
+ if (NArgs <= i) *Free++ = NIL;
+ else
+ { *Free++ = Make_Pointer(TC_LIST, List_Car);
+ for (; i < NArgs; i++, List_Car++)
+ { *List_Car++ = Pop();
+ *List_Car = Make_Pointer(TC_LIST, List_Car+1);
+ }
+ List_Car[-1] = NIL;
+ }
+ for (i = 0; i < Auxes; i++) *Free++ = UNASSIGNED_OBJECT;
+ Free = List_Car;
+ Reduces_To(Get_Body_Elambda(Lambda_Expr));
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_PRIMITIVE:
+ { long Number_Of_Args = N_Args_Primitive(Function);
+ if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
+ STACK_ENV_FIRST_ARG+Number_Of_Args-1)
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
+ /* Remove the frame overhead, since the primitives
+ just expect arguments on the stack */
+ Store_Expression(Function);
+ goto Prim_No_Trap_Apply;
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_COMPILED_PROCEDURE:
+ { apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
+ Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
+ Export_Registers();
+ Which_Way = apply_compiled_procedure();
+
+return_from_compiled_code:
+ Import_Registers();
+ switch (Which_Way)
+ {
+ case PRIM_DONE:
+ { compiled_code_done();
+ goto Pop_Return;
+ }
+
+ case PRIM_APPLY:
+ { compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS +
+ Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
+ goto Internal_Apply;
+ }
+
+ case ERR_COMPILED_CODE_ERROR:
+ { /* The compiled code is signalling a microcode error. */
+ compiled_error_backout();
+ /* The Save_Cont is done by Pop_Return_Error. */
+ Pop_Return_Error( compiled_code_error_code);
+ }
+
+ case PRIM_INTERRUPT:
+ { compiled_error_backout();
+ Save_Cont();
+ Interrupt( (IntCode & IntEnb));
+ }
+\f
+ case ERR_WRONG_NUMBER_OF_ARGUMENTS:
+ { apply_compiled_backout();
+ Apply_Error( Which_Way);
+ }
+
+ case ERR_EXECUTE_MANIFEST_VECTOR:
+ { /* This error code means that enter_compiled_expression
+ was called in a system without compiler support.
+ */
+ execute_compiled_backout();
+ Val = Make_Non_Pointer( TC_COMPILED_EXPRESSION,
+ Fetch_Expression());
+ Pop_Return_Error( Which_Way);
+ }
+
+ case ERR_INAPPLICABLE_OBJECT:
+ { /* This error code means that apply_compiled_procedure
+ was called in a system without compiler support.
+ */
+ apply_compiled_backout();
+ Apply_Error( Which_Way);
+ }
+
+ case ERR_INAPPLICABLE_CONTINUATION:
+ { /* This error code means that return_to_compiled_code
+ or some other compiler continuation was called in a
+ system without compiler support.
+ */
+ Store_Expression(NIL);
+ Store_Return(RC_REENTER_COMPILED_CODE);
+ Pop_Return_Error(Which_Way);
+ }
+
+ default: Microcode_Termination( TERM_COMPILER_DEATH);
+ }
+ }
+
+ default:
+ Apply_Error(ERR_INAPPLICABLE_OBJECT);
+ } /* End of switch in RC_INTERNAL_APPLY */
+ } /* End of RC_INTERNAL_APPLY case */
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_MOVE_TO_ADJACENT_POINT:
+ /* Expression contains the space in which we are moving */
+ { long From_Count = Get_Integer(Stack_Ref(TRANSLATE_FROM_DISTANCE));
+ Pointer Thunk, New_Location;
+ if (From_Count != 0)
+ { Pointer Current = Stack_Ref(TRANSLATE_FROM_POINT);
+ Stack_Ref(TRANSLATE_FROM_DISTANCE) = FIXNUM_0+(From_Count-1);
+ Thunk = Fast_Vector_Ref(Current, STATE_POINT_AFTER_THUNK);
+ New_Location = Fast_Vector_Ref(Current, STATE_POINT_NEARER_POINT);
+ Stack_Ref(TRANSLATE_FROM_POINT) = New_Location;
+ if ((From_Count == 1) &&
+ (Stack_Ref(TRANSLATE_TO_DISTANCE) == FIXNUM_0))
+ Stack_Pointer = Simulate_Popping(4);
+ else Save_Cont();
+ }
+ else
+ { long To_Count = Get_Integer(Stack_Ref(TRANSLATE_TO_DISTANCE))-1;
+ fast Pointer To_Location = Stack_Ref(TRANSLATE_TO_POINT);
+ fast long i;
+ for (i=0; i < To_Count; i++)
+ To_Location = Fast_Vector_Ref(To_Location, STATE_POINT_NEARER_POINT);
+ Thunk = Fast_Vector_Ref(To_Location, STATE_POINT_BEFORE_THUNK);
+ New_Location = To_Location;
+ Stack_Ref(TRANSLATE_TO_DISTANCE) = FIXNUM_0+To_Count;
+ if (To_Count==0)
+ Stack_Pointer = Simulate_Popping(4);
+ else Save_Cont();
+ }
+ if (Fetch_Expression() != NIL)
+ Vector_Set(Fetch_Expression(), STATE_SPACE_NEAREST_POINT, New_Location);
+ else Current_State_Point = New_Location;
+ Will_Push(2);
+ Push(Thunk);
+ Push(STACK_FRAME_HEADER);
+ Pushed();
+ goto Internal_Apply;
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_INVOKE_STACK_THREAD:
+ /* Used for WITH_THREADED_STACK primitive */
+ Will_Push(3);
+ Push(Val); /* Value calculated by thunk */
+ Push(Fetch_Expression());
+ Push(STACK_FRAME_HEADER+1);
+ Pushed();
+ goto Internal_Apply;
+
+ case RC_JOIN_STACKLETS:
+ Our_Throw(true, Fetch_Expression());
+ Join_Stacklet_Backout();
+ Our_Throw_Part_2();
+ break;
+
+ case RC_NORMAL_GC_DONE:
+ End_GC_Hook();
+ if (GC_Check(GC_Space_Needed))
+ { printf("\nGC just ended. The free pointer is at 0x%x, the top of this heap\n",
+ Free);
+ printf("is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n",
+ MemTop, GC_Space_Needed);
+ Microcode_Termination(TERM_EXIT);
+ }
+ GC_Space_Needed = 0;
+ Val = Fetch_Expression();
+ break;
+\f
+ case RC_PCOMB1_APPLY:
+ End_Subproblem();
+ Push(Val); /* Argument value */
+ Finished_Eventual_Pushing();
+ Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB1_FN_SLOT));
+ goto Primitive_Internal_Apply;
+
+ case RC_PCOMB2_APPLY:
+ End_Subproblem();
+ Push(Val); /* Value of arg. 1 */
+ Finished_Eventual_Pushing();
+ Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB2_FN_SLOT));
+ goto Primitive_Internal_Apply;
+
+ case RC_PCOMB2_DO_1:
+ Restore_Env();
+ Push(Val); /* Save value of arg. 2 */
+ Do_Another_Then(RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT);
+
+ case RC_PCOMB3_APPLY:
+ End_Subproblem();
+ Push(Val); /* Save value of arg. 1 */
+ Finished_Eventual_Pushing();
+ Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB3_FN_SLOT));
+ goto Primitive_Internal_Apply;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_PCOMB3_DO_1:
+ { Pointer Temp;
+ Temp = Pop(); /* Value of arg. 3 */
+ Restore_Env();
+ Push(Temp); /* Save arg. 3 again */
+ Push(Val); /* Save arg. 2 */
+ Do_Another_Then(RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT);
+ }
+
+ case RC_PCOMB3_DO_2:
+ Restore_Then_Save_Env();
+ Push(Val); /* Save value of arg. 3 */
+ Do_Another_Then(RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT);
+
+ case RC_POP_RETURN_ERROR:
+ case RC_RESTORE_VALUE:
+ Val = Fetch_Expression();
+ break;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_PURIFY_GC_1:
+ { Pointer GC_Daemon_Proc, Result;
+ Export_Registers();
+ Result = Purify_Pass_2(Fetch_Expression());
+ Import_Registers();
+ if (Result == NIL)
+ { /* The object does not fit in Constant space.
+ There is no need to run the daemons, and we should let the runtime
+ system know what happened.
+ */
+ Val = NIL;
+ break;
+ }
+ GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
+ if (GC_Daemon_Proc==NIL)
+ { Val = TRUTH;
+ break;
+ }
+ Store_Expression(NIL);
+ Store_Return(RC_PURIFY_GC_2);
+ Save_Cont();
+ Will_Push(2);
+ Push(GC_Daemon_Proc);
+ Push(STACK_FRAME_HEADER);
+ Pushed();
+ goto Internal_Apply;
+ }
+
+ case RC_PURIFY_GC_2:
+ Val = TRUTH;
+ break;
+
+ case RC_REPEAT_DISPATCH:
+ Sign_Extend(Fetch_Expression(), Which_Way);
+ Restore_Env();
+ Val = Pop();
+ Restore_Cont();
+ goto Repeat_Dispatch;
+
+ case RC_REPEAT_PRIMITIVE:
+ if (Type_Code(Fetch_Expression()) == TC_PRIMITIVE_EXTERNAL)
+ goto Repeat_External_Primitive;
+ else goto Primitive_Internal_Apply;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+/* The following two return codes are both used to restore
+ a saved history object. The difference is that the first
+ does not copy the history object while the second does.
+ In both cases, the Expression register contains the history
+ object and the next item to be popped off the stack contains
+ the offset back to the previous restore history return code.
+
+ ASSUMPTION: History objects are never created using futures.
+*/
+
+ case RC_RESTORE_DONT_COPY_HISTORY:
+ { Pointer Stacklet;
+ Previous_Restore_History_Offset = Get_Integer(Pop());
+ Stacklet = Pop();
+ History = Get_Pointer(Fetch_Expression());
+ if (Previous_Restore_History_Offset == 0)
+ Previous_Restore_History_Stacklet = NULL;
+ else if (Stacklet == NIL)
+ Previous_Restore_History_Stacklet = NULL;
+ else
+ Previous_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ break;
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_RESTORE_HISTORY:
+ { Pointer Stacklet;
+ Export_Registers();
+ if (! Restore_History(Fetch_Expression()))
+ { Import_Registers();
+ Save_Cont();
+ Will_Push(CONTINUATION_SIZE);
+ Store_Expression(Val);
+ Store_Return(RC_RESTORE_VALUE);
+ Save_Cont();
+ Pushed();
+ Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1));
+ }
+ Import_Registers();
+ Previous_Restore_History_Offset = Get_Integer(Pop());
+ Stacklet = Pop();
+ if (Previous_Restore_History_Offset == 0)
+ Previous_Restore_History_Stacklet = NULL;
+ else
+ { if (Stacklet == NIL)
+ { Previous_Restore_History_Stacklet = NULL;
+ Get_End_Of_Stacklet()[-Previous_Restore_History_Offset] =
+ Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
+ }
+ else
+ { Previous_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ Previous_Restore_History_Stacklet[-Previous_Restore_History_Offset] =
+ Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
+ }
+ }
+ break;
+ }
+
+ case RC_RESTORE_FLUIDS:
+ Fluid_Bindings = Fetch_Expression();
+ New_Compiler_MemTop();
+ break;
+
+ case RC_RESTORE_INT_MASK:
+ IntEnb = Get_Integer(Fetch_Expression());
+ New_Compiler_MemTop();
+ break;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_RESTORE_TO_STATE_POINT:
+ { Pointer Where_To_Go = Fetch_Expression();
+ Will_Push(CONTINUATION_SIZE);
+ /* Restore the contents of Val after moving to point */
+ Store_Expression(Val);
+ Store_Return(RC_RESTORE_VALUE);
+ Save_Cont();
+ Pushed();
+ Export_Registers();
+ Translate_To_Point(Where_To_Go);
+ break; /* We never get here.... */
+ }
+
+/* case RC_RESTORE_VALUE is with RC_POP_RETURN_ERROR */
+
+ case RC_RETURN_TRAP_POINT:
+ Store_Return(Old_Return_Code);
+ Will_Push(CONTINUATION_SIZE+3);
+ Save_Cont();
+ Return_Hook_Address = NULL;
+ Stop_Trapping();
+ Push(Val);
+ Push(Fetch_Return_Trapper());
+ Push(STACK_FRAME_HEADER+1);
+ Pushed();
+ goto Apply_Non_Trapping;
+
+ case RC_SEQ_2_DO_2:
+ End_Subproblem();
+ Restore_Env();
+ Reduces_To_Nth(SEQUENCE_2);
+
+ case RC_SEQ_3_DO_2:
+ Restore_Then_Save_Env();
+ Do_Another_Then(RC_SEQ_3_DO_3, SEQUENCE_2);
+
+ case RC_SEQ_3_DO_3:
+ End_Subproblem();
+ Restore_Env();
+ Reduces_To_Nth(SEQUENCE_3);
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_SNAP_NEED_THUNK:
+ Vector_Set(Fetch_Expression(), THUNK_SNAPPED, TRUTH);
+ Vector_Set(Fetch_Expression(), THUNK_VALUE, Val);
+ break;
+
+ case RC_AFTER_MEMORY_UPDATE:
+ case RC_BAD_INTERRUPT_CONTINUE:
+ case RC_COMPLETE_GC_DONE:
+ case RC_RESTARTABLE_EXIT:
+ case RC_RESTART_EXECUTION:
+ case RC_RESTORE_CONTINUATION:
+ case RC_RESTORE_STEPPER:
+ case RC_POP_FROM_COMPILED_CODE:
+ Export_Registers();
+ Microcode_Termination(TERM_UNIMPLEMENTED_CONTINUATION);
+
+ default:
+ Export_Registers();
+ Microcode_Termination(TERM_NON_EXISTENT_CONTINUATION);
+ };
+ goto Pop_Return;
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: interpret.h
+ *
+ * Macros used by the interpreter and some utilities.
+ *
+ */
+\f
+ /********************/
+ /* OPEN CODED RACKS */
+ /********************/
+
+#ifndef ENABLE_DEBUGGING_TOOLS
+#ifdef In_Main_Interpreter
+#define Using_Registers
+#endif
+#endif
+
+#ifdef Using_Registers
+#define Val Reg_Val
+#define Stack_Pointer Reg_Stack_Pointer
+#define Expression Reg_Expression
+#else
+#define Val Ext_Val
+#define Stack_Pointer Ext_Stack_Pointer
+#define Expression Ext_Expression
+#endif
+
+/* Internal_Will_Push is in stack.h. */
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+#define Will_Push(N) \
+{ Pointer *Will_Push_Limit; \
+ Internal_Will_Push((N)); \
+ Will_Push_Limit = Simulate_Pushing(N)
+
+#define Pushed() \
+ if (Stack_Pointer < Will_Push_Limit) Stack_Death(); \
+}
+
+#else
+#define Will_Push(N) Internal_Will_Push(N)
+#define Pushed() /* No op */
+#endif
+
+#define Will_Eventually_Push(N) Internal_Will_Push(N)
+#define Finished_Eventual_Pushing() /* No op */
+\f
+/* Primitive stack operations:
+ * These operations hide the direction of stack growth.
+ * Throw in stack.h, Allocate_New_Stacklet in utils.c, apply, cwcc and
+ * friends in hooks.c, and possibly other stuff, depend on the direction in
+ * which the stack grows.
+ */
+
+#define Push(P) *--Stack_Pointer = (P)
+#define Pop() (*Stack_Pointer++)
+#define Stack_Ref(N) (Stack_Pointer[(N)])
+#define Simulate_Pushing(N) (Stack_Pointer - (N))
+#define Simulate_Popping(N) (Stack_Pointer + (N))
+
+#define Top_Of_Stack() Stack_Ref(0)
+#define Stack_Distance(previous_top_of_stack) \
+ ((previous_top_of_stack) - (&Top_Of_Stack()))
+
+/* These can be used when SP is a pointer into the stack, to make
+ * stack gap operations independent of the direction of stack growth.
+ * They must match Push and Pop above.
+ */
+
+#define Push_From(SP) *--(SP)
+#define Pop_Into(SP, What) (*(SP)++) = (What)
+\f
+/* Stack Gap Operations: */
+
+/* With_Stack_Gap opens a gap Gap_Size wide Gap_Position cells above the
+ * top of the stack. Code must push Gap_Size objects. It executes Code
+ * with the stack pointer placed so that these objects will fill the gap.
+ */
+
+#define With_Stack_Gap(Gap_Size, Gap_Position, Code) \
+{ Pointer *Saved_Destination; \
+ fast Pointer *Destination; \
+ fast long size_to_move = (Gap_Position); \
+ Destination = Simulate_Pushing(Gap_Size); \
+ Saved_Destination = Destination; \
+ while (--size_to_move >= 0) \
+ Pop_Into(Destination, Pop()); \
+ Code; \
+ Stack_Pointer = Saved_Destination; \
+}
+
+/* Close_Stack_Gap closes a gap Gap_Size wide Gap_Position cells above the
+ * top of the stack. The contents of the gap are lost.
+ */
+
+#define Close_Stack_Gap(Gap_Size, Gap_Position, extra_code) \
+{ fast long size_to_move = (Gap_Position); \
+ fast Pointer *Source = Simulate_Popping(size_to_move); \
+ Stack_Pointer = Simulate_Popping((Gap_Size) + size_to_move); \
+ extra_code; \
+ while (--size_to_move >= 0) \
+ Push(Push_From(Source)); \
+}
+
+/* Racks operations continue on the next page */
+\f
+/* Rack operations, continued */
+
+/* Fetch from register */
+
+#define Fetch_Expression() Expression
+#define Fetch_Env() Env
+#define Fetch_Return() Return
+
+/* Store into register */
+
+#define Store_Expression(P) Expression = (P)
+#define Store_Env(P) Env = (P)
+#define Store_Return(P) \
+ Return = Make_Non_Pointer(TC_RETURN_CODE, (P))
+
+/* Note: Save_Cont must match the definitions in sdata.h */
+
+#define Save_Cont() { Push(Expression); \
+ Push(Return); \
+ Cont_Print(); \
+ }
+
+#define Restore_Cont() { Return = Pop(); \
+ Expression = Pop(); \
+ if (Cont_Debug) \
+ { Print_Return(RESTORE_CONT_RETURN_MESSAGE); \
+ Print_Expression(Fetch_Expression(), \
+ RESTORE_CONT_EXPR_MESSAGE);\
+ CRLF(); \
+ } \
+ }
+
+#define Cont_Print() if (Cont_Debug) \
+ { Print_Return(CONT_PRINT_RETURN_MESSAGE); \
+ Print_Expression(Fetch_Expression(), \
+ CONT_PRINT_EXPR_MESSAGE); \
+ CRLF(); \
+ }
+
+/* Racks operations continue on the next page */
+\f
+/* Rack operations continued */
+
+#define Save_Env() Push(Env)
+#define Restore_Env() Env = Pop()
+#define Restore_Then_Save_Env() Env = Top_Of_Stack()
+
+/* Move from register to static storage and back */
+
+#ifdef Using_Registers
+#define Import_Val() Reg_Val = Ext_Val
+
+#define Import_Registers_Except_Val() \
+ { Reg_Expression = Ext_Expression; \
+ Reg_Stack_Pointer = Ext_Stack_Pointer;\
+ }
+
+#define Import_Registers() \
+ { Import_Registers_Except_Val(); \
+ Import_Val(); \
+ }
+
+#define Export_Registers() { Ext_Val = Reg_Val; \
+ Ext_Expression = Reg_Expression; \
+ Ext_Stack_Pointer = Reg_Stack_Pointer;\
+ }
+#else
+#define Import_Val()
+#define Import_Registers()
+#define Import_Registers_Except_Val()
+#define Export_Registers()
+#endif
+\f
+/* Random utility macros */
+
+#define Pop_Primitive_Frame(NArgs) \
+ Stack_Pointer = Simulate_Popping(NArgs)
+
+#define N_Args_Primitive(Function) \
+ ((int) Arg_Count_Table[Get_Integer(Function)])
+
+#define Stop_Trapping() \
+{ Trapping = false; \
+ if (Return_Hook_Address != NULL) \
+ *Return_Hook_Address = Old_Return_Code; \
+ Return_Hook_Address = NULL; \
+}
+\f
+/* Compiled code utility macros */
+
+/* Going from interpreted code to compiled code */
+
+/* Tail recursion is handled as follows:
+ if the return code is `reenter_compiled_code', it is discarded,
+ and the two contiguous interpreter segments on the stack are
+ merged.
+ */
+
+/* Apply interface:
+ calling a compiled procedure with a frame nslots long.
+ */
+
+#define apply_compiled_setup(nslots) \
+{ long frame_size = (nslots); \
+ if (Stack_Ref(frame_size + CONTINUATION_RETURN_CODE) == \
+ (Make_Non_Pointer(TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
+ { /* Merge compiled code segments on the stack. */ \
+ Close_Stack_Gap(CONTINUATION_SIZE, \
+ frame_size, \
+ { long segment_size = \
+ Datum(Stack_Ref(CONTINUATION_EXPRESSION - \
+ CONTINUATION_SIZE)); \
+ last_return_code = Simulate_Popping(segment_size); \
+ }); \
+ /* Undo the subproblem rotation. */ \
+ Compiler_End_Subproblem(); \
+ } \
+ else \
+ { /* Make a new compiled code segment which includes this frame. */ \
+ /* History need not be hacked here. */ \
+ With_Stack_Gap(1, \
+ frame_size, \
+ { last_return_code = &Top_Of_Stack(); \
+ Push(return_to_interpreter); \
+ }); \
+ } \
+}
+\f
+/* Eval interface:
+ executing a compiled expression.
+ */
+
+#define execute_compiled_setup() \
+{ if (Stack_Ref(CONTINUATION_RETURN_CODE) == \
+ (Make_Non_Pointer(TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
+ { /* Merge compiled code segments on the stack. */ \
+ long segment_size; \
+ Restore_Cont(); \
+ segment_size = Datum(Fetch_Expression()); \
+ last_return_code = Simulate_Popping(segment_size); \
+ /* Undo the subproblem rotation. */ \
+ Compiler_End_Subproblem(); \
+ } \
+ else \
+ { /* Make a new compiled code segment on the stack. */ \
+ /* History need not be hacked here. */ \
+ last_return_code = &Top_Of_Stack(); \
+ Push(return_to_interpreter); \
+ } \
+}
+
+/* Pop return interface:
+ Returning to compiled code from the interpreter.
+ */
+
+#define compiled_code_restart() \
+{ long segment_size; \
+ segment_size = Datum(Fetch_Expression()); \
+ last_return_code = Simulate_Popping(segment_size); \
+ /* Undo the subproblem rotation. */ \
+ Compiler_End_Subproblem(); \
+}
+\f
+/* Going from compiled code to interpreted code */
+
+/* Tail recursion is handled in the following way:
+ if the return address is `return_to_interpreter', it is discarded,
+ and the two contiguous interpreter segments on the stack are
+ merged.
+ */
+
+/* Apply interface:
+ calling an interpreted procedure (or unsafe primitive)
+ with a frame nslots long.
+ */
+
+#define compiler_apply_procedure(nslots) \
+{ long frame_size = (nslots); \
+ if (Stack_Ref( frame_size) == return_to_interpreter) \
+ { \
+ Close_Stack_Gap(1, frame_size, {}); \
+ /* Set up the current rib. */ \
+ Compiler_New_Reduction(); \
+ } \
+ else \
+ { /* Make a new interpreter segment which includes this frame. */ \
+ With_Stack_Gap(CONTINUATION_SIZE, \
+ frame_size, \
+ { long segment_size = Stack_Distance(last_return_code); \
+ Store_Expression(Make_Unsigned_Fixnum(segment_size)); \
+ Store_Return(RC_REENTER_COMPILED_CODE); \
+ Save_Cont(); \
+ }); \
+ /* Rotate history to a new subproblem. */ \
+ Compiler_New_Subproblem(); \
+ } \
+}
+
+/* Pop Return interface:
+ returning to the interpreter from compiled code.
+ Nothing needs to be done at this time.
+ */
+
+#define compiled_code_done()
+\f
+/* Various handlers for backing out of compiled code. */
+
+/* Backing out of apply. */
+
+#define apply_compiled_backout() \
+{ compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS + \
+ Get_Integer( Stack_Ref( STACK_ENV_HEADER))); \
+}
+
+/* Backing out of eval. */
+
+#define execute_compiled_backout() \
+{ if (Top_Of_Stack() == return_to_interpreter) \
+ { \
+ Simulate_Popping(1); \
+ /* Set up the current rib. */ \
+ Compiler_New_Reduction(); \
+ } \
+ else \
+ { long segment_size = Stack_Distance(last_return_code); \
+ Store_Expression(Make_Unsigned_Fixnum(segment_size)); \
+ Store_Return(RC_REENTER_COMPILED_CODE); \
+ Save_Cont(); \
+ /* Rotate history to a new subproblem. */ \
+ Compiler_New_Subproblem(); \
+ } \
+}
+
+/* Backing out because of special errors or interrupts.
+ The microcode has already setup a return code with a NIL.
+ No tail recursion in this case.
+ ***
+ Is the history manipulation correct?
+ Does Microcode_Error do something special?
+ ***
+ */
+
+#define compiled_error_backout() \
+{ long segment_size; \
+ Restore_Cont(); \
+ segment_size = Stack_Distance(last_return_code); \
+ Store_Expression(Make_Unsigned_Fixnum(segment_size)); \
+ /* The Store_Return is a NOP, the Save_Cont is done by the code \
+ that follows. \
+ */ \
+ /* Store_Return(Datum(Fetch_Return())); */ \
+ /* Save_Cont(); */ \
+ Compiler_New_Subproblem(); \
+}
--- /dev/null
+/* 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: LIST.C
+ *
+ * List creation and manipulation primitives.
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+\f
+/* (CONS LEFT RIGHT)
+ [Primitive number 0x20]
+ Creates a pair with left component LEFT and right component
+ RIGHT.
+*/
+Built_In_Primitive(Prim_Cons, 2, "CONS")
+{ Primitive_2_Args();
+ Primitive_GC_If_Needed(2);
+ *Free++ = Arg1;
+ *Free++ = Arg2;
+ return Make_Pointer(TC_LIST, Free-2);
+}
+
+/* (CDR PAIR)
+ [Primitive number 0x22]
+ Returns the second element in the pair. By convention, (CAR
+ NIL) is NIL.
+*/
+Built_In_Primitive(Prim_Cdr, 1, "CDR")
+{ Primitive_1_Arg();
+ if (Arg1 == NIL) return NIL;
+ Arg_1_Type(TC_LIST);
+ return Vector_Ref(Arg1, CONS_CDR);
+}
+
+/* (CAR PAIR)
+ [Primitive number 0x21]
+ Returns the first element in the pair. By convention, (CAR NIL)
+ is NIL.
+*/
+Built_In_Primitive(Prim_Car, 1, "CAR")
+{ Primitive_1_Arg();
+ if (Arg1 == NIL) return NIL;
+ Arg_1_Type(TC_LIST);
+ return Vector_Ref(Arg1, CONS_CAR);
+}
+\f
+/* (GENERAL_CAR_CDR LIST DIRECTIONS)
+ [Primitive number 0x27]
+ DIRECTIONS encodes a string of CAR and CDR operations to be
+ performed on LIST as follows:
+ 1 = NOP 101 = CDAR
+ 10 = CDR 110 = CADR
+ 11 = CAR 111 = CAAR
+ 100 = CDDR ...
+*/
+Built_In_Primitive(Prim_General_Car_Cdr, 2, "GENERAL-CAR-CDR")
+{ fast long CAR_CDR_Pattern;
+ Primitive_2_Args();
+ Arg_2_Type(TC_FIXNUM);
+ CAR_CDR_Pattern = Get_Integer(Arg2);
+ while (CAR_CDR_Pattern > 1)
+ { Touch_In_Primitive(Arg1, Arg1);
+ if (Arg1 == NIL) return NIL;
+ if (Type_Code(Arg1) != TC_LIST)
+ Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ Arg1 =
+ Vector_Ref(Arg1,
+ ((CAR_CDR_Pattern & 1) == 0) ? CONS_CDR : CONS_CAR);
+ CAR_CDR_Pattern >>= 1;
+ }
+ return Arg1;
+}
+\f
+/* (ASSQ ITEM A-LIST)
+ Searches the association list A-LIST for ITEM, using EQ? for
+ testing equality. Returns NIL if ITEM is not found, or the tail
+ of the list whose CAAR is ITEM.
+*/
+Built_In_Primitive(Prim_Assq, 2, "ASSQ")
+{ Pointer This_Assoc_Pair, Key;
+ Primitive_2_Args();
+
+ Touch_In_Primitive(Arg1, Arg1);
+ Touch_In_Primitive(Arg2, Arg2);
+ while (Type_Code(Arg2) == TC_LIST)
+ { Touch_In_Primitive(Vector_Ref(Arg2, CONS_CAR), This_Assoc_Pair);
+ if (Type_Code(This_Assoc_Pair) != TC_LIST)
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ Touch_In_Primitive(Vector_Ref(This_Assoc_Pair, CONS_CAR), Key);
+ if (Key == Arg1) return This_Assoc_Pair;
+ Touch_In_Primitive(Vector_Ref(Arg2, CONS_CDR), Arg2);
+ }
+ if (Arg2 != NIL) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ return NIL;
+}
+
+/* (LENGTH LIST)
+ [Primitive number 0x5D]
+ Returns the number of items in the list. By convention, (LENGTH
+ NIL) is 0. LENGTH will loop forever if given a circular
+ structure.
+*/
+Built_In_Primitive(Prim_Length, 1, "LENGTH")
+{ fast long i;
+ Primitive_1_Arg();
+ i = 0;
+ Touch_In_Primitive(Arg1, Arg1);
+ while (Type_Code(Arg1) == TC_LIST)
+ { i += 1;
+ Touch_In_Primitive(Vector_Ref(Arg1, CONS_CDR), Arg1);
+ }
+ if (Arg1 != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ return FIXNUM_0+i;
+}
+\f
+/* (MEMQ ITEM LIST)
+ [Primitive number 0x1C]
+ Searches LIST for ITEM, using EQ? as a test. Returns NIL if it
+ is not found, or the [first] tail of LIST whose CAR is ITEM.
+*/
+Built_In_Primitive(Prim_Memq, 2, "MEMQ")
+{ fast Pointer Key;
+ Primitive_2_Args();
+ Touch_In_Primitive(Arg1, Arg1);
+ Touch_In_Primitive(Arg2, Arg2);
+ while (Type_Code(Arg2) == TC_LIST)
+ { Touch_In_Primitive(Vector_Ref(Arg2, CONS_CAR), Key);
+ if (Arg1 == Key) return Arg2;
+ else Touch_In_Primitive(Vector_Ref(Arg2, CONS_CDR), Arg2);
+ }
+ if (Arg2 != NIL) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ return NIL;
+}
+
+/* (SET_CAR PAIR VALUE)
+ [Primitive number 0x23]
+ Stores VALUE in the CAR of PAIR. Returns (bad style to count on
+ this) the previous CAR of PAIR.
+*/
+Built_In_Primitive(Prim_Set_Car, 2, "SET-CAR!")
+{ Primitive_2_Args();
+ Arg_1_Type(TC_LIST);
+ Side_Effect_Impurify(Arg1, Arg2);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CAR), Arg2);
+}
+
+/* (SET_CDR PAIR VALUE)
+ [Primitive number 0x24]
+ Stores VALUE in the CDR of PAIR. Returns (bad style to count on
+ this) the previous CDR of PAIR.
+*/
+Built_In_Primitive(Prim_Set_Cdr, 2, "SET-CDR!")
+{ Primitive_2_Args();
+ Arg_1_Type(TC_LIST);
+ Side_Effect_Impurify(Arg1, Arg2);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CDR), Arg2);
+}
+\f
+/* (PAIR OBJECT)
+ [Primitive number 0x7E]
+ Returns #!TRUE if OBJECT has the type-code LIST (ie if it was
+ created by CONS). Return NIL otherwise.
+*/
+Built_In_Primitive(Prim_Pair, 1, "PAIR?")
+{ Primitive_1_Arg();
+ Touch_In_Primitive(Arg1, Arg1);
+ if (Type_Code(Arg1) == TC_LIST) return TRUTH;
+ else return NIL;
+}
+
+/* (SYS_PAIR OBJECT)
+ [Primitive number 0x85]
+ Returns #!TRUE if the garbage collector type of OBJECT is PAIR.
+*/
+Built_In_Primitive(Prim_Sys_Pair, 1, "SYSTEM-PAIR?")
+{ Primitive_1_Arg();
+ Touch_In_Primitive(Arg1, Arg1);
+ if (GC_Type_List(Arg1)) return TRUTH;
+ else return NIL;
+}
+\f
+/* (SYS_PAIR_CAR GC-PAIR)
+ [Primitive number 0x86]
+ Same as CAR, but for anything of GC type PAIR.
+*/
+Built_In_Primitive(Prim_Sys_Pair_Car, 1, "SYSTEM-PAIR-CAR")
+{ Primitive_1_Arg();
+ Arg_1_GC_Type(GC_Pair);
+ return Vector_Ref(Arg1, CONS_CAR);
+}
+
+/* (SYS_PAIR_CDR GC-PAIR)
+ [Primitive number 0x87]
+ Same as CDR, but for anything of GC type PAIR.
+*/
+Built_In_Primitive(Prim_Sys_Pair_Cdr, 1, "SYSTEM-PAIR-CDR")
+{ Primitive_1_Arg();
+ Arg_1_GC_Type(GC_Pair);
+ return Vector_Ref(Arg1, CONS_CDR);
+}
+
+/* (SYS_PAIR_CONS TYPE-CODE OBJECT-1 OBJECT-2)
+ [Primitive number 0x84]
+ Like CONS, but returns an object with the specified type code
+ (not limited to type code LIST).
+*/
+Built_In_Primitive(Prim_Sys_Pair_Cons, 3, "SYSTEM-PAIR-CONS")
+{ long Type;
+ Primitive_3_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Range_Check(Type, Arg1, 0, MAX_SAFE_TYPE,
+ ERR_ARG_1_BAD_RANGE);
+ if (GC_Type_Code(Type) == GC_Pair)
+ { Primitive_GC_If_Needed(2);
+ *Free++ = Arg2;
+ *Free++ = Arg3;
+ return Make_Pointer(Type, Free-2);
+ }
+ else Primitive_Error(ERR_ARG_1_BAD_RANGE); /*NOTREACHED*/
+}
+
+\f
+/* (SYS_SET_CAR GC-PAIR NEW_CAR)
+ [Primitive number 0x88]
+ Same as SET_CAR, but for anything of GC type PAIR.
+*/
+Built_In_Primitive(Prim_Sys_Set_Car, 2, "SYSTEM-PAIR-SET-CAR!")
+{ Primitive_2_Args();
+ Arg_1_GC_Type(GC_Pair);
+ Side_Effect_Impurify(Arg1, Arg2);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CAR), Arg2);
+}
+
+/* (SYS_SET_CDR GC-PAIR NEW_CDR)
+ [Primitive number 0x89]
+ Same as SET_CDR, but for anything of GC type PAIR.
+*/
+Built_In_Primitive(Prim_Sys_Set_Cdr, 2, "SYSTEM-PAIR-SET-CDR!")
+{ Primitive_2_Args();
+ Arg_1_GC_Type(GC_Pair);
+ Side_Effect_Impurify(Arg1, Arg2);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CDR), Arg2);
+}
+
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: LOAD.C
+ *
+ * This file contains common code for reading internal
+ * format binary files.
+ *
+ */
+\f
+#include "fasl.h"
+
+/* Static storage for some shared variables */
+
+long Heap_Count, Const_Count,
+ Version, Sub_Version, Machine_Type, Ext_Prim_Count,
+ Heap_Base, Const_Base, Dumped_Object,
+ Dumped_Heap_Top, Dumped_Constant_Top, Dumped_Stack_Top;
+Pointer Ext_Prim_Vector;
+Boolean Found_Ext_Prims;
+
+Boolean Read_Header()
+{ Pointer Buffer[FASL_HEADER_LENGTH];
+ Pointer Pointer_Heap_Base, Pointer_Const_Base;
+ Load_Data(FASL_OLD_LENGTH, (char *) Buffer);
+ if (Buffer[FASL_Offset_Marker] != FASL_FILE_MARKER) return false;
+ Heap_Count = Get_Integer(Buffer[FASL_Offset_Heap_Count]);
+ Pointer_Heap_Base = Buffer[FASL_Offset_Heap_Base];
+ Heap_Base = Datum(Pointer_Heap_Base);
+ Dumped_Object = Datum(Buffer[FASL_Offset_Dumped_Obj]);
+ Const_Count = Get_Integer(Buffer[FASL_Offset_Const_Count]);
+ Pointer_Const_Base = Buffer[FASL_Offset_Const_Base];
+ Const_Base = Datum(Pointer_Const_Base);
+ Version = The_Version(Buffer[FASL_Offset_Version]);
+ Sub_Version = The_Sub_Version(Buffer[FASL_Offset_Version]);
+ Machine_Type = The_Machine_Type(Buffer[FASL_Offset_Version]);
+ Dumped_Stack_Top = Get_Integer(Buffer[FASL_Offset_Stack_Top]);
+ Dumped_Heap_Top =
+ C_To_Scheme(Nth_Vector_Loc(Pointer_Heap_Base, Heap_Count));
+ Dumped_Constant_Top =
+ C_To_Scheme(Nth_Vector_Loc(Pointer_Const_Base, Const_Count));
+ if (Sub_Version >= FASL_LONG_HEADER)
+ { Load_Data(FASL_HEADER_LENGTH-FASL_OLD_LENGTH,
+ (char *) &(Buffer[FASL_OLD_LENGTH]));
+ Ext_Prim_Vector =
+ Make_Non_Pointer(TC_CELL, Datum(Buffer[FASL_Offset_Ext_Loc]));
+ }
+ else Ext_Prim_Vector = NIL;
+ if (Reloc_or_Load_Debug)
+ { printf("\nHeap_Count = %d; Heap_Base = %x; Dumped_Heap_Top = %x\n",
+ Heap_Count, Heap_Base, Dumped_Heap_Top);
+ printf("C_Count = %d; C_Base = %x, Dumped_C_Top = %x\n",
+ Const_Count, Const_Base, Dumped_Constant_Top);
+ printf("Dumped_S_Top = %x, Ext_Prim_Vector = 0x%08x\n",
+ Dumped_Stack_Top, Ext_Prim_Vector);
+ printf("Dumped Object (as read from file) = %x\n", Dumped_Object);
+ }
+ return true;
+}
--- /dev/null
+/* 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: LOCKS.H
+ Contains everything needed to lock and unlock parts of
+ the heap, pure/constant space and the like.
+ It also contains intercommunication stuff as well. */
+
+#define Lock_Handle long * /* Address of lock word */
+#define CONTENTION_DELAY 10 /* For "slow" locks, back off */
+#define Lock_Cell(Cell) NULL /* Start lock */
+#define Unlock_Cell(Cell) /* End lock */
+#define Initialize_Heap_Locks() /* Clear at start up */
+#define Do_Store_No_Lock(To, F) *(To) = F
+#define Sleep(How_Long) { } /* Delay for locks, etc. */
+
+
--- /dev/null
+/* -*-C-*- is a horrible language, and Emacs agrees. */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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: MISSING.C
+ * This file contains utilities potentially missing from the math library
+ */
+
+#ifdef DEBUG_MISSING
+#include "config.h"
+#endif
+
+static Boolean floating_table_initialized = false;
+static double floating_table[(2*FLONUM_EXPT_SIZE)-1];
+static int exponent_table[(2*FLONUM_EXPT_SIZE)-1];
+
+void initialize_floating_table()
+{ register int index, exponent;
+ register int *int_table = &exponent_table[FLONUM_EXPT_SIZE-1];
+ register double *the_table = &floating_table[FLONUM_EXPT_SIZE-1];
+ register double x;
+ the_table[0] = 1.0;
+ int_table[0] = 0;
+ for (x = 2.0, index = 1, exponent = 1;
+ index < FLONUM_EXPT_SIZE;
+ x *= x, index += 1, exponent += exponent)
+ { the_table[index] = x;
+ int_table[index] = exponent;
+ }
+ for (x = 0.5, index = -1, exponent = -1;
+ index > -FLONUM_EXPT_SIZE;
+ x *= x, index -= 1, exponent += exponent)
+ { the_table[index] = x;
+ int_table[index] = exponent;
+ }
+ floating_table_initialized = true;
+ return;
+}
+
+double frexp(value, eptr)
+double value;
+int *eptr;
+{ register double mant;
+ register int exponent, index;
+ register double *the_table = &floating_table[FLONUM_EXPT_SIZE-1];
+ register int *int_table = &exponent_table[FLONUM_EXPT_SIZE-1];
+
+ if (value == 0.0)
+ { *eptr = 0;
+ return 0.0;
+ }
+ if (!floating_table_initialized) initialize_floating_table();
+ mant = ((value < 0.0) ? -value : value);
+ exponent = 0;
+ while (mant < 0.5)
+ { for (index = -FLONUM_EXPT_SIZE+1;
+ the_table[index] < mant;
+ index += 1) ;
+ exponent += int_table[index];
+ mant /= the_table[index];
+ }
+ if (mant >= 1.0)
+ { while (mant >= 2.0)
+ { for (index = FLONUM_EXPT_SIZE-1;
+ the_table[index] > mant;
+ index -= 1) ;
+ exponent += int_table[index];
+ mant /= the_table[index];
+ }
+ mant /= 2.0;
+ exponent += 1;
+ }
+ *eptr = exponent;
+ return ((value < 0.0) ? -mant : mant);
+}
+
+double ldexp(value, exponent)
+register double value;
+register int exponent;
+{ register int index;
+ register double *the_table = &floating_table[FLONUM_EXPT_SIZE-1];
+ register int *int_table = &exponent_table[FLONUM_EXPT_SIZE-1];
+
+ if (value == 0.0) return 0.0;
+ if (!floating_table_initialized) initialize_floating_table();
+ while (exponent > 0)
+ { for(index = FLONUM_EXPT_SIZE-1;
+ int_table[index] > exponent;
+ index -= 1) ;
+ exponent -= int_table[index];
+ value *= the_table[index];
+ }
+ while (exponent < 0)
+ { for(index = -FLONUM_EXPT_SIZE+1;
+ int_table[index] < exponent;
+ index += 1) ;
+ exponent -= int_table[index];
+ value *= the_table[index];
+ }
+ return value;
+}
+
+\f
+#ifdef DEBUG_MISSING
+
+#include <stdio.h>
+
+main()
+{ double input, output;
+ int exponent;
+
+ while (true)
+ { printf("Number -> ");
+ scanf("%F", &input);
+ output = frexp(input, &exponent);
+ printf("Input = %G; Output = %G; Exponent = %d\n",
+ input, output, exponent);
+ printf("Result = %G\n", ldexp(output, exponent));
+ }
+}
+#endif
+
--- /dev/null
+/* Emacs -*-C-*-an't tell the language */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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: MUL.C
+ *
+ * This file contains the portable fixnum multiplication procedure.
+ * Returns NIL if the result does not fit in a fixnum.
+ * Note: This has only been tried on machines with long = 32 bits.
+ * This file is included in the appropriate os file if needed.
+ */
+
+#define HALF_WORD_SIZE ((sizeof(long)*CHAR_SIZE)/2)
+#define HALF_WORD_MASK (1<<HALF_WORD_SIZE)-1
+#define MAX_MIDDLE (1<<((ADDRESS_LENGTH-1)-HALF_WORD_SIZE))
+#define MAX_FIXNUM (1<<ADDRESS_LENGTH)
+#define ABS(x) (((x) < 0) ? -(x) : (x))
+
+Pointer Mul(Arg1, Arg2)
+long Arg1, Arg2;
+{ long A, B, C;
+ fast long Hi_A, Hi_B, Lo_A, Lo_B, Lo_C, Middle_C;
+ Boolean Sign;
+ Sign_Extend(Arg1, A); Sign_Extend(Arg2, B);
+ Sign = ((A < 0) == (B < 0));
+ A = ABS(A); B = ABS(B);
+ Hi_A = (A >> HALF_WORD_SIZE) & HALF_WORD_MASK;
+ Hi_B = (B >> HALF_WORD_SIZE) & HALF_WORD_MASK;
+ Lo_A = A & HALF_WORD_MASK; Lo_B = B & HALF_WORD_MASK;
+ Lo_C = Lo_A * Lo_B;
+ if (Lo_C > FIXNUM_SIGN_BIT) return NIL;
+ Middle_C = Lo_A * Hi_B + Hi_A * Lo_B;
+ if (Middle_C >= MAX_MIDDLE) return NIL;
+ if ((Hi_A * Hi_B) > 0) return NIL;
+ C = Lo_C + (Middle_C << HALF_WORD_SIZE);
+ if (Fixnum_Fits(C))
+ { if (Sign || (C == 0)) return FIXNUM_0 + C;
+ else return FIXNUM_0 + (MAX_FIXNUM - C);
+ }
+ return NIL;
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: object.h
+ *
+ * This file contains definitions pertaining to the C view of
+ * Scheme pointers: widths of fields, extraction macros, pre-computed
+ * extraction masks, etc.
+ *
+ */
+\f
+/* The C type Pointer is defined at the end of CONFIG.H */
+
+#define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */
+#define MAX_TYPE_CODE 0xFF /* ((1<<TYPE_CODE_LENGTH) - 1) */
+
+/* The danger bit is set in the value cell of an environment whenever a
+ particular binding of a variable to a value has been shadowed by an
+ auxiliary variable in a nested environment. It means that variables
+ cached to this address must be recached since the address may be invalid.
+ See lookup.c
+*/
+
+#define DANGER_TYPE 0x80 /* (1<<(TYPE_CODE_LENGTH-1)) */
+#define MAX_SAFE_TYPE 0x7F /* (MAX_TYPE_CODE & ~DANGER_TYPE) */
+#define SAFE_TYPE_MASK MAX_SAFE_TYPE
+#define DANGER_BIT HIGH_BIT
+
+#ifndef b32 /* Safe versions */
+
+#define POINTER_LENGTH (CHAR_SIZE*sizeof(Pointer))
+#define ADDRESS_LENGTH (POINTER_LENGTH-TYPE_CODE_LENGTH)
+#define ADDRESS_MASK ((1<<ADDRESS_LENGTH) - 1)
+#define TYPE_CODE_MASK (~ADDRESS_MASK)
+#define HIGH_BIT (1 << (POINTER_LENGTH-1))
+/* FIXNUM_LENGTH does NOT include the sign bit! */
+#define FIXNUM_LENGTH (ADDRESS_LENGTH-1)
+#define FIXNUM_SIGN_BIT (1<<FIXNUM_LENGTH)
+#define SIGN_MASK (TYPE_CODE_MASK | FIXNUM_SIGN_BIT)
+#define SMALLEST_FIXNUM (-1<<FIXNUM_LENGTH)
+#define BIGGEST_FIXNUM (~(-1<<FIXNUM_LENGTH))
+
+#else /* 32 bit word versions */
+
+#define POINTER_LENGTH 32
+#define ADDRESS_LENGTH 24
+#define ADDRESS_MASK 0x00FFFFFF
+#define TYPE_CODE_MASK 0xFF000000
+#define HIGH_BIT 0x80000000
+#define FIXNUM_LENGTH 23
+#define FIXNUM_SIGN_BIT 0x00800000
+#define SIGN_MASK 0xFF800000
+#define SMALLEST_FIXNUM 0xFF800000
+#define BIGGEST_FIXNUM 0x007FFFFF
+
+#endif
+\f
+#ifndef UNSIGNED_SHIFT /* Safe version */
+#define Type_Code(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE)
+#define Safe_Type_Code(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK)
+#else /* Faster for logical shifts */
+#define Type_Code(P) ((P) >> ADDRESS_LENGTH)
+#define Safe_Type_Code(P) (Type_Code(P) & SAFE_TYPE_MASK)
+#endif
+
+#define Datum(P) ((P) & ADDRESS_MASK)
+
+#define Make_Object(TC, D) \
+ ((((unsigned) (TC)) << ADDRESS_LENGTH) | (Datum(D)))
+\f
+#ifndef Heap_In_Low_Memory /* Safe version */
+
+typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */
+
+extern Pointer *Memory_Base;
+/* The "-1" in the value returned is guarantee that there is one
+ word reserved exclusively for use by the garbage collector. */
+#define Allocate_Heap_Space(space) \
+ (Memory_Base = (Pointer *) malloc(sizeof(Pointer) * (space)), \
+ Heap = Memory_Base, \
+ Memory_Base + (space) - 1)
+#define Get_Pointer(P) ((Pointer *) (Memory_Base+Datum(P)))
+#define C_To_Scheme(P) ((Pointer) ((P)-Memory_Base))
+
+#else /* Storing absolute addresses */
+
+typedef long relocation_type; /* Used to relocate pointers on fasload */
+
+#ifdef spectrum
+
+#define Quad1_Tag 0x40000000
+#define Allocate_Heap_Space(space) \
+ (Heap = (Pointer *) malloc(sizeof(Pointer) * (space)), \
+ Heap + (space) - 1)
+#define Get_Pointer(P) ((Pointer *) (((P) & ADDRESS_MASK) | Quad1_Tag))
+#define C_To_Scheme(P) ((Pointer) (((long) (P)) & ADDRESS_MASK))
+
+#else /* Not Spectrum, fast case */
+
+#define Allocate_Heap_Space(space) \
+ (Heap = (Pointer *) malloc(sizeof(Pointer) * (space)), \
+ Heap + (space) - 1)
+#define Get_Pointer(P) ((Pointer *) Datum(P))
+#define C_To_Scheme(P) ((Pointer) (P))
+
+#endif /* spectrum */
+#endif /* Heap_In_Low_Memory */
+
+#define Make_Pointer(TC, A) Make_Object((TC), C_To_Scheme(A))
+#define Make_Non_Pointer(TC, D) Make_Object(TC, ((Pointer) (D)))
+#define Make_Unsigned_Fixnum(N) (FIXNUM_0 + (N))
+#define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N))
+
+/* Make_New_Pointer(TC, A) may be more efficient than
+ Make_Pointer(TC, Get_Pointer(A))
+*/
+#define Make_New_Pointer(TC, A) Make_Object(TC, ((Pointer) A))
+
+#define Store_Type_Code(P, TC) P = Make_Object((TC), (P))
+#define Store_Address(P, A) \
+ P = (((P) & TYPE_CODE_MASK) | Datum((Pointer) (A)))
+#define Address(P) Datum(P)
+
+/* These are used only where the object is known to be immutable.
+ On a parallel processor they don't require atomic references */
+#define Fast_Vector_Ref(P, N) ((Get_Pointer(P))[N])
+#define Fast_Vector_Set(P, N, S) Fast_Vector_Ref(P, N) = (S)
+#define Fast_User_Vector_Ref(P, N) Fast_Vector_Ref(P, (N)+1)
+#define Fast_User_Vector_Set(P, N, S) Fast_Vector_Set(P, (N)+1, S)
+#define Nth_Vector_Loc(P, N) (&(Fast_Vector_Ref(P, N)))
+#define Vector_Length(P) (Get_Integer(Fast_Vector_Ref((P), 0)))
+
+/* General case vector handling requires atomicity for parallel processors */
+#define Vector_Ref(P, N) Fetch(Fast_Vector_Ref(P, N))
+#define Vector_Set(P, N, S) Store(Fast_Vector_Ref(P, N), S)
+#define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1)
+#define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S)
+\f
+#ifdef FLOATING_ALIGNMENT
+#define Align_Float(Where) \
+while ((((long) (Where+1)) & FLOATING_ALIGNMENT) != 0) \
+ *Where++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
+#else
+#define Align_Float(Where)
+#endif
+#define Get_Float(P) (* ((double *) Nth_Vector_Loc((P), 1)))
+#define Get_Integer(P) Datum(P)
+#define Sign_Extend(P, S) \
+ { (S) = Get_Integer(P); \
+ if (((S) & FIXNUM_SIGN_BIT) != 0) \
+ (S) |= (-1 << ADDRESS_LENGTH); \
+ }
+#define Fixnum_Fits(x) \
+ ((((x) & SIGN_MASK) == 0) || \
+ (((x) & SIGN_MASK) == SIGN_MASK))
+
+/* Playing with the danger bit */
+
+#define Without_Danger_Bit(P) ((P) & (~DANGER_BIT))
+#define Dangerous(P) ((P & DANGER_BIT) != 0)
+#define Clear_Danger_Bit(P) P &= ~DANGER_BIT
+#define Set_Danger_Bit(P) P |= DANGER_BIT
+/* Side effect testing */
+
+#define Is_Constant(address) \
+(((address) >= Constant_Space) && ((address) < Free_Constant))
+
+#define Is_Pure(address) \
+((Is_Constant(address)) && (Pure_Test(address)))
+
+#define Side_Effect_Impurify(Old_Pointer, Will_Contain) \
+if ((Is_Constant(Get_Pointer(Old_Pointer))) && \
+ (GC_Type(Will_Contain) != GC_Non_Pointer) && \
+ (!(Is_Constant(Get_Pointer(Will_Contain)))) && \
+ (Pure_Test(Get_Pointer(Old_Pointer)))) \
+ Primitive_Error(ERR_WRITE_INTO_PURE_SPACE);
+
+
+
+
--- /dev/null
+/* 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. *
+* *
+****************************************************************/
+
+/* File: PP-BAND.C
+ dumps Scheme FASL in user-readable form
+ */
+
+#include "scheme.h"
+
+/* These are needed by load.c */
+
+static Pointer *Memory_Base;
+
+#define Load_Data(Count,To_Where) \
+ fread(To_Where, sizeof(Pointer), Count, stdin)
+
+#define Reloc_or_Load_Debug true
+
+#include "load.c"
+#include "gctype.c"
+\f
+#ifdef Heap_In_Low_Memory
+#ifdef spectrum
+#define File_To_Pointer(P) ((((long) (P))&ADDRESS_MASK) / sizeof(Pointer))
+#else
+#define File_To_Pointer(P) ((P) / sizeof(Pointer))
+#endif /* spectrum */
+#else
+#define File_To_Pointer(P) (P)
+#endif
+
+#ifndef Conditional_Bug
+#define Relocate(P) \
+ (((long) (P) < Const_Base) ? \
+ File_To_Pointer(((long) (P)) - Heap_Base) : \
+ (Heap_Count+File_To_Pointer(((long) (P)) - Const_Base)))
+#else
+#define Relocate_Into(What, P)
+if (((long) (P)) < Const_Base)
+ (What) = File_To_Pointer(((long) (P)) - Heap_Base);
+else
+ (What) = Heap_Count + File_To_Pointer(((long) P) - Const_Base);
+
+static long Relocate_Temp;
+#define Relocate(P) (Relocate_Into(Relocate_Temp, P), Relocate_Temp)
+#endif
+
+Pointer *Data;
+#define via(File_Address) Relocate(Address(Data[File_Address]))
+
+scheme_string(From, Quoted)
+long From;
+Boolean Quoted;
+{ fast long i, Count;
+ fast char *Chars;
+ Count = Get_Integer(Data[From+STRING_LENGTH]);
+ Chars = (char *) &Data[From+STRING_CHARS];
+ putchar(Quoted ? '\"' : '\'');
+ for (i=0; i < Count; i++) printf("%c", *Chars++);
+ if (Quoted) putchar('\"');
+ putchar('\n');
+}
+\f
+Display(Location, Type, The_Datum)
+long Location, Type, The_Datum;
+{ long Points_To;
+ printf("%5x: %2x|%6x ", Location, Type, The_Datum);
+ if (GC_Type_Map[Type & MAX_SAFE_TYPE] != GC_Non_Pointer)
+ Points_To = Relocate((Pointer *) The_Datum);
+ else
+ Points_To = The_Datum;
+ if (Type > MAX_SAFE_TYPE) printf("*");
+ switch (Type & SAFE_TYPE_MASK)
+ { /* "Strange" cases */
+ case TC_NULL: if (The_Datum == 0)
+ { printf("NIL\n");
+ return;
+ }
+ else printf("[NULL ");
+ break;
+ case TC_TRUE: if (The_Datum == 0)
+ { printf("TRUE\n");
+ return;
+ }
+ else printf("[TRUE ");
+ break;
+ case TC_BROKEN_HEART: printf("[BROKEN-HEART ");
+ if (The_Datum == 0)
+ Points_To = 0;
+ break;
+ case TC_MANIFEST_SPECIAL_NM_VECTOR: printf("[MANIFEST-SPECIAL-NM ");
+ Points_To = The_Datum;
+ break;
+ case TC_MANIFEST_NM_VECTOR: printf("[MANIFEST-NM-VECTOR ");
+ Points_To = The_Datum;
+ break;
+ case TC_INTERNED_SYMBOL: scheme_string(via(Points_To+SYMBOL_NAME), false);
+ return;
+ case TC_UNINTERNED_SYMBOL:
+ printf("uninterned ");
+ scheme_string(via(Points_To+SYMBOL_NAME), false);
+ return;
+ case TC_CHARACTER_STRING: scheme_string(Points_To, true);
+ return;
+ case TC_EXTENDED_FIXNUM: printf("%d\n", The_Datum);
+ return;
+ case TC_FIXNUM: printf("%d\n", Points_To);
+ return;
+
+ /* Default cases */
+ case TC_LIST: printf("[CONS "); break;
+ case TC_WEAK_CONS: printf("[WEAK-CONS "); break;
+ case TC_SCODE_QUOTE: printf("[QUOTE "); break;
+ case TC_BIG_FLONUM: printf("[FLONUM "); break;
+ case TC_COMBINATION_1: printf( "[COMB-1 "); break;
+ case TC_EXTENDED_PROCEDURE: printf("[EPROCEDURE "); break;
+ case TC_COMBINATION_2: printf("[COMB-2 "); break;
+ case TC_BIG_FIXNUM: printf("[BIGNUM "); break;
+ case TC_PROCEDURE: printf("[PROCEDURE "); break;
+ case TC_PRIMITIVE_EXTERNAL: printf("[EXTERNAL-PRIMITIVE "); break;
+ case TC_DELAY: printf("[DELAY "); break;
+ case TC_DELAYED: printf("[DELAYED "); break;
+ case TC_EXTENDED_LAMBDA: printf("[ELAMBDA "); break;
+ case TC_COMMENT: printf("[COMMENT "); break;
+ case TC_NON_MARKED_VECTOR: printf("[NON-MARKED-VECTOR "); break;
+ case TC_LAMBDA: printf("[LAMBDA "); break;
+ case TC_PRIMITIVE: printf("[PRIMITIVE "); break;
+ case TC_SEQUENCE_2: printf("[SEQ-2 "); break;
+ case TC_PCOMB1: printf("[PCOMB-1 "); break;
+ case TC_ACCESS: printf("[ACCESS "); break;
+ case TC_DEFINITION: printf("[DEFINITION "); break;
+ case TC_ASSIGNMENT: printf("[ASSIGNMENT "); break;
+ case TC_HUNK3: printf("[HUNK3 "); break;
+ case TC_IN_PACKAGE: printf("[IN-PACKAGE "); break;
+ case TC_LEXPR: printf("[LEXPR "); break;
+ case TC_VARIABLE: printf("[VARIABLE "); break;
+ case TC_CONDITIONAL: printf("[CONDITIONAL "); break;
+ case TC_DISJUNCTION: printf("[DISJUNCTION "); break;
+ case TC_UNASSIGNED: printf("[UNASSIGNED "); break;
+ case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break;
+ case TC_CHARACTER: printf("[CHARACTER "); break;
+ case TC_PCOMB2: printf("[PCOMB-2 "); break;
+ case TC_VECTOR: printf("[VECTOR "); break;
+ case TC_RETURN_CODE: printf("[RETURN-CODE "); break;
+ case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break;
+ case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break;
+ case TC_COMBINATION: printf("[COMBINATION "); break;
+ case TC_PCOMB3: printf("[PCOMB-3 "); break;
+ case TC_THE_ENVIRONMENT: printf("[THE-ENVIRONMENT "); break;
+ case TC_VECTOR_1B: printf("[VECTOR-1B "); break;
+ case TC_PCOMB0: printf("[PCOMB-0 "); break;
+ case TC_VECTOR_16B: printf("[VECTOR-16B "); break;
+ case TC_CELL: printf("[CELL "); break;
+ case TC_FUTURE: printf("[FUTURE "); break;
+ case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break;
+ case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break;
+ case TC_RETURN_ADDRESS: printf("[RETURN-ADDRESS "); break;
+ default: printf("[02x%x ", Type); break;
+ }
+ printf("%x]\n", Points_To);
+}
+
+main()
+{ Pointer *Next;
+ long i;
+ if (!Read_Header())
+ { fprintf(stderr, "Input does not appear to be in FASL format.\n");
+ exit(1);
+ }
+ printf("Dumped object at 0x%x\n", Relocate(Dumped_Object));
+ if (Sub_Version >= FASL_LONG_HEADER)
+ printf("External primitives at 0x%x\n\n", Relocate(Ext_Prim_Vector));
+ Data = (Pointer *) malloc(sizeof(Pointer) * (Heap_Count + Const_Count));
+ Load_Data(Heap_Count + Const_Count, Data);
+ printf("Heap contents\n\n");
+ for (Next=Data, i=0; i < Heap_Count; Next++, i++)
+ if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR)
+ { long j, count = Get_Integer(*Next);
+ Display(i, Type_Code(*Next), Address(*Next));
+ Next += 1;
+ for (j=0; j < count ; j++, Next++)
+ printf(" %02x%06x\n",
+ Type_Code(*Next), Address(*Next));
+ i += count;
+ Next -= 1;
+ }
+ else Display(i, Type_Code(*Next), Address(*Next));
+ printf("\n\nConstant space\n\n");
+ for (; i < Heap_Count+Const_Count; Next++, i++)
+ if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR)
+ { long j, count = Get_Integer(*Next);
+ Display(i, Type_Code(*Next), Address(*Next));
+ Next += 1;
+ for (j=0; j < count ; j++, Next++)
+ printf(" %02x%06x\n",
+ Type_Code(*Next), Address(*Next));
+ i += count;
+ Next -= 1;
+ }
+ else Display(i, Type_Code(*Next), Address(*Next));
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: prim.c
+ *
+ * The leftovers ... primitives that don't seem to belong elsewhere
+ *
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+#include "prims.h"
+\f
+/* Random predicates: */
+
+/* (NULL OBJECT)
+ [Primitive number 0x0C]
+ Returns #!TRUE if OBJECT is NIL. Otherwise returns NIL. This is
+ the primitive known as NOT, NIL?, and NULL? in Scheme.
+*/
+Built_In_Primitive(Prim_Null, 1, "NULL?")
+{ Primitive_1_Arg();
+ Touch_In_Primitive(Arg1, Arg1);
+ return (Arg1 == NIL) ? TRUTH : NIL;
+}
+
+/* (EQ? OBJECT-1 OBJECT-2)
+ [Primitive number 0x0D]
+ Returns #!TRUE if the two objects have the same type code,
+ address portion, and danger bit. Returns NIL otherwise.
+*/
+Built_In_Primitive(Prim_Eq, 2, "EQ?")
+{ Primitive_2_Args();
+ if (Arg1 == Arg2) return TRUTH;
+ Touch_In_Primitive(Arg1, Arg1);
+ Touch_In_Primitive(Arg2, Arg2);
+ return (Arg1 == Arg2) ? TRUTH : NIL;
+}
+\f
+/* Pointer manipulation */
+
+/* (MAKE_NON_POINTER NUMBER)
+ [Primitive number 0xB1]
+ Returns an (extended) fixnum with the same value as NUMBER. In
+ the CScheme interpreter this is basically a no-op, since fixnums
+ already store 24 bits.
+*/
+Built_In_Primitive(Prim_Make_Non_Pointer, 1, "MAKE-NON-POINTER")
+{ Primitive_1_Arg();
+ Arg_1_Type(TC_FIXNUM);
+ return Arg1;
+}
+
+/* (PRIMITIVE-TYPE OBJECT)
+ [Primitive number 0x10]
+ Returns the type code of OBJECT as a number. This includes the
+ danger bit, if it is set. THE OBJECT IS TOUCHED FIRST.
+*/
+Built_In_Primitive(Prim_Prim_Type, 1, "PRIMITIVE-TYPE")
+{ Primitive_1_Arg();
+ Touch_In_Primitive(Arg1, Arg1);
+ return FIXNUM_0+Type_Code(Arg1);
+}
+
+/* (PRIMITIVE_DATUM OBJECT)
+ [Primitive number 0xB0]
+ Returns the address part of OBJECT.
+*/
+Built_In_Primitive(Prim_Primitive_Datum, 1, "PRIMITIVE-DATUM")
+{ Primitive_1_Arg();
+ return Make_New_Pointer(TC_ADDRESS, Arg1);
+}
+\f
+/* (PRIMITIVE-TYPE? TYPE-CODE OBJECT)
+ [Primitive number 0x0F]
+ Return #!TRUE if the type code of OBJECT is TYPE-CODE, NIL
+ otherwise. The check includes the danger bit of OBJECT.
+ THE OBJECT IS TOUCHED FIRST.
+*/
+Built_In_Primitive(Prim_Prim_Type_QM, 2, "PRIMITIVE-TYPE?")
+{ Primitive_2_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Touch_In_Primitive(Arg2, Arg2);
+ if (Type_Code(Arg2) == Get_Integer(Arg1)) return TRUTH;
+ else return NIL;
+}
+
+/* (PRIMITIVE-SET-TYPE TYPE-CODE OBJECT)
+ [Primitive number 0x11]
+
+ Returns a new object with TYPE-CODE and the address part of
+ OBJECT. TOUCHES ITS SECOND ARGUMENT (for completeness sake).
+ This is a "gc-safe" (paranoid) operation.
+*/
+
+Built_In_Primitive(Prim_Primitive_Set_Type, 2, "PRIMITIVE-SET-TYPE")
+{ long New_GC_Type, New_Type;
+ Primitive_2_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Range_Check(New_Type, Arg1, 0, MAX_SAFE_TYPE, ERR_ARG_1_BAD_RANGE);
+ Touch_In_Primitive(Arg2, Arg2);
+ New_GC_Type = GC_Type_Code(New_Type);
+ if ((GC_Type(Arg2) == New_GC_Type) ||
+ (New_GC_Type == GC_Non_Pointer))
+ return Make_New_Pointer(New_Type, Arg2);
+ else Primitive_Error(ERR_ARG_1_BAD_RANGE); /*NOTREACHED*/
+}
+
+/* (&MAKE-OBJECT TYPE-CODE OBJECT)
+ [Primitive number 0x8D]
+
+ Makes a Scheme object whose datum field is the datum field of
+ OBJECT, and whose type code is TYPE-CODE. It does not touch,
+ and is not "gc-safe": You can screw yourself royally by using
+ this.
+*/
+
+Built_In_Primitive(Prim_And_Make_Object, 2, "&MAKE-OBJECT")
+{ long New_Type;
+ Primitive_2_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Range_Check(New_Type, Arg1, 0, MAX_SAFE_TYPE, ERR_ARG_1_BAD_RANGE);
+ return Make_New_Pointer(New_Type, Arg2);
+}
+\f
+/* Playing with the danger bit */
+
+/* (DANGEROUS? OBJECT)
+ [Primitive number 0x49]
+ Returns #!TRUE if OBJECT has the danger bit set, NIL otherwise.
+*/
+Built_In_Primitive(Prim_Dangerous_QM, 1, "DANGEROUS?")
+{ Primitive_1_Arg();
+ return (Dangerous(Arg1)) ? TRUTH : NIL;
+}
+
+/* (DANGERIZE OBJECT)
+ [Primitive number 0x48]
+ Returns OBJECT, but with the danger bit set.
+*/
+Built_In_Primitive(Prim_Dangerize, 1, "DANGERIZE")
+{ Primitive_1_Arg();
+ return Set_Danger_Bit(Arg1);
+}
+
+/* (UNDANGERIZE OBJECT)
+ [Primitive number 0x47]
+ Returns OBJECT with the danger bit cleared. This does not
+ side-effect the object, it merely returns a new (non-dangerous)
+ pointer to the same item.
+*/
+Built_In_Primitive(Prim_Undangerize, 1, "UNDANGERIZE")
+{ Primitive_1_Arg();
+ return Clear_Danger_Bit(Arg1);
+}
+\f
+/* Mapping between the internal and external representations of
+ primitives, return addresses, external primitives, etc.
+ */
+
+/* (MAP_CODE_TO_ADDRESS TYPE-CODE VALUE-CODE)
+ [Primitive number 0x93]
+ For return codes and primitives, this returns the internal
+ representation of the return address or primitive address given
+ the external representation. Currently in CScheme these two are
+ the same. In the 68000 assembly version the internal
+ representation is an actual address in memory.
+*/
+Built_In_Primitive(Prim_Map_Code_To_Address, 2, "MAP-CODE-TO-ADDRESS")
+{ long Code, Offset;
+ Primitive_2_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Arg_2_Type(TC_FIXNUM);
+ Code = Get_Integer(Arg1);
+ Offset = Get_Integer(Arg2);
+ switch (Code)
+ { case TC_RETURN_CODE:
+ if (Offset > MAX_RETURN_CODE) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ break;
+
+ case TC_PRIMITIVE:
+ if (Offset > MAX_PRIMITIVE) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ break;
+
+ default: Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ }
+ return Make_Non_Pointer(Code, Offset);
+}
+\f
+/* (MAP_ADDRESS_TO_CODE TYPE-CODE ADDRESS)
+ [Primitive number 0x90]
+ This is the inverse operation for MAP_CODE_TO_ADDRESS.
+ Given a machine ADDRESS and a TYPE-CODE (either return code or
+ primitive) it finds the number for the external representation
+ for the internal address.
+*/
+Built_In_Primitive(Prim_Map_Address_To_Code, 2, "MAP-ADDRESS-TO-CODE")
+{ long Code, Offset;
+ Primitive_2_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Code = Get_Integer(Arg1);
+ Arg_2_Type(Code);
+ Offset = Get_Integer(Arg2);
+ switch (Code)
+ { case TC_RETURN_CODE:
+ if (Offset > MAX_RETURN_CODE)
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ break;
+
+ case TC_PRIMITIVE:
+ if (Offset > MAX_PRIMITIVE)
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ break;
+
+ default:
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ }
+ return FIXNUM_0+Offset;
+}
+
+/* (MAP_PRIM_ADDRESS_TO_ARITY INTERNAL-PRIMITIVE)
+ [Primitive number 0x96]
+ Given the internal representation of a primitive (in CScheme the
+ internal and external representations are the same), return the
+ number of arguments it requires.
+*/
+Built_In_Primitive(Prim_Map_Prim_Address_To_Arity, 1,
+ "PRIMITIVE-PROCEDURE-ARITY")
+{ long Prim_Num;
+ Primitive_1_Arg();
+ if (Type_Code(Arg1) != TC_PRIMITIVE_EXTERNAL)
+ { Arg_1_Type(TC_PRIMITIVE);
+ Range_Check(Prim_Num, Arg1, 0, MAX_PRIMITIVE, ERR_ARG_1_BAD_RANGE);
+ return FIXNUM_0 + (int) Arg_Count_Table[Prim_Num];
+ }
+ /* External primitives here */
+ Prim_Num = Get_Integer(Arg1);
+ if (Prim_Num <= MAX_EXTERNAL_PRIMITIVE)
+ return FIXNUM_0 + Ext_Prim_Desc[Prim_Num].arity;
+ if (Undefined_Externals==NIL) Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ if (Prim_Num > (MAX_EXTERNAL_PRIMITIVE+
+ Get_Integer(User_Vector_Ref(Undefined_Externals, 0))))
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ return NIL;
+}
+\f
+/* Playing with non marked vectors. */
+
+/* (NON_MARKED_VECTOR_CONS LENGTH)
+ [Primitive number 0x31]
+ Creates a non-marked vector of the specified LENGTH. The
+ contents of such a vector are not seen by the garbage collector.
+ There are no ordinary operations which can be performed on
+ non-marked vectors, but the SYS_VECTOR operations can be used
+ with care. [This primitive appears to be a relic of days gone
+ by.]
+*/
+Built_In_Primitive(Prim_Non_Marked_Vector_Cons, 1, "NON-MARKED-VECTOR-CONS")
+{ long Length;
+ Primitive_1_Arg();
+ Arg_1_Type(TC_FIXNUM);
+ Length = Get_Integer(Arg1);
+ Primitive_GC_If_Needed(Length+1);
+ *Free = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Length);
+ Free += Length+1;
+ return Make_Pointer(TC_NON_MARKED_VECTOR, Free-(Length+1));
+}
+\f
+/* (INSERT_NON_MARKED_VECTOR TO-GC-VECTOR N FROM-GC-VECTOR)
+ [Primitive number 0x19]
+ This primitive performs a side-effect on the TO-GC-VECTOR. Both
+ TO- and FROM-GC-VECTOR must be of the garbage collector type
+ vector (i.e. vectors, strings, non-marked vectors, bignums,
+ etc.). The FROM-GC-VECTOR is inserted in the middle of
+ TO-GC-VECTOR, preceded by a non-marked vector header. The
+ insertion begins at the Nth position of the vector with the
+ non-marked header. Notice that this is really an "overwrite"
+ rather than an insertion, since the length of the TO-GC-VECTOR
+ does not change and the data which was formerly in the part of
+ the vector now occupied by FROM-GC-VECTOR and its header has
+ been lost. This primitive was added for the use of certain
+ parts of the compiler and runtime system which need to make
+ objects that have an internal part which is "hidden" from the
+ garbage collector. The value returned is TO-GC-VECTOR.
+*/
+Built_In_Primitive(Prim_Insert_Non_Marked_Vector, 3,
+ "INSERT-NON-MARKED-VECTOR!")
+{ Pointer *To,*From;
+ long Index,NM_Length,Length,i;
+ Primitive_3_Args();
+ Arg_1_GC_Type(GC_Vector);
+ Arg_2_Type(TC_FIXNUM);
+ Arg_3_GC_Type(GC_Vector);
+ Length = Vector_Length(Arg1);
+ NM_Length = Vector_Length(Arg3);
+ Range_Check(Index, Arg2, 0, Length-1, ERR_ARG_2_BAD_RANGE);
+ if (Length-Index <= NM_Length)
+ Primitive_Error(ERR_ARG_3_BAD_RANGE);
+ From = Nth_Vector_Loc(Arg3, VECTOR_TYPE);
+ To = Nth_Vector_Loc(Arg1, VECTOR_DATA+Index);
+ for (i=0; i<=NM_Length; i++)
+ *To++ = *From++;
+ return Arg1;
+}
+\f
+/* Cells */
+
+/* (MAKE-CELL CONTENTS)
+ [Primitive number 0x61]
+ Creates a cell with contents CONTENTS.
+*/
+Built_In_Primitive(Prim_Make_Cell, 1, "MAKE-CELL")
+{ Primitive_1_Arg();
+ Primitive_GC_If_Needed(1);
+ *Free++ = Arg1;
+ return Make_Pointer(TC_CELL, Free-1);
+}
+
+/* (CONTENTS CELL)
+ [Primitive number 0x62]
+ Returns the contents of the cell CELL.
+*/
+Built_In_Primitive(Prim_Cell_Contents, 1, "CONTENTS")
+{ Primitive_1_Arg();
+ Arg_1_Type(TC_CELL);
+ return(Vector_Ref(Arg1, CELL_CONTENTS));
+}
+
+/* (CELL? OBJECT)
+ [Primitive number 0x63]
+ Returns #!TRUE if OBJECT has type-code CELL, otherwise returns
+ NIL.
+*/
+Built_In_Primitive(Prim_Cell, 1,"CELL?")
+{ Primitive_1_Arg();
+ Touch_In_Primitive(Arg1,Arg1);
+ return (Type_Code(Arg1 == TC_CELL)) ? TRUTH : NIL;
+}
+
+/* (SET-CONTENTS! CELL VALUE)
+ [Primitive number 0x8C]
+ Stores VALUE as contents of CELL. Returns (bad style to count
+ on this) the previous contents of CELL.
+*/
+Built_In_Primitive(Prim_Set_Cell_Contents, 2, "SET-CONTENTS!")
+{ Primitive_2_Args();
+ Arg_1_Type(TC_CELL);
+ Side_Effect_Impurify(Arg1, Arg2);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, CELL_CONTENTS), Arg2);
+}
+\f
+/* Multiprocessor scheduling primitive */
+
+#ifndef butterfly
+#ifdef COMPILE_FUTURES
+Built_In_Primitive(Prim_Get_Work, 1, "GET-WORK")
+{ Pointer The_Queue, Queue_Head, Result;
+ Primitive_1_Arg();
+
+ The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
+ if (The_Queue != NIL) Queue_Head = Vector_Ref(The_Queue, CONS_CAR);
+ if ((The_Queue==NIL) || (Queue_Head==NIL))
+ if (Arg1 == NIL)
+ { printf("\nNo work available, but some has been requested!\n");
+ Microcode_Termination(TERM_EXIT);
+ }
+ else
+ { Pop_Primitive_Frame(1);
+ Will_Push(2*(STACK_ENV_EXTRA_SLOTS+1) + 1 + CONTINUATION_SIZE);
+ Push(NIL); /* Upon return, no hope if there is no work */
+ Push(Make_Non_Pointer(TC_PRIMITIVE, PC_GET_WORK));
+ Push(STACK_FRAME_HEADER+1);
+ Store_Expression(NIL);
+ Store_Return(RC_INTERNAL_APPLY);
+ Save_Cont();
+ Push(Arg1);
+ Push(STACK_FRAME_HEADER);
+ Pushed();
+ longjmp(*Back_To_Eval, PRIM_APPLY);
+ }
+ Result = Vector_Ref(Queue_Head, CONS_CAR);
+ Queue_Head = Vector_Ref(Queue_Head, CONS_CDR);
+ Vector_Set(The_Queue, CONS_CAR, Queue_Head);
+ if (Queue_Head==NIL) Vector_Set(The_Queue, CONS_CDR, NIL);
+ return Result;
+}
+#else /* #ifdef COMPILE_FUTURES */
+Built_In_Primitive(Prim_Get_Work, 1, "GET-WORK")
+{ Primitive_1_Arg();
+ Primitive_Error(ERR_UNDEFINED_PRIMITIVE);
+}
+#endif /* #ifdef COMPILE_FUTURES */
+#endif /* #ifndef butterfly */
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: primitive.h
+ *
+ * This file contains some macros for defining primitives,
+ * for argument type or value checking, and for accessing
+ * the arguments.
+ *
+ */
+\f
+/* Definition of primitives. See storage.c for some information. */
+
+#define Define_Primitive(C_Name, Number_of_args, Scheme_Name) \
+extern Pointer C_Name(); \
+Pointer C_Name()
+
+#define Built_In_Primitive(C_Name, Number_of_args, Scheme_Name) \
+Define_Primitive(C_Name, Number_of_args, Scheme_Name)
+
+extern Pointer Not_Implemented_Yet();
+
+#define NIY(C_Name, Number_of_args, Scheme_Name) \
+Built_In_Primitive(C_Name, Number_of_args, Scheme_Name) \
+{ return Not_Implemented_Yet(Scheme_Name); \
+}
+
+/* Preambles for primitive procedures. These store the arguments into
+ * local variables for fast access.
+ */
+
+#define Primitive_0_Args()
+
+#define Primitive_1_Args() fast Pointer Arg1 = Stack_Ref(0);\
+ Primitive_0_Args()
+
+#define Primitive_2_Args() fast Pointer Arg2 = Stack_Ref(1);\
+ Primitive_1_Args()
+
+#define Primitive_3_Args() fast Pointer Arg3 = Stack_Ref(2);\
+ Primitive_2_Args()
+
+#define Primitive_4_Args() fast Pointer Arg4 = Stack_Ref(3);\
+ Primitive_3_Args()
+
+#define Primitive_5_Args() fast Pointer Arg5 = Stack_Ref(4);\
+ Primitive_4_Args()
+
+#define Primitive_6_Args() fast Pointer Arg6 = Stack_Ref(5);\
+ Primitive_5_Args()
+
+#define Primitive_7_Args() fast Pointer Arg7 = Stack_Ref(6);\
+ Primitive_6_Args()
+
+#define Primitive_1_Arg() Primitive_1_Args()
+\f
+/* Various utilities */
+
+#define Primitive_Error(Err_No) \
+ { Back_Out_Of_Primitive(); \
+ longjmp(*Back_To_Eval, Err_No); \
+ }
+
+#define Primitive_Interrupt() \
+ { Back_Out_Of_Primitive(); \
+ longjmp(*Back_To_Eval, PRIM_INTERRUPT); \
+ }
+
+#define Primitive_GC(Amount) \
+ { Request_GC(Amount); \
+ Primitive_Interrupt(); \
+ }
+
+#define Primitive_GC_If_Needed(Amount) \
+ if (GC_Check(Amount)) Primitive_GC(Amount)
+
+#define Arg_1_Type(TC) \
+if (Type_Code(Arg1) != (TC)) Primitive_Error(ERR_ARG_1_WRONG_TYPE)
+
+#define Arg_2_Type(TC) \
+if (Type_Code(Arg2) != (TC)) Primitive_Error(ERR_ARG_2_WRONG_TYPE)
+
+#define Arg_3_Type(TC) \
+if (Type_Code(Arg3) != (TC)) Primitive_Error(ERR_ARG_3_WRONG_TYPE)
+
+#define Arg_4_Type(TC) \
+if (Type_Code(Arg4) != (TC)) Primitive_Error(ERR_ARG_4_WRONG_TYPE)
+
+#define Arg_5_Type(TC) \
+if (Type_Code(Arg5) != (TC)) Primitive_Error(ERR_ARG_5_WRONG_TYPE)
+
+#define Arg_6_Type(TC) \
+if (Type_Code(Arg6) != (TC)) Primitive_Error(ERR_ARG_6_WRONG_TYPE)
+
+#define Arg_7_Type(TC) \
+if (Type_Code(Arg7) != (TC)) Primitive_Error(ERR_ARG_7_WRONG_TYPE)
+
+
+#define Arg_1_GC_Type(GCTC) \
+if (GC_Type(Arg1) != GCTC) Primitive_Error(ERR_ARG_1_WRONG_TYPE)
+
+#define Arg_2_GC_Type(GCTC) \
+if (GC_Type(Arg2) != GCTC) Primitive_Error(ERR_ARG_2_WRONG_TYPE)
+
+#define Arg_3_GC_Type(GCTC) \
+if (GC_Type(Arg3) != GCTC) Primitive_Error(ERR_ARG_3_WRONG_TYPE)
+
+
+/* And a procedure or two for range checking */
+
+#define Range_Check(To_Where, P, Low, High, Error) \
+ { To_Where = Get_Integer(P); \
+ if ((To_Where < (Low)) || (To_Where > (High))) \
+ Primitive_Error(Error); }
+
+#define Sign_Extend_Range_Check(To_Where, P, Low, High, Error) \
+ { Sign_Extend(P,To_Where); \
+ if ((To_Where < (Low)) || (To_Where > (High))) \
+ Primitive_Error(Error); }
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: unixprim.c
+
+Simple unix primitives. */
+\f
+#include <pwd.h>
+#include "scheme.h"
+#include "primitive.h"
+
+/* Looks up in the user's shell environment the value of the
+ variable specified as a string. */
+
+Define_Primitive( Prim_get_environment_variable, 1, "GET-ENVIRONMENT-VARIABLE")
+{
+ char *variable_value;
+ extern char *getenv();
+ Primitive_1_Arg();
+
+ Arg_1_Type( TC_CHARACTER_STRING);
+ variable_value = getenv( Scheme_String_To_C_String( Arg1));
+ return ((variable_value == NULL)
+ ? NIL
+ : C_String_To_Scheme_String( variable_value));
+}
+
+Define_Primitive( Prim_get_user_name, 0, "CURRENT-USER-NAME")
+{
+ char *user_name;
+ char *getlogin();
+ Primitive_0_Args();
+
+ user_name = getlogin();
+ if (user_name == NULL)
+ {
+ unsigned short getuid();
+ struct passwd *entry;
+ struct passwd *getpwuid();
+
+ entry = getpwuid( getuid());
+ if (entry == NULL)
+ Primitive_Error( ERR_EXTERNAL_RETURN);
+ user_name = entry->pw_name;
+ }
+ return (C_String_To_Scheme_String( user_name));
+}
+
+Define_Primitive( Prim_get_user_home_directory, 1, "GET-USER-HOME-DIRECTORY")
+{
+ struct passwd *entry;
+ struct passwd *getpwnam();
+ Primitive_1_Arg();
+
+ Arg_1_Type( TC_CHARACTER_STRING);
+ entry = getpwnam( Scheme_String_To_C_String( Arg1));
+ return ((entry == NULL)
+ ? NIL
+ : C_String_To_Scheme_String( entry->pw_dir));
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: translate.h
+ *
+ * This header file contains macros and declarations for Bintopsb.c
+ * and Psbtobin.c
+ *
+ */
+\f
+/* These definitions insure that the appropriate code is extracted
+ from the included files.
+*/
+
+#include <stdio.h>
+#define fast register
+
+#include "config.h"
+#include "object.h"
+#include "bignum.h"
+#include "gc.h"
+#include "types.h"
+#include "sdata.h"
+#include "const.h"
+#include "gccode.h"
+#include "character.h"
+
+#ifdef HAS_FREXP
+extern double frexp(), ldexp();
+#else
+#include "missing.c"
+#endif
+
+#define PORTABLE_VERSION 1
+
+/* Number of objects which, when traced recursively, point at all other
+ objects dumped. Currently the dumped object and the external
+ primitives vector.
+ */
+
+#define NROOTS 2
+
+/* Types to recognize external object references. Any occurrence of these
+ (which are external types and thus handled separately) means a reference
+ to an external object.
+ */
+
+#define CONSTANT_CODE TC_BIG_FIXNUM
+#define HEAP_CODE TC_FIXNUM
+
+#define fixnum_to_bits FIXNUM_LENGTH
+#define bignum_to_bits(len) ((len) * SHIFT)
+#define bits_to_bigdigit(nbits) (((nbits) + (SHIFT-1)) / SHIFT)
+
+#define hex_digits(nbits) (((nbits) + 3) / 4)
+
+#define to_pointer(size) \
+ (((size) + (sizeof(Pointer) - 1)) / sizeof(Pointer))
+
+#define bigdigit_to_pointer(ndig) \
+ to_pointer((ndig) * sizeof(bigdigit))
+
+/* This assumes that a bignum header is 2 Pointers.
+ The bignum code is not very portable, unfortunately */
+
+#define bignum_header_to_pointer Align(0)
+
+#define float_to_pointer \
+ to_pointer(sizeof(double))
+#define flonum_to_pointer(nchars) \
+ ((nchars) * (1 + float_to_pointer))
+
+#define char_to_pointer(nchars) \
+ to_pointer(nchars)
+#define pointer_to_char(npoints) \
+ ((npoints) * sizeof(Pointer))
+\f
+/* Global data */
+
+/* If true, make all integers fixnums if possible, and all strings as
+ short as possible (trim extra stuff). */
+
+static Boolean Compact_P = true;
+
+/* If true, null out all elements of random non-marked vectors. */
+
+static Boolean Null_NMV = false;
+
+#ifndef Heap_In_Low_Memory
+static Pointer *Memory_Base;
+#endif
+
+static FILE *Input_File, *Output_File;
+
+static char *Program_Name;
+\f
+/* Status flags */
+
+#define COMPACT_P 1
+#define NULL_NMV 2
+
+#define Make_Flags() \
+((Compact_P ? COMPACT_P : 0) | \
+ (Null_NMV ? NULL_NMV : 0))
+
+#define Read_Flags(f) \
+Compact_P = ((f) & COMPACT_P); \
+Null_NMV = ((f) & NULL_NMV)
+\f
+/* Argument List Parsing */
+
+struct Option_Struct { char *name;
+ Boolean value;
+ Boolean *ptr;
+ };
+
+Boolean strequal(s1, s2)
+fast char *s1, *s2;
+{ while (*s1 != '\0')
+ if (*s1++ != *s2++) return false;
+ return (*s2 == '\0');
+}
+
+char *Find_Options(argc, argv, Noptions, Options)
+int argc;
+char **argv;
+int Noptions;
+struct Option_Struct Options[];
+{ for ( ; --argc >= 0; argv++)
+ { char *this = *argv;
+ int n;
+ for (n = 0;
+ ((n < Noptions) && (!strequal(this, Options[n].name)));
+ n++) ;
+ if (n >= Noptions) return this;
+ *(Options[n].ptr) = Options[n].value;
+ }
+ return NULL;
+}
+\f
+/* Usage information */
+
+Print_Options(n, options, where)
+int n;
+struct Option_Struct *options;
+FILE *where;
+{ if (--n < 0) return;
+ fprintf(where, "[%s]", options->name);
+ options += 1;
+ for (; --n >= 0; options += 1)
+ fprintf(where, " [%s]", options->name);
+ return;
+}
+
+Print_Usage_and_Exit(noptions, options, io_options)
+int noptions;
+struct Option_Struct *options;
+char *io_options;
+{ fprintf(stderr, "usage: %s%s%s",
+ Program_Name,
+ (((io_options == NULL) ||
+ (io_options[0] == '\0')) ? "" : " "),
+ io_options);
+ if (noptions != 0)
+ { putc(' ', stderr);
+ Print_Options(noptions, options, stderr);
+ }
+ putc('\n', stderr);
+ exit(1);
+}
+\f
+/* Top level of program */
+
+/* When debugging force arguments on command line */
+
+#ifdef DEBUG
+#undef unix
+#endif
+
+#ifdef unix
+
+/* On unix use io redirection */
+
+Setup_Program(argc, argv, Noptions, Options)
+int argc;
+char *argv[];
+int Noptions;
+struct Option_Struct *Options;
+{ extern do_it();
+ Program_Name = argv[0];
+ Input_File = stdin;
+ Output_File = stdout;
+ if (((argc - 1) > Noptions) ||
+ (Find_Options((argc - 1), &argv[1], Noptions, Options) != NULL))
+ Print_Usage_and_Exit(Noptions, Options, "");
+ do_it();
+ return;
+}
+
+#else
+
+/* Otherwise use command line arguments */
+
+Setup_Program(argc, argv, Noptions, Options)
+int argc;
+char *argv[];
+int Noptions;
+struct Option_Struct *Options;
+{ extern do_it();
+ Program_Name = argv[0];
+ if ((argc < 3) ||
+ ((argc - 3) > Noptions) ||
+ (Find_Options((argc - 3), &argv[3], Noptions, Options) != NULL))
+ Print_Usage_and_Exit(Noptions, Options, "input_file output_file");
+ Input_File = ((strequal(argv[1], "-")) ?
+ stdin :
+ fopen(argv[1], "r"));
+ if (Input_File == NULL)
+ { perror("Open failed.");
+ exit(1);
+ }
+ Output_File = ((strequal(argv[2], "-")) ?
+ stdout :
+ fopen(argv[2], "w"));
+ if (Output_File == NULL)
+ { perror("Open failed.");
+ fclose(Input_File);
+ exit(1);
+ }
+ fprintf(stderr, "%s: Reading from %s, writing to %s.\n",
+ Program_Name, argv[1], argv[2]);
+ do_it();
+ fclose(Input_File);
+ fclose(Output_File);
+ return;
+}
+
+#endif
+
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: TO_INTERNAL.C
+ *
+ * This File contains the code to translate portable format binary
+ * files to internal format.
+ *
+ */
+\f
+/* Cheap renames */
+
+#define Portable_File Input_File
+#define Internal_File Output_File
+
+#include "translate.h"
+
+static long Dumped_Object_Addr, Dumped_Ext_Prim_Addr;
+static long Dumped_Heap_Base, Heap_Objects, Heap_Count;
+static long Dumped_Constant_Base, Constant_Objects, Constant_Count;
+static long Dumped_Pure_Base, Pure_Objects, Pure_Count;
+static Pointer *Heap;
+static Pointer *Heap_Base, *Heap_Table, *Heap_Object_Base, *Free;
+static Pointer *Constant_Base, *Constant_Table,
+ *Constant_Object_Base, *Free_Constant;
+static Pointer *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure;
+static Pointer *Stack_Top;
+
+Write_Data(Count, From_Where)
+long Count;
+Pointer *From_Where;
+{ fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File);
+}
+
+#include "dump.c"
+\f
+#define OUT(c) return ((long) ((c) & MAX_CHAR))
+
+long read_a_char()
+{ fast char C = getc(Portable_File);
+ if (C != '\\') OUT(C);
+ C = getc(Portable_File);
+ switch(C)
+ { case 'n': OUT('\n');
+ case 't': OUT('\n');
+ case 'r': OUT('\r');
+ case 'f': OUT('\f');
+ case '0': OUT('\0');
+ case 'X':
+ { long Code;
+ fprintf(stderr,
+ "%s: File is not Portable. Character Code Found.\n",
+ Program_Name);
+ fscanf(Portable_File, "%d", &Code);
+ getc(Portable_File); /* Space */
+ OUT(Code);
+ }
+ case '\\': OUT('\\');
+ default : OUT(C);
+ }
+}
+\f
+Pointer *read_a_string(To, Slot)
+Pointer *To, *Slot;
+{ long maxlen, len, Pointer_Count;
+ fast char *string = ((char *) (&To[STRING_CHARS]));
+ *Slot = Make_Pointer(TC_CHARACTER_STRING, To);
+ fscanf(Portable_File, "%ld %ld", &maxlen, &len);
+ maxlen += 1; /* Null terminated */
+ Pointer_Count = STRING_CHARS + char_to_pointer(maxlen);
+ To[STRING_HEADER] =
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1));
+ To[STRING_LENGTH] = Make_Non_Pointer(TC_FIXNUM, len);
+ getc(Portable_File); /* Space */
+ while (--len >= 0) *string++ = ((char) read_a_char());
+ *string = '\0';
+ return (To + Pointer_Count);
+}
+\f
+Pointer *read_an_integer(The_Type, To, Slot)
+int The_Type;
+Pointer *To;
+Pointer *Slot;
+{ Boolean negative;
+ long size_in_bits;
+
+ getc(Portable_File); /* Space */
+ negative = ((getc(Portable_File)) == '-');
+ fscanf(Portable_File, "%ld", &size_in_bits);
+ if ((size_in_bits <= fixnum_to_bits) &&
+ (The_Type == TC_FIXNUM))
+ { fast long Value = 0;
+ fast int Normalization;
+ fast long ndigits;
+ long digit;
+ if (size_in_bits != 0)
+ for(Normalization = 0,
+ ndigits = hex_digits(size_in_bits);
+ --ndigits >= 0;
+ Normalization += 4)
+ { fscanf(Portable_File, "%1lx", &digit);
+ Value += (digit << Normalization);
+ }
+ if (negative) Value = -Value;
+ *Slot = Make_Non_Pointer(TC_FIXNUM, Value);
+ return To;
+ }
+ else if (size_in_bits == 0)
+ { bigdigit *REG = BIGNUM(To);
+ Prepare_Header(REG, 0, POSITIVE);
+ *Slot = Make_Pointer(TC_BIG_FIXNUM, To);
+ return (To + Align(0));
+ }
+ else
+ { fast bigdigit *The_Bignum;
+ fast long size, nbits, ndigits;
+ fast unsigned long Temp;
+ long Length;
+ if ((The_Type == TC_FIXNUM) && (!Compact_P))
+ fprintf(stderr,
+ "%s: Fixnum too large, coercing to bignum.\n",
+ Program_Name);
+ size = bits_to_bigdigit(size_in_bits);
+ ndigits = hex_digits(size_in_bits);
+ Length = Align(size);
+ The_Bignum = BIGNUM(To);
+ Prepare_Header(The_Bignum, size, (negative ? NEGATIVE : POSITIVE));
+ for (The_Bignum = Bignum_Bottom(The_Bignum), nbits = 0, Temp = 0;
+ --size >= 0;
+ )
+ { for ( ;
+ (nbits < SHIFT) && (ndigits > 0);
+ ndigits -= 1, nbits += 4)
+ { long digit;
+ fscanf(Portable_File, "%1lx", &digit);
+ Temp |= (((unsigned long) digit) << nbits);
+ }
+ *The_Bignum++ = Rem_Radix(Temp);
+ Temp = Div_Radix(Temp);
+ nbits -= SHIFT;
+ }
+ *Slot = Make_Pointer(TC_BIG_FIXNUM, To);
+ return (To + Length);
+ }
+}
+\f
+/* Underflow and Overflow */
+
+/* dflmax and dflmin exist in the Berserkely FORTRAN library */
+
+static double the_max = 0.0;
+
+#define dflmin() 0.0 /* Cop out */
+#define dflmax() ((the_max == 0.0) ? compute_max() : the_max)
+
+double compute_max()
+{ fast double Result = 0.0;
+ fast int expt;
+ for (expt = MAX_FLONUM_EXPONENT;
+ expt != 0;
+ expt >>= 1)
+ Result += ldexp(1.0, expt);
+ the_max = Result;
+ return Result;
+}
+\f
+double read_a_flonum()
+{ Boolean negative;
+ long size_in_bits, exponent;
+ fast double Result;
+
+ getc(Portable_File); /* Space */
+ negative = ((getc(Portable_File)) == '-');
+ fscanf(Portable_File, "%ld %ld", &exponent, &size_in_bits);
+ if (size_in_bits == 0) Result = 0.0;
+ else if ((exponent > MAX_FLONUM_EXPONENT) ||
+ (exponent < -MAX_FLONUM_EXPONENT))
+ { /* Skip over mantissa */
+ while (getc(Portable_File) != '\n') ;
+ fprintf(stderr,
+ "%s: Floating point exponent too %s!\n",
+ Program_Name,
+ ((exponent < 0) ? "small" : "large"));
+ Result = ((exponent < 0) ? dflmin() : dflmax());
+ }
+ else
+ { fast long ndigits;
+ fast double Normalization;
+ long digit;
+ if (size_in_bits > FLONUM_MANTISSA_BITS)
+ fprintf(stderr,
+ "%s: Some precission may be lost.",
+ Program_Name);
+ getc(Portable_File); /* Space */
+ for (ndigits = hex_digits(size_in_bits),
+ Result = 0.0,
+ Normalization = (1.0 / 16.0);
+ --ndigits >= 0;
+ Normalization /= 16.0)
+ { fscanf(Portable_File, "%1lx", &digit);
+ Result += (((double ) digit) * Normalization);
+ }
+ Result = ldexp(Result, ((int) exponent));
+ }
+ if (negative) Result = -Result;
+ return Result;
+}
+\f
+Pointer *
+Read_External(N, Table, To)
+ long N;
+ fast Pointer *Table, *To;
+{
+ fast Pointer *Until = &Table[N];
+ int The_Type;
+
+ while (Table < Until)
+ {
+ fscanf(Portable_File, "%2x", &The_Type);
+ switch(The_Type)
+ {
+ case TC_CHARACTER_STRING:
+ To = read_a_string(To, Table++);
+ continue;
+ case TC_FIXNUM:
+ case TC_BIG_FIXNUM:
+ To = read_an_integer(The_Type, To, Table++);
+ continue;
+ case TC_CHARACTER:
+ {
+ long the_char_code;
+
+ getc(Portable_File); /* Space */
+ fscanf( Portable_File, "%3x", &the_char_code);
+ *Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
+ continue;
+ }
+ case TC_BIG_FLONUM:
+ {
+ double The_Flonum = read_a_flonum();
+
+ Align_Float(To);
+ *Table++ = Make_Pointer(TC_BIG_FLONUM, To);
+ *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (float_to_pointer));
+ *((double *) To) = The_Flonum;
+ To += float_to_pointer;
+ continue;
+ }
+ default:
+ fprintf(stderr,
+ "%s: Unknown external object found; Type = 0x%02x\n",
+ Program_Name, The_Type);
+ exit(1);
+ }
+ }
+ return To;
+}
+\f
+#if false
+Move_Memory(From, N, To)
+fast Pointer *From, *To;
+long N;
+{ fast Pointer *Until = &From[N];
+ while (From < Until) *To++ = *From++;
+ return;
+}
+#endif
+
+Relocate_Objects(From, N, disp)
+fast Pointer *From;
+long N;
+fast long disp;
+{ fast Pointer *Until = &From[N];
+ while (From < Until)
+ { switch(Type_Code(*From))
+ { case TC_FIXNUM:
+ case TC_CHARACTER:
+ From += 1;
+ break;
+ case TC_BIG_FIXNUM:
+ case TC_BIG_FLONUM:
+ case TC_CHARACTER_STRING:
+ *From++ == Make_Object(Type_Code(*From), (disp + Datum(*From)));
+ break;
+ default:
+ fprintf(stderr,
+ "%s: Unknown External Object Reference with Type 0x%02x",
+ Program_Name,
+ Type_Code(*From));
+ }
+ }
+}
+\f
+#define Relocate_Into(Where, Addr) \
+if ((Addr) < Dumped_Pure_Base) \
+ (Where) = &Heap_Object_Base[(Addr) - Dumped_Heap_Base]; \
+else if ((Addr) < Dumped_Constant_Base) \
+ (Where) = &Pure_Base[(Addr) - Dumped_Pure_Base]; \
+else (Where) = &Constant_Base[(Addr) - Dumped_Constant_Base];
+
+#ifndef Conditional_Bug
+
+#define Relocate(Addr) \
+(((Addr) < Dumped_Pure_Base) ? \
+ &Heap_Object_Base[(Addr) - Dumped_Heap_Base] : \
+ (((Addr) < Dumped_Constant_Base) ? \
+ &Pure_Base[(Addr) - Dumped_Pure_Base] : \
+ &Constant_Base[(Addr) - Dumped_Constant_Base]))
+
+#else
+static Pointer *Relocate_Temp;
+#define Relocate(Addr) \
+ (Relocate_Into(Relocate_Temp, Addr), Relocate_Temp)
+#endif
+
+Pointer *Read_Pointers_and_Relocate(N, To)
+fast long N;
+fast Pointer *To;
+{ int The_Type;
+ long The_Datum;
+/* Align_Float(To); */
+ while (--N >= 0)
+ { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
+ switch((The_Type) & SAFE_TYPE_MASK)
+ { case CONSTANT_CODE:
+ if (The_Type > MAX_SAFE_TYPE)
+ { *To = Constant_Table[The_Datum];
+ Set_Danger_Bit(*To++);
+ continue;
+ }
+ *To++ = Constant_Table[The_Datum];
+ continue;
+
+ case HEAP_CODE:
+ if (The_Type > MAX_SAFE_TYPE)
+ { *To = Heap_Table[The_Datum];
+ Set_Danger_Bit(*To++);
+ continue;
+ }
+ *To++ = Heap_Table[The_Datum];
+ continue;
+
+ case TC_MANIFEST_NM_VECTOR:
+ if (!(Null_NMV)) /* Unknown object! */
+ fprintf(stderr, "%s: File is not portable: NMH found\n",
+ Program_Name);
+ *To++ = Make_Non_Pointer(The_Type, The_Datum);
+ { fast long count = The_Datum;
+ N -= count;
+ while (--count >= 0)
+ { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
+ *To++ = Make_Non_Pointer(The_Type, The_Datum);
+ }
+ }
+ continue;
+
+ case TC_BROKEN_HEART:
+ if (The_Datum != 0)
+ { fprintf(stderr, "%s: Broken Heart Found\n", Program_Name);
+ exit(1);
+ }
+ /* Fall Through */
+ case TC_PRIMITIVE_EXTERNAL:
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ case_simple_Non_Pointer:
+ *To++ = Make_Non_Pointer(The_Type, The_Datum);
+ continue;
+
+ default:
+ /* Should be stricter */
+ *To++ = Make_Pointer(The_Type, Relocate(The_Datum));
+ continue;
+ }
+ }
+/* Align_Float(To); */
+ return To;
+}
+\f
+#ifdef DEBUG
+Print_External_Objects(area_name, Table, N)
+char *area_name;
+fast Pointer *Table;
+fast long N;
+{ fast Pointer *Table_End = &Table[N];
+
+ fprintf(stderr, "%s External Objects:\n", area_name);
+ fprintf(stderr, "Table = 0x%x; N = %d\n", Table, N);
+
+ for( ; Table < Table_End; Table++)
+ switch (Type_Code(*Table))
+ { case TC_FIXNUM:
+ { long The_Number;
+ Sign_Extend(*Table, The_Number);
+ fprintf(stderr,
+ "Table[%6d] = Fixnum %d\n",
+ (N-(Table_End-Table)),
+ The_Number);
+ break;
+ }
+ case TC_CHARACTER:
+ fprintf(stderr,
+ "Table[%6d] = Character %c = 0x%02x\n",
+ (N-(Table_End-Table)),
+ Get_Integer(*Table),
+ Get_Integer(*Table));
+ break;
+
+/* Print_External_Objects continues on the next page */
+\f
+/* Print_External_Objects, continued */
+
+ case TC_CHARACTER_STRING:
+ fprintf(stderr,
+ "Table[%6d] = string \"%s\"\n",
+ (N-(Table_End-Table)),
+ ((char *) Nth_Vector_Loc(*Table, STRING_CHARS)));
+ break;
+ case TC_BIG_FIXNUM:
+ fprintf(stderr,
+ "Table[%6d] = Bignum\n",
+ (N-(Table_End-Table)));
+ break;
+ case TC_BIG_FLONUM:
+ fprintf(stderr,
+ "Table[%6d] = Flonum %lf\n",
+ (N-(Table_End-Table)),
+ (* ((double *) Nth_Vector_Loc(*Table, 1))));
+ break;
+ default:
+ fprintf(stderr,
+ "Table[%6d] = Unknown External Object 0x%8x\n",
+ (N-(Table_End-Table)),
+ *Table);
+ break;
+ }
+}
+#endif
+\f
+long Read_Header_and_Allocate()
+{ long Portable_Version, Flags, Version, Sub_Version;
+ long NFlonums, NIntegers, NStrings, NBits, NChars;
+ long Size;
+
+ /* Read Header */
+
+ fscanf(Input_File, "%ld %ld %ld %ld",
+ &Portable_Version, &Flags, &Version, &Sub_Version);
+ fscanf(Input_File, "%ld %ld %ld",
+ &Heap_Count, &Dumped_Heap_Base, &Heap_Objects);
+ fscanf(Input_File, "%ld %ld %ld",
+ &Constant_Count, &Dumped_Constant_Base, &Constant_Objects);
+ fscanf(Input_File, "%ld %ld %ld",
+ &Pure_Count, &Dumped_Pure_Base, &Pure_Objects);
+ fscanf(Input_File, "%ld %ld %ld %ld %ld",
+ &NFlonums, &NIntegers, &NStrings, &NBits, &NChars);
+ fscanf(Input_File, "%ld %ld",
+ &Dumped_Object_Addr, &Dumped_Ext_Prim_Addr);
+
+ if ((Portable_Version != PORTABLE_VERSION) ||
+ (Version != FASL_FORMAT_VERSION) ||
+ (Sub_Version != FASL_SUBVERSION))
+ { fprintf(stderr,
+ "FASL File Version %4d Subversion %4d Portable Version %4d\n",
+ Version, Sub_Version , Portable_Version);
+ fprintf(stderr,
+ "Expected: Version %4d Subversion %4d Portable Version %4d\n",
+ FASL_FORMAT_VERSION, FASL_SUBVERSION, PORTABLE_VERSION);
+ exit(1);
+ }
+
+ Read_Flags(Flags);
+
+ Size = (6 + /* SNMV */
+ Heap_Count + Heap_Objects +
+ Constant_Count + Constant_Objects +
+ Pure_Count + Pure_Objects +
+ flonum_to_pointer(NFlonums) +
+ ((NIntegers * bignum_header_to_pointer) +
+ (bigdigit_to_pointer(bits_to_bigdigit(NBits)))) +
+ ((NStrings * STRING_CHARS) + (char_to_pointer(NChars))));
+
+ Allocate_Heap_Space(Size);
+ if (Heap == NULL)
+ { fprintf(stderr,
+ "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
+ Program_Name, Size);
+ exit(1);
+ }
+ return Size;
+}
+\f
+do_it()
+{ long Size;
+ Size = Read_Header_and_Allocate();
+ Stack_Top = &Heap[Size];
+
+ Heap_Table = &Heap[0];
+ Heap_Base = &Heap_Table[Heap_Objects];
+ Heap_Object_Base =
+ Read_External(Heap_Objects, Heap_Table, Heap_Base);
+
+ Pure_Table = &Heap_Object_Base[Heap_Count];
+ Pure_Base = &Pure_Table[Pure_Objects + 2]; /* SNMV */
+ Pure_Object_Base =
+ Read_External(Pure_Objects, Pure_Table, Pure_Base);
+
+ Constant_Table = &Heap[Size - Constant_Objects];
+ Constant_Base = &Pure_Object_Base[Pure_Count + 2]; /* SNMV */
+ Constant_Object_Base =
+ Read_External(Constant_Objects, Constant_Table, Constant_Base);
+
+#ifdef DEBUG
+ Print_External_Objects("Heap", Heap_Table, Heap_Objects);
+ Print_External_Objects("Pure", Pure_Table, Pure_Objects);
+ Print_External_Objects("Constant", Constant_Table, Constant_Objects);
+#endif
+\f
+ /* Read the normal objects */
+
+ Free =
+ Read_Pointers_and_Relocate(Heap_Count, Heap_Object_Base);
+ Free_Pure =
+ Read_Pointers_and_Relocate(Pure_Count, Pure_Object_Base);
+ Free_Constant =
+ Read_Pointers_and_Relocate(Constant_Count, Constant_Object_Base);
+
+ /* Dump the objects */
+
+ { Pointer *Dumped_Object, *Dumped_Ext_Prim;
+ Relocate_Into(Dumped_Object, Dumped_Object_Addr);
+ Relocate_Into(Dumped_Ext_Prim, Dumped_Ext_Prim_Addr);
+
+#ifdef DEBUG
+ fprintf(stderr, "Dumping:\n");
+ fprintf(stderr,
+ "Heap = 0x%x; Heap Count = %d\n",
+ Heap_Base, (Free - Heap_Base));
+ fprintf(stderr,
+ "Pure Space = 0x%x; Pure Count = %d\n",
+ Pure_Base, (Free_Pure - Pure_Base));
+ fprintf(stderr,
+ "Constant Space = 0x%x; Constant Count = %d\n",
+ Constant_Base, (Free_Constant - Constant_Base));
+ fprintf(stderr,
+ "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
+ Dumped_Object, *Dumped_Object);
+ fprintf(stderr,
+ "& Dumped Ext Prim = 0x%x; Dumped Ext Prim = 0x%x\n",
+ Dumped_Ext_Prim, *Dumped_Ext_Prim);
+#endif
+
+ /* Is there a Pure/Constant block? */
+
+ if ((Constant_Objects == 0) && (Constant_Count == 0) &&
+ (Pure_Objects == 0) && (Pure_Count == 0))
+ Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
+ 0, &Heap[Size], Dumped_Ext_Prim);
+ else
+ { long Pure_Length = (Constant_Base - Pure_Base) + 1;
+ long Total_Length = (Free_Constant - Pure_Base) + 4;
+ Pure_Base[-2] =
+ Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, (Pure_Length - 1));
+ Pure_Base[-1] =
+ Make_Non_Pointer(PURE_PART, Total_Length);
+ Constant_Base[-2] =
+ Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ Constant_Base[-1] =
+ Make_Non_Pointer(CONSTANT_PART, (Pure_Length - 1));
+ Free_Constant[0] =
+ Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ Free_Constant[1] =
+ Make_Non_Pointer(END_OF_BLOCK, Total_Length);
+
+ Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
+ Total_Length, (Pure_Base - 2), Dumped_Ext_Prim);
+ }
+ }
+ return;
+}
+\f
+/* Top level */
+
+static int Noptions = 0;
+/* C does not usually like empty initialized arrays, so ... */
+static struct Option_Struct Options[] = {{"dummy", true, NULL}};
+
+main(argc, argv)
+int argc;
+char *argv[];
+{ Setup_Program(argc, argv, Noptions, Options);
+ return;
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: purify.c
+ *
+ * This file contains the code for primitives dealing with pure
+ * and constant space.
+ *
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+#include "gccode.h"
+#include "zones.h"
+\f
+/* This is a copy of GCLoop, with GC_Mode handling added, and
+ debugging printout removed.
+*/
+
+#define Purify_Pointer(Code) \
+Old = Get_Pointer(Temp); \
+if ((GC_Mode == CONSTANT_COPY) && \
+ (Old > Low_Constant)) \
+ continue; \
+Code
+
+#define Setup_Pointer_for_Purify(Extra_Code) \
+Purify_Pointer(Setup_Pointer(false, Extra_Code))
+
+#define Indirect_BH(In_GC) \
+if (Type_Code(*Old) == TC_BROKEN_HEART) continue;
+
+#define Transport_Indirect() \
+Real_Transport_Vector(); \
+*Get_Pointer(Temp) = New_Address
+\f
+Pointer *PurifyLoop(Scan, To_Pointer, GC_Mode)
+fast Pointer *Scan;
+Pointer **To_Pointer;
+int GC_Mode;
+{ fast Pointer *To, *Old, Temp, *Low_Constant, New_Address;
+
+ To = *To_Pointer;
+ Low_Constant = Constant_Space;
+ for ( ; Scan != To; Scan++)
+ { Temp = *Scan;
+ Switch_by_GC_Type(Temp)
+ { case TC_BROKEN_HEART:
+ if (Scan == (Get_Pointer(Temp)))
+ { *To_Pointer = To;
+ return Scan;
+ }
+ fprintf(stderr, "Purify: Broken heart in scan.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+
+ case TC_MANIFEST_NM_VECTOR:
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ Scan += Get_Integer(Temp);
+ break;
+
+ case_Non_Pointer:
+ break;
+
+ case_compiled_entry_point:
+ if (GC_Mode == PURE_COPY) break;
+ Purify_Pointer(Setup_Internal(false,
+ Transport_Compiled(),
+ Compiled_BH(false, continue)));
+
+ case_Cell:
+ Setup_Pointer_for_Purify(Transport_Cell());
+
+/* PurifyLoop continues on the next page */
+\f
+/* PurifyLoop, continued */
+
+ case TC_INTERNED_SYMBOL:
+ case TC_UNINTERNED_SYMBOL:
+ if (GC_Mode == PURE_COPY)
+ { Temp = Vector_Ref(Temp, SYMBOL_NAME);
+ Purify_Pointer(Setup_Internal(false,
+ Transport_Indirect(),
+ Indirect_BH(false)));
+ }
+ /* Fall through */
+ case_Fasdump_Pair:
+ Setup_Pointer_for_Purify(Transport_Pair());
+
+ case TC_WEAK_CONS:
+ Setup_Pointer_for_Purify(Transport_Weak_Cons());
+
+/* Because variables no longer contain pointers (except for the symbol),
+ they are permitted into pure space now. */
+
+ case TC_VARIABLE:
+ Setup_Pointer_for_Purify(Purify_Transport_Variable());
+
+ case_Triple:
+ Setup_Pointer_for_Purify(Transport_Triple());
+
+/* PurifyLoop continues on the next page */
+\f
+/* PurifyLoop, continued */
+
+#ifdef QUADRUPLE
+ case_Quadruple:
+ Setup_Pointer_for_Purify(Transport_Quadruple());
+#endif
+
+ /* No need to handle futures specially here, since PurifyLoop
+ is always invoked after running GCLoop, which will have
+ spliced all spliceable futures unless the GC itself of the
+ GC dameons spliced them, but this should not occur.
+ */
+
+ case TC_FUTURE:
+ case TC_ENVIRONMENT:
+ if (GC_Mode == PURE_COPY) break;
+ /* Fall through */
+#ifndef FLOATING_ALIGNMENT
+ case TC_BIG_FLONUM:
+ /* Fall through */
+#endif
+ case_Purify_Vector:
+ purify_vector:
+ Setup_Pointer_for_Purify(Transport_Vector());
+
+#ifdef FLOATING_ALIGNMENT
+ case TC_BIG_FLONUM:
+ Setup_Pointer_for_Purify(Transport_Flonum());
+#endif
+
+ default:
+ fprintf(stderr,
+ "PurifyLoop: Bad type code = 0x%02x\n",
+ Type_Code(Temp));
+ Invalid_Type_Code();
+ } /* Switch_by_GC_Type */
+ } /* For loop */
+ *To_Pointer = To;
+ return To;
+} /* PurifyLoop */
+\f
+/* Description of the algorithm for PURIFY:
+
+ The algorithm is trickier than would first appear necessary. This
+ is because the size of the object being purified must be
+ calculated. The idea is that the entire object is copied into the
+ new heap, and then a normal GC is done (the broken hearts created
+ by the copy will, of course, now be used to relocate references to
+ parts of the object). If there is not enough room in constant
+ space for the object, processing stops with a #!false return and
+ the world flipped into the new heap. Otherwise, the
+ process is repeated, moving the object into constant space on the
+ first pass and then doing a GC back into the original heap.
+
+ Notice that in order to make a pure object, the copy process
+ proceeds in two halves. During the first half (which collects the
+ pure part) Compiled Code, Environments, Symbols, and Variables
+ (i.e. things whose contents change) are NOT copied. Then a header
+ is put down indicating constant (not pure) area, and then they ARE
+ copied.
+
+ The constant area contains a contiguous set of blocks of the
+ following format:
+
+ >>Top of Memory (Stack above here)<<
+
+ . (direction of growth)
+ . ^
+ . / \
+ . |
+ . |
+ |----------------------|...
+ | END | Total Size M | . Where END = TC_FIXNUM
+ |----------------------| . SNMH = TC_MANIFEST_SPECIAL_...
+ | SNMH | 1 | | CONST = TC_TRUE
+ |----------------------| | PURE = TC_FALSE
+ | | |
+ | | |
+ | CONSTANT AREA | |
+ | | |
+ | | .
+ ...|----------------------| > M
+ . | CONST | Pure Size N | .
+ . |----------------------| |
+ | | SNMH | 1 | |
+ | |----------------------| |
+ | | | |
+N < | | |
+ | | PURE AREA | |
+ | | | |
+ . | | .
+ . |----------------------| .
+ ...| PURE | Total Size M |...
+ |----------------------|
+ | SNMH | Pure Size N |
+ |----------------------|
+
+ >>Base of Memory (Heap below here)<<
+*/
+\f
+/* The result returned by Purify is a vector containing this data */
+
+#define Purify_Vector_Header 0
+#define Purify_Length 1
+#define Purify_Really_Pure 2
+#define Purify_N_Slots 2
+
+Pointer Purify(Object, Purify_Object)
+Pointer Object, Purify_Object;
+{ long Length;
+ Pointer *Heap_Start, *Result, Answer;
+
+/* Pass 1 -- Copy object to new heap, then GC into that heap */
+
+ GCFlip();
+ Heap_Start = Free;
+ *Free++ = Object;
+ Result = GCLoop(Heap_Start, &Free);
+ if (Free != Result)
+ { fprintf(stderr, "\Purify: Pure Scan ended too early.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+ }
+ Length = (Free-Heap_Start)-1; /* Length of object */
+ GC();
+ Free[Purify_Vector_Header] =
+ Make_Non_Pointer(TC_MANIFEST_VECTOR, Purify_N_Slots);
+ Free[Purify_Length] = FIXNUM_0 + Length;
+ Free[Purify_Really_Pure] = Purify_Object;
+ Answer = Make_Pointer(TC_VECTOR, Free);
+ Free += Purify_N_Slots+1;
+ return Answer;
+}
+\f
+Pointer Purify_Pass_2(Info)
+Pointer Info;
+{ long Length = Get_Integer(Fast_Vector_Ref(Info, Purify_Length));
+ Boolean Purify_Object;
+ Pointer *New_Object, Relocated_Object, *Result, Answer;
+ long Pure_Length, Recomputed_Length;
+
+ if (Fast_Vector_Ref(Info, Purify_Really_Pure) == NIL)
+ Purify_Object = false;
+ else Purify_Object = true;
+ Relocated_Object = *Heap_Bottom;
+ if (!Test_Pure_Space_Top(Free_Constant+Length+6))
+ return NIL;
+ New_Object = Free_Constant;
+ GCFlip();
+ *Free_Constant++ = NIL; /* Will hold pure space header */
+ *Free_Constant++ = Relocated_Object;
+ if (Purify_Object)
+ { Result = PurifyLoop(New_Object+1, &Free_Constant, PURE_COPY);
+ if (Free_Constant != Result)
+ { fprintf(stderr, "\Purify: Pure Copy ended too early.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+ }
+ Pure_Length = (Free_Constant-New_Object) + 1;
+ }
+ else Pure_Length = 3;
+ *Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *Free_Constant++ = Make_Non_Pointer(CONSTANT_PART, Pure_Length);
+ if (Purify_Object)
+ { Result = PurifyLoop(New_Object + 1, &Free_Constant, CONSTANT_COPY);
+ if (Result != Free_Constant)
+ { fprintf(stderr, "\Purify: Constant Copy ended too early.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+ }
+ }
+
+/* Purify_Pass_2 continues on the next page */
+\f
+/* Purify_Pass_2, continued */
+
+ else
+ { Result = GCLoop(New_Object + 1, &Free_Constant);
+ if (Result != Free_Constant)
+ { fprintf(stderr, "\Purify: Constant Copy ended too early.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+ }
+ }
+ Recomputed_Length = (Free_Constant-New_Object)-4;
+ *Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *Free_Constant++ = Make_Non_Pointer(END_OF_BLOCK, Recomputed_Length+5);
+ if (Length > Recomputed_Length)
+ { printf("Purify phase error %x, %x\n", Length, Recomputed_Length);
+ Microcode_Termination(TERM_EXIT);
+ }
+ *New_Object++ =
+ Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, Pure_Length);
+ *New_Object = Make_Non_Pointer(PURE_PART, Recomputed_Length+5);
+ GC();
+ Set_Pure_Top();
+ return TRUTH;
+}
+\f
+/* (PRIMITIVE_PURIFY OBJECT PURE?)
+ [Primitive number 0xB4]
+ Copy an object from the heap into constant space. This requires
+ a spare heap, and is tricky to use -- it should only be used
+ through the wrapper provided in the Scheme runtime system.
+
+ To purify an object we just copy it into Pure Space in two
+ parts with the appropriate headers and footers. The actual
+ copying is done by PurifyLoop above. If we run out of room
+ SCHEME crashes.
+
+ Once the copy is complete we run a full GC which handles the
+ broken hearts which now point into pure space. On a
+ multiprocessor, this primitive uses the master-gc-loop and it
+ should only be used as one would use master-gc-loop i.e. with
+ everyone else halted.
+*/
+
+Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY")
+{ long Saved_Zone;
+ Pointer Object, Lost_Objects, Purify_Result;
+
+ Primitive_2_Args();
+ Save_Time_Zone(Zone_Purify);
+ if ((Arg2 != TRUTH) && (Arg2 != NIL))
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+
+ /* Pass 1 (Purify, above) does a first copy. Then any GC daemons
+ run, and then Purify_Pass_2 is called to copy back.
+ */
+
+ Touch_In_Primitive(Arg1, Object);
+ Purify_Result = Purify(Object, Arg2);
+ if (Get_Fixed_Obj_Slot(GC_Daemon) == NIL)
+ return (Purify_Pass_2(Purify_Result));
+ Pop_Primitive_Frame(2);
+ Store_Expression(Purify_Result);
+ Store_Return(RC_PURIFY_GC_1);
+ Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
+ Save_Cont();
+ Push(Get_Fixed_Obj_Slot(GC_Daemon));
+ Push(STACK_FRAME_HEADER);
+ Pushed();
+ longjmp(*Back_To_Eval, PRIM_APPLY); /*NOTREACHED*/
+}
+\f
+Boolean Pure_Test(Obj_Address)
+fast Pointer *Obj_Address;
+{ fast Pointer *Where;
+#ifdef FLOATING_ALIGNMENT
+ fast Pointer Float_Align_Value = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
+#endif
+ Where = Free_Constant-1;
+ while (Where >= Constant_Space)
+ {
+#ifdef FLOATING_ALIGNMENT
+ while (*Where == Float_Align_Value) Where -= 1;
+#endif
+ Where -= 1+Get_Integer(*Where);
+ if (Where <= Obj_Address)
+ return (Boolean) (Obj_Address <= (Where+1+Get_Integer(*(Where+1))));
+ }
+ return (Boolean) false;
+}
+
+/* (PURE_P OBJECT)
+ [Primitive number 0xBB]
+ Returns #!TRUE if the object is pure (ie it doesn't point to any
+ other object, or it is in a pure section of the constant space).
+*/
+Built_In_Primitive(Prim_Pure_P, 1, "PURE?")
+{ Primitive_1_Arg();
+
+ if ((GC_Type_Non_Pointer(Arg1)) ||
+ (GC_Type_Special(Arg1)))
+ return TRUTH;
+ if (GC_Type_Compiled(Arg1)) return NIL;
+ Touch_In_Primitive(Arg1, Arg1);
+ { Pointer *Obj_Address;
+ Obj_Address = Get_Pointer(Arg1);
+ if (Is_Pure(Obj_Address)) return TRUTH;
+ }
+ return NIL;
+}
+\f
+Pointer Make_Impure(Object)
+Pointer Object;
+{ Pointer *New_Address, *End_Of_Area;
+ fast Pointer *Obj_Address, *Constant_Address;
+ long Length, Block_Length;
+ fast long i;
+
+ /* Calculate size of object to be "impurified".
+ Note that this depends on the fact that Compiled Entries CANNOT
+ be pure.
+ */
+
+ Switch_by_GC_Type(Object)
+ { case TC_BROKEN_HEART:
+ case TC_MANIFEST_NM_VECTOR:
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ case_Non_Pointer:
+ printf("Impurify Non-Pointer.\n");
+ Microcode_Termination(TERM_NON_POINTER_RELOCATION);
+ case TC_BIG_FLONUM:
+ case TC_FUTURE:
+ case_Vector: Length = Vector_Length(Object) + 1; break;
+ case_Quadruple: Length = 4; break;
+ case TC_VARIABLE:
+ case_Triple: Length = 3; break;
+ case TC_WEAK_CONS:
+ case_Pair: Length = 2; break;
+ case_Cell: Length = 1; break;
+ default:
+ fprintf(stderr, "Impurify: Bad type code = 0x%02x\n",
+ Type_Code(Object));
+ Invalid_Type_Code();
+ }
+
+ /* Add a copy of the object to the last constant block in memory.
+ */
+
+ Constant_Address = Free_Constant;
+
+ Obj_Address = Get_Pointer(Object);
+ if (!Test_Pure_Space_Top(Constant_Address+Length)) return NIL;
+ Block_Length = Get_Integer(*(Constant_Address-1));
+ Constant_Address = Constant_Address-2;
+ New_Address = Constant_Address;
+
+#ifdef FLOATING_ALIGNMENT
+ /* This should be done more cleanly, always align before doing a
+ block, or something like it. -- JINX
+ */
+
+ if (Type_Code(Object) == TC_BIG_FLONUM)
+ { Pointer *Start = Constant_Address;
+ Align_Float(Constant_Address);
+ for (i=0; i < Length; i++) *Constant_Address++ = *Obj_Address++;
+ Length = Constant_Address-Start;
+ }
+ else
+#endif
+ for (i = Length; --i >= 0; )
+ { *Constant_Address++ = *Obj_Address;
+ *Obj_Address++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, i);
+ }
+ *Constant_Address++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *Constant_Address++ = Make_Non_Pointer(END_OF_BLOCK, Block_Length+Length);
+ *(New_Address+2-Block_Length) =
+ Make_Non_Pointer(PURE_PART, Block_Length+Length);
+ Obj_Address -= Length;
+ Free_Constant = Constant_Address;
+
+ /* Run through memory relocating pointers to this object, including
+ * those in pure areas.
+ */
+
+ Set_Pure_Top();
+ Terminate_Old_Stacklet();
+ Terminate_Constant_Space(End_Of_Area);
+ Update(Heap_Bottom, Free, Obj_Address, New_Address);
+ Update(Constant_Space, End_Of_Area, Obj_Address, New_Address);
+ return Make_Pointer(Type_Code(Object), New_Address);
+}
+\f
+/* (IMPURIFY OBJECT)
+ [Primitive number 0xBD]
+*/
+Built_In_Primitive(Prim_Impurify, 1, "IMPURIFY")
+{ Pointer Result;
+ Primitive_1_Arg();
+ Touch_In_Primitive(Arg1, Arg1);
+ Result = Make_Impure(Arg1);
+ if (Result != NIL) return Result;
+ Primitive_Error(ERR_IMPURIFY_OUT_OF_SPACE); /*NOTREACHED*/
+}
+
+Update(From, To, Was, Will_Be)
+fast Pointer *From, *To, *Was, *Will_Be;
+{ for (; From < To; From++)
+ { if (GC_Type_Special(*From))
+ { if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
+ From += Get_Integer(*From);
+ continue;
+ }
+ if (GC_Type_Non_Pointer(*From)) continue;
+ if (Get_Pointer(*From) == Was)
+ *From = Make_Pointer(Type_Code(*From), Will_Be);
+ }
+}
+\f
+/* (CONSTANT? OBJECT)
+ [Primitive number 0xBA]
+ Returns #!TRUE if the object is in constant space or isn't a
+ pointer.
+*/
+Built_In_Primitive(Prim_Constant_P, 1, "CONSTANT?")
+{ Primitive_1_Arg();
+ Touch_In_Primitive(Arg1, Arg1);
+ return ((GC_Type_Non_Pointer(Arg1)) ||
+ (GC_Type_Special(Arg1)) ||
+ ((Get_Pointer(Arg1) >= Constant_Space) &&
+ (Get_Pointer(Arg1) < Free_Constant))) ?
+ TRUTH : NIL;
+}
+\f
+/* copy_to_constant_space is a microcode utility procedure.
+ It takes care of making legal constant space blocks.
+ The microcode kills itself if there is not enough constant
+ space left.
+ */
+
+extern Pointer *copy_to_constant_space();
+
+Pointer *
+copy_to_constant_space(source, nobjects)
+fast Pointer *source;
+long nobjects;
+{ fast Pointer *dest;
+ fast long i;
+ Pointer *result;
+
+ dest = Free_Constant;
+ if (!Test_Pure_Space_Top(dest+nobjects+6))
+ { fprintf(stderr,
+ "copy_to_constant_space: Not enough constant space!\n");
+ Microcode_Termination(TERM_NO_SPACE);
+ }
+ *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 3);
+ *dest++ = Make_Non_Pointer(PURE_PART, nobjects+5);
+ *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *dest++ = Make_Non_Pointer(CONSTANT_PART, 3);
+ result = dest;
+ for (i = nobjects; --i >= 0; )
+ *dest++ = *source++;
+ *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *dest++ = Make_Non_Pointer(END_OF_BLOCK, nobjects+5);
+ Free_Constant = dest;
+
+ return result;
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: returns.h
+ *
+ * Return codes. These are placed in Return when an
+ * interpreter operation needs to operate in several
+ * phases. This must correspond with UTABMD.SCM
+ *
+ */
+\f
+/* These names are also in storage.c.
+ * Please maintain consistency.
+ */
+
+#define RC_END_OF_COMPUTATION 0x00
+/* Used to be RC_RESTORE_CONTROL_POINT */
+#define RC_JOIN_STACKLETS 0x01
+#define RC_RESTORE_CONTINUATION 0x02 /* Used for 68000 */
+#define RC_INTERNAL_APPLY 0x03
+#define RC_BAD_INTERRUPT_CONTINUE 0x04 /* Used for 68000 */
+#define RC_RESTORE_HISTORY 0x05
+/* Generated by primitive WITH_HISTORY_DISABLED */
+#define RC_INVOKE_STACK_THREAD 0x06
+/* Generated by primitive WITH_THREADED_CONTINUATION */
+#define RC_RESTART_EXECUTION 0x07 /* Used for 68000 */
+#define RC_EXECUTE_ASSIGNMENT_FINISH 0x08
+#define RC_EXECUTE_DEFINITION_FINISH 0x09
+#define RC_EXECUTE_ACCESS_FINISH 0x0A
+#define RC_EXECUTE_IN_PACKAGE_CONTINUE 0x0B
+#define RC_SEQ_2_DO_2 0x0C
+#define RC_SEQ_3_DO_2 0x0D
+#define RC_SEQ_3_DO_3 0x0E
+#define RC_CONDITIONAL_DECIDE 0x0F
+#define RC_DISJUNCTION_DECIDE 0x10
+#define RC_COMB_1_PROCEDURE 0x11
+#define RC_COMB_APPLY_FUNCTION 0x12
+#define RC_COMB_2_FIRST_OPERAND 0x13
+#define RC_COMB_2_PROCEDURE 0x14
+#define RC_COMB_SAVE_VALUE 0x15
+#define RC_PCOMB1_APPLY 0x16
+#define RC_PCOMB2_DO_1 0x17
+#define RC_PCOMB2_APPLY 0x18
+#define RC_PCOMB3_DO_2 0x19
+#define RC_PCOMB3_DO_1 0x1A
+#define RC_PCOMB3_APPLY 0x1B
+\f
+#define RC_SNAP_NEED_THUNK 0x1C
+/* Generated by primitive FORCE */
+#define RC_REENTER_COMPILED_CODE 0x1D
+/* Formerly RC_GET_CHAR_REPEAT on 68000 0x1E */
+#define RC_COMPILER_REFERENCE_RESTART 0x1F
+#define RC_NORMAL_GC_DONE 0x20
+#define RC_COMPLETE_GC_DONE 0x21 /* Used for 68000 */
+#define RC_PURIFY_GC_1 0x22
+/* Generated by primitive PURIFY */
+#define RC_PURIFY_GC_2 0x23
+/* Generated by primitive PURIFY */
+#define RC_AFTER_MEMORY_UPDATE 0x24 /* Used for 68000 */
+#define RC_RESTARTABLE_EXIT 0x25 /* Used for 68000 */
+/* formerly RC_GET_CHAR 0x26 */
+/* formerly RC_GET_CHAR_IMMEDIATE 0x27 */
+#define RC_COMPILER_ASSIGNMENT_RESTART 0x28
+#define RC_POP_FROM_COMPILED_CODE 0x29
+#define RC_RETURN_TRAP_POINT 0x2A
+#define RC_RESTORE_STEPPER 0x2B /* Used for 68000 */
+#define RC_RESTORE_TO_STATE_POINT 0x2C
+/* Generated by primitive EXECUTE_AT_NEW_POINT */
+#define RC_MOVE_TO_ADJACENT_POINT 0x2D
+#define RC_RESTORE_VALUE 0x2E
+#define RC_RESTORE_DONT_COPY_HISTORY 0x2F
+
+/* The following are not used in the 68000 implementation */
+
+#define RC_POP_RETURN_ERROR 0x40
+#define RC_EVAL_ERROR 0x41
+#define RC_REPEAT_PRIMITIVE 0x42
+#define RC_COMPILER_INTERRUPT_RESTART 0x43
+/* #define RC_COMPILER_RECURSION_GC 0x44 */
+#define RC_RESTORE_INT_MASK 0x45
+#define RC_HALT 0x46
+#define RC_FINISH_GLOBAL_INT 0x47 /* Multiprocessor */
+#define RC_REPEAT_DISPATCH 0x48
+#define RC_GC_CHECK 0x49
+#define RC_RESTORE_FLUIDS 0x4A
+#define RC_COMPILER_LOOKUP_APPLY_RESTART 0x4B
+#define RC_COMPILER_ACCESS_RESTART 0x4C
+#define RC_COMPILER_UNASSIGNED_P_RESTART 0x4D
+#define RC_COMPILER_UNBOUND_P_RESTART 0x4E
+#define RC_COMPILER_DEFINITION_RESTART 0x4F
+#define RC_COMPILER_LEXPR_INTERRUPT_RESTART 0x50
+
+#define MAX_RETURN_CODE 0x50
+
+/* When adding return codes, don't forget to update storage.c too. */
--- /dev/null
+/* 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
+/* This file is intended to help you find out how to write primitives.
+ Many concepts needed to write primitives can be found by looking
+ at actual primitives in the system. Hence this file will often
+ ask you to look at other files that contain system primitives.
+*/
+
+/* Files that contain primitives must have the following includes
+ near the top of the file.
+*/
+#include "scheme.h"
+#include "primitive.h"
+
+/* Scheme.h supplies useful macros that are used throughout the
+ system, and primitive.h supplies macros that are used in defining
+ primitives.
+*/
+
+/* To make a primitive, you must use the macro Define_Primitive
+ with three arguments, followed by the body of C source code
+ that you want the primitive to execute.
+ The three arguments are:
+ 1. The name you want to give to this body of code (a C procedure
+ name).
+ 2. The number of arguments that this scheme primitive should
+ receive. Note: currently, this must be a number between
+ 0 and 3 inclusive. Hence primitives can currently take no more
+ than three arguments.
+ 3. A string representing the scheme name that you want to identify
+ this primitive with.
+
+ The value returned by the body of code following the Define_Primitive
+ is the value of the scheme primitive. Note that this must be a
+ scheme Pointer object (with type tag and datum field), and not an
+ arbitrary C object.
+
+ As an example, here is a primitive that takes no arguments and always
+ returns NIL (NIL is defined in scheme.h and identical to the scheme
+ object #!FALSE. TRUTH is identical to the scheme object #!TRUE
+*/
+
+Define_Primitive(Prim_Return_Nil, 0, "RETURN-NIL")
+{ Primitive_0_Args();
+ return NIL;
+}
+
+/* This will create the primitive return-nil and when a new scheme is
+ made (with the Makefile properly edited to include this file),
+ evaluating (make-primitive-procedure 'return-nil) will return a
+ primitive procedure that when called with no arguments, will return
+ #!FALSE.
+*/
+
+/* Three macros are available for you to access the arguments to the
+ primitives. Primitive_N_Args(), where N is between 0 and 3
+ inclusive binds Arg1 through ArgN to the arguments passed to the
+ primitive. They may also do some other initialization, so unless
+ you REALLY know what you are doing, you should use them in your
+ code. An important thing to note is that since Primitive_N_Args
+ may allocate variables, its use MUST come before any code in the
+ body of the C procedure. For example, here is a primitive that
+ takes one argument and returns it.
+*/
+
+Define_Primitive(Prim_Identity, 1, "IDENTITY")
+{ Primitive_1_Arg();
+ return Arg1;
+}
+
+/* Some primitives may have to allocate space on the heap in order
+ to return lists or vectors. There are two things of importance to
+ note here. First, the primitive is responsible for making sure
+ that there is enough space on the heap for the new structure that
+ is being made. For instance, in making a PAIR, two words on the
+ heap are used, one to point to the CAR, one for CDR. The macro
+ Primitive_GC_If_Needed is supplied to let you check if there is
+ room on the heap. Primitive_GC_If_Needed takes one argument which
+ is the amount of space you would like to allocate. If there is not
+ enough space on the heap, a garbage collection happens and
+ afterwards the primitive is restarted with the same arguments. The
+ second thing to notice is that the primitive is responsible for
+ updating Free according to how many words of storage it has used
+ up. Note that the primitive is restarted, not continued, thus any
+ side effects must be done after the heap overflow check since
+ otherwise they would be done twice.
+
+ A pair is object which has a type TC_LIST and points to the first
+ element of the pair. The macro Make_Pointer takes a type code and
+ an address or data and returns a scheme object with that type code
+ and that address or data. See scheme.h and the files included
+ there for the possible type codes. The following is the equivalent
+ of CONS and takes two arguments and returns the pair which contains
+ both arguments. For further examples on heap allocation, see the
+ primitives in list.c, hunk.c and vector.c.
+*/
+
+Define_Primitive(Prim_New_Cons, 2, "NEW-CONS")
+{ Pointer *Temp;
+ Primitive_2_Args();
+ /* Check to see if there is room in the heap for the pair */
+ Primitive_GC_If_Needed(2);
+ /* Store the values in the heap, updating Free as we go along */
+ Temp = Free;
+ Free += 2;
+ Temp[CONS_CAR] = Arg1;
+ Temp[CONS_CDR] = Arg2;
+ /* Return the pair, which points to the location of the car */
+ return Make_Pointer(TC_LIST, Temp);
+}
+
+/* The following primitive takes three arguments and returns a list
+ of them. Note how the CDR of the first two pairs points
+ to the next pair. Also, scheme objects are of type Pointer
+ (defined in object.h). Note that the result returned can be
+ held in a temporary variable even before the contents of the
+ object are stored in heap.
+*/
+
+Define_Primitive(Prim_Utterly_Random, 3, "WHY-SHOULDNT-THE-NAME-BE-RANDOM?")
+{ /* Hold the end result in a temporary variable while we
+ fill in the list.
+ */
+ Pointer *Result;
+ Primitive_3_Args();
+ /* Check to see if there is enough space on the heap. */
+ Primitive_GC_If_Needed(6);
+ Result = Free;
+ Free[CONS_CAR] = Arg1;
+ /* Make the CDR of the first pair point to the second pair. */
+ Free[CONS_CDR] = Make_Pointer(TC_LIST, Free+2);
+ /* Bump it over to the second pair */
+ Free += 2;
+ Free[CONS_CAR] = Arg2;
+ /* Make the CDR of the second pair point to the third pair. */
+ Free[CONS_CDR] = Make_Pointer(TC_LIST, Free+2);
+ /* Bump it over to the third pair */
+ Free += 2;
+ Free[CONS_CAR] = Arg3;
+ /* Make the last CDR a () to make a "proper" list */
+ Free[CONS_CDR] = NIL;
+ /* Bump Free over to the first available location */
+ Free += 2;
+ return Make_Pointer(TC_LIST, Result);
+}
+
+/* Several Macros are supplied to do arithmetic with scheme numbers.
+ Scheme_Integer_To_C_Integer takes a scheme object and the address
+ of a long. If the scheme object is not of type TC_FIXNUM or
+ TC_BIG_FIXNUM, then the macro returns ERR_ARG_1_WRONG_TYPE. If the
+ scheme number doesn't fit into a long, the macro returns
+ ERR_ARG_1_BAD_RANGE. Otherwise the macro stores the integer
+ represented by the scheme object into the long.
+ C_Integer_To_Scheme_Integer takes a long and returns a scheme
+ object of type either TC_FIXNUM or TC_BIG_FIXNUM that represents
+ that long. Here is a primitive that tries to add 3 to it's
+ argument. Note how scheme errors are performed via
+ Primitive_Error({error-code}). See scheme.h and included files for
+ the possible error codes.
+*/
+
+Define_Primitive(Prim_Add_3, 1, "3+")
+{ long value;
+ int flag;
+ Primitive_1_Arg();
+ flag = Scheme_Integer_To_C_Integer(Arg1, &value);
+ if (flag == PRIM_DONE)
+ return C_Integer_To_Scheme_Integer(value + 3);
+ /* If flag is not equal to PRIM_DONE, then it is one of two
+ errors. We can signal either error by calling Primitive_Error
+ with that error code
+ */
+ Primitive_Error(flag);
+}
+
+/* See fixnum.c for more fixnum primitive examples. float.c
+ gives floating point examples and bignum.c gives bignum
+ examples (Warning: the bignum code is not trivial). generic.c
+ gives examples on arithmetic operations that work for
+ all scheme number types. For efficiency reasons, they do not
+ always use this convenient interface.
+ */
+
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: scheme.h
+ *
+ * General declarations for the SCode interpreter. This
+ * file is INCLUDED by others and contains declarations only.
+ */
+\f
+/* "fast" is a register declaration if we aren't debugging code */
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+#define Consistency_Check true
+#define fast
+#else
+#define Consistency_Check false
+#define fast register
+#endif
+
+#ifdef noquick
+#define quick
+#else
+#define quick fast
+#endif
+
+#ifdef COMPILE_STEPPER
+#define Microcode_Does_Stepping true
+#else
+#define Microcode_Does_Stepping false
+#endif
+
+#define forward extern /* For forward references */
+\f
+#include "config.h" /* Machine and OS configuration info */
+#include "bkpt.h" /* May shadow some defaults */
+#include "object.h" /* Scheme Object Representation */
+#include "scode.h" /* Scheme SCode Representation */
+#include "sdata.h" /* Scheme User Data Representation */
+#include "gc.h" /* Garbage Collector related macros */
+#include "history.h" /* History maintenance */
+#include "interpret.h" /* Macros for interpreter */
+#include "stack.h" /* Macros for stack (stacklet) manipulation */
+#include "futures.h" /* Support macros, etc. for FUTURE */
+#include "types.h" /* Type code numbers */
+#include "errors.h" /* Error code numbers */
+#include "returns.h" /* Return code numbers */
+#include "const.h" /* Various named constants */
+#include "fixobj.h" /* Format of fixed objects vector */
+#ifdef RENAME
+#include "rename.c" /* Rename of identifiers for some compilers */
+#endif
+#include <setjmp.h>
+#include <stdio.h>
+
+#ifdef butterfly
+#include "butterfly.h"
+#endif
+
+#include "default.h" /* Defaults for various hooks. */
+#include "extern.h" /* External declarations */
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: SCODE.H
+ *
+ * Format of the SCode representation of programs. Each of these
+ * is described in terms of the slots in the data structure.
+ *
+ */
+\f
+/* Here are the definitions of the the executable operations for the
+ interpreter. This file should parallel the file SCODE.SCM in the
+ runtime system. The interpreter dispatches on the type code of a
+ pointer to determine what operation to perform. The format of the
+ storage block this points to is described below. Offsets are the
+ number of cells from the location pointed to by the operation. */
+
+/* ALPHABETICALLY LISTED BY TYPE CODE NAME */
+
+/* ACCESS operation: */
+#define ACCESS_ENVIRONMENT 0
+#define ACCESS_NAME 1
+
+/* ASSIGNMENT operation: */
+#define ASSIGN_NAME 0
+#define ASSIGN_VALUE 1
+
+/* COMBINATIONS come in several formats */
+
+/* Non-primitive combinations are vector-like: */
+#define COMB_VECTOR_HEADER 0
+#define COMB_FN_SLOT 1
+#define COMB_ARG_1_SLOT 2
+
+/* Short non-primitive combinations: */
+#define COMB_1_FN 0
+#define COMB_1_ARG_1 1
+
+#define COMB_2_FN 0
+#define COMB_2_ARG_1 1
+#define COMB_2_ARG_2 2
+
+/* COMMENT operation: */
+#define COMMENT_EXPRESSION 0
+#define COMMENT_TEXT 1
+
+/* COMPILED_CODE_ENTRY operation: */
+#define CCE_BYTE_ADDRESS 0
+
+/* CONDITIONAL operation (used for COND, IF, CONJUNCTION): */
+#define COND_PREDICATE 0
+#define COND_CONSEQUENT 1
+#define COND_ALTERNATIVE 2
+\f
+/* DEFINITION operation: */
+#define DEFINE_NAME 0
+#define DEFINE_VALUE 1
+
+/* DELAY operation: */
+#define DELAY_OBJECT 0
+#define DELAY_UNUSED 1
+
+/* DISJUNCTION operation (formerly OR): */
+#define OR_PREDICATE 0
+#define OR_ALTERNATIVE 1
+
+/* IN-PACKAGE operation: */
+#define IN_PACKAGE_ENVIRONMENT 0
+#define IN_PACKAGE_EXPRESSION 1
+
+/* Primitive combinations with 0 arguments are not pointers */
+
+/* Primitive combinations, 1 argument: */
+#define PCOMB1_FN_SLOT 0
+#define PCOMB1_ARG_SLOT 1
+
+/* Primitive combinations, 2 arguments: */
+#define PCOMB2_FN_SLOT 0
+#define PCOMB2_ARG_1_SLOT 1
+#define PCOMB2_ARG_2_SLOT 2
+
+/* Primitive combinations, 3 arguments are vector-like: */
+#define PCOMB3_FN_SLOT 1
+#define PCOMB3_ARG_1_SLOT 2
+#define PCOMB3_ARG_2_SLOT 3
+#define PCOMB3_ARG_3_SLOT 4
+
+/* SCODE_QUOTE returns itself */
+#define SCODE_QUOTE_OBJECT 0
+#define SCODE_QUOTE_IGNORED 1
+
+/* SEQUENCE operations (two forms: SEQUENCE_2 and SEQUENCE_3) */
+#define SEQUENCE_1 0
+#define SEQUENCE_2 1
+#define SEQUENCE_3 2
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: SDATA.H
+ *
+ * Description of the user data objects. This should parallel the
+ * file SDATA.SCM in the runtime system.
+ *
+ */
+\f
+/* Alphabetical order. Every type of object is described either with a
+ comment or with offsets describing locations of various parts. */
+
+/* ADDRESS
+ * is a FIXNUM. It represents a 24-bit address. Not a pointer type.
+ */
+
+/* BIG_FIXNUM (bignum).
+ * See the file BIGNUM.C
+ */
+
+/* BIG_FLONUM (flonum).
+ * Implementation dependent format (uses C data type "double"). Pointer
+ * to implemetation defined floating point format.
+ */
+
+/* BROKEN_HEART.
+ * "Forwarding address" used by garbage collector to indicate that an
+ * object has been moved to a new location. These should never be
+ * encountered by the interpreter!
+ */
+
+/* CELL.
+ * An object that points to one other object (extra indirection).
+ * Used by the compiler to share objects.
+ */
+#define CELL_CONTENTS 0
+
+/* CHARACTER
+ * Not currently used. Intended ultimately to complete the abstraction
+ * of strings. This will probably be removed eventually.
+ */
+
+/* CHARACTER_STRING
+ * Synonym for 8B_VECTOR. Used to store strings of characters. Format
+ * consists of the normal non-marked vector header (STRING_HEADER)
+ * followed by the number of characters in the string (as a FIXNUM),
+ * followed by the characters themselves.
+ */
+#define STRING_HEADER 0
+#define STRING_LENGTH 1
+#define STRING_CHARS 2
+\f
+/* COMPILED_PROCEDURE */
+#define COMP_PROCEDURE_ADDRESS 0
+#define COMP_PROCEDURE_ENV 1
+
+/* CONTINUATION
+ * Pushed on the control stack by the interpreter, each has two parts:
+ * the return address within the interpreter (represented as a type
+ * code RETURN_ADDRESS and address part RC_xxx), and an expression
+ * which was being evaluated at that time (sometimes just used as
+ * additional data needed at the return point). The offsets given
+ * here are with respect to the stack pointer as it is located
+ * immediately after pushing a continuation (or, of course,
+ * immediately before popping it back).
+ *
+ * HISTORY_SIZE is the size of a RESTORE_HISTORY (or
+ * RESTORE_DONT_COPY_HISTORY) continuation.
+ */
+
+#define CONTINUATION_EXPRESSION 1
+#define CONTINUATION_RETURN_CODE 0
+#define CONTINUATION_SIZE 2
+#define HISTORY_SIZE (CONTINUATION_SIZE + 2)
+\f
+/* CONTROL_POINT
+ * Points to a copy of the control stack at the time a control point is
+ * created. This is the saved state of the interpreter, and can be
+ * restored later by APPLYing the control point to an argument (i.e. a
+ * throw). Format is that of an ordinary vector. They are linked
+ * together by using the return code RC_JOIN_STACKLETS.
+ */
+
+/* If USE_STACKLETS is defined, then a stack (i.e. control point) is
+ actually made from smaller units allocated from the heap and linked
+ together. The format is:
+
+ 0 memory address
+
+ _______________________________________
+ |MAN. VECT.| n |
+ _ _______________________________________
+ / | NM VECT | m at GC or when full |
+ | _______________________________________
+ | | ... |\
+ | | not yet in use -- garbage | > m
+ n < _______________________________________/
+ | | Top of Stack, useful contents | <---Stack_Pointer
+ | _______________________________________
+ \ | ... |
+ \ | useful stuff |
+ \_ ________________________________________
+ <---Stack_Top
+ infinite memory address
+
+*/
+
+#define STACKLET_LENGTH 0 /* = VECTOR_LENGTH */
+#define STACKLET_HEADER_SIZE 2
+#define STACKLET_UNUSED_LENGTH 1
+#define STACKLET_FREE_LIST_LINK 1 /* If on free list */
+\f
+/* DELAYED
+ * The object returned by a DELAY operation. Consists initially of a
+ * procedure to be APPLYed and environment. After the FORCE primitive
+ * is applied to the object, the result is stored in the DELAYED object
+ * and further FORCEs return this same result. I.e. FORCE memoizes the
+ * value of the DELAYED object. For historical reasons, such an object
+ * is called a 'thunk.'
+ */
+#define THUNK_SNAPPED 0
+#define THUNK_VALUE 1
+#define THUNK_ENVIRONMENT 0
+#define THUNK_PROCEDURE 1
+\f
+/* ENVIRONMENT
+ * Associates identifiers with values. The identifiers are either from
+ * a lambda-binding (as in a procedure call) or a run-time DEFINE (known
+ * as an 'auxilliary' binding). The environment contains three things:
+ * the list of identifiers which must be marked DANGEROUS if they are
+ * created in this environment (the 'potentially dangerous' list); the
+ * A-list associating auxilliary variables with their values; and the
+ * values of lambda-bound variables. The names of the lambda-bound
+ * variables are found by looking at the PROCEDURE which is stored in
+ * the first formal value slot. This will contain a LEXPR or LAMBDA
+ * object, which contains a list of names associated with the slots in
+ * the environment. Notice that the FINGER used in the process of
+ * constructing an environment frame is stored in the same place where
+ * the potentially dangerous variables will eventually go.
+ *
+ * There are actually 3 data structures which are used at distinct
+ * times to store an environment. A HEAP_ENVIRONMENT is the format
+ * used by the interpreter for a completely formed environment in
+ * which variable lookups will occur. A STACK_COMBINATION is the
+ * structure built on the stack to evaluate normal (long)
+ * combinations. It contains a slot for the finger and the
+ * combination whose operands are being evaluated. Only some of the
+ * argument slots in a stack-combination are meaningful: those which
+ * have already been evaluated (those not "hidden" by the finger).
+ * Finally, a STACK_ENVIRONMENT is the format used at Internal_Apply
+ * just as an application is about to occur. This does NOT have slots
+ * for auxilliary variables or the potentially dangerous list, since
+ * primitives, compiled code, and control points don't need these
+ * slots.
+ *
+ * The "life cycle" of an environment is: (a) it is born on the stack
+ * during the evaluation of a COMBINATION as a STACK_COMBINATION; (b)
+ * when all of the operands and the operator have been evaluated and
+ * stored into this frame, the finger is removed and the function
+ * is stored ... the result is a STACK_ENVIRONMENT; (c) finally, if
+ * the operator is an interpreted procedure, the frame has is copied
+ * onto the heap as a HEAP_ENVIRONMENT (i.e. by adding the two missing
+ * slots). For the optimized combinations (COMBINATION-1, 2, 3 and
+ * PCOMB0, 1, 2, 3), the STACK_ENVIRONMENT is used directly, without
+ * ever creating a STACK_COMBINATION.
+ */
+\f
+/* ENVIRONMENT, continued */
+
+#define HEAP_ENV_EXTRA_SLOTS 3
+ /* Slots over and above those used to store
+ function (procedure) and its arguments in
+ a HEAP environment */
+
+#define HEAP_ENV_HEADER 0
+#define HEAP_ENV_AUX_SLOT 1
+#define HEAP_ENV_P_DANGER 2
+#define HEAP_ENV_FUNCTION 3
+#define HEAP_ENV_FIRST_ARG 4
+
+#define STACK_ENV_EXTRA_SLOTS 1
+#define STACK_ENV_HEADER 0
+#define STACK_ENV_FUNCTION 1
+#define STACK_ENV_FIRST_ARG 2
+
+#define STACK_COMB_FINGER 0
+#define STACK_COMB_FIRST_ARG 1
+
+/* An environment chain always ends in a pointer with type code
+ of GLOBAL_ENV. This will contain an address part which
+ either indicates that the lookup should continue on to the
+ true global environment, or terminate at this frame. */
+
+#define GO_TO_GLOBAL 0
+#define END_OF_CHAIN 1
+
+/* EXTENDED_FIXNUM
+ * Not used in the C version. On the 68000 this is used for 24-bit
+ * integers, while FIXNUM is used for 16-bit integers.
+ */
+\f
+/* EXTENDED_LAMBDA
+ * Support for optional parameters and auxiliary local variables. The
+ * Extended Lambda is similar to LAMBDA, except that it has an extra
+ * word called the ARG_COUNT. This contains an 8-bit count of the
+ * number of optional arguments, an 8-bit count of the number of
+ * required (formal) parameters, and a bit to indicate that additional
+ * (rest) arguments are allowed. The vector of argument names
+ * contains, of course, a size count which allows the calculation of
+ * the number of auxiliary variables required. Auxiliary variables
+ * are created for any internal DEFINEs which are found at syntax time
+ * in the body of a LAMBDA-like special form.
+ */
+
+#define ELAMBDA_SCODE 0
+#define ELAMBDA_NAMES 1
+#define ELAMBDA_ARG_COUNT 2
+
+/* Masks. The infomation on the number of each type of argument is
+ * separated at byte boundaries for easy extraction in the 68000 code.
+ */
+
+#define EL_OPTS_MASK 0xFF
+#define EL_FORMALS_MASK 0xFF00
+#define EL_REST_MASK 0x10000
+#define EL_FORMALS_SHIFT 8
+#define EL_REST_SHIFT 16
+
+/* EXTENDED_PROCEDURE
+ * Counterpart to EXTENDED_LAMBDA. Same format as PROCEDURE.
+ */
+
+/* FALSE
+ * Alternate name for NULL. This is the type code of objects which are
+ * considered as false for the value of predicates.
+ */
+
+/* FIXNUM
+ * Small integer. Fits in the datum portion of a Scheme Pointer.
+ */
+
+/* HUNK3
+ * User object like a CONS, but with 3 slots rather than 2.
+ */
+#define HUNK_CXR0 0
+#define HUNK_CXR1 1
+#define HUNK_CXR2 2
+\f
+/* INTERNED_SYMBOL
+ * A symbol, such as the result of evaluating (QUOTE A). Some important
+ * properties of symbols are that they have a print name, and may be
+ * 'interned' so that all instances of a symbol with the same name share
+ * a unique object. The storage pointed to by a symbol includes both
+ * the print name (a string) and the value associated with a variable of
+ * that name in the global environment. In looking for the value of a
+ * variable in the global environment, the dangerous and potentially
+ * dangerous bits are stored in the dangerous bits of these two cells as
+ * indicated below.
+ */
+#define SYMBOL_NAME 0
+#define SYMBOL_GLOBAL_VALUE 1
+#define GLOBAL_P_DANGER 0
+#define GLOBAL_DANGER 1
+
+/* LAMBDA
+ * Object representing a LAMBDA expression with a fixed number of
+ * arguments. It consists of a list of the names of the arguments
+ * (the first is the name by which the procedure refers to itself) and
+ * the SCode for the procedure.
+ */
+
+#define LAMBDA_SCODE 0
+#define LAMBDA_FORMALS 1
+
+/* LEXPR
+ * Same as LAMBDA (q.v.) except additional arguments are permitted
+ * beyond those indicated in the LAMBDA_FORMALS list.
+ */
+
+/* LIST
+ * Ordinary CONS cell as supplied to a user. Perhaps this data type is
+ * misnamed ... CONS or PAIR would be better.
+ */
+#define CONS_CAR 0
+#define CONS_CDR 1
+
+/* MANIFEST_NM_VECTOR
+ * Not a true object, this type code is used to indicate the start of a
+ * vector which contains objects other than Scheme pointers. The
+ * address portion indicates the number of cells of non-pointers
+ * which follow the header word. For use primarily in garbage
+ * collection to indicate the number of words to copy but not trace.
+ */
+\f
+/* MANIFEST_SPECIAL_NM_VECTOR Similar to MANIFEST_NM_VECTOR but the
+ * contents are relocated when loaded by the FALOADer. This header
+ * occurs in pure and constant space to indicate the start of a region
+ * which contains Pointers to addresses which are known never to move in
+ * the operation of the system.
+ */
+
+/* MANIFEST_VECTOR
+ * Synonym for NULL, used as first cell in a vector object to indicate
+ * how many cells it occupies. Usage is similar to MANIFEST_NM_VECTOR
+ */
+
+/* NON_MARKED_VECTOR
+ * User-visible object containing arbitrary bits. Not currently used.
+ * The data portion will always point to a MANIFEST_NM_VECTOR or
+ * MANIFEST_SPECIAL_NM_VECTOR specifying the length of the vector.
+ */
+#define NM_VECTOR_HEADER 0
+#define NM_ENTRY_COUNT 1
+#define NM_DATA 2
+#define NM_HEADER_LENGTH 2
+
+/* NULL
+ * The type code used by predicates to test for 'false' and by list
+ * operations for testing for the end of a list.
+ */
+
+/* PRIMITIVE
+ * The data portion contains a number specifying a particular primitive
+ * operation to be performed. An object of type PRIMITIVE can be
+ * APPLYed in the same way an object of type PROCEDURE can be.
+ */
+
+/* PRIMITIVE_EXTERNAL
+ * Functionally identical to PRIMITIVE. The distinctions are that a
+ * PRIMITIVE is constrained to take no more than 3 arguments, PRIMITIVEs
+ * can be formed into more efficient PRIMITIVE-COMBINATIONs by a
+ * compiler, and that PRIMITIVE_EXTERNALs are user supplied.
+ */
+
+/* PROCEDURE (formerly CLOSURE)
+ * Consists of two parts: a LAMBDA expression and the environment
+ * in which the LAMBDA was evaluated to yield the PROCEDURE.
+ */
+#define PROCEDURE_LAMBDA_EXPR 0
+#define PROCEDURE_ENVIRONMENT 1
+\f
+/* RETURN_CODE
+ * Represents an address where computation is to continue. These can be
+ * thought of as states in a finite state machine, labels in an assembly
+ * language program, or continuations in a formal semantics. When the
+ * interpretation of a single SCode item requires the EVALuation of a
+ * subproblem, a RETURN_CODE is left behind indicating where computation
+ * continues after the evaluation.
+ */
+
+/* STATE_POINT and STATE_SPACE
+ * Data structures used to keep track of dynamic wind state. Both of
+ * these are actually ordinary vectors with a special tag in the first
+ * user accessible slot. A STATE_SPACE consists of just a pointer to
+ * the current point in that space. A STATE_POINT contains a
+ * procedure to be used when moving through the point (the forward
+ * thunk), an alternate procedure to undo the effects of the first
+ * (the backward thunk), and the point to which you can move directly
+ * from this point.
+ */
+
+#define STATE_POINT_HEADER 0
+#define STATE_POINT_TAG 1
+#define STATE_POINT_BEFORE_THUNK 2
+#define STATE_POINT_AFTER_THUNK 3
+#define STATE_POINT_NEARER_POINT 4
+#define STATE_POINT_DISTANCE_TO_ROOT 5
+#define STATE_POINT_SIZE 6
+
+#define STATE_SPACE_HEADER 0
+#define STATE_SPACE_TAG 1
+#define STATE_SPACE_NEAREST_POINT 2
+#define STATE_SPACE_SIZE 3
+
+/* When in RC_MOVE_TO_ADJACENT_POINT in the interpreter, the following
+ information is available on the stack (placed there by
+ Translate_To_Point
+*/
+#define TRANSLATE_FROM_POINT 0
+#define TRANSLATE_FROM_DISTANCE 1
+#define TRANSLATE_TO_POINT 2
+#define TRANSLATE_TO_DISTANCE 3
+\f
+/* TRAP
+ * Trap-on-reference object. Used as a placeholder for a variable's value
+ * when special action must be taken at lookup time. Used to implement
+ * fluid variables, active values, etc.
+ */
+
+#define TRAP_TAG 0 /* NIL => fluid variable
+ else handler procedure */
+#define TRAP_DEFAULT 1 /* Default value of this slot */
+#define TRAP_FROB 2 /* For user supplied handlers */
+#define TRAP_SIZE 3
+
+/* TRUE
+ * The initial binding of the variable T is to an object of this type.
+ * This type is the beginnings of a possible move toward a system where
+ * predicates check for TRUE / FALSE rather than not-NULL / NULL.
+ */
+
+/* UNASSIGNED
+ * There are two objects made with a data type of UNASSIGNED. The first
+ * (called the "unassigned object") is a value stored in an environment
+ * to indicate that a variable is lambda-bound in that environment but
+ * does not yet have an initial value. The second (called the "unbound
+ * object") is stored in the global value slot of a value when it is
+ * created, and will therefore be returned when a variable is referenced
+ * in an environment where there are no bindings for it. The numbers
+ * here show the data parts corresponding to the two interpretations.
+ */
+
+#define UNASSIGNED 0
+#define UNBOUND 1
+
+/* UNINTERNED_SYMBOL
+ * This indicates that the object is in the format of an INTERNED_SYMBOL
+ * but is not interned.
+ */
+\f
+/* VARIABLE
+ * Variable reference. Contains the symbol referenced, and (if it has
+ * been compiled) the frame and offset in the frame in which it was
+ * found. One of these cells is multiplexed by having its type code
+ * indicate one of four modes of reference: not yet compiled, local
+ * (formal) reference, auxiliary reference, or global value reference
+ */
+#define VARIABLE_SYMBOL 0
+#define VARIABLE_FRAME_NO 1
+#define VARIABLE_OFFSET 2
+#define VARIABLE_COMPILED_TYPE 1
+
+/* VECTOR
+ * A group of contiguous cells with a header (of type MANIFEST_VECTOR)
+ * indicating the length of the group.
+ */
+#define VECTOR_TYPE 0
+#define VECTOR_LENGTH 0
+#define VECTOR_DATA 1
+
+/* VECTOR_16B
+ * Points to a MANIFEST_NM_VECTOR or MANIFEST_SPECIAL_NM_VECTOR header.
+ * The format is described under NON_MARKED_VECTOR. The contents are to
+ * be treated as an array of 16-bit signed or unsigned quantities. Not
+ * currently used, although this may be a useful way to allow users to
+ * inspect the internal representation of bignums.
+ */
+
+/* VECTOR_1B
+ * Similar to VECTOR_16B, but used for a compact representation of an
+ * array of booleans.
+ */
+
+/* VECTOR_8B
+ * An alternate name of CHARACTER_STRING.
+ */
--- /dev/null
+/* Emacs -*-C-*-an't tell the language */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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: STACK.H
+ *
+ * This file contains macros for manipulating stacks and/or stacklets.
+ */
+
+#ifdef USE_STACKLETS
+/* Stack is made up of linked small parts, each in the heap */
+
+#define Initialize_Stack()
+ if (GC_Check(Default_Stacklet_Size)) \
+ Microcode_Termination(TERM_STACK_ALLOCATION_FAILED); \
+ Stack_Guard = Free+STACKLET_HEADER_SIZE; \
+ *Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, Default_Stacklet_Size-1);\
+ Free += Default_Stacklet_Size; \
+ Stack_Pointer = Free; \
+ Free_Stacklets = NULL; \
+ Previous_Restore_History_Stacklet = NULL; \
+ Previous_Restore_History_Offset = 0
+
+#define Internal_Will_Push(N) \
+if ((Stack_Pointer - (N)) < Stack_Guard) \
+{ Export_Registers(); \
+ Allocate_New_Stacklet((N)); \
+ Import_Registers(); \
+}
+
+#define Stack_Allocation_Size(Stack_Blocks) 0
+/* No space required independent of the heap for the stacklets */
+
+#define Current_Stacklet (Stack_Guard-STACKLET_HEADER_SIZE)
+
+/* Make the unused portion of the old stacklet invisible to garbage
+ * collection. This also allows the stack pointer to be reconstructed.
+ */
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+#define Terminate_Old_Stacklet() \
+ if (Stack_Pointer < Stack_Guard) \
+ { printf("\nStack_Pointer: 0x%x, Guard: 0x%x\n", \
+ Stack_Pointer, Stack_Guard); \
+ Microcode_Termination(TERM_EXIT); \
+ } \
+ Current_Stacklet[STACKLET_UNUSED_LENGTH] = \
+ Make_Non_Pointer((DANGER_TYPE | TC_MANIFEST_NM_VECTOR), \
+ Stack_Pointer-Stack_Guard)
+#else
+#define Terminate_Old_Stacklet() \
+ Current_Stacklet[STACKLET_UNUSED_LENGTH] = \
+ Make_Non_Pointer((DANGER_TYPE | TC_MANIFEST_NM_VECTOR), \
+ Stack_Pointer-Stack_Guard)
+#endif
+\f
+/* Used by garbage collector to detect the end of constant space */
+#define Terminate_Constant_Space(Where) \
+ *Free_Constant = Make_Pointer(TC_BROKEN_HEART, Free_Constant); \
+ Where = Free_Constant
+
+#define Get_Current_Stacklet() \
+ Make_Pointer(TC_CONTROL_POINT, Current_Stacklet)
+
+#define Previous_Stack_Pointer(Where) \
+ Nth_Vector_Loc(Where, \
+ (STACKLET_HEADER_SIZE+ \
+ Get_Integer(Vector_Ref(Where, \
+ STACKLET_UNUSED_LENGTH))))
+
+#define Set_Current_Stacklet(Where) \
+{ Pointer Our_Where = (Where); \
+ Stack_Guard = Nth_Vector_Loc(Our_Where, STACKLET_HEADER_SIZE); \
+ Stack_Pointer = Previous_Stack_Pointer(Our_Where); \
+}
+
+#define STACKLET_SLACK STACKLET_HEADER_SIZE + CONTINUATION_SIZE
+#define Default_Stacklet_Size (Stack_Size+STACKLET_SLACK)
+#define New_Stacklet_Size(N) \
+ (STACKLET_SLACK + Stack_Size * (((N) + Stack_Size - 1)/Stack_Size))
+
+#define Get_End_Of_Stacklet() \
+ (&(Current_Stacklet[1+Get_Integer(*Current_Stacklet)]))
+\f
+#define Apply_Stacklet_Backout() \
+Will_Push(2*CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
+ Store_Expression(NIL); \
+ Store_Return(RC_END_OF_COMPUTATION); \
+ Save_Cont(); \
+ Push(Val); \
+ Push(Previous_Stacklet); \
+ Push(STACK_FRAME_HEADER+1); \
+ Store_Return(RC_INTERNAL_APPLY); \
+ Save_Cont(); \
+Pushed()
+
+#define Join_Stacklet_Backout() Apply_Stacklet_Backout()
+
+/* This depends on the fact that Within_Control_Point is going to
+ * push an apply frame immediately after Return_To_Previous_Stacklet
+ * "returns". This apply will cause the GC, then the 2nd argument to
+ * Within_Control_Point will be invoked, and finally the control point
+ * will be entered.
+ */
+
+#define Within_Stacklet_Backout() \
+{ Pointer Old_Expression = Fetch_Expression(); \
+ Store_Expression(Previous_Stacklet); \
+ Store_Return(RC_JOIN_STACKLETS); \
+ Save_Cont(); \
+ Store_Expression(Old_Expression); \
+}
+\f
+/* Our_Throw is used in chaining from one stacklet
+ * to another. In order to improve efficiency, the entire stack is
+ * copied neither on catch or throw, but is instead copied one
+ * stacklet at a time as needed. The need to copy a stacklet is
+ * signified by the danger bit being set in the header of a stacklet.
+ * If the danger bit is found to be set in a stacklet which is being
+ * returned into then that stacklet is copied and the danger bit is
+ * set in the stacklet into which the copied one will return. When a
+ * stacklet is returned from it is no longer needed for anything so it
+ * can be deallocated. A free list of deallocate stacklets is kept in
+ * order to improve the efficiencty of their use.
+ */
+
+#define Our_Throw(From_Pop_Return, Stacklet) \
+{ Pointer Previous_Stacklet = (Stacklet); \
+ Pointer *Stacklet_Top = Current_Stacklet; \
+ Stacklet_Top[STACKLET_FREE_LIST_LINK] = \
+ ((Pointer) Free_Stacklets); \
+ Free_Stacklets = Stacklet_Top; \
+ if (!(From_Pop_Return)) \
+ { Previous_Restore_History_Stacklet = NULL; \
+ Previous_Restore_History_Offset = 0; \
+ } \
+ if (!(Dangerous(Fast_Vector_Ref(Previous_Stacklet, \
+ STACKLET_UNUSED_LENGTH)))) \
+ { if (GC_Check(Vector_Length(Previous_Stacklet) + 1)) \
+ { Free_Stacklets = \
+ ((Pointer *) Free_Stacklets[STACKLET_FREE_LIST_LINK]); \
+ Stack_Pointer = Get_End_Of_Stacklet(); \
+ Previous_Restore_History_Stacklet = NULL; \
+ Previous_Restore_History_Offset = 0;
+ /* Backout code inserted here, SUN screw up! */
+\f
+#define Our_Throw_Part_2() \
+ /* Backout code inserted here, SUN screw up! */ \
+ Request_GC(Vector_Length(Previous_Stacklet) + 1); \
+ } \
+ else /* Space available for copy */ \
+ { long Unused_Length, Used_Length; \
+ fast Pointer *Old_Stacklet_Top = \
+ Get_Pointer(Previous_Stacklet); \
+ Pointer *First_Continuation = \
+ Nth_Vector_Loc(Previous_Stacklet, \
+ ((1+Vector_Length(Previous_Stacklet))- \
+ CONTINUATION_SIZE)); \
+ if (Old_Stacklet_Top==Previous_Restore_History_Stacklet) \
+ Previous_Restore_History_Stacklet = NULL; \
+ if (First_Continuation[CONTINUATION_RETURN_CODE] == \
+ Make_Non_Pointer(TC_RETURN_CODE, RC_JOIN_STACKLETS)) \
+ { Pointer *Even_Older_Stacklet = \
+ Get_Pointer(First_Continuation[CONTINUATION_EXPRESSION]);\
+ Clear_Danger_Bit(Even_Older_Stacklet[STACKLET_UNUSED_LENGTH]);\
+ } \
+ Stack_Guard = &(Free[STACKLET_HEADER_SIZE]); \
+ Free[STACKLET_LENGTH] = Old_Stacklet_Top[STACKLET_LENGTH];\
+ Unused_Length = \
+ Get_Integer(Old_Stacklet_Top[STACKLET_UNUSED_LENGTH]) + \
+ STACKLET_HEADER_SIZE; \
+ Free += Unused_Length; \
+ Stack_Pointer = Free; \
+ Used_Length = \
+ (Get_Integer(Old_Stacklet_Top[STACKLET_LENGTH]) - \
+ Unused_Length) + 1; \
+ Old_Stacklet_Top += Unused_Length; \
+ while (--Used_Length >= 0) *Free++ = *Old_Stacklet_Top++; \
+ } \
+ } \
+ else /* No need to copy the stacklet we are going into */ \
+ { if (Get_Pointer(Previous_Stacklet)== \
+ Previous_Restore_History_Stacklet) \
+ Previous_Restore_History_Stacklet = NULL; \
+ Set_Current_Stacklet(Previous_Stacklet); \
+ } \
+}
+\f
+#else
+
+/* Full size stack in a statically allocated area */
+
+#define Stack_Check(P) \
+{ \
+ if ((P) <= Stack_Guard) \
+ { if ((P) <= Absolute_Stack_Base) \
+ Microcode_Termination(TERM_STACK_OVERFLOW); \
+ Request_Interrupt(INT_Stack_Overflow); \
+ } \
+}
+
+#define Internal_Will_Push(N) Stack_Check(Stack_Pointer - (N))
+
+#define Stack_Allocation_Size(Stack_Blocks) (Stack_Blocks)
+
+#define Terminate_Old_Stacklet()
+
+/* Used by garbage collector to detect the end of constant space, and to
+ skip over the gap between constant space and the stack.
+ */
+#define Terminate_Constant_Space(Where) \
+ *Free_Constant = \
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, \
+ (Stack_Pointer-Free_Constant)-1); \
+ *Stack_Top = Make_Pointer(TC_BROKEN_HEART, Stack_Top); \
+ Where = Stack_Top
+
+#define Get_Current_Stacklet() NIL
+
+#define Set_Current_Stacklet(Where) {}
+
+#define Previous_Stack_Pointer(Where) \
+ Nth_Vector_Loc(Where, \
+ (STACKLET_HEADER_SIZE+ \
+ Get_Integer(Vector_Ref(Where, \
+ STACKLET_UNUSED_LENGTH))))
+
+/* Never allocate more space */
+#define New_Stacklet_Size(N) 0
+
+#define Get_End_Of_Stacklet() Stack_Top
+
+/* Not needed in this version */
+
+#define Join_Stacklet_Backout()
+#define Apply_Stacklet_Backout()
+#define Within_Stacklet_Backout()
+
+/* This piece of code KNOWS which way the stack grows.
+ The assumption is that successive pushes modify decreasing addresses.
+ */
+
+#define Our_Throw(From_Pop_Return, 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 Control_Point = (P); \
+ long NCells, Offset; \
+ fast Pointer *To_Where, *From_Where; \
+ fast long len; \
+ if (Consistency_Check) \
+ if (Type_Code(Control_Point) != TC_CONTROL_POINT) \
+ Microcode_Termination(TERM_BAD_STACK); \
+ len = Vector_Length(Control_Point); \
+ NCells = ((len - 1) - \
+ Get_Integer(Vector_Ref(Control_Point, \
+ STACKLET_UNUSED_LENGTH))); \
+ Stack_Check(Stack_Top - NCells); \
+ From_Where = Nth_Vector_Loc(Control_Point, STACKLET_HEADER_SIZE); \
+ From_Where = Nth_Vector_Loc(Control_Point, ((len + 1) - NCells)); \
+ To_Where = Stack_Top - NCells; \
+ Stack_Pointer = To_Where; \
+ for (len=0; len < NCells; len++) *To_Where++ = *From_Where++; \
+ if (Consistency_Check) \
+ if ((To_Where != Stack_Top) || \
+ (From_Where != Nth_Vector_Loc(Control_Point, \
+ 1+Vector_Length(Control_Point)))) \
+ Microcode_Termination(TERM_BAD_STACK); \
+ if (!(From_Pop_Return)) \
+ { Previous_Restore_History_Stacklet = NULL; \
+ Previous_Restore_History_Offset = 0; \
+ 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)); \
+ } \
+ else if (Previous_Restore_History_Stacklet == \
+ Get_Pointer(Control_Point)) \
+ Previous_Restore_History_Stacklet = NULL; \
+}
+
+#define Our_Throw_Part_2()
+
+#endif
--- /dev/null
+/* 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: STEP.C
+ *
+ * Support for the stepper
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+
+ /**********************************/
+ /* Support of stepping primitives */
+ /**********************************/
+
+long Install_Traps(Hunk3, Return_Hook_Too)
+/* UGLY ... this knows (a) that it is called with the primitive frame
+ already popped off the stack; and (b) the order in which Save_Cont
+ stores things on the stack.
+*/
+Pointer Hunk3;
+Boolean Return_Hook_Too;
+{ Pointer Eval_Hook, Apply_Hook, Return_Hook;
+ Stop_Trapping();
+ Eval_Hook = Vector_Ref(Hunk3, HUNK_CXR0);
+ Apply_Hook = Vector_Ref(Hunk3, HUNK_CXR1);
+ Return_Hook = Vector_Ref(Hunk3, HUNK_CXR2);
+ Set_Fixed_Obj_Slot(Stepper_State, Hunk3);
+ Trapping = (Eval_Hook != NIL) | (Apply_Hook != NIL);
+ if (Microcode_Does_Stepping && Return_Hook_Too && (Return_Hook != NIL))
+ { /* Here it is ... gross and ugly. We know that the top of stack
+ has the existing return code to be clobbered, since it was put
+ there by Save_Cont.
+ */
+ Return_Hook_Address = &Top_Of_Stack();
+ Old_Return_Code = Top_Of_Stack();
+ *Return_Hook_Address = Make_Non_Pointer(TC_RETURN_CODE,
+ RC_RETURN_TRAP_POINT);
+ }
+}
+\f
+/* (EVAL_STEP EXPRESSION ENV HUNK3)
+ Evaluates EXPRESSION in ENV and intalls the eval-trap,
+ apply-trap, and return-trap from HUNK3. If any
+ trap is '(), it is a null trap that does a normal EVAL,
+ APPLY or return.
+*/
+
+Built_In_Primitive(Prim_Eval_Step, 3, "EVAL-STEP")
+{ Primitive_3_Args();
+ Install_Traps(Arg3, false);
+ Pop_Primitive_Frame(3);
+ Store_Expression(Arg1);
+ Store_Env(Arg2);
+ longjmp(*Back_To_Eval, PRIM_NO_TRAP_EVAL);
+}
+\f
+/* (APPLY-STEP OPERATOR OPERANDS HUNK3)
+ Applies OPERATOR to OPERANDS and intalls the eval-trap,
+ apply-trap, and return-trap from HUNK3. If any
+ trap is '(), it is a null trap that does a normal EVAL,
+ APPLY or return.
+*/
+Built_In_Primitive(Prim_Apply_Step, 3, "APPLY-STEP")
+/* Mostly a copy of Prim_Apply, since this, too, must count the space
+ required before actually building a frame
+*/
+{ Pointer Next_From_Slot, *Next_To_Slot;
+ long Number_Of_Args, i;
+ Primitive_3_Args();
+ Arg_3_Type(TC_HUNK3);
+ Number_Of_Args = 0;
+ Next_From_Slot = Arg2;
+ while (Type_Code(Next_From_Slot) == TC_LIST)
+ { Number_Of_Args += 1;
+ Next_From_Slot = Vector_Ref(Next_From_Slot, CONS_CDR);
+ }
+ if (Next_From_Slot != NIL)
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ Install_Traps(Arg3, true);
+ Pop_Primitive_Frame(3);
+ Next_From_Slot = Arg2;
+ Next_To_Slot = Stack_Pointer - Number_Of_Args;
+ Will_Push(Number_Of_Args + STACK_ENV_EXTRA_SLOTS + 1);
+ Stack_Pointer = Next_To_Slot;
+ for (i=0; i < Number_Of_Args; i++)
+ { *Next_To_Slot++ = Vector_Ref(Next_From_Slot, CONS_CAR);
+ Next_From_Slot = Vector_Ref(Next_From_Slot, CONS_CDR);
+ }
+ Push(Arg1); /* The function */
+ Push(STACK_FRAME_HEADER + Number_Of_Args);
+ Pushed();
+ longjmp(*Back_To_Eval, PRIM_NO_TRAP_APPLY);
+}
+\f
+/* (RETURN_STEP VALUE HUNK3)
+ Returns VALUE and intalls the eval-trap, apply-trap, and
+ return-trap from HUNK3. If any trap is '(), it is a null trap
+ that does a normal EVAL, APPLY or return.
+*/
+
+Built_In_Primitive(Prim_Return_Step, 2, "RETURN-STEP")
+/* UGLY ... currently assumes that it is illegal to set a return trap
+ this way, so that we don't run into stack parsing problems. If
+ this is ever changed, be sure to check for COMPILE_STEPPER flag!
+*/
+{ Pointer Return_Hook;
+ Primitive_2_Args();
+ Return_Hook = Vector_Ref(Arg2, HUNK_CXR2);
+ if (Return_Hook != NIL)
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Install_Traps(Arg2, false);
+ return Arg1;
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: storage.c
+ *
+ * This file defines the storage for global variables for
+ * the Scheme Interpreter
+ *
+ */
+
+#include "scheme.h"
+#include "prims.h"
+#include "gctype.c"
+\f
+ /*************/
+ /* REGISTERS */
+ /*************/
+
+Pointer
+ Env, /* The environment */
+ Val, /* The value returned from primitives or apply */
+ Return, /* The return address code */
+ Expression, /* Expression to EVALuate */
+ *History, /* History register */
+ *Free, /* Next free word in storage */
+ *MemTop, /* Top of free space available */
+ *Stack_Pointer, /* Next available slot in control stack */
+ *Stack_Top, /* Top of control stack */
+ *Stack_Guard, /* Guard area at end of stack */
+ *Free_Stacklets, /* Free list of stacklets */
+ *Constant_Space, /* Bottom of constant+pure space */
+ *Free_Constant, /* Next free cell in constant+pure area */
+ *Unused_Heap_Top, *Unused_Heap,
+ /* Top and bottom of 'other' heap for GC */
+ *Heap_Top, *Heap_Bottom, /* Top and bottom of current heap area */
+ *Local_Heap_Base, /* Per-processor CONSing area */
+ *Heap, /* Bottom of entire heap */
+ Swap_Temp, /* Used by Swap_Pointers in default.h */
+ Lookup_Base, /* Slot lookup returns result here */
+ Fluid_Bindings=NIL, /* Fluid bindings AList */
+ Current_State_Point=NIL, /* Used by dynamic winder */
+ return_to_interpreter, /* Return address/code left by interpreter
+ when calling compiled code */
+ *last_return_code; /* Address of the most recent return code in the stack.
+ This is only meaningful while in compiled code.
+ *** This must be changed when stacklets are used. ***
+ */
+\f
+long IntCode, /* Interrupts requesting */
+ IntEnb, /* Interrupts enabled */
+ Lookup_Offset, /* Slot lookup result return */
+ GC_Reserve = 4500, /* Scheme pointer overflow space in heap */
+ GC_Space_Needed, /* Amount of space needed when GC triggered */
+ /* Used to signal microcode errors from compiled code. */
+ compiled_code_error_code;
+
+Declare_Fixed_Objects();
+
+FILE *(Channels[FILE_CHANNELS]), *File_Handle, *Photo_File_Handle;
+int Saved_argc;
+char **Saved_argv;
+char *OS_Name, *OS_Variant;
+Boolean Photo_Open = false; /* Photo file open */
+Boolean Trapping, Can_Do_Cursor;
+Pointer Old_Return_Code, *Return_Hook_Address,
+ *Previous_Restore_History_Stacklet,
+ Weak_Chain;
+long Previous_Restore_History_Offset;
+jmp_buf *Back_To_Eval; /* Buffer for set/longjmp */
+long Heap_Size, Constant_Size, Stack_Size;
+Pointer *Highest_Allocated_Address;
+
+#ifndef Heap_In_Low_Memory
+Pointer *Memory_Base;
+#endif
+\f
+ /**********************/
+ /* DEBUGGING SWITCHES */
+ /**********************/
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+Boolean Eval_Debug = false;
+Boolean Hex_Input_Debug = false;
+Boolean File_Load_Debug = false;
+Boolean Reloc_Debug = false;
+Boolean Intern_Debug = false;
+Boolean Cont_Debug = false;
+Boolean Primitive_Debug = false;
+Boolean Lookup_Debug = false;
+Boolean Define_Debug = false;
+Boolean GC_Debug = false;
+Boolean Upgrade_Debug = false;
+Boolean Dump_Debug = false;
+Boolean Trace_On_Error = false;
+Boolean Bignum_Debug = false;
+Boolean Per_File = true;
+Boolean Fluids_Debug = false;
+More_Debug_Flag_Allocs();
+
+int debug_slotno = 0;
+int debug_nslots = 0;
+int local_slotno = 0;
+int local_nslots = 0;
+/* MHWU
+int debug_circle[debug_maxslots];
+int local_circle[debug_maxslots];
+*/
+int debug_circle[100];
+int local_circle[100];
+#endif
+
+ /****************************/
+ /* Debugging Macro Messages */
+ /****************************/
+
+char *CONT_PRINT_RETURN_MESSAGE = "Save_Cont, return code";
+char *CONT_PRINT_EXPR_MESSAGE = "Save_Cont, expression";
+char *RESTORE_CONT_RETURN_MESSAGE = "Restore_Cont, return code";
+char *RESTORE_CONT_EXPR_MESSAGE = "Restore_Cont, expression";
+
+\f
+ /*********************************/
+ /* Argument Count for Primitives */
+ /*********************************/
+
+char Arg_Count_Table[] = {
+/* 000 */ (char) 3, /* LEXICAL-ASSIGNMENT */
+/* 001 */ (char) 2, /* LOCAL-REFERENCE */
+/* 002 */ (char) 3, /* LOCAL-ASSIGNMENT */
+/* 003 */ (char) 1, /* CATCH */
+/* 004 */ (char) 2, /* SCODE-EVAL */
+/* 005 */ (char) 2, /* APPLY */
+/* 006 */ (char) 1, /* SET!-INTERRUPT-ENABLES */
+/* 007 */ (char) 1, /* STRING->SYMBOL */
+/* 008 */ (char) 1, /* GET-WORK */
+/* 009 */ (char) 1, /* NON-REENTRANT-CATCH */
+/* 00A */ (char) 1, /* GET-CURRENT-DYNAMIC-STATE */
+/* 00B */ (char) 1, /* SET-CURRENT-DYNAMIC-STATE! */
+/* 00C */ (char) 1, /* NULL? NOT */
+/* 00D */ (char) 2, /* EQ? */
+/* 00E */ (char) 2, /* STRING-EQUAL? */
+/* 00F */ (char) 2, /* PRIMITIVE-TYPE? */
+/* 010 */ (char) 1, /* PRIMITIVE-TYPE */
+/* 011 */ (char) 2, /* PRIMITIVE-SET-TYPE */
+/* 012 */ (char) 2, /* LEXICAL-REFERENCE */
+/* 013 */ (char) 2, /* LEXICAL-UNREFERENCEABLE-TEST */
+/* 014 */ (char) 2, /* MAKE-CHAR */
+/* 015 */ (char) 1, /* CHAR-BITS */
+/* 016 */ (char) 0, /* NON-RESTARTABLE-EXIT */
+/* 017 */ (char) 1, /* CHAR-CODE */
+/* 018 */ (char) 2, /* UNASSIGNED-TEST */
+/* 019 */ (char) 3, /* INSERT-NON-MARKED-VECTOR */
+/* 01A */ (char) 0, /* RESTARTABLE-EXIT */
+/* 01B */ (char) 1, /* CHAR->INTEGER */
+/* 01C */ (char) 2, /* MEMQ */
+/* 01D */ (char) 3, /* INSERT-STRING */
+/* 01E */ (char) 1, /* ENABLE-INTERRUPTS */
+/* 01F */ (char) 1, /* MAKE-EMPTY-STRING */
+/* 020 */ (char) 2, /* CONS */
+/* 021 */ (char) 1, /* CAR */
+/* 022 */ (char) 1, /* CDR */
+/* 023 */ (char) 2, /* SET!-CAR */
+/* 024 */ (char) 2, /* SET!-CDR */
+/* 025 */ (char) 2, /* PRINT-STRING */
+/* 026 */ (char) 0, /* TTY-GET-CURSOR */
+/* 027 */ (char) 2, /* GENERAL-CAR-CDR */
+/* 028 */ (char) 3, /* HUNK3-CONS */
+
+/* Argument Count Table continues on next page */
+\f
+/* Argument Count Table, continued */
+
+/* 029 */ (char) 2, /* HUNK3-CXR */
+/* 02A */ (char) 3, /* HUNK3-SET!-CXR */
+/* 02B */ (char) 3, /* OVERWRITE-STRING */
+/* 02C */ (char) 2, /* VECTOR-CONS */
+/* 02D */ (char) 1, /* VECTOR-SIZE */
+/* 02E */ (char) 2, /* VECTOR-REF */
+/* 02F */ (char) 1, /* SET-CURRENT-HISTORY */
+/* 030 */ (char) 3, /* VECTOR-SET! */
+/* 031 */ (char) 1, /* NON-MARKED-VECTOR-CONS */
+/* 032 */ (char) 1, /* GET-CHARACTER */
+/* 033 */ (char) 2, /* UNBOUND-TEST */
+/* 034 */ (char) 1, /* INTEGER->CHAR */
+/* 035 */ (char) 1, /* CHAR-DOWNCASE */
+/* 036 */ (char) 1, /* CHAR-UPCASE */
+/* 037 */ (char) 1, /* ASCII->CHAR */
+/* 038 */ (char) 1, /* CHAR-ASCII? */
+/* 039 */ (char) 1, /* CHAR->ASCII */
+/* 03A */ (char) 1, /* GARBAGE-COLLECT */
+/* 03B */ (char) 2, /* PLUS-FIXNUM */
+/* 03C */ (char) 2, /* MINUS-FIXNUM */
+/* 03D */ (char) 2, /* MULTIPLY-FIXNUM */
+/* 03E */ (char) 2, /* DIVIDE-FIXNUM */
+/* 03F */ (char) 2, /* EQUAL-FIXNUM? */
+/* 040 */ (char) 2, /* LESS-THAN-FIXNUM? */
+/* 041 */ (char) 1, /* POSITIVE-FIXNUM? */
+/* 042 */ (char) 1, /* ONE-PLUS-FIXNUM */
+/* 043 */ (char) 1, /* MINUS-ONE-PLUS-FIXNUM */
+/* 044 */ (char) 2, /* TRUNCATE-STRING */
+/* 045 */ (char) 3, /* SUBSTRING */
+/* 046 */ (char) 1, /* ZERO-FIXNUM? */
+/* 047 */ (char) 1, /* UNDANGERIZE */
+/* 048 */ (char) 1, /* DANGERIZE */
+/* 049 */ (char) 1, /* DANGEROUS? */
+/* 04A */ (char) 3, /* SUBSTRING-TO-LIST */
+/* 04B */ (char) 2, /* MAKE-FILLED-STRING */
+/* 04C */ (char) 2, /* PLUS-BIGNUM */
+/* 04D */ (char) 2, /* MINUS-BIGNUM */
+/* 04E */ (char) 2, /* MULTIPLY-BIGNUM */
+/* 04F */ (char) 2, /* DIVIDE-BIGNUM */
+/* 050 */ (char) 2, /* LISTIFY-BIGNUM */
+/* 051 */ (char) 2, /* EQUAL-BIGNUM? */
+/* 052 */ (char) 2, /* LESS-THAN-BIGNUM? */
+/* 053 */ (char) 1, /* POSITIVE-BIGNUM? */
+
+/* Argument Count Table continues on next page */
+\f
+/* Argument Count Table, continued */
+
+/* 054 */ (char) 2, /* FILE-OPEN-CHANNEL */
+/* 055 */ (char) 1, /* FILE-CLOSE-CHANNEL */
+/* 056 */ (char) 3, /* PRIMITIVE-FASDUMP */
+/* 057 */ (char) 1, /* BINARY-FASLOAD */
+/* 058 */ (char) 3, /* STRING-POSITION */
+/* 059 */ (char) 2, /* STRING-LESS? */
+/* 05A */ (char) 1, /* OBJECT-HASH */
+/* 05B */ (char) 1, /* OBJECT-UNHASH */
+/* 05C */ (char) 0, /* GC-REHASH-DAEMON */
+/* 05D */ (char) 1, /* LENGTH */
+/* 05E */ (char) 2, /* ASSQ */
+/* 05F */ (char) 1, /* BUILD-STRING-FROM-LIST */
+/* 060 */ (char) 2, /* EQUAL-STRING-TO-LIST? */
+/* 061 */ (char) 1, /* MAKE-CELL */
+/* 062 */ (char) 1, /* CONTENTS */
+/* 063 */ (char) 1, /* CELL? */
+/* 064 */ (char) 1, /* CHARACTER-UPCASE */
+/* 065 */ (char) 1, /* CHARACTER-LIST-HASH */
+/* 066 */ (char) 2, /* GCD-FIXNUM */
+/* 067 */ (char) 1, /* COERCE-FIXNUM-TO-BIGNUM */
+/* 068 */ (char) 1, /* COERCE-BIGNUM-TO-FIXNUM */
+/* 069 */ (char) 2, /* PLUS-FLONUM */
+/* 06A */ (char) 2, /* MINUS-FLONUM */
+/* 06B */ (char) 2, /* MULTIPLY-FLONUM */
+/* 06C */ (char) 2, /* DIVIDE-FLONUM */
+/* 06D */ (char) 2, /* EQUAL-FLONUM? */
+/* 06E */ (char) 2, /* LESS-THAN-FLONUM? */
+/* 06F */ (char) 1, /* ZERO-BIGNUM? */
+/* 070 */ (char) 1, /* TRUNCATE-FLONUM */
+/* 071 */ (char) 1, /* ROUND-FLONUM */
+/* 072 */ (char) 1, /* COERCE-INTEGER-TO-FLONUM */
+/* 073 */ (char) 1, /* SINE-FLONUM */
+/* 074 */ (char) 1, /* COSINE-FLONUM */
+/* 075 */ (char) 1, /* ARCTAN-FLONUM */
+/* 076 */ (char) 1, /* EXP-FLONUM */
+/* 077 */ (char) 1, /* LN-FLONUM */
+/* 078 */ (char) 1, /* SQRT-FLONUM */
+/* 079 */ (char) 1, /* PRIMITIVE-FASLOAD */
+/* 07A */ (char) 0, /* GET-FIXED-OBJECTS-VECTOR */
+/* 07B */ (char) 1, /* SET!-FIXED-OBJECTS-VECTOR */
+/* 07C */ (char) 1, /* LIST-TO-VECTOR */
+/* 07D */ (char) 3, /* SUBVECTOR-TO-LIST */
+/* 07E */ (char) 1, /* PAIR? */
+/* 07F */ (char) 1, /* NEGATIVE-FIXNUM? */
+/* 080 */ (char) 1, /* NEGATIVE-BIGNUM? */
+
+/* Argument Count Table continues on next page */
+\f
+/* Argument Count Table, continued */
+
+/* 081 */ (char) 2, /* GREATER-THAN-FIXNUM? */
+/* 082 */ (char) 2, /* GREATER-THAN-BIGNUM? */
+/* 083 */ (char) 1, /* STRING-HASH */
+/* 084 */ (char) 3, /* Sys-PAIR-CONS */
+/* 085 */ (char) 1, /* Sys-PAIR? */
+/* 086 */ (char) 1, /* Sys-PAIR-CAR */
+/* 087 */ (char) 1, /* Sys-PAIR-CDR */
+/* 088 */ (char) 2, /* Sys-PAIR-SET!-CAR */
+/* 089 */ (char) 2, /* Sys-PAIR-SET!-CDR */
+/* 08A */ (char) 1, /* INITIALIZE-OBJECT-HASH */
+/* 08B */ (char) 1, /* GET-CHARACTER-IMMEDIATE */
+/* 08C */ (char) 2, /* SET-CONTENTS! */
+/* 08D */ (char) 2, /* &MAKE-OBJECT */
+/* 08E */ (char) 1, /* Sys-HUNK3-CXR0 */
+/* 08F */ (char) 2, /* Sys-HUNK3-SET!-CXR0 */
+/* 090 */ (char) 2, /* MAP-MACHINE-ADDRESS-TO-CODE */
+/* 091 */ (char) 1, /* Sys-HUNK3-CXR1 */
+/* 092 */ (char) 2, /* Sys-HUNK3-SET!-CXR1 */
+/* 093 */ (char) 2, /* MAP-CODE-TO-MACHINE-ADDRESS */
+/* 094 */ (char) 1, /* Sys-HUNK3-CXR2 */
+/* 095 */ (char) 2, /* Sys-HUNK3-SET!-CXR2 */
+/* 096 */ (char) 1, /* MAP-PRIMITIVE-ADDRESS-TO-ARITY */
+/* 097 */ (char) 2, /* Sys-LIST-TO-VECTOR */
+/* 098 */ (char) 3, /* Sys-SUBVECTOR-TO-LIST */
+/* 099 */ (char) 1, /* Sys-VECTOR? */
+/* 09A */ (char) 2, /* Sys-VECTOR-REF */
+/* 09B */ (char) 3, /* Sys-VECTOR-SET! */
+/* 09C */ (char) 1, /* WITH-HISTORY-DISABLED */
+/* 09D */ (char) 0, /* unused */
+/* 09E */ (char) 0, /* unused */
+/* 09F */ (char) 0, /* unused */
+/* 0A0 */ (char) 0, /* unused */
+/* 0A1 */ (char) 0, /* unused */
+/* 0A2 */ (char) 0, /* unused */
+/* 0A3 */ (char) 1, /* VECTOR-8B-CONS */
+/* 0A4 */ (char) 1, /* VECTOR-8B? */
+/* 0A5 */ (char) 2, /* VECTOR-8B-REF */
+/* 0A6 */ (char) 3, /* VECTOR-8B-SET! */
+/* 0A7 */ (char) 1, /* ZERO-FLONUM? */
+/* 0A8 */ (char) 1, /* POSITIVE-FLONUM? */
+/* 0A9 */ (char) 1, /* NEGATIVE-FLONUM? */
+/* 0AA */ (char) 2, /* GREATER-THAN-FLONUM? */
+/* 0AB */ (char) 1, /* INTERN-CHARACTER-LIST */
+
+/* Argument Count Table continues on next page */
+\f
+/* Argument Count Table, continued */
+
+/* 0AC */ (char) 0, /* unused */
+/* 0AD */ (char) 1, /* VECTOR-8B-SIZE */
+/* 0AE */ (char) 1, /* Sys-VECTOR-SIZE */
+/* 0AF */ (char) 1, /* FORCE */
+/* 0B0 */ (char) 1, /* PRIMITIVE-DATUM */
+/* 0B1 */ (char) 1, /* MAKE-NON-POINTER-OBJECT */
+/* 0B2 */ (char) 1, /* DEBUGGING-PRINTER */
+/* 0B3 */ (char) 1, /* STRING-UPCASE */
+/* 0B4 */ (char) 2, /* PRIMITIVE-PURIFY */
+/* 0B5 */ (char) 0, /* unused */
+/* 0B6 */ (char) 2, /* COMPLETE-GARBAGE-COLLECT */
+/* 0B7 */ (char) 2, /* BAND-DUMP */
+/* 0B8 */ (char) 2, /* SUBSTRING-SEARCH */
+/* 0B9 */ (char) 1, /* BAND-LOAD */
+/* 0BA */ (char) 1, /* CONSTANT-P */
+/* 0BB */ (char) 1, /* PURE-P */
+/* 0BC */ (char) 1, /* GC-TYPE */
+/* 0BD */ (char) 1, /* IMPURIFY */
+/* 0BE */ (char) 2, /* WITH-THREADED-STACK */
+/* 0BF */ (char) 2, /* WITHIN-CONTROL-POINT */
+/* 0C0 */ (char) 1, /* SET-RUN-LIGHT */
+/* 0C1 */ (char) 1, /* FILE-EOF? */
+/* 0C2 */ (char) 1, /* FILE-READ-CHAR */
+/* 0C3 */ (char) 2, /* FILE-FILL-INPUT-BUFFER */
+/* 0C4 */ (char) 1, /* FILE-LENGTH */
+/* 0C5 */ (char) 2, /* FILE-WRITE-CHAR */
+/* 0C6 */ (char) 2, /* FILE-WRITE-STRING */
+/* 0C7 */ (char) 0, /* CLOSE-LOST-OPEN-FILES */
+/* 0C8 */ (char) 2, /* PUT-CHARACTER-TO-OUTPUT-CHANNEL */
+
+/* Argument Count Table continues on next page */
+\f
+/* Argument Count Table, continued */
+
+/* 0C9 */ (char) 2, /* WITH-INTERRUPTS-REDUCED */
+/* 0CA */ (char) 3, /* EVAL-STEP */
+/* 0CB */ (char) 3, /* APPLY-STEP */
+/* 0CC */ (char) 2, /* RETURN-STEP */
+/* 0CD */ (char) 1, /* TTY-READ-CHAR-READY? */
+/* 0CE */ (char) 0, /* TTY-READ-CHAR */
+/* 0CF */ (char) 0, /* TTY-READ-CHAR-IMMEDIATE */
+/* 0D0 */ (char) 0, /* TTY-READ-FINISH */
+/* 0D1 */ (char) 1, /* BIT-STRING-ALLOCATE */
+/* 0D2 */ (char) 2, /* MAKE-BIT-STRING */
+/* 0D3 */ (char) 1, /* BIT-STRING-P */
+/* 0D4 */ (char) 1, /* BIT-STRING-LENGTH */
+/* 0D5 */ (char) 2, /* BIT-STRING-REF */
+/* 0D6 */ (char) 5, /* BIT-SUBSTRING-MOVE-RIGHT-X */
+/* 0D7 */ (char) 2, /* BIT-STRING-SET-X */
+/* 0D8 */ (char) 2, /* BIT-STRING-CLEAR-X */
+/* 0D9 */ (char) 1, /* BIT-STRING-ZERO-P */
+/* 0DA */ (char) 0, /* unused */
+/* 0DB */ (char) 0, /* unused */
+/* 0DC */ (char) 2, /* UNSIGNED-INTEGER-TO-BIT-STRING */
+/* 0DD */ (char) 1, /* BIT-STRING-TO-UNSIGNED-INTEGER */
+/* 0DE */ (char) 0, /* unused */
+/* 0DF */ (char) 3, /* READ-BITS-X */
+/* 0E0 */ (char) 3, /* WRITE-BITS-X */
+/* 0E1 */ (char) 1, /* MAKE-STATE-SPACE */
+/* 0E2 */ (char) 4, /* EXECUTE-AT-NEW-POINT */
+/* 0E3 */ (char) 1, /* TRANSLATE-TO-POINT */
+/* 0E4 */ (char) 0, /* GET-NEXT-CONSTANT */
+/* 0E5 */ (char) 0, /* MICROCODE-IDENTIFY */
+/* 0E6 */ (char) 1, /* ZERO */
+/* 0E7 */ (char) 1, /* POSITIVE */
+
+/* Argument Count Table continues on next page */
+\f
+/* Argument Count Table, continued */
+
+/* 0E8 */ (char) 1, /* NEGATIVE */
+/* 0E9 */ (char) 2, /* EQUAL-NUMBER */
+/* 0EA */ (char) 2, /* LESS */
+/* 0EB */ (char) 2, /* GREATER */
+/* 0EC */ (char) 2, /* PLUS */
+/* 0ED */ (char) 2, /* MINUS */
+/* 0EE */ (char) 2, /* MULTIPLY */
+/* 0EF */ (char) 2, /* DIVIDE */
+/* 0F0 */ (char) 2, /* INTEGER-DIVIDE */
+/* 0F1 */ (char) 1, /* ONE-PLUS */
+/* 0F2 */ (char) 1, /* MINUS-ONE-PLUS */
+/* 0F3 */ (char) 1, /* TRUNCATE */
+/* 0F4 */ (char) 1, /* ROUND */
+/* 0F5 */ (char) 1, /* FLOOR */
+/* 0F6 */ (char) 1, /* CEILING */
+/* 0F7 */ (char) 1, /* SQRT */
+/* 0F8 */ (char) 1, /* EXP */
+/* 0F9 */ (char) 1, /* LN */
+/* 0FA */ (char) 1, /* SINE */
+/* 0FB */ (char) 1, /* COSINE */
+/* 0FB */ (char) 1, /* ARCTAN */
+/* 0FD */ (char) 1, /* TTY-WRITE-CHAR */
+/* 0FE */ (char) 1, /* TTY-WRITE-STRING */
+/* 0FF */ (char) 0, /* TTY-BEEP */
+/* 100 */ (char) 0, /* TTY-CLEAR */
+/* 101 */ (char) 0, /* GET-EXTERNAL-COUNTS */
+/* 102 */ (char) 1, /* GET-EXT-NAME */
+/* 103 */ (char) 2, /* GET-EXT-NUMBER */
+/* 104 */ (char) 0, /* unused */
+/* 105 */ (char) 0, /* unused */
+/* 106 */ (char) 0, /* GET-NEXT-INTERRUPT-CHARACTER */
+/* 107 */ (char) 2, /* CHECK-AND-CLEAN-UP-INPUT-CHANNEL */
+/* 108 */ (char) 0, /* unused */
+/* 109 */ (char) 0, /* SYSTEM-CLOCK */
+/* 10A */ (char) 1, /* FILE-EXISTS */
+/* 10B */ (char) 0, /* unused */
+/* 10C */ (char) 2, /* TTY-MOVE-CURSOR */
+/* 10D */ (char) 0, /* unused */
+/* 10E */ (char) 0, /* CURRENT-DATE */
+/* 10F */ (char) 0, /* CURRENT-TIME */
+/* 110 */ (char) 2, /* TRANSLATE-FILE */
+/* 111 */ (char) 2, /* COPY-FILE */
+/* 112 */ (char) 2, /* RENAME-FILE */
+/* 113 */ (char) 1, /* REMOVE-FILE */
+/* 114 */ (char) 3, /* LINK-FILE */
+/* 115 */ (char) 1, /* MAKE-DIRECTORY */
+/* 116 */ (char) 1, /* VOLUME-NAME */
+/* 117 */ (char) 1, /* SET-WORKING-DIRECTORY-PATHNAME-X */
+/* 118 */ (char) 1, /* OPEN-CATALOG */
+/* 119 */ (char) 0, /* CLOSE-CATALOG */
+/* 11A */ (char) 0, /* NEXT-FILE */
+/* 11B */ (char) 0, /* CAT-NAME */
+/* 11C */ (char) 0, /* CAT-KIND */
+/* 11D */ (char) 0, /* CAT-PSIZE */
+/* 11E */ (char) 0, /* CAT-LSIZE */
+/* 11F */ (char) 0, /* CAT-INFO */
+/* 120 */ (char) 0, /* CAT-BLOCK */
+/* 121 */ (char) 0, /* CAT-CREATE-DATE */
+/* 122 */ (char) 0, /* CAT-CREATE-TIME */
+/* 123 */ (char) 0, /* CAT-LAST-DATE */
+/* 124 */ (char) 0, /* CAT-LAST-TIME */
+/* 125 */ (char) 0, /* ERROR-MESSAGE */
+/* 126 */ (char) 0, /* CURRENT-YEAR */
+/* 127 */ (char) 0, /* CURRENT-MONTH */
+/* 128 */ (char) 0, /* CURRENT-DAY */
+/* 129 */ (char) 0, /* CURRENT-HOUR */
+/* 12A */ (char) 0, /* CURRENT-MINUTE */
+/* 12B */ (char) 0, /* CURRENT-SECOND */
+/* 12C */ (char) 1, /* INIT-FLOPPY */
+/* 12D */ (char) 1, /* ZERO-FLOPPY */
+/* 12E */ (char) 1, /* PACK-VOLUME */
+/* 12F */ (char) 1, /* LOAD-PICTURE */
+/* 130 */ (char) 1, /* STORE-PICTURE */
+/* 131 */ (char) 1, /* LOOKUP-SYSTEM-SYMBOL */
+/* 132 */ (char) 0, /* unused */
+/* 133 */ (char) 0, /* unused */
+/* 134 */ (char) 0, /* CLEAR-TO-END-OF-LINE */
+/* 135 */ (char) 0, /* unused */
+/* 136 */ (char) 0, /* unused */
+/* 137 */ (char) 2, /* WITH-INTERRUPT-MASK */
+/* 138 */ (char) 1, /* STRING? */
+/* 139 */ (char) 1, /* STRING-LENGTH */
+/* 13A */ (char) 2, /* STRING-REF */
+/* 13B */ (char) 3, /* STRING-SET! */
+/* 13C */ (char) 5, /* SUBSTRING-MOVE-RIGHT! */
+/* 13D */ (char) 5, /* SUBSTRING-MOVE-LEFT! */
+/* 13E */ (char) 1, /* STRING-ALLOCATE */
+/* 13F */ (char) 1, /* STRING-MAXIMUM-LENGTH */
+/* 140 */ (char) 2, /* SET-STRING-LENGTH! */
+/* 141 */ (char) 4, /* VECTOR-8B-FILL! */
+/* 142 */ (char) 4, /* VECTOR-8B-FIND-NEXT-CHAR */
+/* 143 */ (char) 4, /* VECTOR-8B-FIND-PREVIOUS-CHAR */
+/* 144 */ (char) 4, /* VECTOR-8B-FIND-NEXT-CHAR-CI */
+/* 145 */ (char) 4, /* VECTOR-8B-FIND-PREVIOUS-CHAR-CI */
+/* 146 */ (char) 4, /* SUBSTRING-FIND-NEXT-CHAR-IN-SET */
+/* 147 */ (char) 4, /* SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET */
+/* 148 */ (char) 6, /* SUBSTRING=? */
+/* 149 */ (char) 6, /* SUBSTRING-CI=? */
+/* 14A */ (char) 6, /* SUBSTRING<? */
+/* 14B */ (char) 3, /* SUBSTRING-UPCASE! */
+/* 14C */ (char) 3, /* SUBSTRING-DOWNCASE! */
+/* 14D */ (char) 6, /* SUBSTRING-MATCH-FORWARD */
+/* 14E */ (char) 6, /* SUBSTRING-MATCH-BACKWARD */
+/* 14F */ (char) 6, /* SUBSTRING-MATCH-FORWARD-CI */
+/* 150 */ (char) 6, /* SUBSTRING-MATCH-BACKWARD-CI */
+/* 151 */ (char) 1, /* PHOTO-OPEN */
+/* 152 */ (char) 0, /* PHOTO-CLOSE */
+/* 153 */ (char) 2, /* SETUP-TIMER-INTERRUPT */
+/* 154 */ (char) 0, /* unused */
+/* 155 */ (char) 0, /* unused */
+/* 156 */ (char) 0, /* unused */
+/* 157 */ (char) 0, /* unused */
+/* 158 */ (char) 0, /* unused */
+/* 159 */ (char) 0, /* unused */
+/* 15A */ (char) 0, /* unused */
+/* 15B */ (char) 0, /* unused */
+/* 15C */ (char) 0, /* unused */
+/* 15D */ (char) 0, /* unused */
+/* 15E */ (char) 0, /* unused */
+/* 15F */ (char) 0, /* unused */
+/* 160 */ (char) 0, /* unused */
+/* 161 */ (char) 0, /* EXTRACT-NON-MARKED-VECTOR */
+/* 162 */ (char) 0, /* UNSNAP-LINKS */
+/* 163 */ (char) 0, /* SAFE-PRIMITIVE-P */
+/* 164 */ (char) 0, /* SUBSTRING-READ */
+/* 165 */ (char) 0, /* SUBSTRING-WRITE */
+/* 166 */ (char) 0, /* SCREEN-X-SIZE */
+/* 167 */ (char) 0, /* SCREEN-Y-SIZE */
+/* 168 */ (char) 0, /* SCREEN-WRITE-CURSOR */
+/* 169 */ (char) 0, /* SCREEN-WRITE-CHARACTER */
+/* 16A */ (char) 0, /* SCREEN-WRITE-SUBSTRING */
+/* 16B */ (char) 0, /* NEXT-FILE-MATCHING */
+/* 16C */ (char) 0, /* unused */
+/* 16D */ (char) 0, /* TTY-WRITE-BYTE */
+/* 16E */ (char) 0, /* FILE-READ-BYTE */
+/* 16F */ (char) 0, /* FILE-WRITE-BYTE */
+/* 170 */ (char) 0, /* unused: SAVE-SCREEN */
+/* 171 */ (char) 0, /* unused: RESTORE-SCREEN */
+/* 172 */ (char) 0, /* unused: SUBSCREEN-CLEAR */
+/* 173 */ (char) 0, /* unused: AND-GCD */
+/* 174 */ (char) 0, /* unused: TTY-REDRAW-SCREEN */
+/* 175 */ (char) 0, /* unused: SCREEN-INVERSE-VIDEO */
+/* 176 */ (char) 1, /* STRING-TO-SYNTAX-ENTRY */
+/* 177 */ (char) 4, /* SCAN-WORD-FORWARD */
+/* 178 */ (char) 4, /* SCAN-WORD-BACKWARD */
+/* 179 */ (char) 7, /* SCAN-LIST-FORWARD */
+/* 17A */ (char) 7, /* SCAN-LIST-BACKWARD */
+/* 17B */ (char) 7, /* SCAN-SEXPS-FORWARD */
+/* 17C */ (char) 4, /* SCAN-FORWARD-TO-WORD */
+/* 17D */ (char) 4, /* SCAN-BACKWARD-PREFIX-CHARS */
+/* 17E */ (char) 2, /* CHAR-TO-SYNTAX-CODE */
+/* 17F */ (char) 4, /* QUOTED-CHAR-P */
+/* 180 */ (char) 0, /* MICROCODE-TABLES-FILENAME */
+/* 181 */ (char) 0, /* unused */
+/* 182 */ (char) 0, /* unused: FIND-PASCAL-PROGRAM */
+/* 183 */ (char) 0, /* unused: EXECUTE-PASCAL-PROGRAM */
+/* 184 */ (char) 0, /* unused: GRAPHICS-MOVE */
+/* 185 */ (char) 0, /* unused: GRAPHICS-LINE */
+/* 186 */ (char) 0, /* unused: GRAPHICS-PIXEL */
+/* 187 */ (char) 0, /* unused: GRAPHICS-SET-DRAWING-MODE */
+/* 188 */ (char) 0, /* unused: ALPHA-RASTER-P */
+/* 189 */ (char) 0, /* unused: TOGGLE-ALPHA-RASTER */
+/* 18A */ (char) 0, /* unused: GRAPHICS-RASTER-P */
+/* 18B */ (char) 0, /* unused: TOGGLE-GRAPHICS-RASTER */
+/* 18C */ (char) 0, /* unused: GRAPHICS-CLEAR */
+/* 18D */ (char) 0, /* unused: GRAPHICS-SET-LINE-STYLE */
+/* 18E */ (char) 3, /* ERROR-PROCEDURE */
+/* 18F */ (char) 0, /* VOLUME-EXISTS-P */
+/* 190 */ (char) 0, /* RE-CHAR-SET-ADJOIN */
+/* 191 */ (char) 0, /* RE-COMPILE-FASTMAP */
+/* 192 */ (char) 0, /* RE-MATCH */
+/* 193 */ (char) 0, /* RE-SEARCH-FORWARD */
+/* 194 */ (char) 0, /* RE-SEARCH-BACKWARD */
+/* 195 */ (char) 0, /* SYS-MEMORY-REF */
+/* 196 */ (char) 0, /* SYS-MEMORY-SET */
+/* 197 */ (char) 2, /* BIT-STRING-FILL-X */
+/* 198 */ (char) 2, /* BIT-STRING-MOVE-X */
+/* 199 */ (char) 2, /* BIT-STRING-MOVEC-X */
+/* 19A */ (char) 2, /* BIT-STRING-OR-X */
+/* 19B */ (char) 2, /* BIT-STRING-AND-X */
+/* 19C */ (char) 2, /* BIT-STRING-ANDC-X */
+/* 19D */ (char) 2, /* BIT-STRING-EQUAL-P */
+/* 19E */ (char) 0, /* WORKING-DIRECTORY-PATHNAME */
+/* 19F */ (char) 1, /* OPEN-DIRECTORY */
+/* 1A0 */ (char) 0, /* DIRECTORY-READ */
+/* 1A1 */ (char) 0 /* UNDER-EMACS? */
+};
+
+#if (MAX_PRIMITIVE_NUMBER != 0x1A1)
+/* Cause an error */
+#include "prims.h and storage.c are inconsistent -- arity table"
+#endif
+\f
+/* Declare the primitives themselves to be Externs */
+
+extern Pointer
+ Prim_And_Make_Object(),
+ Prim_Apply(), Prim_Apply_Step(), Prim_Arctan(), Prim_Arctan_Flonum(),
+ Prim_Assq(), Prim_Band_Dump(), Prim_Band_Load(), Prim_Big_To_Fix(),
+ Prim_Binary_Fasload(),
+ Prim_Build_String_From_List(),
+ Prim_Car(), Prim_Cat_Block(), Prim_Cat_Create_Date(),
+ Prim_Cat_Create_Time(), Prim_Cat_Info(), Prim_Cat_Kind(),
+ Prim_Cat_Last_Date(), Prim_Cat_Last_Time(), Prim_Cat_Lsize(),
+ Prim_Cat_Name(), Prim_Cat_Psize(), Prim_Catch(), Prim_Cdr(),
+ Prim_Ceiling(), Prim_Cell(), Prim_Cell_Contents(),
+ Prim_Character_List_Hash(),
+ Prim_Chk_And_Cln_Input_Channel(),
+ Prim_Close_Lost_Open_Files(),
+ Prim_Clear_To_End_Of_Line(),
+ Prim_Close_Catalog(),
+ Prim_Complete_Garbage_Collect(), Prim_Cons(),
+ Prim_Constant_P(), Prim_Copy_File(),
+ Prim_Cosine(), Prim_Cosine_Flonum(),
+ Prim_Current_Date(), Prim_Current_Day(),
+ Prim_Current_Dynamic_State(), Prim_Current_Hour(),
+ Prim_Current_Minute(), Prim_Current_Month(), Prim_Current_Second(),
+ Prim_Current_Time(), Prim_Current_Year(),
+ Prim_Dangerize(), Prim_Dangerous_QM(),
+ Prim_Divide(), Prim_Divide_Bignum(), Prim_Divide_Fixnum(),
+ Prim_Divide_Flonum(),
+ Prim_Enable_Interrupts(), Prim_Eq(),
+ Prim_Equal_Bignum(), Prim_Equal_Fixnum(),
+ Prim_Equal_Flonum(), Prim_Equal_Number(),
+ Prim_Equal_String_To_List(), Prim_Error_Message(),
+ Prim_Eval_Step(),
+ Prim_Execute_At_New_Point(),
+ Prim_Exp(), Prim_Fix_To_Big(),
+ Prim_Exp_Flonum(), Prim_File_Exists(), Prim_Floor(), Prim_Force(),
+ Prim_Garbage_Collect(), Prim_Gcd_Fixnum(),
+ Prim_Gc_Type(),
+ Prim_General_Car_Cdr(), Prim_Get_Character(),
+ Prim_Get_Char_Immediate(),
+ Prim_Get_External_Count(), Prim_Get_Ext_Name(),
+ Prim_Get_Ext_Number();
+
+/* Externs continue on next page */
+\f
+/* Externs, continued */
+
+extern Pointer
+ Prim_Get_Fixed_Objects_Vector(),
+ Prim_Get_Next_Constant(), Prim_Get_Next_Interrupt_Char(),
+#ifdef COMPILE_FUTURES
+ Prim_Get_Work(),
+#endif
+ Prim_Greater_Bignum(), Prim_Greater(),
+ Prim_Greater_Fixnum(), Prim_Greater_Flonum(),
+ Prim_Hunk3_Cons(), Prim_Hunk3_Cxr(), Prim_Hunk3_Set_Cxr(),
+ Prim_Impurify(), Prim_Init_Floppy(),
+ Prim_Initialize_Object_Hash(),
+ Prim_Ins_BStr(), Prim_Ins_BStr_Excl(),
+ Prim_Insert_Non_Marked_Vector(), Prim_Insert_String(),
+ Prim_Int_To_Float(), Prim_Integer_Divide(),
+ Prim_Intern_Character_List(), Prim_String_To_Symbol(),
+ Prim_Length(), Prim_Less(), Prim_Less_Bignum(), Prim_Less_Fixnum(),
+ Prim_Less_Flonum(), Prim_Lexical_Assignment(),
+ Prim_Lexical_Reference(), Prim_Link_File(),
+ Prim_Listify_Bignum(), Prim_List_To_Vector(), Prim_Ln(),
+ Prim_Ln_Flonum(), Prim_Load_Picture(), Prim_Local_Assignment(),
+ Prim_Local_Reference(),
+ Prim_Lookup_System_Symbol(), Prim_M_1_Plus(),
+ Prim_M_1_Plus_Fixnum(), Prim_Make_Cell(),
+ Prim_Make_Directory(), Prim_Make_Empty_String(),
+ Prim_Make_Fld_String(),
+ Prim_Make_Non_Pointer(), Prim_Make_State_Space(),
+ Prim_Map_Code_To_Address(),
+ Prim_Map_Address_To_Code(),
+ Prim_Map_Prim_Address_To_Arity();
+
+/* Externs continue on next page */
+\f
+/* Externs, continued */
+
+extern Pointer
+ Prim_Memq(),
+ Prim_Microcode_Identify(),
+ Prim_Minus(), Prim_Minus_Bignum(), Prim_Minus_Fixnum(),
+ Prim_Minus_Flonum(), Prim_Multiply_Bignum(),
+ Prim_Multiply(), Prim_Multiply_Fixnum(), Prim_Multiply_Flonum(),
+ Prim_Negative(), Prim_Negative_Bignum(), Prim_Negative_Fixnum(),
+ Prim_Negative_Flonum(), Prim_Next_File(),
+ Prim_Non_Marked_Vector_Cons(), Prim_Non_Reentrant_Catch(),
+ Prim_Non_Restartable_Exit(), Prim_Null(),
+ Prim_Object_Hash(), Prim_Object_Unhash(),
+ Prim_One_Plus(), Prim_One_Plus_Fixnum(),
+ Prim_Open_Catalog(),
+ Prim_Overwrite_String(), Prim_Pack_Volume(),
+ Prim_Pair(), Prim_Plus_Bignum(),
+ Prim_Plus(), Prim_Plus_Fixnum(), Prim_Plus_Flonum(), Prim_Positive(),
+ Prim_Positive_Bignum(),
+ Prim_Positive_Fixnum(), Prim_Positive_Flonum(),
+ Prim_Primitive_Datum(), Prim_Prim_Fasdump(),
+ Prim_Prim_Fasload(), Prim_Primitive_Purify(),
+ Prim_Primitive_Set_Type(), Prim_Prim_Type(),
+ Prim_Prim_Type_QM(), Prim_Print_String(), Prim_Pure_P(),
+ Prim_Put_Char_To_Output_Channel(),
+ Prim_Raise_Char(), Prim_Raise_String(),
+ Prim_Rehash_Gc_Daemon(),
+ Prim_Remove_File(), Prim_Rename_File(),
+ Prim_Restartable_Exit(), Prim_Return_Step(),
+ Prim_Round(),
+ Prim_Round_Flonum(), Prim_Scode_Eval(), Prim_Set_Car(),
+ Prim_Set_Cdr(), Prim_Set_Cell_Contents(),
+ Prim_Set_Current_History(), Prim_Set_Dynamic_State(),
+ Prim_Set_Fixed_Objects_Vector(), Prim_Set_Interrupt_Enables();
+
+/* Externs continue on next page */
+\f
+/* Externs, continued */
+
+extern Pointer
+ Prim_Set_Run_Light(),
+ Prim_Sine(), Prim_Sine_Flonum(),
+ Prim_Sqrt(), Prim_Sqrt_Flonum(), Prim_Store_Picture(),
+ Prim_String_Equal(), Prim_String_Hash(),
+ Prim_String_Less(), Prim_String_Position(),
+ Prim_Substring(), Prim_Substring_Search(),
+ Prim_Substring_To_List(), Prim_Subvector_To_List(),
+ Prim_Sys_H3_0(), Prim_Sys_H3_1(),
+ Prim_Sys_H3_2(), Prim_SH3_Set_0(),
+ Prim_SH3_Set_1(), Prim_SH3_Set_2(),
+ Prim_Sys_List_To_Vector(), Prim_Sys_Pair(),
+ Prim_Sys_Pair_Car(), Prim_Sys_Pair_Cdr(),
+ Prim_Sys_Pair_Cons(), Prim_Sys_Set_Car(),
+ Prim_Sys_Set_Cdr(), Prim_Sys_Subvector_To_List(),
+ Prim_Sys_Vector(), Prim_Sys_Vector_Ref(),
+ Prim_Sys_Vec_Set(), Prim_Sys_Vec_Size(),
+ Prim_System_Clock(), Prim_Temp_Printer(),
+ Prim_Translate_File(), Prim_Translate_To_Point(),
+ Prim_Truncate(), Prim_Truncate_Flonum(), Prim_Truncate_String(),
+ Prim_Unassigned_Test(), Prim_Unbound_Test(),
+ Prim_Undangerize(), Prim_Unreferenceable_Test(),
+ Prim_Unused(),
+ Prim_Volume_Name(),
+ Prim_Vector_8b(), Prim_Vector_8b_Cons(), Prim_Vector_8b_Ref(),
+ Prim_Vec_8b_Size(), Prim_Vector_Cons(), Prim_Vector_Ref(),
+ Prim_Vector_Set(), Prim_Vector_Size(), Prim_With_History_Disabled(),
+ Prim_With_Interrupt_Mask(), Prim_With_Interrupts_Reduced(),
+ Prim_With_Threaded_Stack(), Prim_Within_Control_Point(),
+ Prim_Zero(), Prim_Zero_Bignum(), Prim_Zero_Fixnum(),
+ Prim_Zero_Flonum(), Prim_Zero_Floppy();
+\f
+extern Pointer
+ Prim_Make_Char(), Prim_Char_Bits(), Prim_Char_Code(),
+ Prim_Char_To_Integer(), Prim_Integer_To_Char(),
+ Prim_Char_Downcase(), Prim_Char_Upcase(), Prim_Ascii_To_Char(),
+ Prim_Char_Ascii_P(), Prim_Char_To_Ascii(),
+
+ Prim_File_Open_Channel(), Prim_File_Close_Channel(),
+ Prim_File_Eof_P(), Prim_File_Read_Char(),
+ Prim_File_Fill_Input_Buffer(), Prim_File_Length(),
+ Prim_File_Write_Char(), Prim_File_Write_String(),
+
+ Prim_Tty_Read_Char_Ready_P(), Prim_Tty_Read_Char(),
+ Prim_Tty_Read_Char_Immediate(), Prim_Tty_Read_Finish(),
+ Prim_Tty_Write_Char(), Prim_Tty_Write_String(),
+ Prim_Tty_Beep(), Prim_Tty_Clear(),
+ Prim_Photo_Open(), Prim_Photo_Close(),
+ Prim_Setup_Timer_Interrupt(),
+ Prim_Tty_Move_Cursor(), Prim_Tty_Get_Cursor(),
+
+ Prim_String_P(),Prim_String_Length(),Prim_String_Ref(),
+ Prim_String_Set(), Prim_Substring_Move_Right(),
+ Prim_Substring_Move_Left(), Prim_String_Allocate(),
+ Prim_String_Maximum_Length(), Prim_Set_String_Length();
+
+extern Pointer
+ Prim_Vector_8b_Set(), Prim_Vector_8b_Fill(),
+ Prim_Vector_8b_Find_Next_Char(),
+ Prim_Vector_8b_Find_Previous_Char(),
+ Prim_Vector_8b_Find_Next_Char_Ci(),
+ Prim_Vector_8b_Find_Previous_Char_Ci(),
+ Prim_Substring_Find_Next_Char_In_Set(),
+ Prim_Substring_Find_Previous_Char_In_Set(),
+ Prim_Substring_Equal(),
+ Prim_Substring_Ci_Equal(),
+ Prim_Substring_Less(),
+ Prim_Substring_Upcase(),
+ Prim_Substring_Downcase(),
+ Prim_Substring_Match_Forward(),
+ Prim_Substring_Match_Backward(),
+ Prim_Substring_Match_Forward_Ci(),
+ Prim_Substring_Match_Backward_Ci(),
+ Prim_Screen_X_Size(),
+ Prim_Screen_Y_Size(),
+/* Not yet implemented below here */
+ Prim_Extract_Non_Marked_Vector(),
+ Prim_Unsnap_Links(),
+ Prim_Safe_Primitive_P(),
+ Prim_Substring_Read(),
+ Prim_Substring_Write(),
+ Prim_Screen_Write_Cursor(),
+ Prim_Screen_Write_Character(),
+ Prim_Screen_Write_Substring(),
+ Prim_Next_File_Matching(),
+ Prim_Tty_Write_Byte(),
+ Prim_File_Read_Byte(),
+ Prim_File_Write_Byte(),
+#if 0
+ Prim_And_Gcd(),
+ Prim_Save_Screen(),
+ Prim_Restore_Screen(),
+ Prim_Subscreen_Clear(),
+ Prim_Tty_Redraw_Screen(),
+ Prim_Screen_Inverse_Video(),
+#endif
+ Prim_String_To_Syntax_Entry(),
+ Prim_Scan_Word_Forward(),
+ Prim_Scan_Word_Backward(),
+ Prim_Scan_List_Forward(),
+ Prim_Scan_List_Backward(),
+ Prim_Scan_Sexps_Forward(),
+ Prim_Scan_Forward_To_Word(),
+ Prim_Scan_Backward_Prefix_Chars(),
+ Prim_Char_To_Syntax_Code(),
+ Prim_Quoted_Char_P(),
+ Prim_Microcode_Tables_Filename(),
+#if 0
+ Prim_Find_Pascal_Program(),
+ Prim_Execute_Pascal_Program(),
+ Prim_Graphics_Move(),
+ Prim_Graphics_Line(),
+ Prim_Graphics_Pixel(),
+ Prim_Graphics_Set_Drawing_Mode(),
+ Prim_Alpha_Raster_P(),
+ Prim_Toggle_Alpha_Raster(),
+ Prim_Graphics_Raster_P(),
+ Prim_Toggle_Graphics_Raster(),
+ Prim_Graphics_Clear(),
+ Prim_Graphics_Set_Line_Style(),
+#endif
+ Prim_Error_Procedure(),
+ Prim_Volume_Exists_P(),
+ Prim_Re_Char_Set_Adjoin(),
+ Prim_Re_Compile_Fastmap(),
+ Prim_Re_Match(),
+ Prim_Re_Search_Forward(),
+ Prim_Re_Search_Backward(),
+ Prim_Sys_Memory_Ref(),
+ Prim_Sys_Memory_Set(),
+
+/* new directory access primitives */
+ Prim_working_directory_pathname(),
+ Prim_set_working_directory_pathname_x(),
+ Prim_open_directory(),
+ Prim_directory_read(),
+
+/* new bit string primitives */
+ Prim_bit_string_allocate(), Prim_make_bit_string(),
+ Prim_bit_string_p(), Prim_bit_string_length(),
+ Prim_bit_string_ref(), Prim_bit_substring_move_right_x(),
+ Prim_bit_string_set_x(), Prim_bit_string_clear_x(),
+ Prim_unsigned_integer_to_bit_string(), Prim_bit_string_to_unsigned_integer(),
+ Prim_read_bits_x(), Prim_write_bits_x(),
+ Prim_bit_string_fill_x(), Prim_bit_string_move_x(),
+ Prim_bit_string_movec_x(), Prim_bit_string_or_x(),
+ Prim_bit_string_and_x(), Prim_bit_string_andc_x(),
+ Prim_bit_string_equal_p(), Prim_bit_string_zero_p(),
+
+ Prim_under_emacs_p();
+\f
+/* The table of all primitive procedures */
+
+Pointer (*(Primitive_Table[]))() = {
+/* 000 */ Prim_Lexical_Assignment,
+/* 001 */ Prim_Local_Reference,
+/* 002 */ Prim_Local_Assignment,
+/* 003 */ Prim_Catch,
+/* 004 */ Prim_Scode_Eval,
+/* 005 */ Prim_Apply,
+/* 006 */ Prim_Set_Interrupt_Enables,
+/* 007 */ Prim_String_To_Symbol,
+#ifdef COMPILE_FUTURES
+/* 008 */ Prim_Get_Work,
+#else
+/* 008 */ Prim_Unused,
+#endif
+/* 009 */ Prim_Non_Reentrant_Catch,
+/* 00A */ Prim_Current_Dynamic_State,
+/* 00B */ Prim_Set_Dynamic_State,
+/* 00C */ Prim_Null,
+/* 00D */ Prim_Eq,
+/* 00E */ Prim_String_Equal,
+/* 00F */ Prim_Prim_Type_QM,
+/* 010 */ Prim_Prim_Type,
+/* 011 */ Prim_Primitive_Set_Type,
+/* 012 */ Prim_Lexical_Reference,
+/* 013 */ Prim_Unreferenceable_Test,
+/* 014 */ Prim_Make_Char,
+/* 015 */ Prim_Char_Bits,
+/* 016 */ Prim_Non_Restartable_Exit,
+/* 017 */ Prim_Char_Code,
+/* 018 */ Prim_Unassigned_Test,
+/* 019 */ Prim_Insert_Non_Marked_Vector,
+/* 01A */ Prim_Restartable_Exit,
+/* 01B */ Prim_Char_To_Integer,
+/* 01C */ Prim_Memq,
+/* 01D */ Prim_Insert_String,
+/* 01E */ Prim_Enable_Interrupts,
+/* 01F */ Prim_Make_Empty_String,
+/* 020 */ Prim_Cons,
+/* 021 */ Prim_Car,
+/* 022 */ Prim_Cdr,
+/* 023 */ Prim_Set_Car,
+/* 024 */ Prim_Set_Cdr,
+/* 025 */ Prim_Print_String,
+/* 026 */ Prim_Tty_Get_Cursor,
+/* 027 */ Prim_General_Car_Cdr,
+/* 028 */ Prim_Hunk3_Cons,
+
+/* Primitive dispatch table continues on next page */
+\f
+/* Primitive dispatch table, continued */
+
+/* 029 */ Prim_Hunk3_Cxr,
+/* 02A */ Prim_Hunk3_Set_Cxr,
+/* 02B */ Prim_Overwrite_String,
+/* 02C */ Prim_Vector_Cons,
+/* 02D */ Prim_Vector_Size,
+/* 02E */ Prim_Vector_Ref,
+/* 02F */ Prim_Set_Current_History,
+/* 030 */ Prim_Vector_Set,
+/* 031 */ Prim_Non_Marked_Vector_Cons,
+/* 032 */ Prim_Get_Character,
+/* 033 */ Prim_Unbound_Test,
+/* 034 */ Prim_Integer_To_Char,
+/* 035 */ Prim_Char_Downcase,
+/* 036 */ Prim_Char_Upcase,
+/* 037 */ Prim_Ascii_To_Char,
+/* 038 */ Prim_Char_Ascii_P,
+/* 039 */ Prim_Char_To_Ascii,
+/* 03A */ Prim_Garbage_Collect,
+/* 03B */ Prim_Plus_Fixnum,
+/* 03C */ Prim_Minus_Fixnum,
+/* 03D */ Prim_Multiply_Fixnum,
+/* 03E */ Prim_Divide_Fixnum,
+/* 03F */ Prim_Equal_Fixnum,
+/* 040 */ Prim_Less_Fixnum,
+/* 041 */ Prim_Positive_Fixnum,
+/* 042 */ Prim_One_Plus_Fixnum,
+/* 043 */ Prim_M_1_Plus_Fixnum,
+/* 044 */ Prim_Truncate_String,
+/* 045 */ Prim_Substring,
+/* 046 */ Prim_Zero_Fixnum,
+/* 047 */ Prim_Undangerize,
+/* 048 */ Prim_Dangerize,
+/* 049 */ Prim_Dangerous_QM,
+/* 04A */ Prim_Substring_To_List,
+/* 04B */ Prim_Make_Fld_String,
+/* 04C */ Prim_Plus_Bignum,
+/* 04D */ Prim_Minus_Bignum,
+/* 04E */ Prim_Multiply_Bignum,
+/* 04F */ Prim_Divide_Bignum,
+/* 050 */ Prim_Listify_Bignum,
+/* 051 */ Prim_Equal_Bignum,
+/* 052 */ Prim_Less_Bignum,
+/* 053 */ Prim_Positive_Bignum,
+
+/* Primitive dispatch table continues on next page */
+\f
+/* Primitive dispatch table, continued */
+
+/* 054 */ Prim_File_Open_Channel,
+/* 055 */ Prim_File_Close_Channel,
+/* 056 */ Prim_Prim_Fasdump,
+/* 057 */ Prim_Binary_Fasload,
+/* 058 */ Prim_String_Position,
+/* 059 */ Prim_String_Less,
+/* 05A */ Prim_Object_Hash,
+/* 05B */ Prim_Object_Unhash,
+/* 05C */ Prim_Rehash_Gc_Daemon,
+/* 05D */ Prim_Length,
+/* 05E */ Prim_Assq,
+/* 05F */ Prim_Build_String_From_List,
+/* 060 */ Prim_Equal_String_To_List,
+/* 061 */ Prim_Make_Cell,
+/* 062 */ Prim_Cell_Contents,
+/* 063 */ Prim_Cell,
+/* 064 */ Prim_Raise_Char,
+/* 065 */ Prim_Character_List_Hash,
+/* 066 */ Prim_Gcd_Fixnum,
+/* 067 */ Prim_Fix_To_Big,
+/* 068 */ Prim_Big_To_Fix,
+/* 069 */ Prim_Plus_Flonum,
+/* 06A */ Prim_Minus_Flonum,
+/* 06B */ Prim_Multiply_Flonum,
+/* 06C */ Prim_Divide_Flonum,
+/* 06D */ Prim_Equal_Flonum,
+/* 06E */ Prim_Less_Flonum,
+/* 06F */ Prim_Zero_Bignum,
+/* 070 */ Prim_Truncate_Flonum,
+/* 071 */ Prim_Round_Flonum,
+/* 072 */ Prim_Int_To_Float,
+/* 073 */ Prim_Sine_Flonum,
+/* 074 */ Prim_Cosine_Flonum,
+/* 075 */ Prim_Arctan_Flonum,
+/* 076 */ Prim_Exp_Flonum,
+/* 077 */ Prim_Ln_Flonum,
+/* 078 */ Prim_Sqrt_Flonum,
+/* 079 */ Prim_Prim_Fasload,
+/* 07A */ Prim_Get_Fixed_Objects_Vector,
+/* 07B */ Prim_Set_Fixed_Objects_Vector,
+/* 07C */ Prim_List_To_Vector,
+/* 07D */ Prim_Subvector_To_List,
+/* 07E */ Prim_Pair,
+/* 07F */ Prim_Negative_Fixnum,
+/* 080 */ Prim_Negative_Bignum,
+
+/* Primitive dispatch table continues on next page */
+\f
+/* Primitive dispatch table, continued */
+
+/* 081 */ Prim_Greater_Fixnum,
+/* 082 */ Prim_Greater_Bignum,
+/* 083 */ Prim_String_Hash,
+/* 084 */ Prim_Sys_Pair_Cons,
+/* 085 */ Prim_Sys_Pair,
+/* 086 */ Prim_Sys_Pair_Car,
+/* 087 */ Prim_Sys_Pair_Cdr,
+/* 088 */ Prim_Sys_Set_Car,
+/* 089 */ Prim_Sys_Set_Cdr,
+/* 08A */ Prim_Initialize_Object_Hash,
+/* 08B */ Prim_Get_Char_Immediate,
+/* 08C */ Prim_Set_Cell_Contents,
+/* 08D */ Prim_And_Make_Object,
+/* 08E */ Prim_Sys_H3_0,
+/* 08F */ Prim_SH3_Set_0,
+/* 090 */ Prim_Map_Address_To_Code,
+/* 091 */ Prim_Sys_H3_1,
+/* 092 */ Prim_SH3_Set_1,
+/* 093 */ Prim_Map_Code_To_Address,
+/* 094 */ Prim_Sys_H3_2,
+/* 095 */ Prim_SH3_Set_2,
+/* 096 */ Prim_Map_Prim_Address_To_Arity,
+/* 097 */ Prim_Sys_List_To_Vector,
+/* 098 */ Prim_Sys_Subvector_To_List,
+/* 099 */ Prim_Sys_Vector,
+/* 09A */ Prim_Sys_Vector_Ref,
+/* 09B */ Prim_Sys_Vec_Set,
+/* 09C */ Prim_With_History_Disabled,
+/* 09D */ Prim_Unused,
+/* 09E */ Prim_Unused,
+/* 09F */ Prim_Unused,
+/* 0A0 */ Prim_Unused,
+/* 0A1 */ Prim_Unused,
+/* 0A2 */ Prim_Unused,
+/* 0A3 */ Prim_Vector_8b_Cons,
+/* 0A4 */ Prim_Vector_8b,
+/* 0A5 */ Prim_Vector_8b_Ref,
+/* 0A6 */ Prim_Vector_8b_Set,
+/* 0A7 */ Prim_Zero_Flonum,
+/* 0A8 */ Prim_Positive_Flonum,
+/* 0A9 */ Prim_Negative_Flonum,
+/* 0AA */ Prim_Greater_Flonum,
+/* 0AB */ Prim_Intern_Character_List,
+
+/* Primitive dispatch table continues on next page */
+\f
+/* Primitive dispatch table, continued */
+
+/* 0AC */ Prim_Unused,
+/* 0AD */ Prim_Vec_8b_Size,
+/* 0AE */ Prim_Sys_Vec_Size,
+/* 0AF */ Prim_Force,
+/* 0B0 */ Prim_Primitive_Datum,
+/* 0B1 */ Prim_Make_Non_Pointer,
+/* 0B2 */ Prim_Temp_Printer,
+/* 0B3 */ Prim_Raise_String,
+/* 0B4 */ Prim_Primitive_Purify,
+/* 0B5 */ Prim_Unused,
+/* 0B6 */ Prim_Complete_Garbage_Collect,
+/* 0B7 */ Prim_Band_Dump,
+/* 0B8 */ Prim_Substring_Search,
+/* 0B9 */ Prim_Band_Load,
+/* 0BA */ Prim_Constant_P,
+/* 0BB */ Prim_Pure_P,
+/* 0BC */ Prim_Gc_Type,
+/* 0BD */ Prim_Impurify,
+/* 0BE */ Prim_With_Threaded_Stack,
+/* 0BF */ Prim_Within_Control_Point,
+/* 0C0 */ Prim_Set_Run_Light,
+/* 0C1 */ Prim_File_Eof_P,
+/* 0C2 */ Prim_File_Read_Char,
+/* 0C3 */ Prim_File_Fill_Input_Buffer,
+/* 0C4 */ Prim_File_Length,
+/* 0C5 */ Prim_File_Write_Char,
+/* 0C6 */ Prim_File_Write_String,
+/* 0C7 */ Prim_Close_Lost_Open_Files,
+/* 0C8 */ Prim_Put_Char_To_Output_Channel,
+/* 0C9 */ Prim_With_Interrupts_Reduced,
+
+/* Primitive dispatch table continues on next page */
+\f
+/* Primitive dispatch table, continued */
+
+/* 0CA */ Prim_Eval_Step,
+/* 0CB */ Prim_Apply_Step,
+/* 0CC */ Prim_Return_Step,
+/* 0CD */ Prim_Tty_Read_Char_Ready_P,
+/* 0CE */ Prim_Tty_Read_Char,
+/* 0CF */ Prim_Tty_Read_Char_Immediate,
+/* 0D0 */ Prim_Tty_Read_Finish,
+/* 0D1 */ Prim_bit_string_allocate,
+/* 0D2 */ Prim_make_bit_string,
+/* 0D3 */ Prim_bit_string_p,
+/* 0D4 */ Prim_bit_string_length,
+/* 0D5 */ Prim_bit_string_ref,
+/* 0D6 */ Prim_bit_substring_move_right_x,
+/* 0D7 */ Prim_bit_string_set_x,
+/* 0D8 */ Prim_bit_string_clear_x,
+/* 0D9 */ Prim_bit_string_zero_p,
+/* 0DA */ Prim_Unused,
+/* 0DB */ Prim_Unused,
+/* 0DC */ Prim_unsigned_integer_to_bit_string,
+/* 0DD */ Prim_bit_string_to_unsigned_integer,
+/* 0DE */ Prim_Unused,
+/* 0DF */ Prim_read_bits_x,
+/* 0E0 */ Prim_write_bits_x,
+/* 0E1 */ Prim_Make_State_Space,
+/* 0E2 */ Prim_Execute_At_New_Point,
+/* 0E3 */ Prim_Translate_To_Point,
+/* 0E4 */ Prim_Get_Next_Constant,
+/* 0E5 */ Prim_Microcode_Identify,
+
+/* Primitive dispatch table continues on next page */
+\f
+/* Primitive dispatch table, continued */
+
+/* 0E6 */ Prim_Zero,
+/* 0E7 */ Prim_Positive,
+/* 0E8 */ Prim_Negative,
+/* 0E9 */ Prim_Equal_Number,
+/* 0EA */ Prim_Less,
+/* 0EB */ Prim_Greater,
+/* 0EC */ Prim_Plus,
+/* 0ED */ Prim_Minus,
+/* 0EE */ Prim_Multiply,
+/* 0EF */ Prim_Divide,
+/* 0F0 */ Prim_Integer_Divide,
+/* 0F1 */ Prim_One_Plus,
+/* 0F2 */ Prim_M_1_Plus,
+/* 0F3 */ Prim_Truncate,
+/* 0F4 */ Prim_Round,
+/* 0F5 */ Prim_Floor,
+/* 0F6 */ Prim_Ceiling,
+/* 0F7 */ Prim_Sqrt,
+/* 0F8 */ Prim_Exp,
+/* 0F9 */ Prim_Ln,
+/* 0FA */ Prim_Sine,
+/* 0FB */ Prim_Cosine,
+/* 0FC */ Prim_Arctan,
+/* 0FD */ Prim_Tty_Write_Char,
+/* 0FE */ Prim_Tty_Write_String,
+/* 0FF */ Prim_Tty_Beep,
+/* 100 */ Prim_Tty_Clear,
+/* 101 */ Prim_Get_External_Count,
+/* 102 */ Prim_Get_Ext_Name,
+/* 103 */ Prim_Get_Ext_Number,
+/* 104 */ Prim_Unused,
+/* 105 */ Prim_Unused,
+/* 106 */ Prim_Get_Next_Interrupt_Char,
+/* 107 */ Prim_Chk_And_Cln_Input_Channel,
+/* 108 */ Prim_Unused,
+/* 109 */ Prim_System_Clock,
+/* 10a */ Prim_File_Exists,
+/* 10b */ Prim_Unused,
+/* 10c */ Prim_Tty_Move_Cursor,
+/* 10d */ Prim_Unused,
+/* 10e */ Prim_Current_Date,
+/* 10f */ Prim_Current_Time,
+/* 110 */ Prim_Translate_File,
+/* 111 */ Prim_Copy_File,
+/* 112 */ Prim_Rename_File,
+/* 113 */ Prim_Remove_File,
+/* 114 */ Prim_Link_File,
+/* 115 */ Prim_Make_Directory,
+/* 116 */ Prim_Volume_Name,
+/* 117 */ Prim_set_working_directory_pathname_x,
+/* 118 */ Prim_Open_Catalog,
+/* 119 */ Prim_Close_Catalog,
+/* 11a */ Prim_Next_File,
+/* 11b */ Prim_Cat_Name,
+/* 11c */ Prim_Cat_Kind,
+/* 11d */ Prim_Cat_Psize,
+/* 11e */ Prim_Cat_Lsize,
+/* 11f */ Prim_Cat_Info,
+/* 120 */ Prim_Cat_Block,
+/* 121 */ Prim_Cat_Create_Date,
+/* 122 */ Prim_Cat_Create_Time,
+/* 123 */ Prim_Cat_Last_Date,
+/* 124 */ Prim_Cat_Last_Time,
+/* 125 */ Prim_Error_Message,
+/* 126 */ Prim_Current_Year,
+/* 127 */ Prim_Current_Month,
+/* 128 */ Prim_Current_Day,
+/* 129 */ Prim_Current_Hour,
+/* 12a */ Prim_Current_Minute,
+/* 12b */ Prim_Current_Second,
+/* 12c */ Prim_Init_Floppy,
+/* 12d */ Prim_Zero_Floppy,
+/* 12e */ Prim_Pack_Volume,
+/* 12f */ Prim_Load_Picture,
+/* 130 */ Prim_Store_Picture,
+/* 131 */ Prim_Lookup_System_Symbol,
+/* 132 */ Prim_Unused,
+/* 133 */ Prim_Unused,
+/* 134 */ Prim_Clear_To_End_Of_Line,
+/* 135 */ Prim_Unused,
+/* 136 */ Prim_Unused,
+/* 137 */ Prim_With_Interrupt_Mask,
+/* 138 */ Prim_String_P,
+/* 139 */ Prim_String_Length,
+/* 13A */ Prim_String_Ref,
+/* 13B */ Prim_String_Set,
+/* 13C */ Prim_Substring_Move_Right,
+/* 13D */ Prim_Substring_Move_Left,
+/* 13E */ Prim_String_Allocate,
+/* 13F */ Prim_String_Maximum_Length,
+/* 140 */ Prim_Set_String_Length,
+/* 141 */ Prim_Vector_8b_Fill,
+/* 142 */ Prim_Vector_8b_Find_Next_Char,
+/* 143 */ Prim_Vector_8b_Find_Previous_Char,
+/* 144 */ Prim_Vector_8b_Find_Next_Char_Ci,
+/* 145 */ Prim_Vector_8b_Find_Previous_Char_Ci,
+/* 146 */ Prim_Substring_Find_Next_Char_In_Set,
+/* 147 */ Prim_Substring_Find_Previous_Char_In_Set,
+/* 148 */ Prim_Substring_Equal,
+/* 149 */ Prim_Substring_Ci_Equal,
+/* 14A */ Prim_Substring_Less,
+/* 14B */ Prim_Substring_Upcase,
+/* 14C */ Prim_Substring_Downcase,
+/* 14D */ Prim_Substring_Match_Forward,
+/* 14E */ Prim_Substring_Match_Backward,
+/* 14F */ Prim_Substring_Match_Forward_Ci,
+/* 150 */ Prim_Substring_Match_Backward_Ci,
+/* 151 */ Prim_Photo_Open,
+/* 152 */ Prim_Photo_Close,
+/* 153 */ Prim_Setup_Timer_Interrupt,
+/* 154 */ Prim_Unused,
+/* 155 */ Prim_Unused,
+/* 156 */ Prim_Unused,
+/* 157 */ Prim_Unused,
+/* 158 */ Prim_Unused,
+/* 159 */ Prim_Unused,
+/* 15A */ Prim_Unused,
+/* 15B */ Prim_Unused,
+/* 15C */ Prim_Unused,
+/* 15D */ Prim_Unused,
+/* 15E */ Prim_Unused,
+/* 15F */ Prim_Unused,
+/* 160 */ Prim_Unused,
+/* 161 */ Prim_Extract_Non_Marked_Vector,
+/* 162 */ Prim_Unsnap_Links,
+/* 163 */ Prim_Safe_Primitive_P,
+/* 164 */ Prim_Substring_Read,
+/* 165 */ Prim_Substring_Write,
+/* 166 */ Prim_Screen_X_Size,
+/* 167 */ Prim_Screen_Y_Size,
+/* 168 */ Prim_Screen_Write_Cursor,
+/* 169 */ Prim_Screen_Write_Character,
+/* 16a */ Prim_Screen_Write_Substring,
+/* 16b */ Prim_Next_File_Matching,
+/* 16c */ Prim_Unused,
+/* 16d */ Prim_Tty_Write_Byte,
+/* 16e */ Prim_File_Read_Byte,
+/* 16f */ Prim_File_Write_Byte,
+/* 170 */ Prim_Unused, /* Prim_Save_Screen, */
+/* 171 */ Prim_Unused, /* Prim_Restore_Screen, */
+/* 172 */ Prim_Unused, /* Prim_Subscreen_Clear, */
+/* 173 */ Prim_Unused, /* Prim_And_Gcd, */
+/* 174 */ Prim_Unused, /* Prim_Tty_Redraw_Screen, */
+/* 175 */ Prim_Unused, /* Prim_Screen_Inverse_Video, */
+/* 176 */ Prim_String_To_Syntax_Entry,
+/* 177 */ Prim_Scan_Word_Forward,
+/* 178 */ Prim_Scan_Word_Backward,
+/* 179 */ Prim_Scan_List_Forward,
+/* 17a */ Prim_Scan_List_Backward,
+/* 17b */ Prim_Scan_Sexps_Forward,
+/* 17c */ Prim_Scan_Forward_To_Word,
+/* 17d */ Prim_Scan_Backward_Prefix_Chars,
+/* 17e */ Prim_Char_To_Syntax_Code,
+/* 17f */ Prim_Quoted_Char_P,
+/* 180 */ Prim_Microcode_Tables_Filename,
+/* 181 */ Prim_Unused,
+/* 182 */ Prim_Unused, /* Prim_Find_Pascal_Program, */
+/* 183 */ Prim_Unused, /* Prim_Execute_Pascal_Program, */
+/* 184 */ Prim_Unused, /* Prim_Graphics_Move, */
+/* 185 */ Prim_Unused, /* Prim_Graphics_Line, */
+/* 186 */ Prim_Unused, /* Prim_Graphics_Pixel, */
+/* 187 */ Prim_Unused, /* Prim_Graphics_Set_Drawing_Mode, */
+/* 188 */ Prim_Unused, /* Prim_Alpha_Raster_P, */
+/* 189 */ Prim_Unused, /* Prim_Toggle_Alpha_Raster, */
+/* 18a */ Prim_Unused, /* Prim_Graphics_Raster_P, */
+/* 18b */ Prim_Unused, /* Prim_Toggle_Graphics_Raster, */
+/* 18c */ Prim_Unused, /* Prim_Graphics_Clear, */
+/* 18d */ Prim_Unused, /* Prim_Graphics_Set_Line_Style, */
+/* 18e */ Prim_Error_Procedure,
+/* 18f */ Prim_Volume_Exists_P,
+/* 190 */ Prim_Re_Char_Set_Adjoin,
+/* 191 */ Prim_Re_Compile_Fastmap,
+/* 192 */ Prim_Re_Match,
+/* 193 */ Prim_Re_Search_Forward,
+/* 194 */ Prim_Re_Search_Backward,
+/* 195 */ Prim_Sys_Memory_Ref,
+/* 196 */ Prim_Sys_Memory_Set,
+/* 197 */ Prim_bit_string_fill_x,
+/* 198 */ Prim_bit_string_move_x,
+/* 199 */ Prim_bit_string_movec_x,
+/* 19a */ Prim_bit_string_or_x,
+/* 19b */ Prim_bit_string_and_x,
+/* 19c */ Prim_bit_string_andc_x,
+/* 19d */ Prim_bit_string_equal_p,
+/* 19E */ Prim_working_directory_pathname,
+/* 19F */ Prim_open_directory,
+/* 1A0 */ Prim_directory_read,
+/* 1A1 */ Prim_under_emacs_p
+};
+
+#if (MAX_PRIMITIVE_NUMBER != 0x1A1)
+/* Cause an error */
+#include "Prims.h and storage.c are inconsistent -- Procedure Table"
+#endif
+\f
+/* And, finally, the table of primitive names. */
+
+static char No_Name[] = "";
+
+char *Primitive_Names[] = {
+
+/* 0x00 in lookup */ "LEXICAL-ASSIGNMENT",
+/* 0x01 in lookup */ "LOCAL-REFERENCE",
+/* 0x02 in lookup */ "LOCAL-ASSIGNMENT",
+/* 0x03 in hooks */ "CALL-WITH-CURRENT-CONTINUATION",
+/* 0x04 in hooks */ "SCODE-EVAL",
+/* 0x05 in hooks */ "APPLY",
+/* 0x06 in hooks */ "SET-INTERRUPT-ENABLES!",
+/* 0x07 in fasload */ "STRING->SYMBOL",
+/* 0x08 in prim */ "GET-WORK",
+/* 0x09 in hooks */ "NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION",
+/* 0x0A in hooks */ "CURRENT-DYNAMIC-STATE",
+/* 0x0B in hooks */ "SET-CURRENT-DYNAMIC-STATE!",
+/* 0x0C in prim */ "NULL?",
+/* 0x0D in prim */ "EQ?",
+/* 0x0E in string */ "STRING-EQUAL?",
+/* 0x0F in prim */ "PRIMITIVE-TYPE?",
+/* 0x10 in prim */ "PRIMITIVE-TYPE",
+/* 0x11 in prim */ "PRIMITIVE-SET-TYPE",
+/* 0x12 in lookup */ "LEXICAL-REFERENCE",
+/* 0x13 in lookup */ "LEXICAL-UNREFERENCEABLE?",
+/* 0x14 in character */ "MAKE-CHAR",
+/* 0x15 in character */ "CHAR-BITS",
+/* 0x16 in sysprim */ "EXIT",
+/* 0x17 in character */ "CHAR-CODE",
+/* 0x18 in lookup */ "LEXICAL-UNASSIGNED?",
+/* 0x19 in prim */ "INSERT-NON-MARKED-VECTOR!",
+/* 0x1A in sysprim */ "HALT",
+/* 0x1B in character */ "CHAR->INTEGER",
+/* 0x1C in list */ "MEMQ",
+/* 0x1D in string */ "INSERT-STRING",
+/* 0x1E in hooks */ "ENABLE-INTERRUPTS!",
+/* 0x1F in string */ "MAKE-EMPTY-STRING",
+/* 0x20 in list */ "CONS",
+/* 0x21 in list */ "CAR",
+/* 0x22 in list */ "CDR",
+/* 0x23 in list */ "SET-CAR!",
+/* 0x24 in list */ "SET-CDR!",
+
+/* Primitive names continue on the next page */
+\f
+/* Primitive names, continued */
+
+/* 0x25 in io */ "PRINT-STRING",
+/* 0x26 in ttyio */ "TTY-GET-CURSOR",
+/* 0x27 in list */ "GENERAL-CAR-CDR",
+/* 0x28 in hunk */ "HUNK3-CONS",
+/* 0x29 in hunk */ "HUNK3-CXR",
+/* 0x2A in hunk */ "HUNK3-SET-CXR!",
+/* 0x2B in string */ "INSERT-STRING!",
+/* 0x2C in vector */ "VECTOR-CONS",
+/* 0x2D in vector */ "VECTOR-LENGTH",
+/* 0x2E in vector */ "VECTOR-REF",
+/* 0x2F in hooks */ "SET-CURRENT-HISTORY!",
+/* 0x30 in vector */ "VECTOR-SET!",
+/* 0x31 in prim */ "NON-MARKED-VECTOR-CONS",
+/* 0x32 in io */ "GET-CHARACTER-FROM-INPUT-CHANNEL",
+/* 0x33 in lookup */ "LEXICAL-UNBOUND?",
+/* 0x34 in character */ "INTEGER->CHAR",
+/* 0x35 in character */ "CHAR-DOWNCASE",
+/* 0x36 in character */ "CHAR-UPCASE",
+/* 0x37 in character */ "ASCII->CHAR",
+/* 0x38 in character */ "CHAR-ASCII?",
+/* 0x39 in character */ "CHAR->ASCII",
+/* 0x3A in gcloop */ "GARBAGE-COLLECT",
+/* 0x3B in fixnum */ "PLUS-FIXNUM",
+/* 0x3C in fixnum */ "MINUS-FIXNUM",
+/* 0x3D in fixnum */ "MULTIPLY-FIXNUM",
+/* 0x3E in fixnum */ "DIVIDE-FIXNUM",
+/* 0x3F in fixnum */ "EQUAL-FIXNUM?",
+/* 0x40 in fixnum */ "LESS-THAN-FIXNUM?",
+/* 0x41 in fixnum */ "POSITIVE-FIXNUM?",
+/* 0x42 in fixnum */ "ONE-PLUS-FIXNUM",
+/* 0x43 in fixnum */ "MINUS-ONE-PLUS-FIXNUM",
+/* 0x44 in string */ "TRUNCATE-STRING!",
+/* 0x45 in string */ "SUBSTRING",
+/* 0x46 in fixnum */ "ZERO-FIXNUM?",
+/* 0x47 in prim */ "MAKE-OBJECT-SAFE",
+/* 0x48 in prim */ "MAKE-OBJECT-DANGEROUS",
+/* 0x49 in prim */ "OBJECT-DANGEROUS?",
+/* 0x4A in string */ "SUBSTRING->LIST",
+/* 0x4B in string */ "MAKE-FILLED-STRING",
+/* 0x4C in bignum */ "PLUS-BIGNUM",
+/* 0x4D in bignum */ "MINUS-BIGNUM",
+/* 0x4E in bignum */ "MULTIPLY-BIGNUM",
+/* 0x4F in bignum */ "DIVIDE-BIGNUM",
+
+/* Primitive names continue on the next page */
+\f
+/* Primitive names, continued */
+
+/* 0x50 in bignum */ "LISTIFY-BIGNUM",
+/* 0x51 in bignum */ "EQUAL-BIGNUM?",
+/* 0x52 in bignum */ "LESS-THAN-BIGNUM?",
+/* 0x53 in bignum */ "POSITIVE-BIGNUM?",
+/* 0x54 in fileio */ "FILE-OPEN-CHANNEL",
+/* 0x55 in fileio */ "FILE-CLOSE-CHANNEL",
+/* 0x56 in fasdump */ "PRIMITIVE-FASDUMP",
+/* 0x57 in fasload */ "BINARY-FASLOAD",
+/* 0x58 in string */ "STRING-POSITION",
+/* 0x59 in string */ "STRING-LESS?",
+/* 0x5A in daemon */ "OBJECT-HASH",
+/* 0x5B in daemon */ "OBJECT-UNHASH",
+/* 0x5C in daemon */ "REHASH-GC-DAEMON",
+/* 0x5D in list */ "LENGTH",
+/* 0x5E in list */ "ASSQ",
+/* 0x5F in string */ "LIST->STRING",
+/* 0x60 in string */ "EQUAL-STRING-TO-LIST?",
+/* 0x61 in prim */ "MAKE-CELL",
+/* 0x62 in prim */ "CELL-CONTENTS",
+/* 0x63 in prim */ "CELL?",
+/* 0x64 in string */ "CHARACTER-UPCASE",
+/* 0x65 in fasload */ "CHARACTER-LIST-HASH",
+/* 0x66 in fixnum */ "GCD-FIXNUM",
+/* 0x67 in bignum */ "COERCE-FIXNUM-TO-BIGNUM",
+/* 0x68 in bignum */ "COERCE-BIGNUM-TO-FIXNUM",
+/* 0x69 in flonum */ "PLUS-FLONUM",
+/* 0x6A in flonum */ "MINUS-FLONUM",
+/* 0x6B in flonum */ "MULTIPLY-FLONUM",
+/* 0x6C in flonum */ "DIVIDE-FLONUM",
+/* 0x6D in flonum */ "EQUAL-FLONUM?",
+/* 0x6E in flonum */ "LESS-THAN-FLONUM?",
+/* 0x6F in bignum */ "ZERO-BIGNUM?",
+/* 0x70 in flonum */ "TRUNCATE-FLONUM",
+/* 0x71 in flonum */ "ROUND-FLONUM",
+/* 0x72 in flonum */ "COERCE-INTEGER-TO-FLONUM",
+/* 0x73 in flonum */ "SINE-FLONUM",
+/* 0x74 in flonum */ "COSINE-FLONUM",
+/* 0x75 in flonum */ "ARCTAN-FLONUM",
+/* 0x76 in flonum */ "EXP-FLONUM",
+/* 0x77 in flonum */ "LN-FLONUM",
+
+/* Primitive names continue on the next page */
+\f
+/* Primitive names, continued */
+
+/* 0x78 in flonum */ "SQRT-FLONUM",
+/* 0x79 in nihil */ "PRIMITIVE-FASLOAD",
+/* 0x7A in hooks */ "GET-FIXED-OBJECTS-VECTOR",
+/* 0x7B in hooks */ "SET-FIXED-OBJECTS-VECTOR!",
+/* 0x7C in vector */ "LIST->VECTOR",
+/* 0x7D in vector */ "SUBVECTOR->LIST",
+/* 0x7E in list */ "PAIR?",
+/* 0x7F in fixnum */ "NEGATIVE-FIXNUM?",
+/* 0x80 in bignum */ "NEGATIVE-BIGNUM?",
+/* 0x81 in fixnum */ "GREATER-THAN-FIXNUM?",
+/* 0x82 in bignum */ "GREATER-THAN-BIGNUM?",
+/* 0x83 in string */ "STRING-HASH",
+/* 0x84 in list */ "SYSTEM-PAIR-CONS",
+/* 0x85 in list */ "SYSTEM-PAIR?",
+/* 0x86 in list */ "SYSTEM-PAIR-CAR",
+/* 0x87 in list */ "SYSTEM-PAIR-CDR",
+/* 0x88 in list */ "SYSTEM-PAIR-SET-CAR!",
+/* 0x89 in list */ "SYSTEM-PAIR-SET-CDR!",
+/* 0x8A in daemon */ "INITIALIZE-OBJECT-HASH",
+/* 0x8B in io */ "GET-CHARACTER-FROM-INPUT-CHANNEL-IMMEDIATE",
+/* 0x8C in prim */ "SET-CELL-CONTENTS!",
+/* 0x8D in prim */ "&MAKE-OBJECT",
+/* 0x8E in hunk */ "SYSTEM-HUNK3-CXR0",
+/* 0x8F in hunk */ "SYSTEM-HUNK3-SET-CXR0!",
+/* 0x90 in prim */ "MAP-MACHINE-ADDRESS-TO-CODE",
+/* 0x91 in hunk */ "SYSTEM-HUNK3-CXR1",
+/* 0x92 in hunk */ "SYSTEM-HUNK3-SET-CXR1!",
+/* 0x93 in prim */ "MAP-CODE-TO-MACHINE-ADDRESS",
+/* 0x94 in hunk */ "SYSTEM-HUNK3-CXR2",
+/* 0x95 in hunk */ "SYSTEM-HUNK3-SET-CXR2!",
+/* 0x96 in prim */ "PRIMITIVE-PROCEDURE-ARITY",
+/* 0x97 in vector */ "SYSTEM-LIST-TO-VECTOR",
+/* 0x98 in vector */ "SYSTEM-SUBVECTOR-TO-LIST",
+/* 0x99 in vector */ "SYSTEM-VECTOR?",
+/* 0x9A in vector */ "SYSTEM-VECTOR-REF",
+/* 0x9B in vector */ "SYSTEM-VECTOR-SET!",
+/* 0x9C in hooks */ "WITH-HISTORY-DISABLED",
+
+/* Primitive names continue on the next page */
+\f
+/* Primitive names, continued */
+
+/* 0x9D not here */ No_Name,
+/* 0x9E not here */ No_Name,
+/* 0x9F not here */ No_Name,
+/* 0xA0 not here */ No_Name,
+/* 0xA1 not here */ No_Name,
+/* 0xA2 not here */ No_Name,
+/* 0xA3 in string */ "VECTOR-8B-CONS",
+/* 0xA4 in string */ "VECTOR-8B?",
+/* 0xA5 in string */ "VECTOR-8B-REF",
+/* 0xA6 in string */ "VECTOR-8B-SET!",
+/* 0xA7 in flonum */ "ZERO-FLONUM?",
+/* 0xA8 in flonum */ "POSITIVE-FLONUM?",
+/* 0xA9 in flonum */ "NEGATIVE-FLONUM?",
+/* 0xAA in flonum */ "GREATER-THAN-FLONUM?",
+/* 0xAB in fasload */ "INTERN-CHARACTER-LIST",
+/* 0xAC not here */ No_Name,
+/* 0xAD in string */ "STRING-LENGTH",
+/* 0xAE in vector */ "SYSTEMTEM-VECTOR-SIZE",
+/* 0xAF in hooks */ "FORCE",
+/* 0xB0 in prim */ "PRIMITIVE-DATUM",
+/* 0xB1 in prim */ "MAKE-NON-POINTER-OBJECT",
+/* 0xB2 in debug */ "DEBUGGING-PRINTER",
+/* 0xB3 in string */ "STRING-UPCASE",
+/* 0xB4 in gcloop */ "PRIMITIVE-PURIFY",
+/* 0xB5 not here */ No_Name,
+/* 0xB6 in nihil */ "COMPLETE-GARBAGE-COLLECT",
+/* 0xB7 in fasdump */ "DUMP-BAND",
+/* 0xB8 in string */ "SUBSTRING-SEARCH",
+/* 0xB9 in fasload */ "LOAD-BAND",
+/* 0xBA in gcloop */ "CONSTANT?",
+/* 0xBB in gcloop */ "PURE?",
+/* 0xBC in gcloop */ "PRIMITIVE-GC-TYPE",
+/* 0xBD in gcloop */ "PRIMITIVE-IMPURIFY",
+/* 0xBE in hooks */ "WITH-THREADED-CONTINUATION",
+/* 0xBF in hooks */ "WITHIN-CONTROL-POINT",
+/* 0xC0 in sysprim */ "SET-RUN-LIGHT!",
+/* 0xC1 in fileio */ "FILE-EOF?",
+/* 0xC2 in fileio */ "FILE-READ-CHAR",
+/* 0xC3 in fileio */ "FILE-FILL-INPUT-BUFFER",
+/* 0xC4 in fileio */ "FILE-LENGTH",
+/* 0xC5 in fileio */ "FILE-WRITE-CHAR",
+/* 0xC6 in fileio */ "FILE-WRITE-STRING",
+
+/* Primitive names continue on the next page */
+\f
+/* Primitive names, continued */
+
+/* 0xC7 in daemon */ "CLOSE-LOST-OPEN-FILES",
+/* 0xC8 in io */ "PUT-CHARACTER-TO-OUTPUT-CHANNEL",
+/* 0xC9 in hooks */ "WITH-INTERRUPTS-REDUCED",
+/* 0xCA in step */ "PRIMITIVE-EVAL-STEP",
+/* 0xCB in step */ "PRIMITIVE-APPLY-STEP",
+/* 0xCC in step */ "PRIMITIVE-RETURN-STEP",
+/* 0xCD in console */ "TTY-READ-CHAR-READY?",
+/* 0xCE in console */ "TTY-READ-CHAR",
+/* 0xCF in console */ "TTY-READ-CHAR-IMMEDIATE",
+/* 0xD0 in console */ "TTY-READ-FINISH",
+/* 0xD1 in bitstr */ "BIT-STRING-ALLOCATE",
+/* 0xD2 in bitstr */ "MAKE-BIT-STRING",
+/* 0xD3 in bitstr */ "BIT-STRING?",
+/* 0xD4 in bitstr */ "BIT-STRING-LENGTH",
+/* 0xD5 in bitstr */ "BIT-STRING-REF",
+/* 0xD6 in bitstr */ "BIT-SUBSTRING-MOVE-RIGHT!",
+/* 0xD7 in bitstr */ "BIT-STRING-SET!",
+/* 0xD8 in bitstr */ "BIT-STRING-CLEAR!",
+/* 0xD9 in bitstr */ "BIT-STRING-ZERO?",
+/* 0xDA not here */ No_Name,
+/* 0xDB not here */ No_Name,
+/* 0xDC in bitstr */ "UNSIGNED-INTEGER->BIT-STRING",
+/* 0xDD in bitstr */ "BIT-STRING->UNSIGNED-INTEGER",
+/* 0xDE not here */ No_Name,
+/* 0xDF in bitstr */ "READ-BITS!",
+/* 0xE0 in bitstr */ "WRITE-BITS!",
+/* 0xE1 in hooks */ "MAKE-STATE-SPACE",
+/* 0xE2 in hooks */ "EXECUTE-AT-NEW-POINT",
+/* 0xE3 in hooks */ "TRANSLATE-TO-POINT",
+/* 0xE4 in gcloop */ "GET-NEXT-CONSTANT",
+
+/* Primitive names continue on the next page */
+\f
+/* Primitive names, continued */
+
+/* 0xE5 in boot */ "MICROCODE-IDENTIFY",
+/* 0xE6 in generic */ "ZERO?",
+/* 0xE7 in generic */ "POSITIVE?",
+/* 0xE8 in generic */ "NEGATIVE?",
+/* 0xE9 in generic */ "&=",
+/* 0xEA in generic */ "&<",
+/* 0xEB in generic */ "&>",
+/* 0xEC in generic */ "&+",
+/* 0xED in generic */ "&-",
+/* 0xEE in generic */ "&*",
+/* 0xEF in generic */ "&/",
+/* 0xF0 in generic */ "INTEGER-DIVIDE",
+/* 0xF1 in generic */ "1+",
+/* 0xF2 in generic */ "-1+",
+/* 0xF3 in generic */ "TRUNCATE",
+/* 0xF4 in generic */ "ROUND",
+/* 0xF5 in generic */ "FLOOR",
+/* 0xF6 in generic */ "CEILING",
+/* 0xF7 in generic */ "SQRT",
+/* 0xF8 in generic */ "EXP",
+/* 0xF9 in generic */ "LOG",
+/* 0xFA in generic */ "SIN",
+/* 0xFB in generic */ "COS",
+/* 0xFC in generic */ "&ATAN",
+/* 0xFD in console */ "TTY-WRITE-CHAR",
+/* 0xFE in console */ "TTY-WRITE-STRING",
+/* 0xFF in console */ "TTY-BEEP",
+/* 0x100 in console */ "TTY-CLEAR",
+/* 0x101 in extern */ "GET-EXTERNAL-COUNTS",
+/* 0x102 in extern */ "GET-EXTERNAL-NAME",
+/* 0x103 in extern */ "GET-EXTERNAL-NUMBER",
+/* 0x104 not here */ No_Name,
+/* 0x105 not here */ No_Name,
+/* 0x106 in sysprim */ "GET-NEXT-INTERRUPT-CHARACTER",
+/* 0x107 in sysprim */ "CHECK-AND-CLEAN-UP-INPUT-CHANNEL",
+/* 0x108 not here */ No_Name,
+/* 0x109 in sysprim */ "SYSTEM-CLOCK",
+/* 0x10A in fileio */ "FILE-EXISTS?",
+/* 0x10B not here */ No_Name,
+/* 0x10C in ttyio */ "TTY-MOVE-CURSOR",
+/* 0x10D not here */ No_Name,
+/* 0x10E in nihil */ "CURRENT-DATE",
+/* 0x10F in nihil */ "CURRENT-TIME",
+/* 0x110 in nihil */ "TRANSLATE-FILE",
+/* 0x111 in fileio */ "COPY-FILE",
+/* 0x112 in fileio */ "RENAME-FILE",
+/* 0x113 in fileio */ "REMOVE-FILE",
+/* 0x114 in fileio */ "LINK-FILE",
+/* 0x115 in fileio */ "MAKE-DIRECTORY",
+/* 0x116 in nihil */ "VOLUME-NAME",
+/* 0x117 in fileio */ "SET-WORKING-DIRECTORY-PATHNAME!",
+/* 0x118 in nihil */ "OPEN-CATALOG",
+/* 0x119 in nihil */ "CLOSE-CATALOG",
+/* 0x11A in nihil */ "NEXT-FILE",
+/* 0x11B in nihil */ "CAT-NAME",
+/* 0x11C in nihil */ "CAT-KIND",
+/* 0x11D in nihil */ "CAT-PSIZE",
+/* 0x11E in nihil */ "CAT-LSIZE",
+/* 0x11F in nihil */ "CAT-INFO",
+/* 0x120 in nihil */ "CAT-BLOCK",
+/* 0x121 in nihil */ "CAT-CREATE-DATE",
+/* 0x122 in nihil */ "CAT-CREATE-TIME",
+/* 0x123 in nihil */ "CAT-LAST-DATE",
+/* 0x124 in nihil */ "CAT-LAST-TIME",
+/* 0x125 in nihil */ "ERROR-MESSAGE",
+/* 0x126 in sysprim */ "CURRENT-YEAR",
+/* 0x127 in sysprim */ "CURRENT-MONTH",
+/* 0x128 in sysprim */ "CURRENT-DAY",
+/* 0x129 in sysprim */ "CURRENT-HOUR",
+/* 0x12A in sysprim */ "CURRENT-MINUTE",
+/* 0x12B in sysprim */ "CURRENT-SECOND",
+/* 0x12C in nihil */ "INIT-FLOPPY",
+/* 0x12D in nihil */ "ZERO-FLOPPY",
+/* 0x12E in nihil */ "PACK-VOLUME",
+/* 0x12F in nihil */ "LOAD-PICTURE",
+/* 0x130 in nihil */ "STORE-PICTURE",
+/* 0x131 in nihil */ "LOOKUP-SYSTEM-SYMBOL",
+
+/* Unix specialized primitives start here */
+
+/* 0x132 not here */ No_Name,
+/* 0x133 not here */ No_Name,
+/* 0x134 in ttyio */ "CLEAR-TO-END-OF-LINE",
+/* 0x135 not here */ No_Name,
+/* 0x136 not here */ No_Name,
+/* 0x137 in hooks */ "WITH-INTERRUPT-MASK",
+
+/* 0x138 in stringprim */ "STRING?",
+/* 0x139 in stringprim */ "STRING-LENGTH",
+/* 0x13A in stringprim */ "STRING-REF",
+/* 0x13B in stringprim */ "STRING-SET!",
+/* 0x13C in stringprim */ "SUBSTRING-MOVE-RIGHT!",
+/* 0x13D in stringprim */ "SUBSTRING-MOVE-LEFT!",
+/* 0x13E in stringprim */ "STRING-ALLOCATE",
+/* 0x13F in stringprim */ "STRING-MAXIMUM-LENGTH",
+/* 0x140 in stringprim */ "SET-STRING-LENGTH!",
+/* 0x141 in stringprim */ "VECTOR-8B-FILL!",
+/* 0x142 in stringprim */ "VECTOR-8B-FIND-NEXT-CHAR",
+/* 0x143 in stringprim */ "VECTOR-8B-FIND-PREVIOUS-CHAR",
+/* 0x144 in stringprim */ "VECTOR-8B-FIND-NEXT-CHAR-CI",
+/* 0x145 in stringprim */ "VECTOR-8B-FIND-PREVIOUS-CHAR-CI",
+/* 0x146 in stringprim */ "SUBSTRING-FIND-NEXT-CHAR-IN-SET",
+/* 0x147 in stringprim */ "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET",
+/* 0x148 in stringprim */ "SUBSTRING=?",
+/* 0x149 in stringprim */ "SUBSTRING-CI=?",
+/* 0x14A in stringprim */ "SUBSTRING<?",
+/* 0x14B in stringprim */ "SUBSTRING-UPCASE!",
+/* 0x14C in stringprim */ "SUBSTRING-DOWNCASE!",
+/* 0x14D in stringprim */ "SUBSTRING-MATCH-FORWARD",
+/* 0x14E in stringprim */ "SUBSTRING-MATCH-BACKWARD",
+/* 0x14F in stringprim */ "SUBSTRING-MATCH-FORWARD-CI",
+/* 0x150 in stringprim */ "SUBSTRING-MATCH-BACKWARD-CI",
+/* 0x151 in fileio */ "PHOTO-OPEN",
+/* 0x152 in fileio */ "PHOTO-CLOSE",
+/* 0x153 in sysprim */ "SETUP-TIMER-INTERRUPT",
+/* 0x154 in nihil */ No_Name,
+/* 0x155 in nihil */ No_Name,
+/* 0x156 in nihil */ No_Name,
+/* 0x157 in nihil */ No_Name,
+/* 0x158 in nihil */ No_Name,
+/* 0x159 in nihil */ No_Name,
+/* 0x15A in nihil */ No_Name,
+/* 0x15B in nihil */ No_Name,
+/* 0x15C in nihil */ No_Name,
+/* 0x15D in nihil */ No_Name,
+/* 0x15E in nihil */ No_Name,
+/* 0x15F in nihil */ No_Name,
+/* 0x160 in nihil */ No_Name,
+/* 0x161 in nihil */ "EXTRACT-NON-MARKED-VECTOR",
+/* 0x162 in nihil */ "UNSNAP-LINKS!",
+/* 0x163 in nihil */ "SAFE-PRIMITIVE?",
+/* 0x164 in nihil */ "SUBSTRING-READ",
+/* 0x165 in nihil */ "SUBSTRING-WRITE",
+/* 0x166 in ttyio */ "SCREEN-X-SIZE",
+/* 0x167 in ttyio */ "SCREEN-Y-SIZE",
+/* 0x168 in nihil */ "SCREEN-WRITE-CURSOR",
+/* 0x169 in nihil */ "SCREEN-WRITE-CHARACTER",
+/* 0x16A in nihil */ "SCREEN-WRITE-SUBSTRING",
+/* 0x16B in nihil */ "NEXT-FILE-MATCHING",
+/* 0x16C in nihil */ No_Name,
+/* 0x16D in nihil */ "TTY-WRITE-BYTE",
+/* 0x16E in nihil */ "FILE-READ-BYTE",
+/* 0x16F in nihil */ "FILE-WRITE-BYTE",
+/* 0x170 not here */ No_Name, /* "SAVE-SCREEN", */
+/* 0x171 not here */ No_Name, /* "RESTORE-SCREEN!", */
+/* 0x172 not here */ No_Name, /* "SUBSCREEN-CLEAR!", */
+/* 0x173 not here */ No_Name, /* "&GCD", */
+/* 0x174 not here */ No_Name, /* "TTY-REDRAW-SCREEN", */
+/* 0x175 not here */ No_Name, /* "SCREEN-INVERSE-VIDEO", */
+/* 0x176 in nihil */ "STRING->SYNTAX-ENTRY",
+/* 0x177 in scanprim */ "SCAN-WORD-FORWARD",
+/* 0x178 in scanprim */ "SCAN-WORD-BACKWARD",
+/* 0x179 in scanprim */ "SCAN-LIST-FORWARD",
+/* 0x17A in scanprim */ "SCAN-LIST-BACKWARD",
+/* 0x17B in scanprim */ "SCAN-SEXPS-FORWARD",
+/* 0x17C in scanprim */ "SCAN-FORWARD-TO-WORD",
+/* 0x17D in scanprim */ "SCAN-BACKWARD-PREFIX-CHARS",
+/* 0x17E in scanprim */ "CHAR->SYNTAX-CODE",
+/* 0x17F in scanprim */ "QUOTED-CHAR?",
+/* 0x180 in boot */ "MICROCODE-TABLES-FILENAME",
+/* 0x181 not here */ No_Name,
+/* 0x182 not here */ No_Name, /* "FIND-PASCAL-PROGRAM", */
+/* 0x183 not here */ No_Name, /* "EXECUTE-PASCAL-PROGRAM", */
+/* 0x184 not here */ No_Name, /* "GRAPHICS-MOVE", */
+/* 0x185 not here */ No_Name, /* "GRAPHICS-LINE", */
+/* 0x186 not here */ No_Name, /* "GRAPHICS-PIXEL", */
+/* 0x187 not here */ No_Name, /* "GRAPHICS-SET-DRAWING-MODE", */
+/* 0x188 not here */ No_Name, /* "ALPHA-RASTER?", */
+/* 0x189 not here */ No_Name, /* "TOGGLE-ALPHA-RASTER", */
+/* 0x18A not here */ No_Name, /* "GRAPHICS-RASTER?", */
+/* 0x18B not here */ No_Name, /* "TOGGLE-GRAPHICS-RASTER", */
+/* 0x18C not here */ No_Name, /* "GRAPHICS-CLEAR", */
+/* 0x18D not here */ No_Name, /* "GRAPHICS-SET-LINE-STYLE", */
+/* 0x18E in hooks */ "ERROR-PROCEDURE",
+/* 0x18F in nihil */ "VOLUME-EXISTS?",
+/* 0x190 in nihil */ "RE-CHAR-SET-ADJOIN!",
+/* 0x191 in nihil */ "RE-COMPILE-FASTMAP",
+/* 0x192 in nihil */ "RE-MATCH",
+/* 0x193 in nihil */ "RE-SEARCH-FORWARD",
+/* 0x194 in nihil */ "RE-SEARCH-BACKWARD",
+/* 0x195 in nihil */ "SYSTEM-MEMORY-REF",
+/* 0x196 in nihil */ "SYSTEM-MEMORY-SET!",
+/* 0x197 in bitstr */ "BIT-STRING-FILL!",
+/* 0x198 in bitstr */ "BIT-STRING-MOVE!",
+/* 0x199 in bitstr */ "BIT-STRING-MOVEC!",
+/* 0x19A in bitstr */ "BIT-STRING-OR!",
+/* 0x19B in bitstr */ "BIT-STRING-AND!",
+/* 0x19C in bitstr */ "BIT-STRING-ANDC!",
+/* 0x19D in bitstr */ "BIT-STRING=?",
+/* 0x19E in fileio */ "WORKING-DIRECTORY-PATHNAME",
+/* 0x19F in fileio */ "OPEN-DIRECTORY",
+/* 0x1A0 in fileio */ "DIRECTORY-READ",
+/* 0x1A1 in sysprim */ "UNDER-EMACS?"
+};
+
+#if (MAX_PRIMITIVE_NUMBER != 0x1A1)
+/* Cause an error */
+#include "Error: prims.h and storage.c are inconsistent -- Names Table"
+#endif
+
+/* After passing all above checks */
+
+long MAX_PRIMITIVE = MAX_PRIMITIVE_NUMBER;
+\f
+char *Return_Names[] = {
+/* 0x00 */ "END_OF_COMPUTATION",
+/* 0x01 */ "JOIN_STACKLETS",
+/* 0x02 */ "RESTORE_CONTINUATION",
+/* 0x03 */ "INTERNAL_APPLY",
+/* 0x04 */ "BAD_INTERRUPT_CONTINUE",
+/* 0x05 */ "RESTORE_HISTORY",
+/* 0x06 */ "INVOKE_STACK_THREAD",
+/* 0x07 */ "RESTART_EXECUTION",
+/* 0x08 */ "EXECUTE_ASSIGNMENT_FINISH",
+/* 0x09 */ "EXECUTE_DEFINITION_FINISH",
+/* 0x0A */ "EXECUTE_ACCESS_FINISH",
+/* 0x0b */ "EXECUTE_IN_PACKAGE_CONTINUE",
+/* 0x0C */ "SEQ_2_DO_2",
+/* 0x0d */ "SEQ_3_DO_2",
+/* 0x0E */ "SEQ_3_DO_3",
+/* 0x0f */ "CONDITIONAL_DECIDE",
+/* 0x10 */ "DISJUNCTION_DECIDE",
+/* 0x11 */ "COMB_1_PROCEDURE",
+/* 0x12 */ "COMB_APPLY_FUNCTION",
+/* 0x13 */ "COMB_2_FIRST_OPERAND",
+/* 0x14 */ "COMB_2_PROCEDURE",
+/* 0x15 */ "COMB_SAVE_VALUE",
+/* 0x16 */ "PCOMB1_APPLY",
+/* 0x17 */ "PCOMB2_DO_1",
+/* 0x18 */ "PCOMB2_APPLY",
+/* 0x19 */ "PCOMB3_DO_2",
+/* 0x1A */ "PCOMB3_DO_1",
+/* 0x1B */ "PCOMB3_APPLY",
+/* 0x1C */ "SNAP_NEED_THUNK",
+/* 0x1D */ No_Name,
+/* 0x1E */ No_Name,
+/* 0x1F */ No_Name,
+/* 0x20 */ "NORMAL_GC_DONE",
+/* 0x21 */ "COMPLETE_GC_DONE",
+/* 0x22 */ "PURIFY_GC_1",
+/* 0x23 */ "PURIFY_GC_2",
+/* 0x24 */ "AFTER_MEMORY_UPDATE",
+/* 0x25 */ "RESTARTABLE_EXIT",
+/* 0x26 */ No_Name,
+/* 0x27 */ No_Name,
+\f
+/* 0x28 */ No_Name,
+/* 0x29 */ No_Name,
+/* 0x2A */ "RETURN_TRAP_POINT",
+/* 0x2B */ "RESTORE_STEPPER",
+/* 0x2C */ "RESTORE_TO_STATE_POINT",
+/* 0x2D */ "MOVE_TO_ADJACENT_POINT",
+/* 0x2E */ "RESTORE_VALUE",
+/* 0x2F */ "RESTORE_DONT_COPY_HISTORY",
+/* 0x30 */ No_Name,
+/* 0x31 */ No_Name,
+/* 0x32 */ No_Name,
+/* 0x33 */ No_Name,
+/* 0x34 */ No_Name,
+/* 0x35 */ No_Name,
+/* 0x36 */ No_Name,
+/* 0x37 */ No_Name,
+/* 0x38 */ No_Name,
+/* 0x39 */ No_Name,
+/* 0x3A */ No_Name,
+/* 0x3B */ No_Name,
+/* 0x3C */ No_Name,
+/* 0x3D */ No_Name,
+/* 0x3E */ No_Name,
+/* 0x3F */ No_Name,
+/* 0x40 */ "POP_RETURN_ERROR",
+/* 0x41 */ "EVAL_ERROR",
+/* 0x42 */ "REPEAT_PRIMITIVE",
+/* 0x43 */ "COMPILER_INTERRUPT_RESTART",
+/* 0x44 */ No_Name,
+/* 0x45 */ "RESTORE_INT_MASK",
+/* 0x46 */ "HALT",
+/* 0x47 */ "FINISH_GLOBAL_INT",
+/* 0x48 */ "REPEAT_DISPATCH",
+/* 0x49 */ "GC_CHECK",
+/* 0x4A */ "RESTORE_FLUIDS",
+/* 0x4B */ "COMPILER_LOOKUP_APPLY_RESTART",
+/* 0x4C */ "COMPILER_ACCESS_RESTART",
+/* 0x4D */ "COMPILER_UNASSIGNED_P_RESTART",
+/* 0x4E */ "COMPILER_UNBOUND_P_RESTART",
+/* 0x4F */ "COMPILER_DEFINITION_RESTART",
+/* 0x50 */ "COMPILER_LEXPR_GC_RESTART"
+};
+
+#if (MAX_RETURN_CODE != 0x50)
+/* Cause an error */
+#include "Returns.h and storage.c are inconsistent -- Names Table"
+#endif
+
+long MAX_RETURN = MAX_RETURN_CODE;
--- /dev/null
+/* Emacs -*-C-*-an't tell the language */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: STRINGPRIM.C
+ *
+ * String primitives.
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+#include "character.h"
+#include "stringprim.h"
+\f
+/* The first 6 primitives are in RRRS:
+1. STRING?
+2. STRING-LENGTH
+3. STRING-REF
+4. STRING-SET
+5. SUBSTRING-MOVE-RIGHT!
+6. SUBSTRING-MOVE-LEFT!
+*/
+
+Built_In_Primitive(Prim_String_P, 1, "STRING?")
+{ Primitive_1_Args();
+ if (Type_Code(Arg1) != (TC_CHARACTER_STRING)) return NIL;
+ else return TRUTH;
+}
+
+Built_In_Primitive(Prim_String_Length, 1, "STRING-LENGTH")
+{ Primitive_1_Args();
+ Arg_1_Type(TC_CHARACTER_STRING);
+ return Make_Unsigned_Fixnum(String_Length(Arg1));
+}
+
+Built_In_Primitive(Prim_String_Ref, 2, "STRING-REF")
+{ long index;
+ char *first;
+ Primitive_2_Args();
+
+ Arg_1_Type(TC_CHARACTER_STRING);
+ Arg_2_Type(TC_FIXNUM);
+ MY_Range_Check(index, Arg2,
+ BEGINNING, String_Length(Arg1),
+ ERR_ARG_2_BAD_RANGE);
+
+ first = (char *) String_Index(Arg1, index);
+ return (c_char_to_scheme_char( *first));
+}
+
+Built_In_Primitive(Prim_String_Set, 3, "STRING-SET!")
+{ long index, ascii;
+ Pointer Result;
+ char *first;
+ Primitive_3_Args();
+
+ Arg_1_Type(TC_CHARACTER_STRING);
+ Arg_2_Type(TC_FIXNUM);
+ Arg_3_Type(TC_CHARACTER);
+ MY_Range_Check(index, Arg2,
+ BEGINNING, String_Length(Arg1),
+ ERR_ARG_2_BAD_RANGE);
+
+ ascii = scheme_char_to_c_char( Arg3);
+ if (ascii == NOT_ASCII) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+ first = (char *) String_Index(Arg1, index);
+ Result = c_char_to_scheme_char( *first);
+ *first = ascii;
+ return (Result);
+}
+\f
+Built_In_Primitive(Prim_Substring_Move_Right, 5, "SUBSTRING-MOVE-RIGHT!")
+{ long diff, start, end, length;
+ char *first, *second, *firststart;
+ Primitive_5_Args();
+
+ Arg_4_Type(TC_CHARACTER_STRING);
+ Arg_5_Type(TC_FIXNUM);
+ Check_Substring_Args();
+ diff = end - start;
+ Check_Substring_Index(Arg4, Arg5, SUM_ARG_AND_INTEGER(Arg5, diff),
+ ERR_ARG_5_BAD_RANGE, ERR_ARG_3_BAD_RANGE,
+ second, start, end, length);
+
+ firststart = first + diff;
+ second += diff;
+ while (first < firststart) *--second = *--firststart;
+ return (NIL);
+}
+
+Built_In_Primitive(Prim_Substring_Move_Left, 5, "SUBSTRING-MOVE-LEFT!")
+{ long diff, start, end, length;
+ char *first, *second, *firstend;
+
+ Primitive_5_Args();
+ Arg_4_Type(TC_CHARACTER_STRING);
+ Arg_5_Type(TC_FIXNUM);
+ Check_Substring_Args();
+ diff = end - start;
+ Check_Substring_Index(Arg4, Arg5, SUM_ARG_AND_INTEGER(Arg5, diff),
+ ERR_ARG_5_BAD_RANGE, ERR_ARG_3_BAD_RANGE,
+ second,
+ start, end, length);
+
+ firstend = first + diff;
+ while (first < firstend) *second++ = *first++;
+ return (NIL);
+}
+\f
+/* Eventually the strings used in symbols must be reformatted
+ to be the same as this format. Specifically, they can't have
+ type codes in the length field. */
+
+/* Some length primitives
+1. STRING-ALLOCATE like calling make-string with no character
+ obj
+2. STRING-MAXIMUM-LENGTH returns the max length of a string
+ which is = or > string-length
+3. SET-STRING-LENGTH! changes string from string-length to a
+ length < or = string-max-length.
+*/
+
+Built_In_Primitive(Prim_String_Allocate, 1, "STRING-ALLOCATE")
+{ long length, count;
+ Pointer result;
+
+ Primitive_1_Arg();
+ Arg_1_Type(TC_FIXNUM);
+
+ length = Get_Integer(Arg1);
+ Allocate_String(result, length, count);
+ return result;
+}
+
+Built_In_Primitive(Prim_String_Maximum_Length, 1, "STRING-MAXIMUM-LENGTH")
+{ Primitive_1_Args();
+ Arg_1_Type(TC_CHARACTER_STRING);
+
+ return Make_Unsigned_Fixnum(Max_String_Length(Arg1) - 1);
+} /* -1 for null at end */
+
+Built_In_Primitive(Prim_Set_String_Length, 2, "SET-STRING-LENGTH!")
+{ long length;
+ Pointer Result;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_CHARACTER_STRING);
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(length, Arg2,
+ BEGINNING, (Max_String_Length(Arg1)),
+ ERR_ARG_2_BAD_RANGE);
+
+ Result = Make_Unsigned_Fixnum(String_Length(Arg1));
+ Set_String_Length(Arg1, length);
+ return Result;
+}
+\f
+Built_In_Primitive(Prim_Vector_8b_Ref, 2, "VECTOR-8B-REF")
+{ long index;
+ char *first;
+
+ Primitive_2_Args();
+ Arg_1_Type(TC_CHARACTER_STRING);
+ Arg_2_Type(TC_FIXNUM);
+ MY_Range_Check(index, Arg2,
+ BEGINNING, String_Length(Arg1),
+ ERR_ARG_2_BAD_RANGE);
+
+ first = (char *) String_Index(Arg1, index);
+ return Make_Unsigned_Fixnum(*first);
+}
+
+Built_In_Primitive(Prim_Vector_8b_Set, 3, "VECTOR-8B-SET!")
+{ long index, ascii;
+ Pointer Result;
+ char *first;
+
+ Primitive_3_Args();
+ Arg_1_Type(TC_CHARACTER_STRING);
+ Arg_2_Type(TC_FIXNUM);
+ Arg_3_Type(TC_FIXNUM);
+ MY_Range_Check(index, Arg2,
+ BEGINNING, String_Length(Arg1),
+ ERR_ARG_2_BAD_RANGE);
+ MY_Range_Check(ascii, Arg3,
+ BEGINNING, MAX_ASCII,
+ ERR_ARG_3_BAD_RANGE);
+
+ first = (char *) String_Index(Arg1, index);
+ Result = Make_Unsigned_Fixnum(*first);
+ *first = ascii;
+ return Result;
+}
+
+Built_In_Primitive(Prim_Vector_8b_Fill, 4, "VECTOR-8B-FILL!")
+{ long start, end, ascii, length;
+ char *first, *firstend;
+
+ Primitive_4_Args();
+ Arg_4_Type(TC_FIXNUM);
+ Check_Substring_Args();
+ MY_Range_Check(ascii, Arg4,
+ BEGINNING, MAX_ASCII,
+ ERR_ARG_4_BAD_RANGE);
+
+ firstend = first + end - start;
+ while (first < firstend) *first++ = ascii;
+ return NIL;
+}
+\f
+Built_In_Primitive(Prim_Vector_8b_Find_Next_Char, 4,
+ "VECTOR-8B-FIND-NEXT-CHAR")
+{
+ long start, end, ascii, length;
+ char *first, *firstend;
+
+ Primitive_4_Args();
+ Arg_4_Type(TC_FIXNUM);
+ Check_Substring_Args();
+ MY_Range_Check(ascii, Arg4,
+ BEGINNING, MAX_ASCII,
+ ERR_ARG_4_BAD_RANGE);
+
+ while (start < end)
+ {
+ if (*first++ == ascii)
+ return (Make_Unsigned_Fixnum( start));
+ start += 1;
+ }
+ return (NIL);
+}
+
+Built_In_Primitive(Prim_Vector_8b_Find_Previous_Char, 4,
+ "VECTOR-8B-FIND-PREVIOUS-CHAR")
+{
+ long start, end, ascii, length;
+ char *first, *firststart;
+
+ Primitive_4_Args();
+ Arg_4_Type(TC_FIXNUM);
+ Check_Substring_Args();
+ MY_Range_Check(ascii, Arg4,
+ BEGINNING, MAX_ASCII,
+ ERR_ARG_4_BAD_RANGE);
+
+ first = String_Index( Arg1, end);
+ while (end > start)
+ {
+ end -= 1;
+ if (*--first == ascii)
+ return (Make_Unsigned_Fixnum( end));
+ }
+ return (NIL);
+}
+\f
+Built_In_Primitive(Prim_Vector_8b_Find_Next_Char_Ci, 4,
+ "VECTOR-8B-FIND-NEXT-CHAR-CI")
+{
+ long start, end, ascii, length;
+ char *first, *firstend;
+
+ Primitive_4_Args();
+ Arg_4_Type(TC_FIXNUM);
+ Check_Substring_Args();
+ MY_Range_Check(ascii, Arg4,
+ BEGINNING, MAX_ASCII,
+ ERR_ARG_4_BAD_RANGE);
+
+ ascii = Real_To_Upper( ascii);
+ while (start < end)
+ {
+ if (Real_To_Upper( *first++) == ascii)
+ return (Make_Unsigned_Fixnum( start));
+ start += 1;
+ }
+ return (NIL);
+}
+
+Built_In_Primitive(Prim_Vector_8b_Find_Previous_Char_Ci, 4,
+ "VECTOR-8B-FIND-PREVIOUS-CHAR-CI")
+{
+ long start, end, ascii, length;
+ char *first, *firststart;
+
+ Primitive_4_Args();
+ Arg_4_Type(TC_FIXNUM);
+ Check_Substring_Args();
+ MY_Range_Check(ascii, Arg4,
+ BEGINNING, MAX_ASCII,
+ ERR_ARG_4_BAD_RANGE);
+
+ first = String_Index( Arg1, end);
+ ascii = Real_To_Upper( ascii);
+ while (end > start)
+ {
+ end -= 1;
+ if (Real_To_Upper( *--first) == ascii)
+ return (Make_Unsigned_Fixnum( end));
+ }
+ return (NIL);
+}
+\f
+/* Substring primitives:
+1. SUBSTRING-FIND-NEXT-CHAR-IN-SET
+2. SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET Searches through the specified
+ substring to find the next
+ character in the given char set.
+3. SUBSTRING=?
+4. SUBSTRING-CI=? Comparisons of substrings, done
+5. SUBSTRING<? like the dictionary.
+6. SUBSTRING-UPCASE! Makes each member of the
+7. SUBSTRING-DOWNCASE! substring the specified case.
+8. SUBSTRING-MATCH-FORWARD
+9. SUBSTRING-MATCH-BACKWARD Returns number of characters which
+ did match.
+10. SUBSTRING-MATCH-FORWARD-CI
+11. SUBSTRING-MATCH-BACKWARD-CI Case insensitive of 8 & 9.
+*/
+
+Built_In_Primitive(Prim_Substring_Find_Next_Char_In_Set, 4,
+ "SUBSTRING-FIND-NEXT-CHAR-IN-SET")
+{
+ long length;
+ fast char *first, *char_set;
+ fast long start, end;
+ Primitive_4_Args();
+
+ Check_Substring_Args();
+ Arg_4_Type(TC_CHARACTER_STRING);
+ if (String_Length(Arg4) != MAX_ASCII)
+ Primitive_Error(ERR_ARG_4_BAD_RANGE);
+ char_set = Scheme_String_To_C_String(Arg4);
+
+ while (start < end)
+ {
+ if (char_set[*first++] != '\0')
+ return (Make_Unsigned_Fixnum( start));
+ start += 1;
+ }
+ return (NIL);
+}
+
+Built_In_Primitive(Prim_Substring_Find_Previous_Char_In_Set, 4,
+ "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET")
+{
+ long length;
+ fast char *first, *char_set;
+ fast long start, end;
+ Primitive_4_Args();
+
+ Check_Substring_Args();
+ Arg_4_Type(TC_CHARACTER_STRING);
+ if (String_Length(Arg4) != MAX_ASCII)
+ Primitive_Error(ERR_ARG_4_BAD_RANGE);
+ char_set = Scheme_String_To_C_String(Arg4);
+
+ first = String_Index( Arg1, end);
+ while (end > start)
+ {
+ end -= 1;
+ if (char_set[*--first] != '\0')
+ return (Make_Unsigned_Fixnum( end));
+ }
+ return (NIL);
+}
+\f
+Built_In_Primitive(Prim_Substring_Equal, 6, "SUBSTRING=?")
+{ long start, start_2, end, end_2, j, length, length_2, diff;
+ char *first, *second, *firstend;
+
+ Primitive_6_Args();
+ Check_Substring_Args();
+ Check_Substring_Args_B();
+
+ diff = end - start;
+ firstend = diff + first;
+ if (diff != end_2 - start_2) return (NIL);
+ for (; first < firstend; first++, second++)
+ if (*first != *second) return NIL;
+ return TRUTH;
+}
+
+Built_In_Primitive(Prim_Substring_Ci_Equal, 6, "SUBSTRING-CI=?")
+{ long start, start_2, end, end_2, j, length, length_2, diff;
+ char *first, *second, *firstend;
+
+ Primitive_6_Args();
+ Check_Substring_Args();
+ Check_Substring_Args_B();
+
+ diff = end - start;
+ firstend = first + diff;
+ if (diff != end_2 - start_2) return (NIL);
+ for (; first < firstend; first++, second++)
+ if (Real_To_Upper(*first) != Real_To_Upper(*second))
+ return NIL;
+ return (TRUTH);
+}
+\f
+Built_In_Primitive(Prim_Substring_Less, 6, "SUBSTRING<?")
+{ long start, start_2, end, end_2, j, length, length_2, diff, diff_2;
+ long string_length;
+ char *first, *second, *firstend;
+ Pointer Equal_Answer;
+
+ Primitive_6_Args();
+ Check_Substring_Args();
+ Check_Substring_Args_B();
+
+ diff = end - start;
+ diff_2 = end_2 - start_2;
+ if (diff < diff_2)
+ { string_length = diff;
+ Equal_Answer = TRUTH;
+ }
+ else
+ { string_length = diff_2;
+ Equal_Answer = NIL;
+ }
+ firstend = first + string_length;
+ for (; first < firstend; first++, second++)
+ if (*first > *second) return NIL;
+ else if (*first < *second) return TRUTH;
+ return Equal_Answer;
+}
+
+Built_In_Primitive(Prim_Substring_Upcase, 3, "SUBSTRING-UPCASE!")
+{ long start, end, length;
+ char *first, *firstend;
+
+ Primitive_3_Args();
+ Check_Substring_Args();
+
+ firstend = first + end - start;
+ while (first < firstend) *first++ = Real_To_Upper(*first);
+ return (NIL);
+}
+
+Built_In_Primitive(Prim_Substring_Downcase, 3, "SUBSTRING-DOWNCASE!")
+{ long start, end, length;
+ char *first, *firstend;
+
+ Primitive_3_Args();
+ Check_Substring_Args();
+
+ firstend = first + end - start;
+ while (first < firstend) *first++ = Real_To_Lower(*first);
+ return (NIL);
+}
+\f
+Built_In_Primitive(Prim_Substring_Match_Forward, 6, "SUBSTRING-MATCH-FORWARD")
+{ long start, start_2, end, end_2, length, length_2,
+ diff, diff_2, count, firstend;
+ char *first, *second;
+
+ Primitive_6_Args();
+ Check_Substring_Args();
+ Check_Substring_Args_B();
+
+ diff = end - start;
+ diff_2 = end_2 - start_2;
+ if (diff > diff_2) firstend = diff_2;
+ else firstend = diff;
+ for (count=0; count < firstend; first++, second++, count++)
+ if (*first != *second) return Make_Unsigned_Fixnum(count);
+ return Make_Unsigned_Fixnum(count);
+}
+
+Built_In_Primitive(Prim_Substring_Match_Forward_Ci, 6,
+ "SUBSTRING-MATCH-FORWARD-CI")
+{ long start, start_2, end, end_2, length, length_2,
+ diff, diff_2, firstend, count;
+ char *first, *second;
+
+ Primitive_6_Args();
+ Check_Substring_Args();
+ Check_Substring_Args_B();
+
+ diff = end - start;
+ diff_2 = end_2 - start_2;
+ if (diff > diff_2) firstend = diff_2;
+ else firstend = diff;
+ for (count=0; count < firstend; first++, second++, count++)
+ if (Real_To_Upper(*first) != Real_To_Upper(*second))
+ return Make_Unsigned_Fixnum(count);
+ return Make_Unsigned_Fixnum(count);
+}
+\f
+Built_In_Primitive(Prim_Substring_Match_Backward, 6,
+ "SUBSTRING-MATCH-BACKWARD")
+{ long start, start_2, end, end_2, length, length_2,
+ diff, diff_2, min_length, count;
+ char *first, *second, *firststart;
+
+ Primitive_6_Args();
+ Check_Substring_Args();
+ Check_Substring_Args_B();
+
+ diff = end - start;
+ diff_2 = end_2 - start_2;
+ if (diff > diff_2) min_length = diff_2;
+ else min_length = diff;
+ first += diff - 1;
+ second += diff_2 - 1;
+
+ for (count = 0; count < min_length; first--, second--, count++)
+ if (*first != *second)
+ return Make_Unsigned_Fixnum(count);
+ return Make_Unsigned_Fixnum(count);
+}
+
+Built_In_Primitive(Prim_Substring_Match_Backward_Ci, 6,
+ "SUBSTRING-MATCH-BACKWARD-CI")
+{ long start, start_2, end, end_2, length, length_2,
+ diff, diff_2, min_length, count;
+ char *first, *second, *firststart;
+
+ Primitive_6_Args();
+ Check_Substring_Args();
+ Check_Substring_Args_B();
+
+ diff = end - start;
+ diff_2 = end_2 - start_2;
+ if (diff > diff_2) min_length = diff_2;
+ else min_length = diff;
+ first += diff - 1;
+ second += diff_2 - 1;
+
+ for (count = 0; count < min_length; first--, second--, count++)
+ if (Real_To_Upper(*first) != Real_To_Upper(*second))
+ return Make_Unsigned_Fixnum(count);
+ return Make_Unsigned_Fixnum(count);
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: sysprim.c
+ *
+ * Random system primitives. Most are implemented in terms of
+ * utilities in os.c
+ *
+ */
+#include "scheme.h"
+#include "primitive.h"
+\f
+/* Interrupt primitives */
+
+Built_In_Primitive(Prim_Chk_And_Cln_Input_Channel, 2,
+ "CHECK-AND-CLEAN-UP-INPUT-CHANNEL")
+{ extern Boolean OS_Clean_Interrupt_Channel();
+ Primitive_2_Args();
+
+ return (OS_Clean_Interrupt_Channel(Get_Integer(Arg1),
+ Get_Integer(Arg2)) ?
+ TRUTH : NIL);
+}
+
+Built_In_Primitive(Prim_Get_Next_Interrupt_Char, 0,
+ "GET-NEXT-INTERRUPT-CHARACTER")
+{ int result;
+ extern int OS_Get_Next_Interrupt_Character();
+ Primitive_0_Args();
+
+ result = OS_Get_Next_Interrupt_Character();
+ if (result == -1)
+ { Primitive_Error(ERR_EXTERNAL_RETURN);
+ /*NOTREACHED*/
+ }
+ IntCode &= ~INT_Character;
+ return Make_Unsigned_Fixnum(result);
+}
+\f
+/* Time primitives */
+
+Built_In_Primitive(Prim_System_Clock, 0, "SYSTEM-CLOCK")
+{ Primitive_0_Args();
+ return FIXNUM_0 + System_Clock();
+}
+
+Built_In_Primitive(Prim_Setup_Timer_Interrupt, 2, "SETUP-TIMER-INTERRUPT")
+{ Primitive_2_Args();
+ if ((Arg1 == NIL) && (Arg2==NIL)) Clear_Int_Timer();
+ else
+ { long Days, Centi_Seconds;
+ Arg_1_Type(TC_FIXNUM);
+ Arg_2_Type(TC_FIXNUM);
+ Sign_Extend(Arg1, Days);
+ Sign_Extend(Arg2, Centi_Seconds);
+ Set_Int_Timer(Days, Centi_Seconds);
+ }
+ IntCode &= ~INT_Timer;
+ return NIL;
+}
+\f
+/* Date and current time primitives */
+
+#define Date_Primitive(Prim_Name, OS_Name, S_Name) \
+Built_In_Primitive(Prim_Name, 0, S_Name) \
+{ int result; \
+ extern int OS_Name(); \
+ \
+ result = OS_Name(); \
+ if (result == -1) return NIL; \
+ return Make_Unsigned_Fixnum(result); \
+}
+
+Date_Primitive(Prim_Current_Year, OS_Current_Year, "YEAR");
+Date_Primitive(Prim_Current_Month, OS_Current_Month, "MONTH");
+Date_Primitive(Prim_Current_Day, OS_Current_Day, "DAY");
+Date_Primitive(Prim_Current_Hour, OS_Current_Hour, "HOUR");
+Date_Primitive(Prim_Current_Minute, OS_Current_Minute, "MINUTE");
+Date_Primitive(Prim_Current_Second, OS_Current_Second, "SECOND");
+\f
+/* Truly random primitives */
+
+/* (NON-RESTARTABLE-EXIT)
+ [Primitive number 0x16]
+ Halt SCHEME, with no intention of restarting.
+*/
+
+Built_In_Primitive(Prim_Non_Restartable_Exit, 0, "NON-RESTARTABLE-EXIT")
+{ Primitive_0_Args();
+ Microcode_Termination(TERM_HALT);
+}
+
+Built_In_Primitive(Prim_Restartable_Exit, 0, "RESTARTABLE-EXIT")
+{ extern Boolean Restartable_Exit();
+ Primitive_0_Args();
+
+ Restartable_Exit();
+ return (Restartable_Exit() ? TRUTH : NIL);
+}
+
+/* (SET_RUN_LIGHT OBJECT)
+ [Primitive number 0xC0]
+ On the HP9836, allows the character displayed in the lower
+ right-hand part of the screen to be changed. In CScheme, rings
+ the bell. Used only by GC to indicate that it has started and
+ ended.
+*/
+Built_In_Primitive(Prim_Set_Run_Light, 1, "SET-RUN-LIGHT!")
+{ Primitive_1_Arg();
+#ifdef RUN_LIGHT_IS_BEEP
+ extern void OS_tty_beep();
+
+ OS_tty_beep();
+ OS_Flush_Output_Buffer();
+ return TRUTH;
+#else
+ return NIL;
+#endif
+}
+
+Built_In_Primitive( Prim_under_emacs_p, 0, "UNDER-EMACS?")
+{ extern Boolean OS_Under_Emacs();
+ Primitive_0_Args();
+
+ return (OS_Under_Emacs() ? TRUTH : NIL);
+}
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: TYPES.H
+ *
+ * Type code definitions, numerical order
+ *
+ */
+\f
+#define TC_NULL 0x00
+#define TC_FALSE 0x00
+#define TC_MANIFEST_VECTOR 0x00
+#define GLOBAL_ENV 0x00
+
+#define TC_LIST 0x01
+#define TC_CHARACTER 0x02
+#define TC_SCODE_QUOTE 0x03
+#define TC_PCOMB2 0x04 /* Was 0x44 */
+#define TC_UNINTERNED_SYMBOL 0x05
+#define TC_BIG_FLONUM 0x06
+#define TC_COMBINATION_1 0x07
+#define TC_TRUE 0x08
+#define TC_EXTENDED_PROCEDURE 0x09
+#define TC_VECTOR 0x0A /* Was 0x46 */
+#define TC_RETURN_CODE 0x0B /* Was 0x48 */
+#define TC_COMBINATION_2 0x0C
+#define TC_COMPILED_PROCEDURE 0x0D /* Was 0x49 */
+#define TC_BIG_FIXNUM 0x0E
+#define TC_PROCEDURE 0x0F
+#define TC_PRIMITIVE_EXTERNAL 0x10
+#define TC_DELAY 0x11
+#define TC_ENVIRONMENT 0x12 /* Was 0x4E */
+#define TC_DELAYED 0x13
+#define TC_EXTENDED_LAMBDA 0x14
+#define TC_COMMENT 0x15
+#define TC_NON_MARKED_VECTOR 0x16
+#define TC_LAMBDA 0x17
+#define TC_PRIMITIVE 0x18
+#define TC_SEQUENCE_2 0x19
+\f
+#define TC_FIXNUM 0x1A /* Was 0x50 */
+#define TC_ADDRESS 0x1A
+ /* Notice that TC_FIXNUM and TC_ADDRESS are the same */
+#define TC_PCOMB1 0x1B
+#define TC_CONTROL_POINT 0x1C /* Was 0x56 */
+#define TC_INTERNED_SYMBOL 0x1D
+#define TC_CHARACTER_STRING 0x1E
+#define TC_VECTOR_8B 0x1E
+ /* VECTOR_8B and STRING are the same */
+#define TC_ACCESS 0x1F
+#define TC_EXTENDED_FIXNUM 0x20 /* Not used */
+#define TC_DEFINITION 0x21
+#define TC_BROKEN_HEART 0x22 /* Was 0x58 */
+#define TC_ASSIGNMENT 0x23
+#define TC_HUNK3 0x24
+#define TC_IN_PACKAGE 0x25
+#define TC_COMBINATION 0x26 /* Was 0x5E */
+#define TC_MANIFEST_NM_VECTOR 0x27 /* Was 0x60 */
+#define TC_COMPILED_EXPRESSION 0x28
+#define TC_LEXPR 0x29
+#define TC_PCOMB3 0x2A /* Was 0x66 */
+#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B /* Was 0x68 */
+#define TC_VARIABLE 0x2C
+#define TC_THE_ENVIRONMENT 0x2D /* Was 0x70 */
+#define TC_FUTURE 0x2E
+#define TC_VECTOR_1B 0x2F /* Was 0x76 */
+#define TC_BIT_STRING 0x2F /* Was 0x76 */
+ /* Notice TC_VECTOR_1B and TC_BIT_STRING are the same */
+#define TC_PCOMB0 0x30 /* Was 0x78 */
+#define TC_VECTOR_16B 0x31 /* Was 0x7E */
+#define TC_UNASSIGNED 0x32 /* Was 0x38 */
+#define TC_SEQUENCE_3 0x33 /* Was 0x3C */
+#define TC_CONDITIONAL 0x34
+#define TC_DISJUNCTION 0x35
+#define TC_CELL 0x36
+#define TC_WEAK_CONS 0x37
+#define TC_TRAP 0x38
+#define TC_RETURN_ADDRESS 0x39
+#define TC_COMPILER_LINK 0x3A
+#define TC_STACK_ENVIRONMENT 0x3B
+#define TC_COMPLEX 0x3C
+
+#if defined(MC68020)
+
+#define TC_PEA_INSTRUCTION 0x48
+#define TC_JMP_INSTRUCTION 0x4E
+#define TC_DBF_INSTRUCTION 0x51
+
+#endif
+
+/* If you add a new type, don't forget to update gccode.h and gctype.c */
--- /dev/null
+/* Copyright (C) 1985 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY. No author or distributor
+accepts responsibility to anyone for the consequences of using it
+or for whether it serves any particular purpose or works at all,
+unless he says so in writing. Refer to the GNU Emacs General Public
+License for full details.
+
+Everyone is granted permission to copy, modify and redistribute
+GNU Emacs, but only under the conditions described in the
+GNU Emacs General Public License. A copy of this license is
+supposed to have been given to you along with GNU Emacs so you
+can know your rights and responsibilities. It should be in a
+file named COPYING. Among other things, the copyright notice
+and this notice must be preserved on all copies. */
+
+
+/*
+ * unexec.c - Convert a running program into an a.out file.
+ *
+ * Author: Spencer W. Thomas
+ * Computer Science Dept.
+ * University of Utah
+ * Date: Tue Mar 2 1982
+ * Modified heavily since then.
+ *
+ * Synopsis:
+ * unexec (new_name, a_name, data_start, bss_start, entry_address)
+ * char *new_name, *a_name;
+ * unsigned data_start, bss_start, entry_address;
+ *
+ * Takes a snapshot of the program and makes an a.out format file in the
+ * file named by the string argument new_name.
+ * If a_name is non-NULL, the symbol table will be taken from the given file.
+ *
+ * The boundaries within the a.out file may be adjusted with the data_start
+ * and bss_start arguments. Either or both may be given as 0 for defaults.
+ *
+ * Data_start gives the boundary between the text segment and the data
+ * segment of the program. The text segment can contain shared, read-only
+ * program code and literal data, while the data segment is always unshared
+ * and unprotected. Data_start gives the lowest unprotected address. Since
+ * the granularity of write-protection is on 1k page boundaries on the VAX, a
+ * given data_start value which is not on a page boundary is rounded down to
+ * the beginning of the page it is on. The default when 0 is given leaves the
+ * number of protected pages the same as it was before.
+ *
+ * Bss_start indicates how much of the data segment is to be saved in the
+ * a.out file and restored when the program is executed. It gives the lowest
+ * unsaved address, and is rounded up to a page boundary. The default when 0
+ * is given assumes that the entire data segment is to be stored, including
+ * the previous data and bss as well as any additional storage allocated with
+ * break (2).
+ *
+ * The new file is set up to start at entry_address.
+ *
+ * If you make improvements I'd like to get them too.
+ * harpo!utah-cs!thomas, thomas@Utah-20
+ *
+ */
+
+#ifdef emacs
+#include "config.h"
+#define has_error
+#endif
+
+#ifndef has_error
+#define PERROR(arg) perror (arg); return -1
+#else
+#define PERROR(file) report_error (file, new)
+#endif
+
+#ifndef CANNOT_DUMP /* all rest of file! */
+
+#include <sys/param.h>
+#ifndef makedev /* Try to detect types.h already loaded */
+#include <sys/types.h>
+#endif
+#include <stdio.h>
+#include <sys/stat.h>
+#include <errno.h>
+
+extern char *start_of_text (); /* Start of text */
+extern char *start_of_data (); /* Start of initialized data */
+
+#ifdef COFF
+#include <filehdr.h>
+#include <aouthdr.h>
+#include <scnhdr.h>
+static long block_copy_start; /* Old executable start point */
+static struct filehdr f_hdr; /* File header */
+static struct aouthdr f_ohdr; /* Optional file header (a.out) */
+#define SYMS_START block_copy_start
+
+static int text_scnptr;
+
+#else /* not COFF */
+
+extern char *sbrk ();
+
+#include <a.out.h>
+#define SYMS_START ((long) N_SYMOFF (ohdr))
+
+#ifdef HPUX
+#ifdef hp9000s200
+#define MY_ID HP9000S200_ID
+#else
+#include <model.h>
+#define MY_ID MYSYS
+#endif /* not hp9000s200 */
+static MAGIC OLDMAGIC = {MY_ID, SHARE_MAGIC};
+static MAGIC NEWMAGIC = {MY_ID, DEMAND_MAGIC};
+#define N_TXTOFF(x) TEXT_OFFSET(x)
+#define N_SYMOFF(x) LESYM_OFFSET(x)
+static struct exec hdr, ohdr;
+
+#else /* not HPUX */
+
+#ifdef USG
+static struct bhdr hdr, ohdr;
+#define a_magic fmagic
+#define a_text tsize
+#define a_data dsize
+#define a_bss bsize
+#define a_syms ssize
+#define a_trsize rtsize
+#define a_drsize rdsize
+#define a_entry entry
+#define N_BADMAG(x) \
+ (((x).fmagic)!=OMAGIC && ((x).fmagic)!=NMAGIC &&\
+ ((x).fmagic)!=FMAGIC && ((x).fmagic)!=IMAGIC)
+#define NEWMAGIC FMAGIC
+#else /* not USG */
+static struct exec hdr, ohdr;
+#define NEWMAGIC ZMAGIC
+#endif /* not USG */
+#endif /* not HPUX */
+
+#endif /* not COFF */
+
+static int pagemask;
+
+#if defined (BSD4_1) || defined (USG)
+#ifdef EXEC_PAGESIZE
+#define getpagesize() EXEC_PAGESIZE
+#else
+#ifdef NBPG
+#define getpagesize() NBPG * CLSIZE
+#ifndef CLSIZE
+#define CLSIZE 1
+#endif /* no CLSIZE */
+#else /* no NBPG */
+#define getpagesize() NBPC
+#endif /* no NBPG */
+#endif /* no EXEC_PAGESIZE */
+#endif /* BSD4_1 or USG */
+
+/* Correct an int which is the bit pattern of a pointer to a byte
+ into an int which is the number of a byte.
+ This is a no-op on ordinary machines, but not on all. */
+
+#ifndef ADDR_CORRECT /* Let m-*.h files override this definition */
+#define ADDR_CORRECT(x) (((char *)(x)) - ((char *) 0))
+#endif
+
+#ifdef has_error
+
+static
+report_error (file, fd)
+ char *file;
+ int fd;
+{
+ if (fd)
+ close (fd);
+ error ("Failure operating on %s", file);
+}
+#endif /* has_error */
+
+#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1
+#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1
+#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1
+
+static
+report_error_1 (fd, msg, a1, a2)
+ int fd;
+ char *msg;
+ int a1, a2;
+{
+ close (fd);
+#ifdef has_error
+ error (msg, a1, a2);
+#else
+ fprintf (stderr, msg, a1, a2);
+ fprintf (stderr, "\n");
+#endif
+}
+\f
+/* ****************************************************************
+ * unexec
+ *
+ * driving logic.
+ */
+unexec (new_name, a_name, data_start, bss_start, entry_address)
+ char *new_name, *a_name;
+ unsigned data_start, bss_start, entry_address;
+{
+ int new, a_out = -1;
+
+ if (a_name && (a_out = open (a_name, 0)) < 0)
+ {
+ PERROR (a_name);
+ }
+ if ((new = creat (new_name, 0666)) < 0)
+ {
+ PERROR (new_name);
+ }
+ if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0
+ || copy_text_and_data (new) < 0
+ || copy_sym (new, a_out, a_name, new_name) < 0
+#ifdef COFF
+ || adjust_lnnoptrs (new) < 0
+#endif
+ )
+ {
+ close (new);
+ /* unlink (new_name); /* Failed, unlink new a.out */
+ return -1;
+ }
+
+ close (new);
+ if (a_out >= 0)
+ close (a_out);
+ mark_x (new_name);
+ return 0;
+}
+
+/* ****************************************************************
+ * make_hdr
+ *
+ * Make the header in the new a.out from the header in core.
+ * Modify the text and data sizes.
+ */
+static int
+make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name)
+ int new, a_out;
+ unsigned data_start, bss_start, entry_address;
+ char *a_name;
+ char *new_name;
+{
+#ifdef COFF
+ auto struct scnhdr f_thdr; /* Text section header */
+ auto struct scnhdr f_dhdr; /* Data section header */
+ auto struct scnhdr f_bhdr; /* Bss section header */
+ auto struct scnhdr scntemp; /* Temporary section header */
+ register int scns;
+ register long bias; /* Bias to add for growth */
+
+ /* Salvage as much info from the existing file as possible */
+ if (a_out >= 0)
+ {
+ if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr))
+ {
+ PERROR (a_name);
+ }
+ block_copy_start += sizeof (f_hdr);
+ if (f_hdr.f_opthdr > 0)
+ {
+ if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr))
+ {
+ PERROR (a_name);
+ }
+ block_copy_start += sizeof (f_ohdr);
+ }
+ /* Loop through section headers, copying them in */
+ for (scns = f_hdr.f_nscns; scns > 0; scns--) {
+ if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
+ {
+ PERROR (a_name);
+ }
+ block_copy_start += sizeof (scntemp);
+ if (scntemp.s_scnptr > 0L)
+ {
+ block_copy_start += scntemp.s_size;
+ }
+ if (strcmp (scntemp.s_name, ".text") == 0)
+ {
+ f_thdr = scntemp;
+ }
+ else if (strcmp (scntemp.s_name, ".data") == 0)
+ {
+ f_dhdr = scntemp;
+ }
+ else if (strcmp (scntemp.s_name, ".bss") == 0)
+ {
+ f_bhdr = scntemp;
+ }
+ }
+ }
+ else
+ {
+ ERROR0 ("can't build a COFF file from scratch yet");
+ }
+
+ pagemask = getpagesize () - 1;
+
+ if (!data_start)
+ data_start = (int) start_of_data ();
+ data_start = ADDR_CORRECT (data_start);
+ data_start = data_start & ~pagemask; /* down to a page boundary */
+
+ f_hdr.f_flags |= (F_RELFLG | F_EXEC);
+#ifdef EXEC_MAGIC
+ f_ohdr.magic = EXEC_MAGIC;
+#endif
+ f_ohdr.text_start = (long) start_of_text ();
+ f_ohdr.tsize = data_start - f_ohdr.text_start;
+ f_ohdr.data_start = data_start;
+ f_ohdr.dsize = (long) sbrk (0) - f_ohdr.data_start;
+ f_ohdr.bsize = 0;
+ f_thdr.s_size = f_ohdr.tsize;
+ f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr);
+ f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr));
+ f_thdr.s_scnptr = (f_thdr.s_scnptr + pagemask) & ~pagemask; /* round up */
+ text_scnptr = f_thdr.s_scnptr;
+ f_dhdr.s_paddr = f_ohdr.data_start;
+ f_dhdr.s_vaddr = f_ohdr.data_start;
+ f_dhdr.s_size = f_ohdr.dsize;
+ f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size;
+ f_dhdr.s_scnptr &= ~pagemask; /* round down to page boundary */
+ f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize;
+ f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize;
+ f_bhdr.s_size = f_ohdr.bsize;
+ f_bhdr.s_scnptr = 0L;
+ bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start;
+
+ if (f_hdr.f_symptr > 0L)
+ {
+ f_hdr.f_symptr += bias;
+ }
+
+ if (f_thdr.s_lnnoptr > 0L)
+ {
+ f_thdr.s_lnnoptr += bias;
+ }
+
+ if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr))
+ {
+ PERROR (new_name);
+ }
+
+ if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr))
+ {
+ PERROR (new_name);
+ }
+
+ if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr))
+ {
+ PERROR (new_name);
+ }
+
+ if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr))
+ {
+ PERROR (new_name);
+ }
+
+ if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr))
+ {
+ PERROR (new_name);
+ }
+ return (0);
+
+#else /* if not COFF */
+
+ /* Get symbol table info from header of a.out file if given one. */
+ if (a_out >= 0)
+ {
+ if (read (a_out, &ohdr, sizeof hdr) != sizeof hdr)
+ {
+ PERROR (a_name);
+ }
+
+ if N_BADMAG (ohdr)
+ {
+ ERROR1 ("invalid magic number in %s", a_name);
+ }
+#ifdef celerity
+ hdr.a_scovrfl = ohdr.a_scovrfl;
+#endif
+#ifdef HPUX
+ hdr.a_lesyms = ohdr.a_lesyms;
+ hdr.a_sltsize = ohdr.a_sltsize;
+ hdr.a_dnttsize = ohdr.a_dnttsize;
+ hdr.a_vtsize = ohdr.a_vtsize;
+#else /* not HPUX */
+ hdr.a_syms = ohdr.a_syms;
+#endif /* not HPUX */
+ }
+ else
+ {
+#ifdef celerity
+ hdr.a_scovrfl = 0;
+#endif
+#ifdef HPUX
+ hdr.a_lesyms = 0;
+ hdr.a_sltsize = 0;
+ hdr.a_dnttsize = 0;
+ hdr.a_vtsize = 0;
+#else /* not HPUX */
+ hdr.a_syms = 0; /* No a.out, so no symbol info. */
+#endif /* not HPUX */
+ }
+
+ /* Construct header from user structure. */
+#ifdef HPUX
+ /* (((MAGIC) ohdr.a_magic) == ((MAGIC) OLDMAGIC)) This does not work */
+ hdr.a_magic = ((ohdr.a_magic.file_type == OLDMAGIC.file_type) ?
+ NEWMAGIC : ohdr.a_magic);
+#else /* not HPUX */
+/* hdr.a_magic = NEWMAGIC; */
+ hdr.a_magic = ohdr.a_magic;
+#endif /* not HPUX */
+#ifdef sun3
+ hdr.a_machtype = ohdr.a_machtype;
+#endif /* sun3 */
+ hdr.a_trsize = 0;
+ hdr.a_drsize = 0;
+ hdr.a_entry = entry_address;
+
+ pagemask = getpagesize () - 1;
+
+ /* Adjust data/bss boundary. */
+ if (bss_start != 0)
+ {
+ bss_start = (ADDR_CORRECT (bss_start) + pagemask) & ~pagemask; /* (Up) to page bdry. */
+ if (bss_start > ADDR_CORRECT (sbrk (0)))
+ {
+ ERROR1 ("unexec: Specified bss_start (%u) is past end of program",
+ bss_start);
+ }
+ }
+ else
+ {
+ bss_start = ADDR_CORRECT (sbrk (0));
+ bss_start = (bss_start + pagemask) & ~pagemask;
+ }
+
+ /* Adjust text/data boundary. */
+ if (!data_start)
+ data_start = (int) start_of_data ();
+
+ data_start = ADDR_CORRECT (data_start);
+#ifdef sun
+ data_start = data_start & ~(SEGSIZ - 1); /* (Down) to segment boundary. */
+#else
+ data_start = data_start & ~pagemask; /* (Down) to page boundary. */
+#endif
+
+ if (data_start > bss_start) /* Can't have negative data size. */
+ {
+ ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)",
+ data_start, bss_start);
+ }
+
+ hdr.a_bss = ADDR_CORRECT (sbrk (0)) - bss_start;
+ if (hdr.a_bss < 0)
+ hdr.a_bss = 0;
+ hdr.a_data = bss_start - data_start;
+#if defined(sequent)
+ hdr.a_text = data_start - (long) start_of_text () + sizeof(hdr) + N_ADDRADJ(ohdr);
+#else
+ hdr.a_text = data_start - (long) start_of_text ();
+#endif /* not sequent */
+
+ if (write (new, &hdr, sizeof hdr) != sizeof hdr)
+ {
+ PERROR (new_name);
+ }
+ return 0;
+
+#endif /* not COFF */
+}
+\f
+/* ****************************************************************
+ * copy_text_and_data
+ *
+ * Copy the text and data segments from memory to the new a.out
+ */
+static int
+copy_text_and_data (new)
+ int new;
+{
+ register int nwrite, ret;
+ register char *end;
+ int i;
+ register char *ptr;
+ char buf[80];
+ extern int errno;
+
+#ifdef COFF
+ lseek (new, (long) text_scnptr, 0);
+ ptr = (char *) f_ohdr.text_start;
+ end = ptr + f_ohdr.tsize + f_ohdr.dsize;
+ while (ptr < end)
+ {
+ nwrite = 128;
+ if (nwrite > end - ptr) nwrite = end - ptr;
+ ret = write (new, ptr, nwrite);
+ if (nwrite != ret)
+ {
+ sprintf (buf,
+ "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d",
+ ptr, new, nwrite, ret, errno);
+ PERROR (buf);
+ }
+ ptr += nwrite;
+ }
+ return (0);
+
+#else /* if not COFF */
+
+#if defined(sun3) || defined(sequent)
+ lseek (new, (long) (N_TXTOFF (hdr) + sizeof (hdr)), 0);
+#else
+ lseek (new, (long) N_TXTOFF (hdr), 0);
+#endif
+
+ ptr = start_of_text ();
+ end = ptr + hdr.a_text + hdr.a_data;
+#if defined(sequent)
+ end -= (sizeof(hdr) + N_ADDRADJ(hdr));
+#endif
+ for (i = 0; ptr < end;)
+ {
+ nwrite = 128;
+ if (nwrite > end - ptr) nwrite = end - ptr;
+ ret = write (new, ptr, nwrite);
+ if (ret == -1 && errno == EFAULT)
+ {
+ /* BZS - again, see above about N_TXTOFF on a SUN */
+#if defined(sun3) || defined(sequent)
+ lseek (new, (long) (N_TXTOFF (hdr) + i + nwrite + sizeof (hdr)), 0);
+#else
+ lseek (new, (long) (N_TXTOFF (hdr) + i + nwrite), 0);
+#endif
+ }
+ else if (nwrite != ret)
+ {
+ sprintf (buf,
+ "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d",
+ ptr, new, nwrite, ret, errno);
+ PERROR (buf);
+ }
+ i += nwrite;
+ ptr += nwrite;
+ }
+
+ return 0;
+#endif /* not COFF */
+}
+\f
+/* ****************************************************************
+ * copy_sym
+ *
+ * Copy the relocation information and symbol table from the a.out to the new
+ */
+static int
+copy_sym (new, a_out, a_name, new_name)
+ int new, a_out;
+ char *a_name, *new_name;
+{
+ char page[1024];
+ int n;
+
+ if (a_out < 0)
+ return 0;
+
+#ifdef COFF
+ if (SYMS_START == 0L)
+ return 0;
+#endif /* COFF */
+
+#ifdef sun3
+ /* BZS - I might be covering a sin with this */
+ lseek (new, N_SYMOFF (hdr), 0);
+#else
+ lseek (a_out, SYMS_START, 0); /* Position a.out to symtab. */
+#endif
+ while ((n = read (a_out, page, sizeof page)) > 0)
+ {
+ if (write (new, page, n) != n)
+ {
+ PERROR (new_name);
+ }
+ }
+ if (n < 0)
+ {
+ PERROR (a_name);
+ }
+ return 0;
+}
+\f
+/* ****************************************************************
+ * mark_x
+ *
+ * After succesfully building the new a.out, mark it executable
+ */
+static
+mark_x (name)
+ char *name;
+{
+ struct stat sbuf;
+ int um;
+ int new = 0; /* for PERROR */
+
+ um = umask (777);
+ umask (um);
+ if (stat (name, &sbuf) == -1)
+ {
+ PERROR (name);
+ }
+ sbuf.st_mode |= 0111 & ~um;
+ if (chmod (name, sbuf.st_mode) == -1)
+ PERROR (name);
+}
+\f
+/*
+ * If the COFF file contains a symbol table and a line number section,
+ * then any auxiliary entries that have values for x_lnnoptr must
+ * be adjusted by the amount that the line number section has moved
+ * in the file (bias computed in make_hdr). The #@$%&* designers of
+ * the auxiliary entry structures used the absolute file offsets for
+ * the line number entry rather than an offset from the start of the
+ * line number section!
+ *
+ * When I figure out how to scan through the symbol table and pick out
+ * the auxiliary entries that need adjustment, this routine will
+ * be fixed. As it is now, all such entries are wrong and sdb
+ * will complain. Fred Fish, UniSoft Systems Inc.
+ */
+
+#ifdef COFF
+
+adjust_lnnoptrs (new)
+ int new;
+{
+ return 0;
+}
+
+#endif /* COFF */
+
+#endif /* not CANNOT_DUMP */
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: utils.c
+ *
+ * This file contains a number of utility routines for use
+ * in the Scheme scode interpreter.
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+#include "flonum.h"
+#include "winder.h"
+\f
+/* 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;
+ long Save_Space;
+
+ 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_Interrupt continues on the next page */
+\f
+/* Setup_Interrupt, continued */
+
+Passed_Checks: /* This label may be used in Global_Interrupt_Hook */
+ Stop_History();
+ Save_Space = CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS+3;
+ if (New_Int_Enb+1 == INT_GC) Save_Space += CONTINUATION_SIZE;
+ Will_Push(Save_Space);
+ /* Return from interrupt handler will re-enable interrupts */
+ Store_Return(RC_RESTORE_INT_MASK);
+ Store_Expression(FIXNUM_0 + IntEnb);
+ Save_Cont();
+ if (New_Int_Enb+1 == INT_GC)
+ { Store_Return(RC_GC_CHECK);
+ Store_Expression(FIXNUM_0 + GC_Space_Needed);
+ 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.
+ */
+
+void
+Err_Print(Micro_Error)
+long 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;
+}
+
+void
+Stack_Death()
+{ fprintf(stderr, "\nWill_Push vs. Pushed inconsistency.\n");
+ Microcode_Termination(TERM_BAD_STACK);
+}
+\f
+/* Back_Out_Of_Primitive sets the registers up so that the backout
+ * mechanism in interpret.c will push the primitive number and
+ * an appropriate return code so that the primitive can be
+ * restarted.
+ */
+
+#if (TC_PRIMITIVE == 0) || (TC_PRIMITIVE_EXTERNAL == 0)
+#include "Error: Some primitive type is 0"
+#endif
+
+void
+Back_Out_Of_Primitive()
+{ long nargs;
+
+ /* When primitives are called from compiled code, the type code may
+ * not be in the expression register.
+ */
+
+ if (Safe_Type_Code(Fetch_Expression()) == 0)
+ Store_Expression(Make_Non_Pointer(TC_PRIMITIVE, Fetch_Expression()));
+
+ /* Setup a continuation to return to compiled code if the primitive is
+ * restarted and completes successfully.
+ */
+
+ nargs = N_Args_Primitive(Fetch_Expression());
+ if (Type_Code(Stack_Ref(nargs)) == TC_RETURN_ADDRESS)
+ { Pointer expression = Fetch_Expression();
+ compiler_apply_procedure(nargs);
+ Store_Expression(expression);
+ }
+
+ /* 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;
+}
+\f
+void
+Do_Micro_Error(Err, From_Pop_Return)
+long Err;
+Boolean From_Pop_Return;
+{ Pointer Error_Vector, Handler;
+
+ if (Consistency_Check)
+ { Err_Print(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();
+ }
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+{ int *From = &(local_circle[0]), *To = &(debug_circle[0]), i;
+ for (i=0; i < local_nslots; i++) *To++ = *From++;
+ debug_nslots = local_nslots;
+ debug_slotno = local_slotno;
+}
+#endif
+
+/* Do_Micro_Error continues on the next page. */
+\f
+/* Do_Micro_Error, continued */
+
+ if ((!Valid_Fixed_Obj_Vector()) ||
+ (Type_Code((Error_Vector =
+ Get_Fixed_Obj_Slot(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)
+ { /* This can NOT be folded into the Will_Push below since we cannot */
+ /* afford to have the Will_Push put down its own continuation. */
+ /* There is guaranteed to be enough space for this one */
+ /* continuation; in fact, the Will_Push here is really unneeded! */
+ Will_Push(CONTINUATION_SIZE);
+ Save_Cont();
+ Pushed();
+ }
+ Will_Push(STACK_ENV_EXTRA_SLOTS+3+2*CONTINUATION_SIZE+HISTORY_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 error handler will re-enable interrupts & restore history */
+ Stop_History();
+ 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
+/* 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( MemTop - Free);
+ *Next = '\0';
+ Free += (2 + ((Length + sizeof( Pointer)) / sizeof( Pointer)));
+ Vector_Set(Result, STRING_LENGTH, 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, Handle)
+ Pointer Name;
+ char *Mode_String;
+ FILE **Handle;
+{
+ *Handle =
+ ((FILE *)
+ OS_file_open( Scheme_String_To_C_String( Name), (*Mode_String == 'w')));
+ return ((Boolean) (*Handle != NULL));
+}
+
+void
+Close_File(stream)
+ FILE *stream;
+{
+ extern Boolean OS_file_close();
+
+ if (!OS_file_close( stream))
+ Primitive_Error( ERR_EXTERNAL_RETURN);
+ 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()
+{ Pointer Saved_Expression = Fetch_Expression();
+ long Saved_Return_Code = Fetch_Return();
+Will_Push(HISTORY_SIZE);
+ Save_History(RC_RESTORE_DONT_COPY_HISTORY);
+Pushed();
+ Previous_Restore_History_Stacklet = NULL;
+ Previous_Restore_History_Offset =
+ (Get_End_Of_Stacklet() - Stack_Pointer) +
+ CONTINUATION_RETURN_CODE;
+ Store_Expression(Saved_Expression);
+ Store_Return(Saved_Return_Code);
+ return;
+}
+
+Pointer
+*Copy_Rib(Orig_Rib)
+Pointer *Orig_Rib;
+{ Pointer *Result, *This_Rib;
+ for (This_Rib=NULL, Result=Free;
+ (This_Rib != Orig_Rib) && (!GC_Check(0));
+ 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;
+ 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(0)) 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
+/* 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 = (int) 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()), Datum(Fetch_Expression()));
+ Primitive_Error(ERR_UNDEFINED_PRIMITIVE);
+}
+
+Pointer
+Allocate_Float(F)
+double F;
+{ Pointer Result;
+ Align_Float(Free);
+ Result = Make_Pointer(TC_BIG_FLONUM, Free);
+ *Free = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, FLONUM_SIZE);
+ Get_Float(C_To_Scheme(Free)) = F;
+ Primitive_GC_If_Needed(FLONUM_SIZE+1);
+ Free += FLONUM_SIZE+1;
+ return Result;
+}
+\f
+#ifdef USE_STACKLETS
+ /******************/
+ /* STACKLETS */
+ /******************/
+
+void
+Allocate_New_Stacklet(N)
+long N;
+{ Pointer Old_Expression, *Old_Stacklet, Old_Return;
+ Old_Stacklet = Current_Stacklet;
+ Terminate_Old_Stacklet();
+ if ((Free_Stacklets == NULL) ||
+ ((N+STACKLET_SLACK) > Get_Integer(Free_Stacklets[STACKLET_LENGTH])))
+ { long size = New_Stacklet_Size(N);
+ /* Room is set aside for the two header bytes of a stacklet plus
+ * the two bytes required for the RC_JOIN_STACKLETS frame.
+ */
+ if (GC_Check(size))
+ { Request_GC(size);
+ if (Free+size >= Heap_Top)
+ Microcode_Termination(TERM_STACK_OVERFLOW);
+ }
+ Free[STACKLET_LENGTH] = Make_Non_Pointer(TC_MANIFEST_VECTOR, size-1);
+ Stack_Guard = &(Free[STACKLET_HEADER_SIZE]);
+ Free += size;
+ Stack_Pointer = Free;
+ }
+ else /* Grab first one on the free list */
+ { Pointer *New_Stacklet = Free_Stacklets;
+ Free_Stacklets = ((Pointer *) Free_Stacklets[STACKLET_FREE_LIST_LINK]);
+ Stack_Pointer =
+ &New_Stacklet[1 + Get_Integer(New_Stacklet[STACKLET_LENGTH])];
+ Stack_Guard = &New_Stacklet[STACKLET_HEADER_SIZE];
+ }
+ Old_Expression = Fetch_Expression();
+ Old_Return = Fetch_Return();
+ Store_Expression(Make_Pointer(TC_CONTROL_POINT, Old_Stacklet));
+ Store_Return(RC_JOIN_STACKLETS);
+/* Will_Push omitted because size calculation includes enough room. */
+ Save_Cont();
+ Store_Expression(Old_Expression);
+ Store_Return(Old_Return);
+ return;
+}
+#endif
+\f
+/* Dynamic Winder support code */
+
+Pointer
+Find_State_Space(State_Point)
+Pointer State_Point;
+{ long How_Far = Get_Integer(Fast_Vector_Ref(State_Point,
+ STATE_POINT_DISTANCE_TO_ROOT));
+ long i;
+ fast Pointer Point = State_Point;
+ for (i=0; i <= How_Far; i++)
+ {
+#ifdef ENABLE_DEBUGGING_TOOLS
+ if (Point == NIL)
+ { printf("\nState_Point 0x%x wrong: count was %d, NIL at %d\n",
+ State_Point, How_Far, i);
+ Microcode_Termination(TERM_EXIT);
+ }
+#endif
+ Point = Fast_Vector_Ref(Point, STATE_POINT_NEARER_POINT);
+ }
+ return Point;
+}
+
+/* ASSUMPTION: State points, which are created only by the interpreter,
+ never contain FUTUREs except possibly as the thunks (which are handled
+ by the apply code).
+
+ Furthermore:
+ (1) On a single processor, things should work with multiple state
+ spaces. The microcode variable Current_State_Point tracks
+ the location in the "boot" space (i.e. the one whose space is
+ NIL) and the state spaces themselves (roots of the space
+ trees) track the other spaces.
+ (2) On multi-processors, multiple spaces DO NOT work. Only the
+ initial space (NIL) is tracked by the microcode (it is
+ swapped on every task switch), but no association with trees
+ is kept. This will work since the initial tree has no space
+ at the root, indicating that the microcode variable rather
+ than the state space contains the current state space
+ location.
+*/
+\f
+void
+Translate_To_Point(Target)
+Pointer Target;
+{ Pointer State_Space = Find_State_Space(Target);
+ Pointer Current_Location, *Path = Free;
+ fast Pointer Path_Point, *Path_Ptr;
+ long Distance =
+ Get_Integer(Fast_Vector_Ref(Target, STATE_POINT_DISTANCE_TO_ROOT));
+ long Merge_Depth, From_Depth, i;
+
+ guarantee_state_point();
+ if (State_Space == NIL) Current_Location = Current_State_Point;
+ else Current_Location = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT);
+ if (Target == Current_Location) longjmp(*Back_To_Eval, PRIM_POP_RETURN);
+ for (Path_Ptr=(&(Path[Distance])), Path_Point=Target, i=0;
+ i <= Distance;
+ i++, Path_Point=Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT))
+ *Path_Ptr-- = Path_Point;
+ From_Depth =
+ Get_Integer(Fast_Vector_Ref(Current_Location, STATE_POINT_DISTANCE_TO_ROOT));
+ for (Path_Point=Current_Location, Merge_Depth=From_Depth;
+ Merge_Depth > Distance; Merge_Depth--)
+ Path_Point = Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT);
+ for (Path_Ptr=(&(Path[Merge_Depth])); Merge_Depth >= 0;
+ Merge_Depth--, Path_Ptr--,
+ Path_Point=Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT))
+ if (*Path_Ptr == Path_Point) break;
+#ifdef ENABLE_DEBUGGING_TOOLS
+ if (Merge_Depth < 0)
+ { printf("\nMerge_Depth went negative: %d\n", Merge_Depth);
+ Microcode_Termination(TERM_EXIT);
+ }
+#endif
+ Will_Push(2*CONTINUATION_SIZE + 4);
+ Store_Return(RC_RESTORE_INT_MASK);
+ Store_Expression(FIXNUM_0 + IntEnb);
+ Save_Cont();
+ Push(FIXNUM_0+(Distance-Merge_Depth));
+ Push(Target);
+ Push(FIXNUM_0+(From_Depth-Merge_Depth));
+ Push(Current_Location);
+ Store_Expression(State_Space);
+ Store_Return(RC_MOVE_TO_ADJACENT_POINT);
+ Save_Cont();
+ Pushed();
+ IntEnb &= (INT_GC<<1) - 1; /* Disable lower than GC level */
+ longjmp(*Back_To_Eval, PRIM_POP_RETURN);
+}
--- /dev/null
+/* 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: VECTOR.C
+ *
+ * This file contains procedures for handling vectors and conversion
+ * back and forth to lists.
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+\f
+ /*********************/
+ /* VECTORS <-> LISTS */
+ /*********************/
+
+/* Subvector_To_List is a utility routine used by both
+ SUBVECTOR_TO_LIST and SYS_SUBVECTOR_TO_LIST. It copies the entries
+ in a vector (first argument) starting with the entry specified by
+ argument 2 and ending at the one specified by argument 3. The copy
+ includes the starting entry but does NOT include the ending entry.
+ Thus the entire vector is converted to a list by setting argument 2
+ to 0 and argument 3 to the length of the vector.
+*/
+
+Pointer Subvector_To_List()
+{ Pointer *From, Result;
+ long Length, Start, End, Count, i;
+ Primitive_3_Args();
+ if (Type_Code(Arg2) != TC_FIXNUM) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ if (Type_Code(Arg3) != TC_FIXNUM) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
+ if (Type_Code(Vector_Ref(Arg1, VECTOR_TYPE)) != TC_MANIFEST_VECTOR)
+ Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ Length = Vector_Length(Arg1);
+ Start = Get_Integer(Arg2);
+ End = Get_Integer(Arg3);
+ if (End > Length) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+ if (Start > End) Primitive_Error(ERR_ARG_3_BAD_RANGE);
+ if (Start == End) return NIL;
+ Primitive_GC_If_Needed(2*(End-Start));
+ Result = Make_Pointer(TC_LIST, Free);
+ From = Nth_Vector_Loc(Arg1, Start+1);
+ Count = End-Start;
+ for (i=0; i < Count; i++)
+ { *Free++ = Fetch(*From++);
+ *Free = Make_Pointer(TC_LIST, Free+1);
+ Free += 1;
+ }
+ Free[-1] = NIL;
+ return Result;
+}
+\f
+/* Called by the primitives LIST_TO_VECTOR and SYS_LIST_TO_VECTOR.
+ This utility routine converts a list into a vector.
+*/
+
+Pointer L_To_V(Result_Type, List)
+long Result_Type;
+fast Pointer List;
+{ Pointer *Orig_Free;
+ long Count;
+ Touch_In_Primitive(List, List);
+ Count = 0;
+ Orig_Free = Free++;
+ while (Type_Code(List) == TC_LIST)
+ { Primitive_GC_If_Needed(0);
+ Count += 1;
+ *Free++ = Vector_Ref(List, CONS_CAR);
+ Touch_In_Primitive(Vector_Ref(List, CONS_CDR), List);
+ }
+ if (List != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ *Orig_Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, Count);
+ return Make_Pointer(Result_Type, Orig_Free);
+}
+
+/* (LIST_TO_VECTOR LIST)
+ [Primitive number 0x7C]
+ Returns a vector made from the items in LIST.
+*/
+
+Built_In_Primitive(Prim_List_To_Vector, 1, "LIST->VECTOR")
+{ Primitive_1_Arg();
+ return L_To_V(TC_VECTOR, Arg1);
+}
+\f
+/* (SUBVECTOR_TO_LIST VECTOR FROM TO)
+ [Primitive number 0x7D]
+ Returns a list of the FROMth through TO-1st items in the vector.
+ Thus (SUBVECTOR_TO_LIST V 0 (VECTOR_LENGTH V)) returns a list of
+ all the items in V.
+*/
+Built_In_Primitive(Prim_Subvector_To_List, 3, "SUBVECTOR->LIST")
+{ Primitive_3_Args();
+ Arg_1_Type(TC_VECTOR);
+ /* The work is done by Subvector_To_List, in PRIMSUBR.C */
+ return Subvector_To_List();
+}
+
+/* (VECTOR_CONS LENGTH CONTENTS)
+ [Primitive number 0x2C]
+ Create a new vector to hold LENGTH entries, all of which are
+ initialized to CONTENTS.
+*/
+Built_In_Primitive(Prim_Vector_Cons, 2, "VECTOR-CONS")
+{ long Length, i;
+ Primitive_2_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Length = Get_Integer(Arg1);
+ Primitive_GC_If_Needed(Length+1);
+ *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Length);
+ for (i=0; i < Length; i++) *Free++ = Arg2;
+ return Make_Pointer(TC_VECTOR, Free-(Length+1));
+}
+
+/* (VECTOR_REF VECTOR OFFSET)
+ [Primitive number 0x2E]
+ Return the OFFSETth entry in VECTOR. Entries are numbered from
+ 0.
+*/
+Built_In_Primitive(Prim_Vector_Ref, 2, "VECTOR-REF")
+{ long Offset;
+ Primitive_2_Args();
+ Arg_1_Type(TC_VECTOR);
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(Offset, Arg2,
+ 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ return User_Vector_Ref(Arg1, Offset);
+}
+\f
+/* (VECTOR_SET VECTOR OFFSET VALUE)
+ [Primitive number 0x30]
+ Store VALUE as the OFFSETth entry in VECTOR. Entries are
+ numbered from 0. Returns (bad style to rely on this) the
+ previous value of the entry.
+*/
+Built_In_Primitive(Prim_Vector_Set, 3, "VECTOR-SET!")
+{ long Offset;
+ Primitive_3_Args();
+
+ Arg_1_Type(TC_VECTOR);
+ Arg_2_Type(TC_FIXNUM);
+ Range_Check(Offset, Arg2,
+ 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ Side_Effect_Impurify(Arg1, Arg3);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, Offset+1), Arg3);
+}
+
+/* (VECTOR_SIZE VECTOR)
+ [Primitive number 0x2D]
+ Returns the number of entries in VECTOR.
+*/
+Built_In_Primitive(Prim_Vector_Size, 1, "VECTOR-SIZE")
+{ Primitive_1_Arg();
+ Arg_1_Type(TC_VECTOR);
+ return FIXNUM_0+Vector_Length(Arg1);
+}
+\f
+/* (SYS_LIST_TO_VECTOR GC-LIST)
+ [Primitive number 0x97]
+ Same as LIST_TO_VECTOR except that the resulting vector has the
+ specified type code. This can be used, for example, to create
+ an environment from a list of values.
+*/
+Built_In_Primitive(Prim_Sys_List_To_Vector, 2, "SYSTEM-LIST->VECTOR")
+{ long Type;
+ Primitive_2_Args();
+ Arg_1_Type(TC_FIXNUM);
+ Range_Check(Type, Arg1, 0, MAX_TYPE_CODE, ERR_ARG_1_BAD_RANGE);
+ if (GC_Type_Code(Type) == GC_Vector) return L_To_V(Type, Arg2);
+ else Primitive_Error(ERR_ARG_1_BAD_RANGE); /*NOTREACHED*/
+}
+
+/* (SYS_SUBVECTOR_TO_LIST GC-VECTOR FROM TO)
+ [Primitive number 0x98]
+ Same as SUBVECTOR_TO_LIST, but accepts anything with a GC type
+ of VECTOR. Most useful for accessing values from environments.
+*/
+Built_In_Primitive(Prim_Sys_Subvector_To_List, 3,
+ "SYSTEM-SUBVECTOR->LIST")
+{ Primitive_3_Args();
+ Touch_In_Primitive(Arg1, Arg1);
+ Arg_1_GC_Type(GC_Vector);
+ /* The work is done by Subvector_To_List, in PRIMSUBR.C */
+ return Subvector_To_List();
+}
+\f
+/* (SYS_VECTOR OBJECT)
+ [Primitive number 0x99]
+ Returns #!TRUE if OBJECT is of GC type VECTOR. Otherwise
+ returns NIL.
+*/
+Built_In_Primitive(Prim_Sys_Vector, 1, "SYSTEM-VECTOR")
+{ Primitive_1_Arg();
+ Touch_In_Primitive(Arg1, Arg1);
+ if (GC_Type_Vector(Arg1)) return TRUTH; else return NIL;
+}
+
+/* (SYS_VECTOR_REF GC-VECTOR OFFSET)
+ [Primitive number 0x9A]
+ Like VECTOR_REF, but for anything of GC type VECTOR (eg.
+ environments)
+*/
+Built_In_Primitive(Prim_Sys_Vector_Ref, 2, "SYSTEM-VECTOR-REF")
+{ long Offset;
+ Primitive_2_Args();
+ Touch_In_Primitive(Arg1, Arg1);
+ Arg_1_GC_Type(GC_Vector);
+ Range_Check(Offset, Arg2, 0,
+ Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ return User_Vector_Ref(Arg1, Offset);
+}
+
+/* (SYS_VECTOR_SET GC-VECTOR OFFSET VALUE)
+ [Primitive number 0x9B]
+ Like VECTOR_SET, but for anything of GC type VECTOR (eg.
+ environments)
+*/
+Built_In_Primitive(Prim_Sys_Vec_Set, 3, "SYSTEM-VECTOR-SET!")
+{ long Offset;
+ Primitive_3_Args();
+ Touch_In_Primitive(Arg1, Arg1);
+ Arg_1_GC_Type(GC_Vector);
+ Range_Check(Offset, Arg2, 0,
+ Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ Side_Effect_Impurify(Arg1, Arg3);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, Offset+1), Arg3);
+}
+\f
+/* (SYS_VECTOR_SIZE GC-VECTOR)
+ [Primitive number 0xAE]
+ Like VECTOR_SIZE, but for anything of GC type VECTOR (eg.
+ environments)
+*/
+Built_In_Primitive(Prim_Sys_Vec_Size, 1, "SYSTEM-VECTOR-SIZE")
+{ Primitive_1_Arg();
+ Touch_In_Primitive(Arg1, Arg1);
+ Arg_1_GC_Type(GC_Vector);
+ return FIXNUM_0+Vector_Length(Arg1);
+}
+
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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
+/* This file contains version information for the microcode */
+
+/* Scheme system release version */
+
+#ifndef RELEASE
+#define RELEASE "5.0.19"
+#endif
+
+/* Microcode release version */
+
+#ifndef VERSION
+#define VERSION 9
+#endif
+#ifndef SUBVERSION
+#define SUBVERSION 10
+#endif
+
+#ifndef UCODE_TABLES_FILENAME
+#define UCODE_TABLES_FILENAME "utabmd.bin.99"
+#endif
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: winder.h
+
+Header file for dynamic winder. */
+\f
+#if defined(butterfly)
+
+#define guarantee_state_point() \
+{ \
+ if (Current_State_Point == NIL) \
+ Current_State_Point = Get_Fixed_Obj_Slot( State_Space_Root); \
+}
+
+#else
+
+#define guarantee_state_point()
+
+#endif
--- /dev/null
+#include <stdio.h>
+#include <math.h>
+#include <errno.h>
+
+extern int errno;
+extern char *malloc();
+extern free();
+
+/* Some machines do not set ERANGE by default. */
+/* This attempts to fix this. */
+
+#ifdef celerity
+#define hack_signal
+#endif
+
+#ifdef hack_signal
+#define setup_error() signal(SIGFPE, range_error)
+
+range_error()
+{ setup_error();
+ errno = ERANGE;
+}
+#else
+#define setup_error()
+#endif
+
+
+#define ARR_SIZE 20000
+#define MEM_SIZE 400000
+
+/* Force program data to be relatively large. */
+
+static long dummy[ARR_SIZE];
+
+/* Note: comments are printed in a weird way because some
+ C compilers eliminate them even from strings.
+*/
+
+main()
+{ double accum, delta;
+ int count, expt_size, char_size, mant_size;
+ unsigned long to_be_shifted;
+ unsigned bogus;
+ char *temp;
+
+ setup_error();
+ for(bogus = ((unsigned) -1), count = 0;
+ bogus != 0;
+ count += 1)
+ bogus >>= 1;
+
+ char_size = count/(sizeof(unsigned));
+ temp = malloc(MEM_SIZE*sizeof(long));
+ if (temp == NULL)
+ printf("/%c Cannot allocate %d Pointers. %c/\n",
+ '*', MEM_SIZE, '*');
+ else count = free(temp);
+
+ if (((unsigned long) temp) < (1 << ((char_size*sizeof(long))-8)))
+ printf("#define Heap_In_Low_Memory\n");
+ else
+ printf("/%c Heap is not in Low Memory. %c/\n", '*', '*');
+
+ to_be_shifted = -1;
+ if ((to_be_shifted >> 1) != to_be_shifted)
+ printf("#define UNSIGNED_SHIFT\n");
+ else
+ printf("/%c unsigned longs use arithmetic shifting. %c/\n",
+ '*', '*');
+
+ printf("#define CHAR_SIZE %d\n",
+ char_size);
+
+ printf("#define USHORT_SIZE %d\n",
+ (sizeof(unsigned short) * char_size));
+
+ printf("#define ULONG_SIZE %d\n",
+ (sizeof(unsigned long) * char_size));
+
+ printf("/%c Flonum (double) size is %d bits. %c/\n",
+ '*', (char_size*sizeof(double)), '*');
+
+ for(mant_size = 0, accum = 1.0, delta = 0.5;
+ ((accum + delta) != accum);
+ accum = accum + delta,
+ delta /= 2.0,
+ mant_size += 1) ;
+
+ for(errno = 0, expt_size = 0, bogus = 1;
+ errno != ERANGE;
+ expt_size += 1, bogus <<= 1)
+ accum = pow(2.0, ((double) bogus));
+
+ expt_size -= 1;
+
+ printf("#define FLONUM_EXPT_SIZE %d\n", expt_size);
+ printf("#define FLONUM_MANTISSA_BITS %d\n", mant_size);
+ printf("#define MAX_FLONUM_EXPONENT %d\n", ((1 << expt_size) - 1));
+ printf("/%c Representation %s hidden bit. %c/\n", '*',
+ (((2+expt_size+mant_size) > (char_size*sizeof(double))) ?
+ "uses" :
+ "does not use"), '*');
+ return;
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: xdebug.c
+ *
+ * This file contains primitives to debug the memory management in the
+ * Scheme system.
+ *
+ */
+
+#include "scheme.h"
+#include "primitive.h"
+\f
+/* New debugging utilities */
+
+#define FULL_EQ 0
+#define SAFE_EQ 1
+#define ADDRESS_EQ 2
+#define DATUM_EQ 3
+
+#define SAFE_MASK (~DANGER_BIT)
+
+static Pointer *Find_Occurrence(From, To, What, Mode)
+fast Pointer *From, *To;
+Pointer What;
+int Mode;
+{ fast Pointer Obj;
+ switch (Mode)
+ { default:
+ case FULL_EQ:
+ { Obj = What;
+ for (; From < To; From++)
+ if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
+ From += Get_Integer(*From);
+ else if (*From == Obj) return From;
+ return To;
+ }
+ case SAFE_EQ:
+ { Obj = (What & SAFE_MASK);
+ for (; From < To; From++)
+ if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
+ From += Get_Integer(*From);
+ else if (((*From) & SAFE_MASK) == Obj) return From;
+ return To;
+ }
+ case ADDRESS_EQ:
+ { Obj = Datum(What);
+ for (; From < To; From++)
+ if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
+ From += Get_Integer(*From);
+ else if ((Datum(*From) == Obj) &&
+ (!(GC_Type_Non_Pointer(*From))))
+ return From;
+ return To;
+ }
+ case DATUM_EQ:
+ { Obj = Datum(What);
+ for (; From < To; From++)
+ if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
+ From += Get_Integer(*From);
+ else if (Datum(*From) == Obj) return From;
+ return To;
+ }
+ }
+}
+\f
+static long Find_In_Area(Name, From, To, Obj, Mode, print_p, store_p)
+char *Name;
+Pointer *From, *To, Obj;
+int Mode;
+Boolean print_p, store_p;
+{ fast Pointer *Where;
+ fast long occurrences = 0;
+ if (print_p) printf(" Looking in %s:\n", Name);
+ Where = From-1;
+ while ((Where = Find_Occurrence(Where+1, To, Obj, Mode)) < To)
+ { occurrences += 1;
+ if (print_p)
+#ifndef b32
+ printf("Location = 0x%x; Contents = 0x%x\n",
+ ((long) Where), ((long) (*Where)));
+#else
+ printf("Location = 0x%08x; Contents = 0x%08x\n",
+ ((long) Where), ((long) (*Where)));
+#endif
+ if (store_p)
+ /* Note that Make_Pointer (vs. Make_Non_Pointer) is correct here!! */
+ *Free++ = Make_Pointer(TC_ADDRESS, Where);
+ }
+ return occurrences;
+}
+
+#define PRINT_P 1
+#define STORE_P 2
+
+Pointer Find_Who_Points(Obj, Find_Mode, Collect_Mode)
+Pointer Obj;
+int Find_Mode, Collect_Mode;
+{ long n = 0;
+ Pointer *Saved_Free = Free;
+ Boolean print_p = (Collect_Mode & PRINT_P);
+ Boolean store_p = (Collect_Mode & STORE_P);
+ /* No overflow check done. Hopefully referenced few times, or invoked before
+ to find the count and insure that there is enough space. */
+ if (store_p) Free += 1;
+ if (print_p)
+ { putchar('\n');
+#ifndef b32
+ printf("*** Looking for Obj = 0x%x; Find_Mode = %2d ***\n",
+ Obj, Find_Mode);
+#else
+ printf("*** Looking for Obj = 0x%08x; Find_Mode = %2d ***\n",
+ Obj, Find_Mode);
+#endif
+ }
+ n += Find_In_Area("Constant Space",
+ Constant_Space, Free_Constant, Obj,
+ Find_Mode, print_p, store_p);
+ n += Find_In_Area("the Heap",
+ Heap_Bottom, Saved_Free, Obj,
+ Find_Mode, print_p, store_p);
+#ifndef USE_STACKLETS
+ n += Find_In_Area("the Stack",
+ Stack_Pointer, Stack_Top, Obj,
+ Find_Mode, print_p, store_p);
+#endif
+ if (print_p) printf("Done.\n");
+ if (store_p)
+ { *Saved_Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, n);
+ return Make_Pointer(TC_VECTOR, Saved_Free);
+ }
+ else return Make_Non_Pointer(TC_FIXNUM, n);
+}
+\f
+Print_Memory(Where, How_Many)
+Pointer *Where;
+long How_Many;
+{ fast Pointer *End = &Where[How_Many];
+#ifndef b32
+ printf("\n*** Memory from 0x%x to 0x%x (excluded) ***\n", Where, End);
+ while (Where < End) printf("0x%x\n", *Where++);
+#else
+ printf("\n*** Memory from 0x%08x to 0x%08x (excluded) ***\n", Where, End);
+ while (Where < End) printf("0x%08x\n", *Where++);
+#endif
+ printf("Done.\n");
+ return;
+}
+\f
+/* Primitives to give scheme a handle on utilities from DEBUG.C */
+
+Define_Primitive(Prim_Show_Pure, 0, "SHOW-PURE")
+{ printf("\n*** Constant & Pure Space: ***\n");
+ Show_Pure();
+ return TRUTH;
+}
+
+Define_Primitive(Prim_Show_Env, 1, "SHOW-ENV")
+{ Primitive_1_Arg();
+ printf("\n*** Environment = 0x%x ***\n", Arg1);
+ Show_Env(Arg1);
+ return TRUTH;
+}
+
+Define_Primitive(Prim_Stack_Trace, 0, "STACK-TRACE")
+{ Primitive_0_Args();
+ printf("\n*** Back Trace: ***\n");
+ Back_Trace();
+ return TRUTH;
+}
+
+Define_Primitive(Prim_Find_Symbol, 1, "FIND-SYMBOL")
+{ Primitive_1_Arg();
+ Find_Symbol();
+ return TRUTH;
+}
+\f
+/* Primitives to give scheme a handle on utilities on this file. */
+
+Define_Primitive(Prim_Debug_Flags, 0, "DEBUG-FLAGS")
+{ Handle_Debug_Flags();
+ return TRUTH;
+}
+
+Define_Primitive(Prim_Find_Who_Points, 3, "FIND-WHO-POINTS")
+{ Primitive_3_Args();
+ return Find_Who_Points(Arg1, Get_Integer(Arg2), Get_Integer(Arg3));
+}
+
+Define_Primitive(Prim_Print_Memory, 2, "PRINT-MEMORY")
+{ Pointer *Base;
+ Primitive_2_Args();
+ if (GC_Type_Non_Pointer(Arg1))
+ Base = ((Pointer *) Datum(Arg1));
+ else Base = Get_Pointer(Arg1);
+ Print_Memory(Base, Get_Integer(Arg2));
+ return TRUTH;
+}
--- /dev/null
+/* 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: ZONES.H
+ *
+ * Metering stuff.
+ * We break all times into time zones suitable for external analysis.
+ * Primitives may be included for accessing this information if desired
+ * by supplying additional files.
+ */
+
+#ifdef METERING
+extern long New_Time, Old_Time, Time_Meters[], Current_Zone;
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+#define Set_Time_Zone(Zone) \
+{ New_Time = Sys_Clock();\
+ Time_Meters[Current_Zone] += New_Time-Old_Time;\
+ Old_Time = New_Time;\
+ Current_Zone = Zone;\
+}
+#else
+#define Set_Time_Zone(Zone) Current_Zone = Zone;
+#endif
+
+#define Save_Time_Zone(Zone) Saved_Zone = Current_Zone; Set_Time_Zone(Zone);
+#define Restore_Time_Zone() Set_Time_Zone(Saved_Zone);
+#else
+#define Set_Time_Zone(Zone)
+#define Save_Time_Zone(Zone)
+#define Restore_Time_Zone()
+#endif
+
+#define Zone_Working 0
+#define Zone_GetWork 1
+#define Zone_TTY_IO 2
+#define Zone_Disk_IO 3
+#define Zone_Purify 4
+#define Zone_GCLoop 5
+#define Zone_Global_Int 6
+#define Zone_Store_Lock 7
+#define Zone_Math 8
+#define Zone_GCIdle 9
+#define Zone_Lookup 10
+
+#define Max_Meters 11
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: BINTOPSB.C
+ *
+ * This File contains the code to translate internal format binary
+ * files to portable format.
+ *
+ */
+\f
+/* Cheap renames */
+
+#define Internal_File Input_File
+#define Portable_File Output_File
+
+#include "translate.h"
+
+static Boolean Shuffle_Bytes = false;
+static Boolean Padded_Strings = true;
+static Boolean Dense_Types = true;
+
+static Pointer *Mem_Base;
+static long Heap_Relocation, Constant_Relocation;
+static long Free, Scan, Free_Constant, Scan_Constant;
+static long Objects, Constant_Objects;
+static long NFlonums, NIntegers, NStrings;
+static long NBits, NChars;
+static Pointer *Free_Objects, *Free_Cobjects;
+
+Load_Data(Count, To_Where)
+long Count;
+char *To_Where;
+{ fread(To_Where, sizeof(Pointer), Count, Internal_File);
+}
+
+#define Reloc_or_Load_Debug false
+
+#include "load.c"
+\f
+/* Utility macros and procedures
+ Pointer Objects handled specially in the portable format.
+*/
+
+#ifndef isalpha
+/* Just in case the stdio library atypically contains the character
+ macros, just like the C book claims. */
+#include <ctype.h>
+#endif
+
+#ifndef ispunct
+/* This is in some libraries but not others */
+static char punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
+
+Boolean ispunct(c)
+fast char c;
+{ fast char *s = &punctuation[0];
+ while (*s != '\0') if (*s++ == c) return true;
+ return false;
+}
+#endif
+
+#define OUT(s) \
+fprintf(Portable_File, s); \
+break
+
+print_a_char(c, name)
+fast char c;
+char *name;
+{ switch(c)
+ { case '\n': OUT("\\n");
+ case '\t': OUT("\\t");
+ case '\b': OUT("\\b");
+ case '\r': OUT("\\r");
+ case '\f': OUT("\\f");
+ case '\\': OUT("\\\\");
+ case '\0': OUT("\\0");
+ case ' ' : OUT(" ");
+ default:
+ if ((isalpha(c)) || (isdigit(c)) || (ispunct(c)))
+ putc(c, Portable_File);
+ else
+ { fprintf(stderr,
+ "%s: %s: File may not be portable: c = 0x%x\n",
+ Program_Name, name, ((int) c));
+ /* This does not follow C conventions, but eliminates ambiguity */
+ fprintf(Portable_File, "\X%x ", ((int) c));
+ }
+ }
+}
+\f
+#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer((Code), Old_Contents); \
+ else \
+ { fast long i; \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = STRING_0; \
+ *(FObj)++ = Old_Contents; \
+ i = Get_Integer(Old_Contents); \
+ NStrings += 1; \
+ NChars += (Padded_Strings ? \
+ pointer_to_char(i-1) : \
+ (1 + pointer_to_char(i-1))); \
+ while(--i >= 0) *(FObj)++ = *Old_Address++; \
+ } \
+ if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \
+}
+
+print_a_string(from)
+Pointer *from;
+{ fast long len;
+ fast char *string;
+ long maxlen = pointer_to_char((Get_Integer(*from++))-1);
+ if (!Padded_Strings) maxlen += 1;
+ len = Get_Integer(*from++);
+ fprintf(Portable_File, "%02x %ld %ld ",
+ TC_CHARACTER_STRING,
+ (Compact_P ? len : maxlen),
+ len);
+ string = ((char *) from);
+ if (Shuffle_Bytes)
+ { while(len > 0)
+ { print_a_char(string[3], "print_a_string");
+ if (len > 1) print_a_char(string[2], "print_a_string");
+ if (len > 2) print_a_char(string[1], "print_a_string");
+ if (len > 3) print_a_char(string[0], "print_a_string");
+ len -= 4;
+ string += 4;
+ }
+ }
+ else while(--len >= 0) print_a_char(*string++, "print_a_string");
+ putc('\n', Portable_File);
+ return;
+}
+\f
+print_a_fixnum(val)
+long val;
+{ fast long size_in_bits;
+ fast unsigned long temp = ((val < 0) ? -val : val);
+ for (size_in_bits = 0; temp != 0; size_in_bits += 1)
+ temp = temp >> 1;
+ fprintf(Portable_File, "%02x %c ",
+ TC_FIXNUM,
+ (val < 0 ? '-' : '+'));
+ if (val == 0) fprintf(Portable_File, "0\n");
+ else
+ { fprintf(Portable_File, "%ld ", size_in_bits);
+ temp = ((val < 0) ? -val : val);
+ while (temp != 0)
+ { fprintf(Portable_File, "%01lx", (temp % 16));
+ temp = temp >> 4;
+ }
+ fprintf(Portable_File, "\n");
+ }
+ return;
+}
+\f
+#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer((Code), Old_Contents); \
+ else \
+ { fast long length; \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ NIntegers += 1; \
+ NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \
+ *(FObj)++ = Old_Contents; \
+ for (length = Get_Integer(Old_Contents); \
+ --length >= 0; ) \
+ *(FObj)++ = *Old_Address++; \
+ } \
+ if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \
+}
+
+print_a_bignum(from)
+Pointer *from;
+{ fast bigdigit *the_number, *the_top;
+ fast long size_in_bits;
+ fast unsigned long temp; /* Potential signed problems */
+
+ the_number = BIGNUM(from);
+ temp = LEN(the_number);
+ if (temp == 0)
+ fprintf(Portable_File, "%02x + 0\n",
+ (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM));
+ else
+ { fast long tail;
+ for (size_in_bits = ((temp - 1) * SHIFT),
+ temp = ((long) (*Bignum_Top(the_number)));
+ temp != 0;
+ size_in_bits += 1)
+ temp = temp >> 1;
+
+ fprintf(Portable_File, "%02x %c %ld ",
+ (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM),
+ (NEG_BIGNUM(the_number) ? '-' : '+'),
+ size_in_bits);
+ tail = size_in_bits % SHIFT;
+ if (tail == 0) tail = SHIFT;
+ temp = 0;
+ size_in_bits = 0;
+ the_top = Bignum_Top(the_number);
+ for(the_number = Bignum_Bottom(the_number);
+ the_number <= the_top;
+ the_number += 1)
+ { temp |= (((unsigned long) (*the_number)) << size_in_bits);
+ for (size_in_bits += ((the_number != the_top) ? SHIFT : tail);
+ size_in_bits > 3;
+ size_in_bits -= 4)
+ { fprintf(Portable_File, "%01lx", temp % 16);
+ temp = temp >> 4;
+ }
+ }
+ if (size_in_bits > 0) fprintf(Portable_File, "%01lx\n", temp);
+ else fprintf(Portable_File, "\n");
+ }
+ return;
+}
+\f
+#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer((Code), Old_Contents); \
+ else \
+ { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ (Obj) += 1; \
+ *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \
+ *((double *) (FObj)) = *((double *) Old_Address); \
+ (FObj) += float_to_pointer; \
+ NFlonums += 1; \
+ } \
+ if (Dangerous(This)) Set_Danger_Bit(Mem_Base[(Scn)]); \
+}
+
+print_a_flonum(val)
+double val;
+{ fast long size_in_bits;
+ fast double mant, temp;
+ int expt;
+ extern double frexp();
+
+ fprintf(Portable_File, "%02x %c ",
+ TC_BIG_FLONUM,
+ ((val < 0.0) ? '-' : '+'));
+ if (val == 0.0)
+ { fprintf(Portable_File, "0\n");
+ return;
+ }
+ mant = frexp(((val < 0.0) ? -val : val), &expt);
+ size_in_bits = 1;
+ for(temp = ((mant * 2.0) - 1.0);
+ temp != 0;
+ size_in_bits += 1)
+ { temp *= 2.0;
+ if (temp >= 1.0) temp -= 1.0;
+ }
+ fprintf(Portable_File, "%ld %ld ", expt, size_in_bits);
+ for (size_in_bits = hex_digits(size_in_bits);
+ size_in_bits > 0;
+ size_in_bits -= 1)
+ { fast unsigned int digit = 0;
+ for (expt = 4; --expt >= 0;)
+ { mant *= 2.0;
+ digit = digit << 1;
+ if (mant >= 1.0)
+ { mant -= 1.0;
+ digit += 1;
+ }
+ }
+ fprintf(Portable_File, "%01x", digit);
+ }
+ fprintf(Portable_File, "\n");
+ return;
+}
+\f
+/* Normal Objects */
+
+#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ } \
+}
+
+#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ } \
+}
+
+#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ } \
+}
+
+#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
+{ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ Mem_Base[(Scn)] = \
+ Make_New_Pointer(Type_Code(This), Old_Contents); \
+ else \
+ { fast long len = Get_Integer(Old_Contents); \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ while (len > 0) \
+ { Mem_Base[(Fre)++] = *Old_Address++; \
+ len -= 1; \
+ } \
+ } \
+}
+\f
+/* Common Pointer Code */
+
+#define Do_Pointer(Scn, Action) \
+Old_Address = Get_Pointer(This); \
+if (Datum(This) < Const_Base) \
+ Action(HEAP_CODE, Heap_Relocation, Free, \
+ Scn, Objects, Free_Objects) \
+else if (Datum(This) < Dumped_Constant_Top) \
+Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \
+ Scn, Constant_Objects, Free_Cobjects) \
+else \
+{ fprintf(stderr, \
+ "%s: File is not portable: Pointer to stack.\n", \
+ Program_Name); \
+ exit(1); \
+} \
+(Scn) += 1; \
+break
+\f
+/* Processing of a single area */
+
+#define Do_Area(Code, Area, Bound, Obj, FObj) \
+ Process_Area(Code, &Area, &Bound, &Obj, &FObj)
+
+#ifdef DEBUG
+#define Show_Upgrade(This, New_Type) \
+ fprintf(stderr, "Upgrading from 0x%02x|%06x to 0x%x\n", \
+ Type_Code(This), Datum(This), New_Type);
+#else
+#define Show_Upgrade(This, New_Type)
+#endif
+
+#define Upgrade(New_Type) \
+{ Boolean Was_Dangerous = Dangerous(This); \
+ Show_Upgrade(This, New_Type); \
+ if (Dense_Types) goto Bad_Type; \
+ This = Make_New_Pointer(New_Type, Datum(This)); \
+ if (Was_Dangerous) Set_Danger_Bit(This); \
+ Mem_Base[*Area] = This; \
+ break; \
+}
+
+Process_Area(Code, Area, Bound, Obj, FObj)
+int Code;
+fast long *Area, *Bound;
+fast long *Obj;
+fast Pointer **FObj;
+{ fast Pointer This, *Old_Address, Old_Contents;
+ while(*Area != *Bound)
+ { This = Mem_Base[*Area];
+ Switch_by_GC_Type(This)
+ { case TC_MANIFEST_NM_VECTOR:
+ if (Null_NMV)
+ { fast int i = Get_Integer(This);
+ *Area += 1;
+ for ( ; --i >= 0; *Area += 1)
+ Mem_Base[*Area] = NIL;
+ break;
+ }
+ /* else, Unknown object! */
+ fprintf(stderr, "%s: File is not portable: NMH found\n",
+ Program_Name);
+ *Area += 1 + Get_Integer(This);
+ break;
+
+ case TC_BROKEN_HEART:
+ /* [Broken Heart 0] is the cdr of fasdumped symbols. */
+ if (Get_Integer(This) != 0)
+ { fprintf(stderr, "%s: Broken Heart found in scan.\n",
+ Program_Name);
+ exit(1);
+ }
+ *Area += 1;
+ break;
+
+ case TC_FIXNUM:
+ NIntegers += 1;
+ NBits += fixnum_to_bits;
+ /* Fall Through */
+ case TC_CHARACTER:
+ Process_Character:
+ Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj);
+ *Obj += 1;
+ **FObj = This;
+ if (Dangerous(This))
+ { Set_Danger_Bit(Mem_Base[*Area]);
+ Clear_Danger_Bit(**FObj);
+ }
+ *FObj += 1;
+ /* Fall through */
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ case TC_PRIMITIVE_EXTERNAL:
+ case_simple_Non_Pointer:
+ *Area += 1;
+ break;
+
+ case_compiled_entry_point:
+ fprintf(stderr,
+ "%s: File is not portable: Compiled code.\n",
+ Program_Name);
+ exit(1);
+
+ case_Cell:
+ Do_Pointer(*Area, Do_Cell);
+
+ case TC_WEAK_CONS:
+ case_Pair:
+ Do_Pointer(*Area, Do_Pair);
+
+ case TC_VARIABLE:
+ case_Triple:
+ Do_Pointer(*Area, Do_Triple);
+
+ case TC_BIG_FLONUM:
+ Do_Pointer(*Area, Do_Flonum);
+
+ case TC_BIG_FIXNUM:
+ Do_Pointer(*Area, Do_Bignum);
+
+ case TC_CHARACTER_STRING:
+ Do_Pointer(*Area, Do_String);
+
+ case TC_ENVIRONMENT:
+ case TC_FUTURE:
+ case_simple_Vector:
+ Do_Pointer(*Area, Do_Vector);
+
+/* This should be cleaned up: We can no longer do it like this
+ since we have reused the types.
+ */
+
+ case OLD_TC_BROKEN_HEART:
+ Upgrade(TC_BROKEN_HEART);
+ case OLD_TC_SPECIAL_NM_VECTOR:
+ Upgrade(TC_MANIFEST_SPECIAL_NM_VECTOR);
+#if 0
+ case OLD_TC_UNASSIGNED:
+ Upgrade(TC_UNASSIGNED);
+ case OLD_TC_RETURN_CODE:
+ Upgrade(TC_RETURN_CODE);
+#endif
+ case OLD_TC_PCOMB0:
+ Upgrade(TC_PCOMB0);
+ case OLD_TC_THE_ENVIRONMENT:
+ Upgrade(TC_THE_ENVIRONMENT);
+ case OLD_TC_CHARACTER:
+ Upgrade(TC_CHARACTER);
+ case OLD_TC_FIXNUM:
+ Upgrade(TC_FIXNUM);
+#if 0
+ case OLD_TC_SEQUENCE_3:
+ Upgrade(TC_SEQUENCE_3);
+#endif
+ case OLD_TC_MANIFEST_NM_VECTOR:
+ Upgrade(TC_MANIFEST_NM_VECTOR);
+ case OLD_TC_VECTOR:
+ Upgrade(TC_VECTOR);
+#if 0
+ case OLD_TC_ENVIRONMENT:
+ Upgrade(TC_ENVIRONMENT);
+#endif
+ case OLD_TC_CONTROL_POINT:
+ Upgrade(TC_CONTROL_POINT);
+ case OLD_TC_COMBINATION:
+ Upgrade(TC_COMBINATION);
+ case OLD_TC_PCOMB3:
+ Upgrade(TC_PCOMB3);
+ case OLD_TC_PCOMB2:
+ Upgrade(TC_PCOMB2);
+
+ default:
+ Bad_Type:
+ fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
+ Program_Name, Type_Code(This));
+ exit(1);
+ }
+ }
+}
+\f
+/* Output macros */
+
+#define print_an_object(obj) \
+fprintf(Portable_File, "%02x %lx\n", \
+ Type_Code(obj), Get_Integer(obj))
+
+#define print_external_object(from) \
+{ switch(Type_Code(*from)) \
+ { case TC_FIXNUM: \
+ { long Value; \
+ Sign_Extend(*from++, Value); \
+ print_a_fixnum(Value); \
+ break; \
+ } \
+ case TC_BIG_FIXNUM: \
+ from += 1; \
+ print_a_bignum(from); \
+ from += 1 + Get_Integer(*from); \
+ break; \
+ case TC_CHARACTER_STRING: \
+ from += 1; \
+ print_a_string(from); \
+ from += 1 + Get_Integer(*from); \
+ break; \
+ case TC_BIG_FLONUM: \
+ print_a_flonum(*((double *) (from+1))); \
+ from += 1 + float_to_pointer; \
+ break; \
+ case TC_CHARACTER: \
+ fprintf(Portable_File, "%02x %03x\n", \
+ TC_CHARACTER, (*from & MASK_EXTNDD_CHAR)); \
+ from += 1; \
+ break; \
+ default: \
+ fprintf(stderr, \
+ "%s: Bad Object to print externally %lx\n", \
+ Program_Name, *from); \
+ exit(1); \
+ } \
+}
+\f
+/* Debugging Aids and Consistency Checks */
+
+#ifdef DEBUG
+
+When(what, message)
+Boolean what;
+char *message;
+{ if (what)
+ { fprintf(stderr, "%s: Inconsistency: %s!\n",
+ Program_Name, (message));
+ exit(1);
+ }
+ return;
+}
+
+#define print_header(name, obj, format) \
+fprintf(Portable_File, (format), (obj)); \
+fprintf(stderr, "%s: ", (name)); \
+fprintf(stderr, (format), (obj))
+
+#else
+
+#define When(what, message)
+
+#define print_header(name, obj, format) \
+fprintf(Portable_File, (format), (obj))
+
+#endif
+\f
+/* The main program */
+
+do_it()
+{ Pointer *Heap;
+ long Initial_Free;
+
+ /* Load the Data */
+
+ if (!Read_Header())
+ { fprintf(stderr,
+ "%s: Input file does not appear to be in FASL format.\n",
+ Program_Name);
+ exit(1);
+ }
+
+ if ((Version != FASL_FORMAT_VERSION) ||
+ (Sub_Version > FASL_SUBVERSION) ||
+ (Sub_Version < FASL_OLDEST_SUPPORTED) ||
+ ((Machine_Type != FASL_INTERNAL_FORMAT) && (!Shuffle_Bytes)))
+ { fprintf(stderr, "%s:\n", Program_Name);
+ fprintf(stderr,
+ "FASL File Version %ld Subversion %ld Machine Type %ld\n",
+ Version, Sub_Version , Machine_Type);
+ fprintf(stderr,
+ "Expected: Version %d Subversion %d Machine Type %d\n",
+ FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
+ exit(1);
+ }
+
+ if (Machine_Type == FASL_INTERNAL_FORMAT)
+ Shuffle_Bytes = false;
+ if (Sub_Version < FASL_PADDED_STRINGS)
+ Padded_Strings = false;
+ if (Sub_Version < FASL_DENSE_TYPES)
+ Dense_Types = false;
+
+ /* Constant Space not currently supported */
+
+ if (Const_Count != 0)
+ { fprintf(stderr,
+ "%s: Input file has a constant space area.\n",
+ Program_Name);
+ exit(1);
+ }
+
+ { long Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1);
+#ifdef FLOATING_ALIGNMENT
+ Size += (FLOATING_ALIGNMENT+1)/sizeof(Pointer);
+#endif
+ Allocate_Heap_Space(Size);
+ if (Heap == NULL)
+ { fprintf(stderr,
+ "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
+ Program_Name, Size);
+ exit(1);
+ }
+ }
+ Align_Float(Heap);
+ Load_Data(Heap_Count, &Heap[0]);
+ Load_Data(Const_Count, &Heap[Heap_Count]);
+ Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base);
+ Constant_Relocation = &Heap[Heap_Count] - Get_Pointer(Const_Base);
+
+#ifdef DEBUG
+ fprintf(stderr, "Dumped Heap Base = 0x%08x\n", Heap_Base);
+ fprintf(stderr, "Dumped Constant Base = 0x%08x\n", Const_Base);
+ fprintf(stderr, "Dumped Constant Top = 0x%08x\n", Dumped_Constant_Top);
+ fprintf(stderr, "Heap Count = %6d\n", Heap_Count);
+ fprintf(stderr, "Constant Count = %6d\n", Const_Count);
+#endif
+\f
+ /* Reformat the data */
+
+ NFlonums = NIntegers = NStrings = NBits = NChars = 0;
+ Mem_Base = &Heap[Heap_Count + Const_Count];
+ if (Ext_Prim_Vector == NIL)
+ { Mem_Base[0] = Make_Non_Pointer(TC_CELL, 2);
+ Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
+ Mem_Base[2] = NIL;
+ Initial_Free = NROOTS + 1;
+ Scan = 1;
+ }
+ else
+ { Mem_Base[0] = Ext_Prim_Vector; /* Has CELL TYPE */
+ Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
+ Initial_Free = NROOTS;
+ Scan = 0;
+ }
+ Free = Initial_Free;
+ Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
+ Objects = 0;
+
+ Free_Constant = (2 * Heap_Count) + Initial_Free;
+ Scan_Constant = Free_Constant;
+ Free_Cobjects = &Mem_Base[Const_Count + Free_Constant];
+ Constant_Objects = 0;
+
+#if true
+ Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
+#else
+ /* When Constant Space finally becomes supported,
+ something like this must be done. */
+ while (true)
+ { Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
+ Do_Area(CONSTANT_CODE, Scan_Constant,
+ Free_Constant, Constant_Objects, Free_Cobjects);
+ Do_Area(PURE_CODE, Scan_Pure, Fre_Pure, Pure_Objects, Free_Pobjects);
+ if (Scan == Free) break;
+ }
+#endif
+\f
+ /* Consistency checks */
+
+ When(((Free - Initial_Free) > Heap_Count), "Free overran Heap");
+ When(((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
+ Heap_Count),
+ "Free_Objects overran Heap Object Space");
+ When(((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
+ "Free_Constant overran Constant Space");
+ When(((Free_Cobjects - &Mem_Base[Initial_Free + (2 * Heap_Count) + Const_Count]) >
+ Const_Count),
+ "Free_Cobjects overran Constant Object Space");
+\f
+ /* Output the data */
+
+ /* Header */
+
+ print_header("Portable Version", PORTABLE_VERSION, "%ld\n");
+ print_header("Flags", Make_Flags(), "%ld\n");
+ print_header("Version", FASL_FORMAT_VERSION, "%ld\n");
+ print_header("Sub Version", FASL_SUBVERSION, "%ld\n");
+ print_header("Heap Count", (Free - NROOTS), "%ld\n");
+ print_header("Heap Base", NROOTS, "%ld\n");
+ print_header("Heap Objects", Objects, "%ld\n");
+
+ /* Currently Constant and Pure not supported, but the header is ready */
+
+ print_header("Pure Count", 0, "%ld\n");
+ print_header("Pure Base", Free_Constant, "%ld\n");
+ print_header("Pure Objects", 0, "%ld\n");
+ print_header("Constant Count", 0, "%ld\n");
+ print_header("Constant Base", Free_Constant, "%ld\n");
+ print_header("Constant Objects", 0, "%ld\n");
+
+ print_header("Number of flonums", NFlonums, "%ld\n");
+ print_header("Number of integers", NIntegers, "%ld\n");
+ print_header("Number of strings", NStrings, "%ld\n");
+ print_header("Number of bits in integers", NBits, "%ld\n");
+ print_header("Number of characters in strings", NChars, "%ld\n");
+ print_header("& Dumped Object", (Get_Integer(Mem_Base[1])), "%ld\n");
+ print_header("& Ext Prim Vector", (Get_Integer(Mem_Base[0])), "%ld\n");
+\f
+ /* External Objects */
+
+ /* Heap External Objects */
+
+ Free_Objects = &Mem_Base[Initial_Free + Heap_Count];
+ for (; Objects > 0; Objects -= 1)
+ print_external_object(Free_Objects);
+
+#if false
+ /* Pure External Objects */
+
+ Free_Cobjects = &Mem_Base[Pure_Objects_Start];
+ for (; Pure_Objects > 0; Pure_Objects -= 1)
+ print_external_object(Free_Cobjects);
+
+ /* Constant External Objects */
+
+ Free_Cobjects = &Mem_Base[Constant_Objects_Start];
+ for (; Constant_Objects > 0; Constant_Objects -= 1)
+ print_external_object(Free_Cobjects);
+
+#endif
+\f
+ /* Pointer Objects */
+
+ /* Heap Objects */
+
+ Free_Cobjects = &Mem_Base[Free];
+ for (Free_Objects = &Mem_Base[NROOTS];
+ Free_Objects < Free_Cobjects;
+ Free_Objects += 1)
+ print_an_object(*Free_Objects);
+
+#if false
+ /* Pure Objects */
+
+ Free_Cobjects = &Mem_Base[Free_Pure];
+ for (Free_Objects = &Mem_Base[Pure_Start];
+ Free_Objects < Free_Cobjects;
+ Free_Objects += 1)
+ print_an_object(*Free_Objects);
+
+ /* Constant Objects */
+
+ Free_Cobjects = &Mem_Base[Free_Constant];
+ for (Free_Objects = &Mem_Base[Constant_Start];
+ Free_Objects < Free_Cobjects;
+ Free_Objects += 1)
+ print_an_object(*Free_Objects);
+#endif
+
+ return;
+}
+\f
+/* Top Level */
+
+static int Noptions = 3;
+
+static struct Option_Struct Options[] =
+ {{"Do_Not_Compact", false, &Compact_P},
+ {"Null_Out_NMVs", true, &Null_NMV},
+ {"Swap_Bytes", true, &Shuffle_Bytes}};
+
+main(argc, argv)
+int argc;
+char *argv[];
+{ Setup_Program(argc, argv, Noptions, Options);
+ return;
+}
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: CONST.H
+ *
+ * Named constants used throughout the interpreter
+ *
+ */
+\f
+#if (CHAR_SIZE != 8)
+#define MAX_CHAR ((1<<CHAR_SIZE)-1)
+#else
+#define MAX_CHAR 0xFF
+#endif
+
+#define PI 3.1415926535
+#define STACK_FRAME_HEADER 1
+
+/* Precomputed typed pointers */
+#ifndef b32 /* Safe version */
+
+#define NIL Make_Non_Pointer(TC_NULL, 0)
+#define TRUTH Make_Non_Pointer(TC_TRUE, 0)
+#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_UNASSIGNED, UNASSIGNED)
+#define UNBOUND_OBJECT Make_Non_Pointer(TC_UNASSIGNED, UNBOUND)
+#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0)
+#define FIXNUM_0 Make_Non_Pointer(TC_FIXNUM, 0)
+#define LOCAL_REF_0 Make_Non_Pointer(LOCAL_REF, 0)
+#define BROKEN_HEART_0 Make_Non_Pointer(TC_BROKEN_HEART, 0)
+#define STRING_0 Make_Non_Pointer(TC_CHARACTER_STRING, 0)
+
+#else /* 32 bit word */
+#define NIL 0x00000000
+#define TRUTH 0x08000000
+#define UNASSIGNED_OBJECT 0x32000000
+#define UNBOUND_OBJECT 0x32000001
+#define UNCOMPILED_VARIABLE 0x08000000
+#define FIXNUM_0 0x1A000000
+#define LOCAL_REF_0 0x00000000
+#define BROKEN_HEART_0 0x22000000
+#define STRING_0 0x1E000000
+#endif /* b32 */
+
+/* Some names for flag values */
+
+#define SET_IT 0 /* Lookup */
+#define CLEAR_IT 1
+#define READ_IT 2
+#define TEST_IT 3
+
+#define FOUND_SLOT 1 /* Slot lookup */
+#define NO_SLOT 2
+#define FOUND_UNBOUND 4
+
+#define NOT_THERE -1 /* Command line parser */
+\f
+/* Assorted sizes used in various places */
+
+#ifdef MAXPATHLEN
+#define FILE_NAME_LENGTH MAXPATHLEN
+#else
+#define FILE_NAME_LENGTH 1024 /* Max. chars. in a file name */
+#endif
+
+#define OBARRAY_SIZE 3001 /* Interning hash table */
+#define STACK_GUARD_SIZE 500 /* Cells between constant and
+ stack before overflow
+ occurs */
+#define FILE_CHANNELS 15
+#define MAX_LIST_PRINT 10
+
+#define ILLEGAL_PRIMITIVE -1
+
+/* Hashing algorithm for interning */
+
+#define MAX_HASH_CHARS 5
+#define LENGTH_MULTIPLIER 5
+#define SHIFT_AMOUNT 2
+
+/* For looking up variable definitions */
+
+#define UNCOMPILED_REF TC_TRUE
+#define GLOBAL_REF TC_UNINTERNED_SYMBOL
+#define FORMAL_REF TC_FIXNUM
+#define AUX_REF TC_ENVIRONMENT
+#define LOCAL_REF TC_NULL
+/* LOCAL_REF must be 0 in order for code in interpret.c to work fast */
+
+/* For headers in pure / constant area */
+
+#define END_OF_BLOCK TC_FIXNUM
+#define CONSTANT_PART TC_TRUE
+#define PURE_PART TC_FALSE
+
+/* Primitive flow control codes: directs computation after
+ * processing a primitive application.
+ */
+#define PRIM_DONE -1
+#define PRIM_DO_EXPRESSION -2
+#define PRIM_APPLY -3
+#define PRIM_INTERRUPT -4
+#define PRIM_NO_TRAP_EVAL -5
+#define PRIM_NO_TRAP_APPLY -6
+#define PRIM_POP_RETURN -7
+\f
+/* Interrupt bits -- scanned from LSB (1) to MSB (16) */
+
+#define INT_Stack_Overflow 1 /* Local interrupt */
+#define INT_Global_GC 2
+#define INT_GC 4 /* Local interrupt */
+#define INT_Global_1 8
+#define INT_Character 16 /* Local interrupt */
+#define INT_Global_2 32
+#define INT_Timer 64 /* Local interrupt */
+#define INT_Global_3 128
+#define INT_Global_Mask \
+ (INT_Global_GC | INT_Global_1 | INT_Global_2 | INT_Global_3)
+#define Global_GC_Level 1
+#define Global_1_Level 3
+#define Global_2_Level 5
+#define Global_3_Level 7
+#define MAX_INTERRUPT_NUMBER 7
+
+#define INT_Mask ((1<<(MAX_INTERRUPT_NUMBER+1))-1)
+
+/* Error case detection for precomputed constants */
+/* VMS preprocessor does not like line continuations in conditionals */
+
+#define Are_The_Constants_Incompatible \
+((TC_NULL != 0x00) || (TC_TRUE != 0x08) || (TC_UNASSIGNED != 0x32) || \
+ (UNASSIGNED != 0) || (UNBOUND != 1) || (UNCOMPILED_REF != 0x08) || \
+ (TC_FIXNUM != 0x1A) || (TC_BROKEN_HEART != 0x22) || \
+ (TC_CHARACTER_STRING != 0x1E) || (LOCAL_REF != 0x00))
+
+/* The values used above are in sdata.h and types.h,
+ check for consistency if the check below fails. */
+
+#if Are_The_Constants_Incompatible
+#include "Error: disagreement in const.h"
+#endif
+
+/* These are the only entries in Registers[] needed by the microcode.
+ All other entries are used only by the compiled code interface. */
+
+#define REGBLOCK_MEMTOP 0
+#define REGBLOCK_STACKGUARD 1
+#define REGBLOCK_MINIMUM_LENGTH 2
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: fasl.h
+ Contains information relating to the format of FASL files.
+ Some information is contained in CONFIG.H.
+*/
+\f
+/* FASL Version */
+
+#define FASL_FILE_MARKER 0XFAFAFAFA
+#define FASL_FORMAT_ADDED_STACK 1
+#define FASL_FORMAT_VERSION 1
+#define FASL_SUBVERSION 5
+
+/* The FASL file has a header which begins as follows: */
+
+#define FASL_HEADER_LENGTH 50 /* Scheme objects in header */
+#define FASL_OLD_LENGTH 8 /* Size of header earlier */
+#define FASL_Offset_Marker 0 /* Marker to indicate FASL format */
+#define FASL_Offset_Heap_Count 1 /* Count of objects in heap */
+#define FASL_Offset_Heap_Base 2 /* Address of heap when dumped */
+#define FASL_Offset_Dumped_Obj 3 /* Where dumped object was */
+#define FASL_Offset_Const_Count 4 /* Count of objects in const. area */
+#define FASL_Offset_Const_Base 5 /* Address of const. area at dump */
+#define FASL_Offset_Version 6 /* FASL format version info. */
+#define FASL_Offset_Stack_Top 7 /* Top of stack when dumped */
+#define FASL_Offset_Ext_Loc 8 /* Where ext. prims. vector is */
+
+#define FASL_Offset_First_Free 9 /* Used to clear header */
+
+/* Version information encoding */
+
+#define MACHINE_TYPE_LENGTH (POINTER_LENGTH/2)
+#define MACHINE_TYPE_MASK ((1<<MACHINE_TYPE_LENGTH)-1)
+#define The_Machine_Type(P) ((P) & MACHINE_TYPE_MASK)
+#define SUB_VERSION_LENGTH (MACHINE_TYPE_LENGTH-TYPE_CODE_LENGTH)
+#define SUB_VERSION_MASK ((1<<SUB_VERSION_LENGTH)-1)
+#define The_Sub_Version(P) (((P) >> MACHINE_TYPE_LENGTH) & SUB_VERSION_MASK)
+#define The_Version(P) Type_Code(P)
+#define Make_Version(V, S, M) \
+ Make_Non_Pointer((V), (((S) << MACHINE_TYPE_LENGTH) | (M)))
+\f
+#define WRITE_FLAG "w"
+#define OPEN_FLAG "r"
+
+/* "Memorable" FASL sub-versions -- ones where we modified something
+ and want to remain backwards compatible
+*/
+
+#define FASL_OLDEST_SUPPORTED 2
+#define FASL_LONG_HEADER 3
+#define FASL_DENSE_TYPES 4
+#define FASL_PADDED_STRINGS 5
+
+/* Old Type Codes -- used for conversion purposes */
+
+#define OLD_TC_CHARACTER 0x40
+#define OLD_TC_PCOMB2 0x44
+#define OLD_TC_VECTOR 0x46
+#define OLD_TC_RETURN_CODE 0x48
+#define OLD_TC_COMPILED_PROCEDURE 0x49
+#define OLD_TC_ENVIRONMENT 0x4E
+#define OLD_TC_FIXNUM 0x50
+#define OLD_TC_CONTROL_POINT 0x56
+#define OLD_TC_BROKEN_HEART 0x58
+#define OLD_TC_COMBINATION 0x5E
+#define OLD_TC_MANIFEST_NM_VECTOR 0x60
+#define OLD_TC_PCOMB3 0x66
+#define OLD_TC_SPECIAL_NM_VECTOR 0x68
+#define OLD_TC_THE_ENVIRONMENT 0x70
+#define OLD_TC_VECTOR_1B 0x76
+#define OLD_TC_BIT_STRING 0x76
+#define OLD_TC_PCOMB0 0x78
+#define OLD_TC_VECTOR_16B 0x7E
+#define OLD_TC_UNASSIGNED 0x38
+#define OLD_TC_SEQUENCE_3 0x3C
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: FIXOBJ.H
+ *
+ * Declarations of user offsets into the Fixed Objects Vector.
+ * This should correspond to the file UTABMD.SCM
+ */
+\f
+#define Non_Object 0x00 /* Value for UNBOUND variables */
+#define System_Interrupt_Vector 0x01 /* Handlers for interrups */
+#define System_Error_Vector 0x02 /* Handlers for errors */
+#define OBArray 0x03 /* Array for interning symbols */
+#define Types_Vector 0x04 /* Type number -> Name map */
+#define Returns_Vector 0x05 /* Return code -> Name map */
+#define Primitives_Vector 0x06 /* Primitive code -> Name map */
+#define Errors_Vector 0x07 /* Error code -> Name map */
+#define Hash_Number 0x08 /* Next number for hashing */
+#define Hash_Table 0x09 /* Table for hashing objects */
+#define Unhash_Table 0x0A /* Inverse hash table */
+#define GC_Daemon 0x0B /* Procedure to run after GC */
+#define Trap_Handler 0x0C /* Continue after disaster */
+#define Open_Files 0x0D /* List of open files */
+#define Stepper_State 0x0E /* NOT IMPLEMENTED YET */
+#define Fixed_Objects_Slots 0x0F /* Names of these slots */
+#define External_Primitives 0x10 /* Names of external prims */
+#define State_Space_Tag 0x11 /* Tag for state spaces */
+#define State_Point_Tag 0x12 /* Tag for state points */
+#define Dummy_History 0x13 /* Empty history structure */
+#define Bignum_One 0x14 /* Cache for bignum one */
+#define System_Scheduler 0x15 /* Scheduler for touched futures */
+#define Termination_Vector 0x16 /* Names for terminations */
+#define Termination_Proc_Vector 0x17 /* Handlers for terminations */
+#define Me_Myself 0x18 /* The actual shared vector */
+/* The next slot is used only in multiprocessor mode */
+#define The_Work_Queue 0x19 /* Where work is stored */
+/* These two slots are only used if logging futures */
+#define Future_Logger 0x1A /* Routine to log touched futures */
+#define Touched_Futures 0x1B /* Vector of touched futures */
+#define Precious_Objects 0x1C /* Objects that should not be lost! */
+#define Error_Procedure 0x1D /* User invoked error handler */
+#define Unsnapped_Link 0x1E /* Handler for call to compiled code */
+#define Utilities_Vector 0x1F /* ??? */
+#define Compiler_Err_Procedure 0x20 /* ??? */
+#define Lost_Objects_Base 0x21 /* Free at the end of the "real" gc. */
+#define State_Space_Root 0x22 /* Root of state space */
+
+#define NFixed_Objects 0x23
+
--- /dev/null
+/* Emacs -*-C-*-an't tell the language */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: GCTYPE.C
+ *
+ * This file contains the table which maps between Types and
+ * GC Types.
+ *
+ */
+\f
+ /*********************************/
+ /* Mapping GC_Type to Type_Codes */
+ /*********************************/
+
+int GC_Type_Map[MAX_SAFE_TYPE + 1] = {
+ GC_Non_Pointer, /* TC_NULL,etc */
+ GC_Pair, /* TC_LIST */
+ GC_Non_Pointer, /* TC_CHARACTER */
+ GC_Pair, /* TC_SCODE_QUOTE */
+ GC_Triple, /* TC_PCOMB2 */
+ GC_Pair, /* TC_UNINTERNED_SYMBOL */
+ GC_Vector, /* TC_BIG_FLONUM */
+ GC_Pair, /* TC_COMBINATION_1 */
+ GC_Non_Pointer, /* TC_TRUE */
+ GC_Pair, /* TC_EXTENDED_PROCEDURE */
+ GC_Vector, /* TC_VECTOR */
+ GC_Non_Pointer, /* TC_RETURN_CODE */
+ GC_Triple, /* TC_COMBINATION_2 */
+ GC_Pair, /* TC_COMPILED_PROCEDURE */
+ GC_Vector, /* TC_BIG_FIXNUM */
+ GC_Pair, /* TC_PROCEDURE */
+ GC_Non_Pointer, /* TC_PRIMITIVE_EXTERNAL */
+ GC_Pair, /* TC_DELAY */
+ GC_Vector, /* TC_ENVIRONMENT */
+ GC_Pair, /* TC_DELAYED */
+ GC_Triple, /* TC_EXTENDED_LAMBDA */
+ GC_Pair, /* TC_COMMENT */
+ GC_Vector, /* TC_NON_MARKED_VECTOR */
+ GC_Pair, /* TC_LAMBDA */
+ GC_Non_Pointer, /* TC_PRIMITIVE */
+ GC_Pair, /* TC_SEQUENCE_2 */
+ GC_Non_Pointer, /* TC_FIXNUM */
+ GC_Pair, /* TC_PCOMB1 */
+ GC_Vector, /* TC_CONTROL_POINT */
+ GC_Pair, /* TC_INTERNED_SYMBOL */
+ GC_Vector, /* TC_CHARACTER_STRING,TC_VECTOR_8B */
+ GC_Pair, /* TC_ACCESS */
+ GC_Non_Pointer, /* TC_EXTENDED_FIXNUM */
+ GC_Pair, /* TC_DEFINITION */
+ GC_Special, /* TC_BROKEN_HEART */
+ GC_Pair, /* TC_ASSIGNMENT */
+ GC_Triple, /* TC_HUNK3 */
+ GC_Pair, /* TC_IN_PACKAGE */
+
+/* GC_Type_Map continues on next page */
+\f
+/* GC_Type_Map continued */
+
+ GC_Vector, /* TC_COMBINATION */
+ GC_Special, /* TC_MANIFEST_NM_VECTOR */
+ GC_Compiled, /* TC_COMPILED_EXPRESSION */
+ GC_Pair, /* TC_LEXPR */
+ GC_Vector, /* TC_PCOMB3 */
+ GC_Special, /* TC_MANIFEST_SPECIAL_NM_VECTOR */
+ GC_Triple, /* TC_VARIABLE */
+ GC_Non_Pointer, /* TC_THE_ENVIRONMENT */
+ GC_Vector, /* TC_FUTURE */
+ GC_Vector, /* TC_VECTOR_1B,TC_BIT_STRING */
+ GC_Non_Pointer, /* TC_PCOMB0 */
+ GC_Vector, /* TC_VECTOR_16B */
+ GC_Non_Pointer, /* TC_UNASSIGNED */
+ GC_Triple, /* TC_SEQUENCE_3 */
+ GC_Triple, /* TC_CONDITIONAL */
+ GC_Pair, /* TC_DISJUNCTION */
+ GC_Cell, /* TC_CELL */
+ GC_Pair, /* TC_WEAK_CONS */
+ GC_Triple, /* TC_TRAP */
+ GC_Compiled, /* TC_RETURN_ADDRESS */
+ GC_Pair, /* TC_COMPILER_LINK */
+ GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */
+ GC_Pair, /* TC_COMPLEX */
+ GC_Undefined, /* 0x3D */
+ GC_Undefined, /* 0x3E */
+ GC_Undefined, /* 0x3F */
+ GC_Undefined, /* 0x40 */
+ GC_Undefined, /* 0x41 */
+ GC_Undefined, /* 0x42 */
+ GC_Undefined, /* 0x43 */
+ GC_Undefined, /* 0x44 */
+ GC_Undefined, /* 0x45 */
+ GC_Undefined, /* 0x46 */
+ GC_Undefined, /* 0x47 */
+#if defined(MC68020)
+ GC_Non_Pointer, /* TC_PEA_INSTRUCTION */
+#else
+ GC_Undefined, /* 0x48 */
+#endif
+ GC_Undefined, /* 0x49 */
+ GC_Undefined, /* 0x4A */
+ GC_Undefined, /* 0x4B */
+ GC_Undefined, /* 0x4C */
+ GC_Undefined, /* 0x4D */
+#if defined(MC68020)
+ GC_Non_Pointer, /* TC_JMP_INSTRUCTION */
+#else
+ GC_Undefined, /* 0x4E */
+#endif
+ GC_Undefined, /* 0x4F */
+ GC_Undefined, /* 0x50 */
+#if defined(MC68020)
+ GC_Non_Pointer, /* TC_DBF_INSTRUCTION */
+#else
+ GC_Undefined, /* 0x51 */
+#endif
+ GC_Undefined, /* 0x52 */
+ GC_Undefined, /* 0x53 */
+ GC_Undefined, /* 0x54 */
+
+/* GC_Type_Map continues on next page */
+\f
+/* GC_Type_Map continued */
+
+ GC_Undefined, /* 0x55 */
+ GC_Undefined, /* 0x56 */
+ GC_Undefined, /* 0x57 */
+ GC_Undefined, /* 0x58 */
+ GC_Undefined, /* 0x59 */
+ GC_Undefined, /* 0x5A */
+ GC_Undefined, /* 0x5B */
+ GC_Undefined, /* 0x5C */
+ GC_Undefined, /* 0x5D */
+ GC_Undefined, /* 0x5E */
+ GC_Undefined, /* 0x5F */
+ GC_Undefined, /* 0x60 */
+ GC_Undefined, /* 0x61 */
+ GC_Undefined, /* 0x62 */
+ GC_Undefined, /* 0x63 */
+ GC_Undefined, /* 0x64 */
+ GC_Undefined, /* 0x65 */
+ GC_Undefined, /* 0x66 */
+ GC_Undefined, /* 0x67 */
+ GC_Undefined, /* 0x68 */
+ GC_Undefined, /* 0x69 */
+ GC_Undefined, /* 0x6A */
+ GC_Undefined, /* 0x6B */
+ GC_Undefined, /* 0x6C */
+ GC_Undefined, /* 0x6D */
+ GC_Undefined, /* 0x6E */
+ GC_Undefined, /* 0x6F */
+ GC_Undefined, /* 0x70 */
+ GC_Undefined, /* 0x71 */
+ GC_Undefined, /* 0x72 */
+ GC_Undefined, /* 0x73 */
+ GC_Undefined, /* 0x74 */
+ GC_Undefined, /* 0x75 */
+ GC_Undefined, /* 0x76 */
+ GC_Undefined, /* 0x77 */
+ GC_Undefined, /* 0x78 */
+ GC_Undefined, /* 0x79 */
+ GC_Undefined, /* 0x7A */
+ GC_Undefined, /* 0x7B */
+ GC_Undefined, /* 0x7C */
+ GC_Undefined, /* 0x7D */
+ GC_Undefined, /* 0x7E */
+ GC_Undefined /* 0x7F */
+ };
+
+#if (MAX_SAFE_TYPE != 0x7F)
+#include "gctype.c and scheme.h inconsistent -- GC_Type_Map"
+#endif
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: interpret.c
+ *
+ * This file contains the heart of the Scheme Scode
+ * interpreter
+ *
+ */
+
+#define In_Main_Interpreter true
+#include "scheme.h"
+#include "zones.h"
+\f
+/* In order to make the interpreter tail recursive (i.e.
+ * to avoid calling procedures and thus saving unnecessary
+ * state information), the main body of the interpreter
+ * is coded in a continuation passing style.
+ *
+ * Basically, this is done by dispatching on the type code
+ * for an Scode item. At each dispatch, some processing
+ * is done which may include setting the return address
+ * register, saving the current continuation (return address
+ * and current expression) and jumping to the start of
+ * the interpreter.
+ *
+ * It may be helpful to think of this program as being what
+ * you would get if you wrote the straightforward Scheme
+ * interpreter and then converted it into continuation
+ * passing style as follows. At every point where you would
+ * call EVAL to handle a sub-form, you put a jump back to
+ * Do_Expression. Now, if there was code after the call to
+ * EVAL you first push a "return code" (using Save_Cont) on
+ * the stack and move the code that used to be after the
+ * call down into the part of this file after the tag
+ * Pop_Return.
+ *
+ * Notice that because of the caller saves convention used
+ * here, all of the registers which are of interest have
+ * been SAVEd on the racks by the time interpretation arrives
+ * at Do_Expression (the top of EVAL).
+ *
+ * For notes on error handling and interrupts, see the file
+ * utils.c.
+ *
+ * This file is divided into two parts. The first
+ * corresponds is called the EVAL dispatch, and is ordered
+ * alphabetically by the SCode item handled. The second,
+ * called the return dispatch, begins at Pop_Return and is
+ * ordered alphabetically by return code name.
+ */
+\f
+#define Interrupt(Masked_Code) \
+ { Export_Registers(); \
+ Setup_Interrupt(Masked_Code); \
+ Import_Registers(); \
+ goto Perform_Application; \
+ }
+
+#define Immediate_GC(N) \
+ { Request_GC(N); \
+ Interrupt(IntCode & IntEnb); \
+ }
+
+#define Prepare_Eval_Repeat() \
+ {Will_Push(CONTINUATION_SIZE+1); \
+ Push(Fetch_Env()); \
+ Store_Return(RC_EVAL_ERROR); \
+ Save_Cont(); \
+ Pushed(); \
+ }
+
+#define Eval_GC_Check(Amount) \
+ if (GC_Check(Amount)) \
+ { Prepare_Eval_Repeat(); \
+ Immediate_GC(Amount); \
+ }
+
+#define Eval_Error(Err) \
+ { Export_Registers(); \
+ Do_Micro_Error(Err, false); \
+ Import_Registers(); \
+ goto Internal_Apply; \
+ }
+
+#define Pop_Return_Error(Err) \
+ { Export_Registers(); \
+ Do_Micro_Error(Err, true); \
+ Import_Registers(); \
+ goto Internal_Apply; \
+ }
+
+#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \
+ Store_Return(Return_Code); \
+ Val = Contents_of_Val; \
+ Save_Cont()
+\f
+#define Reduces_To(Expr) \
+ { Store_Expression(Expr); \
+ New_Reduction(Fetch_Expression(), Fetch_Env()); \
+ goto Do_Expression; \
+ }
+
+#define Reduces_To_Nth(N) \
+ Reduces_To(Fast_Vector_Ref(Fetch_Expression(), (N)))
+
+#define Do_Nth_Then(Return_Code, N, Extra) \
+ { Store_Return(Return_Code); \
+ Save_Cont(); \
+ Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \
+ New_Subproblem(Fetch_Expression(), Fetch_Env()); \
+ Extra; \
+ goto Do_Expression; \
+ }
+
+#define Do_Another_Then(Return_Code, N) \
+ { Store_Return(Return_Code); \
+ Save_Cont(); \
+ Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \
+ Reuse_Subproblem(Fetch_Expression(), Fetch_Env()); \
+ goto Do_Expression; \
+ }
+
+#define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT))
+
+/* This makes local variable references faster */
+
+#if (LOCAL_REF == 0)
+#define Local_Offset(Ind) Ind
+#else
+#define Local_Offset(Ind) Get_Integer(Ind)
+#endif
+\f
+#ifdef COMPILE_FUTURES
+#define Splice_Future_Value(The_Loc) \
+{ while ((Type_Code(Val) == TC_FUTURE) && (Future_Spliceable(Val))) \
+ { Pointer *Location; \
+ Val = Future_Value(Val); \
+ Location = The_Loc; \
+ if Dangerous(*Location) Set_Danger_Bit(Val); \
+ *Location = Val; \
+ Clear_Danger_Bit(Val); \
+ } \
+ Set_Time_Zone(Zone_Working); \
+ break; \
+}
+#else
+#define Splice_Future_Value(The_Loc) \
+{ Set_Time_Zone(Zone_Working); \
+ break; \
+}
+#endif
+
+#ifdef TRAP_ON_REFERENCE
+#define Trap(Value) (Safe_Type_Code(Value) == TC_TRAP)
+#else
+#define Trap(Value) false
+#endif
+
+#define MAGIC_RESERVE_SIZE 6 /* See SPMD.SCM */
+#define Reserve_Stack_Space() Will_Eventually_Push(MAGIC_RESERVE_SIZE)
+\f
+ /***********************/
+ /* Macros for Stepping */
+ /***********************/
+
+#define Fetch_Trapper(field) \
+ Vector_Ref(Get_Fixed_Obj_Slot(Stepper_State), (field))
+
+#define Fetch_Eval_Trapper() Fetch_Trapper(HUNK_CXR0)
+#define Fetch_Apply_Trapper() Fetch_Trapper(HUNK_CXR1)
+#define Fetch_Return_Trapper() Fetch_Trapper(HUNK_CXR2)
+\f
+/* Macros for handling FUTUREs */
+
+#ifdef COMPILE_FUTURES
+
+/* Arg_Type_Error handles the error returns from primitives which type check
+ their arguments and restarts them or suspends if the argument is a future. */
+
+#define Arg_Type_Error(Arg_No, Err_No) \
+{ fast Pointer *Arg = &(Stack_Ref(Arg_No-1)); \
+ fast Pointer Orig_Arg = *Arg; \
+ if (Type_Code(*Arg) != TC_FUTURE) Pop_Return_Error(Err_No); \
+ while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
+ { if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
+ *Arg = Future_Value(*Arg); \
+ } \
+ if (Type_Code(*Arg) != TC_FUTURE) goto Prim_No_Trap_Apply; \
+ Save_Cont(); \
+ Will_Push(STACK_ENV_EXTRA_SLOTS+2); \
+ Push(*Arg); /* Arg 1: The future itself */ \
+ Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
+ Push(STACK_FRAME_HEADER+1); \
+ Pushed(); \
+ *Arg = Orig_Arg; \
+ goto Apply_Non_Trapping; \
+}
+\f
+/* Apply_Future_Check is called at apply time to guarantee that certain
+ objects (the procedure itself, and its LAMBDA components for user defined
+ procedures) are not futures
+*/
+
+#define Apply_Future_Check(Name, Object) \
+{ fast Pointer *Arg = &(Object); \
+ fast Pointer Orig_Answer = *Arg; \
+ while (Type_Code(*Arg) == TC_FUTURE) \
+ { if (Future_Has_Value(*Arg)) \
+ { if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
+ *Arg = Future_Value(*Arg); \
+ } \
+ else \
+ { \
+ Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
+ Store_Return(RC_INTERNAL_APPLY); \
+ Val = NIL; \
+ Save_Cont(); \
+ Push(*Arg); \
+ Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
+ Push(STACK_FRAME_HEADER+1); \
+ Pushed(); \
+ *Arg = Orig_Answer; \
+ goto Internal_Apply; \
+ } \
+ } \
+ Name = *Arg; \
+}
+
+/* Future handling macros continue on the next page */
+\f
+/* Future handling macros, continued */
+
+/* Pop_Return_Val_Check suspends the process if the value calculated by
+ a recursive call to EVAL is an undetermined future */
+
+#define Pop_Return_Val_Check() \
+{ fast Pointer Orig_Val = Val; \
+ while (Type_Code(Val) == TC_FUTURE) \
+ { if (Future_Has_Value(Val)) \
+ { if (Future_Is_Keep_Slot(Val)) Log_Touch_Of_Future(Val); \
+ Val = Future_Value(Val); \
+ } \
+ else \
+ { Save_Cont(); \
+ Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
+ Store_Return(RC_RESTORE_VALUE); \
+ Store_Expression(Orig_Val); \
+ Save_Cont(); \
+ Push(Val); \
+ Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
+ Push(STACK_FRAME_HEADER+1); \
+ Pushed(); \
+ goto Internal_Apply; \
+ } \
+ } \
+}
+
+#else /* Not compiling FUTURES code */
+#define Pop_Return_Val_Check()
+#define Apply_Future_Check(Name, Object) Name = (Object)
+#define Arg_Type_Error(Arg_No, Err_No) Pop_Return_Error(Err_No)
+#endif
+\f
+/* The EVAL/APPLY ying/yang */
+
+void
+Interpret(dumped_p)
+ Boolean dumped_p;
+{ long Which_Way;
+ fast Pointer Reg_Val, Reg_Expression, *Reg_Stack_Pointer;
+ extern long enter_compiled_expression();
+ extern long apply_compiled_procedure();
+ extern long return_to_compiled_code();
+
+ /* Primitives jump back here for errors, requests to
+ * evaluate an expression, apply a function, or handle an
+ * interrupt request. On errors or interrupts they leave
+ * their arguments on the stack, the primitive itself in
+ * Expression, and a RESTART_PRIMITIVE continuation in the
+ * return register. In the other cases, they have removed
+ * their stack frames entirely.
+ */
+
+ Which_Way = setjmp(*Back_To_Eval);
+ Set_Time_Zone(Zone_Working);
+ Import_Registers();
+ if (Must_Report_References())
+ { Save_Cont();
+ Will_Push(CONTINUATION_SIZE + 2);
+ Push(Val);
+ Save_Env();
+ Store_Return(RC_REPEAT_DISPATCH);
+ Store_Expression(Make_Non_Pointer(TC_FIXNUM, Which_Way));
+ Save_Cont();
+ Pushed();
+ Call_Future_Logging();
+ }
+Repeat_Dispatch:
+ switch (Which_Way)
+ { case PRIM_APPLY: goto Internal_Apply;
+ case PRIM_NO_TRAP_APPLY: goto Apply_Non_Trapping;
+ case PRIM_DO_EXPRESSION: Reduces_To(Fetch_Expression());
+ case PRIM_NO_TRAP_EVAL: New_Reduction(Fetch_Expression(),Fetch_Env());
+ goto Eval_Non_Trapping;
+ case 0: if (!dumped_p) break; /* Else fall through */
+ case PRIM_POP_RETURN: goto Pop_Return;
+ default: Pop_Return_Error(Which_Way);
+ case PRIM_INTERRUPT:
+ { Save_Cont();
+ Interrupt(IntCode & IntEnb);
+ }
+ case ERR_ARG_1_WRONG_TYPE: Arg_Type_Error(1, ERR_ARG_1_WRONG_TYPE);
+ case ERR_ARG_2_WRONG_TYPE: Arg_Type_Error(2, ERR_ARG_2_WRONG_TYPE);
+ case ERR_ARG_3_WRONG_TYPE: Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE);
+ }
+\f
+ /*****************/
+ /* Do_Expression */
+ /*****************/
+
+Do_Expression:
+
+ if (Eval_Debug)
+ { Print_Expression(Fetch_Expression(), "Eval, expression");
+ CRLF();
+ }
+
+/* The expression register has an Scode item in it which
+ * should be evaluated and the result left in Val.
+ *
+ * A "break" after the code for any operation indicates that
+ * all processing for this operation has been completed, and
+ * the next step will be to pop a return code off the stack
+ * and proceed at Pop_Return. This is sometimes called
+ * "executing the continuation" since the return code can be
+ * considered the continuation to be performed after the
+ * operation.
+ *
+ * An operation can terminate with a Reduces_To or
+ * Reduces_To_Nth macro. This indicates that the value of
+ * the current S-Code item is the value returned when the
+ * new expression is evaluated. Therefore no new
+ * continuation is created and processing continues at
+ * Do_Expression with the new expression in the expression
+ * register.
+ *
+ * Finally, an operation can terminate with a Do_Nth_Then
+ * macro. This indicates that another expression must be
+ * evaluated and them some additional processing will be
+ * performed before the value of this S-Code item available.
+ * Thus a new continuation is created and placed on the
+ * stack (using Save_Cont), the new expression is placed in
+ * the Expression register, and processing continues at
+ * Do_Expression.
+ */
+\f
+/* Handling of Eval Trapping.
+
+ If we are handling traps and there is an Eval Trap set,
+ turn off all trapping and then go to Internal_Apply to call the
+ user supplied eval hook with the expression to be evaluated and the
+ environment.
+
+*/
+
+ if (Microcode_Does_Stepping && Trapping &&
+ (Fetch_Eval_Trapper() != NIL))
+ { Stop_Trapping();
+ Will_Push(4);
+ Push(Fetch_Env());
+ Push(Fetch_Expression());
+ Push(Fetch_Eval_Trapper());
+ Push(STACK_FRAME_HEADER+2);
+ Pushed();
+ goto Apply_Non_Trapping;
+ }
+\f
+Eval_Non_Trapping:
+ Eval_Ucode_Hook();
+ switch (Type_Code(Fetch_Expression()))
+ { case TC_BIG_FIXNUM: /* The self evaluating items */
+ case TC_BIG_FLONUM:
+ case TC_CHARACTER_STRING:
+ case TC_CHARACTER:
+ case TC_COMPILED_PROCEDURE:
+ case TC_CONTROL_POINT:
+ case TC_DELAYED:
+ case TC_ENVIRONMENT:
+ case TC_EXTENDED_FIXNUM:
+ case TC_EXTENDED_PROCEDURE:
+ case TC_FIXNUM:
+ case TC_HUNK3:
+ case TC_LIST:
+ case TC_NON_MARKED_VECTOR:
+ case TC_NULL:
+ case TC_PRIMITIVE:
+ case TC_PRIMITIVE_EXTERNAL:
+ case TC_PROCEDURE:
+ case TC_UNINTERNED_SYMBOL:
+ case TC_INTERNED_SYMBOL:
+ case TC_TRUE:
+ case TC_UNASSIGNED:
+ case TC_VECTOR:
+ case TC_VECTOR_16B:
+ case TC_VECTOR_1B:
+ Val = Fetch_Expression(); break;
+
+ case TC_ACCESS:
+ Will_Push(CONTINUATION_SIZE);
+ Do_Nth_Then(RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT, Pushed());
+
+ case TC_ASSIGNMENT:
+ Will_Push(CONTINUATION_SIZE + 1);
+ Save_Env();
+ Do_Nth_Then(RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE, Pushed());
+
+ case TC_BROKEN_HEART:
+ Export_Registers();
+ Microcode_Termination(TERM_BROKEN_HEART);
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_COMBINATION:
+ { long Array_Length = Vector_Length(Fetch_Expression())-1;
+ Eval_GC_Check(New_Stacklet_Size(Array_Length+1+1+CONTINUATION_SIZE));
+ Will_Push(Array_Length + 1+1+CONTINUATION_SIZE); /* Save_Env, Finger */
+ Stack_Pointer = Simulate_Pushing(Array_Length);
+ Push(Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Array_Length));
+ /* The finger: last argument number */
+ Pushed();
+ if (Array_Length == 0)
+ { Push(STACK_FRAME_HEADER); /* Frame size */
+ Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {});
+ }
+ Save_Env();
+ Do_Nth_Then(RC_COMB_SAVE_VALUE, Array_Length+1, {});
+ }
+
+ case TC_COMBINATION_1:
+ Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+2+CONTINUATION_SIZE */
+ Save_Env();
+ Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1, {});
+
+ case TC_COMBINATION_2:
+ Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+3+CONTINUATION_SIZE */
+ Save_Env();
+ Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {});
+
+ case TC_COMMENT:
+ Reduces_To_Nth(COMMENT_EXPRESSION);
+
+ case TC_CONDITIONAL:
+ Will_Push(CONTINUATION_SIZE + 1);
+ Save_Env();
+ Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE, Pushed());
+
+ case TC_COMPILED_EXPRESSION:
+ execute_compiled_setup();
+ Store_Expression( (Pointer) Get_Pointer( Fetch_Expression()));
+ Export_Registers();
+ Which_Way = enter_compiled_expression();
+ goto return_from_compiled_code;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_DEFINITION:
+ Will_Push(CONTINUATION_SIZE + 1);
+ Save_Env();
+ Do_Nth_Then(RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE, Pushed());
+
+ case TC_DELAY:
+ /* Deliberately omitted: Eval_GC_Check(2); */
+ Val = Make_Pointer(TC_DELAYED, Free);
+ Free[THUNK_ENVIRONMENT] = Fetch_Env();
+ Free[THUNK_PROCEDURE] =
+ Fast_Vector_Ref(Fetch_Expression(), DELAY_OBJECT);
+ Free += 2;
+ break;
+
+ case TC_DISJUNCTION:
+ Will_Push(CONTINUATION_SIZE + 1);
+ Save_Env();
+ Do_Nth_Then(RC_DISJUNCTION_DECIDE, OR_PREDICATE, Pushed());
+
+ case TC_EXTENDED_LAMBDA: /* Close the procedure */
+ /* Deliberately omitted: Eval_GC_Check(2); */
+ Val = Make_Pointer(TC_EXTENDED_PROCEDURE, Free);
+ Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
+ Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
+ Free += 2;
+ break;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+#ifdef COMPILE_FUTURES
+ case TC_FUTURE:
+ if (Future_Has_Value(Fetch_Expression()))
+ { Pointer Future = Fetch_Expression();
+ if (Future_Is_Keep_Slot(Future)) Log_Touch_Of_Future(Future);
+ Reduces_To_Nth(FUTURE_VALUE);
+ }
+ Prepare_Eval_Repeat();
+ Will_Push(STACK_ENV_EXTRA_SLOTS+2);
+ Push(Fetch_Expression()); /* Arg: FUTURE object */
+ Push(Get_Fixed_Obj_Slot(System_Scheduler));
+ Push(STACK_FRAME_HEADER+1);
+ Pushed();
+ goto Internal_Apply;
+#endif
+
+ case TC_IN_PACKAGE:
+ Will_Push(CONTINUATION_SIZE);
+ Do_Nth_Then(RC_EXECUTE_IN_PACKAGE_CONTINUE,
+ IN_PACKAGE_ENVIRONMENT, Pushed());
+
+ case TC_LAMBDA: /* Close the procedure */
+ case TC_LEXPR:
+ /* Deliberately omitted: Eval_GC_Check(2); */
+ Val = Make_Pointer(TC_PROCEDURE, Free);
+ Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
+ Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
+ Free += 2;
+ break;
+
+ case TC_MANIFEST_NM_VECTOR:
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ Eval_Error(ERR_EXECUTE_MANIFEST_VECTOR);
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_PCOMB0:
+ /* In case we back out */
+ Reserve_Stack_Space(); /* CONTINUATION_SIZE */
+ Finished_Eventual_Pushing(); /* of this primitive */
+/* ASSUMPTION: The syntaxer is hereby assumed NEVER to generate primitive
+ combinations unless the primitive itself is output in the code stream.
+ Therefore, we don't have to explicitly check here that the expression
+ register has a primitive in it.
+*/
+Primitive_Internal_Apply:
+ if (Microcode_Does_Stepping && Trapping &&
+ (Fetch_Apply_Trapper() != NIL))
+ {Will_Push(3);
+ Push(Fetch_Expression());
+ Push(Fetch_Apply_Trapper());
+ Push(STACK_FRAME_HEADER + 1 + N_Args_Primitive(Fetch_Expression()));
+ Pushed();
+ Stop_Trapping();
+ goto Apply_Non_Trapping;
+ }
+Prim_No_Trap_Apply:
+ Export_Registers();
+ Metering_Apply_Primitive(Val, Get_Integer(Fetch_Expression()));
+
+/* Any primitive which does not do a long jump can have it's primitive
+ frame popped off here. At this point, it is guaranteed that the
+ primitive is in the expression register in case the primitive needs
+ to back out.
+*/
+ Import_Registers_Except_Val();
+ Pop_Primitive_Frame(N_Args_Primitive(Fetch_Expression()));
+ if (Must_Report_References())
+ { Store_Expression(Val);
+ Store_Return(RC_RESTORE_VALUE);
+ Save_Cont();
+ Call_Future_Logging();
+ }
+ break;
+\f
+ case TC_PCOMB1:
+ Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */
+ Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {});
+
+ case TC_PCOMB2:
+ Reserve_Stack_Space(); /* 2+CONTINUATION_SIZE */
+ Save_Env();
+ Do_Nth_Then(RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT, {});
+
+ case TC_PCOMB3:
+ Reserve_Stack_Space(); /* 3+CONTINUATION_SIZE */
+ Save_Env();
+ Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {});
+
+ case TC_SCODE_QUOTE:
+ Val = Fast_Vector_Ref(Fetch_Expression(), SCODE_QUOTE_OBJECT);
+ break;
+
+ case TC_SEQUENCE_2:
+ Will_Push(CONTINUATION_SIZE + 1);
+ Save_Env();
+ Do_Nth_Then(RC_SEQ_2_DO_2, SEQUENCE_1, Pushed());
+
+ case TC_SEQUENCE_3:
+ Will_Push(CONTINUATION_SIZE + 1);
+ Save_Env();
+ Do_Nth_Then(RC_SEQ_3_DO_2, SEQUENCE_1, Pushed());
+
+ case TC_THE_ENVIRONMENT:
+ Val = Fetch_Env(); break;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_VARIABLE:
+/* ASSUMPTION: The SYMBOL slot does NOT contain a future */
+ { fast Pointer Compilation_Type, *Variable_Object;
+ int The_Type;
+
+ Set_Time_Zone(Zone_Lookup);
+#ifndef No_In_Line_Lookup
+
+ Variable_Object = Get_Pointer(Fetch_Expression());
+ Compilation_Type = Variable_Object[VARIABLE_COMPILED_TYPE];
+ The_Type = Type_Code(Compilation_Type);
+
+ if (The_Type == LOCAL_REF)
+ { fast Pointer *Frame;
+ Frame = Get_Pointer(Fetch_Env());
+ Val = Without_Danger_Bit(Frame[Local_Offset(Compilation_Type)]);
+ if (!Trap(Val))
+ Splice_Future_Value(&(Frame[Local_Offset(Compilation_Type)]));
+ }
+ else if (The_Type == GLOBAL_REF)
+ { Val = Vector_Ref(Compilation_Type, SYMBOL_GLOBAL_VALUE);
+ if (Dangerous(Val))
+ Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
+ else if (!Trap(Val))
+ Splice_Future_Value(Nth_Vector_Loc(Compilation_Type,
+ SYMBOL_GLOBAL_VALUE));
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ else if (The_Type == FORMAL_REF)
+ { fast long Frame_No;
+ fast Pointer *Frame;
+
+ Frame = Get_Pointer(Fetch_Env());
+ Frame_No = Get_Integer(Variable_Object[VARIABLE_FRAME_NO]);
+ while(--Frame_No >= 0)
+ Frame = Get_Pointer(Fast_Vector_Ref(Frame[HEAP_ENV_FUNCTION],
+ PROCEDURE_ENVIRONMENT));
+ Val = Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])];
+ if (Dangerous(Val))
+ Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
+ else if (!Trap(Val))
+ Splice_Future_Value(
+ &(Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])]));
+ }
+#endif
+ /* Fall through in cases not handled above */
+ { long Result;
+ Result = Lex_Ref(Fetch_Env(), Fetch_Expression());
+ Import_Val();
+ Set_Time_Zone(Zone_Working);
+ if (Result == PRIM_DONE) break;
+ Eval_Error(Result);
+ }
+ }
+
+ case TC_RETURN_CODE:
+ default: Eval_Error(ERR_UNDEFINED_USER_TYPE);
+ };
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+/* Now restore the continuation saved during an earlier part
+ * of the EVAL cycle and continue as directed.
+ */
+
+Pop_Return:
+ Pop_Return_Ucode_Hook();
+ Restore_Cont();
+ if (Consistency_Check &&
+ (Type_Code(Fetch_Return()) != TC_RETURN_CODE))
+ { Push(Val); /* For possible stack trace */
+ Save_Cont();
+ Export_Registers();
+ Microcode_Termination(TERM_BAD_STACK);
+ }
+ if (Eval_Debug)
+ { Print_Return("Pop_Return, return code");
+ Print_Expression(Val, "Pop_Return, value");
+ CRLF();
+ };
+
+ /* Dispatch on the return code. A BREAK here will cause
+ * a "goto Pop_Return" to occur, since this is the most
+ * common occurrence.
+ */
+
+ switch (Get_Integer(Fetch_Return()))
+ { case RC_COMB_1_PROCEDURE:
+ Restore_Env();
+ Push(Val); /* Arg. 1 */
+ Push(NIL); /* Operator */
+ Push(STACK_FRAME_HEADER+1);
+ Finished_Eventual_Pushing();
+ Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN);
+
+ case RC_COMB_2_FIRST_OPERAND:
+ Restore_Env();
+ Push(Val);
+ Save_Env();
+ Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_COMB_2_PROCEDURE:
+ Restore_Env();
+ Push(Val); /* Arg 1, just calculated */
+ Push(NIL); /* Function */
+ Push(STACK_FRAME_HEADER+2);
+ Finished_Eventual_Pushing();
+ Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN);
+
+ case RC_COMB_APPLY_FUNCTION:
+ End_Subproblem();
+ Stack_Ref(STACK_ENV_FUNCTION) = Val;
+ goto Internal_Apply;
+
+ case RC_COMB_SAVE_VALUE:
+ { long Arg_Number;
+
+ Restore_Env();
+ Arg_Number = Get_Integer(Stack_Ref(STACK_COMB_FINGER))-1;
+ Stack_Ref(STACK_COMB_FIRST_ARG+Arg_Number) = Val;
+ Stack_Ref(STACK_COMB_FINGER) =
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Arg_Number);
+ /* DO NOT count on the type code being NMVector here, since
+ the stack parser may create them with NIL here! */
+ if (Arg_Number > 0)
+ { Save_Env();
+ Do_Another_Then(RC_COMB_SAVE_VALUE,
+ (COMB_ARG_1_SLOT - 1) + Arg_Number);
+ }
+ Push(Fast_Vector_Ref(Fetch_Expression(), 0)); /* Frame Size */
+ Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+#define define_compiler_restart( return_code, entry) \
+ case return_code: \
+ { extern long entry(); \
+ compiled_code_restart(); \
+ Export_Registers(); \
+ Which_Way = entry(); \
+ goto return_from_compiled_code; \
+ }
+
+ define_compiler_restart( RC_COMPILER_INTERRUPT_RESTART,
+ compiler_interrupt_restart)
+
+ define_compiler_restart( RC_COMPILER_LEXPR_INTERRUPT_RESTART,
+ compiler_lexpr_interrupt_restart)
+
+ define_compiler_restart( RC_COMPILER_LOOKUP_APPLY_RESTART,
+ compiler_lookup_apply_restart)
+
+ define_compiler_restart( RC_COMPILER_REFERENCE_RESTART,
+ compiler_reference_restart)
+
+ define_compiler_restart( RC_COMPILER_ACCESS_RESTART,
+ compiler_access_restart)
+
+ define_compiler_restart( RC_COMPILER_UNASSIGNED_P_RESTART,
+ compiler_unassigned_p_restart)
+
+ define_compiler_restart( RC_COMPILER_UNBOUND_P_RESTART,
+ compiler_unbound_p_restart)
+
+ define_compiler_restart( RC_COMPILER_ASSIGNMENT_RESTART,
+ compiler_assignment_restart)
+
+ define_compiler_restart( RC_COMPILER_DEFINITION_RESTART,
+ compiler_definition_restart)
+
+ case RC_REENTER_COMPILED_CODE:
+ compiled_code_restart();
+ Export_Registers();
+ Which_Way = return_to_compiled_code();
+ goto return_from_compiled_code;
+\f
+ case RC_CONDITIONAL_DECIDE:
+ Pop_Return_Val_Check();
+ End_Subproblem();
+ Restore_Env();
+ Reduces_To_Nth((Val==NIL)? COND_ALTERNATIVE : COND_CONSEQUENT);
+
+ case RC_DISJUNCTION_DECIDE:
+ /* Return predicate if it isn't NIL; else do ALTERNATIVE */
+ Pop_Return_Val_Check();
+ End_Subproblem();
+ Restore_Env();
+ if (Val != NIL) goto Pop_Return;
+ Reduces_To_Nth(OR_ALTERNATIVE);
+
+ case RC_END_OF_COMPUTATION:
+ /* Signals bottom of stack */
+ Export_Registers();
+ Microcode_Termination(TERM_END_OF_COMPUTATION);
+
+ case RC_EVAL_ERROR:
+ Store_Env(Pop());
+ Reduces_To(Fetch_Expression());
+
+ case RC_EXECUTE_ACCESS_FINISH:
+ { long Result;
+ Pop_Return_Val_Check();
+ if (Environment_P(Val))
+ { Result = Symbol_Lex_Ref(Val,
+ Fast_Vector_Ref(Fetch_Expression(), ACCESS_NAME));
+ Import_Val();
+ if (Result != PRIM_DONE) Pop_Return_Error(Result);
+ End_Subproblem();
+ break;
+ }
+ Pop_Return_Error(ERR_BAD_FRAME);
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_EXECUTE_ASSIGNMENT_FINISH:
+ { fast Pointer Compilation_Type, *Variable_Object;
+ Pointer The_Non_Object, Store_Value;
+ int The_Type;
+
+ Set_Time_Zone(Zone_Lookup);
+ Restore_Env();
+ The_Non_Object = Get_Fixed_Obj_Slot(Non_Object);
+ Store_Value = (Val == The_Non_Object) ? UNASSIGNED_OBJECT : Val;
+
+#ifndef No_In_Line_Lookup
+
+ Variable_Object =
+ Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
+ Compilation_Type = Variable_Object[VARIABLE_COMPILED_TYPE];
+ The_Type = Type_Code(Compilation_Type);
+
+ if (The_Type == LOCAL_REF)
+ { fast Pointer *Frame;
+ Frame = Get_Pointer(Fetch_Env());
+ Val = Frame[Local_Offset(Compilation_Type)];
+ if (Dangerous(Val))
+ { Set_Danger_Bit(Store_Value);
+ Clear_Danger_Bit(Val);
+ }
+ if (!Trap(Val))
+ { Frame[Local_Offset(Compilation_Type)] = Store_Value;
+ if (Val == UNASSIGNED_OBJECT) Val = The_Non_Object;
+ Set_Time_Zone(Zone_Working);
+ End_Subproblem();
+ break;
+ }
+ }
+ else if (The_Type == GLOBAL_REF)
+ { Val = Vector_Ref(Compilation_Type, SYMBOL_GLOBAL_VALUE);
+ if (!Dangerous(Val) && !Trap(Val))
+ { Vector_Set(Compilation_Type, SYMBOL_GLOBAL_VALUE, Store_Value);
+ if (Val == UNASSIGNED_OBJECT) Val = The_Non_Object;
+ Set_Time_Zone(Zone_Working);
+ End_Subproblem();
+ break;
+ }
+ else if (Dangerous(Val))
+ Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ else if (The_Type == FORMAL_REF)
+ { fast long Frame_No;
+ fast Pointer *Frame;
+
+ Frame = Get_Pointer(Fetch_Env());
+ Frame_No = Get_Integer(Variable_Object[VARIABLE_FRAME_NO]);
+ while(--Frame_No >= 0)
+ Frame = Get_Pointer(Fast_Vector_Ref(Frame[HEAP_ENV_FUNCTION],
+ PROCEDURE_ENVIRONMENT));
+ Val = Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])];
+ if (!Dangerous(Val) && !Trap(Val))
+ { Frame[Local_Offset(Variable_Object[VARIABLE_OFFSET])] =
+ Store_Value;
+ if (Val==UNASSIGNED_OBJECT) Val = The_Non_Object;
+ Set_Time_Zone(Zone_Working);
+ End_Subproblem();
+ break;
+ }
+ else if (Dangerous(Val))
+ Variable_Object[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
+ }
+#endif
+ /* Fall through in cases not handled above */
+ { long Result;
+ Result = Lex_Set(Fetch_Env(),
+ Vector_Ref(Fetch_Expression(), ASSIGN_NAME),
+ Store_Value);
+ Import_Val();
+ Set_Time_Zone(Zone_Working);
+ if (Result == PRIM_DONE)
+ { End_Subproblem();
+ break;
+ }
+ Save_Env();
+ Pop_Return_Error(Result);
+ }
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_EXECUTE_DEFINITION_FINISH:
+ { Pointer Saved_Val;
+ long Result;
+
+ Saved_Val = Val;
+ Restore_Env();
+ Result = Local_Set(Fetch_Env(),
+ Fast_Vector_Ref(Fetch_Expression(), DEFINE_NAME),
+ Val);
+ Import_Val();
+ if (Result==PRIM_DONE)
+ { End_Subproblem();
+ break;
+ }
+ Save_Env();
+ if (Result==PRIM_INTERRUPT)
+ { Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH,
+ Saved_Val);
+ Interrupt(IntCode & IntEnb);
+ }
+ Pop_Return_Error(Result);
+ };
+
+ case RC_EXECUTE_IN_PACKAGE_CONTINUE:
+ Pop_Return_Val_Check();
+ if (Environment_P(Val))
+ { End_Subproblem();
+ Store_Env(Val);
+ Reduces_To_Nth(IN_PACKAGE_EXPRESSION);
+ }
+ Pop_Return_Error(ERR_BAD_FRAME);
+\f
+#ifdef COMPILE_FUTURES
+ case RC_FINISH_GLOBAL_INT:
+ Export_Registers();
+ Val = Global_Int_Part_2(Fetch_Expression(), Val);
+ Import_Registers_Except_Val();
+ break;
+#endif
+
+ case RC_GC_CHECK:
+ if (Get_Integer(Fetch_Expression()) > Space_Before_GC())
+ {
+ Export_Registers();
+ Microcode_Termination(TERM_GC_OUT_OF_SPACE);
+ }
+ break;
+
+ case RC_HALT:
+ Export_Registers();
+ Microcode_Termination(TERM_TERM_HANDLER);
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+#define Prepare_Apply_Interrupt() \
+ Prepare_Pop_Return_Interrupt(RC_INTERNAL_APPLY, NIL)
+
+#define Apply_Error(N) \
+ { Store_Return(RC_INTERNAL_APPLY); \
+ Val = NIL; \
+ Pop_Return_Error(N); \
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_INTERNAL_APPLY:
+Internal_Apply:
+
+/* Branch here to perform a function application. At this point
+ it is necessary that the top of the stack contain a frame
+ for evaluation of the function to be applied. This frame
+ DOES NOT contain "finger" and "combination" slots, although
+ if the frame is to be copied into the heap, it will have NIL's
+ in the "finger" and "combination" slots which will correspond
+ to "potentially-dangerous" and "auxilliary variables" slots.
+
+ Note, also, that unlike most return codes Val is not used here.
+ Thus, the error and interrupt macros above set it to NIL so that it
+ will not 'hold on' to anything if a GC occurs. Similarly, the
+ contents of Expression are discarded.
+*/
+ if (Microcode_Does_Stepping && Trapping &&
+ (Fetch_Apply_Trapper() != NIL))
+ { long Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER));
+ Top_Of_Stack() = Fetch_Apply_Trapper();
+ Push(STACK_FRAME_HEADER+Count);
+ Stop_Trapping();
+ }
+Apply_Non_Trapping:
+ { long Interrupts;
+ Pointer Function;
+
+ Store_Expression(NIL);
+ Interrupts = IntCode & IntEnb;
+ if (Interrupts != 0)
+ { Prepare_Apply_Interrupt();
+ Interrupt(Interrupts);
+ }
+
+Perform_Application:
+ Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION));
+ Apply_Ucode_Hook();
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ switch(Type_Code(Function))
+ { case TC_PROCEDURE:
+ { Pointer Lambda_Expr, *Temp1, Temp2;
+ long NParams, Size;
+ fast long NArgs;
+
+ Apply_Future_Check(Lambda_Expr,
+ Fast_Vector_Ref(Function,
+ PROCEDURE_LAMBDA_EXPR));
+ Temp1 = Get_Pointer(Lambda_Expr);
+ Apply_Future_Check(Temp2, Temp1[LAMBDA_FORMALS]);
+ NArgs = Get_Integer(Pop());
+ NParams = Vector_Length(Temp2);
+ if (Eval_Debug)
+ { Print_Expression(FIXNUM_0+NArgs,
+ "APPLY: Number of arguments");
+ Print_Expression(FIXNUM_0+NParams,
+ " Number of parameters");
+ }
+ if (Type_Code(Lambda_Expr) == TC_LAMBDA)
+ { if (NArgs != NParams)
+ { Push(STACK_FRAME_HEADER+NArgs-1);
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+ }
+ else if (NArgs < NParams)
+ { Push(STACK_FRAME_HEADER+NArgs-1);
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+ Size = NArgs + (HEAP_ENV_EXTRA_SLOTS - 1);
+ if (GC_Check(Size))
+ { Push(STACK_FRAME_HEADER+NArgs-1);
+ Prepare_Apply_Interrupt();
+ Immediate_GC(Size);
+ }
+ /* Store Environment Frame into heap, putting extra slots
+ for Potentially Dangerous and Auxiliaries */
+ Store_Env(Make_Pointer(TC_ENVIRONMENT, Free));
+ *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size);
+ *Free++ = NIL; /* For PD list and Aux list */
+ *Free++ = NIL;
+ for (; --NArgs >= 0; ) *Free++ = Pop();
+ Reduces_To(Temp1[LAMBDA_SCODE]);
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_CONTROL_POINT:
+ if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
+ STACK_ENV_FIRST_ARG)
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS)
+ Val = Stack_Ref(STACK_ENV_FIRST_ARG);
+ Our_Throw(false, Function);
+ Apply_Stacklet_Backout();
+ Our_Throw_Part_2();
+ goto Pop_Return;
+
+ case TC_PRIMITIVE_EXTERNAL:
+ { long NArgs, Proc = Datum(Function);
+ if (Proc > MAX_EXTERNAL_PRIMITIVE)
+ Apply_Error(ERR_UNDEFINED_PRIMITIVE);
+ NArgs = Ext_Prim_Desc[Proc].arity;
+ if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
+ STACK_ENV_FIRST_ARG+NArgs-1)
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
+ /* Remove the frame overhead, since the primitives
+ just expect arguments on the stack */
+ Store_Expression(Function);
+Repeat_External_Primitive:
+ /* Reinitialize Proc in case we "goto Repeat_External..." */
+ Proc = Get_Integer(Fetch_Expression());
+ Export_Registers();
+ Val = (*(Ext_Prim_Desc[Proc].proc))();
+ Set_Time_Zone(Zone_Working);
+ Import_Registers_Except_Val();
+ Pop_Primitive_Frame(Ext_Prim_Desc[Proc].arity);
+ goto Pop_Return;
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_EXTENDED_PROCEDURE:
+ { Pointer Lambda_Expr, *List_Car, Temp;
+ long NArgs, NParams, Formals, Params, Auxes,
+ Rest_Flag, Size, i;
+
+/* Selectors for the various parts */
+
+#define Get_Body_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_SCODE))
+#define Get_Names_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_NAMES))
+#define Get_Count_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_ARG_COUNT))
+#define Elambda_Formals_Count(Addr) \
+ ((((long) Addr) & EL_FORMALS_MASK) >> EL_FORMALS_SHIFT)
+#define Elambda_Opts_Count(Addr) \
+ (((long) Addr) & EL_OPTS_MASK)
+#define Elambda_Rest_Flag(Addr) \
+ ((((long) Addr) & EL_REST_MASK) >> EL_REST_SHIFT)
+
+ Apply_Future_Check(Lambda_Expr,
+ Fast_Vector_Ref(Function,
+ PROCEDURE_LAMBDA_EXPR));
+ Apply_Future_Check(Temp, Fast_Vector_Ref(Lambda_Expr,
+ ELAMBDA_NAMES));
+ NParams = Vector_Length(Temp) - 1;
+ Apply_Future_Check(Temp, Get_Count_Elambda(Lambda_Expr));
+ Formals = Elambda_Formals_Count(Temp);
+ /* Formals DOES NOT include the name of the lambda */
+ Params = Elambda_Opts_Count(Temp) + Formals;
+ Rest_Flag = Elambda_Rest_Flag(Temp);
+ NArgs = Get_Integer(Pop()) - 1;
+ Auxes = NParams - (Params + Rest_Flag);
+ if ((NArgs < Formals) ||
+ (!Rest_Flag && (NArgs > Params)))
+ { Push(STACK_FRAME_HEADER+NArgs);
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ Size = Params + Rest_Flag + Auxes +
+ (HEAP_ENV_EXTRA_SLOTS + 1);
+ List_Car = Free + Size;
+ if (GC_Check(Size + ((NArgs > Params) ?
+ 2 * (NArgs - Params) : 0)))
+ { Push(STACK_FRAME_HEADER+NArgs);
+ Prepare_Apply_Interrupt();
+ Immediate_GC(Size + ((NArgs > Params) ?
+ 2 * (NArgs - Params) : 0));
+ }
+ Store_Env(Make_Pointer(TC_ENVIRONMENT, Free));
+ *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Size-1);
+ /* Environment Header */
+ *Free++ = NIL; /* Aux list */
+ *Free++ = NIL; /* PD list */
+ Size = 1 + ((NArgs < Params) ? NArgs : Params);
+ for (i = 0; i < Size; i++) *Free++ = Pop();
+ for (i--; i < Params; i++)
+ *Free++ = UNASSIGNED_OBJECT;
+ if (Rest_Flag)
+ if (NArgs <= i) *Free++ = NIL;
+ else
+ { *Free++ = Make_Pointer(TC_LIST, List_Car);
+ for (; i < NArgs; i++, List_Car++)
+ { *List_Car++ = Pop();
+ *List_Car = Make_Pointer(TC_LIST, List_Car+1);
+ }
+ List_Car[-1] = NIL;
+ }
+ for (i = 0; i < Auxes; i++) *Free++ = UNASSIGNED_OBJECT;
+ Free = List_Car;
+ Reduces_To(Get_Body_Elambda(Lambda_Expr));
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_PRIMITIVE:
+ { long Number_Of_Args = N_Args_Primitive(Function);
+ if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
+ STACK_ENV_FIRST_ARG+Number_Of_Args-1)
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
+ /* Remove the frame overhead, since the primitives
+ just expect arguments on the stack */
+ Store_Expression(Function);
+ goto Prim_No_Trap_Apply;
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case TC_COMPILED_PROCEDURE:
+ { apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
+ Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
+ Export_Registers();
+ Which_Way = apply_compiled_procedure();
+
+return_from_compiled_code:
+ Import_Registers();
+ switch (Which_Way)
+ {
+ case PRIM_DONE:
+ { compiled_code_done();
+ goto Pop_Return;
+ }
+
+ case PRIM_APPLY:
+ { compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS +
+ Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
+ goto Internal_Apply;
+ }
+
+ case ERR_COMPILED_CODE_ERROR:
+ { /* The compiled code is signalling a microcode error. */
+ compiled_error_backout();
+ /* The Save_Cont is done by Pop_Return_Error. */
+ Pop_Return_Error( compiled_code_error_code);
+ }
+
+ case PRIM_INTERRUPT:
+ { compiled_error_backout();
+ Save_Cont();
+ Interrupt( (IntCode & IntEnb));
+ }
+\f
+ case ERR_WRONG_NUMBER_OF_ARGUMENTS:
+ { apply_compiled_backout();
+ Apply_Error( Which_Way);
+ }
+
+ case ERR_EXECUTE_MANIFEST_VECTOR:
+ { /* This error code means that enter_compiled_expression
+ was called in a system without compiler support.
+ */
+ execute_compiled_backout();
+ Val = Make_Non_Pointer( TC_COMPILED_EXPRESSION,
+ Fetch_Expression());
+ Pop_Return_Error( Which_Way);
+ }
+
+ case ERR_INAPPLICABLE_OBJECT:
+ { /* This error code means that apply_compiled_procedure
+ was called in a system without compiler support.
+ */
+ apply_compiled_backout();
+ Apply_Error( Which_Way);
+ }
+
+ case ERR_INAPPLICABLE_CONTINUATION:
+ { /* This error code means that return_to_compiled_code
+ or some other compiler continuation was called in a
+ system without compiler support.
+ */
+ Store_Expression(NIL);
+ Store_Return(RC_REENTER_COMPILED_CODE);
+ Pop_Return_Error(Which_Way);
+ }
+
+ default: Microcode_Termination( TERM_COMPILER_DEATH);
+ }
+ }
+
+ default:
+ Apply_Error(ERR_INAPPLICABLE_OBJECT);
+ } /* End of switch in RC_INTERNAL_APPLY */
+ } /* End of RC_INTERNAL_APPLY case */
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_MOVE_TO_ADJACENT_POINT:
+ /* Expression contains the space in which we are moving */
+ { long From_Count = Get_Integer(Stack_Ref(TRANSLATE_FROM_DISTANCE));
+ Pointer Thunk, New_Location;
+ if (From_Count != 0)
+ { Pointer Current = Stack_Ref(TRANSLATE_FROM_POINT);
+ Stack_Ref(TRANSLATE_FROM_DISTANCE) = FIXNUM_0+(From_Count-1);
+ Thunk = Fast_Vector_Ref(Current, STATE_POINT_AFTER_THUNK);
+ New_Location = Fast_Vector_Ref(Current, STATE_POINT_NEARER_POINT);
+ Stack_Ref(TRANSLATE_FROM_POINT) = New_Location;
+ if ((From_Count == 1) &&
+ (Stack_Ref(TRANSLATE_TO_DISTANCE) == FIXNUM_0))
+ Stack_Pointer = Simulate_Popping(4);
+ else Save_Cont();
+ }
+ else
+ { long To_Count = Get_Integer(Stack_Ref(TRANSLATE_TO_DISTANCE))-1;
+ fast Pointer To_Location = Stack_Ref(TRANSLATE_TO_POINT);
+ fast long i;
+ for (i=0; i < To_Count; i++)
+ To_Location = Fast_Vector_Ref(To_Location, STATE_POINT_NEARER_POINT);
+ Thunk = Fast_Vector_Ref(To_Location, STATE_POINT_BEFORE_THUNK);
+ New_Location = To_Location;
+ Stack_Ref(TRANSLATE_TO_DISTANCE) = FIXNUM_0+To_Count;
+ if (To_Count==0)
+ Stack_Pointer = Simulate_Popping(4);
+ else Save_Cont();
+ }
+ if (Fetch_Expression() != NIL)
+ Vector_Set(Fetch_Expression(), STATE_SPACE_NEAREST_POINT, New_Location);
+ else Current_State_Point = New_Location;
+ Will_Push(2);
+ Push(Thunk);
+ Push(STACK_FRAME_HEADER);
+ Pushed();
+ goto Internal_Apply;
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_INVOKE_STACK_THREAD:
+ /* Used for WITH_THREADED_STACK primitive */
+ Will_Push(3);
+ Push(Val); /* Value calculated by thunk */
+ Push(Fetch_Expression());
+ Push(STACK_FRAME_HEADER+1);
+ Pushed();
+ goto Internal_Apply;
+
+ case RC_JOIN_STACKLETS:
+ Our_Throw(true, Fetch_Expression());
+ Join_Stacklet_Backout();
+ Our_Throw_Part_2();
+ break;
+
+ case RC_NORMAL_GC_DONE:
+ End_GC_Hook();
+ if (GC_Check(GC_Space_Needed))
+ { printf("\nGC just ended. The free pointer is at 0x%x, the top of this heap\n",
+ Free);
+ printf("is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n",
+ MemTop, GC_Space_Needed);
+ Microcode_Termination(TERM_EXIT);
+ }
+ GC_Space_Needed = 0;
+ Val = Fetch_Expression();
+ break;
+\f
+ case RC_PCOMB1_APPLY:
+ End_Subproblem();
+ Push(Val); /* Argument value */
+ Finished_Eventual_Pushing();
+ Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB1_FN_SLOT));
+ goto Primitive_Internal_Apply;
+
+ case RC_PCOMB2_APPLY:
+ End_Subproblem();
+ Push(Val); /* Value of arg. 1 */
+ Finished_Eventual_Pushing();
+ Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB2_FN_SLOT));
+ goto Primitive_Internal_Apply;
+
+ case RC_PCOMB2_DO_1:
+ Restore_Env();
+ Push(Val); /* Save value of arg. 2 */
+ Do_Another_Then(RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT);
+
+ case RC_PCOMB3_APPLY:
+ End_Subproblem();
+ Push(Val); /* Save value of arg. 1 */
+ Finished_Eventual_Pushing();
+ Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB3_FN_SLOT));
+ goto Primitive_Internal_Apply;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_PCOMB3_DO_1:
+ { Pointer Temp;
+ Temp = Pop(); /* Value of arg. 3 */
+ Restore_Env();
+ Push(Temp); /* Save arg. 3 again */
+ Push(Val); /* Save arg. 2 */
+ Do_Another_Then(RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT);
+ }
+
+ case RC_PCOMB3_DO_2:
+ Restore_Then_Save_Env();
+ Push(Val); /* Save value of arg. 3 */
+ Do_Another_Then(RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT);
+
+ case RC_POP_RETURN_ERROR:
+ case RC_RESTORE_VALUE:
+ Val = Fetch_Expression();
+ break;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_PURIFY_GC_1:
+ { Pointer GC_Daemon_Proc, Result;
+ Export_Registers();
+ Result = Purify_Pass_2(Fetch_Expression());
+ Import_Registers();
+ if (Result == NIL)
+ { /* The object does not fit in Constant space.
+ There is no need to run the daemons, and we should let the runtime
+ system know what happened.
+ */
+ Val = NIL;
+ break;
+ }
+ GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
+ if (GC_Daemon_Proc==NIL)
+ { Val = TRUTH;
+ break;
+ }
+ Store_Expression(NIL);
+ Store_Return(RC_PURIFY_GC_2);
+ Save_Cont();
+ Will_Push(2);
+ Push(GC_Daemon_Proc);
+ Push(STACK_FRAME_HEADER);
+ Pushed();
+ goto Internal_Apply;
+ }
+
+ case RC_PURIFY_GC_2:
+ Val = TRUTH;
+ break;
+
+ case RC_REPEAT_DISPATCH:
+ Sign_Extend(Fetch_Expression(), Which_Way);
+ Restore_Env();
+ Val = Pop();
+ Restore_Cont();
+ goto Repeat_Dispatch;
+
+ case RC_REPEAT_PRIMITIVE:
+ if (Type_Code(Fetch_Expression()) == TC_PRIMITIVE_EXTERNAL)
+ goto Repeat_External_Primitive;
+ else goto Primitive_Internal_Apply;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+/* The following two return codes are both used to restore
+ a saved history object. The difference is that the first
+ does not copy the history object while the second does.
+ In both cases, the Expression register contains the history
+ object and the next item to be popped off the stack contains
+ the offset back to the previous restore history return code.
+
+ ASSUMPTION: History objects are never created using futures.
+*/
+
+ case RC_RESTORE_DONT_COPY_HISTORY:
+ { Pointer Stacklet;
+ Previous_Restore_History_Offset = Get_Integer(Pop());
+ Stacklet = Pop();
+ History = Get_Pointer(Fetch_Expression());
+ if (Previous_Restore_History_Offset == 0)
+ Previous_Restore_History_Stacklet = NULL;
+ else if (Stacklet == NIL)
+ Previous_Restore_History_Stacklet = NULL;
+ else
+ Previous_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ break;
+ }
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_RESTORE_HISTORY:
+ { Pointer Stacklet;
+ Export_Registers();
+ if (! Restore_History(Fetch_Expression()))
+ { Import_Registers();
+ Save_Cont();
+ Will_Push(CONTINUATION_SIZE);
+ Store_Expression(Val);
+ Store_Return(RC_RESTORE_VALUE);
+ Save_Cont();
+ Pushed();
+ Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1));
+ }
+ Import_Registers();
+ Previous_Restore_History_Offset = Get_Integer(Pop());
+ Stacklet = Pop();
+ if (Previous_Restore_History_Offset == 0)
+ Previous_Restore_History_Stacklet = NULL;
+ else
+ { if (Stacklet == NIL)
+ { Previous_Restore_History_Stacklet = NULL;
+ Get_End_Of_Stacklet()[-Previous_Restore_History_Offset] =
+ Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
+ }
+ else
+ { Previous_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ Previous_Restore_History_Stacklet[-Previous_Restore_History_Offset] =
+ Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
+ }
+ }
+ break;
+ }
+
+ case RC_RESTORE_FLUIDS:
+ Fluid_Bindings = Fetch_Expression();
+ New_Compiler_MemTop();
+ break;
+
+ case RC_RESTORE_INT_MASK:
+ IntEnb = Get_Integer(Fetch_Expression());
+ New_Compiler_MemTop();
+ break;
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_RESTORE_TO_STATE_POINT:
+ { Pointer Where_To_Go = Fetch_Expression();
+ Will_Push(CONTINUATION_SIZE);
+ /* Restore the contents of Val after moving to point */
+ Store_Expression(Val);
+ Store_Return(RC_RESTORE_VALUE);
+ Save_Cont();
+ Pushed();
+ Export_Registers();
+ Translate_To_Point(Where_To_Go);
+ break; /* We never get here.... */
+ }
+
+/* case RC_RESTORE_VALUE is with RC_POP_RETURN_ERROR */
+
+ case RC_RETURN_TRAP_POINT:
+ Store_Return(Old_Return_Code);
+ Will_Push(CONTINUATION_SIZE+3);
+ Save_Cont();
+ Return_Hook_Address = NULL;
+ Stop_Trapping();
+ Push(Val);
+ Push(Fetch_Return_Trapper());
+ Push(STACK_FRAME_HEADER+1);
+ Pushed();
+ goto Apply_Non_Trapping;
+
+ case RC_SEQ_2_DO_2:
+ End_Subproblem();
+ Restore_Env();
+ Reduces_To_Nth(SEQUENCE_2);
+
+ case RC_SEQ_3_DO_2:
+ Restore_Then_Save_Env();
+ Do_Another_Then(RC_SEQ_3_DO_3, SEQUENCE_2);
+
+ case RC_SEQ_3_DO_3:
+ End_Subproblem();
+ Restore_Env();
+ Reduces_To_Nth(SEQUENCE_3);
+
+/* Interpret() continues on the next page */
+\f
+/* Interpret(), continued */
+
+ case RC_SNAP_NEED_THUNK:
+ Vector_Set(Fetch_Expression(), THUNK_SNAPPED, TRUTH);
+ Vector_Set(Fetch_Expression(), THUNK_VALUE, Val);
+ break;
+
+ case RC_AFTER_MEMORY_UPDATE:
+ case RC_BAD_INTERRUPT_CONTINUE:
+ case RC_COMPLETE_GC_DONE:
+ case RC_RESTARTABLE_EXIT:
+ case RC_RESTART_EXECUTION:
+ case RC_RESTORE_CONTINUATION:
+ case RC_RESTORE_STEPPER:
+ case RC_POP_FROM_COMPILED_CODE:
+ Export_Registers();
+ Microcode_Termination(TERM_UNIMPLEMENTED_CONTINUATION);
+
+ default:
+ Export_Registers();
+ Microcode_Termination(TERM_NON_EXISTENT_CONTINUATION);
+ };
+ goto Pop_Return;
+}
--- /dev/null
+/* Emacs -*-C-*-an't tell the language */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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: MUL.C
+ *
+ * This file contains the portable fixnum multiplication procedure.
+ * Returns NIL if the result does not fit in a fixnum.
+ * Note: This has only been tried on machines with long = 32 bits.
+ * This file is included in the appropriate os file if needed.
+ */
+
+#define HALF_WORD_SIZE ((sizeof(long)*CHAR_SIZE)/2)
+#define HALF_WORD_MASK (1<<HALF_WORD_SIZE)-1
+#define MAX_MIDDLE (1<<((ADDRESS_LENGTH-1)-HALF_WORD_SIZE))
+#define MAX_FIXNUM (1<<ADDRESS_LENGTH)
+#define ABS(x) (((x) < 0) ? -(x) : (x))
+
+Pointer Mul(Arg1, Arg2)
+long Arg1, Arg2;
+{ long A, B, C;
+ fast long Hi_A, Hi_B, Lo_A, Lo_B, Lo_C, Middle_C;
+ Boolean Sign;
+ Sign_Extend(Arg1, A); Sign_Extend(Arg2, B);
+ Sign = ((A < 0) == (B < 0));
+ A = ABS(A); B = ABS(B);
+ Hi_A = (A >> HALF_WORD_SIZE) & HALF_WORD_MASK;
+ Hi_B = (B >> HALF_WORD_SIZE) & HALF_WORD_MASK;
+ Lo_A = A & HALF_WORD_MASK; Lo_B = B & HALF_WORD_MASK;
+ Lo_C = Lo_A * Lo_B;
+ if (Lo_C > FIXNUM_SIGN_BIT) return NIL;
+ Middle_C = Lo_A * Hi_B + Hi_A * Lo_B;
+ if (Middle_C >= MAX_MIDDLE) return NIL;
+ if ((Hi_A * Hi_B) > 0) return NIL;
+ C = Lo_C + (Middle_C << HALF_WORD_SIZE);
+ if (Fixnum_Fits(C))
+ { if (Sign || (C == 0)) return FIXNUM_0 + C;
+ else return FIXNUM_0 + (MAX_FIXNUM - C);
+ }
+ return NIL;
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: object.h
+ *
+ * This file contains definitions pertaining to the C view of
+ * Scheme pointers: widths of fields, extraction macros, pre-computed
+ * extraction masks, etc.
+ *
+ */
+\f
+/* The C type Pointer is defined at the end of CONFIG.H */
+
+#define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */
+#define MAX_TYPE_CODE 0xFF /* ((1<<TYPE_CODE_LENGTH) - 1) */
+
+/* The danger bit is set in the value cell of an environment whenever a
+ particular binding of a variable to a value has been shadowed by an
+ auxiliary variable in a nested environment. It means that variables
+ cached to this address must be recached since the address may be invalid.
+ See lookup.c
+*/
+
+#define DANGER_TYPE 0x80 /* (1<<(TYPE_CODE_LENGTH-1)) */
+#define MAX_SAFE_TYPE 0x7F /* (MAX_TYPE_CODE & ~DANGER_TYPE) */
+#define SAFE_TYPE_MASK MAX_SAFE_TYPE
+#define DANGER_BIT HIGH_BIT
+
+#ifndef b32 /* Safe versions */
+
+#define POINTER_LENGTH (CHAR_SIZE*sizeof(Pointer))
+#define ADDRESS_LENGTH (POINTER_LENGTH-TYPE_CODE_LENGTH)
+#define ADDRESS_MASK ((1<<ADDRESS_LENGTH) - 1)
+#define TYPE_CODE_MASK (~ADDRESS_MASK)
+#define HIGH_BIT (1 << (POINTER_LENGTH-1))
+/* FIXNUM_LENGTH does NOT include the sign bit! */
+#define FIXNUM_LENGTH (ADDRESS_LENGTH-1)
+#define FIXNUM_SIGN_BIT (1<<FIXNUM_LENGTH)
+#define SIGN_MASK (TYPE_CODE_MASK | FIXNUM_SIGN_BIT)
+#define SMALLEST_FIXNUM (-1<<FIXNUM_LENGTH)
+#define BIGGEST_FIXNUM (~(-1<<FIXNUM_LENGTH))
+
+#else /* 32 bit word versions */
+
+#define POINTER_LENGTH 32
+#define ADDRESS_LENGTH 24
+#define ADDRESS_MASK 0x00FFFFFF
+#define TYPE_CODE_MASK 0xFF000000
+#define HIGH_BIT 0x80000000
+#define FIXNUM_LENGTH 23
+#define FIXNUM_SIGN_BIT 0x00800000
+#define SIGN_MASK 0xFF800000
+#define SMALLEST_FIXNUM 0xFF800000
+#define BIGGEST_FIXNUM 0x007FFFFF
+
+#endif
+\f
+#ifndef UNSIGNED_SHIFT /* Safe version */
+#define Type_Code(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE)
+#define Safe_Type_Code(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK)
+#else /* Faster for logical shifts */
+#define Type_Code(P) ((P) >> ADDRESS_LENGTH)
+#define Safe_Type_Code(P) (Type_Code(P) & SAFE_TYPE_MASK)
+#endif
+
+#define Datum(P) ((P) & ADDRESS_MASK)
+
+#define Make_Object(TC, D) \
+ ((((unsigned) (TC)) << ADDRESS_LENGTH) | (Datum(D)))
+\f
+#ifndef Heap_In_Low_Memory /* Safe version */
+
+typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */
+
+extern Pointer *Memory_Base;
+/* The "-1" in the value returned is guarantee that there is one
+ word reserved exclusively for use by the garbage collector. */
+#define Allocate_Heap_Space(space) \
+ (Memory_Base = (Pointer *) malloc(sizeof(Pointer) * (space)), \
+ Heap = Memory_Base, \
+ Memory_Base + (space) - 1)
+#define Get_Pointer(P) ((Pointer *) (Memory_Base+Datum(P)))
+#define C_To_Scheme(P) ((Pointer) ((P)-Memory_Base))
+
+#else /* Storing absolute addresses */
+
+typedef long relocation_type; /* Used to relocate pointers on fasload */
+
+#ifdef spectrum
+
+#define Quad1_Tag 0x40000000
+#define Allocate_Heap_Space(space) \
+ (Heap = (Pointer *) malloc(sizeof(Pointer) * (space)), \
+ Heap + (space) - 1)
+#define Get_Pointer(P) ((Pointer *) (((P) & ADDRESS_MASK) | Quad1_Tag))
+#define C_To_Scheme(P) ((Pointer) (((long) (P)) & ADDRESS_MASK))
+
+#else /* Not Spectrum, fast case */
+
+#define Allocate_Heap_Space(space) \
+ (Heap = (Pointer *) malloc(sizeof(Pointer) * (space)), \
+ Heap + (space) - 1)
+#define Get_Pointer(P) ((Pointer *) Datum(P))
+#define C_To_Scheme(P) ((Pointer) (P))
+
+#endif /* spectrum */
+#endif /* Heap_In_Low_Memory */
+
+#define Make_Pointer(TC, A) Make_Object((TC), C_To_Scheme(A))
+#define Make_Non_Pointer(TC, D) Make_Object(TC, ((Pointer) (D)))
+#define Make_Unsigned_Fixnum(N) (FIXNUM_0 + (N))
+#define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N))
+
+/* Make_New_Pointer(TC, A) may be more efficient than
+ Make_Pointer(TC, Get_Pointer(A))
+*/
+#define Make_New_Pointer(TC, A) Make_Object(TC, ((Pointer) A))
+
+#define Store_Type_Code(P, TC) P = Make_Object((TC), (P))
+#define Store_Address(P, A) \
+ P = (((P) & TYPE_CODE_MASK) | Datum((Pointer) (A)))
+#define Address(P) Datum(P)
+
+/* These are used only where the object is known to be immutable.
+ On a parallel processor they don't require atomic references */
+#define Fast_Vector_Ref(P, N) ((Get_Pointer(P))[N])
+#define Fast_Vector_Set(P, N, S) Fast_Vector_Ref(P, N) = (S)
+#define Fast_User_Vector_Ref(P, N) Fast_Vector_Ref(P, (N)+1)
+#define Fast_User_Vector_Set(P, N, S) Fast_Vector_Set(P, (N)+1, S)
+#define Nth_Vector_Loc(P, N) (&(Fast_Vector_Ref(P, N)))
+#define Vector_Length(P) (Get_Integer(Fast_Vector_Ref((P), 0)))
+
+/* General case vector handling requires atomicity for parallel processors */
+#define Vector_Ref(P, N) Fetch(Fast_Vector_Ref(P, N))
+#define Vector_Set(P, N, S) Store(Fast_Vector_Ref(P, N), S)
+#define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1)
+#define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S)
+\f
+#ifdef FLOATING_ALIGNMENT
+#define Align_Float(Where) \
+while ((((long) (Where+1)) & FLOATING_ALIGNMENT) != 0) \
+ *Where++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
+#else
+#define Align_Float(Where)
+#endif
+#define Get_Float(P) (* ((double *) Nth_Vector_Loc((P), 1)))
+#define Get_Integer(P) Datum(P)
+#define Sign_Extend(P, S) \
+ { (S) = Get_Integer(P); \
+ if (((S) & FIXNUM_SIGN_BIT) != 0) \
+ (S) |= (-1 << ADDRESS_LENGTH); \
+ }
+#define Fixnum_Fits(x) \
+ ((((x) & SIGN_MASK) == 0) || \
+ (((x) & SIGN_MASK) == SIGN_MASK))
+
+/* Playing with the danger bit */
+
+#define Without_Danger_Bit(P) ((P) & (~DANGER_BIT))
+#define Dangerous(P) ((P & DANGER_BIT) != 0)
+#define Clear_Danger_Bit(P) P &= ~DANGER_BIT
+#define Set_Danger_Bit(P) P |= DANGER_BIT
+/* Side effect testing */
+
+#define Is_Constant(address) \
+(((address) >= Constant_Space) && ((address) < Free_Constant))
+
+#define Is_Pure(address) \
+((Is_Constant(address)) && (Pure_Test(address)))
+
+#define Side_Effect_Impurify(Old_Pointer, Will_Contain) \
+if ((Is_Constant(Get_Pointer(Old_Pointer))) && \
+ (GC_Type(Will_Contain) != GC_Non_Pointer) && \
+ (!(Is_Constant(Get_Pointer(Will_Contain)))) && \
+ (Pure_Test(Get_Pointer(Old_Pointer)))) \
+ Primitive_Error(ERR_WRITE_INTO_PURE_SPACE);
+
+
+
+
--- /dev/null
+/* 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. *
+* *
+****************************************************************/
+
+/* File: PP-BAND.C
+ dumps Scheme FASL in user-readable form
+ */
+
+#include "scheme.h"
+
+/* These are needed by load.c */
+
+static Pointer *Memory_Base;
+
+#define Load_Data(Count,To_Where) \
+ fread(To_Where, sizeof(Pointer), Count, stdin)
+
+#define Reloc_or_Load_Debug true
+
+#include "load.c"
+#include "gctype.c"
+\f
+#ifdef Heap_In_Low_Memory
+#ifdef spectrum
+#define File_To_Pointer(P) ((((long) (P))&ADDRESS_MASK) / sizeof(Pointer))
+#else
+#define File_To_Pointer(P) ((P) / sizeof(Pointer))
+#endif /* spectrum */
+#else
+#define File_To_Pointer(P) (P)
+#endif
+
+#ifndef Conditional_Bug
+#define Relocate(P) \
+ (((long) (P) < Const_Base) ? \
+ File_To_Pointer(((long) (P)) - Heap_Base) : \
+ (Heap_Count+File_To_Pointer(((long) (P)) - Const_Base)))
+#else
+#define Relocate_Into(What, P)
+if (((long) (P)) < Const_Base)
+ (What) = File_To_Pointer(((long) (P)) - Heap_Base);
+else
+ (What) = Heap_Count + File_To_Pointer(((long) P) - Const_Base);
+
+static long Relocate_Temp;
+#define Relocate(P) (Relocate_Into(Relocate_Temp, P), Relocate_Temp)
+#endif
+
+Pointer *Data;
+#define via(File_Address) Relocate(Address(Data[File_Address]))
+
+scheme_string(From, Quoted)
+long From;
+Boolean Quoted;
+{ fast long i, Count;
+ fast char *Chars;
+ Count = Get_Integer(Data[From+STRING_LENGTH]);
+ Chars = (char *) &Data[From+STRING_CHARS];
+ putchar(Quoted ? '\"' : '\'');
+ for (i=0; i < Count; i++) printf("%c", *Chars++);
+ if (Quoted) putchar('\"');
+ putchar('\n');
+}
+\f
+Display(Location, Type, The_Datum)
+long Location, Type, The_Datum;
+{ long Points_To;
+ printf("%5x: %2x|%6x ", Location, Type, The_Datum);
+ if (GC_Type_Map[Type & MAX_SAFE_TYPE] != GC_Non_Pointer)
+ Points_To = Relocate((Pointer *) The_Datum);
+ else
+ Points_To = The_Datum;
+ if (Type > MAX_SAFE_TYPE) printf("*");
+ switch (Type & SAFE_TYPE_MASK)
+ { /* "Strange" cases */
+ case TC_NULL: if (The_Datum == 0)
+ { printf("NIL\n");
+ return;
+ }
+ else printf("[NULL ");
+ break;
+ case TC_TRUE: if (The_Datum == 0)
+ { printf("TRUE\n");
+ return;
+ }
+ else printf("[TRUE ");
+ break;
+ case TC_BROKEN_HEART: printf("[BROKEN-HEART ");
+ if (The_Datum == 0)
+ Points_To = 0;
+ break;
+ case TC_MANIFEST_SPECIAL_NM_VECTOR: printf("[MANIFEST-SPECIAL-NM ");
+ Points_To = The_Datum;
+ break;
+ case TC_MANIFEST_NM_VECTOR: printf("[MANIFEST-NM-VECTOR ");
+ Points_To = The_Datum;
+ break;
+ case TC_INTERNED_SYMBOL: scheme_string(via(Points_To+SYMBOL_NAME), false);
+ return;
+ case TC_UNINTERNED_SYMBOL:
+ printf("uninterned ");
+ scheme_string(via(Points_To+SYMBOL_NAME), false);
+ return;
+ case TC_CHARACTER_STRING: scheme_string(Points_To, true);
+ return;
+ case TC_EXTENDED_FIXNUM: printf("%d\n", The_Datum);
+ return;
+ case TC_FIXNUM: printf("%d\n", Points_To);
+ return;
+
+ /* Default cases */
+ case TC_LIST: printf("[CONS "); break;
+ case TC_WEAK_CONS: printf("[WEAK-CONS "); break;
+ case TC_SCODE_QUOTE: printf("[QUOTE "); break;
+ case TC_BIG_FLONUM: printf("[FLONUM "); break;
+ case TC_COMBINATION_1: printf( "[COMB-1 "); break;
+ case TC_EXTENDED_PROCEDURE: printf("[EPROCEDURE "); break;
+ case TC_COMBINATION_2: printf("[COMB-2 "); break;
+ case TC_BIG_FIXNUM: printf("[BIGNUM "); break;
+ case TC_PROCEDURE: printf("[PROCEDURE "); break;
+ case TC_PRIMITIVE_EXTERNAL: printf("[EXTERNAL-PRIMITIVE "); break;
+ case TC_DELAY: printf("[DELAY "); break;
+ case TC_DELAYED: printf("[DELAYED "); break;
+ case TC_EXTENDED_LAMBDA: printf("[ELAMBDA "); break;
+ case TC_COMMENT: printf("[COMMENT "); break;
+ case TC_NON_MARKED_VECTOR: printf("[NON-MARKED-VECTOR "); break;
+ case TC_LAMBDA: printf("[LAMBDA "); break;
+ case TC_PRIMITIVE: printf("[PRIMITIVE "); break;
+ case TC_SEQUENCE_2: printf("[SEQ-2 "); break;
+ case TC_PCOMB1: printf("[PCOMB-1 "); break;
+ case TC_ACCESS: printf("[ACCESS "); break;
+ case TC_DEFINITION: printf("[DEFINITION "); break;
+ case TC_ASSIGNMENT: printf("[ASSIGNMENT "); break;
+ case TC_HUNK3: printf("[HUNK3 "); break;
+ case TC_IN_PACKAGE: printf("[IN-PACKAGE "); break;
+ case TC_LEXPR: printf("[LEXPR "); break;
+ case TC_VARIABLE: printf("[VARIABLE "); break;
+ case TC_CONDITIONAL: printf("[CONDITIONAL "); break;
+ case TC_DISJUNCTION: printf("[DISJUNCTION "); break;
+ case TC_UNASSIGNED: printf("[UNASSIGNED "); break;
+ case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break;
+ case TC_CHARACTER: printf("[CHARACTER "); break;
+ case TC_PCOMB2: printf("[PCOMB-2 "); break;
+ case TC_VECTOR: printf("[VECTOR "); break;
+ case TC_RETURN_CODE: printf("[RETURN-CODE "); break;
+ case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break;
+ case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break;
+ case TC_COMBINATION: printf("[COMBINATION "); break;
+ case TC_PCOMB3: printf("[PCOMB-3 "); break;
+ case TC_THE_ENVIRONMENT: printf("[THE-ENVIRONMENT "); break;
+ case TC_VECTOR_1B: printf("[VECTOR-1B "); break;
+ case TC_PCOMB0: printf("[PCOMB-0 "); break;
+ case TC_VECTOR_16B: printf("[VECTOR-16B "); break;
+ case TC_CELL: printf("[CELL "); break;
+ case TC_FUTURE: printf("[FUTURE "); break;
+ case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break;
+ case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break;
+ case TC_RETURN_ADDRESS: printf("[RETURN-ADDRESS "); break;
+ default: printf("[02x%x ", Type); break;
+ }
+ printf("%x]\n", Points_To);
+}
+
+main()
+{ Pointer *Next;
+ long i;
+ if (!Read_Header())
+ { fprintf(stderr, "Input does not appear to be in FASL format.\n");
+ exit(1);
+ }
+ printf("Dumped object at 0x%x\n", Relocate(Dumped_Object));
+ if (Sub_Version >= FASL_LONG_HEADER)
+ printf("External primitives at 0x%x\n\n", Relocate(Ext_Prim_Vector));
+ Data = (Pointer *) malloc(sizeof(Pointer) * (Heap_Count + Const_Count));
+ Load_Data(Heap_Count + Const_Count, Data);
+ printf("Heap contents\n\n");
+ for (Next=Data, i=0; i < Heap_Count; Next++, i++)
+ if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR)
+ { long j, count = Get_Integer(*Next);
+ Display(i, Type_Code(*Next), Address(*Next));
+ Next += 1;
+ for (j=0; j < count ; j++, Next++)
+ printf(" %02x%06x\n",
+ Type_Code(*Next), Address(*Next));
+ i += count;
+ Next -= 1;
+ }
+ else Display(i, Type_Code(*Next), Address(*Next));
+ printf("\n\nConstant space\n\n");
+ for (; i < Heap_Count+Const_Count; Next++, i++)
+ if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR)
+ { long j, count = Get_Integer(*Next);
+ Display(i, Type_Code(*Next), Address(*Next));
+ Next += 1;
+ for (j=0; j < count ; j++, Next++)
+ printf(" %02x%06x\n",
+ Type_Code(*Next), Address(*Next));
+ i += count;
+ Next -= 1;
+ }
+ else Display(i, Type_Code(*Next), Address(*Next));
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: translate.h
+ *
+ * This header file contains macros and declarations for Bintopsb.c
+ * and Psbtobin.c
+ *
+ */
+\f
+/* These definitions insure that the appropriate code is extracted
+ from the included files.
+*/
+
+#include <stdio.h>
+#define fast register
+
+#include "config.h"
+#include "object.h"
+#include "bignum.h"
+#include "gc.h"
+#include "types.h"
+#include "sdata.h"
+#include "const.h"
+#include "gccode.h"
+#include "character.h"
+
+#ifdef HAS_FREXP
+extern double frexp(), ldexp();
+#else
+#include "missing.c"
+#endif
+
+#define PORTABLE_VERSION 1
+
+/* Number of objects which, when traced recursively, point at all other
+ objects dumped. Currently the dumped object and the external
+ primitives vector.
+ */
+
+#define NROOTS 2
+
+/* Types to recognize external object references. Any occurrence of these
+ (which are external types and thus handled separately) means a reference
+ to an external object.
+ */
+
+#define CONSTANT_CODE TC_BIG_FIXNUM
+#define HEAP_CODE TC_FIXNUM
+
+#define fixnum_to_bits FIXNUM_LENGTH
+#define bignum_to_bits(len) ((len) * SHIFT)
+#define bits_to_bigdigit(nbits) (((nbits) + (SHIFT-1)) / SHIFT)
+
+#define hex_digits(nbits) (((nbits) + 3) / 4)
+
+#define to_pointer(size) \
+ (((size) + (sizeof(Pointer) - 1)) / sizeof(Pointer))
+
+#define bigdigit_to_pointer(ndig) \
+ to_pointer((ndig) * sizeof(bigdigit))
+
+/* This assumes that a bignum header is 2 Pointers.
+ The bignum code is not very portable, unfortunately */
+
+#define bignum_header_to_pointer Align(0)
+
+#define float_to_pointer \
+ to_pointer(sizeof(double))
+#define flonum_to_pointer(nchars) \
+ ((nchars) * (1 + float_to_pointer))
+
+#define char_to_pointer(nchars) \
+ to_pointer(nchars)
+#define pointer_to_char(npoints) \
+ ((npoints) * sizeof(Pointer))
+\f
+/* Global data */
+
+/* If true, make all integers fixnums if possible, and all strings as
+ short as possible (trim extra stuff). */
+
+static Boolean Compact_P = true;
+
+/* If true, null out all elements of random non-marked vectors. */
+
+static Boolean Null_NMV = false;
+
+#ifndef Heap_In_Low_Memory
+static Pointer *Memory_Base;
+#endif
+
+static FILE *Input_File, *Output_File;
+
+static char *Program_Name;
+\f
+/* Status flags */
+
+#define COMPACT_P 1
+#define NULL_NMV 2
+
+#define Make_Flags() \
+((Compact_P ? COMPACT_P : 0) | \
+ (Null_NMV ? NULL_NMV : 0))
+
+#define Read_Flags(f) \
+Compact_P = ((f) & COMPACT_P); \
+Null_NMV = ((f) & NULL_NMV)
+\f
+/* Argument List Parsing */
+
+struct Option_Struct { char *name;
+ Boolean value;
+ Boolean *ptr;
+ };
+
+Boolean strequal(s1, s2)
+fast char *s1, *s2;
+{ while (*s1 != '\0')
+ if (*s1++ != *s2++) return false;
+ return (*s2 == '\0');
+}
+
+char *Find_Options(argc, argv, Noptions, Options)
+int argc;
+char **argv;
+int Noptions;
+struct Option_Struct Options[];
+{ for ( ; --argc >= 0; argv++)
+ { char *this = *argv;
+ int n;
+ for (n = 0;
+ ((n < Noptions) && (!strequal(this, Options[n].name)));
+ n++) ;
+ if (n >= Noptions) return this;
+ *(Options[n].ptr) = Options[n].value;
+ }
+ return NULL;
+}
+\f
+/* Usage information */
+
+Print_Options(n, options, where)
+int n;
+struct Option_Struct *options;
+FILE *where;
+{ if (--n < 0) return;
+ fprintf(where, "[%s]", options->name);
+ options += 1;
+ for (; --n >= 0; options += 1)
+ fprintf(where, " [%s]", options->name);
+ return;
+}
+
+Print_Usage_and_Exit(noptions, options, io_options)
+int noptions;
+struct Option_Struct *options;
+char *io_options;
+{ fprintf(stderr, "usage: %s%s%s",
+ Program_Name,
+ (((io_options == NULL) ||
+ (io_options[0] == '\0')) ? "" : " "),
+ io_options);
+ if (noptions != 0)
+ { putc(' ', stderr);
+ Print_Options(noptions, options, stderr);
+ }
+ putc('\n', stderr);
+ exit(1);
+}
+\f
+/* Top level of program */
+
+/* When debugging force arguments on command line */
+
+#ifdef DEBUG
+#undef unix
+#endif
+
+#ifdef unix
+
+/* On unix use io redirection */
+
+Setup_Program(argc, argv, Noptions, Options)
+int argc;
+char *argv[];
+int Noptions;
+struct Option_Struct *Options;
+{ extern do_it();
+ Program_Name = argv[0];
+ Input_File = stdin;
+ Output_File = stdout;
+ if (((argc - 1) > Noptions) ||
+ (Find_Options((argc - 1), &argv[1], Noptions, Options) != NULL))
+ Print_Usage_and_Exit(Noptions, Options, "");
+ do_it();
+ return;
+}
+
+#else
+
+/* Otherwise use command line arguments */
+
+Setup_Program(argc, argv, Noptions, Options)
+int argc;
+char *argv[];
+int Noptions;
+struct Option_Struct *Options;
+{ extern do_it();
+ Program_Name = argv[0];
+ if ((argc < 3) ||
+ ((argc - 3) > Noptions) ||
+ (Find_Options((argc - 3), &argv[3], Noptions, Options) != NULL))
+ Print_Usage_and_Exit(Noptions, Options, "input_file output_file");
+ Input_File = ((strequal(argv[1], "-")) ?
+ stdin :
+ fopen(argv[1], "r"));
+ if (Input_File == NULL)
+ { perror("Open failed.");
+ exit(1);
+ }
+ Output_File = ((strequal(argv[2], "-")) ?
+ stdout :
+ fopen(argv[2], "w"));
+ if (Output_File == NULL)
+ { perror("Open failed.");
+ fclose(Input_File);
+ exit(1);
+ }
+ fprintf(stderr, "%s: Reading from %s, writing to %s.\n",
+ Program_Name, argv[1], argv[2]);
+ do_it();
+ fclose(Input_File);
+ fclose(Output_File);
+ return;
+}
+
+#endif
+
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: TO_INTERNAL.C
+ *
+ * This File contains the code to translate portable format binary
+ * files to internal format.
+ *
+ */
+\f
+/* Cheap renames */
+
+#define Portable_File Input_File
+#define Internal_File Output_File
+
+#include "translate.h"
+
+static long Dumped_Object_Addr, Dumped_Ext_Prim_Addr;
+static long Dumped_Heap_Base, Heap_Objects, Heap_Count;
+static long Dumped_Constant_Base, Constant_Objects, Constant_Count;
+static long Dumped_Pure_Base, Pure_Objects, Pure_Count;
+static Pointer *Heap;
+static Pointer *Heap_Base, *Heap_Table, *Heap_Object_Base, *Free;
+static Pointer *Constant_Base, *Constant_Table,
+ *Constant_Object_Base, *Free_Constant;
+static Pointer *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure;
+static Pointer *Stack_Top;
+
+Write_Data(Count, From_Where)
+long Count;
+Pointer *From_Where;
+{ fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File);
+}
+
+#include "dump.c"
+\f
+#define OUT(c) return ((long) ((c) & MAX_CHAR))
+
+long read_a_char()
+{ fast char C = getc(Portable_File);
+ if (C != '\\') OUT(C);
+ C = getc(Portable_File);
+ switch(C)
+ { case 'n': OUT('\n');
+ case 't': OUT('\n');
+ case 'r': OUT('\r');
+ case 'f': OUT('\f');
+ case '0': OUT('\0');
+ case 'X':
+ { long Code;
+ fprintf(stderr,
+ "%s: File is not Portable. Character Code Found.\n",
+ Program_Name);
+ fscanf(Portable_File, "%d", &Code);
+ getc(Portable_File); /* Space */
+ OUT(Code);
+ }
+ case '\\': OUT('\\');
+ default : OUT(C);
+ }
+}
+\f
+Pointer *read_a_string(To, Slot)
+Pointer *To, *Slot;
+{ long maxlen, len, Pointer_Count;
+ fast char *string = ((char *) (&To[STRING_CHARS]));
+ *Slot = Make_Pointer(TC_CHARACTER_STRING, To);
+ fscanf(Portable_File, "%ld %ld", &maxlen, &len);
+ maxlen += 1; /* Null terminated */
+ Pointer_Count = STRING_CHARS + char_to_pointer(maxlen);
+ To[STRING_HEADER] =
+ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1));
+ To[STRING_LENGTH] = Make_Non_Pointer(TC_FIXNUM, len);
+ getc(Portable_File); /* Space */
+ while (--len >= 0) *string++ = ((char) read_a_char());
+ *string = '\0';
+ return (To + Pointer_Count);
+}
+\f
+Pointer *read_an_integer(The_Type, To, Slot)
+int The_Type;
+Pointer *To;
+Pointer *Slot;
+{ Boolean negative;
+ long size_in_bits;
+
+ getc(Portable_File); /* Space */
+ negative = ((getc(Portable_File)) == '-');
+ fscanf(Portable_File, "%ld", &size_in_bits);
+ if ((size_in_bits <= fixnum_to_bits) &&
+ (The_Type == TC_FIXNUM))
+ { fast long Value = 0;
+ fast int Normalization;
+ fast long ndigits;
+ long digit;
+ if (size_in_bits != 0)
+ for(Normalization = 0,
+ ndigits = hex_digits(size_in_bits);
+ --ndigits >= 0;
+ Normalization += 4)
+ { fscanf(Portable_File, "%1lx", &digit);
+ Value += (digit << Normalization);
+ }
+ if (negative) Value = -Value;
+ *Slot = Make_Non_Pointer(TC_FIXNUM, Value);
+ return To;
+ }
+ else if (size_in_bits == 0)
+ { bigdigit *REG = BIGNUM(To);
+ Prepare_Header(REG, 0, POSITIVE);
+ *Slot = Make_Pointer(TC_BIG_FIXNUM, To);
+ return (To + Align(0));
+ }
+ else
+ { fast bigdigit *The_Bignum;
+ fast long size, nbits, ndigits;
+ fast unsigned long Temp;
+ long Length;
+ if ((The_Type == TC_FIXNUM) && (!Compact_P))
+ fprintf(stderr,
+ "%s: Fixnum too large, coercing to bignum.\n",
+ Program_Name);
+ size = bits_to_bigdigit(size_in_bits);
+ ndigits = hex_digits(size_in_bits);
+ Length = Align(size);
+ The_Bignum = BIGNUM(To);
+ Prepare_Header(The_Bignum, size, (negative ? NEGATIVE : POSITIVE));
+ for (The_Bignum = Bignum_Bottom(The_Bignum), nbits = 0, Temp = 0;
+ --size >= 0;
+ )
+ { for ( ;
+ (nbits < SHIFT) && (ndigits > 0);
+ ndigits -= 1, nbits += 4)
+ { long digit;
+ fscanf(Portable_File, "%1lx", &digit);
+ Temp |= (((unsigned long) digit) << nbits);
+ }
+ *The_Bignum++ = Rem_Radix(Temp);
+ Temp = Div_Radix(Temp);
+ nbits -= SHIFT;
+ }
+ *Slot = Make_Pointer(TC_BIG_FIXNUM, To);
+ return (To + Length);
+ }
+}
+\f
+/* Underflow and Overflow */
+
+/* dflmax and dflmin exist in the Berserkely FORTRAN library */
+
+static double the_max = 0.0;
+
+#define dflmin() 0.0 /* Cop out */
+#define dflmax() ((the_max == 0.0) ? compute_max() : the_max)
+
+double compute_max()
+{ fast double Result = 0.0;
+ fast int expt;
+ for (expt = MAX_FLONUM_EXPONENT;
+ expt != 0;
+ expt >>= 1)
+ Result += ldexp(1.0, expt);
+ the_max = Result;
+ return Result;
+}
+\f
+double read_a_flonum()
+{ Boolean negative;
+ long size_in_bits, exponent;
+ fast double Result;
+
+ getc(Portable_File); /* Space */
+ negative = ((getc(Portable_File)) == '-');
+ fscanf(Portable_File, "%ld %ld", &exponent, &size_in_bits);
+ if (size_in_bits == 0) Result = 0.0;
+ else if ((exponent > MAX_FLONUM_EXPONENT) ||
+ (exponent < -MAX_FLONUM_EXPONENT))
+ { /* Skip over mantissa */
+ while (getc(Portable_File) != '\n') ;
+ fprintf(stderr,
+ "%s: Floating point exponent too %s!\n",
+ Program_Name,
+ ((exponent < 0) ? "small" : "large"));
+ Result = ((exponent < 0) ? dflmin() : dflmax());
+ }
+ else
+ { fast long ndigits;
+ fast double Normalization;
+ long digit;
+ if (size_in_bits > FLONUM_MANTISSA_BITS)
+ fprintf(stderr,
+ "%s: Some precission may be lost.",
+ Program_Name);
+ getc(Portable_File); /* Space */
+ for (ndigits = hex_digits(size_in_bits),
+ Result = 0.0,
+ Normalization = (1.0 / 16.0);
+ --ndigits >= 0;
+ Normalization /= 16.0)
+ { fscanf(Portable_File, "%1lx", &digit);
+ Result += (((double ) digit) * Normalization);
+ }
+ Result = ldexp(Result, ((int) exponent));
+ }
+ if (negative) Result = -Result;
+ return Result;
+}
+\f
+Pointer *
+Read_External(N, Table, To)
+ long N;
+ fast Pointer *Table, *To;
+{
+ fast Pointer *Until = &Table[N];
+ int The_Type;
+
+ while (Table < Until)
+ {
+ fscanf(Portable_File, "%2x", &The_Type);
+ switch(The_Type)
+ {
+ case TC_CHARACTER_STRING:
+ To = read_a_string(To, Table++);
+ continue;
+ case TC_FIXNUM:
+ case TC_BIG_FIXNUM:
+ To = read_an_integer(The_Type, To, Table++);
+ continue;
+ case TC_CHARACTER:
+ {
+ long the_char_code;
+
+ getc(Portable_File); /* Space */
+ fscanf( Portable_File, "%3x", &the_char_code);
+ *Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
+ continue;
+ }
+ case TC_BIG_FLONUM:
+ {
+ double The_Flonum = read_a_flonum();
+
+ Align_Float(To);
+ *Table++ = Make_Pointer(TC_BIG_FLONUM, To);
+ *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (float_to_pointer));
+ *((double *) To) = The_Flonum;
+ To += float_to_pointer;
+ continue;
+ }
+ default:
+ fprintf(stderr,
+ "%s: Unknown external object found; Type = 0x%02x\n",
+ Program_Name, The_Type);
+ exit(1);
+ }
+ }
+ return To;
+}
+\f
+#if false
+Move_Memory(From, N, To)
+fast Pointer *From, *To;
+long N;
+{ fast Pointer *Until = &From[N];
+ while (From < Until) *To++ = *From++;
+ return;
+}
+#endif
+
+Relocate_Objects(From, N, disp)
+fast Pointer *From;
+long N;
+fast long disp;
+{ fast Pointer *Until = &From[N];
+ while (From < Until)
+ { switch(Type_Code(*From))
+ { case TC_FIXNUM:
+ case TC_CHARACTER:
+ From += 1;
+ break;
+ case TC_BIG_FIXNUM:
+ case TC_BIG_FLONUM:
+ case TC_CHARACTER_STRING:
+ *From++ == Make_Object(Type_Code(*From), (disp + Datum(*From)));
+ break;
+ default:
+ fprintf(stderr,
+ "%s: Unknown External Object Reference with Type 0x%02x",
+ Program_Name,
+ Type_Code(*From));
+ }
+ }
+}
+\f
+#define Relocate_Into(Where, Addr) \
+if ((Addr) < Dumped_Pure_Base) \
+ (Where) = &Heap_Object_Base[(Addr) - Dumped_Heap_Base]; \
+else if ((Addr) < Dumped_Constant_Base) \
+ (Where) = &Pure_Base[(Addr) - Dumped_Pure_Base]; \
+else (Where) = &Constant_Base[(Addr) - Dumped_Constant_Base];
+
+#ifndef Conditional_Bug
+
+#define Relocate(Addr) \
+(((Addr) < Dumped_Pure_Base) ? \
+ &Heap_Object_Base[(Addr) - Dumped_Heap_Base] : \
+ (((Addr) < Dumped_Constant_Base) ? \
+ &Pure_Base[(Addr) - Dumped_Pure_Base] : \
+ &Constant_Base[(Addr) - Dumped_Constant_Base]))
+
+#else
+static Pointer *Relocate_Temp;
+#define Relocate(Addr) \
+ (Relocate_Into(Relocate_Temp, Addr), Relocate_Temp)
+#endif
+
+Pointer *Read_Pointers_and_Relocate(N, To)
+fast long N;
+fast Pointer *To;
+{ int The_Type;
+ long The_Datum;
+/* Align_Float(To); */
+ while (--N >= 0)
+ { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
+ switch((The_Type) & SAFE_TYPE_MASK)
+ { case CONSTANT_CODE:
+ if (The_Type > MAX_SAFE_TYPE)
+ { *To = Constant_Table[The_Datum];
+ Set_Danger_Bit(*To++);
+ continue;
+ }
+ *To++ = Constant_Table[The_Datum];
+ continue;
+
+ case HEAP_CODE:
+ if (The_Type > MAX_SAFE_TYPE)
+ { *To = Heap_Table[The_Datum];
+ Set_Danger_Bit(*To++);
+ continue;
+ }
+ *To++ = Heap_Table[The_Datum];
+ continue;
+
+ case TC_MANIFEST_NM_VECTOR:
+ if (!(Null_NMV)) /* Unknown object! */
+ fprintf(stderr, "%s: File is not portable: NMH found\n",
+ Program_Name);
+ *To++ = Make_Non_Pointer(The_Type, The_Datum);
+ { fast long count = The_Datum;
+ N -= count;
+ while (--count >= 0)
+ { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
+ *To++ = Make_Non_Pointer(The_Type, The_Datum);
+ }
+ }
+ continue;
+
+ case TC_BROKEN_HEART:
+ if (The_Datum != 0)
+ { fprintf(stderr, "%s: Broken Heart Found\n", Program_Name);
+ exit(1);
+ }
+ /* Fall Through */
+ case TC_PRIMITIVE_EXTERNAL:
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ case_simple_Non_Pointer:
+ *To++ = Make_Non_Pointer(The_Type, The_Datum);
+ continue;
+
+ default:
+ /* Should be stricter */
+ *To++ = Make_Pointer(The_Type, Relocate(The_Datum));
+ continue;
+ }
+ }
+/* Align_Float(To); */
+ return To;
+}
+\f
+#ifdef DEBUG
+Print_External_Objects(area_name, Table, N)
+char *area_name;
+fast Pointer *Table;
+fast long N;
+{ fast Pointer *Table_End = &Table[N];
+
+ fprintf(stderr, "%s External Objects:\n", area_name);
+ fprintf(stderr, "Table = 0x%x; N = %d\n", Table, N);
+
+ for( ; Table < Table_End; Table++)
+ switch (Type_Code(*Table))
+ { case TC_FIXNUM:
+ { long The_Number;
+ Sign_Extend(*Table, The_Number);
+ fprintf(stderr,
+ "Table[%6d] = Fixnum %d\n",
+ (N-(Table_End-Table)),
+ The_Number);
+ break;
+ }
+ case TC_CHARACTER:
+ fprintf(stderr,
+ "Table[%6d] = Character %c = 0x%02x\n",
+ (N-(Table_End-Table)),
+ Get_Integer(*Table),
+ Get_Integer(*Table));
+ break;
+
+/* Print_External_Objects continues on the next page */
+\f
+/* Print_External_Objects, continued */
+
+ case TC_CHARACTER_STRING:
+ fprintf(stderr,
+ "Table[%6d] = string \"%s\"\n",
+ (N-(Table_End-Table)),
+ ((char *) Nth_Vector_Loc(*Table, STRING_CHARS)));
+ break;
+ case TC_BIG_FIXNUM:
+ fprintf(stderr,
+ "Table[%6d] = Bignum\n",
+ (N-(Table_End-Table)));
+ break;
+ case TC_BIG_FLONUM:
+ fprintf(stderr,
+ "Table[%6d] = Flonum %lf\n",
+ (N-(Table_End-Table)),
+ (* ((double *) Nth_Vector_Loc(*Table, 1))));
+ break;
+ default:
+ fprintf(stderr,
+ "Table[%6d] = Unknown External Object 0x%8x\n",
+ (N-(Table_End-Table)),
+ *Table);
+ break;
+ }
+}
+#endif
+\f
+long Read_Header_and_Allocate()
+{ long Portable_Version, Flags, Version, Sub_Version;
+ long NFlonums, NIntegers, NStrings, NBits, NChars;
+ long Size;
+
+ /* Read Header */
+
+ fscanf(Input_File, "%ld %ld %ld %ld",
+ &Portable_Version, &Flags, &Version, &Sub_Version);
+ fscanf(Input_File, "%ld %ld %ld",
+ &Heap_Count, &Dumped_Heap_Base, &Heap_Objects);
+ fscanf(Input_File, "%ld %ld %ld",
+ &Constant_Count, &Dumped_Constant_Base, &Constant_Objects);
+ fscanf(Input_File, "%ld %ld %ld",
+ &Pure_Count, &Dumped_Pure_Base, &Pure_Objects);
+ fscanf(Input_File, "%ld %ld %ld %ld %ld",
+ &NFlonums, &NIntegers, &NStrings, &NBits, &NChars);
+ fscanf(Input_File, "%ld %ld",
+ &Dumped_Object_Addr, &Dumped_Ext_Prim_Addr);
+
+ if ((Portable_Version != PORTABLE_VERSION) ||
+ (Version != FASL_FORMAT_VERSION) ||
+ (Sub_Version != FASL_SUBVERSION))
+ { fprintf(stderr,
+ "FASL File Version %4d Subversion %4d Portable Version %4d\n",
+ Version, Sub_Version , Portable_Version);
+ fprintf(stderr,
+ "Expected: Version %4d Subversion %4d Portable Version %4d\n",
+ FASL_FORMAT_VERSION, FASL_SUBVERSION, PORTABLE_VERSION);
+ exit(1);
+ }
+
+ Read_Flags(Flags);
+
+ Size = (6 + /* SNMV */
+ Heap_Count + Heap_Objects +
+ Constant_Count + Constant_Objects +
+ Pure_Count + Pure_Objects +
+ flonum_to_pointer(NFlonums) +
+ ((NIntegers * bignum_header_to_pointer) +
+ (bigdigit_to_pointer(bits_to_bigdigit(NBits)))) +
+ ((NStrings * STRING_CHARS) + (char_to_pointer(NChars))));
+
+ Allocate_Heap_Space(Size);
+ if (Heap == NULL)
+ { fprintf(stderr,
+ "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
+ Program_Name, Size);
+ exit(1);
+ }
+ return Size;
+}
+\f
+do_it()
+{ long Size;
+ Size = Read_Header_and_Allocate();
+ Stack_Top = &Heap[Size];
+
+ Heap_Table = &Heap[0];
+ Heap_Base = &Heap_Table[Heap_Objects];
+ Heap_Object_Base =
+ Read_External(Heap_Objects, Heap_Table, Heap_Base);
+
+ Pure_Table = &Heap_Object_Base[Heap_Count];
+ Pure_Base = &Pure_Table[Pure_Objects + 2]; /* SNMV */
+ Pure_Object_Base =
+ Read_External(Pure_Objects, Pure_Table, Pure_Base);
+
+ Constant_Table = &Heap[Size - Constant_Objects];
+ Constant_Base = &Pure_Object_Base[Pure_Count + 2]; /* SNMV */
+ Constant_Object_Base =
+ Read_External(Constant_Objects, Constant_Table, Constant_Base);
+
+#ifdef DEBUG
+ Print_External_Objects("Heap", Heap_Table, Heap_Objects);
+ Print_External_Objects("Pure", Pure_Table, Pure_Objects);
+ Print_External_Objects("Constant", Constant_Table, Constant_Objects);
+#endif
+\f
+ /* Read the normal objects */
+
+ Free =
+ Read_Pointers_and_Relocate(Heap_Count, Heap_Object_Base);
+ Free_Pure =
+ Read_Pointers_and_Relocate(Pure_Count, Pure_Object_Base);
+ Free_Constant =
+ Read_Pointers_and_Relocate(Constant_Count, Constant_Object_Base);
+
+ /* Dump the objects */
+
+ { Pointer *Dumped_Object, *Dumped_Ext_Prim;
+ Relocate_Into(Dumped_Object, Dumped_Object_Addr);
+ Relocate_Into(Dumped_Ext_Prim, Dumped_Ext_Prim_Addr);
+
+#ifdef DEBUG
+ fprintf(stderr, "Dumping:\n");
+ fprintf(stderr,
+ "Heap = 0x%x; Heap Count = %d\n",
+ Heap_Base, (Free - Heap_Base));
+ fprintf(stderr,
+ "Pure Space = 0x%x; Pure Count = %d\n",
+ Pure_Base, (Free_Pure - Pure_Base));
+ fprintf(stderr,
+ "Constant Space = 0x%x; Constant Count = %d\n",
+ Constant_Base, (Free_Constant - Constant_Base));
+ fprintf(stderr,
+ "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
+ Dumped_Object, *Dumped_Object);
+ fprintf(stderr,
+ "& Dumped Ext Prim = 0x%x; Dumped Ext Prim = 0x%x\n",
+ Dumped_Ext_Prim, *Dumped_Ext_Prim);
+#endif
+
+ /* Is there a Pure/Constant block? */
+
+ if ((Constant_Objects == 0) && (Constant_Count == 0) &&
+ (Pure_Objects == 0) && (Pure_Count == 0))
+ Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
+ 0, &Heap[Size], Dumped_Ext_Prim);
+ else
+ { long Pure_Length = (Constant_Base - Pure_Base) + 1;
+ long Total_Length = (Free_Constant - Pure_Base) + 4;
+ Pure_Base[-2] =
+ Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, (Pure_Length - 1));
+ Pure_Base[-1] =
+ Make_Non_Pointer(PURE_PART, Total_Length);
+ Constant_Base[-2] =
+ Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ Constant_Base[-1] =
+ Make_Non_Pointer(CONSTANT_PART, (Pure_Length - 1));
+ Free_Constant[0] =
+ Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ Free_Constant[1] =
+ Make_Non_Pointer(END_OF_BLOCK, Total_Length);
+
+ Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
+ Total_Length, (Pure_Base - 2), Dumped_Ext_Prim);
+ }
+ }
+ return;
+}
+\f
+/* Top level */
+
+static int Noptions = 0;
+/* C does not usually like empty initialized arrays, so ... */
+static struct Option_Struct Options[] = {{"dummy", true, NULL}};
+
+main(argc, argv)
+int argc;
+char *argv[];
+{ Setup_Program(argc, argv, Noptions, Options);
+ return;
+}
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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. */
+
+/* File: returns.h
+ *
+ * Return codes. These are placed in Return when an
+ * interpreter operation needs to operate in several
+ * phases. This must correspond with UTABMD.SCM
+ *
+ */
+\f
+/* These names are also in storage.c.
+ * Please maintain consistency.
+ */
+
+#define RC_END_OF_COMPUTATION 0x00
+/* Used to be RC_RESTORE_CONTROL_POINT */
+#define RC_JOIN_STACKLETS 0x01
+#define RC_RESTORE_CONTINUATION 0x02 /* Used for 68000 */
+#define RC_INTERNAL_APPLY 0x03
+#define RC_BAD_INTERRUPT_CONTINUE 0x04 /* Used for 68000 */
+#define RC_RESTORE_HISTORY 0x05
+/* Generated by primitive WITH_HISTORY_DISABLED */
+#define RC_INVOKE_STACK_THREAD 0x06
+/* Generated by primitive WITH_THREADED_CONTINUATION */
+#define RC_RESTART_EXECUTION 0x07 /* Used for 68000 */
+#define RC_EXECUTE_ASSIGNMENT_FINISH 0x08
+#define RC_EXECUTE_DEFINITION_FINISH 0x09
+#define RC_EXECUTE_ACCESS_FINISH 0x0A
+#define RC_EXECUTE_IN_PACKAGE_CONTINUE 0x0B
+#define RC_SEQ_2_DO_2 0x0C
+#define RC_SEQ_3_DO_2 0x0D
+#define RC_SEQ_3_DO_3 0x0E
+#define RC_CONDITIONAL_DECIDE 0x0F
+#define RC_DISJUNCTION_DECIDE 0x10
+#define RC_COMB_1_PROCEDURE 0x11
+#define RC_COMB_APPLY_FUNCTION 0x12
+#define RC_COMB_2_FIRST_OPERAND 0x13
+#define RC_COMB_2_PROCEDURE 0x14
+#define RC_COMB_SAVE_VALUE 0x15
+#define RC_PCOMB1_APPLY 0x16
+#define RC_PCOMB2_DO_1 0x17
+#define RC_PCOMB2_APPLY 0x18
+#define RC_PCOMB3_DO_2 0x19
+#define RC_PCOMB3_DO_1 0x1A
+#define RC_PCOMB3_APPLY 0x1B
+\f
+#define RC_SNAP_NEED_THUNK 0x1C
+/* Generated by primitive FORCE */
+#define RC_REENTER_COMPILED_CODE 0x1D
+/* Formerly RC_GET_CHAR_REPEAT on 68000 0x1E */
+#define RC_COMPILER_REFERENCE_RESTART 0x1F
+#define RC_NORMAL_GC_DONE 0x20
+#define RC_COMPLETE_GC_DONE 0x21 /* Used for 68000 */
+#define RC_PURIFY_GC_1 0x22
+/* Generated by primitive PURIFY */
+#define RC_PURIFY_GC_2 0x23
+/* Generated by primitive PURIFY */
+#define RC_AFTER_MEMORY_UPDATE 0x24 /* Used for 68000 */
+#define RC_RESTARTABLE_EXIT 0x25 /* Used for 68000 */
+/* formerly RC_GET_CHAR 0x26 */
+/* formerly RC_GET_CHAR_IMMEDIATE 0x27 */
+#define RC_COMPILER_ASSIGNMENT_RESTART 0x28
+#define RC_POP_FROM_COMPILED_CODE 0x29
+#define RC_RETURN_TRAP_POINT 0x2A
+#define RC_RESTORE_STEPPER 0x2B /* Used for 68000 */
+#define RC_RESTORE_TO_STATE_POINT 0x2C
+/* Generated by primitive EXECUTE_AT_NEW_POINT */
+#define RC_MOVE_TO_ADJACENT_POINT 0x2D
+#define RC_RESTORE_VALUE 0x2E
+#define RC_RESTORE_DONT_COPY_HISTORY 0x2F
+
+/* The following are not used in the 68000 implementation */
+
+#define RC_POP_RETURN_ERROR 0x40
+#define RC_EVAL_ERROR 0x41
+#define RC_REPEAT_PRIMITIVE 0x42
+#define RC_COMPILER_INTERRUPT_RESTART 0x43
+/* #define RC_COMPILER_RECURSION_GC 0x44 */
+#define RC_RESTORE_INT_MASK 0x45
+#define RC_HALT 0x46
+#define RC_FINISH_GLOBAL_INT 0x47 /* Multiprocessor */
+#define RC_REPEAT_DISPATCH 0x48
+#define RC_GC_CHECK 0x49
+#define RC_RESTORE_FLUIDS 0x4A
+#define RC_COMPILER_LOOKUP_APPLY_RESTART 0x4B
+#define RC_COMPILER_ACCESS_RESTART 0x4C
+#define RC_COMPILER_UNASSIGNED_P_RESTART 0x4D
+#define RC_COMPILER_UNBOUND_P_RESTART 0x4E
+#define RC_COMPILER_DEFINITION_RESTART 0x4F
+#define RC_COMPILER_LEXPR_INTERRUPT_RESTART 0x50
+
+#define MAX_RETURN_CODE 0x50
+
+/* When adding return codes, don't forget to update storage.c too. */
--- /dev/null
+/* Emacs, -*-C-*-an't you guess? */
+
+/****************************************************************
+* *
+* Copyright (c) 1986 *
+* 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. *
+* *
+****************************************************************/
+
+/* File: TYPES.H
+ *
+ * Type code definitions, numerical order
+ *
+ */
+\f
+#define TC_NULL 0x00
+#define TC_FALSE 0x00
+#define TC_MANIFEST_VECTOR 0x00
+#define GLOBAL_ENV 0x00
+
+#define TC_LIST 0x01
+#define TC_CHARACTER 0x02
+#define TC_SCODE_QUOTE 0x03
+#define TC_PCOMB2 0x04 /* Was 0x44 */
+#define TC_UNINTERNED_SYMBOL 0x05
+#define TC_BIG_FLONUM 0x06
+#define TC_COMBINATION_1 0x07
+#define TC_TRUE 0x08
+#define TC_EXTENDED_PROCEDURE 0x09
+#define TC_VECTOR 0x0A /* Was 0x46 */
+#define TC_RETURN_CODE 0x0B /* Was 0x48 */
+#define TC_COMBINATION_2 0x0C
+#define TC_COMPILED_PROCEDURE 0x0D /* Was 0x49 */
+#define TC_BIG_FIXNUM 0x0E
+#define TC_PROCEDURE 0x0F
+#define TC_PRIMITIVE_EXTERNAL 0x10
+#define TC_DELAY 0x11
+#define TC_ENVIRONMENT 0x12 /* Was 0x4E */
+#define TC_DELAYED 0x13
+#define TC_EXTENDED_LAMBDA 0x14
+#define TC_COMMENT 0x15
+#define TC_NON_MARKED_VECTOR 0x16
+#define TC_LAMBDA 0x17
+#define TC_PRIMITIVE 0x18
+#define TC_SEQUENCE_2 0x19
+\f
+#define TC_FIXNUM 0x1A /* Was 0x50 */
+#define TC_ADDRESS 0x1A
+ /* Notice that TC_FIXNUM and TC_ADDRESS are the same */
+#define TC_PCOMB1 0x1B
+#define TC_CONTROL_POINT 0x1C /* Was 0x56 */
+#define TC_INTERNED_SYMBOL 0x1D
+#define TC_CHARACTER_STRING 0x1E
+#define TC_VECTOR_8B 0x1E
+ /* VECTOR_8B and STRING are the same */
+#define TC_ACCESS 0x1F
+#define TC_EXTENDED_FIXNUM 0x20 /* Not used */
+#define TC_DEFINITION 0x21
+#define TC_BROKEN_HEART 0x22 /* Was 0x58 */
+#define TC_ASSIGNMENT 0x23
+#define TC_HUNK3 0x24
+#define TC_IN_PACKAGE 0x25
+#define TC_COMBINATION 0x26 /* Was 0x5E */
+#define TC_MANIFEST_NM_VECTOR 0x27 /* Was 0x60 */
+#define TC_COMPILED_EXPRESSION 0x28
+#define TC_LEXPR 0x29
+#define TC_PCOMB3 0x2A /* Was 0x66 */
+#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B /* Was 0x68 */
+#define TC_VARIABLE 0x2C
+#define TC_THE_ENVIRONMENT 0x2D /* Was 0x70 */
+#define TC_FUTURE 0x2E
+#define TC_VECTOR_1B 0x2F /* Was 0x76 */
+#define TC_BIT_STRING 0x2F /* Was 0x76 */
+ /* Notice TC_VECTOR_1B and TC_BIT_STRING are the same */
+#define TC_PCOMB0 0x30 /* Was 0x78 */
+#define TC_VECTOR_16B 0x31 /* Was 0x7E */
+#define TC_UNASSIGNED 0x32 /* Was 0x38 */
+#define TC_SEQUENCE_3 0x33 /* Was 0x3C */
+#define TC_CONDITIONAL 0x34
+#define TC_DISJUNCTION 0x35
+#define TC_CELL 0x36
+#define TC_WEAK_CONS 0x37
+#define TC_TRAP 0x38
+#define TC_RETURN_ADDRESS 0x39
+#define TC_COMPILER_LINK 0x3A
+#define TC_STACK_ENVIRONMENT 0x3B
+#define TC_COMPLEX 0x3C
+
+#if defined(MC68020)
+
+#define TC_PEA_INSTRUCTION 0x48
+#define TC_JMP_INSTRUCTION 0x4E
+#define TC_DBF_INSTRUCTION 0x51
+
+#endif
+
+/* If you add a new type, don't forget to update gccode.h and gctype.c */
--- /dev/null
+/* -*-C-*-
+
+Copyright (c) 1986 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
+/* This file contains version information for the microcode */
+
+/* Scheme system release version */
+
+#ifndef RELEASE
+#define RELEASE "5.0.19"
+#endif
+
+/* Microcode release version */
+
+#ifndef VERSION
+#define VERSION 9
+#endif
+#ifndef SUBVERSION
+#define SUBVERSION 10
+#endif
+
+#ifndef UCODE_TABLES_FILENAME
+#define UCODE_TABLES_FILENAME "utabmd.bin.99"
+#endif
projects / mit-scheme.git / commitdiff