From 343857b582c0b7f72834d12ccd57c116f76ca39a Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 16 Dec 1986 20:58:28 +0000 Subject: [PATCH] initial revision --- v7/src/microcode/array.c | 1120 +++++++++++++++++++++ v7/src/microcode/array.h | 166 +++ v7/src/microcode/bignum.c | 946 +++++++++++++++++ v7/src/microcode/bignum.h | 184 ++++ v7/src/microcode/bintopsb.c | 858 ++++++++++++++++ v7/src/microcode/bitstr.c | 861 ++++++++++++++++ v7/src/microcode/bkpt.c | 112 +++ v7/src/microcode/bkpt.h | 107 ++ v7/src/microcode/boot.c | 601 +++++++++++ v7/src/microcode/breakup.c | 135 +++ v7/src/microcode/char.c | 258 +++++ v7/src/microcode/config.h | 437 ++++++++ v7/src/microcode/const.h | 185 ++++ v7/src/microcode/daemon.c | 404 ++++++++ v7/src/microcode/debug.c | 737 ++++++++++++++ v7/src/microcode/default.h | 297 ++++++ v7/src/microcode/dmpwrld.c | 182 ++++ v7/src/microcode/dump.c | 84 ++ v7/src/microcode/errors.h | 135 +++ v7/src/microcode/extern.c | 198 ++++ v7/src/microcode/extern.h | 220 ++++ v7/src/microcode/fasdump.c | 345 +++++++ v7/src/microcode/fasl.h | 106 ++ v7/src/microcode/fasload.c | 672 +++++++++++++ v7/src/microcode/fft.c | 642 ++++++++++++ v7/src/microcode/fhooks.c | 227 +++++ v7/src/microcode/findprim.c | 358 +++++++ v7/src/microcode/fixnum.c | 218 ++++ v7/src/microcode/fixobj.h | 87 ++ v7/src/microcode/flonum.c | 265 +++++ v7/src/microcode/future.c | 364 +++++++ v7/src/microcode/futures.h | 203 ++++ v7/src/microcode/gc.h | 111 ++ v7/src/microcode/gccode.h | 432 ++++++++ v7/src/microcode/gcloop.c | 393 ++++++++ v7/src/microcode/gctype.c | 208 ++++ v7/src/microcode/generic.c | 846 ++++++++++++++++ v7/src/microcode/history.h | 144 +++ v7/src/microcode/hooks.c | 643 ++++++++++++ v7/src/microcode/hunk.c | 172 ++++ v7/src/microcode/image.c | 1164 +++++++++++++++++++++ v7/src/microcode/image.h | 16 + v7/src/microcode/intercom.c | 198 ++++ v7/src/microcode/interp.c | 1648 ++++++++++++++++++++++++++++++ v7/src/microcode/interp.h | 391 +++++++ v7/src/microcode/list.c | 284 ++++++ v7/src/microcode/load.c | 97 ++ v7/src/microcode/locks.h | 55 + v7/src/microcode/missing.c | 159 +++ v7/src/microcode/mul.c | 78 ++ v7/src/microcode/object.h | 209 ++++ v7/src/microcode/ppband.c | 239 +++++ v7/src/microcode/prim.c | 422 ++++++++ v7/src/microcode/prims.h | 148 +++ v7/src/microcode/pruxfs.c | 89 ++ v7/src/microcode/psbmap.h | 268 +++++ v7/src/microcode/psbtobin.c | 630 ++++++++++++ v7/src/microcode/purify.c | 568 +++++++++++ v7/src/microcode/returns.h | 124 +++ v7/src/microcode/sample.c | 222 ++++ v7/src/microcode/scheme.h | 89 ++ v7/src/microcode/scode.h | 133 +++ v7/src/microcode/sdata.h | 495 +++++++++ v7/src/microcode/stack.h | 322 ++++++ v7/src/microcode/step.c | 152 +++ v7/src/microcode/storage.c | 1901 +++++++++++++++++++++++++++++++++++ v7/src/microcode/string.c | 570 +++++++++++ v7/src/microcode/sysprim.c | 155 +++ v7/src/microcode/types.h | 129 +++ v7/src/microcode/unexec.c | 654 ++++++++++++ v7/src/microcode/utils.c | 670 ++++++++++++ v7/src/microcode/vector.c | 278 +++++ v7/src/microcode/version.h | 52 + v7/src/microcode/winder.h | 49 + v7/src/microcode/wsize.c | 104 ++ v7/src/microcode/xdebug.c | 227 +++++ v7/src/microcode/zones.h | 84 ++ v8/src/microcode/bintopsb.c | 858 ++++++++++++++++ v8/src/microcode/const.h | 185 ++++ v8/src/microcode/fasl.h | 106 ++ v8/src/microcode/fixobj.h | 87 ++ v8/src/microcode/gctype.c | 208 ++++ v8/src/microcode/interp.c | 1648 ++++++++++++++++++++++++++++++ v8/src/microcode/mul.c | 78 ++ v8/src/microcode/object.h | 209 ++++ v8/src/microcode/ppband.c | 239 +++++ v8/src/microcode/psbmap.h | 268 +++++ v8/src/microcode/psbtobin.c | 630 ++++++++++++ v8/src/microcode/returns.h | 124 +++ v8/src/microcode/types.h | 129 +++ v8/src/microcode/version.h | 52 + 91 files changed, 32557 insertions(+) create mode 100644 v7/src/microcode/array.c create mode 100644 v7/src/microcode/array.h create mode 100644 v7/src/microcode/bignum.c create mode 100644 v7/src/microcode/bignum.h create mode 100644 v7/src/microcode/bintopsb.c create mode 100644 v7/src/microcode/bitstr.c create mode 100644 v7/src/microcode/bkpt.c create mode 100644 v7/src/microcode/bkpt.h create mode 100644 v7/src/microcode/boot.c create mode 100644 v7/src/microcode/breakup.c create mode 100644 v7/src/microcode/char.c create mode 100644 v7/src/microcode/config.h create mode 100644 v7/src/microcode/const.h create mode 100644 v7/src/microcode/daemon.c create mode 100644 v7/src/microcode/debug.c create mode 100644 v7/src/microcode/default.h create mode 100644 v7/src/microcode/dmpwrld.c create mode 100644 v7/src/microcode/dump.c create mode 100644 v7/src/microcode/errors.h create mode 100644 v7/src/microcode/extern.c create mode 100644 v7/src/microcode/extern.h create mode 100644 v7/src/microcode/fasdump.c create mode 100644 v7/src/microcode/fasl.h create mode 100644 v7/src/microcode/fasload.c create mode 100644 v7/src/microcode/fft.c create mode 100644 v7/src/microcode/fhooks.c create mode 100644 v7/src/microcode/findprim.c create mode 100644 v7/src/microcode/fixnum.c create mode 100644 v7/src/microcode/fixobj.h create mode 100644 v7/src/microcode/flonum.c create mode 100644 v7/src/microcode/future.c create mode 100644 v7/src/microcode/futures.h create mode 100644 v7/src/microcode/gc.h create mode 100644 v7/src/microcode/gccode.h create mode 100644 v7/src/microcode/gcloop.c create mode 100644 v7/src/microcode/gctype.c create mode 100644 v7/src/microcode/generic.c create mode 100644 v7/src/microcode/history.h create mode 100644 v7/src/microcode/hooks.c create mode 100644 v7/src/microcode/hunk.c create mode 100644 v7/src/microcode/image.c create mode 100644 v7/src/microcode/image.h create mode 100644 v7/src/microcode/intercom.c create mode 100644 v7/src/microcode/interp.c create mode 100644 v7/src/microcode/interp.h create mode 100644 v7/src/microcode/list.c create mode 100644 v7/src/microcode/load.c create mode 100644 v7/src/microcode/locks.h create mode 100644 v7/src/microcode/missing.c create mode 100644 v7/src/microcode/mul.c create mode 100644 v7/src/microcode/object.h create mode 100644 v7/src/microcode/ppband.c create mode 100644 v7/src/microcode/prim.c create mode 100644 v7/src/microcode/prims.h create mode 100644 v7/src/microcode/pruxfs.c create mode 100644 v7/src/microcode/psbmap.h create mode 100644 v7/src/microcode/psbtobin.c create mode 100644 v7/src/microcode/purify.c create mode 100644 v7/src/microcode/returns.h create mode 100644 v7/src/microcode/sample.c create mode 100644 v7/src/microcode/scheme.h create mode 100644 v7/src/microcode/scode.h create mode 100644 v7/src/microcode/sdata.h create mode 100644 v7/src/microcode/stack.h create mode 100644 v7/src/microcode/step.c create mode 100644 v7/src/microcode/storage.c create mode 100644 v7/src/microcode/string.c create mode 100644 v7/src/microcode/sysprim.c create mode 100644 v7/src/microcode/types.h create mode 100644 v7/src/microcode/unexec.c create mode 100644 v7/src/microcode/utils.c create mode 100644 v7/src/microcode/vector.c create mode 100644 v7/src/microcode/version.h create mode 100644 v7/src/microcode/winder.h create mode 100644 v7/src/microcode/wsize.c create mode 100644 v7/src/microcode/xdebug.c create mode 100644 v7/src/microcode/zones.h create mode 100644 v8/src/microcode/bintopsb.c create mode 100644 v8/src/microcode/const.h create mode 100644 v8/src/microcode/fasl.h create mode 100644 v8/src/microcode/fixobj.h create mode 100644 v8/src/microcode/gctype.c create mode 100644 v8/src/microcode/interp.c create mode 100644 v8/src/microcode/mul.c create mode 100644 v8/src/microcode/object.h create mode 100644 v8/src/microcode/ppband.c create mode 100644 v8/src/microcode/psbmap.h create mode 100644 v8/src/microcode/psbtobin.c create mode 100644 v8/src/microcode/returns.h create mode 100644 v8/src/microcode/types.h create mode 100644 v8/src/microcode/version.h diff --git a/v7/src/microcode/array.c b/v7/src/microcode/array.c new file mode 100644 index 000000000..bcbe404d2 --- /dev/null +++ b/v7/src/microcode/array.c @@ -0,0 +1,1120 @@ +/* -*- C -*- */ +#include "scheme.h" +#include "primitive.h" +#include "flonum.h" +#include "array.h" +#include + +/* 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); +} + +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); +} + +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++) ; + } +} + + +/**** 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; +} +*/ + +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); +} + +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); +} + +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; +} + +Define_Primitive(Prim_Array_Length, 1, "ARRAY-LENGTH") +{ Primitive_1_Args(); + Arg_1_Type(TC_ARRAY); + return Make_Pointer(TC_FIXNUM, Array_Length(Arg1)); +} + +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); +} + +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); +} + +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; +} + +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; +} + +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; +} + +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; +} + +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; i0) + { + 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 ; +} + +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); +} + +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_indexxmax) Primitive_Error(ERR_ARG_3_BAD_RANGE); + + for (i=0; i < Length; i++) { + if ((*From_Here)xmax) *To_Here++ = xmax; + else *To_Here++ = *From_Here; + From_Here++ ; + } + return Result; +} + +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)Max_Val) *To_Here++ = Max_Val; + else *To_Here++ = *From_Here; + From_Here++ ; + } +} + + +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; +} + +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; i0.0)) return(.08 + .46 * (1 - t_bar)); + else return (0); +} + +double hanning(t, length) double t, length; +{ double twopi = 6.28318530717958; + double pi = twopi/2.; + double t_bar = cos(twopi * (t / length)); + if ((t0.0)) return(.5 * (1 - t_bar)); + else return (0); +} + +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); +} + +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 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; kHigh)) 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 ((valueHigh)) 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 */ + + +/* 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; + */ + + +/* FROM BOB-XT.C */ +extern void Find_Offset_Scale_For_Linear_Map(); /* REAL Min,Max, New_Min,New_Max, *Offset,*Scale; */ + + +#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)); +*/ + +#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)); \ + } \ + } \ + } + + + +/* the end */ diff --git a/v7/src/microcode/bignum.c b/v7/src/microcode/bignum.c new file mode 100644 index 000000000..ceaa1b095 --- /dev/null +++ b/v7/src/microcode/bignum.c @@ -0,0 +1,946 @@ +/* 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: BIGNUM.C + * + * This file contains the procedures for handling BIGNUM Arithmetic + * + */ + +#include "scheme.h" +#include +#include "primitive.h" +#include "bignum.h" +#include "flonum.h" +#include "zones.h" + +/* 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; +} + +/* 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); +} + +/* (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); +} + +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); +} + + +#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); +} + +/* 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 */ + +/* 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); +} + +/* 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 */ + +/* 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); +} + +/* 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 */ + +/* 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); +} + +/* (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; +} + +/* 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 + +/* 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); + } + +/* 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); +} + +/* 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; +} + +/* 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 */ + +/* 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 */ + +/* 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); + } +} + + +/* (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); +} + +/* 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); +} + +/* 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 */ +} + +/* 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); + +/* 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) diff --git a/v7/src/microcode/bignum.h b/v7/src/microcode/bignum.h new file mode 100644 index 000000000..f9e15065a --- /dev/null +++ b/v7/src/microcode/bignum.h @@ -0,0 +1,184 @@ +/* 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. * +* * +****************************************************************/ + +/* 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 + +#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; \ + } + +/* 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) & 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) + +/* 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); + +#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))); \ +} diff --git a/v7/src/microcode/bintopsb.c b/v7/src/microcode/bintopsb.c new file mode 100644 index 000000000..1ce0dd57a --- /dev/null +++ b/v7/src/microcode/bintopsb.c @@ -0,0 +1,858 @@ +/* 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. + * + */ + +/* 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" + +/* 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 +#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)); + } + } +} + +#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; +} + +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; +} + +#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; +} + +#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; +} + +/* 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; \ + } \ + } \ +} + +/* 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 + +/* 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); + } + } +} + +/* 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); \ + } \ +} + +/* 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 + +/* 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 + + /* 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 + + /* 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"); + + /* 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"); + + /* 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 + + /* 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; +} + +/* 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; +} diff --git a/v7/src/microcode/bitstr.c b/v7/src/microcode/bitstr.c new file mode 100644 index 000000000..03b2dae16 --- /dev/null +++ b/v7/src/microcode/bitstr.c @@ -0,0 +1,861 @@ +/* -*-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. */ + +/* + +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) + +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); +} + +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; +} + +/* (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)); +} + +/* 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)); + +/* (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; +} + +#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) +} + +#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) + } + } +} + +#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) + +/* (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); +} + +#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)); + } + } + + 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); + } + } + + { + 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); + } + } + } + } + + 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); + } + } + + { + 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)); + } + } + } + } +} + +/* 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; + } + } +} + +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; + } + } +} + +/* (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) +} + +/* (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); +} + +/* 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); +} diff --git a/v7/src/microcode/bkpt.c b/v7/src/microcode/bkpt.c new file mode 100644 index 000000000..4084a6d22 --- /dev/null +++ b/v7/src/microcode/bkpt.c @@ -0,0 +1,112 @@ +/* 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. + * + */ + +#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; +} diff --git a/v7/src/microcode/bkpt.h b/v7/src/microcode/bkpt.h new file mode 100644 index 000000000..426da658d --- /dev/null +++ b/v7/src/microcode/bkpt.h @@ -0,0 +1,107 @@ +/* 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 + +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 + +/* 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 */ + diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c new file mode 100644 index 000000000..e153b406a --- /dev/null +++ b/v7/src/microcode/boot.c @@ -0,0 +1,601 @@ +/* -*-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: 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. + +*/ + +#include "scheme.h" +#include "primitive.h" +#include "prims.h" +#include "version.h" +#ifndef islower +#include +#endif + +#define STRING_SIZE 512 +#define BLOCKSIZE 1024 +#define blocks(n) ((n)*BLOCKSIZE) + +/* 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]); +} + +/* 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 */ + +/* 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); +} + +/* 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). + +*/ + +/* 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; +} + +/* 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 + +#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); \ +} + +/* 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 ) SYSTEM-GLOBAL-ENVIRONMENT) + if Start_Prim is FASLOAD. Otherwise it is + (BAND-LOAD ) +*/ + + FName = C_String_To_Scheme_String(File_Name); + Fasload_Call = Free; + switch (Start_Prim) + { case PC_FASLOAD: /* (SCODE-EVAL (FASLOAD ) 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 ) */ + *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 */ + +/* 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); +} + +#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); +} + +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; +} + +/*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 */ + +/* 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); +} + diff --git a/v7/src/microcode/breakup.c b/v7/src/microcode/breakup.c new file mode 100644 index 000000000..c49e7f403 --- /dev/null +++ b/v7/src/microcode/breakup.c @@ -0,0 +1,135 @@ +#include + +#ifndef isdigit +#include +#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); +} diff --git a/v7/src/microcode/char.c b/v7/src/microcode/char.c new file mode 100644 index 000000000..6ea786af1 --- /dev/null +++ b/v7/src/microcode/char.c @@ -0,0 +1,258 @@ +/* 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. + */ + +#include +#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))); +} + +/* 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)); +} + +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)); +} + +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); + } +} + +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); + } +} diff --git a/v7/src/microcode/config.h b/v7/src/microcode/config.h new file mode 100644 index 000000000..b67f22c09 --- /dev/null +++ b/v7/src/microcode/config.h @@ -0,0 +1,437 @@ +/* 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: 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 + +/* 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 */ + +/* 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; + +/* 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_. + 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. +*/ + +/* 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 + +/* 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 + +#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 + +#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 +#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 + +#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 + +/* 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 diff --git a/v7/src/microcode/const.h b/v7/src/microcode/const.h new file mode 100644 index 000000000..2e97292d9 --- /dev/null +++ b/v7/src/microcode/const.h @@ -0,0 +1,185 @@ +/* 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 + * + */ + +#if (CHAR_SIZE != 8) +#define MAX_CHAR ((1<>16)&0xFF)+ \ + ((Datum(P)>>8)&0xFF)+ \ + (Datum(P) & 0xFF)) + +Pointer The_Hash_Table, The_Unhash_Table; +long HASH_TABLE_SIZE; + +/* (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; +} + +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; +} + +/* (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); +} + +/* (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; +} + +/* (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 */ + +/* 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; +} + +/* 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 + +/* (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 */ + +/* 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; +} diff --git a/v7/src/microcode/debug.c b/v7/src/microcode/debug.c new file mode 100644 index 000000000..42f56d17f --- /dev/null +++ b/v7/src/microcode/debug.c @@ -0,0 +1,737 @@ +/* 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" + +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 + } +} + +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"); +} + +/* 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"); +} + +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(")"); +} + +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(); +} + +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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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); +} + +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; +} + +/* 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; +} + +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"); + } +} + +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; +} + +/* 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; + } +} + +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"; + } +} + +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 + +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, Set, 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 */ + +/* 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 */ diff --git a/v7/src/microcode/default.h b/v7/src/microcode/default.h new file mode 100644 index 000000000..850c5f30e --- /dev/null +++ b/v7/src/microcode/default.h @@ -0,0 +1,297 @@ +/* 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. + * + */ + +/* 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 + +#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 + +/* 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 + +/* 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 + +/* 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 + +/* 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 + +/* 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 + +/* 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 diff --git a/v7/src/microcode/dmpwrld.c b/v7/src/microcode/dmpwrld.c new file mode 100644 index 000000000..4bb01f1c8 --- /dev/null +++ b/v7/src/microcode/dmpwrld.c @@ -0,0 +1,182 @@ +/* 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" + +#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; + +/* 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); +} + +/* 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" diff --git a/v7/src/microcode/dump.c b/v7/src/microcode/dump.c new file mode 100644 index 000000000..8e0e700db --- /dev/null +++ b/v7/src/microcode/dump.c @@ -0,0 +1,84 @@ +/* -*-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. + */ + +#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); +} diff --git a/v7/src/microcode/errors.h b/v7/src/microcode/errors.h new file mode 100644 index 000000000..e32da9b63 --- /dev/null +++ b/v7/src/microcode/errors.h @@ -0,0 +1,135 @@ +/* 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 + * + */ + +/* 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 + +/* 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 + +/* 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 diff --git a/v7/src/microcode/extern.c b/v7/src/microcode/extern.c new file mode 100644 index 000000000..2bc9ed53d --- /dev/null +++ b/v7/src/microcode/extern.c @@ -0,0 +1,198 @@ +/* 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: 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" + +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); +} + +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); +} + +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)); +} + +/* 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; +} diff --git a/v7/src/microcode/extern.h b/v7/src/microcode/extern.h new file mode 100644 index 000000000..79fac772d --- /dev/null +++ b/v7/src/microcode/extern.h @@ -0,0 +1,220 @@ +/* -*-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. + * + */ + +#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 + +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(); + +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; + +/* 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(); + +/* 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[]; + +/* Conditional utilities */ + +#if false +extern void Clear_Perfinfo_Data(); +#endif diff --git a/v7/src/microcode/fasdump.c b/v7/src/microcode/fasdump.c new file mode 100644 index 000000000..826624c34 --- /dev/null +++ b/v7/src/microcode/fasdump.c @@ -0,0 +1,345 @@ +/* -*-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" + +/* 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, # + 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. +*/ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* (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 */ + +/* 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 */ + +/* 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(); +} + +/* (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; +} + diff --git a/v7/src/microcode/fasl.h b/v7/src/microcode/fasl.h new file mode 100644 index 000000000..7f24ce777 --- /dev/null +++ b/v7/src/microcode/fasl.h @@ -0,0 +1,106 @@ +/* -*-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. +*/ + +/* 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) & 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))) + +#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 diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c new file mode 100644 index 000000000..0e0d8e205 --- /dev/null +++ b/v7/src/microcode/fasload.c @@ -0,0 +1,672 @@ +/* -*-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. + */ + +#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" + +/* 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)); +} + +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)); +} + +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; +} + +/* 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 */ + +/* 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; +} + +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 */ + +/* 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); +} + +/* 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 + +/* 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)); + } + } + } +} + +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; +} + +/* 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; +} + +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; + } + } +} + +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 */ + +/* 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; +} + +/* (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); +} + +/* (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 */ + +/* 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); + } +} + +/* (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); +} + +/* (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; +} diff --git a/v7/src/microcode/fft.c b/v7/src/microcode/fft.c new file mode 100644 index 000000000..4cceae228 --- /dev/null +++ b/v7/src/microcode/fft.c @@ -0,0 +1,642 @@ +/* -*- C -*- */ +/* FFT scheme primitive, using YEKTA FFT */ + +#include "scheme.h" +#include "primitive.h" +#include "flonum.h" +#include "zones.h" +#include +#include "array.h" +#include "image.h" + + +#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; \ + } \ + } \ +} + +/* 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 */ + +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 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 do one more mult */ + mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */ + for (m=0; m>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 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 do one more mult */ + mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */ + for (m=0; m1; 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>1); + Make_Twiddle_Tables(w1,w2,nrows,flag); + for (i=0;i1; 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;i1; 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."); + } +} + +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 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; +} + +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; } + + 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>1); + for (i=0;i>1); + for (i=0;i1; 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; } + + 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>1); + Make_Twiddle_Tables(w1,w2,ncols, flag); + for (i=0;i>1); + Make_Twiddle_Tables(w1,w2,nrows,flag); + for (i=0;i + +/* For macros toupper, isalpha, etc, supposedly on the standard library */ +#include + +#ifdef vax +#ifdef vms +#define normal_exit() return +#else /* Vax, but not a VMS */ +#define normal_exit() exit(0) +#include +#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(); + } + +#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; +} + +#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; + } +} + +/* FIX: No-op for now */ + +sort() +{ return FALSE; +} + +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; +} diff --git a/v7/src/microcode/fixnum.c b/v7/src/microcode/fixnum.c new file mode 100644 index 000000000..e1c4aff11 --- /dev/null +++ b/v7/src/microcode/fixnum.c @@ -0,0 +1,218 @@ +/* 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. * +* * +****************************************************************/ + +#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; +} + + /****************************/ + /* 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(<); +} + + /****************************/ + /* 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); +} + +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); +} + +/* (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); +} diff --git a/v7/src/microcode/fixobj.h b/v7/src/microcode/fixobj.h new file mode 100644 index 000000000..5e459cf0d --- /dev/null +++ b/v7/src/microcode/fixobj.h @@ -0,0 +1,87 @@ +/* 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 + */ + +#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 + diff --git a/v7/src/microcode/flonum.c b/v7/src/microcode/flonum.c new file mode 100644 index 000000000..d45355a80 --- /dev/null +++ b/v7/src/microcode/flonum.c @@ -0,0 +1,265 @@ +/* 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: 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)); +} + +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)); +} + + /************************************/ + /* 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); +} + + /***********************************/ + /* 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))); +} + +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))); +} + +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); +} + +/* (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; +} + +/* (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); +} + +/* (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); +} diff --git a/v7/src/microcode/future.c b/v7/src/microcode/future.c new file mode 100644 index 000000000..58f71c7b1 --- /dev/null +++ b/v7/src/microcode/future.c @@ -0,0 +1,364 @@ +/* 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" + +#ifndef COMPILE_FUTURES +#include "Error: future.c is useless without COMPILE_FUTURES" +#endif + +/* + +A future is a VECTOR starting with , and +, + +where 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 is #!true if someone wants slot kept for a time. + +*/ + +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; +} + +/* 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?! ) + Replaces the CAR of with if it used to contain + . The value returned is either (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; +} + +Define_Primitive(Prim_Set_Cdr_If_Eq, 3, "SET-CDR-IF-EQ?!") +/* (SET-CDR-IF-EQ?! ) + Replaces the CDR of with if it used to contain + . The value returned is either (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?! ) + Replaces the th element of with if it used + to contain . The value returned is either (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?! ) + Replaces the th CXR of with if it used to + contain . The value returned is either (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; +} + +Define_Primitive(Prim_Future_Ref, 2, "FUTURE-REF") +/* (FUTURE-REF ) + Returns the 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! ) + Modifies the 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; +} + +Define_Primitive(Prim_Future_Size, 1, "FUTURE-SIZE") +/* (FUTURE-SIZE ) + 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! ) + 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! ) + 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; + }; +} + +Define_Primitive(Prim_Future_To_Vector, 1, "FUTURE->VECTOR") +/* (FUTURE->VECTOR ) + Create a COPY of 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 */ + +/* 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; +} + +/* + 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; } + diff --git a/v7/src/microcode/futures.h b/v7/src/microcode/futures.h new file mode 100644 index 000000000..b2b73886a --- /dev/null +++ b/v7/src/microcode/futures.h @@ -0,0 +1,203 @@ +/* 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 + */ + +/* 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 */ + +#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; \ +} + +/* 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. +*/ + +#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 diff --git a/v7/src/microcode/gc.h b/v7/src/microcode/gc.h new file mode 100644 index 000000000..28258ac32 --- /dev/null +++ b/v7/src/microcode/gc.h @@ -0,0 +1,111 @@ +/* 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. + */ + +/* 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) + +/* 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) diff --git a/v7/src/microcode/gccode.h b/v7/src/microcode/gccode.h new file mode 100644 index 000000000..5f18c352c --- /dev/null +++ b/v7/src/microcode/gccode.h @@ -0,0 +1,432 @@ +/* -*-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. + * + */ + +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 */ + +/* 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 */ + +/* 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 +*/ + +#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; \ +} + +#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) + +/* 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() + +#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 + +#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 + +/* 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(); \ +} + +/* 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() + +/* 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 diff --git a/v7/src/microcode/gcloop.c b/v7/src/microcode/gcloop.c new file mode 100644 index 000000000..39bf0d5e7 --- /dev/null +++ b/v7/src/microcode/gcloop.c @@ -0,0 +1,393 @@ +/* -*-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" + +#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 */ + +/* 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 */ + +/* 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 */ + +/* 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; +} + +/* 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; +} + +/* 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. +*/ + +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; +} + +/* (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 + +/* (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)); +} diff --git a/v7/src/microcode/gctype.c b/v7/src/microcode/gctype.c new file mode 100644 index 000000000..f45da3d09 --- /dev/null +++ b/v7/src/microcode/gctype.c @@ -0,0 +1,208 @@ +/* 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. + * + */ + + /*********************************/ + /* 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 */ + +/* 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 */ + +/* 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 diff --git a/v7/src/microcode/generic.c b/v7/src/microcode/generic.c new file mode 100644 index 000000000..ab7bced86 --- /dev/null +++ b/v7/src/microcode/generic.c @@ -0,0 +1,846 @@ +/* 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. * +* * +****************************************************************/ + +#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*/ +} + +#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*/ } + +#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*/ } + +#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) + +#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) + +#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) + +#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*/ } + +#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) + +#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) + +#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) + +#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) + +#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*/ } + +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 */ + +/* 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 */ + +/* 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*/ +} + +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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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*/ +} + +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 */ + +/* 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*/ +} + +/* 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) + +/* 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*/ } + +/* 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 + +#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*/ } diff --git a/v7/src/microcode/history.h b/v7/src/microcode/history.h new file mode 100644 index 000000000..fc078a441 --- /dev/null +++ b/v7/src/microcode/history.h @@ -0,0 +1,144 @@ +/* -*-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)) + +/* 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 */ + +/* 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 */ diff --git a/v7/src/microcode/hooks.c b/v7/src/microcode/hooks.c new file mode 100644 index 000000000..ee19b7e26 --- /dev/null +++ b/v7/src/microcode/hooks.c @@ -0,0 +1,643 @@ +/* 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: 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" + +/* (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); + + 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); +} + +/* 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(); */ + +#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 + +/* (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 + +/* (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; +} + +/* (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*/ +} + +/* (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); +} + +/* (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; + } +} + +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; +} + +/* (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; +} + +/* (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; +} + +/* (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); +} + +/* 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); +} + +/* (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); +} + diff --git a/v7/src/microcode/hunk.c b/v7/src/microcode/hunk.c new file mode 100644 index 000000000..48b892fa7 --- /dev/null +++ b/v7/src/microcode/hunk.c @@ -0,0 +1,172 @@ +/* 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: 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); +} + +/* (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); +} + +/* (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); +} + +/* (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); +} + +/* (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); +} + diff --git a/v7/src/microcode/image.c b/v7/src/microcode/image.c new file mode 100644 index 000000000..81c10429a --- /dev/null +++ b/v7/src/microcode/image.c @@ -0,0 +1,1164 @@ +/* -*- C -*- */ +#include "scheme.h" +#include "primitive.h" +#include "flonum.h" +#include "array.h" +#include + +/* 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; iArray[i*ncols+j] */ + }} + + return Result; +} + +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;incols) 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; +} + +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; +} + +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;jSquare_HC)) + Ring_Array[i*ncols+j] = 0; + else Ring_Array[i*ncols+j] = 1; + }} +} + + +/* 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; + + /* 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; +} + +/* ASSUMES hor_shift 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 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 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 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 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 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;i0.0)) return(.08 + .46 * (1 - t_bar)); + else return (0); +} + +REAL hanning(t, length) REAL t, length; +{ REAL twopi = 6.28318530717958; + REAL pi = twopi/2.; + REAL t_bar = cos(twopi * (t / length)); + if ((t0.0)) + return(.5 * (1 - t_bar)); + else return (0); +} + +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); +} + +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 ); +} + +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; +} + +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= 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); +} + + diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c new file mode 100644 index 000000000..3011b2177 --- /dev/null +++ b/v7/src/microcode/interp.c @@ -0,0 +1,1648 @@ +/* -*-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" + +/* 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. + */ + +#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() + +#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 + +#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) + + /***********************/ + /* 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) + +/* 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; \ +} + +/* 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 */ + +/* 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 + +/* 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); + } + + /*****************/ + /* 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. + */ + +/* 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; + } + +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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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; + + 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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; + + 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 */ + +/* 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 */ + +/* 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 */ + +/* 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); + +#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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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)); + } + + 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 */ + +/* 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 */ + +/* 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; + + 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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; +} diff --git a/v7/src/microcode/interp.h b/v7/src/microcode/interp.h new file mode 100644 index 000000000..f129a2408 --- /dev/null +++ b/v7/src/microcode/interp.h @@ -0,0 +1,391 @@ +/* -*-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. + * + */ + + /********************/ + /* 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 */ + +/* 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) + +/* 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 */ + +/* 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 */ + +/* 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 + +/* 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; \ +} + +/* 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); \ + }); \ + } \ +} + +/* 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(); \ +} + +/* 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() + +/* 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(); \ +} diff --git a/v7/src/microcode/list.c b/v7/src/microcode/list.c new file mode 100644 index 000000000..680873525 --- /dev/null +++ b/v7/src/microcode/list.c @@ -0,0 +1,284 @@ +/* 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: LIST.C + * + * List creation and manipulation primitives. + */ + +#include "scheme.h" +#include "primitive.h" + +/* (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); +} + +/* (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; +} + +/* (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; +} + +/* (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); +} + +/* (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; +} + +/* (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*/ +} + + +/* (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); +} + diff --git a/v7/src/microcode/load.c b/v7/src/microcode/load.c new file mode 100644 index 000000000..7790aa748 --- /dev/null +++ b/v7/src/microcode/load.c @@ -0,0 +1,97 @@ +/* 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. + * + */ + +#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; +} diff --git a/v7/src/microcode/locks.h b/v7/src/microcode/locks.h new file mode 100644 index 000000000..4bfbee185 --- /dev/null +++ b/v7/src/microcode/locks.h @@ -0,0 +1,55 @@ +/* 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: 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. */ + + diff --git a/v7/src/microcode/missing.c b/v7/src/microcode/missing.c new file mode 100644 index 000000000..4545092e6 --- /dev/null +++ b/v7/src/microcode/missing.c @@ -0,0 +1,159 @@ +/* -*-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. * +* * +****************************************************************/ + +/* 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; +} + + +#ifdef DEBUG_MISSING + +#include + +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 + diff --git a/v7/src/microcode/mul.c b/v7/src/microcode/mul.c new file mode 100644 index 000000000..d4a73ab51 --- /dev/null +++ b/v7/src/microcode/mul.c @@ -0,0 +1,78 @@ +/* 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: 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) & 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; +} diff --git a/v7/src/microcode/object.h b/v7/src/microcode/object.h new file mode 100644 index 000000000..582c59e6c --- /dev/null +++ b/v7/src/microcode/object.h @@ -0,0 +1,209 @@ +/* -*-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. + * + */ + +/* 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<> 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))) + +#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) + +#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); + + + + diff --git a/v7/src/microcode/ppband.c b/v7/src/microcode/ppband.c new file mode 100644 index 000000000..47e92be0b --- /dev/null +++ b/v7/src/microcode/ppband.c @@ -0,0 +1,239 @@ +/* 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" + +#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'); +} + +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)); +} diff --git a/v7/src/microcode/prim.c b/v7/src/microcode/prim.c new file mode 100644 index 000000000..d4f717efb --- /dev/null +++ b/v7/src/microcode/prim.c @@ -0,0 +1,422 @@ +/* -*-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" + +/* 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; +} + +/* 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); +} + +/* (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); +} + +/* 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); +} + +/* 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); +} + +/* (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; +} + +/* 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)); +} + +/* (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; +} + +/* 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); +} + +/* 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 */ diff --git a/v7/src/microcode/prims.h b/v7/src/microcode/prims.h new file mode 100644 index 000000000..b1ab6df78 --- /dev/null +++ b/v7/src/microcode/prims.h @@ -0,0 +1,148 @@ +/* -*-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. + * + */ + +/* 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() + +/* 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); } diff --git a/v7/src/microcode/pruxfs.c b/v7/src/microcode/pruxfs.c new file mode 100644 index 000000000..7c47f15d5 --- /dev/null +++ b/v7/src/microcode/pruxfs.c @@ -0,0 +1,89 @@ +/* -*-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. */ + +#include +#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)); +} diff --git a/v7/src/microcode/psbmap.h b/v7/src/microcode/psbmap.h new file mode 100644 index 000000000..995580707 --- /dev/null +++ b/v7/src/microcode/psbmap.h @@ -0,0 +1,268 @@ +/* -*-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 + * + */ + +/* These definitions insure that the appropriate code is extracted + from the included files. +*/ + +#include +#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)) + +/* 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; + +/* 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) + +/* 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; +} + +/* 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); +} + +/* 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 + diff --git a/v7/src/microcode/psbtobin.c b/v7/src/microcode/psbtobin.c new file mode 100644 index 000000000..3dfb67733 --- /dev/null +++ b/v7/src/microcode/psbtobin.c @@ -0,0 +1,630 @@ +/* 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. + * + */ + +/* 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" + +#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); + } +} + +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); +} + +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); + } +} + +/* 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; +} + +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; +} + +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; +} + +#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)); + } + } +} + +#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; +} + +#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 */ + +/* 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 + +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; +} + +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 + + /* 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; +} + +/* 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; +} diff --git a/v7/src/microcode/purify.c b/v7/src/microcode/purify.c new file mode 100644 index 000000000..9b48ab547 --- /dev/null +++ b/v7/src/microcode/purify.c @@ -0,0 +1,568 @@ +/* -*-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" + +/* 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 + +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 */ + +/* 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 */ + +/* 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 */ + +/* 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)<< +*/ + +/* 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; +} + +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 */ + +/* 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; +} + +/* (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*/ +} + +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; +} + +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); +} + +/* (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); + } +} + +/* (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; +} + +/* 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; +} diff --git a/v7/src/microcode/returns.h b/v7/src/microcode/returns.h new file mode 100644 index 000000000..2ed16107c --- /dev/null +++ b/v7/src/microcode/returns.h @@ -0,0 +1,124 @@ +/* -*-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 + * + */ + +/* 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 + +#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. */ diff --git a/v7/src/microcode/sample.c b/v7/src/microcode/sample.c new file mode 100644 index 000000000..68da4e46d --- /dev/null +++ b/v7/src/microcode/sample.c @@ -0,0 +1,222 @@ +/* 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. * +* * +****************************************************************/ + +/* 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. + */ + diff --git a/v7/src/microcode/scheme.h b/v7/src/microcode/scheme.h new file mode 100644 index 000000000..a67672f8a --- /dev/null +++ b/v7/src/microcode/scheme.h @@ -0,0 +1,89 @@ +/* -*-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. + */ + +/* "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 */ + +#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 +#include + +#ifdef butterfly +#include "butterfly.h" +#endif + +#include "default.h" /* Defaults for various hooks. */ +#include "extern.h" /* External declarations */ diff --git a/v7/src/microcode/scode.h b/v7/src/microcode/scode.h new file mode 100644 index 000000000..a28c2d4ac --- /dev/null +++ b/v7/src/microcode/scode.h @@ -0,0 +1,133 @@ +/* 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. + * + */ + +/* 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 + +/* 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 diff --git a/v7/src/microcode/sdata.h b/v7/src/microcode/sdata.h new file mode 100644 index 000000000..5c64cd948 --- /dev/null +++ b/v7/src/microcode/sdata.h @@ -0,0 +1,495 @@ +/* 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. + * + */ + +/* 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 + +/* 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) + +/* 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 */ + +/* 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 + +/* 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. + */ + +/* 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. + */ + +/* 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 + +/* 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. + */ + +/* 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 + +/* 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 + +/* 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. + */ + +/* 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. + */ diff --git a/v7/src/microcode/stack.h b/v7/src/microcode/stack.h new file mode 100644 index 000000000..d4cbc4521 --- /dev/null +++ b/v7/src/microcode/stack.h @@ -0,0 +1,322 @@ +/* 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: 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 + +/* 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)])) + +#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); \ +} + +/* 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! */ + +#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); \ + } \ +} + +#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 diff --git a/v7/src/microcode/step.c b/v7/src/microcode/step.c new file mode 100644 index 000000000..4bcebab59 --- /dev/null +++ b/v7/src/microcode/step.c @@ -0,0 +1,152 @@ +/* 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: 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); + } +} + +/* (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); +} + +/* (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); +} + +/* (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; +} diff --git a/v7/src/microcode/storage.c b/v7/src/microcode/storage.c new file mode 100644 index 000000000..e41209061 --- /dev/null +++ b/v7/src/microcode/storage.c @@ -0,0 +1,1901 @@ +/* -*-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" + + /*************/ + /* 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. *** + */ + +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 + + /**********************/ + /* 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"; + + + /*********************************/ + /* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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, /* SUBSTRINGSYMBOL", +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ "SUBSTRINGSYNTAX-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; + +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, + +/* 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; diff --git a/v7/src/microcode/string.c b/v7/src/microcode/string.c new file mode 100644 index 000000000..c52d660f3 --- /dev/null +++ b/v7/src/microcode/string.c @@ -0,0 +1,570 @@ +/* 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" + +/* 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); +} + +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); +} + +/* 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; +} + +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; +} + +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); +} + +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); +} + +/* 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 start) + { + end -= 1; + if (char_set[*--first] != '\0') + return (Make_Unsigned_Fixnum( end)); + } + return (NIL); +} + +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); +} + +Built_In_Primitive(Prim_Substring_Less, 6, "SUBSTRING *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); +} + +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); +} + +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); +} diff --git a/v7/src/microcode/sysprim.c b/v7/src/microcode/sysprim.c new file mode 100644 index 000000000..75d632624 --- /dev/null +++ b/v7/src/microcode/sysprim.c @@ -0,0 +1,155 @@ +/* -*-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" + +/* 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); +} + +/* 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; +} + +/* 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"); + +/* 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); +} diff --git a/v7/src/microcode/types.h b/v7/src/microcode/types.h new file mode 100644 index 000000000..2397dbc07 --- /dev/null +++ b/v7/src/microcode/types.h @@ -0,0 +1,129 @@ +/* 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 + * + */ + +#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 + +#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 */ diff --git a/v7/src/microcode/unexec.c b/v7/src/microcode/unexec.c new file mode 100644 index 000000000..a5f04bab3 --- /dev/null +++ b/v7/src/microcode/unexec.c @@ -0,0 +1,654 @@ +/* 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 +#ifndef makedev /* Try to detect types.h already loaded */ +#include +#endif +#include +#include +#include + +extern char *start_of_text (); /* Start of text */ +extern char *start_of_data (); /* Start of initialized data */ + +#ifdef COFF +#include +#include +#include +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 +#define SYMS_START ((long) N_SYMOFF (ohdr)) + +#ifdef HPUX +#ifdef hp9000s200 +#define MY_ID HP9000S200_ID +#else +#include +#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 +} + +/* **************************************************************** + * 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 */ +} + +/* **************************************************************** + * 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 */ +} + +/* **************************************************************** + * 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; +} + +/* **************************************************************** + * 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); +} + +/* + * 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 */ diff --git a/v7/src/microcode/utils.c b/v7/src/microcode/utils.c new file mode 100644 index 000000000..3be54aaf7 --- /dev/null +++ b/v7/src/microcode/utils.c @@ -0,0 +1,670 @@ +/* -*-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" + +/* 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< 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 */ + +/* 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(); +} + + /******************/ + /* 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 */ + +/* 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); +} + +/* 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; +} + +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. */ + +/* 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(); +} + +/* 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; +} + +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; +} + +/* 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; +} + +/* 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"); +} + +/* 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; +} + +#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 + +/* 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. +*/ + +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); +} diff --git a/v7/src/microcode/vector.c b/v7/src/microcode/vector.c new file mode 100644 index 000000000..b64e810e6 --- /dev/null +++ b/v7/src/microcode/vector.c @@ -0,0 +1,278 @@ +/* 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: VECTOR.C + * + * This file contains procedures for handling vectors and conversion + * back and forth to lists. + */ + +#include "scheme.h" +#include "primitive.h" + + /*********************/ + /* 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; +} + +/* 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); +} + +/* (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); +} + +/* (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); +} + +/* (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(); +} + +/* (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); +} + +/* (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); +} + diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h new file mode 100644 index 000000000..e5567d48d --- /dev/null +++ b/v7/src/microcode/version.h @@ -0,0 +1,52 @@ +/* -*-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. */ + +/* 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 diff --git a/v7/src/microcode/winder.h b/v7/src/microcode/winder.h new file mode 100644 index 000000000..63cf2fe1d --- /dev/null +++ b/v7/src/microcode/winder.h @@ -0,0 +1,49 @@ +/* -*-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. */ + +#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 diff --git a/v7/src/microcode/wsize.c b/v7/src/microcode/wsize.c new file mode 100644 index 000000000..d4be9f27c --- /dev/null +++ b/v7/src/microcode/wsize.c @@ -0,0 +1,104 @@ +#include +#include +#include + +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; +} diff --git a/v7/src/microcode/xdebug.c b/v7/src/microcode/xdebug.c new file mode 100644 index 000000000..84a76faa1 --- /dev/null +++ b/v7/src/microcode/xdebug.c @@ -0,0 +1,227 @@ +/* -*-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" + +/* 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; + } + } +} + +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); +} + +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; +} + +/* 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; +} + +/* 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; +} diff --git a/v7/src/microcode/zones.h b/v7/src/microcode/zones.h new file mode 100644 index 000000000..3d1fcea80 --- /dev/null +++ b/v7/src/microcode/zones.h @@ -0,0 +1,84 @@ +/* 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: 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 diff --git a/v8/src/microcode/bintopsb.c b/v8/src/microcode/bintopsb.c new file mode 100644 index 000000000..1ce0dd57a --- /dev/null +++ b/v8/src/microcode/bintopsb.c @@ -0,0 +1,858 @@ +/* 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. + * + */ + +/* 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" + +/* 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 +#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)); + } + } +} + +#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; +} + +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; +} + +#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; +} + +#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; +} + +/* 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; \ + } \ + } \ +} + +/* 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 + +/* 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); + } + } +} + +/* 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); \ + } \ +} + +/* 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 + +/* 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 + + /* 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 + + /* 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"); + + /* 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"); + + /* 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 + + /* 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; +} + +/* 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; +} diff --git a/v8/src/microcode/const.h b/v8/src/microcode/const.h new file mode 100644 index 000000000..2e97292d9 --- /dev/null +++ b/v8/src/microcode/const.h @@ -0,0 +1,185 @@ +/* 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 + * + */ + +#if (CHAR_SIZE != 8) +#define MAX_CHAR ((1<> 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))) + +#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 diff --git a/v8/src/microcode/fixobj.h b/v8/src/microcode/fixobj.h new file mode 100644 index 000000000..5e459cf0d --- /dev/null +++ b/v8/src/microcode/fixobj.h @@ -0,0 +1,87 @@ +/* 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 + */ + +#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 + diff --git a/v8/src/microcode/gctype.c b/v8/src/microcode/gctype.c new file mode 100644 index 000000000..f45da3d09 --- /dev/null +++ b/v8/src/microcode/gctype.c @@ -0,0 +1,208 @@ +/* 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. + * + */ + + /*********************************/ + /* 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 */ + +/* 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 */ + +/* 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 diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c new file mode 100644 index 000000000..3011b2177 --- /dev/null +++ b/v8/src/microcode/interp.c @@ -0,0 +1,1648 @@ +/* -*-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" + +/* 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. + */ + +#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() + +#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 + +#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) + + /***********************/ + /* 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) + +/* 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; \ +} + +/* 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 */ + +/* 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 + +/* 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); + } + + /*****************/ + /* 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. + */ + +/* 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; + } + +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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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; + + 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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; + + 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 */ + +/* 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 */ + +/* 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 */ + +/* 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); + +#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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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)); + } + + 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 */ + +/* 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 */ + +/* 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; + + 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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 */ + +/* 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; +} diff --git a/v8/src/microcode/mul.c b/v8/src/microcode/mul.c new file mode 100644 index 000000000..d4a73ab51 --- /dev/null +++ b/v8/src/microcode/mul.c @@ -0,0 +1,78 @@ +/* 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: 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) & 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; +} diff --git a/v8/src/microcode/object.h b/v8/src/microcode/object.h new file mode 100644 index 000000000..582c59e6c --- /dev/null +++ b/v8/src/microcode/object.h @@ -0,0 +1,209 @@ +/* -*-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. + * + */ + +/* 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<> 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))) + +#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) + +#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); + + + + diff --git a/v8/src/microcode/ppband.c b/v8/src/microcode/ppband.c new file mode 100644 index 000000000..47e92be0b --- /dev/null +++ b/v8/src/microcode/ppband.c @@ -0,0 +1,239 @@ +/* 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" + +#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'); +} + +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)); +} diff --git a/v8/src/microcode/psbmap.h b/v8/src/microcode/psbmap.h new file mode 100644 index 000000000..995580707 --- /dev/null +++ b/v8/src/microcode/psbmap.h @@ -0,0 +1,268 @@ +/* -*-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 + * + */ + +/* These definitions insure that the appropriate code is extracted + from the included files. +*/ + +#include +#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)) + +/* 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; + +/* 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) + +/* 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; +} + +/* 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); +} + +/* 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 + diff --git a/v8/src/microcode/psbtobin.c b/v8/src/microcode/psbtobin.c new file mode 100644 index 000000000..3dfb67733 --- /dev/null +++ b/v8/src/microcode/psbtobin.c @@ -0,0 +1,630 @@ +/* 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. + * + */ + +/* 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" + +#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); + } +} + +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); +} + +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); + } +} + +/* 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; +} + +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; +} + +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; +} + +#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)); + } + } +} + +#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; +} + +#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 */ + +/* 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 + +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; +} + +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 + + /* 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; +} + +/* 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; +} diff --git a/v8/src/microcode/returns.h b/v8/src/microcode/returns.h new file mode 100644 index 000000000..2ed16107c --- /dev/null +++ b/v8/src/microcode/returns.h @@ -0,0 +1,124 @@ +/* -*-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 + * + */ + +/* 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 + +#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. */ diff --git a/v8/src/microcode/types.h b/v8/src/microcode/types.h new file mode 100644 index 000000000..2397dbc07 --- /dev/null +++ b/v8/src/microcode/types.h @@ -0,0 +1,129 @@ +/* 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 + * + */ + +#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 + +#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 */ diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h new file mode 100644 index 000000000..e5567d48d --- /dev/null +++ b/v8/src/microcode/version.h @@ -0,0 +1,52 @@ +/* -*-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. */ + +/* 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 -- 2.25.1