New number primitives to support R4RS-compatible number system.
This microcode requires runtime version 14.58 or later.
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/array.c,v 9.39 1989/09/20 23:05:24 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/array.c,v 9.38 1989/07/30 23:59:02 pas Exp $ */
-
-\f
#include "scheme.h"
#include "prims.h"
-#include "flonum.h"
#include "array.h"
#include <math.h>
#include <values.h>
/* <values.h> contains some math constants */
-/* .
- ARRAY (as a scheme object)
+/* ARRAY (as a scheme object)
is a usual array (in C) containing REAL numbers (float/double)
- and tagged as a NM_VECTOR
-
+ and tagged as a non-marked vector.
+
Basic contents:
- constructors, selectors, arithmetic operations,
- conversion routines between C_Array, and Scheme_Vector
-
- see array.h for macros, NM_VECTOR, and extern
- */
+ constructors, selectors, arithmetic operations,
+ conversion routines between C_Array, and Scheme_Vector
+ see array.h for macros, NM_VECTOR, and extern */
/* mathematical constants */
#ifdef PI
#define SQRT_2 1.4142135623730950488
#define ONE_OVER_SQRT_2 .7071067811865475244
/* Abramowitz and Stegun */
-
-
-/* first some utilities */
-
-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);
+\f
+REAL
+flonum_to_real (argument, arg_number)
+ fast SCHEME_OBJECT argument;
+ int arg_number;
+{
+ switch (OBJECT_TYPE (argument))
+ {
+ case TC_FIXNUM:
+ return ((REAL) (FIXNUM_TO_DOUBLE (argument)));
+
+ case TC_BIG_FIXNUM:
+ if (! (BIGNUM_TO_DOUBLE_P (argument)))
+ error_bad_range_arg (arg_number);
+ return ((REAL) (bignum_to_double (argument)));
+
+ case TC_BIG_FLONUM:
+ return ((REAL) (FLONUM_TO_DOUBLE (argument)));
+
+ default:
+ error_wrong_type_arg (arg_number);
+ /* NOTREACHED */
}
- 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);
}
-
-/* c */
-
-/* I think this is not needed, it can be done in scheme
- DEFINE_PRIMITIVE ("ARRAY?", Prim_array_predicate, 1, 1, 0)
- { Primitive_1_Args();
- if (Type_Code(Arg1)==TC_ARRAY) return SHARP_F;
- else return SHARP_F;
- }
- */
+\f
+SCHEME_OBJECT
+allocate_array (length)
+ fast long length;
+{
+ fast SCHEME_OBJECT result =
+ (allocate_non_marked_vector
+ (TC_NON_MARKED_VECTOR, ((length * REAL_SIZE) + 1), true));
+ FAST_MEMORY_SET (result, 1, length);
+ return (result);
+}
DEFINE_PRIMITIVE ("VECTOR->ARRAY", Prim_vector_to_array, 1, 1, 0)
-{ Pointer Scheme_Vector_To_Scheme_Array();
- Primitive_1_Args();
- Arg_1_Type(TC_VECTOR);
- return Scheme_Vector_To_Scheme_Array(Arg1);
+{
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, VECTOR_P);
+ {
+ SCHEME_OBJECT vector = (ARG_REF (1));
+ long length = (VECTOR_LENGTH (vector));
+ SCHEME_OBJECT result = (allocate_array (length));
+ fast SCHEME_OBJECT * scan_source = (& (VECTOR_REF (vector, 0)));
+ fast SCHEME_OBJECT * end_source = (scan_source + length);
+ fast REAL * scan_target = (ARRAY_CONTENTS (result));
+ while (scan_source < end_source)
+ (*scan_target++) = (flonum_to_real ((*scan_source++), 1));
+ PRIMITIVE_RETURN (result);
+ }
}
DEFINE_PRIMITIVE ("ARRAY->VECTOR", Prim_array_to_vector, 1, 1, 0)
-{ Pointer Scheme_Array_To_Scheme_Vector();
- Primitive_1_Args();
- Arg_1_Type(TC_ARRAY);
- return Scheme_Array_To_Scheme_Vector(Arg1);
-}
-
-/* array-cons = (array-allocate followed by array-initialize!)
- The two are separated because all too often, we only need
- array memory space. Even though the initialization is fast, it
- happens so often that we get savings.
- Also array-initialize! occurs via subarray-offset-scale!.
-
- */
-DEFINE_PRIMITIVE ("ARRAY-ALLOCATE", Prim_array_allocate, 1,1, 0)
-{ long n,allocated_cells;
- Pointer Result;
+{
PRIMITIVE_HEADER (1);
- CHECK_ARG (1, FIXNUM_P);
-
- n = arg_nonnegative_integer(1); /* length of array to allocate */
- if (n > ARRAY_MAX_LENGTH) error_bad_range_arg(1); /* avoid memory overflow */
-
- Allocate_Array(Result,n,allocated_cells);
- PRIMITIVE_RETURN (Result);
+ CHECK_ARG (1, ARRAY_P);
+ {
+ SCHEME_OBJECT array = (ARG_REF (1));
+ long length = (ARRAY_LENGTH (array));
+ fast REAL * scan_source = (ARRAY_CONTENTS (array));
+ fast REAL * end_source = (scan_source + length);
+ SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, length, true));
+ fast SCHEME_OBJECT * scan_result = (MEMORY_LOC (result, 1));
+ while (scan_source < end_source)
+ (*scan_result++) = (double_to_flonum ((double) (*scan_source++)));
+ PRIMITIVE_RETURN (result);
+ }
}
+DEFINE_PRIMITIVE ("ARRAY-ALLOCATE", Prim_array_allocate, 1,1, 0)
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (allocate_array (arg_nonnegative_integer (1)));
+}
DEFINE_PRIMITIVE ("ARRAY-CONS-REALS", Prim_array_cons_reals, 3, 3, 0)
-{ long i, Length, allocated_cells;
- REAL *a;
- double from, dt;
- Pointer Result;
- int errcode;
- Primitive_3_Args();
-
- errcode = Scheme_Number_To_Double(Arg1, &from); /* starting time */
- if (errcode == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- if (errcode == 2) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- errcode = Scheme_Number_To_Double(Arg2, &dt); /* dt interval */
- if (errcode == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (errcode == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Length = Get_Integer(Arg3); /* number of points */
-
- Allocate_Array(Result,Length,allocated_cells);
- a = Scheme_Array_To_C_Array(Result);
- a[0] = (REAL) from;
- for (i=1; i<Length; i++) { from = from + dt; a[i] = (REAL) from; }
- /* the variable <from> is used as double precision accumulator */
- return Result;
+{
+ PRIMITIVE_HEADER (3);
+ {
+ fast double from = (arg_real_number (1));
+ fast double dt = (arg_real_number (2));
+ long length = (arg_nonnegative_integer (3));
+ SCHEME_OBJECT result = (allocate_array (length));
+ fast REAL * scan_result = (ARRAY_CONTENTS (result));
+ fast int i;
+ for (i = 0; (i < length); i += 1)
+ {
+ (*scan_result++) = ((REAL) from);
+ from += dt;
+ }
+ PRIMITIVE_RETURN (result);
+ }
}
DEFINE_PRIMITIVE ("ARRAY-LENGTH", Prim_array_length, 1, 1, 0)
-{ Primitive_1_Args();
- Arg_1_Type(TC_ARRAY);
- return Make_Pointer(TC_FIXNUM, Array_Length(Arg1));
+{
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, ARRAY_P);
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (ARRAY_LENGTH (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("ARRAY-REF", Prim_array_ref, 2, 2, 0)
-{ long Index;
- REAL *Array, value;
- 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);
+{
+ SCHEME_OBJECT array;
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, ARRAY_P);
+ array = (ARG_REF (1));
+ PRIMITIVE_RETURN
+ (double_to_flonum
+ ((double)
+ ((ARRAY_CONTENTS (array))
+ [arg_index_integer (2, (ARRAY_LENGTH (array)))])));
}
DEFINE_PRIMITIVE ("ARRAY-SET!", Prim_array_set, 3, 3, 0)
-{ long Index;
- REAL *Array, Old_Value;
- int errcode;
-
- 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];
-
- errcode = Scheme_Number_To_REAL(Arg3, &Array[Index]);
- if (errcode == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (errcode == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
-
- Reduced_Flonum_Result((double) Old_Value);
+{
+ SCHEME_OBJECT array;
+ REAL * array_ptr;
+ double old_value;
+ PRIMITIVE_HEADER (3);
+ CHECK_ARG (1, ARRAY_P);
+ array = (ARG_REF (1));
+ array_ptr =
+ (& ((ARRAY_CONTENTS (array))
+ [arg_index_integer (2, (ARRAY_LENGTH (array)))]));
+ old_value = (*array_ptr);
+ (*array_ptr) = (arg_real (3));
+ PRIMITIVE_RETURN (double_to_flonum (old_value));
}
-
-/*____________________ file readers ___________
- ascii and 2bint formats
- ______________________________________________*/
-
-/* Reading data from files
- ATTENTION: for reading REAL numbers, use "lf" for double, "%f" for float
- */
+\f
#if (REAL_IS_DEFINED_DOUBLE == 1)
#define REALREAD "%lf"
#define REALREAD2 "%lf %lf"
#define REALREAD2 "%f %f"
#endif
-DEFINE_PRIMITIVE ("ARRAY-READ-ASCII-FILE", Prim_array_read_ascii_file, 2, 2, 0)
-{ FILE *fp;
- long Length, allocated_cells;
- REAL *a;
- SCHEME_ARRAY Result;
- Primitive_2_Args();
- Arg_1_Type(TC_CHARACTER_STRING); /* filename */
- Arg_2_Type(TC_FIXNUM); /* length of data */
- Length = Get_Integer(Arg2);
- if (Length <= 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Allocate_Array(Result, Length, allocated_cells);
- if (!(Open_File(Arg1, "r", &fp))) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- printf("Reading ascii file ...\n"); fflush(stdout);
- a = Scheme_Array_To_C_Array(Result);
- C_Array_Read_Ascii_File(a,Length,fp);
- return Result;
-}
-C_Array_Read_Ascii_File(a,N,fp) /* 16 ascii decimal digits */
- REAL *a; long N; FILE *fp;
-{ long i;
- for (i=0; i<N; i++) {
- if ( (fscanf(fp, REALREAD, &(a[i]))) != 1)
- { printf("Not enough values read ---\n Last Point was %d with value % .16e \n", i, a[i-1]);
- return SHARP_F; }}
- Close_File(fp);
+static void
+C_Array_Read_Ascii_File (a, N, fp)
+ REAL * a;
+ long N;
+ FILE * fp;
+{
+ fast long i;
+ for (i = 0; (i < N); i += 1)
+ {
+ if ((fscanf (fp, REALREAD, (& (a [i])))) != 1)
+ error_external_return ();
+ }
+ return;
}
-DEFINE_PRIMITIVE ("ARRAY-WRITE-ASCII-FILE", Prim_array_write_ascii_file, 2, 2, 0)
-{ FILE *fp;
- long Length;
- REAL *a;
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
- Arg_2_Type(TC_CHARACTER_STRING); /* filename */
- if (!(Open_File(Arg2, "w", &fp))) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- printf("Writing ascii file ...\n"); fflush(stdout);
- a = Scheme_Array_To_C_Array(Arg1);
- C_Array_Write_Ascii_File(a,Length,fp);
- return SHARP_F;
-}
-C_Array_Write_Ascii_File(a,N,fp) /* 16 ascii decimal digits */
- REAL *a; long N; FILE *fp;
-{ long i;
- for (i=0; i<N; i++) {
- if (feof(fp)!=0) { printf("Not enough values written ---\n Last Point was %d with value %---\n", (i-1), a[i-1]);
- return SHARP_F; }
- fprintf(fp, "% .16e \n", a[i]); }
- Close_File(fp);
-}
-
-/* 2BINT FORMAT = integer stored in 2 consecutive bytes.
- We need to use 2bint because on many machines (bobcats included)
- "putw", and "getw" use 4 byte integers (C int) ---> waste lots of space.
- */
-DEFINE_PRIMITIVE ("ARRAY-READ-2BINT-FILE", Prim_array_read_2bint_file, 2, 2, 0)
-{ FILE *fp;
- long Length, allocated_cells;
- REAL *a;
- SCHEME_ARRAY Result;
- Primitive_2_Args();
- Arg_1_Type(TC_CHARACTER_STRING); /* filename */
- Arg_2_Type(TC_FIXNUM); /* length of data */
- Length = Get_Integer(Arg2);
- if (Length <= 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Allocate_Array(Result, Length, allocated_cells);
- if (!(Open_File(Arg1, "r", &fp))) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- printf("Reading 2bint file ...\n"); fflush(stdout);
- a = Scheme_Array_To_C_Array(Result);
- C_Array_Read_2bint_File(a,Length,fp);
- return Result;
-}
-C_Array_Read_2bint_File(a,N,fp)
- REAL *a; long N; FILE *fp;
-{ long i;
- int foo1,foo2;
- for (i=0;i<N;i++) {
- if (feof(fp)!=0) { printf("Not enough values read: last read i-1=%d , value=%d\n", (i-1), a[i-1]);
- return SHARP_F; }
- foo1=getc(fp); foo2=getc(fp); /* Read 2BYTE INT FORMAT */
- a[i] = ((REAL)
- ((foo1<<8) ^ foo2) ); /* put together the integer */
+DEFINE_PRIMITIVE ("ARRAY-READ-ASCII-FILE", Prim_array_read_ascii_file, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, STRING_P);
+ {
+ fast long length = (arg_nonnegative_integer (2));
+ fast SCHEME_OBJECT result = (allocate_array (length));
+ fast FILE * fp = (fopen ((ARG_REF (1)), "r"));
+ if (fp == ((FILE *) 0))
+ error_bad_range_arg (1);
+ C_Array_Read_Ascii_File ((ARRAY_CONTENTS (result)), length, fp);
+ if ((fclose (fp)) != 0)
+ error_external_return ();
+ PRIMITIVE_RETURN (result);
}
- Close_File(fp);
}
-/* C_Array_Write_2bint_File
- is not implemented yet, I do not have the time to do it now. */
-/* ----- Read data from files --- end*/
+static void
+C_Array_Write_Ascii_File (a, N, fp)
+ REAL * a;
+ long N;
+ FILE * fp;
+{
+ fast long i;
+ for (i = 0; (i < N); i += 1)
+ {
+ if (feof (fp))
+ error_external_return ();
+ fprintf (fp, "% .16e \n", a[i]);
+ }
+ return;
+}
+DEFINE_PRIMITIVE ("ARRAY-WRITE-ASCII-FILE", Prim_array_write_ascii_file, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, ARRAY_P);
+ CHECK_ARG (2, STRING_P);
+ {
+ fast SCHEME_OBJECT array = (ARG_REF (1));
+ fast FILE * fp = (fopen ((ARG_REF (2)), "w"));
+ if (fp == ((FILE *) 0))
+ error_bad_range_arg (2);
+ C_Array_Write_Ascii_File
+ ((ARRAY_CONTENTS (array)),
+ (ARRAY_LENGTH (array)),
+ fp);
+ if ((fclose (fp)) != 0)
+ error_external_return ();
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+static void
+C_Array_Read_2bint_File (a, N, fp)
+ REAL * a;
+ long N;
+ FILE * fp;
+{
+ fast long i;
+ fast int msd;
+ for (i = 0; (i < N); i += 1)
+ {
+ if (feof (fp))
+ error_external_return ();
+ msd = (getc (fp));
+ (a [i]) = ((REAL) ((msd << 8) | (getc (fp))));
+ }
+ return;
+}
+DEFINE_PRIMITIVE ("ARRAY-READ-2BINT-FILE", Prim_array_read_2bint_file, 2, 2, 0)
+{
+ FILE * fp;
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, STRING_P);
+ fp = (fopen ((ARG_REF (1)), "r"));
+ if (fp == ((FILE *) 0))
+ error_bad_range_arg (1);
+ {
+ fast long length = (arg_nonnegative_integer (2));
+ fast SCHEME_OBJECT result = (allocate_array (length));
+ C_Array_Read_2bint_File ((ARRAY_CONTENTS (result)), length, fp);
+ if ((fclose (fp)) != 0)
+ error_external_return ();
+ PRIMITIVE_RETURN (result);
+ }
+}
\f
-/* ARRAY-COPY! a very powerful primitive
- See array.scm for its many applications.
- Be Careful when source and destination are the same array.
- */
DEFINE_PRIMITIVE ("SUBARRAY-COPY!", Prim_subarray_copy, 5, 5, 0)
-{ long i, i1, i2;
- long m, at1, at2;
- REAL *a,*b;
-
+{
PRIMITIVE_HEADER (5);
- CHECK_ARG (1, ARRAY_P); /* source array a */
- CHECK_ARG (2, ARRAY_P); /* destination array b */
-
- a = Scheme_Array_To_C_Array(ARG_REF(1));
- b = Scheme_Array_To_C_Array(ARG_REF(2));
- at1 = arg_nonnegative_integer(3); /* at1 = starting index in source array */
- at2 = arg_nonnegative_integer(4); /* at2 = starting index in destination array */
- m = arg_nonnegative_integer(5); /* m = number of points to copy */
-
- if ((at1 + m) > (Array_Length(ARG_REF(1)))) error_bad_range_arg(3);
- if ((at2 + m) > (Array_Length(ARG_REF(2)))) error_bad_range_arg(4);
- /* These 2 checks cover all cases */
-
- for (i=0,i1=at1,i2=at2; i<m; i++,i1++,i2++)
- b[i2] = a[i1];
-
- PRIMITIVE_RETURN (NIL);
+ CHECK_ARG (1, ARRAY_P); /* source array */
+ CHECK_ARG (2, ARRAY_P); /* destination array */
+ {
+ REAL * source = (ARRAY_CONTENTS (ARG_REF (1)));
+ REAL * target = (ARRAY_CONTENTS (ARG_REF (2)));
+ long start_source = (arg_nonnegative_integer (3));
+ long start_target = (arg_nonnegative_integer (4));
+ long n_elements = (arg_nonnegative_integer (5));
+ if ((start_source + n_elements) > (ARRAY_LENGTH (ARG_REF (1))))
+ error_bad_range_arg (3);
+ if ((start_target + n_elements) > (ARRAY_LENGTH (ARG_REF (2))))
+ error_bad_range_arg (4);
+ {
+ fast REAL * scan_source = (source + start_source);
+ fast REAL * end_source = (scan_source + n_elements);
+ fast REAL * scan_target = (target + start_target);
+ while (scan_source < end_source)
+ (*scan_target++) = (*scan_source++);
+ }
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
DEFINE_PRIMITIVE ("ARRAY-REVERSE!", Prim_array_reverse, 1, 1, 0)
-{ long Length, i,j, Half_Length;
- REAL *Array, Temp;
- Primitive_1_Args();
- Arg_1_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
- Half_Length = Length/2;
- Array = Scheme_Array_To_C_Array(Arg1);
-
- for (i=0, j=Length-1; i<Half_Length; i++, j--) {
- Temp = Array[j];
- Array[j] = Array[i];
- Array[i] = Temp;
+{
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, ARRAY_P);
+ {
+ SCHEME_OBJECT array = (ARG_REF (1));
+ long length = (ARRAY_LENGTH (array));
+ long half_length = (length / 2);
+ fast REAL * array_ptr = (ARRAY_CONTENTS (array));
+ fast long i;
+ fast long j;
+ for (i = 0, j = (length - 1); (i < half_length); i += 1, j -= 1)
+ {
+ fast REAL Temp = (array_ptr [j]);
+ (array_ptr [j]) = (array_ptr [i]);
+ (array_ptr [i]) = Temp;
+ }
}
- return Arg1;
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
-DEFINE_PRIMITIVE ("ARRAY-TIME-REVERSE!",
- Prim_array_time_reverse, 1, 1, 0)
-{ long i, n;
- REAL *a;
- void C_Array_Time_Reverse();
+\f
+DEFINE_PRIMITIVE ("ARRAY-TIME-REVERSE!", Prim_array_time_reverse, 1, 1, 0)
+{
+ void C_Array_Time_Reverse ();
PRIMITIVE_HEADER (1);
CHECK_ARG (1, ARRAY_P);
- a = Scheme_Array_To_C_Array(ARG_REF(1));
- n = Array_Length(ARG_REF(1));
-
- C_Array_Time_Reverse(a,n);
-
- PRIMITIVE_RETURN (NIL);
+ C_Array_Time_Reverse
+ ((ARRAY_CONTENTS (ARG_REF (1))), (ARRAY_LENGTH (ARG_REF (1))));
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
/* time-reverse
x[0] remains fixed. (time=0)
- x[i] swapped with x[n-i]. (mirror image around x[0])
- */
-void C_Array_Time_Reverse(x,n)
+ x[i] swapped with x[n-i]. (mirror image around x[0]) */
+
+void
+C_Array_Time_Reverse (x,n)
REAL *x;
long n;
{ long i, ni, n2;
REAL xt;
if ((n % 2) == 0) /* even length */
- { n2 = (n/2);
+ { n2 = (n/2);
for (i=1; i<n2; i++) /* i=1,2,..,n/2-1 */
{ ni = n-i;
xt = x[i];
x[ni] = xt; }}
}
-/* The following is smart
- and avoids computation when offset or scale are degenerate 0,1
- */
-DEFINE_PRIMITIVE ("SUBARRAY-OFFSET-SCALE!",
- Prim_subarray_offset_scale, 5, 5, 0)
-{ long i, at, m,mplus;
+/* The following is smart
+ and avoids computation when offset or scale are degenerate 0,1 */
+
+DEFINE_PRIMITIVE ("SUBARRAY-OFFSET-SCALE!", Prim_subarray_offset_scale, 5, 5, 0)
+{
+ long i, at, m,mplus;
REAL *a, offset,scale;
- int errcode;
-
PRIMITIVE_HEADER (5);
CHECK_ARG (1, ARRAY_P);
CHECK_ARG (2, FIXNUM_P);
CHECK_ARG (3, FIXNUM_P);
- a = Scheme_Array_To_C_Array(ARG_REF(1));
+ a = ARRAY_CONTENTS(ARG_REF(1));
at = arg_nonnegative_integer(2); /* at = starting index */
m = arg_nonnegative_integer(3); /* m = number of points to change */
-
mplus = at + m;
- if (mplus > (Array_Length(ARG_REF(1)))) error_bad_range_arg(3);
-
- errcode = Scheme_Number_To_REAL(ARG_REF(4), &offset);
- if (errcode==1) error_bad_range_arg(4); if (errcode==2) error_wrong_type_arg(4);
- errcode = Scheme_Number_To_REAL(ARG_REF(5), &scale);
- if (errcode==1) error_bad_range_arg(5); if (errcode==2) error_wrong_type_arg(5);
-
+ if (mplus > (ARRAY_LENGTH(ARG_REF(1)))) error_bad_range_arg(3);
+ offset = (arg_real (4));
+ scale = (arg_real (5));
if ((offset == 0.0) && (scale == 1.0))
; /* be smart */
else if (scale == 0.0)
for (i=at; i<mplus; i++) a[i] = offset + a[i];
else
for (i=at; i<mplus; i++) a[i] = offset + scale * a[i];
-
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
-
-DEFINE_PRIMITIVE ("COMPLEX-SUBARRAY-COMPLEX-SCALE!",
- Prim_complex_subarray_complex_scale, 6,6, 0)
+\f
+DEFINE_PRIMITIVE ("COMPLEX-SUBARRAY-COMPLEX-SCALE!", Prim_complex_subarray_complex_scale, 6,6, 0)
{ long i, at,m,mplus;
REAL *a,*b; /* (a,b) = (real,imag) arrays */
double temp, minus_y, x, y; /* (x,y) = (real,imag) scale */
- int errcode;
-
PRIMITIVE_HEADER (6);
CHECK_ARG (1, ARRAY_P);
CHECK_ARG (2, ARRAY_P);
- CHECK_ARG (3, FIXNUM_P);
- CHECK_ARG (4, FIXNUM_P);
-
- at = arg_nonnegative_integer(3); /* at = starting index */
- m = arg_nonnegative_integer(4); /* m = number of points to change */
+ at = (arg_nonnegative_integer (3)); /* starting index */
+ m = (arg_nonnegative_integer (4)); /* number of points to change */
mplus = at + m;
- if (mplus > (Array_Length(ARG_REF(1)))) error_bad_range_arg(4);
-
- errcode = Scheme_Number_To_Double(ARG_REF(5), &x);
- if (errcode==1) error_bad_range_arg(5); if (errcode==2) error_wrong_type_arg(5);
- errcode = Scheme_Number_To_Double(ARG_REF(6), &y);
- if (errcode==1) error_bad_range_arg(6); if (errcode==2) error_wrong_type_arg(6);
-
- a = Scheme_Array_To_C_Array(ARG_REF(1));
- b = Scheme_Array_To_C_Array(ARG_REF(2));
- if ((Array_Length(ARG_REF(1))) != (Array_Length(ARG_REF(2)))) error_bad_range_arg(2);
-
+ if (mplus > (ARRAY_LENGTH(ARG_REF(1)))) error_bad_range_arg(4);
+ x = (arg_real_number (5));
+ y = (arg_real_number (6));
+ a = ARRAY_CONTENTS(ARG_REF(1));
+ b = ARRAY_CONTENTS(ARG_REF(2));
+ if ((ARRAY_LENGTH(ARG_REF(1))) != (ARRAY_LENGTH(ARG_REF(2))))
+ error_bad_range_arg(2);
if (x==0.0) /* imaginary only */
if (y==0.0)
for (i=at; i<mplus; i++)
{ temp = ((double) a[i])*x - ((double) b[i])*y;
b[i] = (REAL) (((double) b[i])*x + ((double) a[i])*y);
a[i] = (REAL) temp; }
-
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
-
+\f
/* Accumulate
- using combinators *
- corresponding type codes 1
- */
-DEFINE_PRIMITIVE ("COMPLEX-SUBARRAY-ACCUMULATE!",
- Prim_complex_subarray_accumulate, 6,6, 0)
+ using combinators *
+ corresponding type codes 1 */
+
+DEFINE_PRIMITIVE ("COMPLEX-SUBARRAY-ACCUMULATE!", Prim_complex_subarray_accumulate, 6,6, 0)
{ long at,m,mplus, tc, i;
REAL *a,*b; /* (a,b) = (real,imag) input arrays */
- REAL *c; /* result = output array of length 2, holds a complex number */
+ REAL *c; /* result = output array of length 2, holds a complex number */
double x, y, temp;
-
PRIMITIVE_HEADER (6);
CHECK_ARG (1, ARRAY_P); /* a = input array (real) */
CHECK_ARG (2, ARRAY_P); /* b = input array (imag) */
- a = Scheme_Array_To_C_Array(ARG_REF(1));
- b = Scheme_Array_To_C_Array(ARG_REF(2));
- if ((Array_Length(ARG_REF(1))) != (Array_Length(ARG_REF(2)))) error_bad_range_arg(2);
+ a = ARRAY_CONTENTS(ARG_REF(1));
+ b = ARRAY_CONTENTS(ARG_REF(2));
+ if ((ARRAY_LENGTH(ARG_REF(1))) != (ARRAY_LENGTH(ARG_REF(2))))
+ error_bad_range_arg(2);
tc = arg_nonnegative_integer(3); /* tc = type code 0 or 1 */
at = arg_nonnegative_integer(4); /* at = starting index */
m = arg_nonnegative_integer(5); /* m = number of points to process */
CHECK_ARG (6, ARRAY_P); /* c = output array of length 2 */
- c = Scheme_Array_To_C_Array(ARG_REF(6));
- if ((Array_Length(ARG_REF(6))) != 2) error_bad_range_arg(6);
-
+ c = ARRAY_CONTENTS(ARG_REF(6));
+ if ((ARRAY_LENGTH(ARG_REF(6))) != 2) error_bad_range_arg(6);
mplus = at + m;
- if (mplus > (Array_Length(ARG_REF(1)))) error_bad_range_arg(5);
-
+ if (mplus > (ARRAY_LENGTH(ARG_REF(1)))) error_bad_range_arg(5);
if (tc==1)
{ x = 1.0; /* real part of accumulator */
y = 0.0; /* imag part of accumulator */
- for (i=at;i<mplus;i++)
+ for (i=at;i<mplus;i++)
{ temp = ((double) a[i])*x - ((double) b[i])*y;
y = ((double) b[i])*x + ((double) a[i])*y;
x = temp; }
}
else
error_bad_range_arg(3);
-
c[0] = ((REAL) x); /* mechanism for returning complex number */
c[1] = ((REAL) y); /* do not use lists, avoid heap pointer */
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
-
-DEFINE_PRIMITIVE ("CS-ARRAY-TO-COMPLEX-ARRAY!",
- Prim_cs_array_to_complex_array, 3, 3, 0)
+DEFINE_PRIMITIVE ("CS-ARRAY-TO-COMPLEX-ARRAY!", Prim_cs_array_to_complex_array, 3, 3, 0)
{ long n,n2,n2_1, i;
REAL *a, *b,*c;
-
PRIMITIVE_HEADER (3);
CHECK_ARG (1, ARRAY_P);
CHECK_ARG (2, ARRAY_P);
CHECK_ARG (3, ARRAY_P);
-
- a = Scheme_Array_To_C_Array(ARG_REF(1));
- n = Array_Length(ARG_REF(1));
- b = Scheme_Array_To_C_Array(ARG_REF(2));
- c = Scheme_Array_To_C_Array(ARG_REF(3));
- if (n!=(Array_Length(ARG_REF(2)))) error_bad_range_arg(2);
- if (n!=(Array_Length(ARG_REF(3)))) error_bad_range_arg(3);
-
- b[0] = a[0]; c[0] = 0.0;
-
- n2 = n/2; /* integer division truncates down */
+ a = ARRAY_CONTENTS(ARG_REF(1));
+ n = ARRAY_LENGTH(ARG_REF(1));
+ b = ARRAY_CONTENTS(ARG_REF(2));
+ c = ARRAY_CONTENTS(ARG_REF(3));
+ if (n!=(ARRAY_LENGTH(ARG_REF(2)))) error_bad_range_arg(2);
+ if (n!=(ARRAY_LENGTH(ARG_REF(3)))) error_bad_range_arg(3);
+ b[0] = a[0];
+ c[0] = 0.0;
+ n2 = n/2; /* integer division truncates down */
n2_1 = n2+1;
-
if (2*n2 == n) /* even length, n2 is only real */
{ b[n2] = a[n2]; c[n2] = 0.0; }
- else /* odd length, make the loop include the n2 index */
+ else /* odd length, make the loop include the n2 index */
{ n2 = n2+1;
n2_1 = n2; }
-
for (i=1; i<n2; i++) { b[i] = a[i];
c[i] = a[n-i]; }
for (i=n2_1; i<n; i++) { b[i] = a[n-i];
c[i] = (-a[i]); }
-
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
-DEFINE_PRIMITIVE ("CS-ARRAY-MULTIPLY-INTO-SECOND-ONE!",
- Prim_cs_array_multiply_into_second_one, 2, 2, 0)
+\f
+DEFINE_PRIMITIVE ("CS-ARRAY-MULTIPLY-INTO-SECOND-ONE!", Prim_cs_array_multiply_into_second_one, 2, 2, 0)
{ long n,n2;
REAL *a, *b;
void cs_array_multiply_into_second_one();
PRIMITIVE_HEADER (2);
CHECK_ARG (1, ARRAY_P);
CHECK_ARG (2, ARRAY_P);
-
- a = Scheme_Array_To_C_Array(ARG_REF(1));
- n = Array_Length(ARG_REF(1));
- b = Scheme_Array_To_C_Array(ARG_REF(2));
- if (n!=(Array_Length(ARG_REF(2)))) error_bad_range_arg(2);
+ a = ARRAY_CONTENTS(ARG_REF(1));
+ n = ARRAY_LENGTH(ARG_REF(1));
+ b = ARRAY_CONTENTS(ARG_REF(2));
+ if (n!=(ARRAY_LENGTH(ARG_REF(2)))) error_bad_range_arg(2);
n2 = n/2; /* integer division truncates down */
cs_array_multiply_into_second_one(a,b, n,n2);
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-void cs_array_multiply_into_second_one(a,b, n,n2)
- REAL *a, *b; long n,n2;
-{ REAL temp;
+void
+cs_array_multiply_into_second_one (a,b, n,n2)
+ REAL *a, *b;
+ long n,n2;
+{
+ REAL temp;
long i,ni;
b[0] = a[0] * b[0];
-
if (2*n2 == n) /* even length, n2 is only real */
b[n2] = a[n2] * b[n2];
- else
- n2 = n2+1; /* odd length, make the loop include the n2 index */
-
+ else
+ n2 = n2+1; /* odd length, make the loop include the n2 index */
for (i=1; i<n2; i++)
- { ni = n-i;
- temp = a[i]*b[i] - a[ni]*b[ni]; /* real part */
- b[ni] = a[i]*b[ni] + a[ni]*b[i]; /* imag part */
- b[i] = temp; }
+ {
+ ni = n-i;
+ temp = a[i]*b[i] - a[ni]*b[ni]; /* real part */
+ b[ni] = a[i]*b[ni] + a[ni]*b[i]; /* imag part */
+ b[i] = temp;
+ }
}
-DEFINE_PRIMITIVE ("CS-ARRAY-DIVIDE-INTO-XXX!",
- Prim_cs_array_divide_into_xxx, 4, 4, 0)
-{ long n,n2, one_or_two;
+DEFINE_PRIMITIVE ("CS-ARRAY-DIVIDE-INTO-XXX!", Prim_cs_array_divide_into_xxx, 4, 4, 0)
+{
+ long n,n2, one_or_two;
REAL *a, *b, inf;
- int errcode;
void cs_array_divide_into_z();
-
PRIMITIVE_HEADER (4);
CHECK_ARG (1, ARRAY_P);
CHECK_ARG (2, ARRAY_P);
- errcode = Scheme_Number_To_REAL(ARG_REF(3), &inf);
- if (errcode==1) error_bad_range_arg(3); if (errcode==2) error_wrong_type_arg(3);
- CHECK_ARG (4, FIXNUM_P);
- one_or_two = arg_nonnegative_integer(4); /* where to store result of division */
-
- a = Scheme_Array_To_C_Array(ARG_REF(1));
- b = Scheme_Array_To_C_Array(ARG_REF(2));
- n = Array_Length(ARG_REF(1));
- if (n!=(Array_Length(ARG_REF(2)))) error_bad_range_arg(2);
+ inf = (arg_real (3));
+ /* where to store result of division */
+ one_or_two = (arg_nonnegative_integer (4));
+ a = ARRAY_CONTENTS(ARG_REF(1));
+ b = ARRAY_CONTENTS(ARG_REF(2));
+ n = ARRAY_LENGTH(ARG_REF(1));
+ if (n!=(ARRAY_LENGTH(ARG_REF(2)))) error_bad_range_arg(2);
n2 = n/2; /* integer division truncates down */
-
if (one_or_two == 1)
cs_array_divide_into_z(a,b, a, n,n2, inf);
else if (one_or_two == 2)
cs_array_divide_into_z(a,b, b, n,n2, inf);
else
error_bad_range_arg(4);
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-void cs_array_divide_into_second_one(a,b, n,n2,inf) /* used in image.c */
- REAL *a,*b, inf; long n,n2;
-{ void cs_array_divide_into_z();
- cs_array_divide_into_z(a,b, b, n,n2,inf);
+void
+cs_array_divide_into_second_one (a,b, n,n2,inf) /* used in image.c */
+ REAL *a,*b, inf;
+ long n,n2;
+{
+ void cs_array_divide_into_z ();
+ cs_array_divide_into_z (a,b, b, n,n2,inf);
}
-
-void cs_array_divide_into_z(a,b, z, n,n2, inf) /* z can be either a or b */
- REAL *a,*b,*z, inf; long n,n2;
+\f
+void
+cs_array_divide_into_z (a,b, z, n,n2, inf) /* z can be either a or b */
+ REAL *a,*b,*z, inf;
+ long n,n2;
{ long i,ni;
REAL temp, radius;
-
+
if (b[0] == 0.0)
if (a[0] == 0.0) z[0] = 1.0;
else z[0] = a[0] * inf;
else z[0] = a[0] / b[0];
-
+
if (2*n2 == n) /* even length, n2 is only real */
if (b[n2] == 0.0)
if (a[n2] == 0.0) z[n2] = 1.0;
else z[n2] = a[n2] * inf;
else z[n2] = a[n2] / b[n2];
- else
- n2 = n2+1; /* odd length, make the loop include the n2 index */
-
+ else
+ n2 = n2+1; /* odd length, make the loop include the n2 index */
+
for (i=1; i<n2; i++)
{ ni = n-i;
- radius = b[i]*b[i] + b[ni]*b[ni]; /* b^2 denominator = real^2 + imag^2 */
-
+ radius = b[i]*b[i] + b[ni]*b[ni]; /* b^2 denominator = real^2 + imag^2 */
+
if (radius == 0.0) {
if (a[i] == 0.0) z[i] = 1.0;
else z[i] = a[i] * inf;
z[i] = temp / radius; /* real part */
}}
}
-
-
-
-
+\f
/* ARRAY-UNARY-FUNCTION!
- apply unary-function elementwise on array
-
- Available functions :
- */
+ apply unary-function elementwise on array
+ Available functions : */
-void REALabs(a,b) REAL *a,*b;
-{ (*b) = ( (REAL) fabs( (double) (*a)) );
+void
+REALabs (a,b)
+ REAL *a,*b;
+{
+ (*b) = ( (REAL) fabs( (double) (*a)) );
}
-void REALexp(a,b) REAL *a,*b;
-{ register double y;
+
+void
+REALexp (a,b)
+ REAL *a,*b;
+{
+ fast double y;
if ((y = exp((double) (*a))) == HUGE)
- Primitive_Error(ERR_ARG_1_BAD_RANGE); /* OVERFLOW */
+ error_bad_range_arg (1); /* OVERFLOW */
(*b) = ((REAL) y);
}
-void REALlog(a,b) REAL *a,*b;
-{
+
+void
+REALlog (a,b)
+ REAL *a,*b;
+{
if ((*a) < 0.0)
error_bad_range_arg(1); /* log(negative) */
(*b) = ( (REAL) log( (double) (*a)) );
}
-void REALtruncate(a,b) REAL *a,*b; /* towards zero */
-{ double integral_part, modf();
+void
+REALtruncate (a,b)
+ REAL *a,*b; /* towards zero */
+{
+ double integral_part, modf();
modf( ((double) (*a)), &integral_part);
(*b) = ( (REAL) integral_part);
}
-void REALround(a,b) REAL *a,*b; /* towards nearest integer */
-{ double integral_part, modf();
- if ((*a) >= 0.0) /* It may be faster to look at the sign
+
+void
+REALround (a,b)
+ REAL *a,*b; /* towards nearest integer */
+{
+ double integral_part, modf();
+ if ((*a) >= 0.0) /* It may be faster to look at the sign
of mantissa, and dispatch */
- modf( ((double) ((*a)+0.5)), &integral_part);
+ modf( ((double) ((*a)+0.5)), &integral_part);
else
modf( ((double) ((*a)-0.5)), &integral_part);
(*b) = ( (REAL) integral_part);
}
-void REALsquare(a,b) REAL *a,*b;
-{ (*b) = ( (REAL) ((*a) * (*a)) );
+void
+REALsquare (a,b)
+ REAL *a,*b;
+{
+ (*b) = ( (REAL) ((*a) * (*a)) );
}
-void REALsqrt(a,b) REAL *a,*b;
+
+void
+REALsqrt (a,b)
+ REAL *a,*b;
{
if ((*a) < 0.0)
error_bad_range_arg(1); /* sqrt(negative) */
(*b) = ( (REAL) sqrt( (double) (*a)) );
}
-
-void REALsin(a,b) REAL *a,*b;
-{ (*b) = ( (REAL) sin( (double) (*a)) );
+\f
+void
+REALsin (a,b)
+ REAL *a,*b;
+{
+ (*b) = ( (REAL) sin( (double) (*a)) );
}
-void REALcos(a,b) REAL *a,*b;
-{ (*b) = ( (REAL) cos( (double) (*a)) );
+
+void
+REALcos (a,b)
+ REAL *a,*b;
+{
+ (*b) = ( (REAL) cos( (double) (*a)) );
}
-void REALtan(a,b) REAL *a,*b;
-{ (*b) = ( (REAL) tan( (double) (*a)) );
+
+void
+REALtan (a,b)
+ REAL *a,*b;
+{
+ (*b) = ( (REAL) tan( (double) (*a)) );
}
-void REALasin(a,b) REAL *a,*b;
-{ (*b) = ( (REAL) asin( (double) (*a)) );
+
+void
+REALasin (a,b)
+ REAL *a,*b;
+{
+ (*b) = ( (REAL) asin( (double) (*a)) );
}
-void REALacos(a,b) REAL *a,*b;
-{ (*b) = ( (REAL) acos( (double) (*a)) );
+
+void
+REALacos (a,b)
+ REAL *a,*b;
+{
+ (*b) = ( (REAL) acos( (double) (*a)) );
}
-void REALatan(a,b) REAL *a,*b;
-{ (*b) = ( (REAL) atan( (double) (*a)) );
+
+void
+REALatan (a,b)
+ REAL *a,*b;
+{
+ (*b) = ( (REAL) atan( (double) (*a)) );
}
-void REALgamma(a,b) REAL *a,*b;
-{ register double y;
+void
+REALgamma (a,b)
+ REAL *a,*b;
+{
+ fast double y;
if ((y = gamma(((double) (*a)))) > LN_MAXDOUBLE)
error_bad_range_arg(1); /* gamma( non-positive integer ) */
(*b) = ((REAL) (signgam * exp(y))); /* see HPUX Section 3 */
}
-void REALerf(a,b) REAL *a,*b;
-{ (*b) = ( (REAL) erf((double) (*a)) );
+
+void
+REALerf (a,b)
+ REAL *a,*b;
+{
+ (*b) = ( (REAL) erf((double) (*a)) );
}
-void REALerfc(a,b) REAL *a,*b;
-{ (*b) = ( (REAL) erfc((double) (*a)) );
+
+void
+REALerfc (a,b)
+ REAL *a,*b;
+{
+ (*b) = ( (REAL) erfc((double) (*a)) );
}
-void REALbessel1(order,a,b) long order; REAL *a,*b; /* Bessel of first kind */
-{ if (order == 0)
+\f
+void
+REALbessel1 (order,a,b) /* Bessel of first kind */
+ long order;
+ REAL *a,*b;
+{
+ if (order == 0)
(*b) = ( (REAL) j0((double) (*a)) );
if (order == 1)
(*b) = ( (REAL) j1((double) (*a)) );
else
(*b) = ( (REAL) jn(((int) order), ((double) (*a))) );
}
-void REALbessel2(order,a,b) long order; REAL *a,*b; /* Bessel of second kind */
-{
+
+void
+REALbessel2 (order,a,b) /* Bessel of second kind */
+ long order;
+ REAL *a,*b;
+{
if ((*a) <= 0.0)
error_bad_range_arg(1); /* Blows Up */
if (order == 0)
/* Table to store the available unary-functions.
Also some binary functions at the end -- not available right now.
- The (1 and 2)s denote the numofargs (1 for unary 2 for binary)
- */
+ The (1 and 2)s denote the numofargs (1 for unary 2 for binary) */
-struct array_func_table {
+struct array_func_table
+{
long numofargs;
void (*func)();
-} Array_Function_Table[] =
-{
+}
+Array_Function_Table [] =
+{
1, REALabs, /*0*/
1, REALexp, /*1*/
1, REALlog, /*2*/
};
#define MAX_ARRAY_FUNCTC 17
-
+\f
/* array-unary-function! could be called array-operation-1!
- following the naming convention for other similar procedures
- but it is specialized to mappings only, so we have special name.
- */
+ following the naming convention for other similar procedures
+ but it is specialized to mappings only, so we have special name. */
+
DEFINE_PRIMITIVE ("ARRAY-UNARY-FUNCTION!", Prim_array_unary_function, 2,2, 0)
-{ long n, i;
+{
+ long n, i;
REAL *a,*b;
long tc;
void (*f)();
-
PRIMITIVE_HEADER (2);
CHECK_ARG (1, ARRAY_P); /* a = input (and output) array */
CHECK_ARG (2, FIXNUM_P); /* tc = type code */
-
tc = arg_nonnegative_integer(2);
if (tc > MAX_ARRAY_FUNCTC) error_bad_range_arg(2);
f = ((Array_Function_Table[tc]).func);
if (1 != (Array_Function_Table[tc]).numofargs) error_wrong_type_arg(2);
/* check it is a unary function */
-
- a = Scheme_Array_To_C_Array(ARG_REF(1));
+ a = ARRAY_CONTENTS(ARG_REF(1));
b = a;
- n = Array_Length(ARG_REF(1));
-
+ n = ARRAY_LENGTH(ARG_REF(1));
for (i=0; i<n; i++)
(*f) ( &(a[i]), &(b[i]) ); /* a into b */
-
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
/* Accumulate
- using combinators + or *
- corresponding type codes 0 1
- */
+ using combinators + or *
+ corresponding type codes 0 1 */
+
DEFINE_PRIMITIVE ("SUBARRAY-ACCUMULATE", Prim_subarray_accumulate, 4,4, 0)
-{ long at,m,mplus, tc, i;
+{
+ long at,m,mplus, tc, i;
REAL *a;
double result;
-
PRIMITIVE_HEADER (4);
CHECK_ARG (1, ARRAY_P); /* a = input array */
- a = Scheme_Array_To_C_Array(ARG_REF(1));
+ a = ARRAY_CONTENTS(ARG_REF(1));
tc = arg_nonnegative_integer(2); /* tc = type code 0 or 1 */
at = arg_nonnegative_integer(3); /* at = starting index */
m = arg_nonnegative_integer(4); /* m = number of points to process */
-
mplus = at + m;
- if (mplus > (Array_Length(ARG_REF(1)))) error_bad_range_arg(4);
-
- if (tc==0)
- { result = 0.0;
- for (i=at;i<mplus;i++) result = result + ((double) a[i]); }
- else if (tc==1)
- { result = 1.0;
- for (i=at;i<mplus;i++) result = result * ((double) a[i]); }
+ if (mplus > (ARRAY_LENGTH(ARG_REF(1)))) error_bad_range_arg(4);
+ if (tc == 0)
+ {
+ result = 0.0;
+ for (i=at;i<mplus;i++)
+ result = result + ((double) a[i]);
+ }
+ else if (tc == 1)
+ {
+ result = 1.0;
+ for (i=at;i<mplus;i++)
+ result = result * ((double) a[i]);
+ }
else
- error_bad_range_arg(2);
-
- Reduced_Flonum_Result(result);
+ error_bad_range_arg (2);
+ PRIMITIVE_RETURN (double_to_flonum (result));
}
-
-
+\f
/* The following searches for value within tolerance
starting from index=from in array.
- Returns first index where match occurs. -- (useful for finding zeros)
- */
+ Returns first index where match occurs (useful for finding zeros). */
+
DEFINE_PRIMITIVE ("ARRAY-SEARCH-VALUE-TOLERANCE-FROM", Prim_array_search_value_tolerance_from, 4, 4, 0)
-{ long Length, from, i;
- REAL *a, value; /* value to search for */
- double tolerance; /* tolerance allowed */
- int errcode;
- Primitive_4_Args();
- Arg_1_Type(TC_ARRAY);
- a = Scheme_Array_To_C_Array(Arg1); Length = Array_Length(Arg1);
-
- errcode = Scheme_Number_To_REAL(Arg2, &value);
- if (errcode == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (errcode == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- errcode = Scheme_Number_To_Double(Arg3, &tolerance);
- if (errcode == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (errcode == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
- Arg_4_Type(TC_FIXNUM);
- Range_Check(from, Arg4, 0, Length-1, ERR_ARG_4_BAD_RANGE);
-
- i = from;
- while ((tolerance < (fabs(((double) (a[i]-value)))))
- && (i<Length) )
- { i++; }
- if (tolerance >= (fabs(((double) (a[i]-value)))))
- return Make_Pointer(TC_FIXNUM, i);
- else
- return SHARP_F;
+{
+ SCHEME_OBJECT array;
+ fast long length;
+ fast REAL * a;
+ fast REAL value; /* value to search for */
+ fast double tolerance; /* tolerance allowed */
+ PRIMITIVE_HEADER (4);
+ CHECK_ARG (1, ARRAY_P);
+ array = (ARG_REF (1));
+ length = (ARRAY_LENGTH (array));
+ a = (ARRAY_CONTENTS (array));
+ value = (arg_real (2));
+ tolerance = (arg_real (3));
+ {
+ fast long i;
+ for (i = (arg_index_integer (4, length)); (i < length); i += 1)
+ if (tolerance >= (fabs ((double) ((a [i]) - value))))
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (i));
+ }
+ PRIMITIVE_RETURN (SHARP_F);
}
-DEFINE_PRIMITIVE ("SUBARRAY-MIN-MAX-INDEX", Prim_subarray_min_max_index, 3,3, 0)
-{ long at,m,mplus;
- long nmin, nmax;
- Pointer Result, *Orig_Free;
- REAL *a;
-
+DEFINE_PRIMITIVE ("SUBARRAY-MIN-MAX-INDEX", Prim_subarray_min_max_index, 3, 3, 0)
+{
PRIMITIVE_HEADER (3);
CHECK_ARG (1, ARRAY_P);
- a = Scheme_Array_To_C_Array(ARG_REF(1));
- at = arg_nonnegative_integer(2); /* at = starting index */
- m = arg_nonnegative_integer(3); /* m = number of points to process */
-
- mplus = at + m;
- if (mplus > (Array_Length(ARG_REF(1)))) error_bad_range_arg(3);
-
- C_Array_Find_Min_Max ( &(a[at]), m, &nmin, &nmax);
- nmin = nmin + at; /* offset appropriately */
- nmax = nmax + at;
-
- Primitive_GC_If_Needed(4);
- Result = Make_Pointer(TC_LIST, Free);
- Orig_Free = Free;
- Free+=4;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nmin);
- *Orig_Free++ = Make_Pointer(TC_LIST, Orig_Free+1);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nmax);
- *Orig_Free=EMPTY_LIST;
-
- PRIMITIVE_RETURN (Result);
-}
-
-void C_Array_Find_Min_Max(x, n, nmin, nmax) REAL *x; long n, *nmax, *nmin;
-{ REAL *xold = x;
- register REAL xmin, xmax;
- register long nnmin, nnmax;
- register long count;
-
- nnmin = nnmax = 0;
- xmin = xmax = *x++;
- n--;
- count = 1;
- if(n>0)
{
- do {
- if(*x < xmin) {
- nnmin = count++ ;
- xmin = *x++ ;
- } else if(*x > xmax) {
- nnmax = count++ ;
- xmax = *x++ ;
- } else {
- count++ ;
- x++ ;
- }
- } while( --n > 0 ) ;
+ REAL * a = (ARRAY_CONTENTS (ARG_REF (1)));
+ long at = (arg_nonnegative_integer (2)); /* starting index */
+ long m = (arg_nonnegative_integer (3)); /* number of points to process */
+ long mplus = (at + m);
+ long nmin;
+ long nmax;
+ if (mplus > (ARRAY_LENGTH (ARG_REF (1))))
+ error_bad_range_arg (3);
+ C_Array_Find_Min_Max ((& (a [at])), m, (&nmin), (&nmax));
+ PRIMITIVE_RETURN
+ (cons ((LONG_TO_FIXNUM (nmin + at)),
+ (cons ((LONG_TO_FIXNUM (nmax + at)),
+ EMPTY_LIST))));
}
- *nmin = nnmin ;
- *nmax = nnmax ;
}
-
+void
+C_Array_Find_Min_Max (x, n, nmin, nmax)
+ fast REAL * x;
+ fast long n;
+ long * nmin;
+ long * nmax;
+{
+ fast REAL xmin = (*x++);
+ fast REAL xmax = xmin;
+ fast long nnmin = 0;
+ fast long nnmax = 0;
+ fast long count = 1;
+ while ((n--) > 0)
+ {
+ if ((*x) < xmin)
+ {
+ nnmin = count;
+ xmin = (*x);
+ }
+ else if ((*x) > xmax)
+ {
+ nnmax = count;
+ xmax = (*x);
+ }
+ count += 1;
+ x += 1;
+ }
+ (*nmin) = nnmin;
+ (*nmax) = nnmax;
+ return;
+}
+\f
/* array-average
can be done with (array-reduce +) and division by array-length.
- But there is also this C primitive. Keep it around, may be useful someday.
- */
-
-DEFINE_PRIMITIVE ("ARRAY-AVERAGE", Prim_array_find_average, 1, 1, 0)
-{ long Length; REAL average;
- void C_Array_Find_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);
-}
+ But there is also this C primitive.
+ Keep it around, may be useful someday. */
-/* Computes the average in pieces, so as to reduce
+/* Computes the average in pieces, so as to reduce
roundoff smearing in cumulative sum.
- example= first huge positive numbers, then small nums, then huge negative numbers.
- */
-
-void C_Array_Find_Average(Array, Length, pAverage)
- long Length; REAL *Array, *pAverage;
-{ long i;
+ example= first huge positive numbers, then small nums,
+ then huge negative numbers. */
+
+static void
+C_Array_Find_Average (Array, Length, pAverage)
+ long Length;
+ REAL * Array;
+ REAL * pAverage;
+{
+ long i;
long array_index;
REAL average_n, sum;
-
+
average_n = 0.0;
array_index = 0;
- while (array_index<Length) {
- sum = 0.0;
- for (i=0;((array_index<Length) && (i<2000));i++) {
- sum += Array[array_index];
- array_index++;
+ while (array_index < Length)
+ {
+ sum = 0.0;
+ for (i=0;((array_index<Length) && (i<2000));i++) {
+ sum += Array[array_index];
+ array_index++;
+ }
+ average_n += (sum / ((REAL) Length));
}
- average_n += (sum / ((REAL) Length));
- }
- *pAverage = average_n;
+ (*pAverage) = average_n;
+ return;
+}
+
+DEFINE_PRIMITIVE ("ARRAY-AVERAGE", Prim_array_find_average, 1, 1, 0)
+{
+ SCHEME_OBJECT array;
+ REAL average;
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, ARRAY_P);
+ array = (ARG_REF (1));
+ C_Array_Find_Average
+ ((ARRAY_CONTENTS (array)),
+ (ARRAY_LENGTH (array)),
+ (&average));
+ PRIMITIVE_RETURN (double_to_flonum ((double) average));
+}
+\f
+void
+C_Array_Make_Histogram (Array, Length, Histogram, npoints)
+ REAL Array[], Histogram[];
+ long Length, npoints;
+{
+ REAL Max, Min, Offset, Scale;
+ long i, nmin, nmax, index;
+ C_Array_Find_Min_Max (Array, Length, (&nmin), (&nmax));
+ Min = (Array [nmin]);
+ Max = (Array [nmax]);
+ Find_Offset_Scale_For_Linear_Map
+ (Min, Max, 0.0, ((REAL) npoints), (&Offset), (&Scale));
+ for (i = 0; (i < npoints); i += 1)
+ (Histogram [i]) = 0.0;
+ for (i = 0; (i < Length); i += 1)
+ {
+ /* Everything from 0 to 1 maps to bin 0, and so on */
+ index = ((long) (floor ((double) ((Scale * (Array [i])) + Offset))));
+ /* max that won't floor to legal array index */
+ if (index == npoints)
+ index = (index - 1);
+ (Histogram [index]) += 1.0;
+ }
+ return;
}
DEFINE_PRIMITIVE ("ARRAY-MAKE-HISTOGRAM", Prim_array_make_histogram, 2, 2, 0)
-{ long Length, npoints, allocated_cells;
- REAL *Array, *Histogram;
- Pointer Result;
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Length = Array_Length(Arg1);
- Range_Check(npoints, Arg2, 1, (2*Length), ERR_ARG_2_BAD_RANGE);
-
- Allocate_Array(Result, npoints, allocated_cells);
- Array = Scheme_Array_To_C_Array(Arg1);
- Histogram = Scheme_Array_To_C_Array(Result);
- C_Array_Make_Histogram(Array, Length, Histogram, npoints);
- return Result;
-}
-void C_Array_Make_Histogram(Array, Length, Histogram, npoints)
- REAL Array[], Histogram[]; long Length, npoints;
-{ REAL Max,Min, Offset, Scale;
- long i, nmin,nmax, index;
- C_Array_Find_Min_Max(Array, Length, &nmin,&nmax);
- Min=Array[nmin]; Max=Array[nmax];
- Find_Offset_Scale_For_Linear_Map(Min,Max, 0.0, ((REAL) npoints), &Offset, &Scale);
- for (i=0;i<npoints;i++) Histogram[i] = 0.0;
- for (i=0;i<Length;i++) {
- /* Everything from 0 to 1 maps to bin 0, and so on */
- index = (long) (floor((double) ((Scale*Array[i]) + Offset)));
- if (index==npoints) index = index-1; /* max that won't floor to legal array index */
- Histogram[index] += 1.0; }
+{
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, ARRAY_P);
+ {
+ fast SCHEME_OBJECT array = (ARG_REF (1));
+ long length = (ARRAY_LENGTH (array));
+ long npoints = (arg_integer_in_range (2, 1, ((2 * length) + 1)));
+ SCHEME_OBJECT result = (allocate_array (npoints));
+ C_Array_Make_Histogram
+ ((ARRAY_CONTENTS (array)),
+ length,
+ (ARRAY_CONTENTS (result)),
+ npoints);
+ PRIMITIVE_RETURN (result);
+ }
}
+/* The following geometrical map is slightly tricky. */
+void
+Find_Offset_Scale_For_Linear_Map (Min, Max, New_Min, New_Max, Offset, Scale)
+ REAL Min, Max, New_Min, New_Max, *Offset, *Scale;
+{
+ if (Min != Max)
+ {
+ (*Scale) = ((New_Max - New_Min) / (Max - Min));
+ (*Offset) = (New_Min - ((*Scale) * Min));
+ }
+ else
+ {
+ (*Scale) =
+ ((Max == 0.0)
+ ? 0.0
+ : (0.25 * (mabs ((New_Max - New_Min) / Max))));
+ (*Offset) = ((New_Max + New_Min) / 2.0);
+ }
+ return;
+}
+\f
DEFINE_PRIMITIVE ("ARRAY-CLIP-MIN-MAX!", Prim_array_clip_min_max, 3, 3, 0)
-{ long Length, i;
- REAL *To_Here, *From_Here, xmin, xmax;
- int errcode;
-
- Primitive_3_Args();
- Arg_1_Type(TC_ARRAY);
- errcode=Scheme_Number_To_REAL(Arg2, &xmin);
- if (errcode == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (errcode == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- errcode=Scheme_Number_To_REAL(Arg3, &xmax);
- if (errcode == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (errcode == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
- Length = Array_Length(Arg1);
-
- From_Here = Scheme_Array_To_C_Array(Arg1);
- To_Here = Scheme_Array_To_C_Array(Arg1);
-
- if (xmin>xmax) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- for (i=0; i < Length; i++) {
- if ((*From_Here)<xmin) *To_Here++ = xmin;
- else if ((*From_Here)>xmax) *To_Here++ = xmax;
- else *To_Here++ = *From_Here;
- From_Here++ ; }
- return SHARP_F;
+{
+ PRIMITIVE_HEADER (3);
+ CHECK_ARG (1, ARRAY_P);
+ {
+ SCHEME_OBJECT array = (ARG_REF (1));
+ REAL xmin = (arg_real (2));
+ REAL xmax = (arg_real (3));
+ long Length = (ARRAY_LENGTH (array));
+ REAL * From_Here = (ARRAY_CONTENTS (array));
+ REAL * To_Here = From_Here;
+ long i;
+ if (xmin > xmax)
+ error_bad_range_arg (3);
+ for (i = 0; (i < Length); i += 1)
+ {
+ if ((*From_Here) < xmin)
+ (*To_Here++) = xmin;
+ else if ((*From_Here) > xmax)
+ (*To_Here++) = xmax;
+ else
+ (*To_Here++) = (*From_Here);
+ From_Here += 1;
+ }
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
/* complex-array-operation-1!
- groups together procedures that use 1 complex-array
- and store the result in place
- */
+ groups together procedures that use 1 complex-array
+ and store the result in place */
-DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-1!",
- Prim_complex_array_operation_1, 3,3, 0)
+DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-1!", Prim_complex_array_operation_1, 3,3, 0)
{ long n, i, opcode;
REAL *a, *b;
void complex_array_to_polar(), complex_array_exp(), complex_array_sqrt();
void complex_array_sin(), complex_array_cos();
void complex_array_asin(), complex_array_acos();
-
PRIMITIVE_HEADER (3);
CHECK_ARG (1, FIXNUM_P); /* operation opcode */
CHECK_ARG (2, ARRAY_P); /* input array -- n real part */
CHECK_ARG (3, ARRAY_P); /* input array -- n imag part */
-
- n = Array_Length(ARG_REF(2));
- if (n != Array_Length(ARG_REF(3))) error_bad_range_arg(3);
-
- a = Scheme_Array_To_C_Array(ARG_REF(2)); /* real part */
- b = Scheme_Array_To_C_Array(ARG_REF(3)); /* imag part */
-
+ n = ARRAY_LENGTH(ARG_REF(2));
+ if (n != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
+ a = ARRAY_CONTENTS(ARG_REF(2)); /* real part */
+ b = ARRAY_CONTENTS(ARG_REF(3)); /* imag part */
opcode = arg_nonnegative_integer(1);
-
if (opcode==1)
- complex_array_to_polar(a,b,n);
+ complex_array_to_polar(a,b,n);
else if (opcode==2)
- complex_array_exp(a,b,n);
+ complex_array_exp(a,b,n);
else if (opcode==3)
- complex_array_sqrt(a,b,n);
+ complex_array_sqrt(a,b,n);
else if (opcode==4)
- complex_array_sin(a,b,n);
+ complex_array_sin(a,b,n);
else if (opcode==5)
- complex_array_cos(a,b,n);
+ complex_array_cos(a,b,n);
else if (opcode==6)
- complex_array_asin(a,b,n);
+ complex_array_asin(a,b,n);
else if (opcode==7)
- complex_array_acos(a,b,n);
+ complex_array_acos(a,b,n);
else
error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+void
+complex_array_to_polar (a,b,n)
+ REAL *a,*b;
+ long n;
+{
+ long i;
+ double x,y, temp;
+ for (i=0; i<n; i++)
+ {
+ x = (double) a[i];
+ y = (double) b[i];
+ temp = sqrt(x*x + y*y);
+ if (temp == 0.0)
+ b[i] = 0.0; /* choose angle = 0 for x,y=0,0 */
+ else
+ b[i] = (REAL) atan2(y,x);
+ a[i] = (REAL) temp;
+ }
}
-void complex_array_to_polar(a,b,n)
- REAL *a,*b; long n;
-{ long i;
- double x,y, temp;
- for (i=0; i<n; i++) {
- x = (double) a[i];
- y = (double) b[i];
- temp = sqrt(x*x + y*y);
- if (temp == 0.0)
- b[i] = 0.0; /* choose angle = 0 for x,y=0,0 */
- else
- b[i] = (REAL) atan2(y,x);
- a[i] = (REAL) temp;
- }
-}
-
-void complex_array_exp(a,b,n)
- REAL *a,*b; long n;
-{ long i;
+void
+complex_array_exp (a,b,n)
+ REAL *a,*b;
+ long n;
+{
+ long i;
double x,y, temp;
-
+
for (i=0; i<n; i++)
- { x = (double) a[i];
- y = (double) b[i];
- if ((temp = exp(x)) == HUGE) error_bad_range_arg(2); /* overflow */
- a[i] = (REAL) (temp*cos(y));
- b[i] = (REAL) (temp*sin(y));
- }
+ {
+ x = (double) a[i];
+ y = (double) b[i];
+ if ((temp = exp(x)) == HUGE) error_bad_range_arg(2); /* overflow */
+ a[i] = (REAL) (temp*cos(y));
+ b[i] = (REAL) (temp*sin(y));
+ }
}
-void complex_array_sqrt(a,b,n)
- REAL *a,*b; long n;
-{ long i;
+void
+complex_array_sqrt (a,b,n)
+ REAL *a,*b;
+ long n;
+{
+ long i;
double x,y, r;
-
+
for (i=0; i<n; i++)
- { x = (double) a[i];
- y = (double) b[i];
- r = sqrt( x*x + y*y);
- a[i] = sqrt((r+x)/2.0);
- if (y>0.0)
- b[i] = sqrt((r-x)/2.0); /* choose principal root */
- else /* see Abramowitz (p.17 3.7.27) */
- b[i] = -sqrt((r-x)/2.0);
- }
+ {
+ x = (double) a[i];
+ y = (double) b[i];
+ r = sqrt( x*x + y*y);
+ a[i] = sqrt((r+x)/2.0);
+ if (y>0.0)
+ b[i] = sqrt((r-x)/2.0); /* choose principal root */
+ else /* see Abramowitz (p.17 3.7.27) */
+ b[i] = -sqrt((r-x)/2.0);
+ }
}
-
-void complex_array_sin(a,b,n)
- REAL *a,*b; long n;
-{ long i;
+\f
+void
+complex_array_sin (a,b,n)
+ REAL *a,*b;
+ long n;
+{
+ long i;
double x, ey,fy;
REAL temp;
-
+
for (i=0; i<n; i++)
- { x = (double) a[i];
- ey = exp((double) b[i]); /* radius should be small to avoid overflow */
- fy = 1.0/ey; /* exp(-y) */
- temp = (REAL) (sin(x) * (ey + fy) * 0.5); /* expanded (e(iz)-e(-iz))*(-.5i) formula */
- b[i] = (REAL) (cos(x) * (ey - fy) * 0.5); /* see my notes in Abram.p.71 */
- a[i] = temp;
- }
+ {
+ x = (double) a[i];
+ ey = exp((double) b[i]); /* radius should be small to avoid overflow */
+ fy = 1.0/ey; /* exp(-y) */
+ /* expanded (e(iz)-e(-iz))*(-.5i) formula */
+ temp = (REAL) (sin(x) * (ey + fy) * 0.5);
+ /* see my notes in Abram.p.71 */
+ b[i] = (REAL) (cos(x) * (ey - fy) * 0.5);
+ a[i] = temp;
+ }
}
-void complex_array_cos(a,b,n)
- REAL *a,*b; long n;
-{ long i;
+void
+complex_array_cos (a,b,n)
+ REAL *a,*b;
+ long n;
+{
+ long i;
double x, ey,fy;
REAL temp;
-
+
for (i=0; i<n; i++)
- { x = (double) a[i];
- ey = exp((double) b[i]); /* radius should be small to avoid overflow */
- fy = 1.0/ey; /* exp(-y) */
- temp = (REAL) (cos(x) * (ey + fy) * 0.5); /* expanded (e(iz)+e(-iz))*.5 formula */
- b[i] = (REAL) (sin(x) * (fy - ey) * 0.5); /* see my notes in Abram.p.71*/
- a[i] = temp;
- }
+ {
+ x = (double) a[i];
+ ey = exp((double) b[i]); /* radius should be small to avoid overflow */
+ fy = 1.0/ey; /* exp(-y) */
+ /* expanded (e(iz)+e(-iz))*.5 formula */
+ temp = (REAL) (cos(x) * (ey + fy) * 0.5);
+ b[i] = (REAL) (sin(x) * (fy - ey) * 0.5); /* see my notes in Abram.p.71*/
+ a[i] = temp;
+ }
}
-void complex_array_asin(a,b,n)
- REAL *a,*b; long n;
-{ long i;
+void
+complex_array_asin (a,b,n)
+ REAL *a,*b;
+ long n;
+{
+ long i;
double x,y, alfa,beta, xp1,xm1;
-
+
for (i=0; i<n; i++)
- { x = (double) a[i];
- y = (double) b[i];
- xp1 = x+1; xm1 = x-1;
- xp1 = xp1*xp1; xm1 = xm1*xm1;
- y = y*y;
- x = sqrt(xp1+y); /* use again as temp var */
- y = sqrt(xm1+y); /* use again as temp var */
- alfa = (x+y)*0.5;
- beta = (x-y)*0.5; /* Abramowitz p.81 4.4.37 */
- a[i] = (REAL) asin(beta);
- b[i] = (REAL) log(alfa + sqrt(alfa*alfa - 1));
- }
+ {
+ x = (double) a[i];
+ y = (double) b[i];
+ xp1 = x+1; xm1 = x-1;
+ xp1 = xp1*xp1; xm1 = xm1*xm1;
+ y = y*y;
+ x = sqrt(xp1+y); /* use again as temp var */
+ y = sqrt(xm1+y); /* use again as temp var */
+ alfa = (x+y)*0.5;
+ beta = (x-y)*0.5; /* Abramowitz p.81 4.4.37 */
+ a[i] = (REAL) asin(beta);
+ b[i] = (REAL) log(alfa + sqrt(alfa*alfa - 1));
+ }
}
-
-void complex_array_acos(a,b,n)
- REAL *a,*b; long n;
-{ long i;
+\f
+void
+complex_array_acos (a,b,n)
+ REAL *a,*b;
+ long n;
+{
+ long i;
double x,y, alfa,beta, xp1,xm1;
-
+
for (i=0; i<n; i++)
- { x = (double) a[i];
- y = (double) b[i];
- xp1 = x+1; xm1 = x-1;
- xp1 = xp1*xp1; xm1 = xm1*xm1;
- y = y*y;
- x = sqrt(xp1+y); /* use again as temp var */
- y = sqrt(xm1+y); /* use again as temp var */
- alfa = (x+y)*0.5;
- beta = (x-y)*0.5; /* Abramowitz p.81 4.4.38 */
- a[i] = (REAL) acos(beta);
- b[i] = (REAL) -log(alfa + sqrt(alfa*alfa - 1));
- }
+ {
+ x = (double) a[i];
+ y = (double) b[i];
+ xp1 = x+1; xm1 = x-1;
+ xp1 = xp1*xp1; xm1 = xm1*xm1;
+ y = y*y;
+ x = sqrt(xp1+y); /* use again as temp var */
+ y = sqrt(xm1+y); /* use again as temp var */
+ alfa = (x+y)*0.5;
+ beta = (x-y)*0.5; /* Abramowitz p.81 4.4.38 */
+ a[i] = (REAL) acos(beta);
+ b[i] = (REAL) -log(alfa + sqrt(alfa*alfa - 1));
+ }
}
-
/* complex-array-operation-1b!
- groups together procedures that use 1 complex-array & 1 number
- and store the result in place
- (e.g. invert 1/x)
- */
+ groups together procedures that use 1 complex-array & 1 number
+ and store the result in place (e.g. invert 1/x) */
-DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-1B!",
- Prim_complex_array_operation_1b, 4,4, 0)
-{ long n, i, opcode;
+DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-1B!", Prim_complex_array_operation_1b, 4,4, 0)
+{
+ long n, i, opcode;
REAL *a, *b, inf;
- void complex_array_invert();
- int errcode;
-
+ void complex_array_invert ();
PRIMITIVE_HEADER (4);
CHECK_ARG (1, FIXNUM_P); /* operation opcode */
CHECK_ARG (2, ARRAY_P); /* input array -- n real part */
CHECK_ARG (3, ARRAY_P); /* input array -- n imag part */
- errcode = Scheme_Number_To_REAL(ARG_REF(4), &inf); /* User-Provided Infinity */
- if (errcode==1) error_bad_range_arg(4); if (errcode==2) error_wrong_type_arg(4);
-
- n = Array_Length(ARG_REF(2));
- if (n != Array_Length(ARG_REF(3))) error_bad_range_arg(3);
-
- a = Scheme_Array_To_C_Array(ARG_REF(2)); /* real part */
- b = Scheme_Array_To_C_Array(ARG_REF(3)); /* imag part */
-
+ inf = (arg_real (4)); /* User-Provided Infinity */
+ n = ARRAY_LENGTH(ARG_REF(2));
+ if (n != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
+ a = ARRAY_CONTENTS(ARG_REF(2)); /* real part */
+ b = ARRAY_CONTENTS(ARG_REF(3)); /* imag part */
opcode = arg_nonnegative_integer(1);
-
if (opcode==1)
complex_array_invert(a,b, n, inf); /* performs 1/x */
else if (opcode==2)
error_bad_range_arg(1); /* illegal opcode */
else
error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-void complex_array_invert(a,b, n, inf)
- REAL *a,*b, inf; long n;
-{ long i;
+void
+complex_array_invert (a,b, n, inf)
+ REAL *a,*b, inf;
+ long n;
+{
+ long i;
double x,y, r;
-
for (i=0; i<n; i++)
- { x = (double) a[i];
- y = (double) b[i];
- r = (x*x + y*y);
- if (r==0.0) {
- a[i] = inf;
- b[i] = inf; }
- else {
- a[i] = (REAL) x/r;
- b[i] = (REAL) -y/r; }
- }
+ {
+ x = (double) a[i];
+ y = (double) b[i];
+ r = (x*x + y*y);
+ if (r==0.0)
+ {
+ a[i] = inf;
+ b[i] = inf;
+ }
+ else
+ {
+ a[i] = (REAL) x/r;
+ b[i] = (REAL) -y/r;
+ }
+ }
}
-
-
-
+\f
/* complex-array-operation-1a
- groups together procedures that use 1 complex-array
- and store result in a 3rd real array.
- */
+ groups together procedures that use 1 complex-array
+ and store result in a 3rd real array. */
-DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-1A",
- Prim_complex_array_operation_1a, 4,4, 0)
-{ long n, i, opcode;
+DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-1A", Prim_complex_array_operation_1a, 4,4, 0)
+{
+ long n, i, opcode;
REAL *a, *b, *c;
void complex_array_magnitude(), complex_array_angle();
-
PRIMITIVE_HEADER (4);
CHECK_ARG (1, FIXNUM_P); /* operation opcode */
CHECK_ARG (2, ARRAY_P); /* input array -- n real part */
CHECK_ARG (3, ARRAY_P); /* input array -- n imag part */
CHECK_ARG (4, ARRAY_P); /* output array -- n */
-
- n = Array_Length(ARG_REF(2));
- if (n != Array_Length(ARG_REF(3))) error_bad_range_arg(3);
- if (n != Array_Length(ARG_REF(4))) error_bad_range_arg(4);
-
- a = Scheme_Array_To_C_Array(ARG_REF(2)); /* real part */
- b = Scheme_Array_To_C_Array(ARG_REF(3)); /* imag part */
- c = Scheme_Array_To_C_Array(ARG_REF(4)); /* output */
-
+ n = ARRAY_LENGTH(ARG_REF(2));
+ if (n != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
+ if (n != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
+ a = ARRAY_CONTENTS(ARG_REF(2)); /* real part */
+ b = ARRAY_CONTENTS(ARG_REF(3)); /* imag part */
+ c = ARRAY_CONTENTS(ARG_REF(4)); /* output */
opcode = arg_nonnegative_integer(1);
-
if (opcode==1)
- complex_array_magnitude(a,b,c,n);
+ complex_array_magnitude(a,b,c,n);
else if (opcode==2)
- complex_array_angle(a,b,c,n);
+ complex_array_angle(a,b,c,n);
else
error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-void complex_array_magnitude(a,b,c,n)
- REAL *a,*b,*c; long n;
-{ long i;
+void
+complex_array_magnitude (a,b,c,n)
+ REAL *a,*b,*c;
+ long n;
+{
+ long i;
for (i=0; i<n; i++)
c[i] = (REAL) sqrt( (double) a[i]*a[i] + b[i]*b[i] );
}
-void complex_array_angle(a,b,c,n)
- REAL *a,*b,*c; long n;
-{ long i;
- for (i=0; i<n; i++) {
- if ((a[i] == 0.0) && (b[i]==0.0))
- c[i] = 0.0; /* choose angle=0 for point (0,0) */
- else
- c[i] = (REAL) atan2( (double) b[i], (double) a[i]); }
- /* imag real */
+void
+complex_array_angle (a,b,c,n)
+ REAL *a,*b,*c;
+ long n;
+{
+ long i;
+ for (i=0; i<n; i++)
+ {
+ if ((a[i] == 0.0) && (b[i]==0.0))
+ c[i] = 0.0; /* choose angle=0 for point (0,0) */
+ else
+ c[i] = (REAL) atan2( (double) b[i], (double) a[i]);
+ }
}
-
-
-
+\f
DEFINE_PRIMITIVE ("CS-ARRAY-MAGNITUDE!", Prim_cs_array_magnitude, 1, 1, 0)
-{ long n, i;
+{
+ long n, i;
REAL *a;
void cs_array_magnitude();
PRIMITIVE_HEADER (1);
CHECK_ARG (1, ARRAY_P);
- a = Scheme_Array_To_C_Array(ARG_REF(1)); /* input cs-array */
- n = Array_Length(ARG_REF(1)); /* becomes a standard array on return */
-
+ a = ARRAY_CONTENTS(ARG_REF(1)); /* input cs-array */
+ n = ARRAY_LENGTH(ARG_REF(1)); /* becomes a standard array on return */
cs_array_magnitude(a,n);
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-/* result is a standard array (even signal, real data)
- */
-void cs_array_magnitude(a,n)
- REAL *a; long n;
-{ long i, n2, ni;
+/* result is a standard array (even signal, real data) */
+void
+cs_array_magnitude (a,n)
+ REAL *a;
+ long n;
+{
+ long i, n2, ni;
n2 = n/2; /* integer division truncates down */
-
a[0] = (REAL) fabs((double) a[0]); /* imag=0 */
-
if (2*n2 == n) /* even length, n2 is only real */
a[n2] = (REAL) fabs((double) a[n2]); /* imag=0 */
- else
- n2 = n2+1; /* odd length, make the loop include the n2 index */
-
+ else
+ /* odd length, make the loop include the n2 index */
+ n2 = n2+1;
for (i=1; i<n2; i++)
- { ni = n-i;
- a[i] = (REAL) sqrt( (double) a[i]*a[i] + (double) a[ni]*a[ni] );
- a[ni] = a[i]; /* even signal */
- }
+ {
+ ni = n-i;
+ a[i] = (REAL) sqrt( (double) a[i]*a[i] + (double) a[ni]*a[ni] );
+ a[ni] = a[i]; /* even signal */
+ }
}
-
-
-/* Rectangular and Polar
-
- A cs-array has even magnitude and odd angle (almost)
- hence
- a polar cs-array stores magnitude in the first half (real part)
- and angle in the second half (imag part)
-
- except for a[0] real-only and a[n2] (n even)
- The angle of a[0] is either 0 (pos. sign) or pi (neg. sign),
- but there is no place in an n-point cs-array to store this, so
- a[0] and a[n2] when n even are left unchanged when going polar.
- as opposed to taking their absolute values, for magnitude.
-
- */
+\f
+/* Rectangular and Polar
+ A cs-array has even magnitude and odd angle (almost)
+ hence a polar cs-array stores magnitude in the first half (real part)
+ and angle in the second half (imag part)
+ except for a[0] real-only and a[n2] (n even)
+ The angle of a[0] is either 0 (pos. sign) or pi (neg. sign),
+ but there is no place in an n-point cs-array to store this, so
+ a[0] and a[n2] when n even are left unchanged when going polar.
+ as opposed to taking their absolute values, for magnitude. */
DEFINE_PRIMITIVE ("CS-ARRAY-TO-POLAR!", Prim_cs_array_to_polar, 1,1, 0)
-{ long n, i;
+{
+ long n, i;
REAL *a;
void cs_array_to_polar();
-
PRIMITIVE_HEADER (1);
- CHECK_ARG (1, ARRAY_P); /* input and output array -- both cs-arrays */
- a = Scheme_Array_To_C_Array(ARG_REF(1));
- n = Array_Length(ARG_REF(1));
-
+ CHECK_ARG (1, ARRAY_P);
+ a = ARRAY_CONTENTS(ARG_REF(1));
+ n = ARRAY_LENGTH(ARG_REF(1));
cs_array_to_polar(a,n);
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-void cs_array_to_polar(a,n)
- REAL *a; long n;
-{ long i, n2;
+void
+cs_array_to_polar (a,n)
+ REAL *a;
+ long n;
+{
+ long i, n2;
double real, imag; /* temporary variables */
n2 = n/2; /* integer division truncates down */
-
- ; /* a[0] stores both magnitude and angle
- (pos. sign angle=0 , neg. sign angle=pi) */
-
+ /* a[0] stores both magnitude and angle
+ (pos. sign angle=0 , neg. sign angle=pi) */
if (2*n2 == n) /* even length, n2 is only real */
; /* a[n2] stores sign information like a[0] */
- else
- n2 = n2+1; /* odd length, make the loop include the n2 index */
-
+ else
+ /* odd length, make the loop include the n2 index */
+ n2 = n2+1;
for (i=1; i<n2; i++)
- { real = (double) a[i];
- imag = (double) a[n-i];
- a[i] = (REAL) sqrt( real*real + imag*imag );
- if (a[i] == 0.0)
- a[n-i] = 0.0;
- else
- a[n-i] = (REAL) atan2( imag, real ); }
+ {
+ real = (double) a[i];
+ imag = (double) a[n-i];
+ a[i] = (REAL) sqrt( real*real + imag*imag );
+ if (a[i] == 0.0)
+ a[n-i] = 0.0;
+ else
+ a[n-i] = (REAL) atan2( imag, real );
+ }
}
-
-DEFINE_PRIMITIVE ("CS-ARRAY-TO-RECTANGULAR!",
- Prim_cs_array_to_rectangular, 1,1, 0)
-{ long n,n2, i;
+\f
+DEFINE_PRIMITIVE ("CS-ARRAY-TO-RECTANGULAR!", Prim_cs_array_to_rectangular, 1,1, 0)
+{
+ long n,n2, i;
double magn,angl; /* temporary variables */
REAL *a;
-
PRIMITIVE_HEADER (1);
- CHECK_ARG (1, ARRAY_P); /* input and output array -- both cs-arrays */
- a = Scheme_Array_To_C_Array(ARG_REF(1));
- n = Array_Length(ARG_REF(1));
+ CHECK_ARG (1, ARRAY_P);
+ a = ARRAY_CONTENTS(ARG_REF(1));
+ n = ARRAY_LENGTH(ARG_REF(1));
n2 = n/2; /* integer division truncates down */
-
; /* a[0] is okay */
-
if (2*n2 == n) /* even length, n2 is real only */
; /* a[n2] is okay */
else
- n2 = n2+1; /* odd length, make the loop include the n2 index */
-
+ n2 = n2+1; /* odd length, make the loop include the n2 index */
for (i=1; i<n2; i++)
{ magn = (double) a[i];
angl = (double) a[n-i];
a[i] = (REAL) magn * cos(angl);
a[n-i] = (REAL) magn * sin(angl); }
-
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
-/* Convolution in the Time-Domain
- */
-
+/* Convolution in the Time-Domain */
/* In the following macro
- To1 and To2 should be (Length1-1) and (Length2-1) respectively.
- */
-#define C_Convolution_Point_Macro(X, Y, To1, To2, N, Result) \
-{ long Min_of_N_To1=min((N),(To1)); \
- long mi, N_minus_mi; \
- REAL Sum=0.0; \
- for (mi=max(0,(N)-(To2)), N_minus_mi=(N)-mi; mi <= Min_of_N_To1; mi++, N_minus_mi--) \
- Sum += (X[mi] * Y[N_minus_mi]); \
- (Result)=Sum; \
+ To1 and To2 should be (Length1-1) and (Length2-1) respectively. */
+
+#define C_Convolution_Point_Macro(X, Y, To1, To2, N, Result) \
+{ \
+ long Min_of_N_To1 = (min ((N), (To1))); \
+ long mi, N_minus_mi; \
+ REAL Sum = 0.0; \
+ for (mi = (max (0, ((N) - (To2)))), N_minus_mi = ((N) - mi); \
+ (mi <= Min_of_N_To1); \
+ mi += 1, N_minus_mi -= 1) \
+ Sum += ((X [mi]) * (Y [N_minus_mi])); \
+ (Result) = Sum; \
}
+
DEFINE_PRIMITIVE ("CONVOLUTION-POINT", Prim_convolution_point, 3, 3, 0)
-{ long Length1, Length2, N;
+{
+ long Length1, Length2, N;
REAL *Array1, *Array2;
REAL C_Result;
-
- Primitive_3_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_ARRAY);
- Arg_3_Type(TC_FIXNUM);
- Length1 = Array_Length(Arg1);
- Length2 = Array_Length(Arg2);
- N = Get_Integer(Arg3);
- Array1 = Scheme_Array_To_C_Array(Arg1);
- Array2 = Scheme_Array_To_C_Array(Arg2);
+ PRIMITIVE_HEADER (3);
+ CHECK_ARG (1, ARRAY_P);
+ CHECK_ARG (2, ARRAY_P);
+ Length1 = ARRAY_LENGTH (ARG_REF (1));
+ Length2 = ARRAY_LENGTH (ARG_REF (2));
+ N = (arg_nonnegative_integer (3));
+ Array1 = ARRAY_CONTENTS (ARG_REF (1));
+ Array2 = ARRAY_CONTENTS (ARG_REF (2));
C_Convolution_Point_Macro(Array1, Array2, Length1-1, Length2-1, N, C_Result);
- Reduced_Flonum_Result(C_Result);
+ PRIMITIVE_RETURN (double_to_flonum ((double) C_Result));
}
-
-DEFINE_PRIMITIVE ("ARRAY-CONVOLUTION-IN-TIME!",
- Prim_array_convolution_in_time, 3, 3, 0)
-{ long n,m,l, n_1,m_1, i;
+\f
+DEFINE_PRIMITIVE ("ARRAY-CONVOLUTION-IN-TIME!", Prim_array_convolution_in_time, 3, 3, 0)
+{
+ long n,m,l, n_1,m_1, i;
REAL *a,*b,*c;
-
PRIMITIVE_HEADER (3);
- CHECK_ARG (1, ARRAY_P); /* input array a -- length n */
- CHECK_ARG (2, ARRAY_P); /* input array b -- length m */
- CHECK_ARG (3, ARRAY_P); /* ouput array c -- length l = (n + m - 1) */
- a = Scheme_Array_To_C_Array(ARG_REF(1));
- b = Scheme_Array_To_C_Array(ARG_REF(2));
- c = Scheme_Array_To_C_Array(ARG_REF(3));
-
- n = Array_Length(ARG_REF(1));
- m = Array_Length(ARG_REF(2));
+ CHECK_ARG (1, ARRAY_P);
+ CHECK_ARG (2, ARRAY_P);
+ CHECK_ARG (3, ARRAY_P);
+ a = ARRAY_CONTENTS(ARG_REF(1));
+ b = ARRAY_CONTENTS(ARG_REF(2));
+ c = ARRAY_CONTENTS(ARG_REF(3));
+ n = ARRAY_LENGTH(ARG_REF(1));
+ m = ARRAY_LENGTH(ARG_REF(2));
l = n+m-1; /* resulting length */
- if (l != Array_Length(ARG_REF(3))) error_bad_range_arg(3);
-
+ if (l != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
n_1 = n-1; m_1 = m-1;
for (i=0; i<l; i++)
{ C_Convolution_Point_Macro(a, b, n_1, m_1, i, c[i]); }
-
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-DEFINE_PRIMITIVE ("ARRAY-MULTIPLY-INTO-SECOND-ONE!",
- Prim_array_multiply_into_second_one, 2, 2, 0)
-{ long Length, i;
+DEFINE_PRIMITIVE ("ARRAY-MULTIPLY-INTO-SECOND-ONE!", Prim_array_multiply_into_second_one, 2, 2, 0)
+{
+ long Length, i;
REAL *To_Here;
REAL *From_Here_1, *From_Here_2;
- Pointer Result;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
- if (Length != Array_Length(Arg2)) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- Result = Arg2;
-
- From_Here_1 = Scheme_Array_To_C_Array(Arg1);
- From_Here_2 = Scheme_Array_To_C_Array(Arg2);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i < Length; i++) {
- *To_Here++ = (*From_Here_1) * (*From_Here_2);
- From_Here_1++ ;
- From_Here_2++ ;
- }
- return Result;
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, ARRAY_P);
+ CHECK_ARG (2, ARRAY_P);
+ Length = ARRAY_LENGTH (ARG_REF (1));
+ if (Length != ARRAY_LENGTH (ARG_REF (2))) error_bad_range_arg (2);
+ From_Here_1 = ARRAY_CONTENTS (ARG_REF (1));
+ From_Here_2 = ARRAY_CONTENTS (ARG_REF (2));
+ To_Here = From_Here_2;
+ for (i=0; i < Length; i++)
+ {
+ *To_Here++ = (*From_Here_1) * (*From_Here_2);
+ From_Here_1++ ;
+ From_Here_2++ ;
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
+\f
/* complex-array-operation-2!
- groups together procedures that use 2 complex-arrays
- and store result in either 1st or 2nd
- */
+ groups together procedures that use 2 complex-arrays
+ and store result in either 1st or 2nd */
-DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-2!",
- Prim_complex_array_operation_2, 5,5, 0)
-{ long n, opcode;
+DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-2!", Prim_complex_array_operation_2, 5,5, 0)
+{
+ long n, opcode;
REAL *ax,*ay, *bx,*by;
void complex_array_multiply_into_second_one();
-
PRIMITIVE_HEADER (5);
CHECK_ARG (1, FIXNUM_P); /* operation opcode */
CHECK_ARG (2, ARRAY_P); /* ax array -- n real */
CHECK_ARG (3, ARRAY_P); /* ay array -- n imag */
CHECK_ARG (4, ARRAY_P); /* bx array -- n real */
CHECK_ARG (5, ARRAY_P); /* by array -- n imag */
-
- n = Array_Length(ARG_REF(2));
- if (n != Array_Length(ARG_REF(3))) error_bad_range_arg(3);
- if (n != Array_Length(ARG_REF(4))) error_bad_range_arg(4);
- if (n != Array_Length(ARG_REF(4))) error_bad_range_arg(5);
-
- ax = Scheme_Array_To_C_Array(ARG_REF(2)); /* real */
- ay = Scheme_Array_To_C_Array(ARG_REF(3)); /* imag */
- bx = Scheme_Array_To_C_Array(ARG_REF(4)); /* real */
- by = Scheme_Array_To_C_Array(ARG_REF(5)); /* imag */
-
+ n = ARRAY_LENGTH(ARG_REF(2));
+ if (n != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
+ if (n != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
+ if (n != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(5);
+ ax = ARRAY_CONTENTS(ARG_REF(2)); /* real */
+ ay = ARRAY_CONTENTS(ARG_REF(3)); /* imag */
+ bx = ARRAY_CONTENTS(ARG_REF(4)); /* real */
+ by = ARRAY_CONTENTS(ARG_REF(5)); /* imag */
opcode = arg_nonnegative_integer(1);
-
if (opcode==1)
- complex_array_multiply_into_second_one(ax,ay,bx,by, n);
+ complex_array_multiply_into_second_one(ax,ay,bx,by, n);
else if (opcode==2)
error_bad_range_arg(1); /* illegal opcode */
else
error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-void complex_array_multiply_into_second_one(ax,ay,bx,by, n)
- REAL *ax,*ay,*bx,*by; long n;
-{ long i;
+void
+complex_array_multiply_into_second_one (ax,ay,bx,by, n)
+ REAL *ax,*ay,*bx,*by;
+ long n;
+{
+ long i;
REAL temp;
- for (i=0;i<n;i++) {
- temp = ax[i]*bx[i] - ay[i]*by[i]; /* real part */
- by[i] = ax[i]*by[i] + ay[i]*bx[i]; /* imag part */
- bx[i] = temp; }
+ for (i=0;i<n;i++)
+ {
+ temp = ax[i]*bx[i] - ay[i]*by[i]; /* real part */
+ by[i] = ax[i]*by[i] + ay[i]*bx[i]; /* imag part */
+ bx[i] = temp;
+ }
}
-
-void C_Array_Complex_Multiply_Into_First_One(a,b,c,d, length) /* used in fft.c */
- REAL *a,*b,*c,*d; long length;
-{ long i;
+void
+C_Array_Complex_Multiply_Into_First_One (a,b,c,d, length) /* used in fft.c */
+ REAL *a,*b,*c,*d;
+ long length;
+{
+ long i;
REAL temp;
- for (i=0;i<length;i++) {
- temp = a[i]*c[i] - b[i]*d[i];
- b[i] = a[i]*d[i] + b[i]*c[i];
- a[i] = temp;
- }
+ for (i=0;i<length;i++)
+ {
+ temp = a[i]*c[i] - b[i]*d[i];
+ b[i] = a[i]*d[i] + b[i]*c[i];
+ a[i] = temp;
+ }
}
-
-
-DEFINE_PRIMITIVE ("ARRAY-DIVIDE-INTO-XXX!",
- Prim_array_divide_into_xxx, 4,4, 0)
-{ long n, i, one_or_two;
+\f
+DEFINE_PRIMITIVE ("ARRAY-DIVIDE-INTO-XXX!", Prim_array_divide_into_xxx, 4,4, 0)
+{
+ long n, i, one_or_two;
REAL *x,*y,*z, inf;
- int errcode;
void array_divide_into_z();
-
PRIMITIVE_HEADER (4);
CHECK_ARG (1, ARRAY_P);
CHECK_ARG (2, ARRAY_P);
- errcode = Scheme_Number_To_REAL(ARG_REF(3), &inf);
- if (errcode==1) error_bad_range_arg(3); if (errcode==2) error_wrong_type_arg(3);
- CHECK_ARG (4, FIXNUM_P);
- one_or_two = arg_nonnegative_integer(4); /* where to store result of division */
-
- x = Scheme_Array_To_C_Array(ARG_REF(1));
- y = Scheme_Array_To_C_Array(ARG_REF(2));
- n = Array_Length(ARG_REF(1));
- if (n!=(Array_Length(ARG_REF(2)))) error_bad_range_arg(2);
-
+ inf = (arg_real (3));
+ /* where to store result of division */
+ one_or_two = (arg_nonnegative_integer (4));
+ x = ARRAY_CONTENTS(ARG_REF(1));
+ y = ARRAY_CONTENTS(ARG_REF(2));
+ n = ARRAY_LENGTH(ARG_REF(1));
+ if (n!=(ARRAY_LENGTH(ARG_REF(2)))) error_bad_range_arg(2);
if (one_or_two == 1)
array_divide_into_z( x,y, x, n, inf);
else if (one_or_two == 2)
array_divide_into_z( x,y, y, n, inf);
else
error_bad_range_arg(4);
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-void array_divide_into_z( x,y, z, n, inf) /* z can either x or y */
- REAL *x,*y,*z, inf; long n;
-{ long i;
- for (i=0; i<n; i++) {
- if (y[i] == 0.0) {
- if (x[i] == 0.0) z[i] = 1.0;
- else z[i] = inf * x[i]; }
- else z[i] = x[i] / y[i];
- }
+void
+array_divide_into_z (x,y, z, n, inf) /* z can either x or y */
+ REAL *x,*y,*z, inf;
+ long n;
+{
+ long i;
+ for (i=0; i<n; i++)
+ {
+ if (y[i] == 0.0)
+ {
+ if (x[i] == 0.0)
+ z[i] = 1.0;
+ else
+ z[i] = inf * x[i];
+ }
+ else
+ z[i] = x[i] / y[i];
+ }
}
-
-
+\f
/* complex-array-operation-2b!
- groups together procedures that use 2 complex-arrays & 1 additional real number
- and store result in either 1st or 2nd
- (e.g. division)
- */
+ groups together procedures that use 2 complex-arrays
+ & 1 additional real number
+ and store result in either 1st or 2nd (e.g. division) */
-DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-2B!",
- Prim_complex_array_operation_2b, 6,6, 0)
+DEFINE_PRIMITIVE ("COMPLEX-ARRAY-OPERATION-2B!", Prim_complex_array_operation_2b, 6,6, 0)
{ long n, opcode;
REAL *ax,*ay, *bx,*by, inf;
void complex_array_divide_into_z();
- int errcode;
-
PRIMITIVE_HEADER (6);
CHECK_ARG (1, FIXNUM_P); /* operation opcode */
CHECK_ARG (2, ARRAY_P); /* ax array -- n real */
CHECK_ARG (3, ARRAY_P); /* ay array -- n imag */
CHECK_ARG (4, ARRAY_P); /* bx array -- n real */
CHECK_ARG (5, ARRAY_P); /* by array -- n imag */
- errcode = Scheme_Number_To_REAL(ARG_REF(6), &inf); /* User-Provided Infinity */
- if (errcode==1) error_bad_range_arg(6); if (errcode==2) error_wrong_type_arg(6);
-
- n = Array_Length(ARG_REF(2));
- if (n != Array_Length(ARG_REF(3))) error_bad_range_arg(3);
- if (n != Array_Length(ARG_REF(4))) error_bad_range_arg(4);
- if (n != Array_Length(ARG_REF(4))) error_bad_range_arg(5);
-
- ax = Scheme_Array_To_C_Array(ARG_REF(2)); /* real */
- ay = Scheme_Array_To_C_Array(ARG_REF(3)); /* imag */
- bx = Scheme_Array_To_C_Array(ARG_REF(4)); /* real */
- by = Scheme_Array_To_C_Array(ARG_REF(5)); /* imag */
-
+ inf = (arg_real (6)); /* User-Provided Infinity */
+ n = ARRAY_LENGTH(ARG_REF(2));
+ if (n != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
+ if (n != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
+ if (n != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(5);
+ ax = ARRAY_CONTENTS(ARG_REF(2)); /* real */
+ ay = ARRAY_CONTENTS(ARG_REF(3)); /* imag */
+ bx = ARRAY_CONTENTS(ARG_REF(4)); /* real */
+ by = ARRAY_CONTENTS(ARG_REF(5)); /* imag */
opcode = arg_nonnegative_integer(1);
-
if (opcode==1)
- complex_array_divide_into_z(ax,ay,bx,by, ax,ay, n, inf); /* into-first-one */
+ complex_array_divide_into_z (ax,ay,bx,by, ax,ay, n, inf);
else if (opcode==2)
- complex_array_divide_into_z(ax,ay,bx,by, bx,by, n, inf); /* into-second-one */
+ complex_array_divide_into_z (ax,ay,bx,by, bx,by, n, inf);
else
error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
-void complex_array_divide_into_z(xr,xi, yr,yi, zr,zi, n, inf) /* z can be either x or y */
- REAL *xr,*xi, *yr,*yi, *zr,*zi, inf; long n;
-{ long i;
- register double temp, radius;
-
+void
+complex_array_divide_into_z (xr,xi, yr,yi, zr,zi, n, inf)
+ REAL *xr,*xi, *yr,*yi, *zr,*zi, inf;
+ long n;
+{
+ long i;
+ fast double temp, radius;
for (i=0; i<n; i++)
- { radius = (double) (yr[i] * yr[i]) + (yi[i] * yi[i]); /* denominator */
- if (radius == 0.0) {
- if (xr[i] == 0.0) zr[i] = 1.0;
- else zr[i] = inf * xr[i];
- if (xi[i] == 0.0) zi[i] = 1.0;
- else zi[i] = inf * xi[i]; }
- else {
- temp = (double) (xr[i] * yr[i] + xi[i] * yi[i]);
- zi[i] = (REAL) (xi[i] * yr[i] - xr[i] * yi[i]) / radius;
- zr[i] = (REAL) temp / radius;
- }}
+ {
+ radius = (double) (yr[i] * yr[i]) + (yi[i] * yi[i]); /* denominator */
+ if (radius == 0.0)
+ {
+ if (xr[i] == 0.0)
+ zr[i] = 1.0;
+ else
+ zr[i] = inf * xr[i];
+ if (xi[i] == 0.0)
+ zi[i] = 1.0;
+ else
+ zi[i] = inf * xi[i];
+ }
+ else
+ {
+ temp = (double) (xr[i] * yr[i] + xi[i] * yi[i]);
+ zi[i] = (REAL) (xi[i] * yr[i] - xr[i] * yi[i]) / radius;
+ zr[i] = (REAL) temp / radius;
+ }
+ }
}
-
-
-DEFINE_PRIMITIVE ("ARRAY-LINEAR-SUPERPOSITION-INTO-SECOND-ONE!",
- Prim_array_linear_superposition_into_second_one, 4, 4, 0)
-{ long n, i;
+\f
+DEFINE_PRIMITIVE ("ARRAY-LINEAR-SUPERPOSITION-INTO-SECOND-ONE!", Prim_array_linear_superposition_into_second_one, 4, 4, 0)
+{
+ long n, i;
REAL *To_Here, Coeff1, Coeff2;
REAL *From_Here_1, *From_Here_2;
- Pointer Result;
- int errcode;
-
- Primitive_4_Args();
- errcode = Scheme_Number_To_REAL(Arg1, &Coeff1);
- if (errcode == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- if (errcode == 2) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Arg_2_Type(TC_ARRAY);
- errcode = Scheme_Number_To_REAL(Arg3, &Coeff2);
- if (errcode == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (errcode == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
- Arg_4_Type(TC_ARRAY);
-
- n = Array_Length(Arg2);
- if (n != Array_Length(Arg4)) Primitive_Error(ERR_ARG_4_BAD_RANGE);
-
- Result = Arg4;
-
- From_Here_1 = Scheme_Array_To_C_Array(Arg2);
- From_Here_2 = Scheme_Array_To_C_Array(Arg4);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i < n; i++) {
- *To_Here++ = (Coeff1 * (*From_Here_1)) + (Coeff2 * (*From_Here_2));
- From_Here_1++ ;
- From_Here_2++ ;
- }
- return Result;
+ PRIMITIVE_HEADER (4);
+ Coeff1 = (arg_real (1));
+ CHECK_ARG (2, ARRAY_P);
+ Coeff2 = (arg_real (3));
+ CHECK_ARG (4, ARRAY_P);
+ n = (ARRAY_LENGTH (ARG_REF (2)));
+ if (n != (ARRAY_LENGTH (ARG_REF (4))))
+ error_bad_range_arg (4);
+ From_Here_1 = (ARRAY_CONTENTS (ARG_REF (2)));
+ From_Here_2 = (ARRAY_CONTENTS (ARG_REF (4)));
+ To_Here = From_Here_2;
+ for (i=0; i < n; i++)
+ {
+ *To_Here++ = (Coeff1 * (*From_Here_1)) + (Coeff2 * (*From_Here_2));
+ From_Here_1++ ;
+ From_Here_2++ ;
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-/* m_pi = 3.14159265358979323846264338327950288419716939937510;
- */
+/* m_pi = 3.14159265358979323846264338327950288419716939937510; */
DEFINE_PRIMITIVE ("SAMPLE-PERIODIC-FUNCTION", Prim_sample_periodic_function, 4, 4, 0)
-{ long N, i, allocated_cells, Function_Number;
+{
+ long N, i, Function_Number;
double Signal_Frequency, Sampling_Frequency, DT, DTi;
double twopi = 6.28318530717958;
- Pointer Result, Pfunction_number, Psignal_frequency;
- Pointer Pfunction_Number;
- int errcode;
+ SCHEME_OBJECT Result, Pfunction_number, Psignal_frequency;
+ SCHEME_OBJECT Pfunction_Number;
REAL *To_Here;
double unit_square_wave(), unit_triangle_wave();
-
- Primitive_4_Args();
- Arg_1_Type(TC_FIXNUM);
- Arg_4_Type(TC_FIXNUM);
- Range_Check(Function_Number, Arg1, 0, 10, ERR_ARG_1_BAD_RANGE); /* fix this */
-
- errcode = Scheme_Number_To_Double(Arg2, &Signal_Frequency);
- if (errcode == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (errcode == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- if (Signal_Frequency == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- errcode = Scheme_Number_To_Double(Arg3, &Sampling_Frequency);
- if (errcode == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (errcode == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
- if (Sampling_Frequency == 0) Primitive_Error(ERR_ARG_3_BAD_RANGE);
-
- Range_Check(N, Arg4, 0, ARRAY_MAX_LENGTH, ERR_ARG_4_BAD_RANGE);
-
- Allocate_Array(Result, N, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
-
+ PRIMITIVE_HEADER (4);
+ Function_Number = (arg_index_integer (1, 11));
+ Signal_Frequency = (arg_real_number (2));
+ if (Signal_Frequency == 0)
+ error_bad_range_arg (2);
+ Sampling_Frequency = (arg_real_number (3));
+ if (Sampling_Frequency == 0)
+ error_bad_range_arg (3);
+ N = (arg_nonnegative_integer (4));
+ Result = (allocate_array (N));
+ To_Here = ARRAY_CONTENTS(Result);
DT = (double) (twopi * Signal_Frequency * (1 / Sampling_Frequency));
if (Function_Number == 0)
for (i=0, DTi=0.0; i < N; i++, DTi += DT)
else if (Function_Number == 2)
for (i=0, DTi=0.0; i < N; i++, DTi += DT)
*To_Here++ = (REAL) unit_square_wave(DTi);
- else if (Function_Number == 3)
+ else if (Function_Number == 3)
for (i=0, DTi=0.0; i < N; i++, DTi += DT)
*To_Here++ = (REAL) unit_triangle_wave(DTi);
else
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
-
- return Result;
+ error_bad_range_arg (1);
+ PRIMITIVE_RETURN (Result);
}
-
-double hamming(t, length) double t, length;
-{ double twopi = 6.28318530717958;
+\f;
+double
+hamming (t, length)
+ double t, length;
+{
+ double twopi = 6.28318530717958;
double pi = twopi/2.;
double t_bar = cos(twopi * (t / length));
if ((t<length) && (t>0.0)) return(.08 + .46 * (1 - t_bar));
else return (0);
}
-double unit_square_wave(t) double t;
-{ double twopi = 6.28318530717958;
+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);
+ if (t_bar < pi) return(1);
+ else return(-1);
}
-double unit_triangle_wave(t) double t;
-{ double twopi = 6.28318530717958;
+double
+unit_triangle_wave (t)
+ double t;
+{
+ double twopi = 6.28318530717958;
double pi = twopi/2.;
double pi_half = pi/2.;
double three_pi_half = pi+pi_half;
double t_bar = ((double) fabs(fmod( ((double) t), twopi)));
-
- if (t_bar<pi_half) return(-(t_bar/pi));
- else if (t_bar<pi) return(t_bar/pi);
- else if (t_bar<three_pi_half) return((twopi-t_bar)/pi);
- else return (-((twopi-t_bar)/pi));
+ if (t_bar<pi_half)
+ return (-(t_bar/pi));
+ else if (t_bar<pi)
+ return (t_bar/pi);
+ else if (t_bar<three_pi_half)
+ return ((twopi-t_bar)/pi);
+ else
+ return (-((twopi-t_bar)/pi));
}
-
-
+\f
DEFINE_PRIMITIVE ("ARRAY-HANNING!", Prim_array_hanning, 2,2, 0)
-{ long n, hanning_power;
+{
+ long n, hanning_power;
REAL *a;
void C_Array_Make_Hanning();
-
PRIMITIVE_HEADER (2);
CHECK_ARG (1, ARRAY_P); /* input array -- n */
CHECK_ARG (2, FIXNUM_P); /* hanning power */
-
- a = Scheme_Array_To_C_Array(ARG_REF(1));
- n = Array_Length(ARG_REF(1));
+ a = ARRAY_CONTENTS(ARG_REF(1));
+ n = ARRAY_LENGTH(ARG_REF(1));
hanning_power = arg_nonnegative_integer(2);
-
- C_Array_Make_Hanning( a, n, hanning_power);
- PRIMITIVE_RETURN (NIL);
+ C_Array_Make_Hanning (a, n, hanning_power);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-void C_Array_Make_Hanning(f1, length, power)
- REAL f1[]; long length, power;
-{ double window_length;
+
+void
+C_Array_Make_Hanning (f1, length, power)
+ REAL f1[];
+ long length, power;
+{
+ double window_length;
long i;
double integer_power(), hanning();
window_length = ((double) length);
for (i=0;i<length;i++)
- { f1[i] = ((REAL)
- hanning(((double) i), window_length));
- f1[i] = (REAL) integer_power(((double) f1[i]), power); }
+ {
+ f1[i] = ((REAL) hanning(((double) i), window_length));
+ f1[i] = (REAL) integer_power(((double) f1[i]), power);
+ }
}
-double hanning(t, length) double t, length;
-{ double twopi = 6.283185307179586476925287;
+
+double
+hanning (t, length)
+ double t, length;
+{
+ double twopi = 6.283185307179586476925287;
double t_bar;
t_bar = cos(twopi * (t / length));
- if ((t<length) && (t>0.0)) return(.5 * (1 - t_bar));
- else return (0.0);
+ if ((t<length) && (t>0.0))
+ return(.5 * (1 - t_bar));
+ else
+ return (0.0);
}
-double integer_power(a, n) double a; long n;
-{ double b;
+
+double
+integer_power (a, n)
+ double a;
+ long n;
+{
+ double b;
double integer_power();
if (n<0) exit(-1);
else if (n==0) return(1.0);
else if (n==1) return(a);
else if ((n%2) == 0)
- { b = integer_power(a, n/2);
- return(b*b); }
+ {
+ b = integer_power(a, n/2);
+ return(b*b);
+ }
else
- { return(a * integer_power(a, (n-1))); }
+ return(a * integer_power(a, (n-1)));
}
-
+\f
/* array-operation-1!
- groups together procedures that use 1 array
- and store the result in place
- (e.g. random)
- */
+ groups together procedures that use 1 array
+ and store the result in place (e.g. random) */
-DEFINE_PRIMITIVE ("ARRAY-OPERATION-1!",
- Prim_array_operation_1, 2,2, 0)
-{ long n, opcode;
+DEFINE_PRIMITIVE ("ARRAY-OPERATION-1!", Prim_array_operation_1, 2,2, 0)
+{
+ long n, opcode;
REAL *a;
void array_random();
-
PRIMITIVE_HEADER (2);
CHECK_ARG (1, FIXNUM_P); /* operation opcode */
CHECK_ARG (2, ARRAY_P); /* input array -- n */
-
- n = Array_Length(ARG_REF(2));
- a = Scheme_Array_To_C_Array(ARG_REF(2));
-
+ n = ARRAY_LENGTH(ARG_REF(2));
+ a = ARRAY_CONTENTS(ARG_REF(2));
opcode = arg_nonnegative_integer(1);
-
if (opcode==1)
- array_random(a,n);
+ array_random(a,n);
else if (opcode==2)
error_bad_range_arg(1); /* illegal opcode */
else
error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-void array_random(a,n)
- REAL *a; long n;
-{ long i;
+void
+array_random (a,n)
+ REAL *a;
+ long n;
+{
+ long i;
/* HPUX 3: Rand uses a multiplicative congruential random-number generator
- with period 2^32 that returns successive pseudo-random numbers in the
+ with period 2^32 that returns successive pseudo-random numbers in the
range from 0 to 2^15-1 */
for (i=0;i<n;i++)
- a[i] = ((REAL) rand()) * (3.0517578125e-5); /* 3.051xxx = 2^(-15)
- makes the range from 0 to 1 */
+ a[i] = ((REAL) rand()) * (3.0517578125e-5);
+ /* 3.051xxx = 2^(-15) makes the range from 0 to 1 */
}
-
-
-/* The following should go away.
- superceded by ARRAY-CONS-INTEGERS, ARRAY-UNARY-FUNCTION and array-random
- */
+\f
+/* The following should go away.
+ superceded by ARRAY-CONS-INTEGERS, ARRAY-UNARY-FUNCTION and array-random */
DEFINE_PRIMITIVE ("SAMPLE-APERIODIC-FUNCTION", Prim_sample_aperiodic_function, 3, 3, 0)
-{ long N, i, allocated_cells, Function_Number;
+{
+ long N, i, Function_Number;
double Sampling_Frequency, DT, DTi;
double twopi = 6.28318530717958;
- Pointer Result;
- int errcode;
+ SCHEME_OBJECT Result;
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);
-
- errcode = Scheme_Number_To_Double(Arg2, &Sampling_Frequency);
- if (errcode == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (errcode == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- if (Sampling_Frequency == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- Range_Check(N, Arg3, 0, ARRAY_MAX_LENGTH, ERR_ARG_3_BAD_RANGE);
-
- Allocate_Array(Result, N, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
-
+ PRIMITIVE_HEADER (3);
+ Function_Number = (arg_index_integer (1, 7));
+ Sampling_Frequency = (arg_real_number (2));
+ if (Sampling_Frequency == 0)
+ error_bad_range_arg (2);
+ N = (arg_nonnegative_integer (3));
+ Result = (allocate_array (N));
+ To_Here = ARRAY_CONTENTS(Result);
DT = (twopi * (1 / Sampling_Frequency));
if (Function_Number == 0)
/* HPUX 3: Rand uses a multiplicative congruential random-number generator
- with period 2^32 that returns successive pseudo-random numbers in the
+ with period 2^32 that returns successive pseudo-random numbers in the
range from 0 to 2^15-1 */
for (i=0; i<N; i++)
- *To_Here++ = 3.0517578125e-5 * ((REAL) rand()); /* 2^(-15) makes range from 0 to 1 */
+ /* 2^(-15) makes range from 0 to 1 */
+ *To_Here++ = 3.0517578125e-5 * ((REAL) rand());
else if (Function_Number == 1)
{ double length=DT*N;
for (i=0, DTi=0.0; i < N; i++, DTi += DT)
*To_Here++ = (REAL) hanning(DTi, length);
}
- else if (Function_Number == 2)
+ else if (Function_Number == 2)
{ double length=DT*N;
for (i=0, DTi=0.0; i < N; i++, DTi += DT)
*To_Here++ = (REAL) hamming(DTi, length);
for (i=0, DTi=0.0; i < N; i++, DTi += DT)
*To_Here++ = (REAL) exp(DTi);
else
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
-
- return Result;
+ error_bad_range_arg (1);
+ PRIMITIVE_RETURN (Result);
}
-
+\f
DEFINE_PRIMITIVE ("ARRAY-PERIODIC-DOWNSAMPLE", Prim_array_periodic_downsample, 2, 2, 0)
-{ long Length, Pseudo_Length, Sampling_Ratio;
+{
+ 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);
-
+ SCHEME_OBJECT Result;
+ long i, array_index;
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, ARRAY_P);
+ Length = ARRAY_LENGTH(ARG_REF (1));
+ Sampling_Ratio = ((arg_integer (2)) % Length);
+ if (Sampling_Ratio < 1)
+ error_bad_range_arg (2);
+ Array = ARRAY_CONTENTS(ARG_REF (1));
+ Result = (allocate_array (Length));
+ To_Here = ARRAY_CONTENTS(Result);
Pseudo_Length = Length * Sampling_Ratio;
- for (i=0; i<Pseudo_Length; i += Sampling_Ratio) /* new Array has the same Length by assuming periodicity */
+ /* new Array has the same Length by assuming periodicity */
+ for (i=0; i<Pseudo_Length; i += Sampling_Ratio)
{ array_index = i % Length;
*To_Here++ = Array[array_index]; }
- return Result;
+ PRIMITIVE_RETURN (Result);
}
-/* Shift is not done in place (no side-effects).
- */
+/* Shift is not done in place (no side-effects). */
DEFINE_PRIMITIVE ("ARRAY-PERIODIC-SHIFT", Prim_array_periodic_shift, 2, 2, 0)
-{ long Length, Shift;
+{
+ long Length, Shift;
REAL *Array, *To_Here;
- Pointer Result;
- long allocated_cells, i, array_index;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Length = Array_Length(Arg1);
- Sign_Extend(Arg2, Shift);
- Shift = Shift % Length; /* periodic waveform, same sign as dividend */
- Array = Scheme_Array_To_C_Array(Arg1);
- Allocate_Array(Result, Length, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i<Length; i++) { /* new Array has the same Length by assuming periodicity */
+ SCHEME_OBJECT Result;
+ long i, array_index;
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, ARRAY_P);
+ Length = ARRAY_LENGTH(ARG_REF (1));
+ /* periodic waveform, same sign as dividend */
+ Shift = ((arg_integer (2)) % Length);
+ Array = ARRAY_CONTENTS(ARG_REF (1));
+ Result = (allocate_array (Length));
+ To_Here = ARRAY_CONTENTS(Result);
+ /* new Array has the same Length by assuming periodicity */
+ for (i=0; i<Length; i++) {
array_index = (i+Shift) % Length;
if (array_index<0) array_index = Length + array_index; /* wrap around */
*To_Here++ = Array[array_index]; }
- return Result;
+ PRIMITIVE_RETURN (Result);
}
/* This is done here because array-map is very slow */
DEFINE_PRIMITIVE ("ARRAY-APERIODIC-DOWNSAMPLE", Prim_array_aperiodic_downsample, 2, 2, 0)
-{ long Length, New_Length, Sampling_Ratio;
+{
+ long Length, New_Length, Sampling_Ratio;
REAL *Array, *To_Here;
- Pointer Result;
- long allocated_cells, i, array_index;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Array = Scheme_Array_To_C_Array(Arg1);
- Length = Array_Length(Arg1);
- Range_Check(Sampling_Ratio, Arg2, 1, Length, ERR_ARG_2_BAD_RANGE);
- if (Length < 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- New_Length = 1 + ((Length-1)/Sampling_Ratio); /* 1 for first one and then the rest --- integer division chops */
- Allocate_Array(Result, New_Length, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
-
+ SCHEME_OBJECT Result;
+ long i, array_index;
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, ARRAY_P);
+ Array = ARRAY_CONTENTS(ARG_REF (1));
+ Length = ARRAY_LENGTH(ARG_REF (1));
+ Sampling_Ratio = (arg_integer_in_range (2, 1, (Length + 1)));
+ if (Length < 1) error_bad_range_arg (1);
+ /* 1 for first one and then the rest --- integer division chops */
+ New_Length = 1 + ((Length-1)/Sampling_Ratio);
+ Result = (allocate_array (New_Length));
+ To_Here = ARRAY_CONTENTS(Result);
for (i=0; i<Length; i += Sampling_Ratio)
*To_Here++ = Array[i];
- return Result;
-}
-/* ARRAY-APERIODIC-SHIFT can be done in scheme using subarray, and array-append */
-/* UPSAMPLING should be done in scheme */
-
-/* END ARRAY PROCESSING */
-
-/*********** CONVERSION BETWEEN ARRAYS,VECTORS ********************/
-
-Pointer Scheme_Array_To_Scheme_Vector(Scheme_Array) Pointer Scheme_Array;
-{ REAL *Array;
- long Length;
- Pointer C_Array_To_Scheme_Vector();
-
- Length = Array_Length(Scheme_Array);
- Array = Scheme_Array_To_C_Array(Scheme_Array);
- return C_Array_To_Scheme_Vector(Array, Length);
-}
-
-/* C_ARRAY */
-\f
-Pointer C_Array_To_Scheme_Array(Array, Length) REAL *Array; long Length;
-{ Pointer Result;
- long allocated_cells;
- Allocate_Array(Result, Length, allocated_cells);
- return Result;
-}
-\f
-Pointer C_Array_To_Scheme_Vector(Array, Length) REAL *Array; long Length;
-{ Pointer Result;
- Pointer *Now_Free;
- long i;
-
- Primitive_GC_If_Needed(Length+1 + Length*(FLONUM_SIZE+1));
- Now_Free = (Pointer *) Free;
- Free = Free + Length + 1; /* INCREMENT BEFORE ALLOCATING FLONUMS ! */
-
- Result = Make_Pointer(TC_VECTOR, Now_Free);
- *Now_Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Length);
-
- for (i=0; i<Length; i++) {
- Store_Reduced_Flonum_Result( Array[i], *Now_Free);
- Now_Free++;
- }
- return Result;
-}
-
-\f
-/* SCHEME_VECTOR */
-
-Pointer Scheme_Vector_To_Scheme_Array(Arg1) Pointer Arg1;
-{ Pointer Result;
- long Length, allocated_cells;
- REAL *Array;
-
- Length = Vector_Length(Arg1);
- Allocate_Array(Result, Length, allocated_cells);
- Array = Scheme_Array_To_C_Array(Result);
-
- Scheme_Vector_To_C_Array(Arg1, Array);
- return Result;
-}
-
-\f
-void Scheme_Vector_To_C_Array(Scheme_Vector, Array)
- Pointer Scheme_Vector; REAL *Array;
-{ Pointer *From_Here;
- REAL *To_Here;
- long Length, i;
- int errcode;
-
- From_Here = Nth_Vector_Loc(Scheme_Vector, VECTOR_DATA);
- To_Here = Array;
- Length = Vector_Length(Scheme_Vector);
- for (i=0; i < Length; i++, From_Here++) {
- errcode = Scheme_Number_To_REAL(*From_Here, To_Here);
- if (errcode == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- if (errcode == 2) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- To_Here++; /* this gets incremented by REAL_SIZE ! */
- }
+ PRIMITIVE_RETURN (Result);
}
-
-/* END of ARRAY PROCESSING */
\f
/* one more hack for speed */
-/* (SOLVE-SYSTEM A B N)
- Solves the system of equations Ax = b. A and B are
+/* (SOLVE-SYSTEM A B N)
+ Solves the system of equations Ax = b. A and B are
arrays and b is the order of the system. Returns x.
- From the Fortran procedure in Strang.
-*/
+ From the Fortran procedure in Strang. */
DEFINE_PRIMITIVE ("SOLVE-SYSTEM", Prim_gaussian_elimination, 2, 2, 0)
-{ REAL *A, *B, *X;
- long Length, allocated_cells;
- Pointer Result;
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_ARRAY);
- Length = Array_Length(Arg2);
- if ((Length*Length) != Array_Length(Arg1)) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- A = Scheme_Array_To_C_Array(Arg1);
- B = Scheme_Array_To_C_Array(Arg2);
- Allocate_Array(Result, Length, allocated_cells);
- X = Scheme_Array_To_C_Array(Result);
+{
+ REAL *A, *B, *X;
+ long Length;
+ SCHEME_OBJECT Result;
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, ARRAY_P);
+ CHECK_ARG (2, ARRAY_P);
+ Length = ARRAY_LENGTH(ARG_REF (2));
+ if ((Length*Length) != ARRAY_LENGTH(ARG_REF (1))) error_bad_range_arg (2);
+ A = ARRAY_CONTENTS(ARG_REF (1));
+ B = ARRAY_CONTENTS(ARG_REF (2));
+ Result = (allocate_array (Length));
+ X = ARRAY_CONTENTS(Result);
C_Array_Copy(B, X, Length);
C_Gaussian_Elimination(A, X, Length);
- return Result;
+ PRIMITIVE_RETURN (Result);
}
-/*
- C routine side-effects b.
-*/
-C_Gaussian_Elimination(a, b, n)
-REAL *a, *b;
-long n;
-{ long *pvt;
+/* C routine side-effects b. */
+C_Gaussian_Elimination (a, b, n)
+ REAL *a, *b;
+ long n;
+{
+ long *pvt;
REAL p, t;
- long i, j, k, m;
- Primitive_GC_If_Needed(n);
+ long i, j, k, m;
+ Primitive_GC_If_Needed (n);
pvt = ((long *) Free);
*(pvt+n-1) = 1;
if (n != 1) {
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)
+ 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;
}
k = n - j + 1;
*(b+k-1) = *(b+k-1) / *(a+k+(k-1)*n-1);
t = - *(b+k-1);
- for (i=1; i <= n-j; i++)
+ for (i=1; i <= n-j; i++)
*(b+i-1) = *(b+i-1) + *(a+i+(k-1)*n-1) * t;
}
}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/array.h,v 9.31 1989/09/20 23:05:33 cph Rel $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
Technology nor of any adaptation thereof in any advertising,
promotional, or sales literature without prior written consent from
MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/array.h,v 9.30 1989/06/22 21:51:57 pas Rel $ */
\f
-
-#define REAL float
#define REAL_IS_DEFINED_DOUBLE 0
-/*
- When REAL is float, set = 0
- When REAL is double, set = 1
- This is used by #ifdef in some places like "fscanf"
- */
-
-#define REAL_SIZE ((sizeof(Pointer)+sizeof(REAL)-1)/ sizeof(Pointer))
-/* Scheme_Arrays are implemented as NON_MARKED_VECTOR
- Do not forget to include object.h */
-
-#define ARRAY_P NON_MARKED_VECTOR_P
-/* This is used in places like "CHECK_ARG(1, ARRAY_P)" */
-
-#define TC_ARRAY TC_NON_MARKED_VECTOR
-#define TC_MANIFEST_ARRAY TC_MANIFEST_NM_VECTOR
-#define ARRAY_HEADER 0 /* NM_VECTOR_HEADER */
-/* Contains the number of actual cells (words) allocated, used in gc */
-#define ARRAY_LENGTH 1 /* NM_ENTRY_COUNT */
-#define ARRAY_DATA 2 /* NM_DATA */
-#define ARRAY_HEADER_SIZE 2
+#if (REAL_IS_DEFINED_DOUBLE == 0)
+#define REAL float
+#else
+#define REAL double
+#endif
-#define SCHEME_ARRAY Pointer
-/* C type for a scheme array
- */
+#define arg_real(arg_number) ((REAL) (arg_real_number (arg_number)))
+#define REAL_SIZE (BYTES_TO_WORDS (sizeof (REAL)))
-#define Array_Ref(P,N) ((Get_Pointer(P))[N+2])
+#define FLOAT_SIZE (BYTES_TO_WORDS (sizeof (float)))
+#define DOUBLE_SIZE (BYTES_TO_WORDS (sizeof (double)))
-#define Nth_Array_Loc(P,N) (Scheme_Array_To_C_Array(P) + N)
+/* Scheme_Arrays are implemented as NON_MARKED_VECTOR. */
-#define Scheme_Array_To_C_Array(Scheme_Array) \
- ((REAL *) Nth_Vector_Loc(Scheme_Array, ARRAY_DATA))
+#define ARRAY_P NON_MARKED_VECTOR_P
+#define ARRAY_LENGTH(array) ((long) (FAST_MEMORY_REF ((array), 1)))
+#define ARRAY_CONTENTS(array) ((REAL *) (MEMORY_LOC (array, 2)))
-#define Array_Length(Scheme_Array) \
- ((long) Vector_Ref(Scheme_Array, ARRAY_LENGTH))
+extern SCHEME_OBJECT allocate_array ();
-#define Allocate_Array(result, Length, allocated_cells) \
-{ allocated_cells = (Length*REAL_SIZE) + ARRAY_HEADER_SIZE; \
- Primitive_GC_If_Needed(allocated_cells); \
- result = Make_Pointer(TC_ARRAY, Free); \
- Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1); \
- Free[ARRAY_LENGTH] = Length; \
- Free = Free+allocated_cells; }
+extern void C_Array_Find_Min_Max ();
+extern void C_Array_Complex_Multiply_Into_First_One ();
-#define ARRAY_MAX_LENGTH 1000000
-/* This is 4 Mbytes for what it's worth... */
+extern void C_Array_Make_Histogram ();
+/* REAL * Array;
+ REAL * Histogram;
+ long Length;
+ long npoints; */
+extern void Find_Offset_Scale_For_Linear_Map();
+/* REAL Min;
+ REAL Max;
+ REAL New_Min;
+ REAL New_Max;
+ REAL * Offset;
+ REAL * Scale; */
+\f
/* The following macros implement commonly used array procs. */
-/* In the following macros we assign the arguments to local variables
+/* In the following macros we assign the arguments to local variables
so as to do any computation (referencing, etc.) only once outside the loop.
- Otherwise it would be done again and again inside the loop -- look at "cc -v -S -O" to see the difference
- */
-/* The names, like "MCRINDX", have been chosen to avoid shadowing the variables that are substituted in.
- WARNING: Do not use any names starting with the prefix "mcr", when calling these macros
- */
-
-#define C_Array_Scale(a,scale, N) \
-{ register long mcrindx; \
- register REAL mcrd0, *mcrfrom; \
- mcrd0 = scale; \
- mcrfrom = a; \
- for (mcrindx=0; mcrindx<N; mcrindx++) mcrfrom[mcrindx] = mcrfrom[mcrindx] * mcrd0; }
-#define Array_Scale(ar,scale) \
- C_Array_Scale(Scheme_Array_To_C_Array(ar), scale, Array_Length(ar))
-
-#define C_Array_Copy(from,to,N) \
-{ register long mcrindx; \
- register REAL *mcrfrom, *mcrto; \
- mcrfrom = from; \
- mcrto = to; \
- for (mcrindx=0; mcrindx<N; mcrindx++) mcrto[mcrindx] = mcrfrom[mcrindx]; }
-#define Array_Copy(ar1,ar2) \
- C_Array_Copy(Scheme_Array_To_C_Array(ar1), Scheme_Array_To_C_Array(ar2), Array_Length(ar1))
-
-#define C_Array_Add_Into_Second_One(from,to,N) \
-{ register long mcrindx; \
- register REAL *mcrfrom, *mcrto; \
- mcrfrom = from; \
- mcrto = to; \
- for (mcrindx=0; mcrindx<N; mcrindx++) mcrto[mcrindx] = mcrto[mcrindx] + mcrfrom[mcrindx]; }
-#define Array_Add_Into_Second_One(ar1,ar2) \
- C_Array_Add_Into_Second_One(Scheme_Array_To_C_Array(ar1), Scheme_Array_To_C_Array(ar2), Array_Length(ar1))
-
-/* More Macros about random things
- */
-
-#define Make_List_From_3_Pointers(pointer1, pointer2, pointer3, Result) \
-{ Primitive_GC_If_Needed(6); \
- Result = Make_Pointer(TC_LIST, Free); \
- *Free++ = pointer1; \
- *Free++ = Make_Pointer(TC_LIST, Free+1); \
- *Free++ = pointer2; \
- *Free++ = Make_Pointer(TC_LIST, Free+1); \
- *Free++ = pointer3; \
- *Free++ = EMPTY_LIST; }
-
-#define Float_Range_Check(variable, Scheme_Pointer, Low, High, Error_Message) \
-{ REAL value; \
- int err; \
- err = Scheme_Number_To_REAL(Scheme_Pointer, &value); \
- if ((err == 1) || (err == 2)) Primitive_Error(Error_Message); \
- if ((value<Low) || (value>High)) Primitive_Error(Error_Message); \
- variable = ((float) value); }
-
-#define REAL_Range_Check(variable, Scheme_Pointer, Low, High, Error_Message) \
-{ REAL value; \
- int err; \
- err = Scheme_Number_To_REAL(Scheme_Pointer, &value); \
- if ((err == 1) || (err == 2)) Primitive_Error(Error_Message); \
- if ((value<Low) || (value>High)) Primitive_Error(Error_Message); \
- else variable = value; }
-
-#define C_Make_Polar(Real, Imag, Mag_Cell, Phase_Cell) \
-{ double double_Real=((double) Real), double_Imag=((double) Imag); \
- Mag_Cell = (REAL) sqrt((double_Real*double_Real)+(double_Imag*double_Imag)); \
- if (Mag_Cell==0.0) \
- Phase_Cell = 0.0; \
- else \
- Phase_Cell = (REAL) atan2(double_Imag, double_Real); \
+ Otherwise it would be done again and again inside the loop.
+ The names, like "MCRINDX", have been chosen to avoid shadowing the
+ variables that are substituted in. WARNING: Do not use any names
+ starting with the prefix "mcr", when calling these macros */
+
+#define C_Array_Scale(array, scale, n) \
+{ \
+ fast REAL * mcr_scan = (array); \
+ fast REAL * mcr_end = (mcr_scan + (n)); \
+ fast REAL mcrd0 = (scale); \
+ while (mcr_scan < mcr_end) \
+ (*mcr_scan++) *= mcrd0; \
}
-/* Undefined angle at (0,0) ---- Choose value 0.0 */
+#define Array_Scale(array, scale) \
+{ \
+ C_Array_Scale \
+ ((ARRAY_CONTENTS (array)), \
+ (scale), \
+ (ARRAY_LENGTH (array))); \
+}
-#define Linear_Map(slope,offset,From,To) { (To) = (((slope)*(From))+offset); }
-
-#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_Find_Min_Max();
-extern void C_Array_Make_Histogram(); /* REAL *Array,*Histogram; long Length,npoints */
-extern void C_Array_Complex_Multiply_Into_First_One();
+#define C_Array_Copy(from, to, n) \
+{ \
+ fast REAL * mcr_scan_source = (from); \
+ fast REAL * mcr_end_source = (mcr_scan_source + (n)); \
+ fast REAL * mcr_scan_target = (to); \
+ while (mcr_scan_source < mcr_end_source) \
+ (*mcr_scan_target++) = (*mcr_scan_source++); \
+}
-/* 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);
- */
+#define Array_Copy(from, to) \
+{ \
+ C_Array_Copy \
+ ((ARRAY_CONTENTS (from)), \
+ (ARRAY_CONTENTS (to)), \
+ (ARRAY_LENGTH (from))); \
+}
-extern Pointer Scheme_Vector_To_Scheme_Array();
-extern Pointer Scheme_Array_To_Scheme_Vector();
+#define C_Array_Add_Into_Second_One(from, to, n) \
+{ \
+ fast REAL * mcr_scan_source = (from); \
+ fast REAL * mcr_end_source = (mcr_scan_source + (n)); \
+ fast REAL * mcr_scan_target = (to); \
+ while (mcr_scan_source < mcr_end_source) \
+ (*mcr_scan_target++) += (*mcr_scan_source++); \
+}
-extern Pointer C_Array_To_Scheme_Vector();
-extern void Scheme_Vector_To_C_Array();
-/* Pointer Scheme_Vector; REAL *Array;
- */
+#define Array_Add_Into_Second_One(from,to) \
+{ \
+ C_Array_Add_Into_Second_One \
+ ((ARRAY_CONTENTS (from)), \
+ (ARRAY_CONTENTS (to)), \
+ (ARRAY_LENGTH (from))); \
+}
-/* From bob-xt.c */
-extern void Find_Offset_Scale_For_Linear_Map();
-/* REAL Min,Max, New_Min,New_Max, *Offset,*Scale;
- */
+#define mabs(x) (((x) < 0) ? (- (x)) : (x))
+#define max(x,y) (((x) < (y)) ? (y) : (x))
+#define min(x,y) (((x) < (y)) ? (x) : (y))
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.45 1989/09/20 23:05:37 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.44 1989/06/08 00:19:08 jinx Rel $ */
-
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
- and related utilities to disk.
-*/
+ and related utilities to disk. */
#include "scheme.h"
#include "prims.h"
#include "error: bchdmp does not handle floating alignment."
#endif
-extern Pointer
+extern SCHEME_OBJECT
dump_renumber_primitive(),
*initialize_primitive_table(),
*cons_primitive_table(),
static char *dump_file_name;
static int real_gc_file, dump_file;
-static Pointer *saved_free;
-static Pointer fixup_buffer[GC_DISK_BUFFER_SIZE];
-static Pointer *fixup_buffer_end = &fixup_buffer[GC_DISK_BUFFER_SIZE];
-static Pointer *fixup;
+static SCHEME_OBJECT *saved_free;
+static SCHEME_OBJECT fixup_buffer[GC_DISK_BUFFER_SIZE];
+static SCHEME_OBJECT *fixup_buffer_end = &fixup_buffer[GC_DISK_BUFFER_SIZE];
+static SCHEME_OBJECT *fixup;
static fixup_count = 0;
static Boolean compiled_code_present_p;
\f
return (PRIM_INTERRUPT); \
} \
*--fixup = contents; \
- *--fixup = ((Pointer) location); \
+ *--fixup = ((SCHEME_OBJECT) location); \
}
#define fasdump_normal_setup() \
{ \
- Old = Get_Pointer(Temp); \
- if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART) \
+ Old = OBJECT_ADDRESS (Temp); \
+ if (OBJECT_TYPE (*Old) == TC_BROKEN_HEART) \
{ \
- *Scan = Make_New_Pointer(OBJECT_TYPE(Temp), *Old); \
+ *Scan = (MAKE_OBJECT_FROM_OBJECTS (Temp, *Old)); \
continue; \
} \
- New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
+ New_Address = (MAKE_BROKEN_HEART (To_Address)); \
fasdump_remember_to_fix(Old, *Old); \
}
#define fasdump_normal_end() \
{ \
- *Get_Pointer(Temp) = New_Address; \
- *Scan = Make_New_Pointer(OBJECT_TYPE(Temp), New_Address); \
+ *OBJECT_ADDRESS (Temp) = New_Address; \
+ *Scan = (MAKE_OBJECT_FROM_OBJECTS (Temp, New_Address)); \
continue; \
}
\f
#define fasdump_typeless_setup() \
{ \
- Old = ((Pointer *) Temp); \
- if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART) \
+ Old = ((SCHEME_OBJECT *) Temp); \
+ if (OBJECT_TYPE (*Old) == TC_BROKEN_HEART) \
{ \
- *Scan = ((Pointer) Get_Pointer(*Old)); \
+ *Scan = ((SCHEME_OBJECT) OBJECT_ADDRESS (*Old)); \
continue; \
} \
- New_Address = ((Pointer) To_Address); \
+ New_Address = ((SCHEME_OBJECT) To_Address); \
fasdump_remember_to_fix(Old, *Old); \
}
#define fasdump_typeless_end() \
{ \
- *Get_Pointer(Temp) = Make_Broken_Heart(C_To_Scheme(New_Address)); \
- *Scan = ((Pointer) New_Address); \
+ (* (OBJECT_ADDRESS (Temp))) = (MAKE_BROKEN_HEART (New_Address)); \
+ *Scan = ((SCHEME_OBJECT) New_Address); \
continue; \
}
#define fasdump_compiled_entry() \
{ \
compiled_code_present_p = true; \
- Old = Get_Pointer(Temp); \
+ Old = OBJECT_ADDRESS (Temp); \
Compiled_BH(false, continue); \
{ \
- Pointer *Saved_Old = Old; \
+ SCHEME_OBJECT *Saved_Old = Old; \
\
fasdump_remember_to_fix(Old, *Old); \
- New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
+ New_Address = (MAKE_BROKEN_HEART (To_Address)); \
copy_vector(&success); \
if (!success) \
{ \
return (PRIM_INTERRUPT); \
} \
*Saved_Old = New_Address; \
- *Scan = Relocate_Compiled(Temp, Get_Pointer(New_Address), \
+ *Scan = Relocate_Compiled(Temp, OBJECT_ADDRESS (New_Address), \
Saved_Old); \
continue; \
} \
fasdump_exit(length)
long length;
{
- fast Pointer *fixes, *fix_address;
+ fast SCHEME_OBJECT *fixes, *fix_address;
Boolean result;
Free = saved_free;
unlink(dump_file_name);
}
dump_file_name = ((char *) NULL);
-
+
fixes = fixup;
\f
next_buffer:
while (fixes != fixup_buffer_end)
{
- fix_address = ((Pointer *) (*fixes++)); /* Where it goes. */
+ fix_address = ((SCHEME_OBJECT *) (*fixes++)); /* Where it goes. */
*fix_address = *fixes++; /* Put it there. */
}
-
+
if (fixup_count >= 0)
{
if ((lseek(real_gc_file, (fixup_count * GC_BUFFER_BYTES), 0) == -1) ||
fixes = fixup_buffer;
goto next_buffer;
}
-
+
fixup = fixes;
Fasdump_Exit_Hook();
return (result);
long
dumploop(Scan, To_ptr, To_Address_ptr)
- fast Pointer *Scan;
- Pointer **To_ptr, **To_Address_ptr;
+ fast SCHEME_OBJECT *Scan;
+ SCHEME_OBJECT **To_ptr, **To_Address_ptr;
{
- fast Pointer *To, *Old, Temp, *To_Address, New_Address;
+ fast SCHEME_OBJECT *To, *Old, Temp, *To_Address, New_Address;
Boolean success;
success = true;
Switch_by_GC_Type(Temp)
{
case TC_BROKEN_HEART:
- if (OBJECT_DATUM(Temp) == 0)
+ if (OBJECT_DATUM (Temp) == 0)
{
break;
}
- if (Scan != (Get_Pointer(Temp)))
+ if (Scan != (OBJECT_ADDRESS (Temp)))
{
sprintf(gc_death_message_buffer,
"purifyloop: broken heart (0x%lx) in scan",
case TC_MANIFEST_SPECIAL_NM_VECTOR:
/* Check whether this bumps over current buffer,
and if so we need a new bufferfull. */
- Scan += Get_Integer(Temp);
+ Scan += OBJECT_DATUM (Temp);
if (Scan < scan_buffer_top)
{
break;
Scan += 1;
start_ptr = FIRST_MANIFEST_CLOSURE_ENTRY(Scan);
-
+
for (word_ptr = start_ptr,
next_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
true;
fasdump_normal_pointer(copy_cell(), 1);
case TC_REFERENCE_TRAP:
- if (OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE)
+ if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
{
/* It is a non pointer. */
break;
{
fasdump_normal_setup();
*To++ = *Old;
- *To++ = Make_Broken_Heart(0);
+ *To++ = BROKEN_HEART_ZERO;
fasdump_transport_end(2);
fasdump_normal_end();
}
{
Boolean success;
long value, length, hlength, tlength, tsize;
- Pointer *dumped_object, *free_buffer;
- Pointer *table_start, *table_end, *table_top;
- Pointer header[FASL_HEADER_LENGTH];
- Primitive_3_Args();
-
- CHECK_ARG (2, STRING_P);
- dump_file_name = Scheme_String_To_C_String(Arg2);
-
- dump_file = open(dump_file_name, GC_FILE_FLAGS, 0666);
+ SCHEME_OBJECT *dumped_object, *free_buffer;
+ SCHEME_OBJECT *table_start, *table_end, *table_top;
+ SCHEME_OBJECT header[FASL_HEADER_LENGTH];
+ PRIMITIVE_HEADER (3);
+ dump_file_name = (STRING_ARG (2));
+ dump_file = (open (dump_file_name, GC_FILE_FLAGS, 0666));
if (dump_file < 0)
- {
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- }
+ error_bad_range_arg (2);
compiled_code_present_p = false;
success = true;
#endif
free_buffer = initialize_free_buffer();
- Free = ((Pointer *) NULL);
+ Free = ((SCHEME_OBJECT *) NULL);
free_buffer += FASL_HEADER_LENGTH;
- *free_buffer++ = Arg1;
+ *free_buffer++ = (ARG_REF (1));
dumped_object = Free;
Free += 1;
}
else
{
- Primitive_Error(value);
+ signal_error_from_primitive (value);
}
}
end_transport(&success);
}
tsize = (table_end - table_start);
- hlength = (sizeof(Pointer) * tsize);
+ hlength = (sizeof(SCHEME_OBJECT) * tsize);
if ((lseek(gc_file,
- (sizeof(Pointer) * (length + FASL_HEADER_LENGTH)),
+ (sizeof(SCHEME_OBJECT) * (length + FASL_HEADER_LENGTH)),
0) == -1) ||
(write(gc_file, ((char *) &table_start[0]), hlength) != hlength))
{
PRIMITIVE_RETURN (SHARP_F);
}
- hlength = (sizeof(Pointer) * FASL_HEADER_LENGTH);
+ hlength = (sizeof(SCHEME_OBJECT) * FASL_HEADER_LENGTH);
prepare_dump_header(header, dumped_object, length, dumped_object,
0, Constant_Space, tlength, tsize,
compiled_code_present_p, false);
fasdump_exit(0);
PRIMITIVE_RETURN (SHARP_F);
}
- PRIMITIVE_RETURN(fasdump_exit((sizeof(Pointer) *
+ PRIMITIVE_RETURN(fasdump_exit((sizeof(SCHEME_OBJECT) *
(length + tsize)) + hlength) ?
SHARP_T : SHARP_F);
}
DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0)
{
- extern Pointer compiler_utilities;
- Pointer Combination, *table_start, *table_end, *saved_free;
- long Arg1Type, table_length;
+ extern SCHEME_OBJECT compiler_utilities;
+ SCHEME_OBJECT Combination, *table_start, *table_end, *saved_free;
+ long table_length;
Boolean result;
- Primitive_2_Args();
-
- Band_Dump_Permitted();
- Arg1Type = OBJECT_TYPE(Arg1);
- if ((Arg1Type != TC_CONTROL_POINT) &&
- (Arg1Type != TC_EXTENDED_PROCEDURE) &&
- (Arg1Type != TC_PRIMITIVE))
- {
- 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);
- }
- Primitive_GC_If_Needed(5);
+ PRIMITIVE_HEADER (2);
+ Band_Dump_Permitted ();
+ CHECK_ARG (1, INTERPRETER_APPLICABLE_P);
+ CHECK_ARG (2, STRING_P);
+ if (! (Open_Dump_File ((ARG_REF (2)), WRITE_FLAG)))
+ error_bad_range_arg (2);
+ Primitive_GC_If_Needed (5);
saved_free = Free;
- Combination = Make_Pointer(TC_COMBINATION_1, Free);
- Free[COMB_1_FN] = Arg1;
+ Combination = MAKE_POINTER_OBJECT (TC_COMBINATION_1, Free);
+ Free[COMB_1_FN] = (ARG_REF (1));
Free[COMB_1_ARG_1] = SHARP_F;
Free += 2;
*Free++ = Combination;
*Free++ = compiler_utilities;
- *Free = Make_Pointer(TC_LIST, (Free - 2));
+ *Free = MAKE_POINTER_OBJECT (TC_LIST, (Free - 2));
Free++; /* Some compilers are TOO clever about this and increment Free
before calculating Free-2! */
table_start = Free;
{
#if false
/* Aligning here confuses some of the counts computed. */
- Align_Float(Free);
+ ALIGN_FLOAT (Free);
#endif
result = Write_File((Free - 1),
((long) (Free - Heap_Bottom)), Heap_Bottom,
Free = saved_free;
if (result)
{
- PRIMITIVE_RETURN(SHARP_T);
+ PRIMITIVE_RETURN (SHARP_T);
}
else
{
extern int unlink();
-
- unlink(Scheme_String_To_C_String(Arg2));
- PRIMITIVE_RETURN(SHARP_F);
+ unlink (STRING_LOC ((ARG_REF (2)), 0));
+ PRIMITIVE_RETURN (SHARP_F);
}
}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcc.h,v 9.34 1989/09/20 23:05:41 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcc.h,v 9.33 1988/08/15 20:36:07 cph Rel $ */
-
#include "gccode.h"
#ifdef bsd
#include <sys/file.h>
#include <fcntl.h>
#endif
\f
-/* All of these are in objects (Pointer), not bytes. */
+/* All of these are in objects (SCHEME_OBJECT), not bytes. */
#define GC_EXTRA_BUFFER_SIZE 512
#define GC_DISK_BUFFER_SIZE 1024
#define GC_BUFFER_SPACE (GC_DISK_BUFFER_SIZE + GC_EXTRA_BUFFER_SIZE)
-#define GC_BUFFER_BYTES (GC_DISK_BUFFER_SIZE * sizeof(Pointer))
-#define GC_BUFFER_OVERLAP_BYTES (GC_EXTRA_BUFFER_SIZE * sizeof(Pointer))
-#define GC_BUFFER_REMAINDER_BYTES (GC_BUFFER_BYTES - GC_BUFFER_OVERLAP_BYTES)
+#define GC_BUFFER_BYTES (GC_DISK_BUFFER_SIZE * sizeof(SCHEME_OBJECT))
+#define GC_BUFFER_OVERLAP_BYTES (GC_EXTRA_BUFFER_SIZE * sizeof(SCHEME_OBJECT))
+#define GC_BUFFER_REMAINDER_BYTES (GC_BUFFER_BYTES - GC_BUFFER_OVERLAP_BYTES)
#define GC_FILE_FLAGS (O_RDWR | O_CREAT) /* O_SYNCIO removed */
#define GC_FILE_MASK 0644 /* Everyone reads, owner writes */
#define GC_DEFAULT_FILE_NAME "/tmp/GCXXXXXX"
-extern Pointer *scan_buffer_top, *scan_buffer_bottom;
-extern Pointer *free_buffer_top, *free_buffer_bottom;
-extern Pointer *dump_and_reload_scan_buffer();
-extern Pointer *dump_and_reset_free_buffer();
+extern SCHEME_OBJECT *scan_buffer_top, *scan_buffer_bottom;
+extern SCHEME_OBJECT *free_buffer_top, *free_buffer_bottom;
+extern SCHEME_OBJECT *dump_and_reload_scan_buffer();
+extern SCHEME_OBJECT *dump_and_reset_free_buffer();
extern void dump_free_directly(), load_buffer();
extern void extend_scan_buffer();
extern char *end_scan_buffer_extension();
-extern Pointer *GCLoop();
-extern Pointer *initialize_free_buffer(), *initialize_scan_buffer();
+extern SCHEME_OBJECT *GCLoop();
+extern SCHEME_OBJECT *initialize_free_buffer(), *initialize_scan_buffer();
extern void end_transport(), GC();
extern int gc_file;
{ \
long Car_Type; \
\
- Car_Type = OBJECT_TYPE(*Old); \
- *To++ = Make_New_Pointer(TC_NULL, *Old); \
+ Car_Type = OBJECT_TYPE (*Old); \
+ *To++ = (OBJECT_NEW_TYPE (TC_NULL, *Old)); \
Old += 1; \
*To++ = *Old; \
- *Old = Make_New_Pointer(Car_Type, Weak_Chain); \
+ *Old = (OBJECT_NEW_TYPE (Car_Type, Weak_Chain)); \
Weak_Chain = Temp; \
}
#define copy_vector(success) \
{ \
- Pointer *Saved_Scan = Scan; \
- unsigned long real_length = 1 + Get_Integer(*Old); \
+ SCHEME_OBJECT *Saved_Scan = Scan; \
+ unsigned long real_length = 1 + OBJECT_DATUM (*Old); \
\
To_Address += real_length; \
Scan = To + real_length; \
#define relocate_normal_setup() \
{ \
- Old = Get_Pointer(Temp); \
+ Old = OBJECT_ADDRESS (Temp); \
if (Old >= Low_Constant) \
continue; \
- if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART) \
+ if (OBJECT_TYPE (*Old) == TC_BROKEN_HEART) \
{ \
- *Scan = Make_New_Pointer(OBJECT_TYPE(Temp), *Old); \
+ *Scan = (MAKE_OBJECT_FROM_OBJECTS (Temp, *Old)); \
continue; \
} \
- New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
+ New_Address = (MAKE_BROKEN_HEART (To_Address)); \
}
#define relocate_normal_transport(copy_code, length) \
#define relocate_normal_end() \
{ \
- *Get_Pointer(Temp) = New_Address; \
- *Scan = Make_New_Pointer(OBJECT_TYPE(Temp), New_Address); \
+ *OBJECT_ADDRESS (Temp) = New_Address; \
+ *Scan = (MAKE_OBJECT_FROM_OBJECTS (Temp, New_Address)); \
continue; \
}
#define relocate_typeless_setup() \
{ \
- Old = ((Pointer *) Temp); \
+ Old = ((SCHEME_OBJECT *) Temp); \
if (Old >= Low_Constant) \
continue; \
- if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART) \
+ if (OBJECT_TYPE (*Old) == TC_BROKEN_HEART) \
{ \
- *Scan = ((Pointer) Get_Pointer(*Old)); \
+ *Scan = ((SCHEME_OBJECT) OBJECT_ADDRESS (*Old)); \
continue; \
} \
- New_Address = ((Pointer) To_Address); \
+ New_Address = ((SCHEME_OBJECT) To_Address); \
}
#define relocate_typeless_transport(copy_code, length) \
#define relocate_typeless_end() \
{ \
- *((Pointer *) Temp) = Make_Broken_Heart(C_To_Scheme(New_Address)); \
+ (* ((SCHEME_OBJECT *) Temp)) = (MAKE_BROKEN_HEART (New_Address)); \
*Scan = New_Address; \
continue; \
}
\f
#define relocate_compiled_entry(in_gc_p) \
{ \
- Old = Get_Pointer(Temp); \
+ Old = OBJECT_ADDRESS (Temp); \
if (Old >= Low_Constant) \
continue; \
Compiled_BH(in_gc_p, continue); \
{ \
- Pointer *Saved_Old = Old; \
+ SCHEME_OBJECT *Saved_Old = Old; \
\
- New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
+ New_Address = (MAKE_BROKEN_HEART (To_Address)); \
copy_vector(NULL); \
*Saved_Old = New_Address; \
*Scan = Relocate_Compiled(Temp, \
- Get_Pointer(New_Address), \
+ OBJECT_ADDRESS (New_Address), \
Saved_Old); \
continue; \
} \
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcl.c,v 9.36 1989/09/20 23:05:45 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcl.c,v 9.35 1989/06/08 00:19:13 jinx Rel $ */
-
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
- and related utilities to disk.
-*/
+ and related utilities to disk. */
#include "scheme.h"
#include "bchgcc.h"
#include "error: bchgcl does not handle floating alignment."
#endif
\f
-Pointer *
+SCHEME_OBJECT *
GCLoop(Scan, To_ptr, To_Address_ptr)
- fast Pointer *Scan;
- Pointer **To_ptr, **To_Address_ptr;
+ fast SCHEME_OBJECT *Scan;
+ SCHEME_OBJECT **To_ptr, **To_Address_ptr;
{
- fast Pointer *To, *Old, Temp, *Low_Constant, *To_Address, New_Address;
+ fast SCHEME_OBJECT *To, *Old, Temp, *Low_Constant, *To_Address, New_Address;
To = *To_ptr;
To_Address = *To_Address_ptr;
Switch_by_GC_Type(Temp)
{
case TC_BROKEN_HEART:
- if (Scan != (Get_Pointer(Temp)))
+ if (Scan != (OBJECT_ADDRESS (Temp)))
{
sprintf(gc_death_message_buffer,
"gcloop: broken heart (0x%lx) in scan",
case TC_MANIFEST_SPECIAL_NM_VECTOR:
/* Check whether this bumps over current buffer,
and if so we need a new bufferfull. */
- Scan += Get_Integer(Temp);
+ Scan += OBJECT_DATUM (Temp);
if (Scan < scan_buffer_top)
{
break;
Scan += 1;
start_ptr = FIRST_MANIFEST_CLOSURE_ENTRY(Scan);
-
+
for (word_ptr = start_ptr,
next_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
true;
relocate_normal_pointer(copy_cell(), 1);
case TC_REFERENCE_TRAP:
- if (OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE)
+ if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
{
/* It is a non pointer. */
break;
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.48 1989/09/20 23:05:48 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Technology nor of any adaptation thereof in any advertising,
promotional, or sales literature without prior written consent from
MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.47 1989/08/28 18:28:15 cph Exp $ */
\f
/* Memory management top level. Garbage collection to disk.
/* Local declarations */
static long scan_position, free_position;
-static Pointer *gc_disk_buffer_1, *gc_disk_buffer_2;
-Pointer *scan_buffer_top, *scan_buffer_bottom;
-Pointer *free_buffer_top, *free_buffer_bottom;
+static SCHEME_OBJECT *gc_disk_buffer_1, *gc_disk_buffer_2;
+SCHEME_OBJECT *scan_buffer_top, *scan_buffer_bottom;
+SCHEME_OBJECT *free_buffer_top, *free_buffer_bottom;
static Boolean extension_overlap_p;
static long extension_overlap_length;
return;
}
\f
-void
+void
Clear_Memory (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
{
Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
{
- Pointer test_value;
+ SCHEME_OBJECT test_value;
int Real_Stack_Size;
Real_Stack_Size = Stack_Allocation_Size(Our_Stack_Size);
/* Allocate.
The two GC buffers are not included in the valid Scheme memory.
*/
- Highest_Allocated_Address =
- Allocate_Heap_Space(Real_Stack_Size + Our_Heap_Size +
+ Highest_Allocated_Address =
+ ALLOCATE_HEAP_SPACE(Real_Stack_Size + Our_Heap_Size +
Our_Constant_Size + (2 * GC_BUFFER_SPACE) +
HEAP_BUFFER_SPACE);
Highest_Allocated_Address -= (2 * GC_BUFFER_SPACE);
Heap += HEAP_BUFFER_SPACE;
- Initial_Align_Float(Heap);
+ INITIAL_ALIGN_FLOAT(Heap);
Constant_Space = Heap + Our_Heap_Size;
gc_disk_buffer_1 = Constant_Space + Our_Constant_Size + Real_Stack_Size;
gc_disk_buffer_2 = (gc_disk_buffer_1 + GC_BUFFER_SPACE);
/* Consistency check 3 */
- test_value = (Make_Pointer(LAST_TYPE_CODE, Highest_Allocated_Address));
+ test_value =
+ (MAKE_POINTER_OBJECT (LAST_TYPE_CODE, Highest_Allocated_Address));
- if (((OBJECT_TYPE(test_value)) != LAST_TYPE_CODE) ||
- ((Get_Pointer(test_value)) != Highest_Allocated_Address))
+ if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) ||
+ ((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address))
{
fprintf(stderr,
- "Largest address does not fit in datum field of Pointer.\n");
+ "Largest address does not fit in datum field of object.\n");
fprintf(stderr,
"Allocate less space or re-compile without Heap_In_Low_Memory.\n");
exit(1);
Heap_Bottom = Heap;
Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size);
- open_gc_file(Our_Heap_Size * sizeof(Pointer));
+ open_gc_file(Our_Heap_Size * sizeof(SCHEME_OBJECT));
return;
}
\f
void
dump_buffer(from, position, nbuffers, name, success)
- Pointer *from;
+ SCHEME_OBJECT *from;
long *position, nbuffers;
char *name;
Boolean *success;
void
load_buffer(position, to, nbytes, name)
long position;
- Pointer *to;
+ SCHEME_OBJECT *to;
long nbytes;
char *name;
{
}
load_buffer(scan_position, scan_buffer_bottom,
GC_BUFFER_BYTES, "the scan buffer");
- *scan_buffer_top = Make_Pointer(TC_BROKEN_HEART, scan_buffer_top);
+ *scan_buffer_top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top);
return;
}
\f
-Pointer *
+SCHEME_OBJECT *
initialize_scan_buffer()
{
scan_position = 0;
Various parts of the garbage collector depend on scan_buffer_top
always pointing to a valid buffer.
*/
-Pointer *
+SCHEME_OBJECT *
initialize_free_buffer()
{
free_position = 0;
void
extend_scan_buffer(to_where, current_free)
fast char *to_where;
- Pointer *current_free;
+ SCHEME_OBJECT *current_free;
{
long new_scan_position;
{
/* There was no overlap */
- fast Pointer *source, *dest, *limit;
+ fast SCHEME_OBJECT *source, *dest, *limit;
source = scan_buffer_top;
dest = scan_buffer_bottom;
dest,
GC_BUFFER_REMAINDER_BYTES,
"the scan buffer");
- *scan_buffer_top = Make_Pointer(TC_BROKEN_HEART, scan_buffer_top);
+ *scan_buffer_top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top);
}
else
{
dest,
(GC_BUFFER_BYTES - extension_overlap_length),
"the scan buffer");
- *scan_buffer_top = Make_Pointer(TC_BROKEN_HEART, scan_buffer_top);
+ *scan_buffer_top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top);
}
}
extension_overlap_p = false;
return (result);
}
\f
-Pointer *
+SCHEME_OBJECT *
dump_and_reload_scan_buffer(number_to_skip, success)
long number_to_skip;
Boolean *success;
return (scan_buffer_bottom);
}
-Pointer *
+SCHEME_OBJECT *
dump_and_reset_free_buffer(overflow, success)
fast long overflow;
Boolean *success;
{
- fast Pointer *into, *from;
+ fast SCHEME_OBJECT *into, *from;
from = free_buffer_top;
if (free_buffer_bottom == scan_buffer_bottom)
*/
if (!extension_overlap_p)
{
- *scan_buffer_top = Make_Pointer(TC_BROKEN_HEART, scan_buffer_top);
+ *scan_buffer_top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top);
}
return (into);
}
void
dump_free_directly(from, nbuffers, success)
- Pointer *from;
+ SCHEME_OBJECT *from;
long nbuffers;
Boolean *success;
{
return;
}
-Pointer *
+SCHEME_OBJECT *
guarantee_in_memory(addr)
- Pointer *addr;
+ SCHEME_OBJECT *addr;
{
long position, offset;
is on disk. Old space is in memory.
*/
-Pointer Weak_Chain;
+SCHEME_OBJECT Weak_Chain;
void
Fix_Weak_Chain()
{
- fast Pointer *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant;
+ fast SCHEME_OBJECT *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant;
initialize_new_space_buffer();
Low_Constant = Constant_Space;
while (Weak_Chain != EMPTY_LIST)
{
- Old_Weak_Cell = Get_Pointer(Weak_Chain);
- Scan = guarantee_in_memory(Get_Pointer(*Old_Weak_Cell++));
+ Old_Weak_Cell = OBJECT_ADDRESS (Weak_Chain);
+ Scan = guarantee_in_memory(OBJECT_ADDRESS (*Old_Weak_Cell++));
Weak_Chain = *Old_Weak_Cell;
Old_Car = *Scan;
- Temp = Make_New_Pointer(OBJECT_TYPE(Weak_Chain), Old_Car);
- Weak_Chain = Make_New_Pointer(TC_NULL, Weak_Chain);
+ Temp = (MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, Old_Car));
+ Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain));
switch(GC_Type(Temp))
{
continue;
case GC_Special:
- if (OBJECT_TYPE(Temp) != TC_REFERENCE_TRAP)
+ if (OBJECT_TYPE (Temp) != TC_REFERENCE_TRAP)
{
/* No other special type makes sense here. */
goto fail;
}
- if (OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE)
+ if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
{
*Scan = Temp;
continue;
case GC_Quadruple:
case GC_Vector:
/* Old is still a pointer to old space */
- Old = Get_Pointer(Old_Car);
+ Old = OBJECT_ADDRESS (Old_Car);
if (Old >= Low_Constant)
{
*Scan = Temp;
continue;
}
- if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART)
+ if (OBJECT_TYPE (*Old) == TC_BROKEN_HEART)
{
- *Scan = Make_New_Pointer(OBJECT_TYPE(Temp), *Old);
+ *Scan = (MAKE_OBJECT_FROM_OBJECTS (Temp, *Old));
continue;
}
*Scan = SHARP_F;
case GC_Compiled:
/* Old is still a pointer to old space */
- Old = Get_Pointer(Old_Car);
+ Old = OBJECT_ADDRESS (Old_Car);
if (Old >= Low_Constant)
{
*Scan = Temp;
Temp);
*Scan = SHARP_F;
continue;
-
+
default: /* Non Marked Headers and Broken Hearts */
fail:
fprintf(stderr,
- 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.
\f
void
GC(initial_weak_chain)
- Pointer initial_weak_chain;
+ SCHEME_OBJECT initial_weak_chain;
{
- Pointer
+ SCHEME_OBJECT
*Root, *Result, *end_of_constant_area,
The_Precious_Objects, *Root2, *free_buffer;
Set_Fixed_Obj_Slot(Lost_Objects_Base, SHARP_F);
*free_buffer++ = Fixed_Objects;
- *free_buffer++ = Make_Pointer(UNMARKED_HISTORY_TYPE, History);
+ *free_buffer++ = MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History);
*free_buffer++ = Undefined_Primitives;
*free_buffer++ = Undefined_Primitives_Arity;
*free_buffer++ = Get_Current_Stacklet();
*free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ?
SHARP_F :
- Make_Pointer(TC_CONTROL_POINT,
+ MAKE_POINTER_OBJECT (TC_CONTROL_POINT,
Prev_Restore_History_Stacklet));
*free_buffer++ = Current_State_Point;
*free_buffer++ = Fluid_Bindings;
/* Load new space into memory. */
load_buffer(0, Heap_Bottom,
- ((Free - Heap_Bottom) * sizeof(Pointer)),
+ ((Free - Heap_Bottom) * sizeof(SCHEME_OBJECT)),
"new space");
/* 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));
+ Set_Fixed_Obj_Slot (Precious_Objects, *Root2);
+ Set_Fixed_Obj_Slot
+ (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (Root2))));
- History = Get_Pointer(*Root++);
+ History = OBJECT_ADDRESS (*Root++);
Undefined_Primitives = *Root++;
Undefined_Primitives_Arity = *Root++;
}
else
{
- Prev_Restore_History_Stacklet = Get_Pointer(*Root++);
+ Prev_Restore_History_Stacklet = OBJECT_ADDRESS (*Root++);
}
Current_State_Point = *Root++;
Fluid_Bindings = *Root++;
DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0)
{
+ long new_gc_reserve;
extern unsigned long gc_counter;
- Pointer GC_Daemon_Proc;
- Primitive_1_Arg();
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- Arg_1_Type(TC_FIXNUM);
+ SCHEME_OBJECT GC_Daemon_Proc;
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ new_gc_reserve = (arg_nonnegative_integer (1));
if (Free > Heap_Top)
{
Microcode_Termination(TERM_GC_OUT_OF_SPACE);
}
ENTER_CRITICAL_SECTION ("garbage collector");
gc_counter += 1;
- GC_Reserve = (UNSIGNED_FIXNUM_VALUE (Arg1));
+ GC_Reserve = new_gc_reserve;
GC(EMPTY_LIST);
CLEAR_INTERRUPT(INT_GC);
Pop_Primitive_Frame(1);
{
Will_Push(CONTINUATION_SIZE);
Store_Return(RC_NORMAL_GC_DONE);
- Store_Expression(Make_Unsigned_Fixnum(MemTop - Free));
+ Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free));
Save_Cont();
Pushed();
PRIMITIVE_ABORT(PRIM_POP_RETURN);
}
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
Store_Return(RC_NORMAL_GC_DONE);
- Store_Expression(Make_Unsigned_Fixnum(MemTop - Free));
+ Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free));
Save_Cont();
Push(GC_Daemon_Proc);
Push(STACK_FRAME_HEADER);
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.44 1989/06/08 00:24:47 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.45 1989/09/20 23:05:53 cph Exp $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
#define relocate_indirect_setup() \
{ \
- Old = Get_Pointer(Temp); \
+ Old = OBJECT_ADDRESS (Temp); \
if (Old >= Low_Constant) \
continue; \
- if (Type_Code(*Old) == TC_BROKEN_HEART) \
+ if (OBJECT_TYPE (*Old) == TC_BROKEN_HEART) \
{ \
continue; \
} \
- New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
+ New_Address = (MAKE_BROKEN_HEART (To_Address)); \
}
#define relocate_indirect_end() \
{ \
- *Get_Pointer(Temp) = New_Address; \
+ *OBJECT_ADDRESS (Temp) = New_Address; \
continue; \
}
\f
/* A modified copy of GCLoop. */
-Pointer *
+SCHEME_OBJECT *
purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode)
- fast Pointer *Scan;
- Pointer **To_ptr, **To_Address_ptr;
+ fast SCHEME_OBJECT *Scan;
+ SCHEME_OBJECT **To_ptr, **To_Address_ptr;
int purify_mode;
{
- fast Pointer *To, *Old, Temp, *Low_Constant, *To_Address, New_Address;
+ fast SCHEME_OBJECT *To, *Old, Temp, *Low_Constant, *To_Address, New_Address;
To = *To_ptr;
To_Address = *To_Address_ptr;
Switch_by_GC_Type(Temp)
{
case TC_BROKEN_HEART:
- if (Scan != (Get_Pointer(Temp)))
+ if (Scan != (OBJECT_ADDRESS (Temp)))
{
sprintf(gc_death_message_buffer,
"purifyloop: broken heart (0x%lx) in scan",
case TC_MANIFEST_SPECIAL_NM_VECTOR:
/* Check whether this bumps over current buffer,
and if so we need a new bufferfull. */
- Scan += Get_Integer(Temp);
+ Scan += OBJECT_DATUM (Temp);
if (Scan < scan_buffer_top)
{
break;
}
Scan = scan_buffer_top + overflow;
break;
- }
+ }
}
\f
case TC_MANIFEST_CLOSURE:
Scan += 1;
start_ptr = FIRST_MANIFEST_CLOSURE_ENTRY(Scan);
-
+
for (word_ptr = start_ptr,
next_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
true;
relocate_normal_pointer(copy_cell(), 1);
case TC_REFERENCE_TRAP:
- if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
+ if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
break; /* It is a non pointer. */
goto purify_pair;
case TC_UNINTERNED_SYMBOL:
if (purify_mode == PURE_COPY)
{
- Temp = Vector_Ref(Temp, SYMBOL_NAME);
+ Temp = MEMORY_REF (Temp, SYMBOL_NAME);
relocate_indirect_setup();
copy_vector(NULL);
relocate_indirect_end();
break;
else
relocate_normal_pointer(copy_weak_pair(), 2);
-
+
case TC_VARIABLE:
case_Triple:
relocate_normal_pointer(copy_triple(), 3);
}
\f
/* This is not paranoia!
- The two words in the header may overflow the free buffer.
+ The two words in the header may overflow the free buffer.
*/
-Pointer *
+SCHEME_OBJECT *
purify_header_overflow(free_buffer)
- Pointer *free_buffer;
+ SCHEME_OBJECT *free_buffer;
{
- Pointer *scan_buffer;
+ SCHEME_OBJECT *scan_buffer;
long delta;
delta = (free_buffer - free_buffer_top);
return (free_buffer);
}
\f
-Pointer
+SCHEME_OBJECT
purify(object, flag)
- Pointer object, flag;
+ SCHEME_OBJECT object, flag;
{
long length, pure_length;
- Pointer value, *Result, *free_buffer, *block_start;
+ SCHEME_OBJECT value, *Result, *free_buffer, *block_start;
Weak_Chain = EMPTY_LIST;
free_buffer = initialize_free_buffer();
block_start = Free_Constant;
Free_Constant += 2;
- *free_buffer++ = NIL; /* Pure block header. */
+ *free_buffer++ = SHARP_F; /* Pure block header. */
*free_buffer++ = object;
if (free_buffer >= free_buffer_top)
{
}
Free_Constant += 2;
- *free_buffer++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *free_buffer++ = Make_Non_Pointer(CONSTANT_PART, pure_length);
+ *free_buffer++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *free_buffer++ = MAKE_OBJECT (CONSTANT_PART, pure_length);
if (free_buffer >= free_buffer_top)
{
free_buffer = purify_header_overflow(free_buffer);
Free_Constant += 2;
length = (Free_Constant - block_start);
- *free_buffer++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *free_buffer++ = Make_Non_Pointer(END_OF_BLOCK, (length - 1));
+ *free_buffer++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *free_buffer++ = MAKE_OBJECT (END_OF_BLOCK, (length - 1));
if (free_buffer >= free_buffer_top)
{
free_buffer = purify_header_overflow(free_buffer);
}
load_buffer(0, block_start,
- (length * sizeof(Pointer)),
+ (length * sizeof(SCHEME_OBJECT)),
"into constant space");
- *block_start++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR,
- pure_length);
- *block_start = Make_Non_Pointer(PURE_PART, (length - 1));
+ *block_start++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, pure_length);
+ *block_start = MAKE_OBJECT (PURE_PART, (length - 1));
GC(Weak_Chain);
Set_Pure_Top();
return (SHARP_T);
/* Stub. Not needed by this version. Terminates Scheme if invoked. */
-Pointer
+SCHEME_OBJECT
Purify_Pass_2(info)
- Pointer info;
+ SCHEME_OBJECT info;
{
gc_death(TERM_EXIT, "Purify_Pass_2 invoked", NULL, NULL);
/*NOTREACHED*/
DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0)
{
- Pointer object, daemon;
- Pointer result;
- Primitive_3_Args();
-
+ SCHEME_OBJECT object, daemon;
+ SCHEME_OBJECT result;
+ PRIMITIVE_HEADER (3);
PRIMITIVE_CANONICALIZE_CONTEXT();
- if ((Arg2 != SHARP_T) && (Arg2 != SHARP_F))
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Arg_3_Type(TC_FIXNUM);
- Touch_In_Primitive(Arg1, object);
- GC_Reserve = (Get_Integer (Arg3));
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
+ CHECK_ARG (2, BOOLEAN_P);
+ GC_Reserve = (arg_nonnegative_integer (3));
ENTER_CRITICAL_SECTION ("purify");
{
- Pointer purify_result;
- Pointer words_free;
+ SCHEME_OBJECT purify_result;
+ SCHEME_OBJECT words_free;
- purify_result = purify(object, Arg2);
- words_free = (Make_Unsigned_Fixnum (MemTop - Free));
- result = (Make_Pointer (TC_LIST, Free));
+ purify_result = (purify (object, (ARG_REF (2))));
+ words_free = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));
+ result = (MAKE_POINTER_OBJECT (TC_LIST, Free));
(*Free++) = purify_result;
(*Free++) = words_free;
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bignum.c,v 9.27 1989/08/28 18:28:19 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bignum.c,v 9.28 1989/09/20 23:05:57 cph Exp $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* BIG NUMber arithmetic */
+/* Implementation of Bignums (unlimited precision integers) */
+#ifdef MIT_SCHEME
#include "scheme.h"
-#include <math.h>
-#include "prims.h"
+#else
#include "bignum.h"
-#include "flonum.h"
-#include "zones.h"
+#endif
+#include "bignumint.h"
+#include "limits.h"
\f
-/* The following macros are the beginnings of a redesign of the bignum
- code. Some of the procedures and primitives defined here use these
- new conventions. Please update things as you work on them. */
-
-#define DIGITS_PER_POINTER ((sizeof (Pointer)) / (sizeof (bigdigit)))
-
-#define DIGITS_TO_POINTERS(n_digits) \
- (((n_digits) + (DIGITS_PER_POINTER - 1)) / DIGITS_PER_POINTER)
+#ifndef MIT_SCHEME
-#define DIGITS_TO_GC_LENGTH(n_digits) (DIGITS_TO_POINTERS ((n_digits) + 2))
+static bignum_type
+bignum_malloc (length)
+ bignum_length_type length;
+{
+ extern char * malloc ();
+ char * result = (malloc (length * (sizeof (bignum_digit_type))));
+ BIGNUM_ASSERT (result != ((char *) 0));
+ return ((bignum_type) result);
+}
-#define DIGITS_TO_GC_HEADER(n_digits) \
- (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, (DIGITS_TO_GC_LENGTH (n_digits))))
+static bignum_type
+bignum_realloc (bignum, length)
+ bignum_type bignum;
+ bignum_length_type length;
+{
+ extern char * realloc ();
+ char * result =
+ (realloc (((char *) bignum), (length * (sizeof (bignum_digit_type)))));
+ BIGNUM_ASSERT (result != ((char *) 0));
+ return ((bignum_type) result);
+}
-#define BIGNUM_PTR(bignum, index) \
- (((bigdigit *) (Nth_Vector_Loc ((bignum), 1))) + (index))
+#endif /* not MIT_SCHEME */
+
+/* Forward references */
+static int bignum_equal_p_unsigned ();
+static enum bignum_comparison bignum_compare_unsigned ();
+static bignum_type bignum_add_unsigned ();
+static bignum_type bignum_subtract_unsigned ();
+static bignum_type bignum_multiply_unsigned ();
+static bignum_type bignum_multiply_unsigned_small_factor ();
+static void bignum_destructive_scale_up ();
+static void bignum_destructive_add ();
+static void bignum_divide_unsigned_large_denominator ();
+static int bignum_compute_normalization_shift ();
+static void bignum_destructive_normalization ();
+static void bignum_destructive_unnormalization ();
+static void bignum_divide_unsigned_normalized ();
+static bignum_digit_type bignum_divide_subtract ();
+static void bignum_divide_unsigned_medium_denominator ();
+static bignum_digit_type bignum_digit_divide ();
+static bignum_digit_type bignum_digit_divide_subtract ();
+static void bignum_divide_unsigned_small_denominator ();
+static bignum_digit_type bignum_destructive_scale_down ();
+static bignum_type bignum_remainder_unsigned_small_denominator ();
+static bignum_type bignum_digit_to_bignum ();
+static bignum_type bignum_allocate ();
+static bignum_type bignum_allocate_zeroed ();
+static bignum_type bignum_shorten_length ();
+static bignum_type bignum_trim ();
+static bignum_type bignum_copy ();
+static bignum_type bignum_new_sign ();
+static bignum_type bignum_maybe_new_sign ();
+static void bignum_destructive_copy ();
+static void bignum_destructive_zero ();
+\f
+/* Exports */
-#define BIGNUM_REF(bignum, index) (* (BIGNUM_PTR ((bignum), (index))))
-#define BIGNUM_SIGN(bignum) (BIGNUM_REF ((bignum), 0))
-#define BIGNUM_LENGTH(bignum) (BIGNUM_REF ((bignum), 1))
-#define BIGNUM_START_PTR(bignum) (BIGNUM_PTR ((bignum), 2))
-#define BIGNUM_END_PTR(bignum) \
- (BIGNUM_PTR ((bignum), (2 + (BIGNUM_LENGTH (bignum)))))
+bignum_type
+bignum_make_zero ()
+{
+ fast bignum_type result = (BIGNUM_ALLOCATE (0));
+ BIGNUM_SET_HEADER (result, 0, 0);
+ return (result);
+}
-#define BIGNUM_NEGATIVE_P(bignum) ((BIGNUM_SIGN (bignum)) == 0)
-#define BIGNUM_ZERO_P(bignum) ((BIGNUM_LENGTH (bignum)) == 0)
-\f
-static Pointer
-make_bignum_zero ()
+bignum_type
+bignum_make_one (negative_p)
+ int negative_p;
{
- Pointer bignum =
- (allocate_non_marked_vector
- (TC_BIG_FIXNUM, (DIGITS_TO_GC_LENGTH (0)), true));
- (BIGNUM_SIGN (bignum)) = 1;
- (BIGNUM_LENGTH (bignum)) = 0;
- return (bignum);
+ fast bignum_type result = (BIGNUM_ALLOCATE (1));
+ BIGNUM_SET_HEADER (result, 1, negative_p);
+ (BIGNUM_REF (result, 0)) = 1;
+ return (result);
}
-static Pointer
-bignum_allocate (n_digits, negative_p)
- long n_digits;
- Boolean negative_p;
+int
+bignum_equal_p (x, y)
+ fast bignum_type x;
+ fast bignum_type y;
{
- Pointer bignum =
- (allocate_non_marked_vector
- (TC_BIG_FIXNUM, (DIGITS_TO_GC_LENGTH (n_digits)), true));
- (BIGNUM_SIGN (bignum)) = (negative_p ? 0 : 1);
- (BIGNUM_LENGTH (bignum)) = n_digits;
- return (bignum);
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (BIGNUM_ZERO_P (y))
+ : ((! (BIGNUM_ZERO_P (y))) &&
+ ((BIGNUM_NEGATIVE_P (x))
+ ? (BIGNUM_NEGATIVE_P (x))
+ : (! (BIGNUM_NEGATIVE_P (x)))) &&
+ (bignum_equal_p_unsigned (x, y))));
}
-static void
-bignum_destructive_copy (source, target)
- Pointer source;
- Pointer target;
+enum bignum_comparison
+bignum_test (bignum)
+ fast bignum_type bignum;
{
- fast bigdigit * scan_source;
- fast bigdigit * end_source;
- fast bigdigit * scan_target;
+ return
+ ((BIGNUM_ZERO_P (bignum))
+ ? bignum_comparison_equal
+ : (BIGNUM_NEGATIVE_P (bignum))
+ ? bignum_comparison_less
+ : bignum_comparison_greater);
+}
- (BIGNUM_SIGN (target)) = (BIGNUM_SIGN (source));
- (BIGNUM_LENGTH (target)) = (BIGNUM_LENGTH (source));
- scan_source = (BIGNUM_START_PTR (source));
- end_source = (BIGNUM_END_PTR (source));
- scan_target = (BIGNUM_START_PTR (target));
- while (scan_source < end_source)
- (*scan_target++) = (*scan_source++);
- return;
+enum bignum_comparison
+bignum_compare (x, y)
+ fast bignum_type x;
+ fast bignum_type y;
+{
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? ((BIGNUM_ZERO_P (y))
+ ? bignum_comparison_equal
+ : (BIGNUM_NEGATIVE_P (y))
+ ? bignum_comparison_greater
+ : bignum_comparison_less)
+ : (BIGNUM_ZERO_P (y))
+ ? ((BIGNUM_NEGATIVE_P (x))
+ ? bignum_comparison_less
+ : bignum_comparison_greater)
+ : (BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_compare_unsigned (y, x))
+ : (bignum_comparison_less))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_comparison_greater)
+ : (bignum_compare_unsigned (x, y))));
+}
+\f
+bignum_type
+bignum_add (x, y)
+ fast bignum_type x;
+ fast bignum_type y;
+{
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (BIGNUM_MAYBE_COPY (y))
+ : (BIGNUM_ZERO_P (y))
+ ? (BIGNUM_MAYBE_COPY (x))
+ : ((BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_add_unsigned (x, y, 1))
+ : (bignum_subtract_unsigned (y, x)))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_subtract_unsigned (x, y))
+ : (bignum_add_unsigned (x, y, 0)))));
}
-static Pointer
-bignum_copy (source)
- Pointer source;
+bignum_type
+bignum_subtract (x, y)
+ fast bignum_type x;
+ fast bignum_type y;
{
- Pointer target =
- (allocate_non_marked_vector
- (TC_BIG_FIXNUM, (DIGITS_TO_GC_LENGTH (BIGNUM_LENGTH (source))), true));
- bignum_destructive_copy (source, target);
- return (target);
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? ((BIGNUM_ZERO_P (y))
+ ? (BIGNUM_MAYBE_COPY (y))
+ : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y))))))
+ : ((BIGNUM_ZERO_P (y))
+ ? (BIGNUM_MAYBE_COPY (x))
+ : ((BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_subtract_unsigned (y, x))
+ : (bignum_add_unsigned (x, y, 1)))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_add_unsigned (x, y, 0))
+ : (bignum_subtract_unsigned (x, y))))));
}
-static int
-bignum_length_in_bits (bignum)
- Pointer bignum;
+bignum_type
+bignum_negate (x)
+ fast bignum_type x;
{
- if (BIGNUM_ZERO_P (bignum))
- return (0);
- {
- int max_index = ((BIGNUM_LENGTH (bignum)) - 1);
- fast int result = (max_index * SHIFT);
- fast unsigned long max_digit = (BIGNUM_REF (bignum, max_index));
- while (max_digit > 0)
- {
- result += 1;
- max_digit >>= 1;
- }
- return (result);
- }
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (BIGNUM_MAYBE_COPY (x))
+ : (bignum_new_sign (x, (! (BIGNUM_NEGATIVE_P (x))))));
}
\f
-static unsigned long
-scale_down (source, target, denominator)
- Pointer source;
- Pointer target;
- unsigned long denominator;
+bignum_type
+bignum_multiply (x, y)
+ fast bignum_type x;
+ fast bignum_type y;
{
- fast unsigned long remainder;
- fast unsigned long quotient;
- fast bigdigit * scan_source;
- fast bigdigit * scan_target;
- fast bigdigit * start_source;
-
- (BIGNUM_SIGN (target)) = (BIGNUM_SIGN (source));
- (BIGNUM_LENGTH (target)) = (BIGNUM_LENGTH (source));
- scan_source = (BIGNUM_END_PTR (source));
- start_source = (BIGNUM_START_PTR (source));
- scan_target = (BIGNUM_END_PTR (target));
- remainder = 0;
- while (scan_source > start_source)
+ fast bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ fast bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ fast int negative_p =
+ ((BIGNUM_NEGATIVE_P (x))
+ ? (! (BIGNUM_NEGATIVE_P (y)))
+ : (BIGNUM_NEGATIVE_P (y)));
+ if (BIGNUM_ZERO_P (x))
+ return (BIGNUM_MAYBE_COPY (x));
+ if (BIGNUM_ZERO_P (y))
+ return (BIGNUM_MAYBE_COPY (y));
+ if (x_length == 1)
{
- remainder = ((remainder << SHIFT) + (*--scan_source));
- quotient = (remainder / denominator);
- remainder = (remainder % denominator);
- (*--scan_target) = quotient;
+ bignum_digit_type digit = (BIGNUM_REF (x, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (y, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
}
- return (remainder);
+ if (y_length == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (y, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (x, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
+ }
+ return (bignum_multiply_unsigned (x, y, negative_p));
}
-
-static unsigned long
-scale_down_self (bignum, denominator)
- Pointer bignum;
- unsigned long denominator;
+\f
+int
+bignum_divide (numerator, denominator, quotient, remainder)
+ bignum_type numerator;
+ bignum_type denominator;
+ bignum_type * quotient;
+ bignum_type * remainder;
{
- fast unsigned long remainder;
- fast unsigned long quotient;
- fast bigdigit * scan;
- fast bigdigit * start;
-
- scan = (BIGNUM_END_PTR (bignum));
- start = (BIGNUM_START_PTR (bignum));
- remainder = 0;
- while (scan > start)
+ if (BIGNUM_ZERO_P (denominator))
+ return (1);
+ if (BIGNUM_ZERO_P (numerator))
{
- remainder = ((remainder << SHIFT) + (*--scan));
- quotient = (remainder / denominator);
- remainder = (remainder % denominator);
- (*scan) = quotient;
+ (*quotient) = (BIGNUM_MAYBE_COPY (numerator));
+ (*remainder) = (BIGNUM_MAYBE_COPY (numerator));
}
- return (remainder);
+ else
+ {
+ int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ {
+ (*quotient) = (BIGNUM_ONE (q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ case bignum_comparison_less:
+ {
+ (*quotient) = (BIGNUM_ZERO ());
+ (*remainder) = (BIGNUM_MAYBE_COPY (numerator));
+ break;
+ }
+ case bignum_comparison_greater:
+ {
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ {
+ (*quotient) =
+ (bignum_maybe_new_sign (numerator, q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ else if (digit < BIGNUM_RADIX_ROOT)
+ {
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ else
+ {
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ }
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ }
+ }
+ return (0);
}
\f
-void
-trim_bignum(ARG)
- bigdigit *ARG;
+bignum_type
+bignum_quotient (numerator, denominator)
+ bignum_type numerator;
+ bignum_type denominator;
{
- 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);
- return;
+ if (BIGNUM_ZERO_P (denominator))
+ return (BIGNUM_OUT_OF_BAND);
+ if (BIGNUM_ZERO_P (numerator))
+ return (BIGNUM_MAYBE_COPY (numerator));
+ {
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator))
+ ? (! (BIGNUM_NEGATIVE_P (numerator)))
+ : (BIGNUM_NEGATIVE_P (numerator)));
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ONE (q_negative_p));
+ case bignum_comparison_less:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_greater:
+ {
+ bignum_type quotient;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (numerator, q_negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ ("ient), ((bignum_type *) 0),
+ q_negative_p, 0);
+ else
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ ("ient), ((bignum_type *) 0),
+ q_negative_p, 0);
+ }
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ("ient), ((bignum_type *) 0),
+ q_negative_p, 0);
+ return (quotient);
+ }
+ }
+ }
}
-
-void
-copy_bignum(SOURCE, TARGET)
- fast bigdigit *SOURCE, *TARGET;
+\f
+bignum_type
+bignum_remainder (numerator, denominator)
+ bignum_type numerator;
+ bignum_type denominator;
{
- fast bigdigit *LIMIT;
-
- LIMIT = Bignum_Top(SOURCE);
- while (LIMIT >= SOURCE)
- *TARGET++ = *SOURCE++;
- return;
+ if (BIGNUM_ZERO_P (denominator))
+ return (BIGNUM_OUT_OF_BAND);
+ if (BIGNUM_ZERO_P (numerator))
+ return (BIGNUM_MAYBE_COPY (numerator));
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
+ return (BIGNUM_MAYBE_COPY (numerator));
+ case bignum_comparison_greater:
+ {
+ bignum_type remainder;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (BIGNUM_ZERO ());
+ if (digit < BIGNUM_RADIX_ROOT)
+ return
+ (bignum_remainder_unsigned_small_denominator
+ (numerator, digit, (BIGNUM_NEGATIVE_P (numerator))));
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ ((bignum_type *) 0), (&remainder),
+ 0, (BIGNUM_NEGATIVE_P (numerator)));
+ }
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ((bignum_type *) 0), (&remainder),
+ 0, (BIGNUM_NEGATIVE_P (numerator)));
+ return (remainder);
+ }
+ }
}
\f
-/* scale() and unscale() used by Division and Listify */
+/* These procedures depend on the non-portable type `unsigned long'.
+ If your compiler doesn't support this type, either define the
+ switch `BIGNUM_NO_ULONG' to disable them (in "bignum.h"), or write
+ new versions that don't use this type. */
-void
-scale(SOURCE, DEST, how_much)
- fast bigdigit *SOURCE, *DEST;
- fast long how_much;
-{
- fast unsigned bigdouble prod = 0;
- bigdigit *LIMIT;
+#ifndef BIGNUM_NO_ULONG
- if (how_much == 1)
+bignum_type
+long_to_bignum (n)
+ long n;
+{
+ int negative_p;
+ bignum_digit_type result_digits [BIGNUM_DIGITS_FOR_LONG];
+ fast bignum_digit_type * end_digits = result_digits;
+ /* Special cases win when these small constants are cached. */
+ if (n == 0) return (BIGNUM_ZERO ());
+ if (n == 1) return (BIGNUM_ONE (0));
+ if (n == -1) return (BIGNUM_ONE (1));
{
- if (SOURCE != DEST)
- copy_bignum(SOURCE, DEST);
- Prepare_Header(DEST, (LEN(SOURCE) + 1), SIGN(SOURCE));
- *Bignum_Top(DEST) = 0;
- return;
+ fast unsigned long accumulator = ((negative_p = (n < 0)) ? (-n) : n);
+ do
+ {
+ (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK);
+ accumulator >>= BIGNUM_DIGIT_LENGTH;
+ }
+ while (accumulator != 0);
}
-
- /* 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);
+ bignum_type result =
+ (bignum_allocate ((end_digits - result_digits), negative_p));
+ fast bignum_digit_type * scan_digits = result_digits;
+ fast bignum_digit_type * scan_result = (BIGNUM_START_PTR (result));
+ while (scan_digits < end_digits)
+ (*scan_result++) = (*scan_digits++);
+ return (result);
}
- *DEST = Get_Carry(prod);
- return;
}
-/* returns remainder */
-
long
-unscale(SOURCE, DEST, how_much)
- bigdigit *SOURCE;
- fast bigdigit *DEST;
- fast long how_much;
+bignum_to_long (bignum)
+ bignum_type bignum;
{
- 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)
+ if (BIGNUM_ZERO_P (bignum))
+ return (0);
{
- /* Bug fix by JMiller */
- fast unsigned bigdouble digits, temp;
-
- digits = Mul_Radix(carry) + *SCAN--;
- temp = digits / how_much;
- *DEST-- = temp;
- temp = temp * how_much;
- carry = digits - temp;
+ fast unsigned long accumulator = 0;
+ fast bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ while (start < scan)
+ accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan));
+ return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator);
}
- return carry;
}
-\f
-/* Bignum Comparison utilities */
-/* big_compare_unsigned() compares the magnitudes of two BIGNUM's.
- * Called by big_compare() and minus_unsigned_bignum().
- */
+#endif /* not BIGNUM_NO_ULONG */
+\f
+#define DTB_WRITE_DIGIT(factor) \
+{ \
+ significand *= (factor); \
+ digit = ((bignum_digit_type) significand); \
+ (*--scan) = digit; \
+ significand -= ((double) digit); \
+}
-int
-big_compare_unsigned(ARG1, ARG2)
- fast bigdigit *ARG1, *ARG2;
+bignum_type
+double_to_bignum (x)
+ double x;
{
- 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;
+ extern double frexp ();
+ int exponent;
+ fast double significand = (frexp (x, (&exponent)));
+ if (exponent <= 0) return (BIGNUM_ZERO ());
+ if (exponent == 1) return (BIGNUM_ONE (x < 0));
+ if (significand < 0) significand = (-significand);
+ {
+ bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent));
+ bignum_type result = (bignum_allocate (length, (x < 0)));
+ bignum_digit_type * start = (BIGNUM_START_PTR (result));
+ fast bignum_digit_type * scan = (start + length);
+ fast bignum_digit_type digit;
+ int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
+ if (odd_bits > 0)
+ DTB_WRITE_DIGIT (1 << odd_bits);
+ while (start < scan)
+ {
+ if (significand == 0)
+ {
+ while (start < scan)
+ (*--scan) = 0;
+ break;
+ }
+ DTB_WRITE_DIGIT (BIGNUM_RADIX);
+ }
+ return (result);
}
- return EQUAL;
}
-/* big_compare() will return either of three cases, determining whether
- * ARG1 is bigger, smaller, or equal to ARG2.
- */
+#undef DTB_WRITE_DIGIT
-Pointer
-big_compare(ARG1, ARG2)
- bigdigit *ARG1, *ARG2;
+double
+bignum_to_double (bignum)
+ bignum_type bignum;
{
- 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()");
+ if (BIGNUM_ZERO_P (bignum))
+ return (0);
+ {
+ fast double accumulator = 0;
+ fast bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ while (start < scan)
+ accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan));
+ return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator);
}
- /*NOTREACHED*/
}
\f
-Pointer
-Fix_To_Big (object)
- Pointer object;
+int
+bignum_fits_in_word_p (bignum, word_length, twos_complement_p)
+ bignum_type bignum;
+ long word_length;
+ int twos_complement_p;
{
- fast long value;
- fast Pointer result;
+ unsigned int n_bits = (twos_complement_p ? (word_length - 1) : word_length);
+ BIGNUM_ASSERT (n_bits > 0);
+ {
+ fast bignum_length_type length = (BIGNUM_LENGTH (bignum));
+ fast unsigned int max_digits = (BIGNUM_BITS_TO_DIGITS (n_bits));
+ bignum_digit_type msd, max;
+ return
+ ((length < max_digits) ||
+ ((length == max_digits) &&
+ ((((msd = (BIGNUM_REF (bignum, (length - 1)))) <
+ (max = (1 << (n_bits - ((length - 1) * BIGNUM_DIGIT_LENGTH))))) ||
+ (twos_complement_p &&
+ (msd == max) &&
+ (BIGNUM_NEGATIVE_P (bignum)))))));
+ }
+}
- FIXNUM_VALUE (object, value);
- if (value == 0)
- return (make_bignum_zero ());
- else if (value > 0)
- result = (bignum_allocate (FIXNUM_LENGTH_AS_BIGNUM, false));
- else
- {
- result = (bignum_allocate (FIXNUM_LENGTH_AS_BIGNUM, true));
- value = (- value);
- }
+bignum_type
+bignum_length_in_bits (bignum)
+ bignum_type bignum;
+{
+ if (BIGNUM_ZERO_P (bignum))
+ return (BIGNUM_ZERO ());
{
- fast bigdigit * scan = (BIGNUM_START_PTR (result));
- fast long length = 0;
- while (value > 0)
+ bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
+ fast bignum_digit_type digit = (BIGNUM_REF (bignum, index));
+ fast bignum_type result = (bignum_allocate (2, 0));
+ (BIGNUM_REF (result, 0)) = index;
+ (BIGNUM_REF (result, 1)) = 0;
+ bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
+ while (digit > 0)
{
- (*scan++) = (value & DIGIT_MASK);
- value = (value >> SHIFT);
- length += 1;
+ bignum_destructive_add (result, ((bignum_digit_type) 1));
+ digit >>= 1;
}
- (BIGNUM_LENGTH (result)) = length;
- Fast_Vector_Set (result, 0, (DIGITS_TO_GC_HEADER (length)));
+ return (bignum_trim (result));
}
- return (result);
}
-Pointer
-Big_To_Fix (object)
- Pointer object;
+bignum_type
+bignum_length_upper_limit ()
+{
+ fast bignum_type result = (bignum_allocate (2, 0));
+ (BIGNUM_REF (result, 0)) = 0;
+ (BIGNUM_REF (result, 1)) = BIGNUM_DIGIT_LENGTH;
+ return (result);
+}
+\f
+bignum_type
+digit_stream_to_bignum (n_digits, producer, context, radix, negative_p)
+ fast unsigned int n_digits;
+ unsigned int (*producer) ();
+ bignum_procedure_context context;
+ fast unsigned int radix;
+ int negative_p;
{
- if (! (BIGNUM_P (object)))
- return (object);
- if (BIGNUM_ZERO_P (object))
- return (MAKE_UNSIGNED_FIXNUM (0));
+ BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
+ if (n_digits == 0)
+ return (BIGNUM_ZERO ());
+ if (n_digits == 1)
+ {
+ long digit = ((long) ((*producer) (context)));
+ return (long_to_bignum (negative_p ? (- digit) : digit));
+ }
{
- long length = (BIGNUM_LENGTH (object));
- if (length > FIXNUM_LENGTH_AS_BIGNUM)
- return (object);
+ bignum_length_type length;
{
- fast bigdigit * start = (BIGNUM_START_PTR (object));
- fast bigdigit * scan = (start + length);
- fast long result = (*--scan);
- if (length == FIXNUM_LENGTH_AS_BIGNUM)
+ fast unsigned int radix_copy = radix;
+ fast unsigned int log_radix = 0;
+ while (radix_copy > 0)
{
- long max_value = (1 << (FIXNUM_LENGTH - ((length - 1) * SHIFT)));
-
- if ((result > max_value) ||
- ((result == max_value) && (! (BIGNUM_NEGATIVE_P (object)))))
- return (object);
+ radix_copy >>= 1;
+ log_radix += 1;
+ }
+ /* This length will be at least as large as needed. */
+ length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
+ }
+ {
+ fast bignum_type result = (bignum_allocate_zeroed (length, negative_p));
+ while ((n_digits--) > 0)
+ {
+ bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
+ bignum_destructive_add
+ (result, ((bignum_digit_type) ((*producer) (context))));
}
- while (scan > start)
- result = ((result << SHIFT) + (*--scan));
- if (BIGNUM_NEGATIVE_P (object))
- result = (- result);
- return ((Fixnum_Fits (result)) ? (MAKE_SIGNED_FIXNUM (result)) : object);
+ return (bignum_trim (result));
}
}
}
-\f
-Pointer
-Big_To_Float (bignum)
- Pointer bignum;
+
+void
+bignum_to_digit_stream (bignum, radix, consumer, context)
+ bignum_type bignum;
+ unsigned int radix;
+ void (*consumer) ();
+ bignum_procedure_context context;
{
- /* If precision should not be lost,
- compare to FLONUM_MANTISSA_BITS instead. */
- if ((bignum_length_in_bits (bignum)) > MAX_FLONUM_EXPONENT)
- return (bignum);
- {
- fast bigdigit * start = (BIGNUM_START_PTR (bignum));
- fast bigdigit * scan = (BIGNUM_END_PTR (bignum));
- fast double accumulator = (0.0);
- while (scan > start)
- accumulator = ((accumulator * ((double) RADIX)) + ((double) (*--scan)));
- if (BIGNUM_NEGATIVE_P (bignum))
- accumulator = (- accumulator);
- Primitive_GC_If_Needed (FLONUM_SIZE + 1);
- return (Allocate_Float (accumulator));
- }
+ BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
+ if (! (BIGNUM_ZERO_P (bignum)))
+ {
+ fast bignum_type working_copy = (bignum_copy (bignum));
+ fast bignum_digit_type * start = (BIGNUM_START_PTR (working_copy));
+ fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (working_copy)));
+ while (start < scan)
+ {
+ if ((scan[-1]) == 0)
+ scan -= 1;
+ else
+ (*consumer)
+ (context, (bignum_destructive_scale_down (working_copy, radix)));
+ }
+ BIGNUM_DEALLOCATE (working_copy);
+ }
+ return;
}
-\f
-#ifdef HAS_FREXP
-extern double frexp(), ldexp();
-#else
-#include "missing.c"
-#endif
-Pointer
-Float_To_Big(flonum)
- double flonum;
+long
+bignum_max_digit_stream_radix ()
{
- fast double mantissa;
- fast bigdigit *Answer, size;
- int exponent;
- long Align_size;
-
- if (flonum == 0.0)
- return (make_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);
+ return (BIGNUM_RADIX_ROOT);
}
\f
-Pointer
-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;
+/* Comparisons */
- /* Swap ARG1 and ARG2 so that ARG1 is always longer */
+static int
+bignum_equal_p_unsigned (x, y)
+ bignum_type x;
+ bignum_type y;
+{
+ bignum_length_type length = (BIGNUM_LENGTH (x));
+ if (length != (BIGNUM_LENGTH (y)))
+ return (0);
+ else
+ {
+ fast bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ fast bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ fast bignum_digit_type * end_x = (scan_x + length);
+ while (scan_x < end_x)
+ if ((*scan_x++) != (*scan_y++))
+ return (0);
+ return (1);
+ }
+}
- if (LEN(ARG1) < LEN(ARG2))
+static enum bignum_comparison
+bignum_compare_unsigned (x, y)
+ bignum_type x;
+ bignum_type y;
+{
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ if (x_length < y_length)
+ return (bignum_comparison_less);
+ if (x_length > y_length)
+ return (bignum_comparison_greater);
{
- Answer = ARG1;
- ARG1 = ARG2;
- ARG2 = Answer;
+ fast bignum_digit_type * start_x = (BIGNUM_START_PTR (x));
+ fast bignum_digit_type * scan_x = (start_x + x_length);
+ fast bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
+ while (start_x < scan_x)
+ {
+ fast bignum_digit_type digit_x = (*--scan_x);
+ fast bignum_digit_type digit_y = (*--scan_y);
+ if (digit_x < digit_y)
+ return (bignum_comparison_less);
+ if (digit_x > digit_y)
+ return (bignum_comparison_greater);
+ }
}
-
- /* 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);
-
- /* 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;
+ return (bignum_comparison_equal);
+}
\f
- /* Starts Looping */
-
- while (TOP2 >= ARG2)
- {
- Sum = *ARG1++ + *ARG2++ + Get_Carry(Sum);
- *Answer++ = Get_Digit(Sum);
- }
-
- /* Let remaining carry propagate */
+/* Addition */
- while ((TOP1 >= ARG1) && (Get_Carry(Sum) != 0))
+static bignum_type
+bignum_add_unsigned (x, y, negative_p)
+ bignum_type x;
+ bignum_type y;
+ int negative_p;
+{
+ if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
+ {
+ bignum_type z = x;
+ x = y;
+ y = z;
+ }
{
- Sum = *ARG1++ + 1;
- *Answer++ = Get_Digit(Sum);
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_type r = (bignum_allocate ((x_length + 1), negative_p));
+ fast bignum_digit_type sum;
+ fast bignum_digit_type carry = 0;
+ fast bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ fast bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ {
+ fast bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ fast bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ while (scan_y < end_y)
+ {
+ sum = ((*scan_x++) + (*scan_y++) + carry);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*scan_r++) = sum;
+ carry = 0;
+ }
+ else
+ {
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ carry = 1;
+ }
+ }
+ }
+ {
+ fast bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
+ if (carry != 0)
+ while (scan_x < end_x)
+ {
+ sum = ((*scan_x++) + 1);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*scan_r++) = sum;
+ carry = 0;
+ break;
+ }
+ else
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ }
+ while (scan_x < end_x)
+ (*scan_r++) = (*scan_x++);
+ }
+ if (carry != 0)
+ {
+ (*scan_r) = 1;
+ return (r);
+ }
+ return (bignum_shorten_length (r, x_length));
}
+}
+\f
+/* Subtraction */
- /* 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)
+static bignum_type
+bignum_subtract_unsigned (x, y)
+ bignum_type x;
+ bignum_type y;
+{
+ int negative_p;
+ switch (bignum_compare_unsigned (x, y))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
+ {
+ bignum_type z = x;
+ x = y;
+ y = z;
+ }
+ negative_p = 1;
+ break;
+ case bignum_comparison_greater:
+ negative_p = 0;
+ break;
+ }
{
- Answer = BIGNUM(Free);
- LEN(Answer) -= 1;
- *((Pointer *) Answer) = Make_Header(Align(LEN(Answer)));
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_type r = (bignum_allocate (x_length, negative_p));
+ fast bignum_digit_type difference;
+ fast bignum_digit_type borrow = 0;
+ fast bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ fast bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ {
+ fast bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ fast bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ while (scan_y < end_y)
+ {
+ difference = (((*scan_x++) - (*scan_y++)) - borrow);
+ if (difference < 0)
+ {
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ borrow = 1;
+ }
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
+ }
+ }
+ }
+ {
+ fast bignum_digit_type * end_x = (scan_x + x_length);
+ if (borrow != 0)
+ while (scan_x < end_x)
+ {
+ difference = ((*scan_x++) - borrow);
+ if (difference < 0)
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
+ break;
+ }
+ }
+ BIGNUM_ASSERT (borrow == 0);
+ while (scan_x < end_x)
+ (*scan_r++) = (*scan_x++);
+ }
+ return (bignum_trim (r));
}
- Free += Size;
- return Make_Pointer(TC_BIG_FIXNUM, Free-Size);
}
\f
-Pointer
-minus_unsigned_bignum(ARG1, ARG2, sign)
- fast bigdigit *ARG1, *ARG2;
- bigdigit sign;
+/* Multiplication
+ Maximum value for product_low or product_high:
+ ((R * R) + (R * (R - 2)) + (R - 1))
+ Maximum value for carry: ((R * (R - 1)) + (R - 1))
+ where R == BIGNUM_RADIX_ROOT */
+
+static bignum_type
+bignum_multiply_unsigned (x, y, negative_p)
+ bignum_type x;
+ bignum_type y;
+ int negative_p;
{
- 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);
-
- 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))
+ if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
+ {
+ bignum_type z = x;
+ x = y;
+ y = z;
+ }
{
- Diff = *ARG1++ + MAX_DIGIT_SIZE;
- *Answer++ = Get_Digit(Diff);
+ fast bignum_digit_type carry;
+ fast bignum_digit_type y_digit_low;
+ fast bignum_digit_type y_digit_high;
+ fast bignum_digit_type x_digit_low;
+ fast bignum_digit_type x_digit_high;
+ bignum_digit_type product_low;
+ fast bignum_digit_type * scan_r;
+ fast bignum_digit_type * scan_y;
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ bignum_type r =
+ (bignum_allocate_zeroed ((x_length + y_length), negative_p));
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * end_x = (scan_x + x_length);
+ bignum_digit_type * start_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (start_y + y_length);
+ bignum_digit_type * start_r = (BIGNUM_START_PTR (r));
+#define x_digit x_digit_high
+#define y_digit y_digit_high
+#define product_high carry
+ while (scan_x < end_x)
+ {
+ x_digit = (*scan_x++);
+ x_digit_low = (HD_LOW (x_digit));
+ x_digit_high = (HD_HIGH (x_digit));
+ carry = 0;
+ scan_y = start_y;
+ scan_r = (start_r++);
+ while (scan_y < end_y)
+ {
+ y_digit = (*scan_y++);
+ y_digit_low = (HD_LOW (y_digit));
+ y_digit_high = (HD_HIGH (y_digit));
+ product_low =
+ ((*scan_r) +
+ (x_digit_low * y_digit_low) +
+ (HD_LOW (carry)));
+ product_high =
+ ((x_digit_high * y_digit_low) +
+ (x_digit_low * y_digit_high) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan_r++) =
+ (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry =
+ ((x_digit_high * y_digit_high) +
+ (HD_HIGH (product_high)));
+ }
+ (*scan_r) += carry;
+ }
+ return (bignum_trim (r));
+#undef x_digit
+#undef y_digit
+#undef product_high
}
-
- while (TOP1 >= ARG1)
- *Answer++ = *ARG1++;
- trim_bignum((bigdigit *) Free);
- Free += Size;
- return Make_Pointer(TC_BIG_FIXNUM, Free-Size);
}
\f
-/* Addition */
-
-Pointer
-plus_signed_bignum(ARG1, ARG2)
- bigdigit *ARG1, *ARG2;
-{ /* Special Case for answer being zero */
- if (ZERO_BIGNUM(ARG1) && ZERO_BIGNUM(ARG2))
- return (make_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()");
- }
- /*NOTREACHED*/
+static bignum_type
+bignum_multiply_unsigned_small_factor (x, y, negative_p)
+ bignum_type x;
+ bignum_digit_type y;
+ int negative_p;
+{
+ bignum_length_type length_x = (BIGNUM_LENGTH (x));
+ bignum_type p = (bignum_allocate ((length_x + 1), negative_p));
+ bignum_destructive_copy (x, p);
+ (BIGNUM_REF (p, length_x)) = 0;
+ bignum_destructive_scale_up (p, y);
+ return (bignum_trim (p));
}
-/* Subtraction */
-
-Pointer
-minus_signed_bignum(ARG1, ARG2)
- bigdigit *ARG1, *ARG2;
+static void
+bignum_destructive_scale_up (bignum, factor)
+ bignum_type bignum;
+ bignum_digit_type factor;
{
- /* Special Case for answer being zero */
+ fast bignum_digit_type carry = 0;
+ fast bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ fast bignum_digit_type two_digits;
+ fast bignum_digit_type product_low;
+#define product_high carry
+ bignum_digit_type * end = (scan + ((BIGNUM_LENGTH (bignum)) - 1));
+ BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT));
+ while (scan < end)
+ {
+ two_digits = (*scan);
+ product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
+ product_high =
+ ((factor * (HD_HIGH (two_digits))) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry = (HD_HIGH (product_high));
+ }
+ (*scan) += carry;
+ return;
+#undef product_high
+}
- if (ZERO_BIGNUM(ARG1) && ZERO_BIGNUM(ARG2))
- return (make_bignum_zero ());
+static void
+bignum_destructive_add (bignum, n)
+ bignum_type bignum;
+ bignum_digit_type n;
+{
+ fast bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ fast bignum_digit_type digit;
+ digit = ((*scan) + n);
+ if (digit < BIGNUM_RADIX)
+ {
+ (*scan) = digit;
+ return;
+ }
+ (*scan++) = (digit - BIGNUM_RADIX);
+ while (1)
+ {
+ digit = ((*scan) + 1);
+ if (digit < BIGNUM_RADIX)
+ {
+ (*scan) = digit;
+ return;
+ }
+ (*scan++) = (digit - BIGNUM_RADIX);
+ }
+ return;
+}
+\f
+/* Division */
- /* Dispatches According to Sign of Args */
+/* For help understanding this algorithm, see:
+ Knuth, Donald E., "The Art of Computer Programming",
+ volume 2, "Seminumerical Algorithms"
+ section 4.3.1, "Multiple-Precision Arithmetic". */
- 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()");
+static void
+bignum_divide_unsigned_large_denominator (numerator, denominator,
+ quotient, remainder,
+ q_negative_p, r_negative_p)
+ bignum_type numerator;
+ bignum_type denominator;
+ bignum_type * quotient;
+ bignum_type * remainder;
+ int q_negative_p;
+ int r_negative_p;
+{
+ bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
+ bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
+ bignum_type q =
+ ((quotient != ((bignum_type *) 0))
+ ? (bignum_allocate ((length_n - length_d), q_negative_p))
+ : BIGNUM_OUT_OF_BAND);
+ bignum_type u = (bignum_allocate (length_n, r_negative_p));
+ int shift = 0;
+ BIGNUM_ASSERT (length_d > 1);
+ {
+ fast bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
+ while (v1 < (BIGNUM_RADIX / 2))
+ {
+ v1 <<= 1;
+ shift += 1;
+ }
}
- /*NOTREACHED*/
+ if (shift == 0)
+ {
+ bignum_destructive_copy (numerator, u);
+ (BIGNUM_REF (u, (length_n - 1))) = 0;
+ bignum_divide_unsigned_normalized (u, denominator, q);
+ }
+ else
+ {
+ bignum_type v = (bignum_allocate (length_d, 0));
+ bignum_destructive_normalization (numerator, u, shift);
+ bignum_destructive_normalization (denominator, v, shift);
+ bignum_divide_unsigned_normalized (u, v, q);
+ BIGNUM_DEALLOCATE (v);
+ if (remainder != ((bignum_type *) 0))
+ bignum_destructive_unnormalization (u, shift);
+ }
+ if (quotient != ((bignum_type *) 0))
+ (*quotient) = (bignum_trim (q));
+ if (remainder != ((bignum_type *) 0))
+ (*remainder) = (bignum_trim (u));
+ else
+ BIGNUM_DEALLOCATE (u);
+ return;
}
\f
-/* Multiplication */
-
-Pointer
-multiply_unsigned_bignum(ARG1, ARG2, sign)
- fast bigdigit *ARG1, *ARG2;
- bigdigit sign;
+static void
+bignum_divide_unsigned_normalized (u, v, q)
+ bignum_type u;
+ bignum_type v;
+ bignum_type q;
{
- 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;
-
- /* Main loops for MULTIPLY */
-
- size = LEN(ARG2);
- Answer = Bignum_Bottom(Answer) + size;
- TOP1 = Bignum_Top(ARG1);
- TOP2 = Bignum_Top(ARG2);
- ARG2 = TOP2;
+ bignum_length_type u_length = (BIGNUM_LENGTH (u));
+ bignum_length_type v_length = (BIGNUM_LENGTH (v));
+ bignum_digit_type * u_start = (BIGNUM_START_PTR (u));
+ bignum_digit_type * u_scan = (u_start + u_length);
+ bignum_digit_type * u_scan_limit = (u_start + v_length);
+ bignum_digit_type * u_scan_start = (u_scan - v_length);
+ bignum_digit_type * v_start = (BIGNUM_START_PTR (v));
+ bignum_digit_type * v_end = (v_start + v_length);
+ bignum_digit_type * q_scan;
+ bignum_digit_type v1 = (v_end[-1]);
+ bignum_digit_type v2 = (v_end[-2]);
+ fast bignum_digit_type ph; /* high half of double-digit product */
+ fast bignum_digit_type pl; /* low half of double-digit product */
+ fast bignum_digit_type guess;
+ fast bignum_digit_type gh; /* high half-digit of guess */
+ fast bignum_digit_type ch; /* high half of double-digit comparand */
+ fast bignum_digit_type v2l = (HD_LOW (v2));
+ fast bignum_digit_type v2h = (HD_HIGH (v2));
+ fast bignum_digit_type cl; /* low half of double-digit comparand */
+#define gl ph /* low half-digit of guess */
+#define uj pl
+#define qj ph
+ bignum_digit_type gm; /* memory loc for reference parameter */
+ if (q != BIGNUM_OUT_OF_BAND)
+ q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q)));
+ while (u_scan_limit < u_scan)
+ {
+ uj = (*--u_scan);
+ /* comparand =
+ (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
+ guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
+ cl = (u_scan[-2]);
+ ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
+ guess = gm;
+ if (guess > (BIGNUM_RADIX - 1))
+ guess = (BIGNUM_RADIX - 1);
+ while (1)
+ {
+ /* product = (guess * v2); */
+ gl = (HD_LOW (guess));
+ gh = (HD_HIGH (guess));
+ pl = (v2l * gl);
+ ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
+ pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
+ ph = ((v2h * gh) + (HD_HIGH (ph)));
+ /* if (comparand >= product) */
+ if ((ch > ph) || ((ch == ph) && (cl >= pl)))
+ break;
+ guess -= 1;
+ /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
+ ch += v1;
+ /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
+ if (ch >= BIGNUM_RADIX)
+ break;
+ }
+ qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
+ if (q != BIGNUM_OUT_OF_BAND)
+ (*--q_scan) = qj;
+ }
+ return;
+#undef gl
+#undef uj
+#undef qj
+}
\f
- for (ARG1 = Bignum_Bottom(ARG1); TOP1 >= ARG1; ARG1++, Answer++)
+static bignum_digit_type
+bignum_divide_subtract (v_start, v_end, guess, u_start)
+ bignum_digit_type * v_start;
+ bignum_digit_type * v_end;
+ bignum_digit_type guess;
+ bignum_digit_type * u_start;
+{
+ bignum_digit_type * v_scan = v_start;
+ bignum_digit_type * u_scan = u_start;
+ fast bignum_digit_type carry = 0;
+ if (guess == 0) return (0);
{
- if (*ARG1 != 0)
- {
- Prod = 0;
- Answer -= size;
- for (ARG2 = TOP2 - size + 1; TOP2 >= ARG2; ++ARG2)
+ bignum_digit_type gl = (HD_LOW (guess));
+ bignum_digit_type gh = (HD_HIGH (guess));
+ fast bignum_digit_type v;
+ fast bignum_digit_type pl;
+ fast bignum_digit_type vl;
+#define vh v
+#define ph carry
+#define diff pl
+ while (v_scan < v_end)
+ {
+ v = (*v_scan++);
+ vl = (HD_LOW (v));
+ vh = (HD_HIGH (v));
+ pl = ((vl * gl) + (HD_LOW (carry)));
+ ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
+ diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
+ if (diff < 0)
+ {
+ (*u_scan++) = (diff + BIGNUM_RADIX);
+ carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
+ }
+ else
+ {
+ (*u_scan++) = diff;
+ carry = ((vh * gh) + (HD_HIGH (ph)));
+ }
+ }
+ if (carry == 0)
+ return (guess);
+ diff = ((*u_scan) - carry);
+ if (diff < 0)
+ (*u_scan) = (diff + BIGNUM_RADIX);
+ else
{
- Prod = *ARG1 * *ARG2 + *Answer + Get_Carry(Prod);
- *Answer++ = Get_Digit(Prod);
+ (*u_scan) = diff;
+ return (guess);
}
- *Answer = Get_Carry(Prod);
- }
+#undef vh
+#undef ph
+#undef diff
}
-
- /* Trims Answer */
-
- Answer = BIGNUM(Free);
- if (*(Bignum_Top(Answer)) == 0)
+ /* Subtraction generated carry, implying guess is one too large.
+ Add v back in to bring it back down. */
+ v_scan = v_start;
+ u_scan = u_start;
+ carry = 0;
+ while (v_scan < v_end)
+ {
+ bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*u_scan++) = sum;
+ carry = 0;
+ }
+ else
+ {
+ (*u_scan++) = (sum - BIGNUM_RADIX);
+ carry = 1;
+ }
+ }
+ if (carry == 1)
+ (*u_scan) += 1;
+ return (guess - 1);
+}
+\f
+static void
+bignum_divide_unsigned_medium_denominator (numerator, denominator,
+ quotient, remainder,
+ q_negative_p, r_negative_p)
+ bignum_type numerator;
+ bignum_digit_type denominator;
+ bignum_type * quotient;
+ bignum_type * remainder;
+ int q_negative_p;
+ int r_negative_p;
+{
+ bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
+ bignum_length_type length_q;
+ bignum_type q;
+ int shift = 0;
+ /* Because `bignum_digit_divide' requires a normalized denominator. */
+ while (denominator < (BIGNUM_RADIX / 2))
+ {
+ denominator <<= 1;
+ shift += 1;
+ }
+ if (shift == 0)
+ {
+ length_q = length_n;
+ q = (bignum_allocate (length_q, q_negative_p));
+ bignum_destructive_copy (numerator, q);
+ }
+ else
+ {
+ length_q = (length_n + 1);
+ q = (bignum_allocate (length_q, q_negative_p));
+ bignum_destructive_normalization (numerator, q, shift);
+ }
{
- LEN(Answer) -= 1;
- *((Pointer *) Answer) = Make_Header(Align(LEN(Answer)));
+ fast bignum_digit_type r = 0;
+ fast bignum_digit_type * start = (BIGNUM_START_PTR (q));
+ fast bignum_digit_type * scan = (start + length_q);
+ bignum_digit_type qj;
+ if (quotient != ((bignum_type *) 0))
+ {
+ while (start < scan)
+ {
+ r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
+ (*scan) = qj;
+ }
+ (*quotient) = (bignum_trim (q));
+ }
+ else
+ {
+ while (start < scan)
+ r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
+ BIGNUM_DEALLOCATE (q);
+ }
+ if (remainder != ((bignum_type *) 0))
+ {
+ if (shift != 0)
+ r >>= shift;
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+ }
}
- Free += Size;
- return Make_Pointer(TC_BIG_FIXNUM, Free-Size);
+ return;
}
-
-Pointer
-multiply_signed_bignum(ARG1, ARG2)
- bigdigit *ARG1, *ARG2;
+\f
+static void
+bignum_destructive_normalization (source, target, shift_left)
+ bignum_type source;
+ bignum_type target;
+ int shift_left;
{
- if (ZERO_BIGNUM(ARG1) || ZERO_BIGNUM(ARG2))
- return (make_bignum_zero ());
+ fast bignum_digit_type digit;
+ fast bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ fast bignum_digit_type carry = 0;
+ fast bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
+ bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
+ bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
+ int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
+ bignum_digit_type mask = ((1 << shift_right) - 1);
+ while (scan_source < end_source)
+ {
+ digit = (*scan_source++);
+ (*scan_target++) = (((digit & mask) << shift_left) | carry);
+ carry = (digit >> shift_right);
+ }
+ if (scan_target < end_target)
+ (*scan_target) = carry;
+ else
+ BIGNUM_ASSERT (carry == 0);
+ return;
+}
- 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()");
- }
- /*NOTREACHED*/
+static void
+bignum_destructive_unnormalization (bignum, shift_right)
+ bignum_type bignum;
+ int shift_right;
+{
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ fast bignum_digit_type digit;
+ fast bignum_digit_type carry = 0;
+ int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
+ bignum_digit_type mask = ((1 << shift_right) - 1);
+ while (start < scan)
+ {
+ digit = (*--scan);
+ (*scan) = ((digit >> shift_right) | carry);
+ carry = ((digit & mask) << shift_left);
+ }
+ BIGNUM_ASSERT (carry == 0);
+ return;
}
\f
-/* This is the guts of the division algorithm. The storage
- * allocation and other hairy prep work is done in the superior
- * routines. ARG1 and ARG2 are fresh copies, ARG1 will
- * ultimately become the Remainder. Storage already
- * allocated for all four parameters.
- */
+/* This is a reduced version of the division algorithm, applied to the
+ case of dividing two bignum digits by one bignum digit. It is
+ assumed that the numerator and denominator are normalized. */
-static Pointer BIG_A[TEMP_SIZE], BIG_B[TEMP_SIZE];
+#define BDD_STEP(qn, j) \
+{ \
+ uj = (u[j]); \
+ uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
+ guess = (uj_uj1 / v1); \
+ comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
+ if (guess > (BIGNUM_RADIX_ROOT - 1)) \
+ guess = (BIGNUM_RADIX_ROOT - 1); \
+ while ((guess * v2) > comparand) \
+ { \
+ guess -= 1; \
+ comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
+ if (comparand >= BIGNUM_RADIX) \
+ break; \
+ } \
+ qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \
+}
-Pointer
-div_internal(ARG1, ARG2, Quotient)
- bigdigit *ARG1, *ARG2, *Quotient;
+static bignum_digit_type
+bignum_digit_divide (uh, ul, v, q)
+ bignum_digit_type uh;
+ bignum_digit_type ul;
+ bignum_digit_type v;
+ bignum_digit_type * q; /* return value */
{
- fast bigdigit *SCAN,*PROD;
- fast bigdouble Digit, Prod;
- fast bigdouble guess, dvsr2, dvsr1;
- fast bigdigit *LIMIT, *QUOT_SCAN;
- bigdigit *Big_A, *Big_B;
-
- Big_A = BIGNUM(BIG_A);
- 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);
-\f
- /* Main Loop for div_internal() */
-
- while (QUOT_SCAN >= Quotient)
- {
- if (dvsr1 <= *ARG1) guess = RADIX - 1;
- else
- { /* This should be
- * guess = (Mul_Radix(*ARG1) + *(ARG1 - 1)) / dvsr1;
- * but because of overflow problems ...
- */
+ fast bignum_digit_type guess;
+ fast bignum_digit_type comparand;
+ fast bignum_digit_type v1 = (HD_HIGH (v));
+ fast bignum_digit_type v2 = (HD_LOW (v));
+ fast bignum_digit_type uj;
+ fast bignum_digit_type uj_uj1;
+ bignum_digit_type q1;
+ bignum_digit_type q2;
+ bignum_digit_type u [4];
+ if (uh == 0)
+ {
+ if (ul < v)
+ {
+ (*q) = 0;
+ return (ul);
+ }
+ else if (ul == v)
+ {
+ (*q) = 1;
+ return (0);
+ }
+ }
+ (u[0]) = (HD_HIGH (uh));
+ (u[1]) = (HD_LOW (uh));
+ (u[2]) = (HD_HIGH (ul));
+ (u[3]) = (HD_LOW (ul));
+ v1 = (HD_HIGH (v));
+ v2 = (HD_LOW (v));
+ BDD_STEP (q1, 0);
+ BDD_STEP (q2, 1);
+ (*q) = (HD_CONS (q1, q2));
+ return (HD_CONS ((u[2]), (u[3])));
+}
- 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);
+#undef BDD_STEP
\f
- 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. */
+#define BDDS_MULSUB(vn, un, carry_in) \
+{ \
+ product = ((vn * guess) + carry_in); \
+ diff = (un - (HD_LOW (product))); \
+ if (diff < 0) \
+ { \
+ un = (diff + BIGNUM_RADIX_ROOT); \
+ carry = ((HD_HIGH (product)) + 1); \
+ } \
+ else \
+ { \
+ un = diff; \
+ carry = (HD_HIGH (product)); \
+ } \
+}
- 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);
- }
+#define BDDS_ADD(vn, un, carry_in) \
+{ \
+ sum = (vn + un + carry_in); \
+ if (sum < BIGNUM_RADIX_ROOT) \
+ { \
+ un = sum; \
+ carry = 0; \
+ } \
+ else \
+ { \
+ un = (sum - BIGNUM_RADIX_ROOT); \
+ carry = 1; \
+ } \
}
-\f
-/* div_signed_bignum() differentiates between all the possible
- * cases and allocates storage for the quotient, remainder, and
- * any intrmediate storage needed.
- */
-Pointer
-div_signed_bignum (ARG1, ARG2)
- bigdigit *ARG1, *ARG2;
+static bignum_digit_type
+bignum_digit_divide_subtract (v1, v2, guess, u)
+ bignum_digit_type v1;
+ bignum_digit_type v2;
+ bignum_digit_type guess;
+ bignum_digit_type u [];
{
- 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);
+ fast bignum_digit_type product;
+ fast bignum_digit_type diff;
+ fast bignum_digit_type carry;
+ BDDS_MULSUB (v2, (u[2]), 0);
+ BDDS_MULSUB (v1, (u[1]), carry);
+ if (carry == 0)
+ return (guess);
+ diff = ((u[0]) - carry);
+ if (diff < 0)
+ (u[0]) = (diff + BIGNUM_RADIX);
+ else
+ {
+ (u[0]) = diff;
+ return (guess);
+ }
}
- 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);
+ fast bignum_digit_type sum;
+ fast bignum_digit_type carry;
+ BDDS_ADD(v2, (u[2]), 0);
+ BDDS_ADD(v1, (u[1]), carry);
+ if (carry == 1)
+ (u[0]) += 1;
}
- 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 =
- (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);
+ return (guess - 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);
- }
+#undef BDDS_MULSUB
+#undef BDDS_ADD
\f
-/* Determines sign of the quotient and remainder */
-
- SIGN(REMD) = POSITIVE;
- SIGN(QUOT) = POSITIVE;
- switch(Categorize_Sign(ARG1,ARG2))
- { case ARG2_NEGATIVE :
- SIGN(QUOT) = NEGATIVE;
- break;
- case ARG1_NEGATIVE :
- SIGN(QUOT) = NEGATIVE;
- case BOTH_NEGATIVE :
- SIGN(REMD) = NEGATIVE;
- break;
- case BOTH_POSITIVE : break;
- default : Sign_Error("divide_bignum()");
- }
- /* Glue the two results in a list and return as answer */
- Cons_Cell[CONS_CAR] = Make_Pointer(TC_BIG_FIXNUM, (Pointer *) QUOT);
- Cons_Cell[CONS_CDR] = Make_Pointer(TC_BIG_FIXNUM, (Pointer *) REMD);
- return Make_Pointer(TC_LIST, Cons_Cell);
+static void
+bignum_divide_unsigned_small_denominator (numerator, denominator,
+ quotient, remainder,
+ q_negative_p, r_negative_p)
+ bignum_type numerator;
+ bignum_digit_type denominator;
+ bignum_type * quotient;
+ bignum_type * remainder;
+ int q_negative_p;
+ int r_negative_p;
+{
+ bignum_type q = (bignum_new_sign (numerator, q_negative_p));
+ bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
+ (*quotient) = (bignum_trim (q));
+ if (remainder != ((bignum_type *) 0))
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+ return;
}
-\f
-/* Utility for debugging */
-#ifdef ENABLE_DEBUGGING_TOOLS
-void
-print_digits(name, num, how_many)
- char *name;
- bigdigit *num;
- int how_many;
-{
- int NDigits = LEN(num);
- int limit;
+/* Given (denominator > 1), it is fairly easy to show that
+ (quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see
+ that all digits are < BIGNUM_RADIX. */
- 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;
+static bignum_digit_type
+bignum_destructive_scale_down (bignum, denominator)
+ bignum_type bignum;
+ fast bignum_digit_type denominator;
+{
+ fast bignum_digit_type numerator;
+ fast bignum_digit_type remainder = 0;
+ fast bignum_digit_type two_digits;
+#define quotient_high remainder
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT));
+ while (start < scan)
+ {
+ two_digits = (*--scan);
+ numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
+ quotient_high = (numerator / denominator);
+ numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
+ (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
+ remainder = (numerator % denominator);
+ }
+ return (remainder);
+#undef quotient_high
}
-#endif
\f
-DEFINE_PRIMITIVE ("COERCE-FIXNUM-TO-BIGNUM", Prim_fix_to_big, 1, 1,
- "Returns the bignum that corresponds to FIXNUM.")
+static bignum_type
+bignum_remainder_unsigned_small_denominator (n, d, negative_p)
+ bignum_type n;
+ bignum_digit_type d;
+ int negative_p;
{
- PRIMITIVE_HEADER (1);
-
- CHECK_ARG (1, FIXNUM_P);
- PRIMITIVE_RETURN (Fix_To_Big (ARG_REF (1)));
+ fast bignum_digit_type two_digits;
+ bignum_digit_type * start = (BIGNUM_START_PTR (n));
+ fast bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n)));
+ fast bignum_digit_type r = 0;
+ BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT));
+ while (start < scan)
+ {
+ two_digits = (*--scan);
+ r =
+ ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
+ (HD_LOW (two_digits))))
+ % d);
+ }
+ return (bignum_digit_to_bignum (r, negative_p));
}
-DEFINE_PRIMITIVE ("COERCE-BIGNUM-TO-FIXNUM", Prim_big_to_fix, 1, 1,
- "Returns the fixnum that corresponds to BIGNUM.
-If BIGNUM cannot be represented as a fixnum, returns BIGNUM.")
+static bignum_type
+bignum_digit_to_bignum (digit, negative_p)
+ fast bignum_digit_type digit;
+ int negative_p;
{
- PRIMITIVE_HEADER (1);
-
- CHECK_ARG (1, BIGNUM_P);
- PRIMITIVE_RETURN (Big_To_Fix (ARG_REF (1)));
+ if (digit == 0)
+ return (BIGNUM_ZERO ());
+ else
+ {
+ fast bignum_type result = (bignum_allocate (1, negative_p));
+ (BIGNUM_REF (result, 0)) = digit;
+ return (result);
+ }
}
+\f
+/* Allocation */
-DEFINE_PRIMITIVE ("LISTIFY-BIGNUM", Prim_listify_bignum, 2, 2,
- "Returns a list of the digits of BIGNUM in RADIX.")
+static bignum_type
+bignum_allocate (length, negative_p)
+ fast bignum_length_type length;
+ int negative_p;
{
- Pointer bignum;
- long radix;
- PRIMITIVE_HEADER (2);
-
- Set_Time_Zone (Zone_Math);
-
- CHECK_ARG (1, BIGNUM_P);
- bignum = (ARG_REF (1));
- radix = (arg_nonnegative_integer (2, (BIGGEST_FIXNUM + 1)));
- if (BIGNUM_ZERO_P (bignum))
- PRIMITIVE_RETURN (cons ((MAKE_UNSIGNED_FIXNUM (0)), EMPTY_LIST));
+ BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
{
- Pointer working_copy = (bignum_copy (bignum));
- fast bigdigit * start_copy = (BIGNUM_START_PTR (working_copy));
- fast bigdigit * end_copy = (BIGNUM_END_PTR (working_copy));
- fast Pointer previous_cdr = EMPTY_LIST;
- while (end_copy > start_copy)
- {
- if ((end_copy [-1]) == 0)
- end_copy -= 1;
- else
- previous_cdr =
- (cons
- ((MAKE_UNSIGNED_FIXNUM (scale_down_self (working_copy, radix))),
- previous_cdr));
- }
- PRIMITIVE_RETURN (previous_cdr);
+ fast bignum_type result = (BIGNUM_ALLOCATE (length));
+ BIGNUM_SET_HEADER (result, length, negative_p);
+ return (result);
}
}
-\f
-#define BINARY_PRIMITIVE(operator) \
-{ \
- PRIMITIVE_HEADER (2); \
- \
- Set_Time_Zone (Zone_Math); \
- CHECK_ARG (1, BIGNUM_P); \
- CHECK_ARG (2, BIGNUM_P); \
- { \
- Pointer * original_free = Free; \
- Pointer result = \
- (operator \
- ((BIGNUM (Get_Pointer (ARG_REF (1)))), \
- (BIGNUM (Get_Pointer (ARG_REF (2)))))); \
- if (Consistency_Check && ((Get_Pointer (result)) != original_free)) \
- { \
- fprintf (stderr, \
- "\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)) \
- { \
- fprintf (stderr, \
- "\nBignum operation result at 0x%x, length 0x%x\n", \
- (Address (result)), \
- (Vector_Length (result))); \
- Microcode_Termination (TERM_EXIT); \
- } \
- PRIMITIVE_RETURN (result); \
- } \
-}
-
-DEFINE_PRIMITIVE ("PLUS-BIGNUM", Prim_plus_bignum, 2, 2, 0)
-BINARY_PRIMITIVE (plus_signed_bignum)
-
-DEFINE_PRIMITIVE ("MINUS-BIGNUM", Prim_minus_bignum, 2, 2, 0)
-BINARY_PRIMITIVE (minus_signed_bignum)
-DEFINE_PRIMITIVE ("MULTIPLY-BIGNUM", Prim_multiply_bignum, 2, 2, 0)
-BINARY_PRIMITIVE (multiply_signed_bignum)
-\f
-/* (DIVIDE-BIGNUM ONE-BIGNUM ANOTHER_BIGNUM)
- * returns a cons of the bignum quotient and remainder of both arguments.
- */
-
-DEFINE_PRIMITIVE ("DIVIDE-BIGNUM", Prim_divide_bignum, 2, 2, 0)
+static bignum_type
+bignum_allocate_zeroed (length, negative_p)
+ fast bignum_length_type length;
+ int negative_p;
{
- Pointer Result, *End_Of_First, *First, *Second, *original_free=Free;
- Primitive_2_Args();
+ BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
+ {
+ fast bignum_type result = (BIGNUM_ALLOCATE (length));
+ fast bignum_digit_type * scan = (BIGNUM_START_PTR (result));
+ fast bignum_digit_type * end = (scan + length);
+ BIGNUM_SET_HEADER (result, length, negative_p);
+ while (scan < end)
+ (*scan++) = 0;
+ return (result);
+ }
+}
- 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)
+static bignum_type
+bignum_shorten_length (bignum, length)
+ fast bignum_type bignum;
+ fast bignum_length_type length;
+{
+ fast bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
+ BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
+ if (length < current_length)
{
- fprintf(stderr, "\nBignum_Divide: results swapped.\n");
- Microcode_Termination(TERM_EXIT);
+ BIGNUM_SET_HEADER
+ (bignum, length, ((length != 0) && (BIGNUM_NEGATIVE_P (bignum))));
+ BIGNUM_REDUCE_LENGTH (bignum, bignum, length)
}
- else if (First != original_free+2)
+ return (bignum);
+}
+
+static bignum_type
+bignum_trim (bignum)
+ bignum_type bignum;
+{
+ fast bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ fast bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
+ fast bignum_digit_type * scan = end;
+ while ((start < scan) && ((*--scan) == 0))
+ ;
+ scan += 1;
+ if (scan < end)
{
- fprintf(stderr, "\nBignum Divide: hole at start\n");
- Microcode_Termination(TERM_EXIT);
+ fast bignum_length_type length = (scan - start);
+ BIGNUM_SET_HEADER
+ (bignum, length, ((length != 0) && (BIGNUM_NEGATIVE_P (bignum))));
+ BIGNUM_REDUCE_LENGTH (bignum, bignum, length);
}
- }
- End_Of_First = First + 1 + (OBJECT_DATUM (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 + (OBJECT_DATUM (Second[0]));
- if (Bignum_Debug)
- printf("\nEnd=0x%x\n", Free);
- return Result;
+ return (bignum);
}
\f
-/* All the unary bignum predicates take one argument and return NIL if
- it is not a bignum. Otherwise, they return a fixnum 1 if the
- predicate is true or a fixnum 0 if it is false. This convention of
- NIL/0/1 is used for all numeric predicates so that the generic
- dispatch can detect "inapplicable" as distinct from "false" answer.
-*/
+/* Copying */
-#define Unary_Predicate(Test) \
-{ \
- bigdigit *ARG; \
- Primitive_1_Arg(); \
- \
- Arg_1_Type(TC_BIG_FIXNUM); \
- Set_Time_Zone(Zone_Math); \
- ARG = BIGNUM(Get_Pointer(Arg1)); \
- return (MAKE_UNSIGNED_FIXNUM (((Test) ? 1 : 0))); \
+static bignum_type
+bignum_copy (source)
+ fast bignum_type source;
+{
+ fast bignum_type target =
+ (bignum_allocate ((BIGNUM_LENGTH (source)), (BIGNUM_NEGATIVE_P (source))));
+ bignum_destructive_copy (source, target);
+ return (target);
}
-DEFINE_PRIMITIVE ("ZERO-BIGNUM?", Prim_zero_bignum, 1, 1, 0)
-Unary_Predicate(LEN(ARG) == 0)
-
-DEFINE_PRIMITIVE ("POSITIVE-BIGNUM?", Prim_positive_bignum, 1, 1, 0)
-Unary_Predicate((LEN(ARG) != 0) && POS_BIGNUM(ARG))
-
-DEFINE_PRIMITIVE ("NEGATIVE-BIGNUM?", Prim_negative_bignum, 1, 1, 0)
-Unary_Predicate((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.
-*/
-\f
-#define Binary_Predicate(Code) \
-{ \
- int result; \
- Primitive_2_Args(); \
- \
- Arg_1_Type(TC_BIG_FIXNUM); \
- Arg_2_Type(TC_BIG_FIXNUM); \
- Set_Time_Zone(Zone_Math); \
- if (big_compare(BIGNUM(Get_Pointer(Arg1)), \
- BIGNUM(Get_Pointer(Arg2))) == Code) \
- result = 1; \
- else \
- result = 0; \
- return (MAKE_UNSIGNED_FIXNUM (result)); \
+static bignum_type
+bignum_new_sign (bignum, negative_p)
+ fast bignum_type bignum;
+ int negative_p;
+{
+ fast bignum_type result =
+ (bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p));
+ bignum_destructive_copy (bignum, result);
+ return (result);
}
-DEFINE_PRIMITIVE ("EQUAL-BIGNUM?", Prim_equal_bignum, 2, 2, 0)
-Binary_Predicate(EQUAL)
+static bignum_type
+bignum_maybe_new_sign (bignum, negative_p)
+ fast bignum_type bignum;
+ int negative_p;
+{
+#ifndef BIGNUM_FORCE_NEW_RESULTS
+ if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p))
+ return (bignum);
+ else
+#endif /* not BIGNUM_FORCE_NEW_RESULTS */
+ {
+ fast bignum_type result =
+ (bignum_allocate ((BIGNUM_LENGTH (bignum)), negative_p));
+ bignum_destructive_copy (bignum, result);
+ return (result);
+ }
+}
-DEFINE_PRIMITIVE ("GREATER-THAN-BIGNUM?", Prim_greater_bignum, 2, 2, 0)
-Binary_Predicate(ONE_BIGGER)
+static void
+bignum_destructive_copy (source, target)
+ bignum_type source;
+ bignum_type target;
+{
+ fast bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ fast bignum_digit_type * end_source =
+ (scan_source + (BIGNUM_LENGTH (source)));
+ fast bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
+ while (scan_source < end_source)
+ (*scan_target++) = (*scan_source++);
+ return;
+}
-DEFINE_PRIMITIVE ("LESS-THAN-BIGNUM?", Prim_less_bignum, 2, 2, 0)
-Binary_Predicate(TWO_BIGGER)
+static void
+bignum_destructive_zero (bignum)
+ fast bignum_type bignum;
+{
+ fast bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ fast bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
+ while (scan < end)
+ (*scan++) = 0;
+ return;
+}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bignum.h,v 9.25 1989/09/20 23:06:04 cph Rel $
+
+Copyright (c) 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bignum.h,v 9.24 1988/08/15 20:36:57 cph Rel $
+/* External Interface to Bignum Code */
- Head file for bignums. This is shared by bignum.c and generic.c.
-*/
-\f
-#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
+/* The `unsigned long' type is used for the conversion procedures
+ `bignum_to_long' and `long_to_bignum'. Older implementations of C
+ don't support this type; if you have such an implementation you can
+ disable these procedures using the following flag (alternatively
+ you could write alternate versions that don't require this type). */
+/* #define BIGNUM_NO_ULONG */
\f
-#define POSITIVE 1
-#define NEGATIVE 0
-
-/* The representation of a BIGNUM is machine dependent. For a VAX-11
- * it is as follows:
- */
-
-#ifdef pdp10
-typedef unsigned int bigdigit;
-typedef long bigdouble;
-#define SHIFT 16
-#define factor 1
-#else
-#if ((USHORT_SIZE * 2) <= ULONG_SIZE)
-#define bigdigit unsigned short
-#define bigdouble long /* Should be unsigned */
-#define SHIFT USHORT_SIZE
-#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 */
+#ifdef MIT_SCHEME
-#define TEMP_SIZE Align(4)
+typedef SCHEME_OBJECT bignum_type;
+#define BIGNUM_OUT_OF_BAND SHARP_F
-/* Macros for making BIGNUM headers */
-
-#define Make_Header(l) Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,(l-1))
-#define Prepare_Header(Bignum,Length,Sign) \
- { *((Pointer *) Bignum) = Make_Header(Align(Length)); \
- SIGN(Bignum) = Sign; \
- LEN(Bignum) = Length; \
- }
-\f
-/* Predicates coded as macros for determining the sign of BIGNUM's */
-
-#define POS_BIGNUM(Bignum) (SIGN(Bignum) == POSITIVE)
-#define NEG_BIGNUM(Bignum) (SIGN(Bignum) == NEGATIVE)
-#define ZERO_BIGNUM(Bignum) (LEN(Bignum) == 0)
-#define NON_ZERO_BIGNUM(Bignum) (LEN(Bignum) != 0)
-
-
-/* Coerces a C pointer to point to BIGNUM digits */
-
-#define BIGNUM(ptr) ((bigdigit *) ptr)
-
-/* Macros for manipulating long BIGNUM digits */
+#else
-#define RADIX (1<<SHIFT)
-#define MAX_DIGIT_SIZE (RADIX-1)
-#define CARRY_MASK (MAX_DIGIT_SIZE<<SHIFT)
-#define DIGIT_MASK MAX_DIGIT_SIZE
-#define DIV_MASK ((1<<DELTA)-1)
-#define Get_Carry(lw) (((lw & CARRY_MASK) >> SHIFT) & DIGIT_MASK)
-#define Get_Digit(lw) (lw & DIGIT_MASK)
-#define Mul_Radix(sw) (sw << SHIFT)
-#define Div_Radix(lw) ((lw >> SHIFT) & DIV_MASK)
-#define Rem_Radix(lw) (lw & DIGIT_MASK)
+typedef long * bignum_type;
+#define BIGNUM_OUT_OF_BAND ((bignum_type) 0)
-/* Length of the BIGNUM that contains the largest FIXNUM */
+#endif
-#define FIXNUM_LENGTH_AS_BIGNUM ((FIXNUM_LENGTH + (SHIFT - 1)) / SHIFT)
-#define C_INTEGER_LENGTH_AS_BIGNUM ((POINTER_LENGTH + (SHIFT - 1)) / SHIFT)
-\f
-/* Cases returned by the comparison function big_compare() */
-
-#define EQUAL 0
-#define ONE_BIGGER 1
-#define TWO_BIGGER 2
-
-/* Categorize_Sign() takes two bignum's and classify them according
- * to four possible cases, depending on each's sign. Depends on
- * definition of POSITIVE and NEGATIVE, earlier!!!
- */
-
-#define Categorize_Sign(ARG1, ARG2) ((SIGN(ARG1) << 1) | SIGN(ARG2))
-#define BOTH_NEGATIVE 0
-#define ARG1_NEGATIVE 1
-#define ARG2_NEGATIVE 2
-#define BOTH_POSITIVE 3
-#define Sign_Error(proc) \
- { printf(proc); \
- printf(" -- Sign Determination Error\n"); \
- printf("Possibly Uncanonicalized Bignum\n"); \
- return ERR_UNDEFINED_PRIMITIVE; \
- }
-
-#define Fetch_Bignum(big) BIGNUM(Get_Pointer(big))
-
-#define Bignum_Operation(Object, Result) \
- Result = (Object); \
- Free = Nth_Vector_Loc(Result, Vector_Length(Result)+1); \
- Result = Big_To_Fix(Result);
-\f
-#define Divide_Bignum_Operation(Object, Result) \
-{ Pointer *End_Of_First, *First, *Second; \
- Result = (Object); \
- First = Get_Pointer(Vector_Ref(Result, CONS_CAR)); \
- Second = Get_Pointer(Vector_Ref(Result, CONS_CDR)); \
- End_Of_First = First+1+Get_Integer(First[0]); \
- if (End_Of_First != Second) \
- { *End_Of_First = \
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Second-End_Of_First)-1); \
- if (Bignum_Debug) printf("\nGap=0x%x\n", (Second-End_Of_First)-1); \
- } \
- Free = Second+1+Get_Integer(Second[0]); \
- Vector_Set(Result,CONS_CAR,Big_To_Fix(Vector_Ref(Result,CONS_CAR))); \
- Vector_Set(Result,CONS_CDR,Big_To_Fix(Vector_Ref(Result,CONS_CDR))); \
-}
+enum bignum_comparison
+{
+ bignum_comparison_equal, bignum_comparison_less, bignum_comparison_greater
+};
+
+#ifdef __STDC__
+
+typedef void * bignum_procedure_context;
+extern bignum_type bignum_make_zero (void);
+extern bignum_type bignum_make_one (int negative_p);
+extern int bignum_equal_p (bignum_type, bignum_type);
+extern enum bignum_comparison bignum_test (bignum_type);
+extern enum bignum_comparison bignum_compare (bignum_type, bignum_type);
+extern bignum_type bignum_add (bignum_type, bignum_type);
+extern bignum_type bignum_subtract (bignum_type, bignum_type);
+extern bignum_type bignum_negate (bignum_type);
+extern bignum_type bignum_multiply (bignum_type, bignum_type);
+extern int bignum_divide
+ (bignum_type numerator, bignum_type denominator,
+ bignum_type * quotient, bignum_type * remainder);
+#ifndef BIGNUM_NO_ULONG
+extern bignum_type long_to_bignum (long);
+extern long bignum_to_long (bignum_type);
+#endif /* not BIGNUM_NO_ULONG */
+extern bignum_type double_to_bignum (double);
+extern double bignum_to_double (bignum_type);
+extern int bignum_fits_in_word_p
+ (bignum_type, long word_length, int twos_complement_p);
+extern bignum_type bignum_length_in_bits (bignum_type);
+extern bignum_type bignum_length_upper_limit (void);
+extern bignum_type digit_stream_to_bignum
+ (unsigned int n_digits,
+ unsigned int (*producer) (), bignum_procedure_context context,
+ unsigned int radix, int negative_p);
+extern void bignum_to_digit_stream
+ (bignum_type, unsigned int radix,
+ void (*consumer) (), bignum_procedure_context context);
+extern long bignum_max_digit_stream_radix (void);
+
+#else /* not __STDC__ */
+
+typedef char * bignum_procedure_context;
+extern bignum_type bignum_make_zero ();
+extern bignum_type bignum_make_one ();
+extern int bignum_equal_p ();
+extern enum bignum_comparison bignum_test ();
+extern enum bignum_comparison bignum_compare ();
+extern bignum_type bignum_add ();
+extern bignum_type bignum_subtract ();
+extern bignum_type bignum_negate ();
+extern bignum_type bignum_multiply ();
+extern int bignum_divide ();
+#ifndef BIGNUM_NO_ULONG
+extern bignum_type long_to_bignum ();
+extern long bignum_to_long ();
+#endif /* not BIGNUM_NO_ULONG */
+extern bignum_type double_to_bignum ();
+extern double bignum_to_double ();
+extern int bignum_fits_in_word_p ();
+extern bignum_type bignum_length_in_bits ();
+extern bignum_type bignum_length_upper_limit ();
+extern bignum_type digit_stream_to_bignum ();
+extern void bignum_to_digit_stream ();
+extern long bignum_max_digit_stream_radix ();
+
+#endif /* __STDC__ */
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.40 1989/09/20 23:04:28 cph Exp $
+
Copyright (c) 1987, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.39 1989/07/25 08:46:06 cph Rel $
- *
- * This File contains the code to translate internal format binary
- * files to portable format.
- *
- */
+/* This File contains the code to translate internal format binary
+ files to portable format. */
\f
/* IO definitions */
#include "psbmap.h"
#include "trap.h"
+#include "limits.h"
#define internal_file input_file
#define portable_file output_file
{
extern int fread();
- return (fread(To_Where, sizeof(Pointer), Count, internal_file));
+ return (fread(To_Where, sizeof(SCHEME_OBJECT), Count, internal_file));
}
#define INHIBIT_FASL_VERSION_CHECK
#define TC_PRIMITIVE_EXTERNAL 0x10
#define STRING_LENGTH_TO_LONG(value) \
-((long) (upgrade_lengths_p ? Get_Integer(value) : (value)))
+ ((long) (upgrade_lengths_p ? (OBJECT_DATUM (value)) : (value)))
static Boolean
allow_compiled_p = false,
Free, Scan, Free_Constant, Scan_Constant,
Objects, Constant_Objects;
-static Pointer
+static SCHEME_OBJECT
*Mem_Base,
*Free_Objects, *Free_Cobjects,
*compiled_entry_table, *compiled_entry_pointer,
}
else
{
- unsigned int x = (((int) c) & ((1 << CHAR_SIZE) - 1));
+ unsigned int x = (((int) c) & ((1 << CHAR_BIT) - 1));
fprintf(stderr,
"%s: %s: File may not be portable: c = 0x%x\n",
program_name, name, x);
return;
}
\f
+#undef MAKE_BROKEN_HEART
+#define MAKE_BROKEN_HEART(offset) (BROKEN_HEART_ZERO + (offset))
+
#define Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, kernel_code) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer((Code), Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_TYPE ((Code), Old_Contents)); \
else \
{ \
kernel_code; \
#define standard_kernel(kernel_code, type, Code, Scn, Obj, FObj) \
{ \
- fast long length; \
- \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- length = Get_Integer(Old_Contents); \
- kernel_code; \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer((type), 0); \
- *(FObj)++ = Old_Contents; \
- while(--length >= 0) \
+ (Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj))); \
{ \
- *(FObj)++ = *Old_Address++; \
+ fast long length = (OBJECT_DATUM (Old_Contents)); \
+ kernel_code; \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Obj)); \
+ (Obj) += 1; \
+ (*(FObj)++) = (MAKE_OBJECT ((type), 0)); \
+ (*(FObj)++) = Old_Contents; \
+ while ((length--) > 0) \
+ (*(FObj)++) = (*Old_Address++); \
} \
}
\f
#define do_string_kernel() \
{ \
NStrings += 1; \
- NChars += pointer_to_char(length - 1); \
+ NChars += (pointer_to_char (length - 1)); \
}
#define do_bignum_kernel() \
{ \
NIntegers += 1; \
- NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
+ NBits += \
+ (((* ((bignum_digit_type *) (Old_Address + 1))) \
+ & BIGNUM_DIGIT_MASK) \
+ * BIGNUM_DIGIT_LENGTH); \
}
#define do_bit_string_kernel() \
{ \
NBitstrs += 1; \
- NBBits += Old_Address[BIT_STRING_LENGTH_OFFSET]; \
+ NBBits += (Old_Address [BIT_STRING_LENGTH_OFFSET]); \
}
#define do_flonum_kernel(Code, Scn, Obj, FObj) \
{ \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ (Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj))); \
NFlonums += 1; \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Obj)); \
(Obj) += 1; \
- Align_Float(FObj); \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \
- *((double *) (FObj)) = *((double *) Old_Address); \
+ ALIGN_FLOAT (FObj); \
+ (*(FObj)++) = (MAKE_OBJECT (TC_BIG_FLONUM, 0)); \
+ (* ((double *) (FObj))) = (* ((double *) Old_Address)); \
(FObj) += float_to_pointer; \
}
#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, \
- standard_kernel(do_string_kernel(), TC_CHARACTER_STRING, \
- Code, Scn, Obj, FObj))
+ Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
+ standard_kernel (do_string_kernel (), \
+ TC_CHARACTER_STRING, \
+ Code, Scn, Obj, FObj))
#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, \
- standard_kernel(do_bignum_kernel(), TC_BIG_FIXNUM, \
- Code, Scn, Obj, FObj))
+ Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
+ standard_kernel (do_bignum_kernel (), TC_BIG_FIXNUM, \
+ Code, Scn, Obj, FObj))
#define Do_Bit_String(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, \
- standard_kernel(do_bit_string_kernel(), TC_BIT_STRING, \
- Code, Scn, Obj, FObj))
+ Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
+ standard_kernel (do_bit_string_kernel (), TC_BIT_STRING, \
+ Code, Scn, Obj, FObj))
#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, \
- do_flonum_kernel(Code, Scn, Obj, FObj))
+ Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
+ do_flonum_kernel (Code, Scn, Obj, FObj))
\f
void
print_a_fixnum(val)
\f
void
print_a_string(from)
- Pointer *from;
+ SCHEME_OBJECT *from;
{
long len;
long maxlen;
- maxlen = pointer_to_char((Get_Integer(*from++)) - 1);
+ maxlen = pointer_to_char((OBJECT_DATUM (*from++)) - 1);
len = STRING_LENGTH_TO_LONG(*from++);
fprintf(portable_file,
return;
}
\f
-void
-print_a_bignum(from)
- Pointer *from;
+static long
+bignum_length (bignum)
+ SCHEME_OBJECT bignum;
{
- 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)
+ if (BIGNUM_ZERO_P (bignum))
+ return (0);
{
- fprintf(portable_file, "%02x + 0\n",
- (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
+ bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
+ fast bignum_digit_type digit = (BIGNUM_REF (bignum, index));
+ fast long result;
+ if (index >= (LONG_MAX / BIGNUM_DIGIT_LENGTH))
+ goto loser;
+ result = (index * BIGNUM_DIGIT_LENGTH);
+ while (digit > 0)
+ {
+ result += 1;
+ if (result >= LONG_MAX)
+ goto loser;
+ digit >>= 1;
+ }
+ return (result);
}
- 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;
- }
+ loser:
+ fprintf (stderr, "%s: Bignum exceeds representable length.\n",
+ program_name);
+ quit (1);
+ /* NOTREACHED */
+}
\f
- 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)
+void
+print_a_bignum (bignum)
+ SCHEME_OBJECT bignum;
+{
+ if (BIGNUM_ZERO_P (bignum))
{
- tail = SHIFT;
+ fprintf (portable_file, "%02x + 0\n",
+ (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
+ return;
}
- 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)
+ {
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ fast long length_in_bits = (bignum_length (bignum));
+ fast int bits_in_digit = 0;
+ fast bignum_digit_type accumulator;
+ fprintf (portable_file, "%02x %c %ld ",
+ (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM),
+ ((BIGNUM_NEGATIVE_P (bignum)) ? '-' : '+'),
+ length_in_bits);
+ accumulator = (*scan++);
+ bits_in_digit =
+ ((length_in_bits < BIGNUM_DIGIT_LENGTH)
+ ? length_in_bits
+ : BIGNUM_DIGIT_LENGTH);
+ while (length_in_bits > 0)
{
- fprintf(portable_file, "%01lx", (temp & 0xf));
- temp = temp >> 4;
+ if (bits_in_digit > 4)
+ {
+ fprintf (portable_file, "%01lx", (accumulator & 0xf));
+ length_in_bits -= 4;
+ accumulator >>= 4;
+ bits_in_digit -= 4;
+ }
+ else if (bits_in_digit == 4)
+ {
+ fprintf (portable_file, "%01lx", accumulator);
+ length_in_bits -= 4;
+ if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
+ {
+ accumulator = (*scan++);
+ bits_in_digit = BIGNUM_DIGIT_LENGTH;
+ }
+ else if (length_in_bits > 0)
+ {
+ accumulator = (*scan++);
+ bits_in_digit = length_in_bits;
+ }
+ else
+ break;
+ }
+ else if (bits_in_digit < length_in_bits)
+ {
+ int carry = accumulator;
+ int diff_bits = (4 - bits_in_digit);
+ accumulator = (*scan++);
+ fprintf (portable_file, "%01lx",
+ (carry |
+ ((accumulator && ((1 << diff_bits) - 1)) <<
+ bits_in_digit)));
+ length_in_bits -= 4;
+ bits_in_digit = (BIGNUM_DIGIT_LENGTH - diff_bits);
+ if (length_in_bits >= bits_in_digit)
+ accumulator >>= diff_bits;
+ else if (length_in_bits > 0)
+ {
+ accumulator >>= diff_bits;
+ bits_in_digit = length_in_bits;
+ }
+ else
+ break;
+ }
+ else
+ {
+ fprintf (portable_file, "%01lx", accumulator);
+ break;
+ }
}
- }
- if (size_in_bits > 0)
- {
- fprintf(portable_file, "%01lx\n", (temp & 0xf));
- }
- else
- {
- fprintf(portable_file, "\n");
- }
}
- return;
+ fprintf (portable_file, "\n");
}
\f
/* The following procedure assumes that a C long is at least 4 bits. */
void
print_a_bit_string(from)
- Pointer *from;
+ SCHEME_OBJECT *from;
{
- Pointer the_bit_string;
+ SCHEME_OBJECT the_bit_string;
fast long bits_remaining, leftover_bits;
- fast Pointer accumulator, next_word, *scan;
+ fast SCHEME_OBJECT accumulator, next_word, *scan;
- the_bit_string = Make_Pointer(TC_BIT_STRING, from);
- bits_remaining = bit_string_length(the_bit_string);
+ the_bit_string = (MAKE_POINTER_OBJECT (TC_BIT_STRING, from));
+ bits_remaining = (BIT_STRING_LENGTH (the_bit_string));
fprintf(portable_file, "%02x %ld", TC_BIT_STRING, bits_remaining);
if (bits_remaining != 0)
{
fprintf(portable_file, " ");
- scan = bit_string_low_ptr(the_bit_string);
+ scan = BIT_STRING_LOW_PTR(the_bit_string);
for (leftover_bits = 0;
bits_remaining > 0;
- bits_remaining -= POINTER_LENGTH)
+ bits_remaining -= OBJECT_LENGTH)
{
- next_word = *(inc_bit_string_ptr(scan));
+ next_word = *(INC_BIT_STRING_PTR(scan));
- if (bits_remaining < POINTER_LENGTH)
- next_word &= low_mask(bits_remaining);
+ if (bits_remaining < OBJECT_LENGTH)
+ next_word &= LOW_MASK(bits_remaining);
if (leftover_bits != 0)
{
- accumulator &= low_mask(leftover_bits);
+ accumulator &= LOW_MASK(leftover_bits);
accumulator |=
- ((next_word & low_mask(4 - leftover_bits)) << leftover_bits);
+ ((next_word & LOW_MASK(4 - leftover_bits)) << leftover_bits);
next_word = (next_word >> (4 - leftover_bits));
- leftover_bits += ((bits_remaining > POINTER_LENGTH) ?
- (POINTER_LENGTH - 4) :
+ leftover_bits += ((bits_remaining > OBJECT_LENGTH) ?
+ (OBJECT_LENGTH - 4) :
(bits_remaining - 4));
fprintf(portable_file, "%01lx", (accumulator & 0xf));
}
else
{
- leftover_bits = ((bits_remaining > POINTER_LENGTH) ?
- POINTER_LENGTH :
+ leftover_bits = ((bits_remaining > OBJECT_LENGTH) ?
+ OBJECT_LENGTH :
bits_remaining);
}
#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
- Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- } \
+ { \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ } \
}
#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
- Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
+ { \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ } \
}
-\f
+
#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
- Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
+ { \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ } \
}
#define Do_Quad(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
- Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
+ { \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ } \
}
\f
#define Copy_Vector(Scn, Fre) \
{ \
- fast long len; \
- \
- len = OBJECT_DATUM(Old_Contents); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- while (--len >= 0) \
- { \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
+ fast long len = (OBJECT_DATUM (Old_Contents)); \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ while ((len--) > 0) \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
}
#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
- Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
- Copy_Vector(Scn, Fre); \
- } \
+ { \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ Copy_Vector (Scn, Fre); \
+ } \
}
-\f
+
/* This is a hack to get the cross compiler to work from vaxen to other
- machines and viceversa.
- */
+ machines and viceversa. */
#define Do_Inverted_Block(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
- Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- fast long len1, len2; \
- Pointer *Saved; \
- \
- Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
- \
- len1 = OBJECT_DATUM(Old_Contents); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- if ((OBJECT_TYPE(*Old_Address)) != TC_MANIFEST_NM_VECTOR) \
- { \
- fprintf(stderr, "%s: Bad compiled code block found.\n", \
- program_name); \
- quit(1); \
- } \
- len2 = OBJECT_DATUM(*Old_Address); \
- Mem_Base[(Fre)++] = *Old_Address++; \
- Old_Address += len2; \
- Saved = Old_Address; \
- len1 -= (len2 + 1); \
- while (--len2 >= 0) \
{ \
- Old_Address -= 1; \
- Mem_Base[(Fre)++] = *Old_Address; \
+ fast long len1, len2; \
+ SCHEME_OBJECT * Saved; \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ len1 = (OBJECT_DATUM (Old_Contents)); \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ if ((OBJECT_TYPE (*Old_Address)) != TC_MANIFEST_NM_VECTOR) \
+ { \
+ fprintf (stderr, "%s: Bad compiled code block found.\n", \
+ program_name); \
+ quit (1); \
+ } \
+ len2 = (OBJECT_DATUM (*Old_Address)); \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ Old_Address += len2; \
+ Saved = Old_Address; \
+ len1 -= (len2 + 1); \
+ while ((len2--) > 0) \
+ (Mem_Base [(Fre)++]) = (*--Old_Address); \
+ Old_Address = Saved; \
+ while ((len1--) > 0) \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
} \
- Old_Address = Saved; \
- while (--len1 >= 0) \
- { \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
- } \
}
\f
#ifdef CMPGCFILE
#define Do_Compiled_Entry(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
long offset; \
- Pointer *saved; \
- \
+ SCHEME_OBJECT * saved; \
Old_Address += (Rel); \
saved = Old_Address; \
- Get_Compiled_Block(Old_Address, saved); \
- Old_Contents = *Old_Address; \
- \
- Mem_Base[(Scn)] = \
- Make_Non_Pointer(TC_COMPILED_ENTRY, \
- (compiled_entry_pointer - compiled_entry_table)); \
- \
+ Get_Compiled_Block (Old_Address, saved); \
+ Old_Contents = (*Old_Address); \
+ (Mem_Base [(Scn)]) = \
+ (OBJECT_NEW_DATUM \
+ (TC_COMPILED_ENTRY, \
+ (compiled_entry_pointer - compiled_entry_table))); \
offset = (((char *) saved) - ((char *) Old_Address)); \
- *compiled_entry_pointer++ = MAKE_SIGNED_FIXNUM(offset); \
- \
+ (*compiled_entry_pointer++) = (LONG_TO_FIXNUM (offset)); \
/* Base pointer */ \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- *compiled_entry_pointer++ = \
- Make_New_Pointer(OBJECT_TYPE(This), Old_Contents); \
- } \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (*compiled_entry_pointer++) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- *compiled_entry_pointer++ = \
- Make_New_Pointer(OBJECT_TYPE(This), (Fre)); \
- \
- Copy_Vector(Scn, Fre); \
- } \
+ { \
+ (*compiled_entry_pointer++) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, (Fre))); \
+ Copy_Vector (Scn, Fre); \
+ } \
}
#else /* no CMPGCFILE */
#define Do_Compiled_Entry(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
- fprintf(stderr, \
- "%s: Invoking Do_Compiled_Entry with no compiler support!\n", \
- program_name); \
- quit(1); \
+ fprintf \
+ (stderr, \
+ "%s: Invoking Do_Compiled_Entry with no compiler support!\n", \
+ program_name); \
+ quit (1); \
}
#endif /* CMPGCFILE */
{ \
long the_datum; \
\
- Old_Address = Get_Pointer(This); \
- the_datum = OBJECT_DATUM(This); \
+ Old_Address = (OBJECT_ADDRESS (This)); \
+ the_datum = (OBJECT_DATUM (This)); \
if ((the_datum >= Heap_Base) && \
(the_datum < Dumped_Heap_Top)) \
- { \
- Action(HEAP_CODE, Heap_Relocation, Free, \
- Scn, Objects, Free_Objects); \
- } \
- \
- /* \
- \
- Currently constant space is not supported \
- \
+ { \
+ Action \
+ (HEAP_CODE, Heap_Relocation, Free, \
+ Scn, Objects, Free_Objects); \
+ } \
+ /* Currently constant space is not supported \
else if ((the_datum >= Const_Base) && \
(the_datum < Dumped_Constant_Top)) \
- { \
- Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \
- Scn, Constant_Objects, Free_Cobjects); \
- } \
- \
- */ \
- \
+ { \
+ Action \
+ (CONSTANT_CODE, Constant_Relocation, Free_Constant, \
+ Scn, Constant_Objects, Free_Cobjects); \
+ } \
+ */ \
else \
- { \
- out_of_range_pointer(This); \
- } \
+ { \
+ out_of_range_pointer (This); \
+ } \
(Scn) += 1; \
break; \
}
\f
void
out_of_range_pointer(ptr)
- Pointer ptr;
+ SCHEME_OBJECT ptr;
{
fprintf(stderr,
"%s: The input file is not portable: Out of range pointer.\n",
fprintf(stderr, "Const_Base = 0x%lx;\tConst_Top = 0x%lx\n",
Const_Base, Dumped_Constant_Top);
fprintf(stderr, "ptr = 0x%02x|0x%lx\n",
- OBJECT_TYPE(ptr), OBJECT_DATUM(ptr));
+ OBJECT_TYPE (ptr), OBJECT_DATUM (ptr));
quit(1);
}
-Pointer *
+SCHEME_OBJECT *
relocate(object)
- Pointer object;
+ SCHEME_OBJECT object;
{
long the_datum;
- Pointer *result;
+ SCHEME_OBJECT *result;
- result = Get_Pointer(object);
- the_datum = OBJECT_DATUM(object);
+ result = OBJECT_ADDRESS (object);
+ the_datum = OBJECT_DATUM (object);
if ((the_datum >= Heap_Base) &&
(the_datum < Dumped_Heap_Top))
#define PRIMITIVE_UPGRADE_SPACE 2048
-static Pointer
+static SCHEME_OBJECT
*internal_renumber_table,
*external_renumber_table,
*external_prim_name_table;
static Boolean
found_ext_prims = false;
-Pointer
+SCHEME_OBJECT
upgrade_primitive(prim)
- Pointer prim;
+ SCHEME_OBJECT prim;
{
long the_datum, the_type, new_type, code;
- Pointer new;
+ SCHEME_OBJECT new;
- the_datum = OBJECT_DATUM(prim);
- the_type = OBJECT_TYPE(prim);
+ the_datum = OBJECT_DATUM (prim);
+ the_type = OBJECT_TYPE (prim);
if (the_type != TC_PRIMITIVE_EXTERNAL)
{
code = the_datum;
}
\f
new = internal_renumber_table[code];
- if (new == NIL)
+ if (new == SHARP_F)
{
/*
This does not need to check for overflow because the worst case
was checked in setup_primitive_upgrade;
*/
- new = Make_Non_Pointer(new_type, Primitive_Table_Length);
+ new = (MAKE_OBJECT (new_type, Primitive_Table_Length));
internal_renumber_table[code] = new;
external_renumber_table[Primitive_Table_Length] = prim;
Primitive_Table_Length += 1;
if (the_type == TC_PRIMITIVE_EXTERNAL)
{
NPChars +=
- STRING_LENGTH_TO_LONG((((Pointer *)
+ STRING_LENGTH_TO_LONG((((SCHEME_OBJECT *)
(external_prim_name_table[the_datum]))
- [STRING_LENGTH]));
+ [STRING_LENGTH_INDEX]));
}
else
{
}
else
{
- return (Make_New_Pointer(new_type, new));
+ return (OBJECT_NEW_TYPE (new_type, new));
}
}
\f
-Pointer *
+SCHEME_OBJECT *
setup_primitive_upgrade(Heap)
- Pointer *Heap;
+ SCHEME_OBJECT *Heap;
{
fast long count, length;
- Pointer *old_prims_vector;
-
+ SCHEME_OBJECT *old_prims_vector;
+
internal_renumber_table = &Heap[0];
external_renumber_table =
&internal_renumber_table[PRIMITIVE_UPGRADE_SPACE];
&external_renumber_table[PRIMITIVE_UPGRADE_SPACE];
old_prims_vector = relocate(Ext_Prim_Vector);
- if (*old_prims_vector == NIL)
+ if (*old_prims_vector == SHARP_F)
{
length = 0;
}
else
{
old_prims_vector = relocate(*old_prims_vector);
- length = Get_Integer(*old_prims_vector);
+ length = OBJECT_DATUM (*old_prims_vector);
old_prims_vector += VECTOR_DATA;
for (count = 0; count < length; count += 1)
{
- Pointer *temp;
+ SCHEME_OBJECT *temp;
/* symbol */
temp = relocate(old_prims_vector[count]);
/* string */
temp = relocate(temp[SYMBOL_NAME]);
- external_prim_name_table[count] = ((Pointer) temp);
+ external_prim_name_table[count] = ((SCHEME_OBJECT) temp);
}
}
length += (MAX_BUILTIN_PRIMITIVE + 1);
}
for (count = 0; count < length; count += 1)
{
- internal_renumber_table[count] = NIL;
+ internal_renumber_table[count] = SHARP_F;
}
NPChars = 0;
return (&external_prim_name_table[PRIMITIVE_UPGRADE_SPACE]);
int Code;
fast long *Area, *Bound;
fast long *Obj;
- fast Pointer **FObj;
+ fast SCHEME_OBJECT **FObj;
{
- fast Pointer This, *Old_Address, Old_Contents;
+ fast SCHEME_OBJECT This, *Old_Address, Old_Contents;
while(*Area != *Bound)
{
#ifdef PRIMITIVE_EXTERNAL_REUSED
if (upgrade_primitives_p &&
- (OBJECT_TYPE(This) == TC_PRIMITIVE_EXTERNAL))
+ (OBJECT_TYPE (This) == TC_PRIMITIVE_EXTERNAL))
{
Mem_Base[*Area] = upgrade_primitive(This);
*Area += 1;
{
fast int i;
- i = Get_Integer(This);
+ i = OBJECT_DATUM (This);
*Area += 1;
for ( ; --i >= 0; *Area += 1)
{
- Mem_Base[*Area] = NIL;
+ Mem_Base[*Area] = SHARP_F;
}
break;
}
fprintf(stderr, "%s: File is not portable: NMH found\n",
program_name);
}
- *Area += (1 + OBJECT_DATUM(This));
+ *Area += (1 + OBJECT_DATUM (This));
break;
case TC_BROKEN_HEART:
/* [Broken Heart 0] is the cdr of fasdumped symbols. */
- if (OBJECT_DATUM(This) != 0)
+ if (OBJECT_DATUM (This) != 0)
{
fprintf(stderr, "%s: Broken Heart found in scan.\n",
program_name);
case TC_CHARACTER:
Process_Character:
- Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj);
+ Mem_Base[*Area] = (MAKE_OBJECT (Code, *Obj));
*Obj += 1;
**FObj = This;
*FObj += 1;
{
long kind;
- kind = OBJECT_DATUM(This);
+ kind = OBJECT_DATUM (This);
if (upgrade_traps_p)
{
case TC_FUTURE:
case_simple_Vector:
- if (OBJECT_TYPE(This) == TC_BIT_STRING)
+ if (BIT_STRING_P (This))
{
Do_Pointer(*Area, Do_Bit_String);
}
default:
Bad_Type:
fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
- program_name, OBJECT_TYPE(This));
+ program_name, OBJECT_TYPE (This));
quit(1);
}
}
void
print_external_objects(from, count)
- fast Pointer *from;
+ fast SCHEME_OBJECT *from;
fast long count;
{
while (--count >= 0)
{
- switch(OBJECT_TYPE(*from))
+ switch(OBJECT_TYPE (*from))
{
case TC_FIXNUM:
- {
- long Value;
-
- Sign_Extend(*from++, Value);
- print_a_fixnum(Value);
+ print_a_fixnum (FIXNUM_TO_LONG (*from));
+ from += 1;
break;
- }
case TC_BIT_STRING:
print_a_bit_string(++from);
- from += (1 + OBJECT_DATUM(*from));
+ from += (1 + OBJECT_DATUM (*from));
break;
case TC_BIG_FIXNUM:
- print_a_bignum(++from);
- from += (1 + OBJECT_DATUM(*from));
+ print_a_bignum (*from++);
+ from += (1 + OBJECT_DATUM (*from));
break;
-
+
case TC_CHARACTER_STRING:
print_a_string(++from);
- from += (1 + OBJECT_DATUM(*from));
+ from += (1 + OBJECT_DATUM (*from));
break;
case TC_BIG_FLONUM:
case TC_CHARACTER:
fprintf(portable_file, "%02x %03x\n",
- TC_CHARACTER, (*from & MASK_EXTNDD_CHAR));
+ TC_CHARACTER, (*from & MASK_MIT_ASCII));
from += 1;
break;
#ifdef FLOATING_ALIGNMENT
case TC_MANIFEST_NM_VECTOR:
- if ((OBJECT_DATUM(*from)) == 0)
+ if ((OBJECT_DATUM (*from)) == 0)
{
from += 1;
count += 1;
\f
void
print_objects(from, to)
- fast Pointer *from, *to;
+ fast SCHEME_OBJECT *from, *to;
{
fast long the_datum, the_type;
while(from < to)
{
- the_type = OBJECT_TYPE(*from);
- the_datum = OBJECT_DATUM(*from);
+ the_type = OBJECT_TYPE (*from);
+ the_datum = OBJECT_DATUM (*from);
from += 1;
if (the_type == TC_MANIFEST_NM_VECTOR)
}
else if (the_type == TC_COMPILED_ENTRY)
{
- Pointer base;
+ SCHEME_OBJECT base;
long offset;
- Sign_Extend(compiled_entry_table[the_datum], offset);
+ offset = (FIXNUM_TO_LONG (compiled_entry_table [the_datum]));
base = compiled_entry_table[the_datum + 1];
fprintf(portable_file, "%02x %lx %02x %lx\n",
TC_COMPILED_ENTRY, offset,
- OBJECT_TYPE(base), OBJECT_DATUM(base));
+ OBJECT_TYPE (base), OBJECT_DATUM (base));
}
else
{
void
do_it()
{
- Pointer *Heap;
+ SCHEME_OBJECT *Heap;
long Initial_Free;
/* Load the Data */
(2 * (Heap_Count + Const_Count)) :
0));
- Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE);
+ ALLOCATE_HEAP_SPACE (Size + HEAP_BUFFER_SPACE);
- if (Heap == NULL)
+ if (Heap == ((SCHEME_OBJECT *) 0))
{
fprintf(stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
+ "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
program_name, Size);
quit(1);
}
}
Heap += HEAP_BUFFER_SPACE;
- Initial_Align_Float(Heap);
+ INITIAL_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)));
+ Heap_Relocation = ((&Heap[0]) - (OBJECT_ADDRESS (Heap_Base)));
+ Constant_Relocation = ((&Heap[Heap_Count]) - (OBJECT_ADDRESS (Const_Base)));
\f
/* Setup compiled code and primitive tables. */
}
else
{
- fast Pointer *table;
+ fast SCHEME_OBJECT *table;
fast long count, char_count;
Load_Data(Primitive_Table_Size, primitive_table);
table = primitive_table;
--count >= 0;)
{
- char_count += STRING_LENGTH_TO_LONG(table[1 + STRING_LENGTH]);
- table += (2 + Get_Integer(table[1 + STRING_HEADER]));
+ char_count += STRING_LENGTH_TO_LONG(table[1 + STRING_LENGTH_INDEX]);
+ table += (2 + OBJECT_DATUM (table[1 + STRING_HEADER]));
}
NPChars = char_count;
primitive_table_end = &primitive_table[Primitive_Table_Size];
NFlonums = NIntegers = NStrings = 0;
NBits = NBBits = NChars = 0;
- Mem_Base[0] = Make_New_Pointer(TC_CELL, Dumped_Object);
+ Mem_Base[0] = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object));
Initial_Free = NROOTS;
Scan = 0;
WRITE_HEADER("Constant Base", "%ld", Free_Constant);
WRITE_HEADER("Constant Objects", "%ld", 0);
- WRITE_HEADER("& Dumped Object", "%ld", (OBJECT_DATUM(Mem_Base[0])));
+ WRITE_HEADER("& Dumped Object", "%ld", (OBJECT_DATUM (Mem_Base[0])));
WRITE_HEADER("Number of flonums", "%ld", NFlonums);
WRITE_HEADER("Number of integers", "%ld", NIntegers);
dumped_interface_version);
#if false
WRITE_HEADER("Compiler utilities vector", "%ld",
- OBJECT_DATUM(dumped_utilities));
+ OBJECT_DATUM (dumped_utilities));
#endif
\f
/* External Objects */
-
+
print_external_objects(&Mem_Base[Initial_Free + Heap_Count],
Objects);
-
+
#if false
print_external_objects(&Mem_Base[Pure_Objects_Start],
#if false
print_objects(&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]);
- print_objects(&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
+ print_objects(&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
#endif
\f
/* Primitives */
if (upgrade_primitives_p)
{
- Pointer obj;
- fast Pointer *table;
+ SCHEME_OBJECT obj;
+ fast SCHEME_OBJECT *table;
fast long count, the_datum;
for (count = Primitive_Table_Length,
--count >= 0;)
{
obj = *table++;
- the_datum = OBJECT_DATUM(obj);
- if (OBJECT_TYPE(obj) == TC_PRIMITIVE_EXTERNAL)
+ the_datum = OBJECT_DATUM (obj);
+ if (OBJECT_TYPE (obj) == TC_PRIMITIVE_EXTERNAL)
{
- Pointer *strobj;
+ SCHEME_OBJECT *strobj;
- strobj = ((Pointer *) (external_prim_name_table[the_datum]));
+ strobj = ((SCHEME_OBJECT *) (external_prim_name_table[the_datum]));
print_a_primitive(((long) UNKNOWN_PRIMITIVE_ARITY),
- (STRING_LENGTH_TO_LONG(strobj[STRING_LENGTH])),
+ (STRING_LENGTH_TO_LONG(strobj[STRING_LENGTH_INDEX])),
((char *) &strobj[STRING_CHARS]));
}
else
}
else
{
- fast Pointer *table;
+ fast SCHEME_OBJECT *table;
fast long count;
long arity;
for (count = Primitive_Table_Length, table = primitive_table;
--count >= 0;)
{
- Sign_Extend(*table, arity);
+ arity = (FIXNUM_TO_LONG (*table));
table += 1;
print_a_primitive(arity,
- (STRING_LENGTH_TO_LONG(table[STRING_LENGTH])),
+ (STRING_LENGTH_TO_LONG(table[STRING_LENGTH_INDEX])),
((char *) &table[STRING_CHARS]));
- table += (1 + Get_Integer(table[STRING_HEADER]));
+ table += (1 + OBJECT_DATUM (table[STRING_HEADER]));
}
}
return;
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.c,v 9.40 1989/09/20 23:06:09 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.c,v 9.39 1989/07/05 18:42:21 cph Rel $
-
- Bit string primitives.
-
- 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.
-
-*/
+/* Bit string primitives.
+ 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 "prims.h"
-#include "bignum.h"
#include "bitstr.h"
\f
-Pointer
+SCHEME_OBJECT
allocate_bit_string (length)
long length;
{
long total_pointers;
- Pointer result;
+ SCHEME_OBJECT result;
- total_pointers = (1 + (bits_to_pointers (length)));
+ total_pointers = (1 + (BIT_STRING_LENGTH_TO_GC_LENGTH (length)));
result = (allocate_non_marked_vector (TC_BIT_STRING, total_pointers, true));
- Fast_Vector_Set (result, BIT_STRING_LENGTH_OFFSET, length);
+ FAST_MEMORY_SET (result, BIT_STRING_LENGTH_OFFSET, length);
return (result);
}
DEFINE_PRIMITIVE ("BIT-STRING-ALLOCATE", Prim_bit_string_allocate, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
PRIMITIVE_RETURN (allocate_bit_string (arg_nonnegative_integer (1)));
}
/* (BIT-STRING? object)
- Returns true iff object is a bit string. */
+ Returns #T iff object is a bit string. */
DEFINE_PRIMITIVE ("BIT-STRING?", Prim_bit_string_p, 1, 1, 0)
{
- fast Pointer object;
+ fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
-
- object = (ARG_REF (1));
- Touch_In_Primitive (object, object);
- PRIMITIVE_RETURN ((BIT_STRING_P (object)) ? SHARP_T : NIL);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (BIT_STRING_P (object)));
}
\f
void
fill_bit_string (bit_string, sense)
- Pointer bit_string;
+ SCHEME_OBJECT bit_string;
Boolean sense;
{
- Pointer *scanner;
- Pointer filler;
+ SCHEME_OBJECT *scanner;
+ SCHEME_OBJECT filler;
long i;
- filler = ((Pointer) (sense ? (~ 0) : 0));
- scanner = bit_string_high_ptr (bit_string);
- for (i = bits_to_pointers (bit_string_length (bit_string));
+ filler = ((SCHEME_OBJECT) (sense ? (~ 0) : 0));
+ scanner = BIT_STRING_HIGH_PTR (bit_string);
+ for (i = BIT_STRING_LENGTH_TO_GC_LENGTH (BIT_STRING_LENGTH (bit_string));
(i > 0); i -= 1)
- (* (dec_bit_string_ptr (scanner))) = filler;
+ (* (DEC_BIT_STRING_PTR (scanner))) = filler;
}
void
clear_bit_string (bit_string)
- Pointer bit_string;
+ SCHEME_OBJECT bit_string;
{
- Pointer *scanner;
+ SCHEME_OBJECT *scanner;
long i;
- scanner = bit_string_high_ptr (bit_string);
- for (i = bits_to_pointers (bit_string_length (bit_string));
+ scanner = BIT_STRING_HIGH_PTR (bit_string);
+ for (i = BIT_STRING_LENGTH_TO_GC_LENGTH (BIT_STRING_LENGTH (bit_string));
(i > 0); i -= 1)
- (* (dec_bit_string_ptr (scanner))) = 0;
+ (* (DEC_BIT_STRING_PTR (scanner))) = 0;
}
\f
/* (MAKE-BIT-STRING size initialization)
DEFINE_PRIMITIVE ("MAKE-BIT-STRING", Prim_make_bit_string, 2, 2, 0)
{
- Pointer result;
+ SCHEME_OBJECT result;
PRIMITIVE_HEADER (2);
-
result = allocate_bit_string (arg_nonnegative_integer (1));
- fill_bit_string (result, ((ARG_REF (2)) != NIL));
+ fill_bit_string (result, (OBJECT_TO_BOOLEAN (ARG_REF (2))));
PRIMITIVE_RETURN (result);
}
DEFINE_PRIMITIVE ("BIT-STRING-FILL!", Prim_bit_string_fill_x, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
-
CHECK_ARG (1, BIT_STRING_P);
- fill_bit_string ((ARG_REF (1)), ((ARG_REF (2)) != NIL));
- PRIMITIVE_RETURN (NIL);
+ fill_bit_string ((ARG_REF (1)), (OBJECT_TO_BOOLEAN (ARG_REF (2))));
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
/* (BIT-STRING-LENGTH bit-string)
DEFINE_PRIMITIVE ("BIT-STRING-LENGTH", Prim_bit_string_length, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
CHECK_ARG (1, BIT_STRING_P);
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (bit_string_length (ARG_REF (1))));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (BIT_STRING_LENGTH (ARG_REF (1))));
}
\f
#define REF_INITIALIZATION() \
- fast Pointer bit_string; \
+ fast SCHEME_OBJECT bit_string; \
fast long index; \
- fast Pointer *ptr; \
+ fast SCHEME_OBJECT *ptr; \
fast long mask; \
PRIMITIVE_HEADER (2); \
\
CHECK_ARG (1, BIT_STRING_P); \
bit_string = (ARG_REF (1)); \
index = (arg_nonnegative_integer (2)); \
- if (index >= (bit_string_length (bit_string))) \
+ if (index >= (BIT_STRING_LENGTH (bit_string))) \
error_bad_range_arg (1); \
\
ptr = \
- (Nth_Vector_Loc (bit_string, (index_to_word (bit_string, index)))); \
- mask = (1 << (index % POINTER_LENGTH))
+ (MEMORY_LOC \
+ (bit_string, (BIT_STRING_INDEX_TO_WORD (bit_string, index)))); \
+ mask = (1 << (index % OBJECT_LENGTH))
/* (BIT-STRING-REF bit-string index)
Returns the boolean value of the indexed bit. */
DEFINE_PRIMITIVE ("BIT-STRING-REF", Prim_bit_string_ref, 2, 2, 0)
{
REF_INITIALIZATION ();
-
- PRIMITIVE_RETURN ((((bit_string_word (ptr)) & mask) == 0) ? NIL : SHARP_T);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (((BIT_STRING_WORD (ptr)) & mask) != 0));
}
/* (BIT-STRING-CLEAR! bit-string index)
DEFINE_PRIMITIVE ("BIT-STRING-CLEAR!", Prim_bit_string_clear_x, 2, 2, 0)
{
REF_INITIALIZATION ();
-
- if (((bit_string_word (ptr)) & mask) == 0)
- PRIMITIVE_RETURN (NIL);
- (bit_string_word (ptr)) &= ~mask;
+ if (((BIT_STRING_WORD (ptr)) & mask) == 0)
+ PRIMITIVE_RETURN (SHARP_F);
+ (BIT_STRING_WORD (ptr)) &= ~mask;
PRIMITIVE_RETURN (SHARP_T);
}
DEFINE_PRIMITIVE ("BIT-STRING-SET!", Prim_bit_string_set_x, 2, 2, 0)
{
REF_INITIALIZATION ();
-
- if (((bit_string_word (ptr)) & mask) != 0)
+ if (((BIT_STRING_WORD (ptr)) & mask) != 0)
PRIMITIVE_RETURN (SHARP_T);
- ((bit_string_word (ptr))) |= mask;
- PRIMITIVE_RETURN (NIL);
+ ((BIT_STRING_WORD (ptr))) |= mask;
+ PRIMITIVE_RETURN (SHARP_F);
}
\f
#define ZERO_SECTION_P() \
{ \
- for (i = (length / POINTER_LENGTH); (i > 0); i -= 1) \
- if ((* (dec_bit_string_ptr (scan))) != 0) \
- PRIMITIVE_RETURN (NIL); \
+ for (i = (length / OBJECT_LENGTH); (i > 0); i -= 1) \
+ if ((* (DEC_BIT_STRING_PTR (scan))) != 0) \
+ PRIMITIVE_RETURN (SHARP_F); \
PRIMITIVE_RETURN (SHARP_T); \
}
DEFINE_PRIMITIVE ("BIT-STRING-ZERO?", Prim_bit_string_zero_p, 1, 1, 0)
{
- fast Pointer bit_string;
- fast Pointer *scan;
+ fast SCHEME_OBJECT bit_string;
+ fast SCHEME_OBJECT *scan;
fast long i;
long length, odd_bits;
PRIMITIVE_HEADER (1);
-
CHECK_ARG (1, BIT_STRING_P);
bit_string = (ARG_REF (1));
- length = (bit_string_length (bit_string));
- odd_bits = (length % POINTER_LENGTH);
- scan = (bit_string_high_ptr (bit_string));
+ length = (BIT_STRING_LENGTH (bit_string));
+ odd_bits = (length % OBJECT_LENGTH);
+ scan = (BIT_STRING_HIGH_PTR (bit_string));
if (odd_bits == 0)
{
ZERO_SECTION_P ();
}
- else if (((bit_string_word (scan)) & (low_mask (odd_bits))) != 0)
- PRIMITIVE_RETURN (NIL);
+ else if (((BIT_STRING_WORD (scan)) & (LOW_MASK (odd_bits))) != 0)
+ PRIMITIVE_RETURN (SHARP_F);
else
{
- dec_bit_string_ptr (scan);
+ DEC_BIT_STRING_PTR (scan);
ZERO_SECTION_P ();
}
}
\f
#define EQUAL_SECTIONS_P() \
{ \
- for (i = (length / POINTER_LENGTH); (i > 0); i -= 1) \
- if ((* (dec_bit_string_ptr (scan1))) != \
- (* (dec_bit_string_ptr (scan2)))) \
- PRIMITIVE_RETURN (NIL); \
+ for (i = (length / OBJECT_LENGTH); (i > 0); i -= 1) \
+ if ((* (DEC_BIT_STRING_PTR (scan1))) != \
+ (* (DEC_BIT_STRING_PTR (scan2)))) \
+ PRIMITIVE_RETURN (SHARP_F); \
PRIMITIVE_RETURN (SHARP_T); \
}
DEFINE_PRIMITIVE ("BIT-STRING=?", Prim_bit_string_equal_p, 2, 2, 0)
{
- Pointer bit_string_1, bit_string_2;
+ SCHEME_OBJECT bit_string_1, bit_string_2;
long length;
- fast Pointer *scan1, *scan2;
+ fast SCHEME_OBJECT *scan1, *scan2;
fast long i;
long odd_bits;
PRIMITIVE_HEADER (2);
-
CHECK_ARG (1, BIT_STRING_P);
CHECK_ARG (2, BIT_STRING_P);
-
bit_string_1 = (ARG_REF (1));
bit_string_2 = (ARG_REF (2));
- length = bit_string_length (bit_string_1);
- if (length != bit_string_length (bit_string_2))
- PRIMITIVE_RETURN (NIL);
-
- scan1 = (bit_string_high_ptr (bit_string_1));
- scan2 = (bit_string_high_ptr (bit_string_2));
- odd_bits = (length % POINTER_LENGTH);
+ length = BIT_STRING_LENGTH (bit_string_1);
+ if (length != BIT_STRING_LENGTH (bit_string_2))
+ PRIMITIVE_RETURN (SHARP_F);
+ scan1 = (BIT_STRING_HIGH_PTR (bit_string_1));
+ scan2 = (BIT_STRING_HIGH_PTR (bit_string_2));
+ odd_bits = (length % OBJECT_LENGTH);
if (odd_bits == 0)
{
EQUAL_SECTIONS_P ();
{
long mask;
- mask = (low_mask (odd_bits));
- if (((bit_string_msw (bit_string_1)) & mask) !=
- ((bit_string_msw (bit_string_2)) & mask))
- PRIMITIVE_RETURN (NIL);
+ mask = (LOW_MASK (odd_bits));
+ if (((BIT_STRING_MSW (bit_string_1)) & mask) !=
+ ((BIT_STRING_MSW (bit_string_2)) & mask))
+ PRIMITIVE_RETURN (SHARP_F);
else
{
- dec_bit_string_ptr (scan1);
- dec_bit_string_ptr (scan2);
+ DEC_BIT_STRING_PTR (scan1);
+ DEC_BIT_STRING_PTR (scan2);
EQUAL_SECTIONS_P ();
}
}
destination and source. */
#define BITWISE_OP(action) \
- Pointer bit_string_1, bit_string_2; \
+{ \
+ SCHEME_OBJECT bit_string_1, bit_string_2; \
fast long i; \
- fast Pointer *scan1, *scan2; \
+ fast SCHEME_OBJECT *scan1, *scan2; \
PRIMITIVE_HEADER (2); \
- \
bit_string_1 = (ARG_REF (1)); \
bit_string_2 = (ARG_REF (2)); \
- if ((bit_string_length (bit_string_1)) != \
- (bit_string_length (bit_string_2))) \
+ if ((BIT_STRING_LENGTH (bit_string_1)) != \
+ (BIT_STRING_LENGTH (bit_string_2))) \
error_bad_range_arg (1); \
- \
- scan1 = (bit_string_high_ptr (bit_string_1)); \
- scan2 = (bit_string_high_ptr (bit_string_2)); \
- for (i = ((Vector_Length (bit_string_1)) - 1); (i > 0); i -= 1) \
- (* (dec_bit_string_ptr (scan1))) action() \
- (* (dec_bit_string_ptr (scan2))); \
- PRIMITIVE_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() &= ~
-#define bit_string_xor_x_action() ^=
+ scan1 = (BIT_STRING_HIGH_PTR (bit_string_1)); \
+ scan2 = (BIT_STRING_HIGH_PTR (bit_string_2)); \
+ for (i = ((VECTOR_LENGTH (bit_string_1)) - 1); (i > 0); i -= 1) \
+ (* (DEC_BIT_STRING_PTR (scan1))) action \
+ (* (DEC_BIT_STRING_PTR (scan2))); \
+ PRIMITIVE_RETURN (UNSPECIFIC); \
+}
DEFINE_PRIMITIVE ("BIT-STRING-MOVE!", Prim_bit_string_move_x, 2, 2, 0)
-{ BITWISE_OP (bit_string_move_x_action); }
+ BITWISE_OP (=)
DEFINE_PRIMITIVE ("BIT-STRING-MOVEC!", Prim_bit_string_movec_x, 2, 2, 0)
-{ BITWISE_OP (bit_string_movec_x_action); }
+ BITWISE_OP (=~)
DEFINE_PRIMITIVE ("BIT-STRING-OR!", Prim_bit_string_or_x, 2, 2, 0)
-{ BITWISE_OP (bit_string_or_x_action); }
+ BITWISE_OP (|=)
DEFINE_PRIMITIVE ("BIT-STRING-AND!", Prim_bit_string_and_x, 2, 2, 0)
-{ BITWISE_OP (bit_string_and_x_action); }
+ BITWISE_OP (&=)
DEFINE_PRIMITIVE ("BIT-STRING-ANDC!", Prim_bit_string_andc_x, 2, 2, 0)
-{ BITWISE_OP (bit_string_andc_x_action); }
+ BITWISE_OP (&=~)
DEFINE_PRIMITIVE ("BIT-STRING-XOR!", Prim_bit_string_xor_x, 2, 2, 0)
-{ BITWISE_OP (bit_string_xor_x_action); }
+ BITWISE_OP (^=)
\f
/* (BIT-SUBSTRING-MOVE-RIGHT! source start1 end1 destination start2)
Destructively copies the substring of SOURCE between START1 and
DEFINE_PRIMITIVE ("BIT-SUBSTRING-MOVE-RIGHT!", Prim_bit_substring_move_right_x, 5, 5, 0)
{
- fast Pointer bit_string_1, bit_string_2;
+ fast SCHEME_OBJECT bit_string_1, bit_string_2;
long start1, end1, start2, end2, nbits;
long end1_mod, end2_mod;
void copy_bits();
PRIMITIVE_HEADER (5);
-
CHECK_ARG (1, BIT_STRING_P);
bit_string_1 = (ARG_REF (1));
start1 = (arg_nonnegative_integer (2));
end1 = (arg_nonnegative_integer (3));
- CHECK_ARG (4, BIT_STRING_P);
+ CHECK_ARG (4, BIT_STRING_P);
bit_string_2 = (ARG_REF (4));
start2 = (arg_nonnegative_integer (5));
-
nbits = (end1 - start1);
end2 = (start2 + nbits);
-
if ((start1 < 0) || (start1 > end1))
error_bad_range_arg (2);
- if (end1 > (bit_string_length (bit_string_1)))
+ if (end1 > (BIT_STRING_LENGTH (bit_string_1)))
error_bad_range_arg (3);
- if ((start2 < 0) || (end2 > (bit_string_length (bit_string_2))))
+ if ((start2 < 0) || (end2 > (BIT_STRING_LENGTH (bit_string_2))))
error_bad_range_arg (5);
-
- end1_mod = (end1 % POINTER_LENGTH);
- end2_mod = (end2 % POINTER_LENGTH);
-
- /* Using `index_to_word' here with -1 offset will work in every
+ end1_mod = (end1 % OBJECT_LENGTH);
+ end2_mod = (end2 % OBJECT_LENGTH);
+ /* Using `BIT_STRING_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 expression `(-1 / OBJECT_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 (bit_string_1,
- (index_to_word (bit_string_1, (end1 - 1))))),
- ((end1_mod == 0) ? 0 : (POINTER_LENGTH - end1_mod)),
- (Nth_Vector_Loc (bit_string_2,
- (index_to_word (bit_string_2, (end2 - 1))))),
- ((end2_mod == 0) ? 0 : (POINTER_LENGTH - end2_mod)),
+ copy_bits ((MEMORY_LOC
+ (bit_string_1,
+ (BIT_STRING_INDEX_TO_WORD (bit_string_1, (end1 - 1))))),
+ ((end1_mod == 0) ? 0 : (OBJECT_LENGTH - end1_mod)),
+ (MEMORY_LOC
+ (bit_string_2,
+ (BIT_STRING_INDEX_TO_WORD (bit_string_2, (end2 - 1))))),
+ ((end2_mod == 0) ? 0 : (OBJECT_LENGTH - end2_mod)),
nbits);
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
#define MASKED_TRANSFER(source, destination, nbits, offset) do \
{ \
long mask; \
\
- mask = (any_mask (nbits, offset)); \
- (bit_string_word (destination)) = \
- (((bit_string_word (source)) & mask) | \
- ((bit_string_word (destination)) & ~mask)); \
+ mask = (ANY_MASK (nbits, offset)); \
+ (BIT_STRING_WORD (destination)) = \
+ (((BIT_STRING_WORD (source)) & mask) | \
+ ((BIT_STRING_WORD (destination)) & ~mask)); \
} while (0)
/* This procedure copies bits from one place to another.
- The offsets are measured from the MSB of the first Pointer of
+ The offsets are measured from the MSB of the first SCHEME_OBJECT 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;
+ SCHEME_OBJECT *source, *destination;
long source_offset, destination_offset, nbits;
{
\f
/* 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
+ transferred as SCHEME_OBJECTs, and only the `head' and `tail' need be
treated specially. */
if (source_offset == destination_offset)
{
long head;
- head = (POINTER_LENGTH - source_offset);
+ head = (OBJECT_LENGTH - source_offset);
if (nbits <= head)
{
MASKED_TRANSFER (source, destination, nbits, (head - nbits));
}
else
{
- Pointer temp;
+ SCHEME_OBJECT temp;
long mask;
- mask = (low_mask (head));
- temp = (bit_string_word (destination));
- (* (dec_bit_string_ptr (destination))) =
- (((* (dec_bit_string_ptr (source))) & mask) |
+ mask = (LOW_MASK (head));
+ temp = (BIT_STRING_WORD (destination));
+ (* (DEC_BIT_STRING_PTR (destination))) =
+ (((* (DEC_BIT_STRING_PTR (source))) & mask) |
(temp & (~ mask)));
nbits -= head;
}
{
long nwords, tail;
- for (nwords = (nbits / POINTER_LENGTH); (nwords > 0); nwords -= 1)
- (* (dec_bit_string_ptr (destination))) =
- (* (dec_bit_string_ptr (source)));
+ for (nwords = (nbits / OBJECT_LENGTH); (nwords > 0); nwords -= 1)
+ (* (DEC_BIT_STRING_PTR (destination))) =
+ (* (DEC_BIT_STRING_PTR (source)));
- tail = (nbits % POINTER_LENGTH);
+ tail = (nbits % OBJECT_LENGTH);
if (tail > 0)
MASKED_TRANSFER
- (source, destination, tail, (POINTER_LENGTH - tail));
+ (source, destination, tail, (OBJECT_LENGTH - tail));
}
}
\f
long offset1, offset2, head;
offset1 = (destination_offset - source_offset);
- offset2 = (POINTER_LENGTH - offset1);
- head = (POINTER_LENGTH - destination_offset);
+ offset2 = (OBJECT_LENGTH - offset1);
+ head = (OBJECT_LENGTH - destination_offset);
if (nbits <= head)
{
long mask;
- mask = (any_mask (nbits, (head - nbits)));
- (bit_string_word (destination)) =
- ((((bit_string_word (source)) >> offset1) & mask) |
- ((bit_string_word (destination)) & ~mask));
+ mask = (ANY_MASK (nbits, (head - nbits)));
+ (BIT_STRING_WORD (destination)) =
+ ((((BIT_STRING_WORD (source)) >> offset1) & mask) |
+ ((BIT_STRING_WORD (destination)) & ~mask));
}
else
{
long mask1, mask2;
- { Pointer temp;
+ { SCHEME_OBJECT temp;
long mask;
- mask = (low_mask (head));
- temp = (bit_string_word (destination));
- (* (dec_bit_string_ptr (destination))) =
- ((((bit_string_word (source)) >> offset1) & mask) |
+ mask = (LOW_MASK (head));
+ temp = (BIT_STRING_WORD (destination));
+ (* (DEC_BIT_STRING_PTR (destination))) =
+ ((((BIT_STRING_WORD (source)) >> offset1) & mask) |
(temp & ~mask));
}
nbits -= head;
- mask1 = (low_mask (offset1));
- mask2 = (low_mask (offset2));
+ mask1 = (LOW_MASK (offset1));
+ mask2 = (LOW_MASK (offset2));
{
long nwords, i;
- for (nwords = (nbits / POINTER_LENGTH); (nwords > 0); nwords -= 1)
+ for (nwords = (nbits / OBJECT_LENGTH); (nwords > 0); nwords -= 1)
{
- i = (((* (dec_bit_string_ptr (source))) & mask1) << offset2);
- (* (dec_bit_string_ptr (destination))) =
- ((((bit_string_word (source)) >> offset1) & mask2) | i);
+ i = (((* (DEC_BIT_STRING_PTR (source))) & mask1) << offset2);
+ (* (DEC_BIT_STRING_PTR (destination))) =
+ ((((BIT_STRING_WORD (source)) >> offset1) & mask2) | i);
}
}
\f
{
long tail, dest_tail;
- tail = (nbits % POINTER_LENGTH);
+ tail = (nbits % OBJECT_LENGTH);
dest_tail =
- ((bit_string_word (destination)) &
- (low_mask (POINTER_LENGTH - tail)));
+ ((BIT_STRING_WORD (destination)) &
+ (LOW_MASK (OBJECT_LENGTH - tail)));
if (tail <= offset1)
{
- (bit_string_word (destination)) =
- ((((bit_string_word (source)) &
- (any_mask (tail, (offset1 - tail))))
+ (BIT_STRING_WORD (destination)) =
+ ((((BIT_STRING_WORD (source)) &
+ (ANY_MASK (tail, (offset1 - tail))))
<< offset2)
| dest_tail);
}
{
long i, j;
- i = (((* (dec_bit_string_ptr (source))) & mask1) << offset2);
+ i = (((* (DEC_BIT_STRING_PTR (source))) & mask1) << offset2);
j = (tail - offset1);
- (bit_string_word (destination)) =
- ((((bit_string_word (source)) &
- (any_mask (j, (POINTER_LENGTH - j))))
+ (BIT_STRING_WORD (destination)) =
+ ((((BIT_STRING_WORD (source)) &
+ (ANY_MASK (j, (OBJECT_LENGTH - j))))
>> offset1)
| i | dest_tail);
}
long offset1, offset2, head;
offset1 = (source_offset - destination_offset);
- offset2 = (POINTER_LENGTH - offset1);
- head = (POINTER_LENGTH - source_offset);
+ offset2 = (OBJECT_LENGTH - offset1);
+ head = (OBJECT_LENGTH - source_offset);
if (nbits <= head)
{
long mask;
- mask = (any_mask (nbits, (offset1 + (head - nbits))));
- (bit_string_word (destination)) =
- ((((bit_string_word (source)) << offset1) & mask) |
- ((bit_string_word (destination)) & ~mask));
+ mask = (ANY_MASK (nbits, (offset1 + (head - nbits))));
+ (BIT_STRING_WORD (destination)) =
+ ((((BIT_STRING_WORD (source)) << offset1) & mask) |
+ ((BIT_STRING_WORD (destination)) & ~mask));
}
else
{
{
long mask;
- mask = (any_mask (head, offset1));
+ mask = (ANY_MASK (head, offset1));
dest_buffer =
- (((bit_string_word (destination)) & ~mask)
- | (((* (dec_bit_string_ptr (source))) << offset1) & mask));
+ (((BIT_STRING_WORD (destination)) & ~mask)
+ | (((* (DEC_BIT_STRING_PTR (source))) << offset1) & mask));
}
nbits -= head;
- mask1 = (low_mask (offset1));
- mask2 = (any_mask (offset2, offset1));
+ mask1 = (LOW_MASK (offset1));
+ mask2 = (ANY_MASK (offset2, offset1));
{
long nwords;
- nwords = (nbits / POINTER_LENGTH);
+ nwords = (nbits / OBJECT_LENGTH);
if (nwords > 0)
dest_buffer &= mask2;
for (; (nwords > 0); nwords -= 1)
{
- (* (dec_bit_string_ptr (destination))) =
+ (* (DEC_BIT_STRING_PTR (destination))) =
(dest_buffer |
- (((bit_string_word (source)) >> offset2) & mask1));
- dest_buffer = ((* (dec_bit_string_ptr (source))) << offset1);
+ (((BIT_STRING_WORD (source)) >> offset2) & mask1));
+ dest_buffer = ((* (DEC_BIT_STRING_PTR (source))) << offset1);
}
}
\f
{
long tail;
- tail = (nbits % POINTER_LENGTH);
+ tail = (nbits % OBJECT_LENGTH);
if (tail <= offset1)
{
long mask;
- mask = (any_mask (tail, (offset1 - tail)));
+ mask = (ANY_MASK (tail, (offset1 - tail)));
/* This path through copy bits didn't work in certain
*/
dest_buffer &= (~ mask);
- (bit_string_word (destination)) =
+ (BIT_STRING_WORD (destination)) =
(dest_buffer |
- ((bit_string_word (destination)) &
- (low_mask (offset1 - tail))) |
- (((bit_string_word (source)) >> offset2) &
+ ((BIT_STRING_WORD (destination)) &
+ (LOW_MASK (offset1 - tail))) |
+ (((BIT_STRING_WORD (source)) >> offset2) &
mask));
}
else
{
long mask;
- (* (dec_bit_string_ptr (destination))) =
+ (* (DEC_BIT_STRING_PTR (destination))) =
(dest_buffer |
- (((bit_string_word (source)) >> offset2) & mask1));
- mask = (low_mask (POINTER_LENGTH - tail));
- (bit_string_word (destination)) =
- (((bit_string_word (destination)) & (~ mask)) |
- (((bit_string_word (source)) << offset1) & mask));
+ (((BIT_STRING_WORD (source)) >> offset2) & mask1));
+ mask = (LOW_MASK (OBJECT_LENGTH - tail));
+ (BIT_STRING_WORD (destination)) =
+ (((BIT_STRING_WORD (destination)) & (~ mask)) |
+ (((BIT_STRING_WORD (source)) << offset1) & mask));
}
}
}
: (count_significant_bits (number, (ULONG_SIZE - 1))));
}
\f
-Pointer
+SCHEME_OBJECT
zero_to_bit_string (length)
long length;
{
- Pointer result;
+ SCHEME_OBJECT result;
result = (allocate_bit_string (length));
clear_bit_string (result);
return (result);
}
-Pointer
+SCHEME_OBJECT
long_to_bit_string (length, number)
long length, number;
{
}
else
{
- Pointer result;
+ SCHEME_OBJECT result;
if (length < (long_significant_bits (number)))
error_bad_range_arg (2);
result = (zero_to_bit_string (length));
- (bit_string_lsw (result)) = number;
+ (BIT_STRING_LSW (result)) = number;
return (result);
}
}
\f
-/* The bignum <-> bit-string coercion procedures use the following pun:
- inc_bit_string_ptr is being used on a *bigdigit, rather than *Pointer.
-*/
-
-Pointer
+SCHEME_OBJECT
bignum_to_bit_string (length, bignum)
long length;
- Pointer bignum;
+ SCHEME_OBJECT bignum;
{
- bigdigit *bigptr;
- long ndigits;
-
- bigptr = (BIGNUM (Get_Pointer (bignum)));
- if (NEG_BIGNUM (bigptr))
- error_bad_range_arg (2);
- ndigits = (LEN (bigptr));
- if (ndigits == 0)
- zero_to_bit_string (length);
- else
+ switch (bignum_test (bignum))
{
- Pointer result;
- bigdigit *scan1, *scan2;
-
- if (length <
- (count_significant_bits ((* (Bignum_Top (bigptr))), SHIFT)
- + (SHIFT * (ndigits - 1))))
+ case bignum_comparison_equal:
+ return (zero_to_bit_string (length));
+ case bignum_comparison_less:
+ error_bad_range_arg (2);
+ case bignum_comparison_greater:
+ if (! (bignum_fits_in_word_p (bignum, length, 0)))
error_bad_range_arg (2);
- result = (zero_to_bit_string (length));
- scan1 = (Bignum_Bottom (bigptr));
- scan2 = ((bigdigit *) (bit_string_low_ptr (result)));
- for (; (ndigits > 0); ndigits -= 1)
- (* (inc_bit_string_ptr (scan2))) = (*scan1++);
- return (result);
+ {
+ static void btbs_consumer ();
+ SCHEME_OBJECT result = (zero_to_bit_string (length));
+ unsigned char * result_ptr =
+ ((unsigned char *) (BIT_STRING_LOW_PTR (result)));
+ bignum_to_digit_stream
+ (bignum, (1 << CHAR_BIT), btbs_consumer, (&result_ptr));
+ return (result);
+ }
}
}
-\f
-Pointer
+
+static void
+btbs_consumer (result_ptr, digit)
+ unsigned char ** result_ptr;
+ unsigned int digit;
+{
+ (* (INC_BIT_STRING_PTR (*result_ptr))) = digit;
+ return;
+}
+
+SCHEME_OBJECT
bit_string_to_bignum (nbits, bitstr)
long nbits;
- Pointer bitstr;
+ SCHEME_OBJECT bitstr;
{
- fast long ndigits;
- long align_ndigits;
- fast bigdigit *scan1, *scan2;
- bigdigit *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_low_ptr (bitstr)));
- scan2 = (Bignum_Bottom (bignum));
- while ((--ndigits) > 0)
- (*scan2++) = (* (inc_bit_string_ptr (scan1)));
- nbits = (nbits % SHIFT);
- (*scan2) =
- ((nbits == 0)
- ? (* (inc_bit_string_ptr (scan1)))
- : ((* (inc_bit_string_ptr (scan1))) & (low_mask (nbits))));
-
- return (Make_Pointer (TC_BIG_FIXNUM, ((Pointer *) bignum)));
+ static unsigned int bstb_producer ();
+ unsigned char * source_ptr =
+ ((unsigned char *) (BIT_STRING_HIGH_PTR (bitstr)));
+ return
+ (digit_stream_to_bignum
+ (((nbits + (CHAR_BIT - 1)) / CHAR_BIT),
+ bstb_producer, (&source_ptr),
+ (1 << CHAR_BIT), 0));
+}
+
+static unsigned int
+bstb_producer (source_ptr)
+ unsigned char ** source_ptr;
+{
+ return (* (DEC_BIT_STRING_PTR (*source_ptr)));
}
\f
/* (UNSIGNED-INTEGER->BIT-STRING length integer)
DEFINE_PRIMITIVE ("UNSIGNED-INTEGER->BIT-STRING", Prim_unsigned_to_bit_string, 2, 2, 0)
{
fast long length;
- fast Pointer object;
+ fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (2);
-
length = (arg_nonnegative_integer (1));
object = (ARG_REF (2));
-
if (FIXNUM_P (object))
{
if (FIXNUM_NEGATIVE_P (object))
error_bad_range_arg (2);
- PRIMITIVE_RETURN (long_to_bit_string (length,
- (UNSIGNED_FIXNUM_VALUE (object))));
+ PRIMITIVE_RETURN
+ (long_to_bit_string
+ (length, (UNSIGNED_FIXNUM_TO_LONG (object))));
}
if (BIGNUM_P (object))
PRIMITIVE_RETURN (bignum_to_bit_string (length, object));
error_wrong_type_arg (2);
+ /* NOTREACHED */
}
-\f
+
/* (BIT-STRING->UNSIGNED-INTEGER bit-string)
BIT-STRING is converted to the appropriate non-negative integer.
This operation is the inverse of `unsigned-integer->bit-string'. */
DEFINE_PRIMITIVE ("BIT-STRING->UNSIGNED-INTEGER", Prim_bit_string_to_unsigned, 1, 1, 0)
{
- fast Pointer bit_string, *scan;
+ fast SCHEME_OBJECT bit_string, *scan;
long nwords, nbits, word;
PRIMITIVE_HEADER (1);
-
CHECK_ARG (1, BIT_STRING_P);
bit_string = (ARG_REF (1));
-
/* Count the number of significant bits.*/
- scan = (bit_string_high_ptr (bit_string));
- nbits = ((bit_string_length (bit_string)) % POINTER_LENGTH);
+ scan = (BIT_STRING_HIGH_PTR (bit_string));
+ nbits = ((BIT_STRING_LENGTH (bit_string)) % OBJECT_LENGTH);
word =
((nbits > 0)
- ? ((* (dec_bit_string_ptr (scan))) & (low_mask (nbits)))
- : (* (dec_bit_string_ptr (scan))));
- for (nwords = ((Vector_Length (bit_string)) - 1); (nwords > 0); nwords -= 1)
+ ? ((* (DEC_BIT_STRING_PTR (scan))) & (LOW_MASK (nbits)))
+ : (* (DEC_BIT_STRING_PTR (scan))));
+ for (nwords = ((VECTOR_LENGTH (bit_string)) - 1); (nwords > 0); nwords -= 1)
{
if (word != 0)
break;
- word = (* (dec_bit_string_ptr (scan)));
+ word = (* (DEC_BIT_STRING_PTR (scan)));
}
if (nwords == 0)
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (0));
- nbits = (((nwords - 1) * POINTER_LENGTH) + (long_significant_bits (word)));
-
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
+ nbits = (((nwords - 1) * OBJECT_LENGTH) + (long_significant_bits (word)));
PRIMITIVE_RETURN
((nbits < FIXNUM_LENGTH)
- ? (Make_Unsigned_Fixnum (word))
+ ? (LONG_TO_UNSIGNED_FIXNUM (word))
: (bit_string_to_bignum (nbits, bit_string)));
}
\f
#define READ_BITS_INITIALIZE() \
- Pointer bit_string; \
+ SCHEME_OBJECT bit_string; \
long end, end_mod, offset; \
- Pointer *start; \
+ SCHEME_OBJECT *start; \
PRIMITIVE_HEADER (3); \
- \
CHECK_ARG (3, BIT_STRING_P); \
bit_string = (ARG_REF (3)); \
- end = (bit_string_length (bit_string)); \
- end_mod = (end % POINTER_LENGTH); \
+ end = (BIT_STRING_LENGTH (bit_string)); \
+ end_mod = (end % OBJECT_LENGTH); \
offset = (arg_nonnegative_integer (2)); \
- start = (read_bits_ptr ((ARG_REF (1)), offset, end)); \
- compute_read_bits_offset (offset, end)
+ start = (READ_BITS_PTR ((ARG_REF (1)), offset, end)); \
+ COMPUTE_READ_BITS_OFFSET (offset, end)
/* (READ-BITS! pointer offset bit-string)
DEFINE_PRIMITIVE ("READ-BITS!", Prim_read_bits_x, 3, 3, 0)
{
READ_BITS_INITIALIZE ();
-
copy_bits (start,
offset,
- (Nth_Vector_Loc (bit_string,
- (index_to_word (bit_string, (end - 1))))),
- ((end_mod == 0) ? 0 : (POINTER_LENGTH - end_mod)),
+ (MEMORY_LOC
+ (bit_string,
+ (BIT_STRING_INDEX_TO_WORD (bit_string, (end - 1))))),
+ ((end_mod == 0) ? 0 : (OBJECT_LENGTH - end_mod)),
end);
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
/* (WRITE-BITS! pointer offset bit-string)
DEFINE_PRIMITIVE ("WRITE-BITS!", Prim_write_bits_x, 3, 3, 0)
{
READ_BITS_INITIALIZE ();
-
- copy_bits ((Nth_Vector_Loc (bit_string,
- (index_to_word (bit_string, (end - 1))))),
- ((end_mod == 0) ? 0 : (POINTER_LENGTH - end_mod)),
+ copy_bits ((MEMORY_LOC
+ (bit_string,
+ (BIT_STRING_INDEX_TO_WORD (bit_string, (end - 1))))),
+ ((end_mod == 0) ? 0 : (OBJECT_LENGTH - end_mod)),
start,
offset,
end);
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
/* Search Primitives */
#define SUBSTRING_FIND_INITIALIZE() \
- Pointer bit_string; \
+ SCHEME_OBJECT bit_string; \
long start, end; \
long word, bit, end_word, end_bit, mask; \
- Pointer *scan; \
+ SCHEME_OBJECT *scan; \
PRIMITIVE_HEADER (3); \
- \
CHECK_ARG (1, BIT_STRING_P); \
bit_string = (ARG_REF (1)); \
start = (arg_nonnegative_integer (2)); \
end = (arg_nonnegative_integer (3)); \
- \
- if (end > (bit_string_length (bit_string))) \
+ if (end > (BIT_STRING_LENGTH (bit_string))) \
error_bad_range_arg (3); \
if (start > end) \
error_bad_range_arg (2); \
- \
if (start == end) \
- PRIMITIVE_RETURN (NIL)
+ PRIMITIVE_RETURN (SHARP_F)
#define SUBSTRING_FIND_NEXT_INITIALIZE() \
SUBSTRING_FIND_INITIALIZE (); \
- word = (index_to_word (bit_string, start)); \
- bit = (start % POINTER_LENGTH); \
- end_word = (index_to_word (bit_string, (end - 1))); \
- end_bit = (((end - 1) % POINTER_LENGTH) + 1); \
- scan = (Nth_Vector_Loc (bit_string, word))
+ word = (BIT_STRING_INDEX_TO_WORD (bit_string, start)); \
+ bit = (start % OBJECT_LENGTH); \
+ end_word = (BIT_STRING_INDEX_TO_WORD (bit_string, (end - 1))); \
+ end_bit = (((end - 1) % OBJECT_LENGTH) + 1); \
+ scan = (MEMORY_LOC (bit_string, word))
#define FIND_NEXT_SET_LOOP(init_bit) \
{ \
mask = (1 << (init_bit)); \
while (true) \
{ \
- if (((bit_string_word (scan)) & mask) != 0) \
+ if (((BIT_STRING_WORD (scan)) & mask) != 0) \
goto win; \
bit += 1; \
mask <<= 1; \
} \
}
-\f
+
DEFINE_PRIMITIVE ("BIT-SUBSTRING-FIND-NEXT-SET-BIT", Prim_bitstr_find_next_set_bit, 3, 3, 0)
{
SUBSTRING_FIND_NEXT_INITIALIZE ();
-
if (word == end_word)
{
- if ((((end_bit - bit) == POINTER_LENGTH) &&
- ((bit_string_word (scan)) != 0)) ||
- (((bit_string_word (scan)) & (any_mask ((end_bit - bit), bit)))
+ if ((((end_bit - bit) == OBJECT_LENGTH) &&
+ ((BIT_STRING_WORD (scan)) != 0)) ||
+ (((BIT_STRING_WORD (scan)) & (ANY_MASK ((end_bit - bit), bit)))
!= 0))
{
FIND_NEXT_SET_LOOP (bit);
}
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
- else if (((bit_string_word (scan)) &
- ((bit == 0) ? (~ 0) : (any_mask ((POINTER_LENGTH - bit), bit))))
+ else if (((BIT_STRING_WORD (scan)) &
+ ((bit == 0) ? (~ 0) : (ANY_MASK ((OBJECT_LENGTH - bit), bit))))
!= 0)
{
FIND_NEXT_SET_LOOP (bit);
}
-
while ((--word) > end_word)
- if ((* (inc_bit_string_ptr (scan))) != 0)
+ if ((* (INC_BIT_STRING_PTR (scan))) != 0)
{
FIND_NEXT_SET_LOOP (0);
}
-
- if (((* (inc_bit_string_ptr (scan))) &
- ((end_bit == POINTER_LENGTH) ? (~ 0) : (low_mask (end_bit))))
+ if (((* (INC_BIT_STRING_PTR (scan))) &
+ ((end_bit == OBJECT_LENGTH) ? (~ 0) : (LOW_MASK (end_bit))))
!= 0)
{
FIND_NEXT_SET_LOOP (0);
}
-
- PRIMITIVE_RETURN (NIL);
-
+ PRIMITIVE_RETURN (SHARP_F);
win:
- PRIMITIVE_RETURN (index_pair_to_bit_fixnum (bit_string, word, bit));
+ PRIMITIVE_RETURN
+ (LONG_TO_UNSIGNED_FIXNUM
+ (BIT_STRING_INDEX_PAIR_TO_INDEX (bit_string, word, bit)));
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.h,v 1.5 1988/08/15 20:37:27 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.h,v 1.6 1989/09/20 23:06:15 cph Exp $
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
/* Bit string macros. "Little indian" version. */
\f
#define BIT_STRING_LENGTH_OFFSET 1
-#define BIT_STRING_FIRST_WORD 2
+#define BIT_STRING_FIRST_WORD 2
-#define bits_to_pointers(bits) \
-(((bits) + (POINTER_LENGTH - 1)) / POINTER_LENGTH)
+#define BIT_STRING_LENGTH_TO_GC_LENGTH(bits) \
+ (((bits) + (OBJECT_LENGTH - 1)) / OBJECT_LENGTH)
-#define low_mask(nbits) ((1 << (nbits)) - 1)
-#define any_mask(nbits, offset) ((low_mask (nbits)) << (offset))
+#define LOW_MASK(nbits) ((1 << (nbits)) - 1)
+#define ANY_MASK(nbits, offset) ((LOW_MASK (nbits)) << (offset))
-#define bit_string_length(bit_string) \
-(Fast_Vector_Ref (bit_string, BIT_STRING_LENGTH_OFFSET))
+#define BIT_STRING_LENGTH(bit_string) \
+ ((long) (FAST_MEMORY_REF ((bit_string), BIT_STRING_LENGTH_OFFSET)))
-#define bit_string_start_ptr(bit_string) \
-(Nth_Vector_Loc (bit_string, BIT_STRING_FIRST_WORD))
+#define BIT_STRING_MSW(bit_string) \
+ (BIT_STRING_WORD (BIT_STRING_HIGH_PTR (bit_string)))
-#define bit_string_end_ptr(bit_string) \
-(Nth_Vector_Loc (bit_string, ((Vector_Length (bit_string)) + 1)))
-
-#define bit_string_msw(bit_string) \
-(bit_string_word(bit_string_high_ptr(bit_string)))
-
-#define bit_string_lsw(bit_string) \
-(bit_string_word(Nth_Vector_Loc(bit_string, index_to_word(bit_string, 0))))
-
-#define index_pair_to_bit_fixnum(string, word, bit) \
-(Make_Unsigned_Fixnum (index_pair_to_bit_number (string, word, bit)))
+#define BIT_STRING_LSW(bit_string) \
+ (BIT_STRING_WORD \
+ (MEMORY_LOC \
+ ((bit_string), (BIT_STRING_INDEX_TO_WORD ((bit_string), 0)))))
\f
/* Byte order dependencies. */
*/
-#define bit_string_high_ptr bit_string_end_ptr
-
-#define bit_string_low_ptr bit_string_start_ptr
+#define BIT_STRING_HIGH_PTR(bit_string) \
+ (MEMORY_LOC ((bit_string), ((VECTOR_LENGTH (bit_string)) + 1)))
-#define bit_string_word(ptr) (*((ptr) - 1))
+#define BIT_STRING_LOW_PTR(bit_string) \
+ (MEMORY_LOC ((bit_string), BIT_STRING_FIRST_WORD))
-#define dec_bit_string_ptr(ptr) (--(ptr))
+#define BIT_STRING_WORD(ptr) (*((ptr) - 1))
+#define DEC_BIT_STRING_PTR(ptr) (--(ptr))
+#define INC_BIT_STRING_PTR(ptr) ((ptr)++)
+
+/* This is off by one so BIT_STRING_WORD will get the correct word. */
-#define inc_bit_string_ptr(ptr) ((ptr)++)
+#define BIT_STRING_INDEX_TO_WORD(bit_string, index) \
+ ((BIT_STRING_FIRST_WORD + 1) + ((index) / OBJECT_LENGTH))
-/* This is off by one so bit_string_word will get the correct word. */
+#define BIT_STRING_INDEX_PAIR_TO_INDEX(string, word, bit) \
+ (((word) * OBJECT_LENGTH) + (bit))
-#define index_to_word(bit_string, index) \
-((BIT_STRING_FIRST_WORD + 1) + (index / POINTER_LENGTH))
+#define READ_BITS_PTR(object, offset, end) \
+ (MEMORY_LOC \
+ ((object), (BIT_STRING_LENGTH_TO_GC_LENGTH (((offset) + (end)) - 1))))
-#define index_pair_to_bit_number(string, word, bit) \
-(((word) * POINTER_LENGTH) + (bit))
-
-#define read_bits_ptr(object, offset, end) \
-(Nth_Vector_Loc(object, bits_to_pointers((offset + end) - 1)))
-
-#define compute_read_bits_offset(offset, end) \
+#define COMPUTE_READ_BITS_OFFSET(offset, end) \
{ \
- offset = ((offset + end) % POINTER_LENGTH); \
+ offset = ((offset + end) % OBJECT_LENGTH); \
if (offset != 0) \
- offset = (POINTER_LENGTH - offset); \
+ offset = (OBJECT_LENGTH - offset); \
}
-
-
\f
#else /* not VAX_BYTE_ORDER */
The "size in bits" is a C "long" integer.
*/
-#define bit_string_high_ptr bit_string_start_ptr
-
-#define bit_string_low_ptr bit_string_end_ptr
+#define BIT_STRING_HIGH_PTR(bit_string) \
+ (MEMORY_LOC ((bit_string), BIT_STRING_FIRST_WORD))
-#define bit_string_word(ptr) (*(ptr))
+#define BIT_STRING_LOW_PTR(bit_string) \
+ (MEMORY_LOC ((bit_string), ((VECTOR_LENGTH (bit_string)) + 1)))
-#define dec_bit_string_ptr(ptr) ((ptr)++)
-
-#define inc_bit_string_ptr(ptr) (--(ptr))
+#define BIT_STRING_WORD(ptr) (*(ptr))
+#define DEC_BIT_STRING_PTR(ptr) ((ptr)++)
+#define INC_BIT_STRING_PTR(ptr) (--(ptr))
/* This 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 BIT_STRING_INDEX_TO_WORD(bit_string, index) \
+ ((VECTOR_LENGTH (bit_string)) - ((index) / OBJECT_LENGTH))
-#define index_to_word(bit_string, index) \
-((Vector_Length (bit_string)) - (index / POINTER_LENGTH))
-
-#define index_pair_to_bit_number(string, word, bit) \
-((((Vector_Length (string)) - (word)) * POINTER_LENGTH) + (bit))
+#define BIT_STRING_INDEX_PAIR_TO_INDEX(string, word, bit) \
+ ((((VECTOR_LENGTH (string)) - (word)) * OBJECT_LENGTH) + (bit))
-#define read_bits_ptr(object, offset, end) \
-(Nth_Vector_Loc((object), ((offset) / POINTER_LENGTH)))
-
-#define compute_read_bits_offset(offset, end) \
-{ \
- offset = (offset % POINTER_LENGTH); \
-}
+#define READ_BITS_PTR(object, offset, end) \
+ (MEMORY_LOC ((object), ((offset) / OBJECT_LENGTH)))
+#define COMPUTE_READ_BITS_OFFSET(offset, end) \
+ (offset) = ((offset) % OBJECT_LENGTH);
#endif /* VAX_BYTE_ORDER */
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.c,v 9.23 1989/09/20 23:06:19 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.c,v 9.22 1988/08/15 20:37:36 cph Rel $
- *
- * This file contains breakpoint utilities.
- * Disabled when not debugging the interpreter.
- *
- */
+/* This file contains breakpoint utilities.
+ Disabled when not debugging the interpreter. */
\f
#include "scheme.h"
extern Boolean Add_a_Pop_Return_Breakpoint();
static struct sp_record One_Before =
-{ ((Pointer *) 0),
- sp_nil
+{ ((SCHEME_OBJECT *) 0),
+ sp_nil
};
Boolean Add_a_Pop_Return_Breakpoint(SP)
-Pointer *SP;
+SCHEME_OBJECT *SP;
{ sp_record_list old = SP_List;
SP_List = ((sp_record_list) malloc(sizeof(struct sp_record)));
if (SP_List == sp_nil)
*/
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 */
+{ fast SCHEME_OBJECT *SP = Stack_Pointer;
+ fast sp_record_list previous = &One_Before;
+ fast sp_record_list this = previous->next; /* = SP_List */
for ( ;
this != sp_nil;
previous = this, this = this->next)
return;
}
-/* A breakpoint can be placed here from a C debugger to examine
+/* 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;
+ SCHEME_OBJECT *Old_Stack = Stack_Pointer;
printf("Pop Return Break: SP = 0x%x\n", Stack_Pointer);
ignore = Print_One_Continuation_Frame();
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.27 1989/09/20 23:06:22 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.26 1989/03/27 23:14:08 jinx Rel $
- *
- * This file contains breakpoint utilities.
- * Disabled when not debugging the interpreter.
- * It "shadows" definitions in default.h
- *
- */
+/* This file contains breakpoint utilities.
+ Disabled when not debugging the interpreter.
+ It "shadows" definitions in default.h */
#ifdef ENABLE_DEBUGGING_TOOLS
\f
struct sp_record
-{ Pointer *sp;
+{ SCHEME_OBJECT *sp;
struct sp_record *next;
};
typedef struct sp_record *sp_record_list;
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.56 1989/06/12 17:36:22 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.57 1989/09/20 23:06:26 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
/* This file contains the code to support startup of
the SCHEME interpreter.
-
- The command line (when not running a dumped executable version) may
+
+ The command line (when not running a dumped executable version) may
take the following forms:
scheme
#include "scheme.h"
#include "prims.h"
#include "version.h"
-#include "char.h"
-#include "string.h"
#include "paths.h"
#ifndef islower
#include <ctype.h>
return;
}
\f
-int
+int
Parse_Option(opt_key, nargs, args, casep)
char *opt_key, **args;
Boolean casep;
int nargs;
{
int position;
-
+
position = Parse_Option(key, nargs, args, true);
if ((position == NOT_THERE) || (position == (nargs-1)))
{
{
return atoi(args[position+1]);
}
-}
+}
\f
/* Used to test whether it is a dumped executable version */
Exit_Scheme_Declarations;
-forward void Start_Scheme();
+forward void Start_Scheme ();
+forward void Enter_Interpreter ();
extern void Clear_Memory(), Setup_Memory(), Reset_Memory();
+extern void OS_initialize ();
/*
THE MAIN PROGRAM
*/
main_type
-main(argc, argv)
+main (argc, argv)
int argc;
- char **argv;
+ char ** argv;
{
Boolean cold_load_p, supplied_p;
char *file_name;
- extern void compiler_initialize();
+ extern void compiler_initialize ();
Init_Exit_Scheme();
if (!supplied_p)
{
printf("Scheme Microcode Version %d.%d\n", VERSION, SUBVERSION);
- OS_Init(true);
+ OS_initialize(true);
Enter_Interpreter();
}
else
\f
#define Default_Init_Fixed_Objects(Fixed_Objects) \
{ \
- Fixed_Objects = make_fixed_objects_vector(); \
+ Fixed_Objects = (make_fixed_objects_vector ()); \
}
-Pointer
-make_fixed_objects_vector()
+SCHEME_OBJECT
+make_fixed_objects_vector ()
{
- fast Pointer fixed_objects_vector;
- 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 + 2)));
- for (i = 0; (i <= (MAX_INTERRUPT_NUMBER + 1)); i += 1)
- {
- *Free++ = NIL;
- }
-
+ extern SCHEME_OBJECT initialize_history ();
+ /* Create the fixed objects vector,
+ with 4 extra slots for expansion and debugging. */
+ fast SCHEME_OBJECT fixed_objects_vector =
+ (make_vector ((NFixed_Objects + 4), SHARP_F, false));
+ VECTOR_SET (fixed_objects_vector, Me_Myself, fixed_objects_vector);
+ VECTOR_SET (fixed_objects_vector, Non_Object, (MAKE_OBJECT (TC_TRUE, 2)));
+ VECTOR_SET
+ (fixed_objects_vector,
+ System_Interrupt_Vector,
+ (make_vector ((MAX_INTERRUPT_NUMBER + 2), SHARP_F, false)));
/* 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;
- }
-
- /* 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);
-\f
- /* Cons the FIXED OBJECTS VECTOR */
-
- fixed_objects_vector = Make_Pointer(TC_VECTOR, Free);
-
- /* Create the vector with 4 extra slots for expansion and
- debugging.
- */
-
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, (NFixed_Objects + 4));
- for (i=1; i <= (NFixed_Objects + 4); i++)
- {
- *Free++ = NIL;
- }
-
- /* Initialize components */
-
- User_Vector_Set(fixed_objects_vector, Non_Object,
- (Make_Non_Pointer (TC_TRUE, 2)));
- User_Vector_Set(fixed_objects_vector, System_Interrupt_Vector, Int_Vec);
- User_Vector_Set(fixed_objects_vector, System_Error_Vector, Error);
- User_Vector_Set(fixed_objects_vector, OBArray, OB_Array);
- User_Vector_Set(fixed_objects_vector, Dummy_History,
- Make_Pointer(UNMARKED_HISTORY_TYPE, Dummy_Hist));
- User_Vector_Set(fixed_objects_vector, State_Space_Tag, SHARP_T);
- User_Vector_Set(fixed_objects_vector, Bignum_One,
- Fix_To_Big(Make_Unsigned_Fixnum(1)));
- User_Vector_Set(fixed_objects_vector, Me_Myself, fixed_objects_vector);
- User_Vector_Set(fixed_objects_vector, The_Work_Queue, The_Queue);
- User_Vector_Set(fixed_objects_vector, Utilities_Vector, The_Utilities);
- return fixed_objects_vector;
+ VECTOR_SET (fixed_objects_vector, System_Error_Vector, SHARP_F);
+ VECTOR_SET
+ (fixed_objects_vector,
+ OBArray,
+ (make_vector (OBARRAY_SIZE, EMPTY_LIST, false)));
+ VECTOR_SET (fixed_objects_vector, Dummy_History, (initialize_history ()));
+ VECTOR_SET (fixed_objects_vector, State_Space_Tag, SHARP_T);
+ VECTOR_SET (fixed_objects_vector, Bignum_One, (long_to_bignum (1)));
+
+ (*Free++) = EMPTY_LIST;
+ (*Free++) = EMPTY_LIST;
+ VECTOR_SET
+ (fixed_objects_vector,
+ The_Work_Queue,
+ (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2))));
+
+ VECTOR_SET
+ (fixed_objects_vector,
+ Utilities_Vector,
+ (make_vector (0, SHARP_F, false)));
+ return (fixed_objects_vector);
}
\f
/* Boot Scheme */
int Start_Prim;
char *File_Name;
{
- extern Pointer make_primitive();
- Pointer FName, Init_Prog, *Fasload_Call, prim;
+ extern SCHEME_OBJECT make_primitive();
+ SCHEME_OBJECT FName, Init_Prog, *Fasload_Call, prim;
fast long i;
Boolean I_Am_Master; /* Parallel processor test */
{
printf("Scheme Microcode Version %d.%d\n", VERSION, SUBVERSION);
}
- OS_Init(I_Am_Master);
+ OS_initialize(I_Am_Master);
if (I_Am_Master)
{
for (i = 0; i < FILE_CHANNELS; i++)
{
Channels[i] = NULL;
}
- Init_Fixed_Objects();
+ Current_State_Point = SHARP_F;
+ Fluid_Bindings = EMPTY_LIST;
+ GC_Reserve = 4500;
+ GC_Space_Needed = 0;
+ Photo_Open = false;
+ Init_Fixed_Objects ();
}
\f
/* The initial program to execute is one of
switch (Start_Prim)
{
case BOOT_FASLOAD: /* (SCODE-EVAL (BINARY-FASLOAD <file>) GLOBAL-ENV) */
- FName = C_String_To_Scheme_String(File_Name);
+ FName = char_pointer_to_string(File_Name);
prim = make_primitive("BINARY-FASLOAD");
Fasload_Call = Free;
*Free++ = prim;
*Free++ = FName;
prim = make_primitive("SCODE-EVAL");
- Init_Prog = Make_Pointer(TC_PCOMB2, Free);
+ Init_Prog = MAKE_POINTER_OBJECT (TC_PCOMB2, Free);
*Free++ = prim;
- *Free++ = Make_Pointer(TC_PCOMB1, Fasload_Call);
- *Free++ = Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL);
+ *Free++ = MAKE_POINTER_OBJECT (TC_PCOMB1, Fasload_Call);
+ *Free++ = MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL);
break;
case BOOT_LOAD_BAND: /* (LOAD-BAND <file>) */
- FName = C_String_To_Scheme_String(File_Name);
+ FName = char_pointer_to_string(File_Name);
prim = make_primitive("LOAD-BAND");
Fasload_Call = Free;
*Free++ = prim;
*Free++ = FName;
- Init_Prog = Make_Pointer(TC_PCOMB1, Fasload_Call);
+ Init_Prog = MAKE_POINTER_OBJECT (TC_PCOMB1, Fasload_Call);
break;
case BOOT_GET_WORK: /* ((GET-WORK)) */
prim = make_primitive("GET-WORK");
Fasload_Call = Free;
*Free++ = prim;
- *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);
+ *Free++ = SHARP_F;
+ Init_Prog = MAKE_POINTER_OBJECT (TC_COMBINATION, Free);
+ *Free++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, 1);
+ *Free++ = MAKE_POINTER_OBJECT (TC_PCOMB1, Fasload_Call);
break;
default:
- fprintf(stderr, "Unknown boot time option: %d\n", Start_Prim);
- Microcode_Termination(TERM_BAD_PRIMITIVE);
+ fprintf (stderr, "Unknown boot time option: %d\n", Start_Prim);
+ Microcode_Termination (TERM_BAD_PRIMITIVE);
/*NOTREACHED*/
}
/* Setup registers */
INITIALIZE_INTERRUPTS();
- Env = Make_Non_Pointer(GLOBAL_ENV, 0);
+ Env = MAKE_OBJECT (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();
+ Will_Push (CONTINUATION_SIZE);
+ Store_Return (RC_END_OF_COMPUTATION);
+ Store_Expression (SHARP_F);
+ Save_Cont ();
+ Pushed ();
- Store_Expression(Init_Prog);
+ 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);
+ fprintf (stderr, "Configuration won't hold initial data.\n");
+ Microcode_Termination (TERM_EXIT);
}
Entry_Hook();
Enter_Interpreter();
/*NOTREACHED*/
}
+void
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);
+ Interpret (Was_Scheme_Dumped);
+ fprintf (stderr, "\nThe interpreter returned to top level!\n");
+ fflush (stderr);
+ Microcode_Termination (TERM_EXIT);
/*NOTREACHED*/
}
\f
void
-attempt_termination_backout(code)
+attempt_termination_backout (code)
long code;
{
extern long death_blow;
- Pointer Term_Vector, Handler;
+ SCHEME_OBJECT Term_Vector;
+ SCHEME_OBJECT Handler;
- if ((WITHIN_CRITICAL_SECTION_P()) ||
- (code == TERM_HALT) ||
- (!(Valid_Fixed_Obj_Vector())))
- {
+ if ((WITHIN_CRITICAL_SECTION_P ()) ||
+ (code == TERM_HALT) ||
+ (! (Valid_Fixed_Obj_Vector ())))
return;
- }
-
- Term_Vector = Get_Fixed_Obj_Slot(Termination_Proc_Vector);
- if ((OBJECT_TYPE(Term_Vector) != TC_VECTOR) ||
- (Vector_Length(Term_Vector) <= code))
- {
+ Term_Vector = (Get_Fixed_Obj_Slot (Termination_Proc_Vector));
+ if ((! (VECTOR_P (Term_Vector))) ||
+ ((VECTOR_LENGTH (Term_Vector)) <= code))
return;
- }
-
- Handler = User_Vector_Ref(Term_Vector, code);
- if (Handler == NIL)
- {
+ Handler = (VECTOR_REF (Term_Vector, code));
+ if (Handler == SHARP_F)
return;
- }
- Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS +
- ((code == TERM_NO_ERROR_HANDLER) ? 5 : 4));
- Store_Return(RC_HALT);
- Store_Expression(Make_Unsigned_Fixnum(code));
- Save_Cont();
+ Will_Push (CONTINUATION_SIZE +
+ STACK_ENV_EXTRA_SLOTS +
+ ((code == TERM_NO_ERROR_HANDLER) ? 5 : 4));
+ Store_Return (RC_HALT);
+ Store_Expression (LONG_TO_UNSIGNED_FIXNUM (code));
+ Save_Cont ();
if (code == TERM_NO_ERROR_HANDLER)
{
- Push(MAKE_UNSIGNED_FIXNUM(death_blow));
+ Push (LONG_TO_UNSIGNED_FIXNUM (death_blow));
}
- Push(Val); /* Arg 3 */
- Push(Fetch_Env()); /* Arg 2 */
- Push(Fetch_Expression()); /* Arg 1 */
- Push(Handler); /* The handler function */
- Push(STACK_FRAME_HEADER + ((code == TERM_NO_ERROR_HANDLER) ? 4 : 3));
- Pushed();
- longjmp(*Back_To_Eval, PRIM_NO_TRAP_APPLY);
+ Push (Val); /* Arg 3 */
+ Push (Fetch_Env ()); /* Arg 2 */
+ Push (Fetch_Expression ()); /* Arg 1 */
+ Push (Handler); /* The handler function */
+ Push (STACK_FRAME_HEADER + ((code == TERM_NO_ERROR_HANDLER) ? 4 : 3));
+ Pushed ();
+ longjmp ((*Back_To_Eval), PRIM_NO_TRAP_APPLY);
/*NOTREACHED*/
}
\f
extern char *Term_Messages[];
Boolean abnormal_p;
long value;
+ extern void OS_quit ();
attempt_termination_backout(code);
value = 1;
abnormal_p = false;
break;
-
+
case TERM_NO_ERROR_HANDLER:
/* This does not print a back trace because it was printed before
getting here irrelevant of the state of Trace_On_Error.
}
break;
}
- OS_Flush_Output_Buffer ();
- OS_Quit (code, abnormal_p);
+ OS_tty_flush_output ();
+ OS_quit (code, abnormal_p);
Reset_Memory ();
Exit_Hook ();
Exit_Scheme (value);
\f
/* Garbage collection debugging utilities. */
-extern Pointer
+extern SCHEME_OBJECT
*deadly_free,
*deadly_scan;
extern char
gc_death_message_buffer[];
-Pointer
+SCHEME_OBJECT
*deadly_free,
*deadly_scan;
gc_death(code, message, scan, free)
long code;
char *message;
- Pointer *scan, *free;
+ SCHEME_OBJECT *scan, *free;
{
fprintf(stderr, "\n%s.\n", message);
fprintf(stderr, "scan = 0x%lx; free = 0x%lx\n", scan, free);
DEFINE_PRIMITIVE ("MICROCODE-IDENTIFY", Prim_microcode_identify, 0, 0, 0)
{
- extern Pointer make_vector ();
- fast Pointer Result;
+ fast SCHEME_OBJECT Result;
PRIMITIVE_HEADER (0);
-
- Result = (make_vector (IDENTITY_LENGTH, NIL));
- User_Vector_Set
- (Result, ID_RELEASE, (C_String_To_Scheme_String (RELEASE)));
- User_Vector_Set
- (Result, ID_MICRO_VERSION, (MAKE_UNSIGNED_FIXNUM (VERSION)));
- User_Vector_Set
- (Result, ID_MICRO_MOD, (MAKE_UNSIGNED_FIXNUM (SUBVERSION)));
- User_Vector_Set
- (Result, ID_PRINTER_WIDTH, (MAKE_UNSIGNED_FIXNUM (NColumns ())));
- User_Vector_Set
- (Result, ID_PRINTER_LENGTH, (MAKE_UNSIGNED_FIXNUM (NLines ())));
- User_Vector_Set
- (Result, ID_NEW_LINE_CHARACTER, (c_char_to_scheme_char ('\n')));
- User_Vector_Set
+ Result = (make_vector (IDENTITY_LENGTH, SHARP_F, true));
+ FAST_VECTOR_SET
+ (Result, ID_RELEASE, (char_pointer_to_string (RELEASE)));
+ FAST_VECTOR_SET
+ (Result, ID_MICRO_VERSION, (LONG_TO_UNSIGNED_FIXNUM (VERSION)));
+ FAST_VECTOR_SET
+ (Result, ID_MICRO_MOD, (LONG_TO_UNSIGNED_FIXNUM (SUBVERSION)));
+ FAST_VECTOR_SET
+ (Result, ID_PRINTER_WIDTH, (LONG_TO_UNSIGNED_FIXNUM (OS_tty_x_size ())));
+ FAST_VECTOR_SET
+ (Result, ID_PRINTER_LENGTH, (LONG_TO_UNSIGNED_FIXNUM (OS_tty_y_size ())));
+ FAST_VECTOR_SET
+ (Result, ID_NEW_LINE_CHARACTER, (ASCII_TO_CHAR ('\n')));
+ FAST_VECTOR_SET
(Result, ID_FLONUM_PRECISION,
- (MAKE_UNSIGNED_FIXNUM (FLONUM_MANTISSA_BITS)));
- User_Vector_Set
- (Result, ID_FLONUM_EXPONENT, (MAKE_UNSIGNED_FIXNUM (FLONUM_EXPT_SIZE)));
- User_Vector_Set
- (Result, ID_OS_NAME, (C_String_To_Scheme_String (OS_Name)));
- User_Vector_Set
- (Result, ID_OS_VARIANT, (C_String_To_Scheme_String (OS_Variant)));
- User_Vector_Set
- (Result, ID_STACK_TYPE, (C_String_To_Scheme_String (STACK_TYPE_STRING)));
+ (LONG_TO_UNSIGNED_FIXNUM (FLONUM_MANTISSA_BITS)));
+ FAST_VECTOR_SET
+ (Result, ID_FLONUM_EXPONENT, (LONG_TO_UNSIGNED_FIXNUM (FLONUM_EXPT_SIZE)));
+ FAST_VECTOR_SET
+ (Result, ID_OS_NAME, (char_pointer_to_string (OS_Name)));
+ FAST_VECTOR_SET
+ (Result, ID_OS_VARIANT, (char_pointer_to_string (OS_Variant)));
+ FAST_VECTOR_SET
+ (Result, ID_STACK_TYPE, (char_pointer_to_string (STACK_TYPE_STRING)));
PRIMITIVE_RETURN (Result);
}
\f
char *Prefix, *Suffix;
fast long Count;
long position;
- extern Pointer allocate_string ();
- Pointer Result;
+ extern SCHEME_OBJECT allocate_string ();
+ SCHEME_OBJECT Result;
PRIMITIVE_HEADER (0);
-
if ((((position = (Parse_Option ("-utabmd", Saved_argc, Saved_argv, true)))
!= NOT_THERE) &&
(position != (Saved_argc - 1))) ||
Prefix = SCHEME_SOURCES_PATH;
Suffix = UCODE_TABLES_FILENAME;
}
-
/* Find the length of the combined string, and allocate. */
-
Count = 0;
for (From = Prefix; ((*From++) != '\0'); )
Count += 1;
for (From = Suffix; ((*From++) != '\0'); )
Count += 1;
-
/* Append both substrings. */
-
Result = (allocate_string (Count));
- To = (string_pointer (Result, 0));
+ To = ((char *) (STRING_LOC (Result, 0)));
for (From = (& (Prefix [0])); ((*From) != '\0'); )
(*To++) = (*From++);
for (From = (& (Suffix [0])); ((*From) != '\0'); )
(*To++) = (*From++);
PRIMITIVE_RETURN (Result);
}
-\f
+
DEFINE_PRIMITIVE ("GET-COMMAND-LINE", Prim_get_command_line, 0, 0, 0)
{
fast int i;
- fast Pointer result;
- extern Pointer allocate_marked_vector ();
+ fast SCHEME_OBJECT result;
+ extern SCHEME_OBJECT allocate_marked_vector ();
PRIMITIVE_HEADER (0);
-
result = (allocate_marked_vector (TC_VECTOR, Saved_argc, true));
for (i = 0; (i < Saved_argc); i += 1)
- User_Vector_Set (result, i, (C_String_To_Scheme_String (Saved_argv [i])));
+ FAST_VECTOR_SET (result, i, (char_pointer_to_string (Saved_argv [i])));
PRIMITIVE_RETURN (result);
}
/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/breakup.c,v 9.21 1987/01/22 14:11:34 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/breakup.c,v 9.22 1989/09/20 23:04:34 cph Rel $ */
\f
#include <stdio.h>
for (c = getchar();
isoctal(c) && count >= 0;
c = getchar(), count -=1)
- putchar(c);
+ putchar(c);
if (count != 2) return c;
putchar(c);
return getchar();
main()
{ register int c;
- register boolean after_new_line = true;
+ register boolean after_new_line = true;
while ((c = getchar()) != EOF)
re_dispatch:
switch(c)
if (c == '\n')
{ fprintf(stderr, "Confused character: \\n\n");
after_new_line = true;
- break;
+ break;
}
if (c == '\'')
{ fprintf(stderr, "Confused character: \\\'\n");
if (c != '\'')
fprintf(stderr, "Confused character: %c = 0x%x\n",
c);
- break;
+ break;
case '"':
after_new_line == false;
putchar(c);
if (c == '\\')
c = get_a_char();
}
- break;
+ break;
case '#':
if (after_new_line)
{ while (((c = getchar()) != EOF) && (c != '\n')) ;
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/char.c,v 9.28 1989/09/20 23:06:31 cph Rel $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/char.c,v 9.27 1989/08/28 18:28:24 cph Exp $ */
-
/* Character primitives. */
#include "scheme.h"
#include "prims.h"
-#include "char.h"
#include <ctype.h>
\f
long
arg_ascii_char (n)
int n;
{
- fast long ascii;
-
CHECK_ARG (n, CHARACTER_P);
- ascii = ARG_REF(n);
- if (OBJECT_DATUM(ascii) >= MAX_ASCII)
- error_bad_range_arg (n);
- return (scheme_char_to_c_char(ascii));
+ {
+ fast SCHEME_OBJECT object = (ARG_REF (n));
+ if (! (CHAR_TO_ASCII_P (object)))
+ error_bad_range_arg (n);
+ return (CHAR_TO_ASCII (object));
+ }
}
long
arg_ascii_integer (n)
int n;
{
- fast Pointer arg;
- fast long ascii;
-
- CHECK_ARG (n, FIXNUM_P);
- arg = (ARG_REF (n));
- if (FIXNUM_NEGATIVE_P (arg))
- error_bad_range_arg (n);
- FIXNUM_VALUE (arg, ascii);
- if (ascii >= MAX_ASCII)
- error_bad_range_arg (n);
- return (ascii);
+ return (arg_index_integer (n, MAX_ASCII));
}
-\f
+
DEFINE_PRIMITIVE ("MAKE-CHAR", Prim_make_char, 2, 2, 0)
{
- long bucky_bits, code;
PRIMITIVE_HEADER (2);
-
- code = (arg_index_integer (1, MAX_CODE));
- bucky_bits = (arg_index_integer (2, MAX_BITS));
- PRIMITIVE_RETURN (make_char (bucky_bits, code));
+ PRIMITIVE_RETURN
+ (MAKE_CHAR ((arg_index_integer (2, MAX_BITS)),
+ (arg_index_integer (1, MAX_CODE))));
}
DEFINE_PRIMITIVE ("CHAR-BITS", Prim_char_bits, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
CHECK_ARG (1, CHARACTER_P);
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (char_bits (ARG_REF (1))));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (CHAR_BITS (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("CHAR-CODE", Prim_char_code, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
CHECK_ARG (1, CHARACTER_P);
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (char_code (ARG_REF (1))));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (CHAR_CODE (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("CHAR->INTEGER", Prim_char_to_integer, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
CHECK_ARG (1, CHARACTER_P);
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM ((ARG_REF (1)) & MASK_EXTNDD_CHAR));
+ PRIMITIVE_RETURN
+ (LONG_TO_UNSIGNED_FIXNUM ((ARG_REF (1)) & MASK_MIT_ASCII));
}
DEFINE_PRIMITIVE ("INTEGER->CHAR", Prim_integer_to_char, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
PRIMITIVE_RETURN
- (Make_Non_Pointer (TC_CHARACTER,
- (arg_index_integer (1, MAX_EXTNDD_CHAR))));
+ (MAKE_OBJECT (TC_CHARACTER, (arg_index_integer (1, MAX_MIT_ASCII))));
}
\f
long
char_downcase (c)
- long c;
+ fast long c;
{
- c = (char_to_long (c));
return ((isupper (c)) ? ((c - 'A') + 'a') : c);
}
long
char_upcase (c)
- long c;
+ fast long c;
{
- c = (char_to_long (c));
return ((islower (c)) ? ((c - 'a') + 'A') : c);
}
DEFINE_PRIMITIVE ("CHAR-DOWNCASE", Prim_char_downcase, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
CHECK_ARG (1, CHARACTER_P);
PRIMITIVE_RETURN
- (make_char ((char_bits (ARG_REF (1))),
- (char_downcase (char_code (ARG_REF (1))))));
+ (MAKE_CHAR ((CHAR_BITS (ARG_REF (1))),
+ (char_downcase (CHAR_CODE (ARG_REF (1))))));
}
DEFINE_PRIMITIVE ("CHAR-UPCASE", Prim_char_upcase, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
CHECK_ARG (1, CHARACTER_P);
PRIMITIVE_RETURN
- (make_char ((char_bits (ARG_REF (1))),
- (char_upcase (char_code (ARG_REF (1))))));
+ (MAKE_CHAR ((CHAR_BITS (ARG_REF (1))),
+ (char_upcase (CHAR_CODE (ARG_REF (1))))));
}
-\f
+
DEFINE_PRIMITIVE ("ASCII->CHAR", Prim_ascii_to_char, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN (c_char_to_scheme_char (arg_ascii_integer (1)));
+ PRIMITIVE_RETURN (ASCII_TO_CHAR (arg_index_integer (1, MAX_ASCII)));
}
DEFINE_PRIMITIVE ("CHAR->ASCII", Prim_char_to_ascii, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (arg_ascii_char (1)));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (arg_ascii_char (1)));
}
DEFINE_PRIMITIVE ("CHAR-ASCII?", Prim_char_ascii_p, 1, 1, 0)
{
- fast Pointer character;
PRIMITIVE_HEADER (1);
-
CHECK_ARG (1, CHARACTER_P);
- character = ARG_REF (1);
- PRIMITIVE_RETURN
- ((OBJECT_DATUM(character) >= MAX_ASCII) ?
- NIL :
- (MAKE_UNSIGNED_FIXNUM (scheme_char_to_c_char(character))));
-}
-\f
-forward Boolean ascii_control_p();
-
-long
-ascii_to_mit_ascii (ascii)
- long ascii;
-{
- long bucky_bits, code;
-
- bucky_bits = (((ascii & 0200) != 0) ? CHAR_BITS_META : 0);
- code = (ascii & 0177);
- if (ascii_control_p (code))
- {
- code |= 0100; /* Convert to non-control code. */
- bucky_bits |= CHAR_BITS_CONTROL;
- }
- return ((bucky_bits << CODE_LENGTH) | code);
-}
-
-long
-mit_ascii_to_ascii (mit_ascii)
- long mit_ascii;
-{
- long bucky_bits, code;
-
- bucky_bits = ((mit_ascii >> CODE_LENGTH) & CHAR_MASK_BITS);
- code = (mit_ascii & CHAR_MASK_CODE);
- if ((bucky_bits & (~ CHAR_BITS_CONTROL_META)) != 0)
- return (NOT_ASCII);
- else
- {
- if ((bucky_bits & CHAR_BITS_CONTROL) != 0)
- {
- code = (char_upcase (code) & (~ 0100));
- if (!ascii_control_p (code))
- return (NOT_ASCII);
- }
- else
- {
- if (ascii_control_p (code))
- return (NOT_ASCII);
- }
- return (((bucky_bits & CHAR_BITS_META) != 0) ? (code | 0200) : code);
- }
-}
-\f
-Boolean
-ascii_control_p (code)
- int code;
-{
- switch (code)
- {
- case 000:
- case 001:
- case 002:
- case 003:
- case 004:
- case 005:
- case 006:
- case 007:
- case 016:
- case 017:
- case 020:
- case 021:
- case 022:
- case 023:
- case 024:
- case 025:
- case 026:
- case 027:
- case 030:
- case 031:
- case 034:
- case 035:
- case 036:
- return (true);
-
- default:
- return (false);
- }
+ {
+ fast SCHEME_OBJECT character = ARG_REF (1);
+ PRIMITIVE_RETURN
+ (((OBJECT_DATUM (character)) >= MAX_ASCII) ?
+ SHARP_F :
+ (LONG_TO_UNSIGNED_FIXNUM (CHAR_TO_ASCII (character))));
+ }
}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpint.h,v 10.3 1989/09/20 23:06:45 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpint.h,v 10.2 1988/08/15 20:43:41 cph Rel $
- *
- * Macros for the interface between compiled code and interpreted code.
- *
- */
+/* Macros for the interface between compiled code and interpreted code. */
\f
/* Stack Gap Operations: */
#define With_Stack_Gap(Gap_Size, Gap_Position, Code) \
{ \
- Pointer *Saved_Destination; \
- fast Pointer *Destination; \
+ SCHEME_OBJECT *Saved_Destination; \
+ fast SCHEME_OBJECT *Destination; \
fast long size_to_move; \
\
size_to_move = (Gap_Position); \
Stack_Pointer = Saved_Destination; \
}
-/* Close_Stack_Gap closes a gap Gap_Size wide Gap_Position cells above the
+/* 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; \
- fast Pointer *Source; \
+ fast SCHEME_OBJECT *Source; \
\
size_to_move = (Gap_Position); \
Source = Simulate_Popping(size_to_move); \
\
frame_size = (nslots); \
if (Stack_Ref(frame_size + CONTINUATION_RETURN_CODE) == \
- (Make_Non_Pointer(TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
+ (MAKE_OBJECT (TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
{ \
/* Merge compiled code segments on the stack. */ \
Close_Stack_Gap (CONTINUATION_SIZE, \
long segment_size; \
\
segment_size = \
- OBJECT_DATUM(Stack_Ref(CONTINUATION_EXPRESSION - \
- CONTINUATION_SIZE)); \
+ (OBJECT_DATUM \
+ (Stack_Ref \
+ (CONTINUATION_EXPRESSION - \
+ CONTINUATION_SIZE))); \
last_return_code = Simulate_Popping(segment_size); \
}); \
/* Undo the subproblem rotation. */ \
#define execute_compiled_setup() \
{ \
if (Stack_Ref(CONTINUATION_RETURN_CODE) == \
- (Make_Non_Pointer(TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
+ (MAKE_OBJECT (TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
{ \
/* Merge compiled code segments on the stack. */ \
long segment_size; \
\
Restore_Cont(); \
- segment_size = OBJECT_DATUM(Fetch_Expression()); \
+ segment_size = OBJECT_DATUM (Fetch_Expression()); \
last_return_code = Simulate_Popping(segment_size); \
/* Undo the subproblem rotation. */ \
Compiler_End_Subproblem(); \
/* Pop return interface:
Returning to compiled code from the interpreter.
*/
-
+
#define compiled_code_restart() \
{ \
long segment_size; \
\
- segment_size = Datum(Fetch_Expression()); \
+ segment_size = OBJECT_DATUM (Fetch_Expression()); \
last_return_code = Simulate_Popping(segment_size); \
/* Undo the subproblem rotation. */ \
Compiler_End_Subproblem(); \
} \
else \
{ /* Make a new interpreter segment which includes this frame. */ \
- With_Stack_Gap(CONTINUATION_SIZE, \
- frame_size, \
- { \
- long segment_size; \
+ With_Stack_Gap \
+ (CONTINUATION_SIZE, \
+ frame_size, \
+ { \
+ long segment_size; \
\
- segment_size = Stack_Distance(last_return_code); \
- Store_Expression(Make_Unsigned_Fixnum(segment_size)); \
- Store_Return(RC_REENTER_COMPILED_CODE); \
- Save_Cont(); \
- }); \
+ segment_size = Stack_Distance(last_return_code); \
+ Store_Expression(LONG_TO_UNSIGNED_FIXNUM(segment_size)); \
+ Store_Return(RC_REENTER_COMPILED_CODE); \
+ Save_Cont(); \
+ }); \
/* Rotate history to a new subproblem. */ \
Compiler_New_Subproblem(); \
} \
#define apply_compiled_backout() \
{ \
compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS + \
- Get_Integer( Stack_Ref( STACK_ENV_HEADER))); \
+ OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));\
}
/* Backing out of eval. */
long segment_size; \
\
segment_size = Stack_Distance(last_return_code); \
- Store_Expression(Make_Unsigned_Fixnum(segment_size)); \
+ Store_Expression(LONG_TO_UNSIGNED_FIXNUM(segment_size)); \
Store_Return(RC_REENTER_COMPILED_CODE); \
Save_Cont(); \
/* Rotate history to a new subproblem. */ \
}
/* Backing out because of special errors or interrupts.
- The microcode has already setup a return code with a NIL.
+ The microcode has already setup a return code with a #F.
No tail recursion in this case.
***
Is the history manipulation correct?
\
Restore_Cont(); \
segment_size = Stack_Distance(last_return_code); \
- Store_Expression(Make_Unsigned_Fixnum(segment_size)); \
+ Store_Expression(LONG_TO_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())); */ \
+ /* Store_Return (OBJECT_DATUM (Fetch_Return ())); */ \
/* Save_Cont(); */ \
Compiler_New_Subproblem(); \
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/comutl.c,v 1.18 1989/01/30 13:04:03 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/comutl.c,v 1.19 1989/09/20 23:07:04 cph Rel $
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#include "scheme.h"
#include "prims.h"
-extern Pointer
+extern SCHEME_OBJECT
*compiled_entry_to_block_address();
extern long
extern void
compiled_entry_type();
\f
-#define COMPILED_CODE_ADDRESS_P(object) \
- ((OBJECT_TYPE (object)) == TC_COMPILED_ENTRY)
-
DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->BLOCK", Prim_comp_code_address_block, 1, 1,
"Given a compiled code address, return its compiled code block.")
{
CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
PRIMITIVE_RETURN
- (Make_Pointer (TC_COMPILED_CODE_BLOCK,
- (compiled_entry_to_block_address (ARG_REF (1)))));
+ (MAKE_POINTER_OBJECT
+ (TC_COMPILED_CODE_BLOCK,
+ (compiled_entry_to_block_address (ARG_REF (1)))));
}
DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->OFFSET", Prim_comp_code_address_offset, 1, 1,
"Given a compiled code address, return its offset into its block.")
{
PRIMITIVE_HEADER (1);
-
CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
PRIMITIVE_RETURN
- (MAKE_SIGNED_FIXNUM (compiled_entry_to_block_offset (ARG_REF (1))));
+ (LONG_TO_FIXNUM (compiled_entry_to_block_offset (ARG_REF (1))));
}
#ifndef USE_STACKLETS
DEFINE_PRIMITIVE ("STACK-TOP-ADDRESS", Prim_stack_top_address, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer ((long) (Stack_Top)));
+ PRIMITIVE_RETURN (long_to_integer ((long) (Stack_Top)));
}
-#define STACK_ADDRESS_P(object) \
- ((OBJECT_TYPE (object)) == TC_STACK_ENVIRONMENT)
-
DEFINE_PRIMITIVE ("STACK-ADDRESS-OFFSET", Prim_stack_address_offset, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STACK_ADDRESS_P);
PRIMITIVE_RETURN
- (C_Integer_To_Scheme_Integer
+ (long_to_integer
((STACK_LOCATIVE_DIFFERENCE
(((long) (Stack_Top)), (OBJECT_DATUM (ARG_REF (1)))))
- / (sizeof (Pointer))));
+ / (sizeof (SCHEME_OBJECT))));
}
#endif /* USE_STACKLETS */
DEFINE_PRIMITIVE ("COMPILED-ENTRY-KIND", Prim_compiled_entry_type, 1, 1, 0)
{
- fast Pointer *temp;
- Pointer result;
- PRIMITIVE_HEADER(1);
-
+ PRIMITIVE_HEADER (1);
CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
-
- Primitive_GC_If_Needed(3);
- temp = Free;
- Free = &temp[3];
- compiled_entry_type(ARG_REF(1), temp);
- temp[0] = MAKE_UNSIGNED_FIXNUM(((long) temp[0]));
- temp[1] = MAKE_SIGNED_FIXNUM(((long) temp[1]));
- temp[2] = MAKE_SIGNED_FIXNUM(((long) temp[2]));
- PRIMITIVE_RETURN (Make_Pointer(TC_HUNK3, temp));
+ {
+ long results [3];
+ compiled_entry_type ((ARG_REF (1)), results);
+ PRIMITIVE_RETURN
+ (hunk3_cons ((LONG_TO_FIXNUM (results [0])),
+ (LONG_TO_FIXNUM (results [1])),
+ (LONG_TO_FIXNUM (results [2]))));
+ }
}
\f
DEFINE_PRIMITIVE ("COERCE-TO-COMPILED-PROCEDURE", Prim_coerce_to_closure, 2, 2, 0)
{
- Pointer temp;
- long value, result;
+ SCHEME_OBJECT temp;
+ long result;
PRIMITIVE_HEADER(2);
-
- CHECK_ARG (2, FIXNUM_P);
-
- FIXNUM_VALUE(ARG_REF(2), value);
- result = coerce_to_compiled(ARG_REF(1), value, &temp);
+ result = (coerce_to_compiled ((ARG_REF (1)), (arg_integer (2)), &temp));
switch(result)
{
case PRIM_DONE:
case PRIM_INTERRUPT:
Primitive_GC(10);
/*NOTREACHED*/
-
+
default:
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ error_bad_range_arg (2);
/*NOTREACHED*/
}
}
DEFINE_PRIMITIVE ("COMPILED-CLOSURE->ENTRY", Prim_compiled_closure_to_entry, 1, 1,
"Given a compiled closure, return the entry point which it invokes.")
{
- Pointer entry_type [3];
- Pointer closure;
+ SCHEME_OBJECT entry_type [3];
+ SCHEME_OBJECT closure;
extern void compiled_entry_type ();
- extern long compiled_entry_manifest_closure_p ();
- extern Pointer compiled_closure_to_entry ();
+ extern long compiled_entry_closure_p ();
+ extern SCHEME_OBJECT compiled_closure_to_entry ();
PRIMITIVE_HEADER (1);
CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
closure = (ARG_REF (1));
compiled_entry_type (closure, (& (entry_type [0])));
- if (! (((entry_type [0]) == 0) &&
- (compiled_entry_manifest_closure_p (closure))))
+ if (! (((entry_type [0]) == 0) && (compiled_entry_closure_p (closure))))
error_bad_range_arg (1);
PRIMITIVE_RETURN (compiled_closure_to_entry (closure));
}
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.47 1989/09/20 23:07:08 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.46 1989/08/28 18:28:38 cph Exp $
- *
- * This file contains the configuration information and the information
- * given on the command line on Unix.
- *
- */
+/* This file contains the configuration information and the information
+ given on the command line on Unix. */
\f
/* Default pathnames. */
/* 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.
-*/
+ option is incompatible with the stepper and compiler. */
+
/* #define USE_STACKLETS */
#endif
#endif
#endif
#endif
-/* These C type definitions are needed by everybody.
+/* 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 */
+/* This is the Scheme object type; it should be called `SCHEME_OBJECT'.
+ The various fields are defined in "object.h". */
+typedef unsigned long SCHEME_OBJECT;
-typedef unsigned long Pointer;
+/* This definition makes the value of `OBJECT_LENGTH' available to
+ the preprocessor. */
+#define OBJECT_LENGTH ULONG_SIZE
\f
/* Operating System / Machine dependencies:
If you do not know the values of the parameters specified below,
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.
+ 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. This can be
These parameters MUST be specified (and are computed by Wsize):
- CHAR_SIZE is the size of a character in bits.
+ CHAR_BIT 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
+ be equivalent to (sizeof(unsigned short) * CHAR_BIT), but is
available to the preprocessor.
ULONG_SIZE is the size of an unsigned long in bits.
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
+ 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.
FLOATING_ALIGNMENT should be defined ONLY 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
+ SCHEME_OBJECTs (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.
VAX_BYTE_ORDER should be defined ONLY if the least significant byte
of a longword in memory lies at the lowest address, not defined
otherwise (ie. Motorola MC68020, with opposite convention, or
- PDP-10 with word addressin).
-*/
+ PDP-10 with word addressing). */
\f
-/*
+/*
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,
+ (CHAR_BIT*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
+ 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
+ of a Scheme object. The datum portion of a Scheme object 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.
+ (i.e. SCHEME_OBJECT) results in a logical (vs. arithmetic) shift.
Setting the flag allows faster type code extraction.
BELL is the character which rings the terminal bell.
#define FASL_MIPS 15
\f
/* These (pdp10 and nu) haven't worked in a while.
- * Should be upgraded or flushed some day.
+ * Should be upgraded or flushed some day.
*/
#ifdef pdp10
#define MACHINE_TYPE "pdp10"
#define Heap_In_Low_Memory
-#define CHAR_SIZE 36 / * Ugh! Supposedly fixed in newer Cs * /
+#define CHAR_BIT 36 / * Ugh! Supposedly fixed in newer Cs * /
#define BELL '\007'
#define FASL_INTERNAL_FORMAT FASL_PDP10
#endif
#ifdef nu
#define MACHINE_TYPE "nu"
#define Heap_In_Low_Memory
-#define CHAR_SIZE 8
+#define CHAR_BIT 8
#define USHORT_SIZE 16
#define ULONG_SIZE 32
#define BELL '\007'
#define HAS_FREXP
#ifdef quick
/* Bignum code fails for certain variables in registers because of a
- compiler bug!
+ compiler bug!
*/
#undef quick
#define quick
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
#define VAX_BYTE_ORDER
-#define CHAR_SIZE 8
+#define CHAR_BIT 8
#define USHORT_SIZE 16
#define ULONG_SIZE 32
#define BELL '\007'
#else /* not VMS ie. unix */
/* 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); \
-}
+#define HAVE_DOUBLE_TO_LONG_BUG
#endif /* VMS */
#endif /* vax */
#define MACHINE_TYPE "hp9000s200"
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
+#define CHAR_BIT 8
#define USHORT_SIZE 16
#define ULONG_SIZE 32
#define BELL '\007'
#ifdef hp9000s500
#define MACHINE_TYPE "hp9000s500"
/* An unfortunate fact of life on this machine:
- the C heap is in high memory thus Heap_In_Low_Memory is not
+ 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 CHAR_BIT 8
#define USHORT_SIZE 16
#define ULONG_SIZE 32
#define BELL '\007'
#ifdef sun
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
+#define CHAR_BIT 8
#define USHORT_SIZE 16
#define ULONG_SIZE 32
#define BELL '\007'
#define HAS_FLOOR
#define HAS_FREXP
-/* Sun C compiler bug. */
-#define double_into_fixnum(what, target) \
-{ \
- long for_suns_sake = ((long) what); \
- \
- target = Make_Non_Pointer(TC_FIXNUM, for_suns_sake); \
-}
-#endif
+#define HAVE_DOUBLE_TO_LONG_BUG
+
+#endif /* sun */
#ifdef butterfly
#define MACHINE_TYPE "butterfly"
#define Heap_In_Low_Memory
-#define CHAR_SIZE 8
+#define CHAR_BIT 8
#define USHORT_SIZE 16
#define ULONG_SIZE 32
#define BELL '\007'
#define MACHINE_TYPE "cyber180"
/* Word size is 64 bits. */
#define Heap_In_Low_Memory
-#define CHAR_SIZE 8
+#define CHAR_BIT 8
#define USHORT_SIZE ???
#define ULONG_SIZE ???
#define BELL '\007'
#define MACHINE_TYPE "celerity"
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
+#define CHAR_BIT 8
#define USHORT_SIZE 16
#define ULONG_SIZE 32
#define BELL '\007'
#ifdef hp9000s800
#define MACHINE_TYPE "hp9000s800"
#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
+#define CHAR_BIT 8
#define USHORT_SIZE 16
#define ULONG_SIZE 32
#define BELL '\007'
/* Heap resides in "Quad 1", and hence memory addresses have a 1
in the second MSBit. This is kludged by the definitions below, and is
- still considered Heap_In_Low_Memory.
-*/
-
+ still considered Heap_In_Low_Memory. */
#define Heap_In_Low_Memory
/* It must be at least one more than the minimum necessary,
- and it may not work if it is not even.
- */
+ and it may not work if it is not even. */
+#define TYPE_CODE_LENGTH 8
-#define TYPE_CODE_LENGTH 8
+/* Datum includes the quad tag, type doesn't. */
+#define TYPE_CODE_MASK 0x3F000000
+#define DATUM_MASK 0x40FFFFFF
+#define OBJECT_MASKS_DEFINED
/* Clear the quad tag if there */
-
-#define TC_BITS_TO_TC(BITS) ((BITS) & 0x3F)
-
-/* This assumes that the max type code is 6, so that it does not
- overflow into the quad tag.
- */
-
-#define TC_TO_TC_BITS(TC) (TC)
-
-#define OBJECT_TYPE(O) (TC_BITS_TO_TC((O) >> ADDRESS_LENGTH))
-
-/* Keep quad bit. */
-
-#define OBJECT_DATUM(O) ((O) & 0x40FFFFFF)
-
-#define MAKE_OBJECT(TC, D) \
- ((((unsigned) (TC_TO_TC_BITS(TC))) << ADDRESS_LENGTH) | (OBJECT_DATUM (D)))
+#define OBJECT_TYPE(object) (((object) >> DATUM_LENGTH) & 0x3F)
#endif /* AVOID_SPECTRUM_TC_KLUDGE */
#endif /* spectrum */
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
#define VAX_BYTE_ORDER
-#define CHAR_SIZE 8
+#define CHAR_BIT 8
#define USHORT_SIZE 16
#define ULONG_SIZE 32
#define DBFLT_SIZE 64
#define MACHINE_TYPE "pyramid"
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
+#define CHAR_BIT 8
#define USHORT_SIZE 16
#define ULONG_SIZE 32
#define BELL '\007'
#define MACHINE_TYPE "alliant"
#define Heap_In_Low_Memory
#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
+#define CHAR_BIT 8
#define USHORT_SIZE 16
#define ULONG_SIZE 32
#define BELL '\007'
#define MACHINE_TYPE "MIPS (DECStation 3100)"
#define UNSIGNED_SHIFT
#define VAX_BYTE_ORDER
-#define CHAR_SIZE 8
+#define CHAR_BIT 8
#define USHORT_SIZE 16
#define ULONG_SIZE 32
/* Flonum (double) size is 64 bits. */
#define BELL '\007'
#endif
\f
-/* Make sure that some definition applies.
+/* 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
+#ifndef CHAR_BIT
#include "Error: config.h: Unknown configuration."
#endif
#endif
#ifndef CONSTANT_SIZE
-#define CONSTANT_SIZE 350 /* Default Kcells for constant */
+#define CONSTANT_SIZE 360 /* Default Kcells for constant */
#endif
#ifndef HEAP_SIZE
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.34 1989/08/28 18:28:42 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.35 1989/09/20 23:07:12 cph Exp $
*
* Named constants used throughout the interpreter
*
*/
\f
-#if (CHAR_SIZE != 8)
-#define MAX_CHAR ((1<<CHAR_SIZE)-1)
+#if (CHAR_BIT != 8)
+#define MAX_CHAR ((1<<CHAR_BIT)-1)
#else
#define MAX_CHAR 0xFF
#endif
#endif /* b32 */
#ifndef SHARP_F /* Safe version */
-#define SHARP_F Make_Non_Pointer(TC_NULL, 0)
-#define SHARP_T Make_Non_Pointer(TC_TRUE, 0)
-#define UNSPECIFIC Make_Non_Pointer(TC_TRUE, 1)
-#define FIXNUM_ZERO Make_Non_Pointer(TC_FIXNUM, 0)
-#define BROKEN_HEART_ZERO Make_Non_Pointer(TC_BROKEN_HEART, 0)
+#define SHARP_F MAKE_OBJECT (TC_NULL, 0)
+#define SHARP_T MAKE_OBJECT (TC_TRUE, 0)
+#define UNSPECIFIC MAKE_OBJECT (TC_TRUE, 1)
+#define FIXNUM_ZERO MAKE_OBJECT (TC_FIXNUM, 0)
+#define BROKEN_HEART_ZERO MAKE_OBJECT (TC_BROKEN_HEART, 0)
#endif /* SHARP_F */
#define EMPTY_LIST SHARP_F
-#define NIL SHARP_F
-#define TRUTH SHARP_T
#define NOT_THERE -1 /* Command line parser */
\f
/* Assorted sizes used in various places */
#define ILLEGAL_PRIMITIVE -1
/* Last immediate reference trap. */
-
+
#define TRAP_MAX_IMMEDIATE 9
/* For headers in pure / constant area */
#if Are_The_Constants_Incompatible
#include "Error: const.h and types.h disagree"
-#endif
+#endif
/* These are the only entries in Registers[] needed by the microcode.
All other entries are used only by the compiled code interface. */
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/daemon.c,v 9.27 1989/09/20 23:07:22 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/daemon.c,v 9.26 1988/08/15 20:44:42 cph Rel $
-
- This file contains code for the Garbage Collection daemons.
+/* This file contains code for the Garbage Collection daemons.
There are currently two daemons, one for closing files which
have disappeared due to GC, the other for supporting object
hash tables where entries disappear when the corresponding
Both of these daemons should be written in Scheme, but since the
interpreter conses while executing Scheme programs, they are
unsafe. The Scheme versions actually exist, but are commented out
- of the appropriate runtime system sources.
-*/
+ of the appropriate runtime system sources. */
#include "scheme.h"
#include "prims.h"
\f
-/* (CLOSE-LOST-OPEN-FILES file-list)
+/* (CLOSE-LOST-OPEN-FILES file-list)
file-list is an assq-like list where the associations are weak
pairs rather than normal pairs. This primitive destructively
removes those weak pairs whose cars are #F, and closes the
corresponding file descriptor contained in the cdrs. See io.scm in
- the runtime system for a longer description.
-*/
+ the runtime system for a longer description. */
DEFINE_PRIMITIVE ("CLOSE-LOST-OPEN-FILES", Prim_close_lost_open_files, 1, 1, 0)
{
extern Boolean OS_file_close();
- fast Pointer *Smash, Cell, Weak_Cell, Value;
+ fast SCHEME_OBJECT *Smash, Cell, Weak_Cell, Value;
+ fast SCHEME_OBJECT file_list;
long channel_number;
- Primitive_1_Arg();
-
+ PRIMITIVE_HEADER (1);
+ file_list = (ARG_REF (1));
Value = SHARP_T;
-
- for (Smash = Nth_Vector_Loc(Arg1, CONS_CDR), Cell = *Smash;
- Cell != NIL;
+ for (Smash = PAIR_CDR_LOC (file_list), Cell = *Smash;
+ Cell != EMPTY_LIST;
Cell = *Smash)
{
- Weak_Cell = Fast_Vector_Ref(Cell, CONS_CAR);
- if (Fast_Vector_Ref(Weak_Cell, CONS_CAR) == NIL)
- {
- channel_number = Get_Integer(Fast_Vector_Ref(Weak_Cell, CONS_CDR));
- if (!OS_file_close (Channels[channel_number]))
- Value = NIL;
- Channels[channel_number] = NULL;
- *Smash = Fast_Vector_Ref(Cell, CONS_CDR);
- }
+ Weak_Cell = (FAST_PAIR_CAR (Cell));
+ if ((FAST_PAIR_CAR (Weak_Cell)) == SHARP_F)
+ {
+ channel_number = (UNSIGNED_FIXNUM_TO_LONG (FAST_PAIR_CDR (Weak_Cell)));
+ if (!OS_file_close (Channels[channel_number]))
+ Value = SHARP_F;
+ (Channels [channel_number]) = NULL;
+ (*Smash) = (FAST_PAIR_CDR (Cell));
+ }
else
- Smash = Nth_Vector_Loc(Cell, CONS_CDR);
+ Smash = PAIR_CDR_LOC (Cell);
}
- return Value;
+ PRIMITIVE_RETURN (Value);
}
\f
/* Utilities for the rehash daemon below */
It is also the case that the storage needed by this daemon is
available, since it was all reclaimed by the immediately preceeding
garbage collection, and at most that much is allocated now.
- Therefore, there is no gc check here.
-*/
+ Therefore, there is no gc check here. */
void
-rehash_pair(pair, hash_table, table_size)
-Pointer pair, hash_table;
-long table_size;
+rehash_pair (pair, hash_table, table_size)
+ SCHEME_OBJECT pair, hash_table;
+ long table_size;
{ long object_datum, hash_address;
- Pointer *new_pair;
+ SCHEME_OBJECT *new_pair;
- object_datum = Datum(Fast_Vector_Ref(pair, CONS_CAR));
+ object_datum = OBJECT_DATUM (FAST_PAIR_CAR (pair));
hash_address = 2+(object_datum % table_size);
new_pair = Free;
- *Free++ = Make_New_Pointer(TC_LIST, pair);
- *Free++ = Fast_Vector_Ref(hash_table, hash_address);
- Fast_Vector_Set(hash_table,
- hash_address,
- Make_Pointer(TC_LIST, new_pair));
+ *Free++ = (OBJECT_NEW_TYPE (TC_LIST, pair));
+ *Free++ = FAST_MEMORY_REF (hash_table, hash_address);
+ FAST_MEMORY_SET (hash_table,
+ hash_address,
+ MAKE_POINTER_OBJECT (TC_LIST, new_pair));
return;
}
void
-rehash_bucket(bucket, hash_table, table_size)
-Pointer *bucket, hash_table;
-long table_size;
-{ fast Pointer weak_pair;
- while (*bucket != NIL)
- { weak_pair = Fast_Vector_Ref(*bucket, CONS_CAR);
- if (Fast_Vector_Ref(weak_pair, CONS_CAR) != NIL)
+rehash_bucket (bucket, hash_table, table_size)
+ SCHEME_OBJECT *bucket, hash_table;
+ long table_size;
+{ fast SCHEME_OBJECT weak_pair;
+ while (*bucket != EMPTY_LIST)
+ { weak_pair = FAST_PAIR_CAR (*bucket);
+ if (FAST_PAIR_CAR (weak_pair) != SHARP_F)
{ rehash_pair(weak_pair, hash_table, table_size);
}
- bucket = Nth_Vector_Loc(*bucket, CONS_CDR);
+ bucket = PAIR_CDR_LOC (*bucket);
}
return;
}
void
splice_and_rehash_bucket(bucket, hash_table, table_size)
-Pointer *bucket, hash_table;
-long table_size;
-{ fast Pointer weak_pair;
- while (*bucket != NIL)
- { weak_pair = Fast_Vector_Ref(*bucket, CONS_CAR);
- if (Fast_Vector_Ref(weak_pair, CONS_CAR) != NIL)
+ SCHEME_OBJECT *bucket, hash_table;
+ long table_size;
+{ fast SCHEME_OBJECT weak_pair;
+ while (*bucket != EMPTY_LIST)
+ { weak_pair = FAST_PAIR_CAR (*bucket);
+ if (FAST_PAIR_CAR (weak_pair) != SHARP_F)
{ rehash_pair(weak_pair, hash_table, table_size);
- bucket = Nth_Vector_Loc(*bucket, CONS_CDR);
+ bucket = PAIR_CDR_LOC (*bucket);
}
else
- { *bucket = Fast_Vector_Ref(*bucket, CONS_CDR);
+ { *bucket = FAST_PAIR_CDR (*bucket);
}
}
return;
/* (REHASH unhash-table hash-table)
Cleans up and recomputes hash-table from the valid information in
unhash-table after a garbage collection.
- See hash.scm in the runtime system for a description.
-*/
+ See hash.scm in the runtime system for a description. */
DEFINE_PRIMITIVE ("REHASH", Prim_rehash, 2, 2, 0)
{
long table_size, counter;
- Pointer *bucket;
- Primitive_2_Args();
-
- table_size = Vector_Length(Arg1);
+ SCHEME_OBJECT *bucket;
+ PRIMITIVE_HEADER (2);
+ table_size = VECTOR_LENGTH (ARG_REF (1));
/* First cleanup the hash table */
- for (counter = table_size, bucket = Nth_Vector_Loc(Arg2, 2);
- --counter >= 0;)
- *bucket++ = NIL;
+ counter = table_size;
+ bucket = (MEMORY_LOC ((ARG_REF (2)), 2));
+ while ((counter--) > 0)
+ (*bucket++) = EMPTY_LIST;
/* Now rehash all the entries from the unhash table and maybe splice
the buckets. */
-
- for (counter = table_size, bucket = Nth_Vector_Loc(Arg1, 1);
- --counter >= 0;
- bucket += 1)
- { if (Fast_Vector_Ref(*bucket, CONS_CAR) == SHARP_T)
- splice_and_rehash_bucket(Nth_Vector_Loc(*bucket, CONS_CDR), Arg2, table_size);
- else
- rehash_bucket(Nth_Vector_Loc(*bucket, CONS_CDR), Arg2, table_size);
- }
-
- return SHARP_T;
+ counter = table_size;
+ bucket = (MEMORY_LOC ((ARG_REF (1)), 1));
+ while ((counter--) > 0)
+ {
+ if ((FAST_PAIR_CAR (*bucket)) == SHARP_T)
+ splice_and_rehash_bucket
+ ((PAIR_CDR_LOC (*bucket)), (ARG_REF (2)), table_size);
+ else
+ rehash_bucket ((PAIR_CDR_LOC (*bucket)), (ARG_REF (2)), table_size);
+ bucket += 1;
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/debug.c,v 9.34 1989/09/20 23:07:26 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/debug.c,v 9.33 1989/05/24 05:33:24 jinx Rel $
- *
- * Utilities to help with debugging
- */
+/* Utilities to help with debugging */
#include "scheme.h"
#include "prims.h"
\f
/* Compiled Code Debugging */
-static Pointer
+static SCHEME_OBJECT
compiled_block_debug_filename (block)
- Pointer block;
+ SCHEME_OBJECT block;
{
- extern Pointer compiled_block_debugging_info ();
- Pointer info;
+ extern SCHEME_OBJECT compiled_block_debugging_info ();
+ SCHEME_OBJECT info;
info = (compiled_block_debugging_info (block));
return
(((STRING_P (info)) ||
((PAIR_P (info)) &&
- (STRING_P (Vector_Ref (info, CONS_CAR))) &&
- (FIXNUM_P (Vector_Ref (info, CONS_CDR)))))
+ (STRING_P (PAIR_CAR (info))) &&
+ (FIXNUM_P (PAIR_CDR (info)))))
? info
: SHARP_F);
}
-extern Pointer *compiled_entry_to_block_address();
+extern SCHEME_OBJECT *compiled_entry_to_block_address();
#define COMPILED_ENTRY_TO_BLOCK(entry) \
-(Make_Pointer (TC_COMPILED_CODE_BLOCK, \
- (compiled_entry_to_block_address (entry))))
+(MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, \
+ (compiled_entry_to_block_address (entry))))
-static Pointer
+static SCHEME_OBJECT
compiled_entry_debug_filename (entry)
- Pointer entry;
+ SCHEME_OBJECT entry;
{
- Pointer results [3];
+ SCHEME_OBJECT results [3];
extern void compiled_entry_type ();
- extern long compiled_entry_manifest_closure_p ();
+ extern long compiled_entry_closure_p ();
extern long compiled_entry_to_block_offset ();
- extern Pointer compiled_closure_to_entry ();
+ extern SCHEME_OBJECT compiled_closure_to_entry ();
compiled_entry_type (entry, (& (results [0])));
- if (((results [0]) == 0) && (compiled_entry_manifest_closure_p (entry)))
+ if (((results [0]) == 0) && (compiled_entry_closure_p (entry)))
entry = (compiled_closure_to_entry (entry));
return (compiled_block_debug_filename (COMPILED_ENTRY_TO_BLOCK (entry)));
}
char *
compiled_entry_filename (entry)
- Pointer entry;
+ SCHEME_OBJECT entry;
{
- Pointer result;
+ SCHEME_OBJECT result;
result = (compiled_entry_debug_filename (entry));
if (STRING_P (result))
- return (Scheme_String_To_C_String (result));
+ return ((char *) (STRING_LOC ((result), 0)));
else if (PAIR_P (result))
- return (Scheme_String_To_C_String (Vector_Ref (result, CONS_CAR)));
+ return ((char *) (STRING_LOC ((PAIR_CAR (result)), 0)));
else
return ("**** filename not known ****");
}
void
Show_Pure ()
{
- Pointer *Obj_Address;
+ SCHEME_OBJECT *Obj_Address;
long Pure_Size, Total_Size;
Obj_Address = Constant_Space;
printf ("Done.\n");
return;
}
- Pure_Size = Get_Integer(*Obj_Address);
- Total_Size = Get_Integer(Obj_Address[1]);
+ Pure_Size = OBJECT_DATUM (*Obj_Address);
+ Total_Size = OBJECT_DATUM (Obj_Address[1]);
printf ("0x%x: pure=0x%x, total=0x%x\n",
Obj_Address, Pure_Size, Total_Size);
- if (OBJECT_TYPE(*Obj_Address) != TC_MANIFEST_SPECIAL_NM_VECTOR)
+ if (OBJECT_TYPE (*Obj_Address) != TC_MANIFEST_SPECIAL_NM_VECTOR)
{
printf ("Missing initial SNMV.\n");
return;
}
- if (OBJECT_TYPE(Obj_Address[1]) != PURE_PART)
+ if (OBJECT_TYPE (Obj_Address[1]) != PURE_PART)
{
printf ("Missing subsequent pure header.\n");
}
- if (OBJECT_TYPE(Obj_Address[Pure_Size-1]) !=
+ if (OBJECT_TYPE (Obj_Address[Pure_Size-1]) !=
TC_MANIFEST_SPECIAL_NM_VECTOR)
{
printf ("Missing internal SNMV.\n");
return;
}
- if (OBJECT_TYPE(Obj_Address[Pure_Size]) != CONSTANT_PART)
+ if (OBJECT_TYPE (Obj_Address[Pure_Size]) != CONSTANT_PART)
{
printf ("Missing constant header.\n");
return;
}
- if (Get_Integer(Obj_Address[Pure_Size]) != Pure_Size)
+ if (OBJECT_DATUM (Obj_Address[Pure_Size]) != Pure_Size)
{
printf ("Pure size mismatch 0x%x.\n",
- Get_Integer(Obj_Address[Pure_Size]));
+ OBJECT_DATUM (Obj_Address[Pure_Size]));
}
- if (OBJECT_TYPE(Obj_Address[Total_Size-1]) !=
+ if (OBJECT_TYPE (Obj_Address[Total_Size-1]) !=
TC_MANIFEST_SPECIAL_NM_VECTOR)
{
printf ("Missing ending SNMV.\n");
return;
}
- if (OBJECT_TYPE(Obj_Address[Total_Size]) != END_OF_BLOCK)
+ if (OBJECT_TYPE (Obj_Address[Total_Size]) != END_OF_BLOCK)
{
printf ("Missing ending header.\n");
return;
}
- if (Get_Integer(Obj_Address[Total_Size]) != Total_Size)
+ if (OBJECT_DATUM (Obj_Address[Total_Size]) != Total_Size)
{
printf ("Total size mismatch 0x%x.\n",
- Get_Integer(Obj_Address[Total_Size]));
+ OBJECT_DATUM (Obj_Address[Total_Size]));
}
Obj_Address += Total_Size+1;
#ifdef FLOATING_ALIGNMENT
- while (*Obj_Address == Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0))
+ while (*Obj_Address == MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0))
{
Obj_Address += 1;
}
\f
void
Show_Env (The_Env)
- Pointer The_Env;
+ SCHEME_OBJECT The_Env;
{
- Pointer *name_ptr, procedure, *value_ptr, extension;
+ SCHEME_OBJECT *name_ptr, procedure, *value_ptr, extension;
long count, i;
- procedure = Vector_Ref (The_Env, ENVIRONMENT_FUNCTION);
- value_ptr = Nth_Vector_Loc(The_Env, ENVIRONMENT_FIRST_ARG);
+ procedure = MEMORY_REF (The_Env, ENVIRONMENT_FUNCTION);
+ value_ptr = MEMORY_LOC (The_Env, ENVIRONMENT_FIRST_ARG);
- if (OBJECT_TYPE(procedure) == AUX_LIST_TYPE)
+ if (OBJECT_TYPE (procedure) == AUX_LIST_TYPE)
{
extension = procedure;
- procedure = Fast_Vector_Ref (extension, ENV_EXTENSION_PROCEDURE);
+ procedure = FAST_MEMORY_REF (extension, ENV_EXTENSION_PROCEDURE);
}
else
- extension = NIL;
+ extension = SHARP_F;
- if ((OBJECT_TYPE(procedure) != TC_PROCEDURE) &&
- (OBJECT_TYPE(procedure) != TC_EXTENDED_PROCEDURE))
+ if ((OBJECT_TYPE (procedure) != TC_PROCEDURE) &&
+ (OBJECT_TYPE (procedure) != TC_EXTENDED_PROCEDURE))
{
printf ("Not created by a procedure");
return;
}
- name_ptr = Nth_Vector_Loc(procedure, PROCEDURE_LAMBDA_EXPR);
- name_ptr = Nth_Vector_Loc(*name_ptr, LAMBDA_FORMALS);
- count = Vector_Length(*name_ptr) - 1;
+ name_ptr = MEMORY_LOC (procedure, PROCEDURE_LAMBDA_EXPR);
+ name_ptr = MEMORY_LOC (*name_ptr, LAMBDA_FORMALS);
+ count = VECTOR_LENGTH (*name_ptr) - 1;
- name_ptr = Nth_Vector_Loc(*name_ptr, 2);
+ name_ptr = MEMORY_LOC (*name_ptr, 2);
for (i = 0; i < count; i++)
{
Print_Expression(*name_ptr++, "Name ");
Print_Expression(*value_ptr++, " Value ");
printf ("\n");
}
- if (extension != NIL)
+ if (extension != SHARP_F)
{
printf ("Auxilliary Variables\n");
- count = Get_Integer(Vector_Ref (extension, AUX_LIST_COUNT));
- for (i = 0, name_ptr = Nth_Vector_Loc(extension, AUX_LIST_FIRST);
+ count = OBJECT_DATUM (MEMORY_REF (extension, AUX_LIST_COUNT));
+ for (i = 0, name_ptr = MEMORY_LOC (extension, AUX_LIST_FIRST);
i < count;
i++, name_ptr++)
{
- Print_Expression(Vector_Ref (*name_ptr, CONS_CAR),
- "Name ");
- Print_Expression(Vector_Ref (*name_ptr, CONS_CAR),
- " Value ");
+ Print_Expression (PAIR_CAR (*name_ptr), "Name ");
+ Print_Expression (PAIR_CDR (*name_ptr), " Value ");
printf ("\n");
}
}
}
\f
-#define NULL_P(object) ((OBJECT_TYPE (object)) == TC_NULL)
-#define PAIR_CAR(pair) (Vector_Ref ((pair), CONS_CAR))
-#define PAIR_CDR(pair) (Vector_Ref ((pair), CONS_CDR))
-
static void
print_list (pair)
- Pointer pair;
+ SCHEME_OBJECT pair;
{
int count;
pair = (PAIR_CDR (pair));
count += 1;
}
- if (! (NULL_P (pair)))
+ if (pair != EMPTY_LIST)
{
if (count == MAX_LIST_PRINT)
printf (" ...");
static void
print_return_name (Ptr)
- Pointer Ptr;
+ SCHEME_OBJECT Ptr;
{
long index;
char * name;
{
printf ("%s: ", String);
print_return_name (Fetch_Return ());
- CRLF ();
+ printf ("\n");
}
\f
static void
print_string (string)
- Pointer string;
+ SCHEME_OBJECT string;
{
long length;
long i;
char this;
printf ("\"");
- length = ((long) (Vector_Ref (string, STRING_LENGTH)));
- next = ((char *) (Nth_Vector_Loc (string, STRING_CHARS)));
+ length = (STRING_LENGTH (string));
+ next = ((char *) (STRING_LOC (string, 0)));
for (i = 0; (i < length); i += 1)
{
this = (*next++);
static void
print_symbol (symbol)
- Pointer symbol;
+ SCHEME_OBJECT symbol;
{
- Pointer string;
+ SCHEME_OBJECT string;
long length;
long i;
char * next;
- string = (Vector_Ref (symbol, SYMBOL_NAME));
- length = ((long) (Vector_Ref (string, STRING_LENGTH)));
- next = ((char *) (Nth_Vector_Loc (string, STRING_CHARS)));
+ string = (MEMORY_REF (symbol, SYMBOL_NAME));
+ length = (STRING_LENGTH (string));
+ next = ((char *) (STRING_LOC (string, 0)));
for (i = 0; (i < length); i += 1)
putchar (*next++);
return;
\f
static void
print_filename (filename)
- Pointer filename;
+ SCHEME_OBJECT filename;
{
long length;
char * scan;
char * end;
char * slash;
- length = ((long) (Vector_Ref (filename, STRING_LENGTH)));
- scan = ((char *) (Nth_Vector_Loc (filename, STRING_CHARS)));
+ length = (STRING_LENGTH (filename));
+ scan = ((char *) (STRING_LOC (filename, 0)));
end = (scan + length);
slash = scan;
while (scan < end)
void
print_object (object)
- Pointer object;
+ SCHEME_OBJECT object;
{
do_printing (object, true);
printf ("\n");
void
print_objects (objects, n)
- Pointer * objects;
+ SCHEME_OBJECT * objects;
int n;
{
- Pointer * scan;
- Pointer * end;
-
+ SCHEME_OBJECT * scan;
+ SCHEME_OBJECT * end;
+
scan = objects;
end = (objects + n);
while (scan < end)
void
print_vector (vector)
- Pointer vector;
+ SCHEME_OBJECT vector;
{
- print_objects ((Nth_Vector_Loc (vector, 1)),
- (UNSIGNED_FIXNUM_VALUE (Fast_Vector_Ref ((vector), 0))));
+ print_objects
+ ((MEMORY_LOC (vector, 1)), (OBJECT_DATUM (VECTOR_LENGTH (vector))));
return;
}
\f
void
Print_Expression (expression, string)
- Pointer expression;
+ SCHEME_OBJECT expression;
char * string;
{
if ((string [0]) != 0)
static void
do_printing (Expr, Detailed)
- Pointer Expr;
+ SCHEME_OBJECT Expr;
Boolean Detailed;
{
long Temp_Address;
case TC_ACCESS:
{
printf ("[ACCESS (");
- Expr = (Vector_Ref (Expr, ACCESS_NAME));
+ Expr = (MEMORY_REF (Expr, ACCESS_NAME));
SPrint:
print_symbol (Expr);
handled_p = true;
case TC_ASSIGNMENT:
printf ("[SET! (");
- Expr = (Vector_Ref ((Vector_Ref (Expr, ASSIGN_NAME)), VARIABLE_SYMBOL));
+ Expr = (MEMORY_REF ((MEMORY_REF (Expr, ASSIGN_NAME)), VARIABLE_SYMBOL));
goto SPrint;
case TC_CHARACTER_STRING:
case TC_DEFINITION:
printf ("[DEFINE (");
- Expr = (Vector_Ref (Expr, DEFINE_NAME));
+ Expr = (MEMORY_REF (Expr, DEFINE_NAME));
goto SPrint;
case TC_FIXNUM:
- {
- long a;
-
- Sign_Extend (Expr, a);
- printf ("%d", a);
- return;
- }
+ printf ("%d", (FIXNUM_TO_LONG (Expr)));
+ return;
case TC_BIG_FLONUM:
- printf ("%f", (Get_Float (Expr)));
+ printf ("%f", (FLONUM_TO_DOUBLE (Expr)));
return;
case TC_WEAK_CONS:
return;
case TC_VARIABLE:
- Expr = (Vector_Ref (Expr, VARIABLE_SYMBOL));
+ Expr = (MEMORY_REF (Expr, VARIABLE_SYMBOL));
if (Detailed)
{
printf ("[VARIABLE (");
case TC_COMBINATION:
printf ("[COMBINATION (%d args) 0x%x]",
- ((Vector_Length (Expr)) - 1),
+ ((VECTOR_LENGTH (Expr)) - 1),
Temp_Address);
if (Detailed)
{
printf (" (");
- do_printing ((Vector_Ref (Expr, COMB_FN_SLOT)), false);
+ do_printing ((MEMORY_REF (Expr, COMB_FN_SLOT)), false);
printf (" ...)");
}
return;
if (Detailed)
{
printf (" (");
- do_printing ((Vector_Ref (Expr, COMB_1_FN)), false);
+ do_printing ((MEMORY_REF (Expr, COMB_1_FN)), false);
printf (", ");
- do_printing ((Vector_Ref (Expr, COMB_1_ARG_1)), false);
+ do_printing ((MEMORY_REF (Expr, COMB_1_ARG_1)), false);
printf (")");
}
return;
if (Detailed)
{
printf (" (");
- do_printing ((Vector_Ref (Expr, COMB_2_FN)), false);
+ do_printing ((MEMORY_REF (Expr, COMB_2_FN)), false);
printf (", ");
- do_printing ((Vector_Ref (Expr, COMB_2_ARG_1)), false);
+ do_printing ((MEMORY_REF (Expr, COMB_2_ARG_1)), false);
printf (", ");
- do_printing ((Vector_Ref (Expr, COMB_2_ARG_2)), false);
+ do_printing ((MEMORY_REF (Expr, COMB_2_ARG_2)), false);
printf (")");
}
return;
case TC_ENVIRONMENT:
{
- Pointer procedure;
+ SCHEME_OBJECT procedure;
printf ("[ENVIRONMENT 0x%x]", Temp_Address);
printf (" (from ");
- procedure = (Vector_Ref (Expr, ENVIRONMENT_FUNCTION));
+ procedure = (MEMORY_REF (Expr, ENVIRONMENT_FUNCTION));
if ((OBJECT_TYPE (procedure)) == TC_QUAD)
- procedure = (Vector_Ref (procedure, ENV_EXTENSION_PROCEDURE));
+ procedure = (MEMORY_REF (procedure, ENV_EXTENSION_PROCEDURE));
do_printing (procedure, false);
printf (")");
return;
case TC_EXTENDED_LAMBDA:
if (Detailed)
printf ("[EXTENDED_LAMBDA (");
- do_printing ((Vector_Ref ((Vector_Ref (Expr, ELAMBDA_NAMES)), 1)),
+ do_printing ((MEMORY_REF ((MEMORY_REF (Expr, ELAMBDA_NAMES)), 1)),
false);
if (Detailed)
printf (") 0x%x", Temp_Address);
case TC_EXTENDED_PROCEDURE:
if (Detailed)
printf ("[EXTENDED_PROCEDURE (");
- do_printing ((Vector_Ref (Expr, PROCEDURE_LAMBDA_EXPR)), false);
+ do_printing ((MEMORY_REF (Expr, PROCEDURE_LAMBDA_EXPR)), false);
if (Detailed)
printf (") 0x%x]", Temp_Address);
break;
case TC_LAMBDA:
if (Detailed)
printf ("[LAMBDA (");
- do_printing ((Vector_Ref ((Vector_Ref (Expr, LAMBDA_FORMALS)), 1)),
+ do_printing ((MEMORY_REF ((MEMORY_REF (Expr, LAMBDA_FORMALS)), 1)),
false);
if (Detailed)
printf (") 0x%x]", Temp_Address);
case TC_PROCEDURE:
if (Detailed)
printf ("[PROCEDURE (");
- do_printing ((Vector_Ref (Expr, PROCEDURE_LAMBDA_EXPR)), false);
+ do_printing ((MEMORY_REF (Expr, PROCEDURE_LAMBDA_EXPR)), false);
if (Detailed)
printf (") 0x%x]", Temp_Address);
return;
if ((OBJECT_DATUM (Expr)) <= TRAP_MAX_IMMEDIATE)
break;
printf ("[REFERENCE-TRAP");
- Print_Expression ((Vector_Ref (Expr, TRAP_TAG)), " tag");
- Print_Expression ((Vector_Ref (Expr, TRAP_EXTRA)), " extra");
+ Print_Expression ((MEMORY_REF (Expr, TRAP_TAG)), " tag");
+ Print_Expression ((MEMORY_REF (Expr, TRAP_EXTRA)), " extra");
printf ("]");
return;
}
case TC_COMPILED_ENTRY:
{
extern void compiled_entry_type ();
- extern long compiled_entry_manifest_closure_p ();
+ extern long compiled_entry_closure_p ();
extern long compiled_entry_to_block_offset ();
- extern Pointer compiled_closure_to_entry ();
+ extern SCHEME_OBJECT compiled_closure_to_entry ();
- Pointer results [3];
+ SCHEME_OBJECT results [3];
char * type_string;
- Pointer filename;
- Pointer entry;
+ SCHEME_OBJECT filename;
+ SCHEME_OBJECT entry;
Boolean closure_p;
entry = Expr;
switch (results [0])
{
case 0:
- if (compiled_entry_manifest_closure_p (entry))
+ if (compiled_entry_closure_p (entry))
{
type_string = "COMPILED_CLOSURE";
entry = (compiled_closure_to_entry (entry));
}
else if (PAIR_P (filename))
{
- int block_number;
-
printf (" file: ");
- print_filename (Vector_Ref (filename, CONS_CAR));
- FIXNUM_VALUE ((Vector_Ref (filename, CONS_CDR)), block_number);
- printf (" block: %d", block_number);
+ print_filename (PAIR_CAR (filename));
+ printf (" block: %d", (FIXNUM_TO_LONG (PAIR_CDR (filename))));
}
printf ("]");
return;
\f
Boolean
Print_One_Continuation_Frame (Temp)
- Pointer Temp;
+ SCHEME_OBJECT Temp;
{
- Pointer Expr;
+ SCHEME_OBJECT Expr;
Print_Expression (Temp, "Return code");
- CRLF ();
+ printf ("\n");
Expr = (Pop ());
Print_Expression (Expr, "Expression");
printf ("\n");
Back_Trace (where)
FILE *where;
{
- Pointer Temp, *Old_Stack;
+ SCHEME_OBJECT Temp, *Old_Stack;
Back_Trace_Entry_Hook();
Old_Stack = Stack_Pointer;
if (Return_Hook_Address == &Top_Of_Stack())
{
Temp = Pop();
- if (Temp != Make_Non_Pointer(TC_RETURN_CODE, RC_RETURN_TRAP_POINT))
+ if (Temp != MAKE_OBJECT (TC_RETURN_CODE, RC_RETURN_TRAP_POINT))
{
printf ("\n--> Return trap is missing here <--\n");
}
Print_Expression(Temp, " ...");
if ((OBJECT_TYPE (Temp)) == TC_MANIFEST_NM_VECTOR)
{
- Stack_Pointer = Simulate_Popping(Get_Integer(Temp));
+ Stack_Pointer = Simulate_Popping(OBJECT_DATUM (Temp));
printf (" (skipping)");
}
printf ("\n");
void
print_stack (sp)
- Pointer * sp;
+ SCHEME_OBJECT * sp;
{
- Pointer * saved_sp;
+ SCHEME_OBJECT * saved_sp;
saved_sp = Stack_Pointer;
Stack_Pointer = sp;
\f
static Boolean
print_primitive_name (primitive)
- Pointer primitive;
+ SCHEME_OBJECT primitive;
{
extern char *primitive_to_name();
char *name;
void
Print_Primitive (primitive)
- Pointer primitive;
+ SCHEME_OBJECT primitive;
{
extern long primitive_to_arity();
char buffer1[40], buffer2[40];
while (true)
{ interrupted = false;
printf ("Clear<number>, Set<number>, Done, ?, or Halt: ");
- OS_Flush_Output_Buffer();
+ OS_tty_flush_output();
/* Considerably haired up to go through standard (safe) interface */
/* -*-C-*-
-Copyright (c) 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.32 1989/09/20 23:07:30 cph Exp $
+
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.31 1989/03/27 23:14:47 jinx Rel $
- *
- * 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.
- *
- */
+/* This file contains default definitions for some hooks which
+ various machines require. These machines define these hooks
+ in CONFIG.H and this file defines them only if they remain
+ undefined. */
\f
/* Compiler bug fixes. */
#define Or3(x, y, z) ((x) || (y) || (z))
#endif
-#ifndef Fetch
+#ifndef MEMORY_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)
+ for example) to supply their own atomic operators in config.h. */
+#define MEMORY_FETCH(locative) (locative)
+#define MEMORY_STORE(locative, object) (locative) = (object)
#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 Get_Fixed_Obj_Slot(N) FAST_VECTOR_REF (Fixed_Objects, N)
+#define Set_Fixed_Obj_Slot(N,S) FAST_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 Declare_Fixed_Objects() SCHEME_OBJECT Fixed_Objects;
+#define Valid_Fixed_Obj_Vector() (VECTOR_P (Fixed_Objects))
#define Save_Fixed_Obj(Save_FO) \
Save_FO = Fixed_Objects; \
- Fixed_Objects = NIL;
+ Fixed_Objects = SHARP_F;
#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)
+#ifndef SWAP_POINTERS
+#define SWAP_POINTERS(locative, object, target) \
+{ \
+ (target) = (* (locative)); \
+ (* (locative)) = (object); \
+}
#endif
\f
#ifndef USE_STACKLETS
#endif
#ifndef Set_Pure_Top
-#define Set_Pure_Top() Align_Float (Free_Constant)
+#define Set_Pure_Top() ALIGN_FLOAT (Free_Constant)
#endif
#ifndef Test_Pure_Space_Top
#ifndef Close_File_Hook
#define Close_File_Hook()
#endif
-
-/* Used in flonum.h and generic.c */
-
-#ifndef double_into_fixnum
-#define double_into_fixnum(what, target) \
- target = Make_Non_Pointer(TC_FIXNUM, ((long) (what)))
-#endif
\f
/* Used in interpret.c */
#ifndef ENABLE_DEBUGGING_TOOLS
#define APPLY_PRIMITIVE INTERNAL_APPLY_PRIMITIVE
#else
-extern Pointer Apply_Primitive();
+extern SCHEME_OBJECT Apply_Primitive();
#define APPLY_PRIMITIVE(Loc, N) \
{ \
Loc = Apply_Primitive(N); \
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dmpwrld.c,v 9.30 1989/09/20 23:07:35 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dmpwrld.c,v 9.29 1989/05/31 01:49:57 jinx Rel $
- *
- * This file contains a primitive to dump an executable version of Scheme.
- * It uses unexec.c from GNU Emacs.
- * Look at unexec.c for more information.
- */
+/* This file contains a primitive to dump an executable version of Scheme.
+ It uses unexec.c from GNU Emacs.
+ Look at unexec.c for more information. */
#include "scheme.h"
#include "prims.h"
#include "unexec.c"
-char
+char
*start_of_text()
-{
+{
return ((char *) TEXT_START);
}
-char
+char
*start_of_data()
-{
+{
return ((char *) DATA_START);
}
return false;
}
-/* These two procedures depend on the internal structure of a
+/* These two procedures depend on the internal structure of a
FILE object. See /usr/include/stdio.h for details. */
-long
+long
Save_Input_Buffer()
-{
+{
long result;
result = (stdin)->_cnt;
return result;
}
-void
+void
Restore_Input_Buffer(Buflen)
fast long Buflen;
{
Boolean Saved_Dumped_Value, Saved_Photo_Open;
int Result;
long Buflen;
- Primitive_1_Arg();
+ PRIMITIVE_HEADER (1);
PRIMITIVE_CANONICALIZE_CONTEXT();
- 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);
+ signal_error_from_primitive (ERR_OUT_OF_FILE_HANDLES);
+ fname = (STRING_ARG (1));
/* Set up for restore */
Was_Scheme_Dumped = true;
Val = SHARP_T;
- OS_Quit (TERM_HALT, false);
+ OS_quit (TERM_HALT, false);
Pop_Primitive_Frame(1);
/* Dump! */
-
+
unix_find_pathname(Saved_argv[0], path_buffer);
Result = unexec(fname,
path_buffer,
/* Restore State */
- OS_Re_Init();
- Val = NIL;
+ OS_reinitialize();
+ Val = SHARP_F;
Was_Scheme_Dumped = Saved_Dumped_Value;
/* IO: Restoring cached input for this job. */
Photo_Open = Saved_Photo_Open;
if (Result != 0)
- {
- Push(Arg1); /* Since popped above */
- Primitive_Error(ERR_EXTERNAL_RETURN);
- }
+ {
+ Push (ARG_REF (1)); /* Since popped above */
+ error_external_return ();
+ }
- PRIMITIVE_ABORT(PRIM_POP_RETURN);
+ PRIMITIVE_ABORT (PRIM_POP_RETURN);
/*NOTREACHED*/
}
-
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dump.c,v 9.29 1989/09/20 23:07:39 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dump.c,v 9.28 1988/08/15 20:45:11 cph Rel $
- *
- * This file contains common code for dumping internal format binary files.
- */
+/* This file contains common code for dumping internal format binary files. */
\f
-extern Pointer compiler_utilities;
+extern SCHEME_OBJECT compiler_utilities;
extern long compiler_interface_version, compiler_processor_type;
void
Constant_Count, Constant_Relocation,
table_length, table_size,
cc_code_p, band_p)
- Pointer
+ SCHEME_OBJECT
*Buffer, *Dumped_Object,
*Heap_Relocation, *Constant_Relocation;
long
#ifdef DEBUG
#ifndef Heap_In_Low_Memory
- fprintf(stderr, "\nMemory_Base = 0x%x\n", Memory_Base);
+ fprintf(stderr, "\nmemory_base = 0x%x\n", memory_base);
#endif /* Heap_In_Low_Memory */
fprintf(stderr, "\nHeap_Relocation=0x%x, dumped as 0x%x\n",
- Heap_Relocation, Make_Pointer(TC_BROKEN_HEART, Heap_Relocation));
+ Heap_Relocation,
+ (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Heap_Relocation)));
fprintf(stderr, "\nDumped object=0x%x, dumped as 0x%x\n",
- Dumped_Object, Make_Pointer(TC_BROKEN_HEART, Dumped_Object));
+ Dumped_Object,
+ (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Dumped_Object)));
#endif /* DEBUG */
Buffer[FASL_Offset_Marker] = FASL_FILE_MARKER;
Buffer[FASL_Offset_Heap_Count] =
- Make_Non_Pointer(TC_BROKEN_HEART, Heap_Count);
+ MAKE_OBJECT (TC_BROKEN_HEART, Heap_Count);
Buffer[FASL_Offset_Heap_Base] =
- Make_Pointer(TC_BROKEN_HEART, Heap_Relocation);
+ MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Heap_Relocation);
Buffer[FASL_Offset_Dumped_Obj] =
- Make_Pointer(TC_BROKEN_HEART, Dumped_Object);
+ MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Dumped_Object);
Buffer[FASL_Offset_Const_Count] =
- Make_Non_Pointer(TC_BROKEN_HEART, Constant_Count);
+ MAKE_OBJECT (TC_BROKEN_HEART, Constant_Count);
Buffer[FASL_Offset_Const_Base] =
- Make_Pointer(TC_BROKEN_HEART, Constant_Relocation);
+ MAKE_POINTER_OBJECT (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_Non_Pointer(TC_BROKEN_HEART, 0); /* Nothing in stack area */
+ MAKE_OBJECT (TC_BROKEN_HEART, 0); /* Nothing in stack area */
#else
- Make_Pointer(TC_BROKEN_HEART, Stack_Top);
+ MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Top);
#endif /* USE_STACKLETS */
- Buffer[FASL_Offset_Prim_Length] =
- Make_Non_Pointer(TC_BROKEN_HEART, table_length);
- Buffer[FASL_Offset_Prim_Size] =
- Make_Non_Pointer(TC_BROKEN_HEART, table_size);
+ Buffer[FASL_Offset_Prim_Length] =
+ MAKE_OBJECT (TC_BROKEN_HEART, table_length);
+ Buffer[FASL_Offset_Prim_Size] =
+ MAKE_OBJECT (TC_BROKEN_HEART, table_size);
\f
if (cc_code_p)
{
it can be loaded anywhere.
*/
Buffer[FASL_Offset_Ci_Version] = MAKE_CI_VERSION(band_p, 0, 0);
- Buffer[FASL_Offset_Ut_Base] = NIL;
+ Buffer[FASL_Offset_Ut_Base] = SHARP_F;
}
for (i = FASL_Offset_First_Free; i < FASL_HEADER_LENGTH; i++)
{
- Buffer[i] = NIL;
+ Buffer[i] = SHARP_F;
}
return;
}
Constant_Count, Constant_Relocation,
table_start, table_length, table_size,
cc_code_p, band_p)
- Pointer
+ SCHEME_OBJECT
*Dumped_Object,
*Heap_Relocation, *Constant_Relocation,
*table_start;
table_length, table_size;
Boolean cc_code_p, band_p;
{
- Pointer Buffer[FASL_HEADER_LENGTH];
+ SCHEME_OBJECT Buffer[FASL_HEADER_LENGTH];
prepare_dump_header(Buffer, Dumped_Object,
Heap_Count, Heap_Relocation,
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/edwin.h,v 1.3 1989/08/28 18:28:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/edwin.h,v 1.4 1989/09/20 23:07:42 cph Rel $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
/* Definitions for Edwin data structures.
This MUST match the definitions in the Edwin source code. */
\f
-#define GROUP_P(object) ((OBJECT_TYPE (object)) == TC_VECTOR)
-#define GROUP_TEXT(group) (User_Vector_Ref ((group), 1))
-#define GROUP_GAP_START(group) (UNSIGNED_FIXNUM_VALUE (User_Vector_Ref ((group), 2)))
-#define GROUP_GAP_LENGTH(group) (UNSIGNED_FIXNUM_VALUE (User_Vector_Ref ((group), 3)))
-#define GROUP_GAP_END(group) (UNSIGNED_FIXNUM_VALUE (User_Vector_Ref ((group), 4)))
-#define GROUP_START_MARK(group) (User_Vector_Ref ((group), 6))
-#define GROUP_END_MARK(group) (User_Vector_Ref ((group), 7))
-
-#define MARK_GROUP(mark) (User_Vector_Ref ((mark), 1))
-#define MARK_POSITION(mark) (UNSIGNED_FIXNUM_VALUE (User_Vector_Ref ((mark), 2)))
-#define MARK_LEFT_INSERTING(mark) ((User_Vector_Ref ((mark), 3)) != SHARP_F)
+#define GROUP_P VECTOR_P
+#define GROUP_TEXT(group) (VECTOR_REF ((group), 1))
+
+#define GROUP_GAP_START(group) \
+ (UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF ((group), 2)))
+
+#define GROUP_GAP_LENGTH(group) \
+ (UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF ((group), 3)))
+
+#define GROUP_GAP_END(group) \
+ (UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF ((group), 4)))
+
+#define GROUP_START_MARK(group) (VECTOR_REF ((group), 6))
+#define GROUP_END_MARK(group) (VECTOR_REF ((group), 7))
+
+#define MARK_GROUP(mark) (VECTOR_REF ((mark), 1))
+#define MARK_POSITION(mark) (UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF ((mark), 2)))
+#define MARK_LEFT_INSERTING(mark) ((VECTOR_REF ((mark), 3)) != SHARP_F)
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.c,v 9.29 1989/09/20 23:07:46 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.c,v 9.28 1988/09/27 01:46:59 cph Rel $ */
-
#include "scheme.h"
#include "prims.h"
\f
return address or primitive procedure type. VALUE-CODE is the index\n\
number (i.e. external representation) of the desired result.")
{
- Pointer result;
long tc, number;
- Primitive_2_Args();
-
- Arg_1_Type(TC_FIXNUM);
- Arg_2_Type(TC_FIXNUM);
- tc = Get_Integer(Arg1);
- number = Get_Integer(Arg2);
+ PRIMITIVE_HEADER (2);
+ tc = (arg_nonnegative_integer (1));
+ number = (arg_nonnegative_integer (2));
switch (tc)
{
case TC_RETURN_CODE:
if (number > MAX_RETURN_CODE)
- {
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- }
- result = (Make_Non_Pointer(tc, number));
- break;
+ error_bad_range_arg (2);
+ PRIMITIVE_RETURN (MAKE_OBJECT (tc, number));
case TC_PRIMITIVE:
- if (number >= NUMBER_OF_PRIMITIVES())
- {
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- }
- if (number > MAX_PRIMITIVE)
- {
- result = MAKE_PRIMITIVE_OBJECT(number, (MAX_PRIMITIVE + 1));
- }
- else
- {
- result = MAKE_PRIMITIVE_OBJECT(0, number);
- }
- break;
-
- default: Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ if (number >= (NUMBER_OF_PRIMITIVES ()))
+ error_bad_range_arg (2);
+ PRIMITIVE_RETURN
+ ((number > MAX_PRIMITIVE)
+ ? (MAKE_PRIMITIVE_OBJECT (number, (MAX_PRIMITIVE + 1)))
+ : (MAKE_PRIMITIVE_OBJECT (0, number)));
+
+ default:
+ error_bad_range_arg (1);
}
- PRIMITIVE_RETURN(result);
+ /* NOTREACHED */
}
-\f
+
DEFINE_PRIMITIVE ("MAP-MACHINE-ADDRESS-TO-CODE", Prim_map_address_to_code, 2, 2,
"This is the inverse operation of `map-code-to-machine-address'. Given\n\
a machine ADDRESS and a TYPE-CODE (either return code or primitive\n\
procedure), it finds the number for the external representation for\n\
the internal address.")
{
- long tc, number;
- Primitive_2_Args();
-
- Arg_1_Type(TC_FIXNUM);
- tc = Get_Integer(Arg1);
- Arg_2_Type(tc);
+ fast long tc;
+ fast SCHEME_OBJECT address;
+ PRIMITIVE_HEADER (2);
+ tc = (arg_nonnegative_integer (1));
+ address = (ARG_REF (2));
+ if ((OBJECT_TYPE (address)) != tc)
+ error_wrong_type_arg (2);
switch (tc)
- { case TC_RETURN_CODE:
- number = Get_Integer(Arg2);
- if (number > MAX_RETURN_CODE)
+ {
+ case TC_RETURN_CODE:
{
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ fast long number = (OBJECT_DATUM (address));
+ if (number > MAX_RETURN_CODE)
+ error_bad_range_arg (2);
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (number));
}
- break;
case TC_PRIMITIVE:
- number = PRIMITIVE_NUMBER(Arg2);
- break;
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (PRIMITIVE_NUMBER (address)));
- default:
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- }
- PRIMITIVE_RETURN(MAKE_UNSIGNED_FIXNUM(number));
+ default:
+ error_bad_range_arg (1);
+ }
+ /* NOTREACHED */
}
\f
DEFINE_PRIMITIVE ("PRIMITIVE-PROCEDURE-ARITY", Prim_primitive_procedure_arity, 1, 1,
"Given a primitive procedure, returns the number of arguments it requires.")
{
- extern long primitive_to_arity();
- long answer;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_PRIMITIVE);
-
- if (PRIMITIVE_NUMBER(Arg1) >= NUMBER_OF_PRIMITIVES())
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, PRIMITIVE_P);
{
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ fast SCHEME_OBJECT primitive = (ARG_REF (1));
+ extern long primitive_to_arity ();
+ if ((PRIMITIVE_NUMBER (primitive)) >= (NUMBER_OF_PRIMITIVES ()))
+ error_bad_range_arg (1);
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM (primitive_to_arity (primitive)));
}
- answer = primitive_to_arity(Arg1);
- PRIMITIVE_RETURN(MAKE_SIGNED_FIXNUM(answer));
}
-DEFINE_PRIMITIVE ("PRIMITIVE-PROCEDURE-DOCUMENTATION", Prim_primitive_procedure_documentation, 1, 1,
- "Given a primitive procedure, returns its documentation string.")
+DEFINE_PRIMITIVE ("PRIMITIVE-PROCEDURE-DOCUMENTATION", Prim_primitive_procedure_doc, 1, 1,
+ "Given a primitive procedure, return its documentation string.")
{
- extern char * primitive_to_documentation ();
- char * answer;
- Primitive_1_Arg ();
-
- Arg_1_Type (TC_PRIMITIVE);
-
- if ((PRIMITIVE_NUMBER (Arg1)) >= (NUMBER_OF_PRIMITIVES ()))
- error_bad_range_arg (1);
- answer = (primitive_to_documentation (Arg1));
- PRIMITIVE_RETURN
- ((answer == ((char *) 0))
- ? SHARP_F
- : (C_String_To_Scheme_String (answer)));
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, PRIMITIVE_P);
+ {
+ fast SCHEME_OBJECT primitive = (ARG_REF (1));
+ if ((PRIMITIVE_NUMBER (primitive)) >= (NUMBER_OF_PRIMITIVES ()))
+ error_bad_range_arg (1);
+ {
+ extern char * primitive_to_documentation ();
+ fast char * answer = (primitive_to_documentation (primitive));
+ PRIMITIVE_RETURN
+ ((answer == ((char *) 0))
+ ? SHARP_F
+ : (char_pointer_to_string (answer)));
+ }
+ }
}
DEFINE_PRIMITIVE ("GET-PRIMITIVE-COUNTS", Prim_get_primitive_counts, 0, 0,
- "Returns a pair of the number of primitives defined in this interpreter\n\
-and the number of primitives referenced but not defined.")
+ "Return a pair of integers which are the number of primitive procedures.\n\
+The car is the count of defined primitives;
+the cdr is the count of undefined primitives that are referenced.")
{
- Primitive_0_Args();
-
- *Free++ = MAKE_UNSIGNED_FIXNUM(NUMBER_OF_DEFINED_PRIMITIVES());
- *Free++ = MAKE_UNSIGNED_FIXNUM(NUMBER_OF_UNDEFINED_PRIMITIVES());
- PRIMITIVE_RETURN(Make_Pointer(TC_LIST, Free - 2));
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN
+ (cons ((LONG_TO_UNSIGNED_FIXNUM (NUMBER_OF_DEFINED_PRIMITIVES ())),
+ (LONG_TO_UNSIGNED_FIXNUM (NUMBER_OF_UNDEFINED_PRIMITIVES ()))));
}
DEFINE_PRIMITIVE ("GET-PRIMITIVE-NAME", Prim_get_primitive_name, 1, 1,
- "Given a primitive procedure, returns the string for the name of that\n\
-procedure.")
+ "Return the (string) name of PRIMITIVE-PROCEDURE.")
{
- extern Pointer primitive_name();
- long Number, TC;
- Primitive_1_Arg();
-
- TC = OBJECT_TYPE(Arg1);
- if ((TC != TC_FIXNUM) && (TC != TC_PRIMITIVE))
+ PRIMITIVE_HEADER (1);
{
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ fast SCHEME_OBJECT primitive = (ARG_REF (1));
+ if (! ((PRIMITIVE_P (primitive)) || (FIXNUM_P (primitive))))
+ error_wrong_type_arg (1);
+ {
+ fast long number = (PRIMITIVE_NUMBER (primitive));
+ extern SCHEME_OBJECT primitive_name ();
+ if ((number < 0) || (number >= NUMBER_OF_PRIMITIVES()))
+ error_bad_range_arg (1);
+ PRIMITIVE_RETURN (primitive_name (number));
+ }
}
- Number = PRIMITIVE_NUMBER(Arg1);
- if ((Number < 0) || (Number >= NUMBER_OF_PRIMITIVES()))
- {
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- }
- PRIMITIVE_RETURN(primitive_name(Number));
}
\f
DEFINE_PRIMITIVE ("GET-PRIMITIVE-ADDRESS", Prim_get_primitive_address, 2, 2,
- "Given a symbol NAME, return the primitive object corresponding to this\n\
-name.\n\
+ "Given a symbol NAME, return the primitive object of that name.\n\
ARITY is the number of arguments which the primitive should expect.\n\
If ARITY is #F, #F is returned if the primitive is not implemented,\n\
even if the name already exists.\n\
If ARITY is an integer, a primitive object will always be returned,\n\
whether the corresponding primitive is implemented or not.")
{
- extern Pointer find_primitive();
+ fast SCHEME_OBJECT name;
+ fast SCHEME_OBJECT arity_arg;
+ extern SCHEME_OBJECT find_primitive ();
Boolean intern_p, allow_p;
long arity;
- Primitive_2_Args();
-
- Arg_1_Type(TC_INTERNED_SYMBOL);
- Touch_In_Primitive(Arg2, Arg2);
- if (Arg2 == NIL)
- {
- allow_p = false;
- intern_p = false;
- arity = UNKNOWN_PRIMITIVE_ARITY;
- }
- else if (Arg2 == SHARP_T)
- {
- allow_p = true;
- intern_p = false;
- arity = UNKNOWN_PRIMITIVE_ARITY;
- }
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, SYMBOL_P);
+ name = (ARG_REF (1));
+ TOUCH_IN_PRIMITIVE ((ARG_REF (2)), arity_arg);
+ if (arity_arg == SHARP_F)
+ {
+ allow_p = false;
+ intern_p = false;
+ arity = UNKNOWN_PRIMITIVE_ARITY;
+ }
+ else if (arity_arg == SHARP_T)
+ {
+ allow_p = true;
+ intern_p = false;
+ arity = UNKNOWN_PRIMITIVE_ARITY;
+ }
else
- {
- CHECK_ARG(2, FIXNUM_P);
- allow_p = true;
- intern_p = true;
- Sign_Extend(Arg2, arity);
- }
- PRIMITIVE_RETURN(find_primitive(Fast_Vector_Ref(Arg1, SYMBOL_NAME),
- intern_p, allow_p, arity));
+ {
+ CHECK_ARG(2, FIXNUM_P);
+ allow_p = true;
+ intern_p = true;
+ arity = (FIXNUM_TO_LONG (arity_arg));
+ }
+ PRIMITIVE_RETURN
+ (find_primitive
+ ((FAST_MEMORY_REF (name, SYMBOL_NAME)), intern_p, allow_p, arity));
}
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.33 1989/09/20 23:07:50 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.32 1989/08/28 18:28:48 cph Exp $
- *
- * External declarations.
- *
- */
+/* External Declarations */
\f
#ifdef ENABLE_DEBUGGING_TOOLS
extern void Pop_Return_Break_Point();
extern int debug_slotno, debug_nslots, local_slotno, local_nslots,
debug_circle[], local_circle[];
-#else
+
+#else /* not ENABLE_DEBUGGING_TOOLS */
+
#define Eval_Debug false
#define Hex_Input_Debug false
#define File_Load_Debug false
#define Per_File false
#define Bignum_Debug false
#define Fluids_Debug false
-#endif
-\f
+
+#endif /* ENABLE_DEBUGGING_TOOLS */
+
/* The register block */
-extern Pointer Registers[];
-
-extern Pointer
- *Ext_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 */
- *Constant_Top, /* Top of constant+pure space */
- *Heap_Top, /* Top of current heap space */
- *Heap_Bottom, /* Bottom of current heap space */
- *Unused_Heap_Top, /* Top of unused heap for GC */
- *Unused_Heap, /* Bottom of unused heap for GC */
- *Local_Heap_Base, /* Per-processor CONSing area */
- *Heap, /* Bottom of all heap space */
- Current_State_Point, /* Dynamic state point */
- Fluid_Bindings, /* Fluid bindings AList */
- *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. ***
- */
- return_to_interpreter;/* Return code/address used by the compiled code
- interface to make compiled code return to the
- interpreter.
- */
-
-extern Declare_Fixed_Objects();
-\f
+extern SCHEME_OBJECT Registers [];
+
+extern SCHEME_OBJECT
+ * Ext_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 */
+ * Constant_Top, /* Top of constant+pure space */
+ * Heap_Top, /* Top of current heap space */
+ * Heap_Bottom, /* Bottom of current heap space */
+ * Unused_Heap_Top, /* Top of unused heap for GC */
+ * Unused_Heap, /* Bottom of unused heap for GC */
+ * Local_Heap_Base, /* Per-processor CONSing area */
+ * Heap, /* Bottom of all heap space */
+ Current_State_Point, /* Dynamic state point */
+ Fluid_Bindings, /* Fluid bindings AList */
+
+ /* 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. *** */
+ * last_return_code,
+
+ /* Return code/address used by the compiled code interface to make
+ compiled code return to the interpreter. */
+ return_to_interpreter;
+
+extern Declare_Fixed_Objects ();
+\f
extern long
IntCode, /* Interrupts requesting */
IntEnb, /* Interrupts enabled */
/* Used to signal microcode errors from compiled code. */
compiled_code_error_code;
-extern char *Return_Names[];
+extern char * Return_Names [];
extern long MAX_RETURN;
-extern char *CONT_PRINT_RETURN_MESSAGE,
- *CONT_PRINT_EXPR_MESSAGE,
- *RESTORE_CONT_RETURN_MESSAGE,
- *RESTORE_CONT_EXPR_MESSAGE;
+extern char
+ * CONT_PRINT_RETURN_MESSAGE,
+ * CONT_PRINT_EXPR_MESSAGE,
+ * RESTORE_CONT_RETURN_MESSAGE,
+ * RESTORE_CONT_EXPR_MESSAGE;
+
+extern int GC_Type_Map [];
-extern int GC_Type_Map[];
+extern FILE * (Channels [FILE_CHANNELS]);
+extern Boolean Photo_Open;
+extern FILE * Photo_File_Handle;
-extern Boolean Photo_Open; /* Photo file open */
-extern jmp_buf *Back_To_Eval;
+extern jmp_buf * Back_To_Eval;
extern Boolean Trapping;
-extern Pointer Old_Return_Code, *Return_Hook_Address;
+extern SCHEME_OBJECT Old_Return_Code;
+extern SCHEME_OBJECT * Return_Hook_Address;
-extern Pointer *Prev_Restore_History_Stacklet;
+extern SCHEME_OBJECT * Prev_Restore_History_Stacklet;
extern long Prev_Restore_History_Offset;
-\f
-/* And file "channels" */
-
-extern FILE *(Channels[FILE_CHANNELS]);
-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;
-\f
-/* Environment lookup utilities. */
+extern char ** Saved_argv;
-extern long Lex_Ref(), Local_Set(), Lex_Set(),
- Symbol_Lex_Ref(), Symbol_Lex_Set();
+extern char * OS_Name;
+extern char * OS_Variant;
-/* String utilities */
-
-extern Pointer C_String_To_Scheme_String();
-
-#define Scheme_String_To_C_String(Scheme_String) \
- ((char *) Nth_Vector_Loc(Scheme_String, STRING_CHARS))
-
-/* 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();
+extern long Heap_Size;
+extern long Constant_Size;
+extern long Stack_Size;
+extern SCHEME_OBJECT * Highest_Allocated_Address;
+\f
+/* Environment lookup utilities. */
+extern long Lex_Ref ();
+extern long Local_Set ();
+extern long Lex_Set ();
+extern long Symbol_Lex_Ref ();
+extern long Symbol_Lex_Set ();
+
+/* Arithmetic utilities */
+extern long fixnum_to_long ();
+extern SCHEME_OBJECT double_to_fixnum ();
+extern SCHEME_OBJECT double_to_flonum ();
+extern Boolean integer_to_long_p ();
+extern long integer_to_long ();
+extern SCHEME_OBJECT long_to_integer ();
+extern Boolean integer_to_double_p ();
+extern double integer_to_double ();
+extern SCHEME_OBJECT double_to_integer ();
+extern double double_truncate ();
+extern Boolean real_number_to_double_p ();
+extern double real_number_to_double ();
+extern SCHEME_OBJECT bignum_to_fixnum ();
+extern SCHEME_OBJECT bignum_to_integer ();
+extern SCHEME_OBJECT bignum_to_flonum ();
+extern SCHEME_OBJECT flonum_floor ();
+extern SCHEME_OBJECT flonum_ceiling ();
+extern SCHEME_OBJECT flonum_round ();
+extern Boolean integer_zero_p ();
+extern Boolean integer_negative_p ();
+extern Boolean integer_positive_p ();
+extern Boolean integer_equal_p ();
+extern Boolean integer_less_p ();
+extern SCHEME_OBJECT integer_negate ();
+extern SCHEME_OBJECT integer_add ();
+extern SCHEME_OBJECT integer_add_1 ();
+extern SCHEME_OBJECT integer_subtract ();
+extern SCHEME_OBJECT integer_subtract_1 ();
+extern SCHEME_OBJECT integer_multiply ();
+extern Boolean integer_divide ();
+extern SCHEME_OBJECT integer_quotient ();
+extern SCHEME_OBJECT integer_remainder ();
+
+/* Character utilities */
+extern long char_downcase ();
+extern long char_upcase ();
+
+/* Allocation utilities */
+extern SCHEME_OBJECT cons ();
+extern SCHEME_OBJECT system_pair_cons ();
+extern SCHEME_OBJECT hunk3_cons ();
+extern SCHEME_OBJECT allocate_non_marked_vector ();
+extern SCHEME_OBJECT allocate_marked_vector ();
+extern SCHEME_OBJECT make_vector ();
+extern SCHEME_OBJECT allocate_string ();
+extern SCHEME_OBJECT memory_to_string ();
+extern SCHEME_OBJECT char_pointer_to_string ();
/* Random and OS utilities */
-
-extern int Parse_Option();
-extern Boolean Restore_History();
-extern long NColumns(), NLines(), OS_process_clock ();
-extern void OS_Flush_Output_Buffer(), OS_Re_Init();
-extern Pointer cons ();
-extern Pointer allocate_non_marked_vector ();
-extern Pointer allocate_marked_vector ();
-extern Pointer make_vector ();
+extern int Parse_Option ();
+extern Boolean Restore_History ();
+extern long OS_tty_x_size ();
+extern long OS_tty_y_size ();
+extern long OS_process_clock ();
+extern void OS_tty_flush_output ();
+extern void OS_reinitialize ();
+extern Boolean interpreter_applicable_p ();
/* Memory management utilities */
-
-extern Pointer Purify_Pass_2(), Fasload();
-extern Boolean Pure_Test();
-
+extern SCHEME_OBJECT Purify_Pass_2 ();
+extern SCHEME_OBJECT Fasload ();
+extern Boolean Pure_Test ();
+\f
/* 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 term_type Microcode_Termination ();
+extern void
+ Interpret (),
+ Do_Micro_Error (),
+ Setup_Interrupt (),
+ Back_Out_Of_Primitive (),
+ Translate_To_Point (),
+ Stop_History (),
+ Stack_Death ();
#ifdef USE_STACKLETS
-extern void Allocate_New_Stacklet();
+extern void Allocate_New_Stacklet ();
#endif
-extern Pointer *Make_Dummy_History(), Find_State_Space();
+extern SCHEME_OBJECT * Make_Dummy_History ();
+extern SCHEME_OBJECT Find_State_Space ();
/* Debugging utilities */
-extern void Back_Trace(), Handle_Debug_Flags(),
- Show_Env(), Show_Pure(),
- Print_Return(), Print_Expression(), Print_Primitive();
-\f
+extern void
+ Back_Trace (),
+ Handle_Debug_Flags (),
+ Show_Env (),
+ Show_Pure (),
+ Print_Return (),
+ Print_Expression (),
+ Print_Primitive ();
+
/* Conditional utilities */
#if false
-extern void Clear_Perfinfo_Data();
+extern void Clear_Perfinfo_Data ();
#endif
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.43 1989/09/20 23:07:54 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.42 1989/06/08 00:25:01 jinx Rel $
-
- This file contains code for fasdump and dump-band.
-*/
+/* This file contains code for fasdump and dump-band. */
#include "scheme.h"
#include "prims.h"
#include "fasl.h"
#include "dump.c"
-extern Pointer
+extern SCHEME_OBJECT
dump_renumber_primitive(),
*initialize_primitive_table(),
*cons_primitive_table(),
\f
/* Some statics used freely in this file */
-static Pointer *NewFree, *NewMemTop, *Fixup, *Orig_New_Free;
+static SCHEME_OBJECT *NewFree, *NewMemTop, *Fixup, *Orig_New_Free;
static Boolean compiled_code_present_p;
/* FASDUMP:
where the flag is #!true for a dump into constant
space at reload time, () for a dump into heap.
- Currently flag is ignored.
+ Currently flag is ignored.
*/
\f
-/*
+/*
Copy of GCLoop, except (a) copies out of constant space into the
object to be dumped; (b) changes symbols and variables as
described; (c) keeps track of broken hearts and their original
Dump_Pointer(Fasdump_Setup_Pointer(Extra_Code, Normal_BH(false, continue)))
#define Dump_Pointer(Code) \
-Old = Get_Pointer(Temp); \
+Old = OBJECT_ADDRESS (Temp); \
Code
#define Dump_Compiled_Entry() \
/* Dump_Mode is currently a fossil. It should be resurrected. */
-/* Should be big enough for the largest fixed size object (a Quad)
+/* Should be big enough for the largest fixed size object (a Quad)
and 2 for the Fixup.
*/
long
DumpLoop(Scan, Dump_Mode)
- fast Pointer *Scan;
+ fast SCHEME_OBJECT *Scan;
int Dump_Mode;
{
- fast Pointer *To, *Old, Temp, New_Address, *Fixes;
+ fast SCHEME_OBJECT *To, *Old, Temp, New_Address, *Fixes;
long result;
To = NewFree;
break;
case TC_BROKEN_HEART:
- if (OBJECT_DATUM(Temp) != 0)
+ if (OBJECT_DATUM (Temp) != 0)
{
sprintf(gc_death_message_buffer,
"dumploop: broken heart (0x%lx) in scan",
case TC_MANIFEST_NM_VECTOR:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
- Scan += Get_Integer(Temp);
+ Scan += OBJECT_DATUM (Temp);
break;
/* Compiled code relocation. */
{
fast long count;
fast machine_word *word_ptr;
- Pointer *end_scan;
+ SCHEME_OBJECT *end_scan;
count = READ_OPERATOR_LINKAGE_COUNT(Temp);
word_ptr = FIRST_OPERATOR_LINKAGE_ENTRY(Scan);
break;
case TC_REFERENCE_TRAP:
- if (OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE)
+ if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
{
/* It is a non pointer. */
break;
break;
case TC_INTERNED_SYMBOL:
- Setup_Pointer_for_Dump(Fasdump_Symbol(Make_Broken_Heart(0)));
+ Setup_Pointer_for_Dump (Fasdump_Symbol (BROKEN_HEART_ZERO));
break;
case TC_UNINTERNED_SYMBOL:
- Setup_Pointer_for_Dump(Fasdump_Symbol(UNBOUND_OBJECT));
+ Setup_Pointer_for_Dump (Fasdump_Symbol (UNBOUND_OBJECT));
break;
case_Triple:
PRIMITIVE_RETURN(Fasdump_Exit(PRIM_INTERRUPT)); \
}
-Pointer
+SCHEME_OBJECT
Fasdump_Exit(code)
long code;
{
Boolean result;
- fast Pointer *Fixes;
+ fast SCHEME_OBJECT *Fixes;
Fixes = Fixup;
result = Close_Dump_File();
while (Fixes != NewMemTop)
{
- fast Pointer *Fix_Address;
+ fast SCHEME_OBJECT *Fix_Address;
- Fix_Address = Get_Pointer(*Fixes++); /* Where it goes. */
+ Fix_Address = OBJECT_ADDRESS (*Fixes++); /* Where it goes. */
*Fix_Address = *Fixes++; /* Put it there. */
}
Fixup = Fixes;
Fasdump_Exit_Hook();
if (!result)
{
- Primitive_Error(ERR_IO_ERROR);
+ signal_error_from_primitive (ERR_IO_ERROR);
/*NOTREACHED*/
}
if (code == PRIM_DONE)
}
else if (code == PRIM_INTERRUPT)
{
- return (NIL);
+ return (SHARP_F);
}
else
{
- Primitive_Error(code);
+ signal_error_from_primitive (code);
/*NOTREACHED*/
}
}
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
+ the filename and the third a flag. The flag, if #T, means
that the object is to be dumped for reloading into constant
- space. This is currently disabled. If the flag is NIL, it means
+ space. This is currently disabled. If the flag is #F, it means
that it will be reloaded into the heap. The primitive returns
- #!TRUE or NIL indicating whether it successfully dumped the
+ #T or #F indicating whether it successfully dumped the
object (it can fail on an object that is too large).
The code for dumping pure is severely broken and conditionalized out.
DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0)
{
- Pointer Object, File_Name, Flag, *New_Object;
- Pointer *table_start, *table_end;
- long Pure_Length, Length, table_length, value;
+ SCHEME_OBJECT Object, File_Name, Flag, *New_Object;
+ SCHEME_OBJECT *table_start, *table_end;
+ long Length, table_length;
Boolean result;
- Primitive_3_Args();
-
+ PRIMITIVE_HEADER (3);
CHECK_ARG (2, STRING_P);
-
compiled_code_present_p = false;
- Object = Arg1;
- File_Name = Arg2;
- Flag = Arg3;
-
- if (!Open_Dump_File(File_Name, WRITE_FLAG))
- {
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- }
+ Object = (ARG_REF (1));
+ File_Name = (ARG_REF (2));
+ Flag = (ARG_REF (3));
+ if (! (Open_Dump_File (File_Name, WRITE_FLAG)))
+ error_bad_range_arg (2);
#if false
- if ((Flag != NIL) && (Flag != SHARP_T))
+ CHECK_ARG (3, BOOLEAN_P);
#else
- if (Flag != NIL)
-#endif /* false */
- {
- Primitive_Error(ERR_ARG_3_WRONG_TYPE);
- }
-
+ if (Flag != SHARP_F)
+ error_wrong_type_arg (3);
+#endif
table_end = &Free[Space_Before_GC()];
table_start = initialize_primitive_table(Free, table_end);
if (table_start >= table_end)
- {
- Primitive_GC(table_start - Free);
- }
-
+ {
+ Primitive_GC (table_start - Free);
+ }
Fasdump_Free_Calc(NewFree, NewMemTop, Orig_New_Free);
Fixup = NewMemTop;
New_Object = NewFree;
if (Flag == SHARP_T)
{
- Pointer *Addr_Of_New_Object;
+ SCHEME_OBJECT *Addr_Of_New_Object;
- *New_Free++ = NIL;
+ *New_Free++ = SHARP_F;
DUMPLOOP(New_Object, PURE_COPY);
#if false
/* Can't align. */
- Align_Float(NewFree);
+ ALIGN_FLOAT (NewFree);
#endif
Pure_Length = ((NewFree - New_Object) + 1);
- *NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *NewFree++ = Make_Non_Pointer(CONSTANT_PART, Pure_Length);
+ *NewFree++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *NewFree++ = MAKE_OBJECT (CONSTANT_PART, Pure_Length);
DUMPLOOP(New_Object, CONSTANT_COPY);
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]);
- New_Object[0] = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR,
- Pure_Length);
- New_Object[1] = Make_Non_Pointer(PURE_PART, (Length - 1));
+ *NewFree++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *NewFree++ = MAKE_OBJECT (END_OF_BLOCK, (Length - 1));
+ Addr_Of_New_Object = OBJECT_ADDRESS (New_Object[0]);
+ New_Object[0] = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, Pure_Length);
+ New_Object[1] = MAKE_OBJECT (PURE_PART, (Length - 1));
table_start = NewFree;
table_end = cons_primitive_table(NewFree, Fixup, &table_length);
if (table_end >= Fixup)
DUMPLOOP(New_Object, NORMAL_GC);
#if false
/* Aligning might screw up some of the counters. */
- Align_Float(NewFree);
+ ALIGN_FLOAT (NewFree);
#endif
Length = (NewFree - New_Object);
table_start = NewFree;
/* (DUMP-BAND PROCEDURE FILE-NAME)
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.
+ argument of #F.
*/
DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0)
{
- Pointer Combination, *table_start, *table_end, *saved_free;
+ SCHEME_OBJECT Combination, *table_start, *table_end, *saved_free;
long table_length;
Boolean result;
- Primitive_2_Args();
-
- Band_Dump_Permitted();
- /* This type check isn't strictly needed, but it is better to find
- out about problems now than to wait until band-load time.
- However, the type code list must be kept in agreement with
- internal-apply in the interpreter. */
- {
- long type_code;
-
- type_code = (OBJECT_TYPE (Arg1));
- if (! ((type_code == TC_COMPILED_ENTRY) ||
- (type_code == TC_CONTROL_POINT) ||
- (type_code == TC_ENTITY) ||
- (type_code == TC_EXTENDED_PROCEDURE) ||
- (type_code == TC_PRIMITIVE) ||
- (type_code == TC_PROCEDURE)))
- error_wrong_type_arg (1);
- }
- Arg_2_Type(TC_CHARACTER_STRING);
-
+ PRIMITIVE_HEADER (2);
+ Band_Dump_Permitted ();
+ CHECK_ARG (1, INTERPRETER_APPLICABLE_P);
+ CHECK_ARG (2, STRING_P);
if (Unused_Heap < Heap_Bottom)
- {
- /* Cause the image to be in the low heap, to increase
- the probability that no relocation is needed on reload.
- */
-
- Primitive_GC(0);
- }
-
- if (!Open_Dump_File(Arg2, WRITE_FLAG))
- {
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- }
- Primitive_GC_If_Needed(5);
+ {
+ /* Cause the image to be in the low heap, to increase
+ the probability that no relocation is needed on reload. */
+ Primitive_GC (0);
+ }
+ if (! (Open_Dump_File ((ARG_REF (2)), WRITE_FLAG)))
+ error_bad_range_arg (2);
+ Primitive_GC_If_Needed (5);
saved_free = Free;
- Combination = Make_Pointer(TC_COMBINATION_1, Free);
- Free[COMB_1_FN] = Arg1;
- Free[COMB_1_ARG_1] = NIL;
+ Combination = MAKE_POINTER_OBJECT (TC_COMBINATION_1, Free);
+ Free[COMB_1_FN] = (ARG_REF (1));
+ Free[COMB_1_ARG_1] = SHARP_F;
Free += 2;
*Free++ = Combination;
*Free++ = compiler_utilities;
- *Free = Make_Pointer(TC_LIST, (Free - 2));
+ *Free = MAKE_POINTER_OBJECT (TC_LIST, (Free - 2));
Free++; /* Some compilers are TOO clever about this and increment Free
before calculating Free-2! */
table_start = Free;
{
#if false
/* Aligning here confuses some of the counts computed. */
- Align_Float(Free);
+ ALIGN_FLOAT (Free);
#endif
result = Write_File((Free - 1),
((long) (Free - Heap_Bottom)), Heap_Bottom,
Constant_Space,
table_start, table_length,
((long) (table_end - table_start)),
- (compiler_utilities != NIL), true);
+ (compiler_utilities != SHARP_F), true);
}
/* The and is short-circuit, so it must be done in this order. */
- result = (Close_Dump_File() && result);
- Band_Dump_Exit_Hook();
+ result = ((Close_Dump_File ()) && result);
+ Band_Dump_Exit_Hook ();
Free = saved_free;
- PRIMITIVE_RETURN(result ? SHARP_T : NIL);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (result));
}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasl.h,v 9.30 1989/09/20 23:07:58 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasl.h,v 9.29 1988/08/15 20:46:07 cph Rel $
-
- Contains information relating to the format of FASL files.
+/* Contains information relating to the format of FASL files.
The machine/opsys information is contained in config.h
The processor and compiled code version information is
- contained in the appropriate cmp* file, or compiler.c
-*/
+ contained in the appropriate cmp* file, or compiler.c */
extern long Load_Data(), Write_Data();
extern Boolean Open_Dump_File(), Close_Dump_File();
#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_Version 6 /* FASL format version info. */
#define FASL_Offset_Stack_Top 7 /* Top of stack when dumped */
#define FASL_Offset_Prim_Length 8 /* Number of entries in primitive table */
-#define FASL_Offset_Prim_Size 9 /* Size of primitive table in Pointers */
+#define FASL_Offset_Prim_Size 9 /* Size of primitive table in SCHEME_OBJECTs */
#define FASL_Offset_Ci_Version 10 /* Version number for compiled code interface */
#define FASL_Offset_Ut_Base 11 /* Address of the utilities vector */
/* Version information encoding */
-#define MACHINE_TYPE_LENGTH (POINTER_LENGTH / 2)
+#define MACHINE_TYPE_LENGTH (OBJECT_LENGTH / 2)
#define MACHINE_TYPE_MASK ((1 << MACHINE_TYPE_LENGTH) - 1)
#define The_Machine_Type(P) ((P) & MACHINE_TYPE_MASK)
#define SUBVERSION_LENGTH (MACHINE_TYPE_LENGTH - TYPE_CODE_LENGTH)
#define SUBVERSION_MASK ((1 << SUBVERSION_LENGTH) - 1)
#define The_Sub_Version(P) (((P) >> MACHINE_TYPE_LENGTH) & SUBVERSION_MASK)
-#define The_Version(P) OBJECT_TYPE(P)
+#define The_Version(P) OBJECT_TYPE (P)
#define Make_Version(V, S, M) \
- Make_Non_Pointer((V), (((S) << MACHINE_TYPE_LENGTH) | (M)))
+ MAKE_OBJECT ((V), (((S) << MACHINE_TYPE_LENGTH) | (M)))
-#define CI_MASK ((1 << (ADDRESS_LENGTH / 2)) - 1)
-#define CI_VERSION(P) (((P) >> (ADDRESS_LENGTH / 2)) & CI_MASK)
+#define CI_MASK ((1 << (DATUM_LENGTH / 2)) - 1)
+#define CI_VERSION(P) (((P) >> (DATUM_LENGTH / 2)) & CI_MASK)
#define CI_PROCESSOR(P) ((P) & CI_MASK)
-#define CI_BAND_P(P) (OBJECT_TYPE(P) == TC_TRUE)
+#define CI_BAND_P(P) (OBJECT_TYPE (P) == TC_TRUE)
#define MAKE_CI_VERSION(Band_p, Version, Processor_Type) \
- Make_Non_Pointer(((Band_p) ? TC_TRUE : TC_NULL), \
- (((Version) << (ADDRESS_LENGTH / 2)) | \
+ MAKE_OBJECT (((Band_p) ? TC_TRUE : TC_NULL), \
+ (((Version) << (DATUM_LENGTH / 2)) | \
(Processor_Type)))
#define WRITE_FLAG 1
#define FASL_REFERENCE_TRAP 6
#define FASL_MERGED_PRIMITIVES 7
#define FASL_INTERFACE_VERSION 8
+#define FASL_NEW_BIGNUMS 9
/* Current parameters. Always used on output. */
#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK
-#define FASL_SUBVERSION FASL_INTERFACE_VERSION
+#define FASL_SUBVERSION FASL_NEW_BIGNUMS
/*
The definitions below correspond to the ones above. They usually
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.43 1989/09/20 23:08:02 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.42 1989/07/25 08:45:49 cph Rel $
-
- The "fast loader" which reads in and relocates binary files and then
+/* 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.
- */
+ returns a single object read in. */
#include "scheme.h"
#include "prims.h"
\f
long
read_file_start(name)
- Pointer name;
+ SCHEME_OBJECT name;
{
long value, heap_length;
Boolean file_opened;
- if (OBJECT_TYPE(name) != TC_CHARACTER_STRING)
+ if (OBJECT_TYPE (name) != TC_CHARACTER_STRING)
{
return (ERR_ARG_1_WRONG_TYPE);
}
case FASL_FILE_BAD_INTERFACE:
return (ERR_FASLOAD_COMPILED_MISMATCH);
}
- }
+ }
if (Or2(Reloc_Debug, File_Load_Debug))
{
return (PRIM_DONE);
}
\f
-Pointer *
+SCHEME_OBJECT *
read_file_end()
{
- Pointer *table;
+ SCHEME_OBJECT *table;
if ((Load_Data(Heap_Count, ((char *) Free))) != Heap_Count)
{
Close_Dump_File();
- Primitive_Error(ERR_IO_ERROR);
+ signal_error_from_primitive (ERR_IO_ERROR);
}
NORMALIZE_REGION(((char *) Free), Heap_Count);
Free += Heap_Count;
if ((Load_Data(Const_Count, ((char *) Free_Constant))) != Const_Count)
{
Close_Dump_File();
- Primitive_Error(ERR_IO_ERROR);
+ signal_error_from_primitive (ERR_IO_ERROR);
}
NORMALIZE_REGION(((char *) Free_Constant), Const_Count);
Free_Constant += Const_Count;
Primitive_Table_Size)
{
Close_Dump_File();
- Primitive_Error(ERR_IO_ERROR);
+ signal_error_from_primitive (ERR_IO_ERROR);
}
NORMALIZE_REGION(((char *) table), Primitive_Table_Size);
Free += Primitive_Table_Size;
}
else
{
- Primitive_Error(ERR_IO_ERROR);
+ signal_error_from_primitive (ERR_IO_ERROR);
}
}
\f
static Boolean Warned = false;
-Pointer *
+SCHEME_OBJECT *
Relocate(P)
long P;
{
- Pointer *Result;
+ SCHEME_OBJECT *Result;
if ((P >= Heap_Base) && (P < Dumped_Heap_Top))
{
- Result = ((Pointer *) (P + heap_relocation));
+ Result = ((SCHEME_OBJECT *) (P + heap_relocation));
}
else if ((P >= Const_Base) && (P < Dumped_Constant_Top))
{
- Result = ((Pointer *) (P + const_relocation));
+ Result = ((SCHEME_OBJECT *) (P + const_relocation));
}
else if ((P >= Dumped_Constant_Top) && (P < Dumped_Stack_Top))
{
- Result = ((Pointer *) (P + stack_relocation));
+ Result = ((SCHEME_OBJECT *) (P + stack_relocation));
}
else
{
Const_Base, Dumped_Constant_Top, Dumped_Stack_Top);
Warned = true;
}
- Result = ((Pointer *) 0);
+ Result = ((SCHEME_OBJECT *) 0);
}
if (Reloc_Debug)
{
{ \
if ((P) < Dumped_Heap_Top) \
{ \
- (Loc) = ((Pointer *) ((P) + heap_relocation)); \
+ (Loc) = ((SCHEME_OBJECT *) ((P) + heap_relocation)); \
} \
else if ((P) < Dumped_Constant_Top) \
{ \
- (Loc) = ((Pointer *) ((P) + const_relocation)); \
+ (Loc) = ((SCHEME_OBJECT *) ((P) + const_relocation)); \
} \
else \
{ \
- (Loc) = ((Pointer *) ((P) + stack_relocation)); \
+ (Loc) = ((SCHEME_OBJECT *) ((P) + stack_relocation)); \
} \
}
#define Relocate(P) \
((P < Const_Base) ? \
- ((Pointer *) (P + heap_relocation)) : \
+ ((SCHEME_OBJECT *) (P + heap_relocation)) : \
((P < Dumped_Constant_Top) ? \
- ((Pointer *) (P + const_relocation)) : \
- ((Pointer *) (P + stack_relocation))))
+ ((SCHEME_OBJECT *) (P + const_relocation)) : \
+ ((SCHEME_OBJECT *) (P + stack_relocation))))
#else /* Conditional_Bug */
-static Pointer *Relocate_Temp;
+static SCHEME_OBJECT *Relocate_Temp;
#define Relocate(P) \
(Relocate_Into(Relocate_Temp, P), Relocate_Temp)
void
Relocate_Block(Scan, Stop_At)
- fast Pointer *Scan, *Stop_At;
+ fast SCHEME_OBJECT *Scan, *Stop_At;
{
- extern Pointer *load_renumber_table;
- fast Pointer Temp;
+ extern SCHEME_OBJECT *load_renumber_table;
+ fast SCHEME_OBJECT Temp;
fast long address;
if (Reloc_Debug)
case_Fasload_Non_Pointer:
Scan += 1;
break;
-
+
case TC_PRIMITIVE:
- *Scan++ = load_renumber_table[PRIMITIVE_NUMBER(Temp)];
+ *Scan++ = (load_renumber_table [PRIMITIVE_NUMBER (Temp)]);
break;
-
+
case TC_PCOMB0:
*Scan++ =
- Make_Non_Pointer(TC_PCOMB0,
- load_renumber_table[PRIMITIVE_NUMBER(Temp)]);
+ OBJECT_NEW_TYPE
+ (TC_PCOMB0, (load_renumber_table [PRIMITIVE_NUMBER (Temp)]));
break;
case TC_MANIFEST_NM_VECTOR:
- Scan += (Get_Integer(Temp) + 1);
+ Scan += (OBJECT_DATUM (Temp) + 1);
break;
\f
case TC_LINKAGE_SECTION:
)
{
address = ((long) *Scan);
- *Scan++ = ((Pointer) Relocate(address));
+ *Scan++ = ((SCHEME_OBJECT) Relocate(address));
}
break;
}
{
fast long count;
fast machine_word *word_ptr;
- Pointer *end_scan;
+ SCHEME_OBJECT *end_scan;
count = READ_OPERATOR_LINKAGE_COUNT(Temp);
word_ptr = FIRST_OPERATOR_LINKAGE_ENTRY(Scan);
Scan = OPERATOR_LINKAGE_ENTRY_ADDRESS(word_ptr);
word_ptr = NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr);
address = ((long) *Scan);
- *Scan = ((Pointer) Relocate(address));
+ *Scan = ((SCHEME_OBJECT) Relocate(address));
}
Scan = &end_scan[1];
break;
Scan = MANIFEST_CLOSURE_ENTRY_ADDRESS(word_ptr);
word_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
address = ((long) *Scan);
- *Scan = ((Pointer) Relocate(address));
+ *Scan = ((SCHEME_OBJECT) Relocate(address));
}
Scan = &((MANIFEST_CLOSURE_END(word_ptr, start_ptr))[1]);
break;
\f
#ifdef BYTE_INVERSION
case TC_CHARACTER_STRING:
- String_Inversion(Relocate(OBJECT_DATUM(Temp)));
+ String_Inversion(Relocate(OBJECT_DATUM (Temp)));
goto normal_pointer;
#endif
case TC_REFERENCE_TRAP:
- if (OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE)
+ if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
{
Scan += 1;
break;
/* This should be more strict. */
default:
+#ifdef BYTE_INVERSION
normal_pointer:
- address = OBJECT_DATUM(Temp);
- *Scan++ = Make_Pointer(OBJECT_TYPE(Temp), Relocate(address));
+#endif
+ address = OBJECT_DATUM (Temp);
+ *Scan++ = MAKE_POINTER_OBJECT (OBJECT_TYPE (Temp), Relocate(address));
break;
}
}
\f
Boolean
check_primitive_numbers(table, length)
- fast Pointer *table;
+ fast SCHEME_OBJECT *table;
fast long length;
{
fast long count, top;
\f
void
Intern_Block(Next_Pointer, Stop_At)
- fast Pointer *Next_Pointer, *Stop_At;
+ fast SCHEME_OBJECT *Next_Pointer, *Stop_At;
{
if (Reloc_Debug)
{
while (Next_Pointer < Stop_At)
{
- switch (OBJECT_TYPE(*Next_Pointer))
+ switch (OBJECT_TYPE (*Next_Pointer))
{
case TC_MANIFEST_NM_VECTOR:
- Next_Pointer += (1 + Get_Integer(*Next_Pointer));
+ Next_Pointer += (1 + OBJECT_DATUM (*Next_Pointer));
break;
case TC_INTERNED_SYMBOL:
- if (OBJECT_TYPE(Vector_Ref(*Next_Pointer, SYMBOL_GLOBAL_VALUE)) ==
+ if (OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_GLOBAL_VALUE)) ==
TC_BROKEN_HEART)
{
- Pointer old_symbol = (*Next_Pointer);
- Vector_Set (old_symbol, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT);
+ SCHEME_OBJECT old_symbol = (*Next_Pointer);
+ MEMORY_SET (old_symbol, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT);
{
- extern Pointer intern_symbol ();
- Pointer new_symbol = (intern_symbol (old_symbol));
+ extern SCHEME_OBJECT intern_symbol ();
+ SCHEME_OBJECT new_symbol = (intern_symbol (old_symbol));
if (new_symbol != old_symbol)
{
(*Next_Pointer) = new_symbol;
- Vector_Set
+ MEMORY_SET
(old_symbol,
SYMBOL_NAME,
- (Make_New_Pointer (TC_BROKEN_HEART, new_symbol)));
+ (OBJECT_NEW_TYPE (TC_BROKEN_HEART, new_symbol)));
}
}
}
- else if (OBJECT_TYPE(Vector_Ref(*Next_Pointer, SYMBOL_NAME)) ==
+ else if (OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_NAME)) ==
TC_BROKEN_HEART)
{
*Next_Pointer =
- Make_New_Pointer(OBJECT_TYPE(*Next_Pointer),
- Fast_Vector_Ref(*Next_Pointer,
- SYMBOL_NAME));
+ (MAKE_OBJECT_FROM_OBJECTS
+ ((*Next_Pointer),
+ (FAST_MEMORY_REF ((*Next_Pointer), SYMBOL_NAME))));
}
Next_Pointer += 1;
break;
return;
}
\f
-Pointer
+SCHEME_OBJECT
load_file(from_band_load)
Boolean from_band_load;
{
- Pointer
- *Heap_End, *Orig_Heap,
+ SCHEME_OBJECT
+ *Orig_Heap,
*Constant_End, *Orig_Constant,
*temp, *primitive_table;
extern void install_primitive_table();
- extern Pointer *load_renumber_table;
+ extern SCHEME_OBJECT *load_renumber_table;
/* Read File */
load_renumber_table = Free;
Free += Primitive_Table_Length;
- Align_Float(Free);
+ ALIGN_FLOAT (Free);
Orig_Heap = Free;
Orig_Constant = Free_Constant;
primitive_table = read_file_end();
automagically: the utilities vector is part of the band.
*/
- if ((!band_p) && (dumped_utilities != NIL))
+ if ((!band_p) && (dumped_utilities != SHARP_F))
{
- extern Pointer compiler_utilities;
+ extern SCHEME_OBJECT compiler_utilities;
- if (compiler_utilities == NIL)
+ if (compiler_utilities == SHARP_F)
{
- Primitive_Error(ERR_FASLOAD_COMPILED_MISMATCH);
+ signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
}
- const_relocation = (((relocation_type) Get_Pointer(compiler_utilities)) -
- Datum(dumped_utilities));
+ const_relocation =
+ (((relocation_type) (OBJECT_ADDRESS (compiler_utilities))) -
+ (OBJECT_DATUM (dumped_utilities)));
Dumped_Constant_Top =
- C_To_Scheme(Nth_Vector_Loc(dumped_utilities,
- (1 + Vector_Length(compiler_utilities))));
+ (ADDRESS_TO_DATUM
+ (MEMORY_LOC (dumped_utilities,
+ (1 + (VECTOR_LENGTH (compiler_utilities))))));
}
else
{
#endif
/* Setup the primitive table */
-
+
install_primitive_table(primitive_table,
Primitive_Table_Length,
from_band_load);
if (Reloc_Debug)
{
printf("heap_relocation = %d = %x; const_relocation = %d = %x\n",
- heap_relocation, heap_relocation,
+ heap_relocation, heap_relocation,
const_relocation, const_relocation);
}
DEFINE_PRIMITIVE ("BINARY-FASLOAD", Prim_binary_fasload, 1, 1, 0)
{
long result;
- Primitive_1_Arg();
-
- result = read_file_start(Arg1);
+ PRIMITIVE_HEADER (1);
+ result = (read_file_start (ARG_REF (1)));
if (band_p)
- {
- Primitive_Error(ERR_FASLOAD_BAND);
- }
+ signal_error_from_primitive (ERR_FASLOAD_BAND);
if (result != PRIM_DONE)
- {
- if (result == PRIM_INTERRUPT)
{
- Primitive_Interrupt();
+ if (result == PRIM_INTERRUPT)
+ signal_interrupt_from_primitive ();
+ else
+ signal_error_from_primitive (result);
}
- else
- {
- Primitive_Error(result);
- }
- }
- PRIMITIVE_RETURN(load_file(false));
+ PRIMITIVE_RETURN (load_file (false));
}
/* Band loading. */
/* (RELOAD-BAND-NAME)
Returns the filename (as a Scheme string) from which the runtime system
- was band loaded (load-band'ed ?), or NIL if the system was fasl'ed.
+ was band loaded (load-band'ed ?), or #F if the system was fasl'ed.
*/
DEFINE_PRIMITIVE ("RELOAD-BAND-NAME", Prim_reload_band_name, 0, 0, 0)
{
- Primitive_0_Args();
-
- if (reload_band_name == NULL)
- {
- PRIMITIVE_RETURN(NIL);
- }
-
- PRIMITIVE_RETURN(C_String_To_Scheme_String(reload_band_name));
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN
+ ((reload_band_name == NULL)
+ ? SHARP_F
+ : (char_pointer_to_string (reload_band_name)));
}
/* Utility for load band below. */
extern void compiler_reset_error();
-void
+void
compiler_reset_error()
{
fprintf(stderr,
\f
DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0)
{
- extern char *malloc();
- extern strcpy(), free();
- extern void compiler_reset();
- extern Pointer compiler_utilities;
- static void terminate_band_load();
-
- jmp_buf
- swapped_buf,
- *saved_buf;
- Pointer
+ extern char * malloc ();
+ extern strcpy ();
+ extern free ();
+ extern void compiler_initialize ();
+ extern void compiler_reset ();
+ extern SCHEME_OBJECT compiler_utilities;
+ static void terminate_band_load ();
+ SCHEME_OBJECT
+ argument,
*saved_free,
*saved_memtop,
*saved_free_constant,
*saved_stack_pointer;
long temp, length;
- Pointer result, cutl;
+ SCHEME_OBJECT result, cutl;
char *band_name;
Boolean load_file_failed;
- Primitive_1_Arg();
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ argument = (ARG_REF (1));
saved_free = Free;
Free = Heap_Bottom;
saved_memtop = MemTop;
saved_stack_pointer = Stack_Pointer;
Stack_Pointer = Highest_Allocated_Address;
- temp = read_file_start(Arg1);
+ temp = (read_file_start (argument));
if (temp != PRIM_DONE)
{
Free = saved_free;
if (temp == PRIM_INTERRUPT)
{
- Primitive_Error(ERR_FASL_FILE_TOO_BIG);
+ signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG);
}
else
{
- Primitive_Error(temp);
+ signal_error_from_primitive (temp);
}
}
\f
/* Point of no return. */
- length = ((long) (Fast_Vector_Ref(Arg1, STRING_LENGTH)));
+ length = (STRING_LENGTH (argument));
band_name = malloc(length);
if (band_name != ((char *) NULL))
- {
- strcpy(band_name, Scheme_String_To_C_String(Arg1));
- }
+ strcpy (band_name, ((char *) (STRING_LOC (argument, 0))));
load_file_failed = true;
INITIALIZE_INTERRUPTS();
Initialize_Stack();
Set_Pure_Top();
- cutl = Vector_Ref(result, 1);
- if (cutl != NIL)
+ cutl = MEMORY_REF (result, 1);
+ if (cutl != SHARP_F)
{
compiler_utilities = cutl;
compiler_reset(cutl);
{
compiler_initialize(true);
}
- Restore_Fixed_Obj(NIL);
- Fluid_Bindings = NIL;
- Current_State_Point = NIL;
+ Restore_Fixed_Obj (SHARP_F);
+ Fluid_Bindings = EMPTY_LIST;
+ Current_State_Point = SHARP_F;
/* Setup initial program */
- Store_Return(RC_END_OF_COMPUTATION);
- Store_Expression(NIL);
- Save_Cont();
+ Store_Return (RC_END_OF_COMPUTATION);
+ Store_Expression (SHARP_F);
+ Save_Cont ();
\f
- Store_Expression(Vector_Ref(result, 0));
- Store_Env(Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL));
+ Store_Expression(MEMORY_REF (result, 0));
+ Store_Env(MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL));
/* Clear various interpreter state parameters. */
Trapping = false;
Return_Hook_Address = NULL;
History = Make_Dummy_History();
- Prev_Restore_History_Stacklet = NIL;
+ Prev_Restore_History_Stacklet = SHARP_F;
Prev_Restore_History_Offset = 0;
end_band_load(true, false);
#define MAGIC_OFFSET (TC_FIXNUM + 1)
-Pointer String_Chain, Last_String;
+SCHEME_OBJECT String_Chain, Last_String;
Setup_For_String_Inversion()
{
- String_Chain = NIL;
- Last_String = NIL;
+ String_Chain = SHARP_F;
+ Last_String = SHARP_F;
return;
}
{
if (Byte_Invert_Fasl_Files)
{
- while (String_Chain != NIL)
+ while (String_Chain != SHARP_F)
{
long Count;
- Pointer Next;
+ SCHEME_OBJECT Next;
- Count = Get_Integer(Fast_Vector_Ref(String_Chain, STRING_HEADER));
- Count = 4*(Count-2)+OBJECT_TYPE(String_Chain)-MAGIC_OFFSET;
+ Count = OBJECT_DATUM (FAST_MEMORY_REF (String_Chain, STRING_HEADER));
+ Count = 4*(Count-2)+OBJECT_TYPE (String_Chain)-MAGIC_OFFSET;
if (Reloc_Debug)
{
printf("String at 0x%x: restoring length of %d.\n",
- Address(String_Chain), Count);
+ OBJECT_ADDRESS (String_Chain), Count);
}
- Next = Fast_Vector_Ref(String_Chain, STRING_LENGTH);
- Fast_Vector_Set(String_Chain, STRING_LENGTH, ((Pointer) (Count)));
+ Next = (STRING_LENGTH (String_Chain));
+ SET_STRING_LENGTH (String_Chain, Count);
String_Chain = Next;
}
}
"\\%03o" : "%c", (C && MAX_CHAR));
String_Inversion(Orig_Pointer)
- Pointer *Orig_Pointer;
+ SCHEME_OBJECT *Orig_Pointer;
{
- Pointer *Pointer_Address;
+ SCHEME_OBJECT *Pointer_Address;
char *To_Char;
long Code;
return;
}
- Code = OBJECT_TYPE(Orig_Pointer[STRING_LENGTH]);
+ Code = OBJECT_TYPE (Orig_Pointer[STRING_LENGTH_INDEX]);
if (Code == 0) /* Already reversed? */
{
long Count, old_size, new_size, i;
- old_size = Get_Integer(Orig_Pointer[STRING_HEADER]);
- new_size =
- 2 + (((long) (Orig_Pointer[STRING_LENGTH]))) / 4;
+ old_size = OBJECT_DATUM (Orig_Pointer[STRING_HEADER]);
+ new_size =
+ 2 + (((long) (Orig_Pointer[STRING_LENGTH_INDEX]))) / 4;
if (Reloc_Debug)
{
printf("\nString at 0x%x with %d characters",
Orig_Pointer,
- ((long) (Orig_Pointer[STRING_LENGTH])));
+ ((long) (Orig_Pointer[STRING_LENGTH_INDEX])));
}
if (old_size != new_size)
Microcode_Termination(TERM_EXIT);
}
- Count = ((long) (Orig_Pointer[STRING_LENGTH])) % 4;
+ Count = ((long) (Orig_Pointer[STRING_LENGTH_INDEX])) % 4;
if (Count == 0)
{
Count = 4;
}
- if (Last_String == NIL)
+ if (Last_String == SHARP_F)
{
- String_Chain = Make_Pointer(Count + MAGIC_OFFSET, Orig_Pointer);
+ String_Chain = MAKE_POINTER_OBJECT (Count + MAGIC_OFFSET, Orig_Pointer);
}
else
{
- Fast_Vector_Set(Last_String, STRING_LENGTH,
- Make_Pointer(Count + MAGIC_OFFSET, Orig_Pointer));
+ FAST_MEMORY_SET
+ (Last_String, STRING_LENGTH_INDEX,
+ MAKE_POINTER_OBJECT (Count + MAGIC_OFFSET, Orig_Pointer));
}
\f
- Last_String = Make_Pointer(TC_NULL, Orig_Pointer);
- Orig_Pointer[STRING_LENGTH] = NIL;
- Count = Get_Integer(Orig_Pointer[STRING_HEADER]) - 1;
- if (Reloc_Debug)
+ Last_String = MAKE_POINTER_OBJECT (TC_NULL, Orig_Pointer);
+ Orig_Pointer[STRING_LENGTH_INDEX] = SHARP_F;
+ Count = OBJECT_DATUM (Orig_Pointer[STRING_HEADER]) - 1;
+ if (Reloc_Debug)
{
printf("\nCell count=%d\n", Count);
}
{
int C1, C2, C3, C4;
- C4 = OBJECT_TYPE(*Pointer_Address) & 0xFF;
+ C4 = OBJECT_TYPE (*Pointer_Address) & 0xFF;
C3 = (((long) *Pointer_Address)>>16) & 0xFF;
C2 = (((long) *Pointer_Address)>>8) & 0xFF;
C1 = ((long) *Pointer_Address) & 0xFF;
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/fft.c,v 9.27 1989/09/20 23:08:09 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/fft.c,v 9.26 1989/06/22 21:52:02 pas Rel $ */
-
/* Time-Frequency Transforms (pas) */
#include "scheme.h"
#include "prims.h"
-#include "flonum.h"
-#include "zones.h"
+#include "zones.h"
#include <math.h>
#include "array.h"
#include "image.h"
-
-/* SUMMARY
+\f
+/* SUMMARY
- pas_cft (complex data, DIF, split-radix)
- - pas_rft (real data, DIT, split-radix) output is conjugate-symmetric
+ - pas_rft (real data, DIT, split-radix) output is conjugate-symmetric
- pas_csft (cs data, DIF, split-radix) output is real
- pas_cft
- pas_rft2d
- pas_csft2d
-
+
Stuff before 4-15-1989
- C_Array_FFT (complex data, radix=2, NOT-in-place)
- 2d DFT
*/
-/* The DFT is as defined in Siebert 6003 book,
- i.e.
+/* The DFT is as defined in Siebert 6003 book,
+ i.e.
forward DFT = Negative exponent and division by N
backward DFT = Positive exponent
(note Seibert forward DFT is Oppenheim backward DFT)
#define SQRT_2 1.4142135623730950488
#define ONE_OVER_SQRT_2 .7071067811865475244
/* Abramowitz and Stegun */
-
-
-
+\f
DEFINE_PRIMITIVE ("PAS-CFT!", Prim_pas_cft, 5, 5, 0)
{ long i, length, power, flag;
REAL *f1,*f2, *wcos,*w3cos,*w3sin;
void pas_cft();
PRIMITIVE_HEADER (5);
- CHECK_ARG (1, FIXNUM_P); /* flag forward-backward */
CHECK_ARG (2, ARRAY_P); /* real part */
CHECK_ARG (3, ARRAY_P); /* imag part */
CHECK_ARG (4, ARRAY_P); /* twiddle tables, total length = 3*(length/4) */
CHECK_ARG (5, FIXNUM_P); /* (1)=tables precomputed, else recompute */
-
- flag = Get_Integer(ARG_REF(1));
- length = Array_Length(ARG_REF(2));
- if (length != (Array_Length(ARG_REF(3)))) error_bad_range_arg(2);
- for (power=0, i=length; i>1; power++)
+ flag = (arg_nonnegative_integer (1));
+ length = ARRAY_LENGTH(ARG_REF(2));
+ if (length != (ARRAY_LENGTH(ARG_REF(3)))) error_bad_range_arg(2);
+
+ for (power=0, i=length; i>1; power++)
{ if ( (i % 2) == 1) error_bad_range_arg(2);
i=i/2; }
-
- f1 = Scheme_Array_To_C_Array(ARG_REF(2));
- f2 = Scheme_Array_To_C_Array(ARG_REF(3));
+
+ f1 = ARRAY_CONTENTS(ARG_REF(2));
+ f2 = ARRAY_CONTENTS(ARG_REF(3));
if (f1==f2) error_wrong_type_arg(2);
-
- wcos = Scheme_Array_To_C_Array(ARG_REF(4)); /* twiddle tables */
- if (Array_Length(ARG_REF(4)) != (3*length/4)) error_bad_range_arg(4);
+
+ wcos = ARRAY_CONTENTS(ARG_REF(4)); /* twiddle tables */
+ if (ARRAY_LENGTH(ARG_REF(4)) != (3*length/4)) error_bad_range_arg(4);
w3cos = wcos + length/4;
w3sin = w3cos + length/4;
if ((arg_nonnegative_integer(5)) == 1)
pas_cft(1, flag, f1,f2, length, power, wcos,w3cos,w3sin);
- else
+ else
pas_cft(0, flag, f1,f2, length, power, wcos,w3cos,w3sin);
/* 1 means tables are already made
0 means compute new tables */
-
-
- PRIMITIVE_RETURN (NIL);
+
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("PAS-CFT-MAKE-TWIDDLE-TABLES!",
REAL *wcos,*w3cos,*w3sin;
void pas_cft_make_twiddle_tables_once();
PRIMITIVE_HEADER (2);
-
+
length = arg_nonnegative_integer(1); /* length of cft that we intend to compute */
CHECK_ARG (2, ARRAY_P); /* storage for twiddle tables */
- if (Array_Length(ARG_REF(2)) != (3*length/4)) error_bad_range_arg(2);
-
+ if (ARRAY_LENGTH(ARG_REF(2)) != (3*length/4)) error_bad_range_arg(2);
+
power=0;
- for (power=0, i=length; i>1; power++)
- { if ( (i % 2) == 1) error_bad_range_arg(1);
+ for (power=0, i=length; i>1; power++)
+ { if ( (i % 2) == 1) error_bad_range_arg(1);
i=i/2; }
-
- wcos = Scheme_Array_To_C_Array(ARG_REF(2)); /* twiddle tables */
+
+ wcos = ARRAY_CONTENTS(ARG_REF(2)); /* twiddle tables */
w3cos = wcos + length/4;
w3sin = w3cos + length/4;
pas_cft_make_twiddle_tables_once(length, power, wcos,w3cos,w3sin);
-
- PRIMITIVE_RETURN (NIL);
-}
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
-/*
+/*
C COMPLEX FOURIER TRANSFORM (Split-Radix, Decimation-in-frequency)
C (adapted and optimized from Sorensen,et.al. ASSP-34 no.1 page 152, February 1986)
*/
/* Twiddle Tables for PAS_CFT;
- (tables for forward transform only)
+ (tables for forward transform only)
Inverse transform === forward CFT (without 1/N scaling) followed by time-reversal.
/
- The tables contain (2pi/N)*i for i=0,1,2,..,N/4
+ The tables contain (2pi/N)*i for i=0,1,2,..,N/4
(except i=0 is ignored, never used)
/
Table for wsin[i] is not needed because wsin[i]=wcos[n4-i].
Table for w3sin[i] is needed however. The previous relationship does not work for w3sin.
- */
+ */
/* There are two routines for making twiddle tables:
a fast one, and a slower one but more precise.
Use the slow one for making permanent tables.
*/
-void pas_cft_make_twiddle_tables(n,m, wcos,w3cos,w3sin) /* efficient version */
+void
+pas_cft_make_twiddle_tables (n,m, wcos,w3cos,w3sin) /* efficient version */
REAL *wcos, *w3cos, *w3sin;
long n,m;
{ long i, n4;
n4 = n/4;
for (i=1; i<n4; i++) /* start from table entry 1 */
{ tm = 6.283185307179586476925287 * (((double) i) / ((double) n));
- wcos[i] = (REAL) cos(tm);
+ wcos[i] = (REAL) cos(tm);
}
for (i=1; i<n4; i++)
{ costm = wcos[i];
sintm = wcos[n4-i];
w3cos[i] = costm * (1 - 4*sintm*sintm); /* see my notes */
- w3sin[i] = sintm * (4*costm*costm - 1);
+ w3sin[i] = sintm * (4*costm*costm - 1);
}
}
-void pas_cft_make_twiddle_tables_once(n,m, wcos,w3cos,w3sin) /* slow version, more accurate */
+void
+pas_cft_make_twiddle_tables_once (n,m, wcos,w3cos,w3sin) /* slow version, more accurate */
REAL *wcos, *w3cos, *w3sin;
long n,m;
{ long i, n4;
n4 = n/4;
for (i=1; i<n4; i++) /* start from table entry 1 */
{ tm = 6.283185307179586476925287 * (((double) i) / ((double) n));
- wcos[i] = (REAL) cos(tm);
+ wcos[i] = (REAL) cos(tm);
tm = tm * 3.0; /* this is more precise (in the 16th decimal) than */
w3cos[i] = (REAL) cos(tm); /* the more efficient version. (I tested by for/backward) */
- w3sin[i] = (REAL) sin(tm);
+ w3sin[i] = (REAL) sin(tm);
}
}
-void pas_cft(tables_ok,flag, x,y,n,m, wcos,w3cos,w3sin)
+void
+pas_cft (tables_ok,flag, x,y,n,m, wcos,w3cos,w3sin)
REAL *x,*y, *wcos,*w3cos,*w3sin;
long n,m, flag, tables_ok;
{ REAL scale;
if (tables_ok != 1) /* 1 means = tables already made */
pas_cft_make_twiddle_tables(n,m, wcos,w3cos,w3sin);
-
+
if (flag == 1) /* forward cft */
{ pas_cft_forward_loop(x,y,n,m, wcos,w3cos,w3sin);
scale = (REAL) (1.0 / ((double) n));
}
}
-void pas_cft_forward_loop(x,y,n,m, wcos,w3cos,w3sin) /* n >= 4 */
+void
+pas_cft_forward_loop (x,y,n,m, wcos,w3cos,w3sin) /* n >= 4 */
REAL *x,*y, *wcos,*w3cos,*w3sin;
long n,m;
{ /* REAL a,a3,e; no need anymore, use tables */
- REAL r1,r2,s1,s2,s3, xt, cc1,cc3,ss1,ss3;
+ REAL r1,r2,s1,s2,s3, xt, cc1,cc3,ss1,ss3;
long n1,n2,n4, i,j,k, is,id, i0,i1,i2,i3;
long windex0, windex, windex_n4; /* indices for twiddle tables */
/********** fortran indices start from 1,... **/
- x = x-1; /* TRICK---- x(0) is now illegal, but x(1) and x(n) are valid */
+ x = x-1; /* TRICK---- x(0) is now illegal, but x(1) and x(n) are valid */
y = y-1;
/********** fortran indices start from 1,... **/
/* c */
y[i2] = s2; /* used to be y[i2] = (-s2); */
x[i3] = s3;
y[i3] = r2;
- /* x[i2] = r1*cc1 + s2*ss1; used to be, see below
+ /* x[i2] = r1*cc1 + s2*ss1; used to be, see below
y[i2] = s2*cc1 - r1*ss1; used to be, see below, inside the DO 20 J=1,N4
x[i3] = s3*cc3 + r2*ss3;
y[i3] = r2*cc3 - s3*ss3; */
cc1 = cos(a);
ss1 = sin(a);
cc3 = cos(a3);
- ss3 = sin(a3);
+ ss3 = sin(a3);
a = j*e;*/
is = j;
id = 2*n2;
if (is < n) goto label40; /* IF (IS.LT.N) GOTO 40 */
} /* 20 CONTINUE */
} /* 10 CONTINUE */
- /* c
+ /* c
c-----------last-stage, length-2 butterfly ----------------c
c */
is = 1;
is = 2*id - 1;
id = 4*id;
if (is < n) goto label50; /* IF (IS.LT.N) GOTO 50 */
- /*
- c
+ /*
+ c
c-----------bit-reverse-counter---------------c
*/
label100:
/* c-------------------------------------*/
/* c */
} /* RETURN \r END */
-
-
\f
DEFINE_PRIMITIVE ("PAS-RFT-CSFT!", Prim_pas_rft_csft, 5, 5, 0)
{ long i, length, power, flag, ft_type;
REAL *f1, *wcos,*w3cos,*w3sin;
void pas_rft(), pas_csft();
PRIMITIVE_HEADER (5);
- CHECK_ARG (1, FIXNUM_P); /* flag 1=forward, else backward transform */
CHECK_ARG (2, ARRAY_P); /* Input data (real or cs) */
CHECK_ARG (3, ARRAY_P); /* Twiddle tables, total length = 4*(length/8) */
CHECK_ARG (4, FIXNUM_P); /* (1)=tables precomputed, else recompute */
CHECK_ARG (5, FIXNUM_P); /* ft_type = 1 or 3
1 means compute rft, 3 means compute csft */
- flag = Get_Integer(ARG_REF(1));
- f1 = Scheme_Array_To_C_Array(ARG_REF(2));
- length = Array_Length(ARG_REF(2));
- for (power=0, i=length; i>1; power++)
+ flag = (arg_nonnegative_integer (1));
+ f1 = ARRAY_CONTENTS(ARG_REF(2));
+ length = ARRAY_LENGTH(ARG_REF(2));
+ for (power=0, i=length; i>1; power++)
{ if ( (i % 2) == 1) error_bad_range_arg(2);
i=i/2; }
-
- wcos = Scheme_Array_To_C_Array(ARG_REF(3)); /* twiddle tables */
- if (Array_Length(ARG_REF(3)) != (4*length/8)) error_bad_range_arg(3);
+
+ wcos = ARRAY_CONTENTS(ARG_REF(3)); /* twiddle tables */
+ if (ARRAY_LENGTH(ARG_REF(3)) != (4*length/8)) error_bad_range_arg(3);
w3cos = wcos + (length/4);
w3sin = w3cos + (length/8);
-
+
ft_type = (arg_nonnegative_integer(5)); /* rft or csft */
if (ft_type == 1) {
if ((arg_nonnegative_integer(4)) == 1)
pas_csft (1, flag, f1, length, power, wcos,w3cos,w3sin);
else pas_csft (0, flag, f1, length, power, wcos,w3cos,w3sin);
/* 1 means tables are already made
- 0 means compute new tables */
+ 0 means compute new tables */
}
else error_bad_range_arg(5);
-
- PRIMITIVE_RETURN (NIL);
+
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("PAS-REALDATA-MAKE-TWIDDLE-TABLES!",
REAL *wcos,*w3cos,*w3sin;
void pas_realdata_make_twiddle_tables_once();
PRIMITIVE_HEADER (2);
-
+
length = arg_nonnegative_integer(1); /* length of rft that we intend to compute */
CHECK_ARG (2, ARRAY_P); /* storage for twiddle tables */
- if (Array_Length(ARG_REF(2)) != (4*length/8)) error_bad_range_arg(2);
-
+ if (ARRAY_LENGTH(ARG_REF(2)) != (4*length/8)) error_bad_range_arg(2);
+
power=0;
- for (power=0, i=length; i>1; power++)
- { if ( (i % 2) == 1) error_bad_range_arg(1);
+ for (power=0, i=length; i>1; power++)
+ { if ( (i % 2) == 1) error_bad_range_arg(1);
i=i/2; }
-
- wcos = Scheme_Array_To_C_Array(ARG_REF(2)); /* twiddle tables */
+
+ wcos = ARRAY_CONTENTS(ARG_REF(2)); /* twiddle tables */
w3cos = wcos + length/4;
w3sin = w3cos + length/8;
pas_realdata_make_twiddle_tables_once(length, power, wcos,w3cos,w3sin);
-
- PRIMITIVE_RETURN (NIL);
+
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-/*
+/*
C REAL FOURIER TRANSFORM (Split-Radix, Decimation-in-time)
C (adapted from Sorensen,et.al. ASSP-35 no.6 page 849, October 1986)
- C
+ C
C the output is [Re(0),Re(1),...,Re(n/2), Im(n/2-1),...,Im(1)]
*/
/
Table for wsin[i] is not needed because wsin[i]=wcos[n4-i].
Table for w3sin[i] is needed however. The previous relationship does not work for w3sin.
- /
+ /
Instead of getting sin() from a wsin[i] table with i=1,..,N/8
we get it from wcos[n4-i].
This way we can use a CFT table which goes up to N/4
n8 = n/8;
for (i=1; i<n4; i++) /* start from table entry 1 */
{ tm = 6.283185307179586476925287 * (((double) i) / ((double) n));
- wcos[i] = (REAL) cos(tm);
+ wcos[i] = (REAL) cos(tm);
}
for (i=1; i<n8; i++)
{ costm = wcos[i];
sintm = wcos[n4-i];
w3cos[i] = costm * (1 - 4*sintm*sintm); /* see my notes */
- w3sin[i] = sintm * (4*costm*costm - 1);
+ w3sin[i] = sintm * (4*costm*costm - 1);
}
}
n8 = n/8;
for (i=1; i<n8; i++) /* start from table entry 1 */
{ tm = 6.283185307179586476925287 * (((double) i) / ((double) n));
- wcos[i] = (REAL) cos(tm);
+ wcos[i] = (REAL) cos(tm);
tm = tm * 3.0; /* this is more precise (in the 16th decimal) than */
w3cos[i] = (REAL) cos(tm); /* the more efficient version. (I tested by for/backward) */
- w3sin[i] = (REAL) sin(tm);
+ w3sin[i] = (REAL) sin(tm);
}
for (i=n8; i<n4; i++)
{ tm = 6.283185307179586476925287 * (((double) i) / ((double) n));
void pas_rft(tables_ok,flag, x,n,m, wcos,w3cos,w3sin)
REAL *x, *wcos,*w3cos,*w3sin;
- long n,m, flag, tables_ok;
+ long n,m, flag, tables_ok;
{ REAL scale;
long i;
void pas_realdata_make_twiddle_tables();
void pas_rft_forward_loop();
-
+
if (tables_ok != 1) /* 1 means = tables already made */
pas_realdata_make_twiddle_tables(n,m, wcos,w3cos,w3sin);
-
+
pas_rft_forward_loop(x,n,m, wcos,w3cos,w3sin);
-
+
if (flag == 1) /* forward rft */
{ scale = (REAL) (1.0 / ((double) n));
for (i=0; i<n; i++) x[i] = x[i] * scale; }
*/
/* wcos must be length n/4
- w3cos, w3sin must be length n/8
+ w3cos, w3sin must be length n/8
(greater than n/8 is fine also, e.g. use cft tables)
*/
long n1,n2,n4,n8, i,j,k, is,id, i0,i1,i2,i3,i4,i5,i6,i7,i8;
long windex0, windex, windex_n4; /* indices for twiddle tables */
/********** fortran indices start from 1,... **/
- x = x-1; /* TRICK---- x(0) is now illegal, but x(1) and x(n) are valid */
+ x = x-1; /* TRICK---- x(0) is now illegal, but x(1) and x(n) are valid */
/********** fortran indices start from 1,... **/
/* c */
windex_n4 = n/4; /* need for indexing sin via wcos twiddle table */
- /* c
+ /* c
c-----------bit-reverse-counter---------------c
*/
label100:
/* c ----length-two-butterflies----------- */
is = 1;
id = 4;
- label70:
+ label70:
for (i0=is; i0<=n; i0=i0+id) /* 70 DO 60 I0 = IS,N,ID */
{ i1 = i0 + 1;
r1 = x[i0];
x[i0] = r1 + x[i1];
- x[i1] = r1 - x[i1];
+ x[i1] = r1 - x[i1];
} /* 60 CONTINUE */
is = 2*id - 1;
id = 4*id;
x[i1] = x[i1] + t2;
label38: /* 38 CONTINUE */
;
- }
+ }
is = 2*id - n2;
id = 4*id;
if (is < n) goto label40; /* IF (IS.LT.N) GOTO 40 */
cc3 = w3cos[windex];
ss3 = w3sin[windex]; /* sin-from-cos trick does not work here */
windex = j*windex0; /* same trick as "a = j*e" */
- /* a3 = 3*a;
+ /* a3 = 3*a;
cc1 = cos(a);
ss1 = sin(a);
cc3 = cos(a3);
- ss3 = sin(a3);
+ ss3 = sin(a3);
a = j*e;*/
is = 0;
id = 2*n2;
} /* RETURN \r END */
-/*
+/*
C CONJUGATE SYMMETRIC FOURIER TRANSFORM (Split-Radix, Decimation-in-time)
C (adapted from Sorensen,et.al. ASSP-35 no.6 page 849, October 1986)
- C
+ C
C input is [Re(0),Re(1),...,Re(n/2), Im(n/2-1),...,Im(1)]
C output is real
*/
-
+
/* twiddle tables identical with rft
for comments see rft */
void pas_csft(tables_ok,flag, x,n,m, wcos,w3cos,w3sin)
REAL *x, *wcos,*w3cos,*w3sin;
- long n,m, flag, tables_ok;
+ long n,m, flag, tables_ok;
{ REAL scale;
long i,n2;
void pas_realdata_make_twiddle_tables();
if (tables_ok != 1) /* 1 means = tables already made */
pas_realdata_make_twiddle_tables(n,m, wcos,w3cos,w3sin);
-
+
if (flag == 1) /* forward csft */
{ n2 = n/2;
scale = (REAL) (1.0 / ((double) n));
- for (i=0; i<=n2; i++) x[i] = x[i]*scale;
+ for (i=0; i<=n2; i++) x[i] = x[i]*scale;
scale = (-scale);
for (i=n2+1; i<n; i++) x[i] = x[i]*scale; /* scale and conjugate cs-array */
pas_csft_backward_loop(x,n,m, wcos,w3cos,w3sin);
*/
/* wcos must be length n/4
- w3cos, w3sin must be length n/8
+ w3cos, w3sin must be length n/8
(greater than n/8 is fine also, e.g. use cft tables)
*/
long n1,n2,n4,n8, i,j,k, is,id, i0,i1,i2,i3,i4,i5,i6,i7,i8;
long windex0, windex, windex_n4; /* indices for twiddle tables */
/********** fortran indices start from 1,... **/
- x = x-1; /* TRICK---- x(0) is now illegal, but x(1) and x(n) are valid */
+ x = x-1; /* TRICK---- x(0) is now illegal, but x(1) and x(n) are valid */
/********** fortran indices start from 1,... **/
/* c */
windex_n4 = n/4; /* need for indexing sin via wcos twiddle table */
t2 = (x[i4] + x[i3])/sqrt(2.0); */
x[i1] = x[i1] + x[i2];
x[i2] = x[i4] - x[i3];
- x[i3] = 2 * (t2-t1); /* x[i3] = 2 * (-t2-t1); */
+ x[i3] = 2 * (t2-t1); /* x[i3] = 2 * (-t2-t1); */
x[i4] = 2 * (t2+t1); /* x[i4] = 2 * (-t2+t1); */
label15:
;
windex0 = 1<<(k-1); /* see my notes */
windex = windex0;
for (j=2; j<=n8; j++) /* do 20 j=2,n8 */
- {
+ {
/* windex = (j-1)*(1<<(k-1)); -- done with trick to avoid (j-1) and 1<<(k-1) */
cc1 = wcos[windex];
ss1 = wcos[windex_n4 - windex]; /* sin-from-cos trick: see my notes */
/* c ----length-two-butterflies----------- */
is = 1;
id = 4;
- label70:
+ label70:
for (i0=is; i0<=n; i0=i0+id) /* 70 DO 60 I0 = IS,N,ID */
{ i1 = i0 + 1;
r1 = x[i0];
x[i0] = r1 + x[i1];
- x[i1] = r1 - x[i1];
+ x[i1] = r1 - x[i1];
} /* 60 CONTINUE */
is = 2*id - 1;
id = 4*id;
if (is < n) goto label70; /* IF (IS.LT.N) GOTO 70 */
/* c */
/* c-----------bit-reverse-counter---------------c */
- label100:
+ label100:
j = 1;
n1 = n - 1;
for (i=1; i<=n1; i++) /* DO 104 I = 1, N1 */
REAL *f1,*f2, *wcos,*w3cos,*w3sin;
void pas_cft2d();
PRIMITIVE_HEADER (5);
- CHECK_ARG (1, FIXNUM_P); /* flag forward-backward */
CHECK_ARG (2, ARRAY_P); /* real part */
CHECK_ARG (3, ARRAY_P); /* imag part */
CHECK_ARG (4, ARRAY_P); /* twiddle tables, length = 3*(rows/4) */
- CHECK_ARG (5, FIXNUM_P); /* (1)=tables precomputed, else recompute */
-
- flag = Get_Integer(ARG_REF(1));
- length = Array_Length(ARG_REF(2));
- if (length != (Array_Length(ARG_REF(3)))) error_bad_range_arg(2);
-
+
+ flag = (arg_nonnegative_integer (1));
+ length = ARRAY_LENGTH(ARG_REF(2));
+ if (length != (ARRAY_LENGTH(ARG_REF(3)))) error_bad_range_arg(2);
+
for (power=0, i=length; i>1; power++) /* length must be power of 2 */
{ if ( (i % 2) == 1) error_bad_range_arg(2);
i=i/2; }
-
+
if ((power % 2) == 1) error_bad_range_arg(2);
rowpower = (power/2);
rows = (1<<rowpower); /* square image */
-
- f1 = Scheme_Array_To_C_Array(ARG_REF(2));
- f2 = Scheme_Array_To_C_Array(ARG_REF(3));
+
+ f1 = ARRAY_CONTENTS(ARG_REF(2));
+ f2 = ARRAY_CONTENTS(ARG_REF(3));
if (f1==f2) error_wrong_type_arg(2);
-
- wcos = Scheme_Array_To_C_Array(ARG_REF(4)); /* twiddle tables */
- if (Array_Length(ARG_REF(4)) != (3*rows/4)) error_bad_range_arg(4);
+
+ wcos = ARRAY_CONTENTS(ARG_REF(4)); /* twiddle tables */
+ if (ARRAY_LENGTH(ARG_REF(4)) != (3*rows/4)) error_bad_range_arg(4);
w3cos = wcos + rows/4;
w3sin = w3cos + rows/4;
if ((arg_nonnegative_integer(5)) == 1)
pas_cft2d(1, flag, f1,f2, rows, rowpower, wcos,w3cos,w3sin);
- else
+ else
pas_cft2d(0, flag, f1,f2, rows, rowpower, wcos,w3cos,w3sin);
/* 1 means tables are already made
0 means compute new tables */
-
- PRIMITIVE_RETURN (NIL);
+
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
/* pas_cft2d
- n = rows of square image, rows is power of 2
- m = rowpower
- Scaling (1/n) is done all-at-once at the end.
+ n = rows of square image, rows is power of 2
+ m = rowpower
+ Scaling (1/n) is done all-at-once at the end.
Time-Reversing is done intermediately, it is more efficient.
*/
void pas_cft2d(tables_ok,flag, x,y,n,m, wcos,w3cos,w3sin)
REAL *x,*y, *wcos,*w3cos,*w3sin;
long n,m, flag, tables_ok;
{ REAL scale, *xrow,*yrow;
- long i,j, rows,cols, total_length;
+ long i,j, rows,cols, total_length;
void pas_cft_make_twiddle_tables_once();
void C_Array_Time_Reverse();
void pas_cft_forward_loop();
rows = n;
cols = rows; /* square image */
total_length = rows*rows;
-
+
if (flag != 1) /* backward transform */
for (i=0; i<total_length; i++) y[i] = (-y[i]); /* conjugate before */
-
+
xrow = x; yrow = y; /* ROW-WISE */
for (i=0; i<rows; i++) /* forward or backward */
{ pas_cft_forward_loop( xrow,yrow, n,m, wcos,w3cos,w3sin);
xrow = xrow + cols;
yrow = yrow + cols; }
-
+
Image_Fast_Transpose(x, rows); /* COLUMN-WISE */
Image_Fast_Transpose(y, rows);
xrow = x; yrow = y;
Image_Fast_Transpose(x, rows);
Image_Fast_Transpose(y, rows);
-
+
if (flag == 1) /* forward : scale */
{ scale = (REAL) (1.0 / ((double) total_length));
for (i=0; i<total_length; i++)
REAL *f1, *wcos,*w3cos,*w3sin;
void pas_rft2d(), pas_csft2d();
PRIMITIVE_HEADER (5);
- CHECK_ARG (1, FIXNUM_P); /* flag 1=forward, else backward transform */
CHECK_ARG (2, ARRAY_P); /* Input data (real or cs) */
CHECK_ARG (3, ARRAY_P); /* CFT twiddle tables, length = 3*(rows/4) */
CHECK_ARG (4, FIXNUM_P); /* (1)=tables precomputed, else recompute */
- CHECK_ARG (5, FIXNUM_P); /* ft_type = 1 or 3
- 1 means rft, 3 means csft */
- flag = Get_Integer(ARG_REF(1));
- f1 = Scheme_Array_To_C_Array(ARG_REF(2));
- length = Array_Length(ARG_REF(2));
+ flag = (arg_nonnegative_integer (1));
+ f1 = ARRAY_CONTENTS(ARG_REF(2));
+ length = ARRAY_LENGTH(ARG_REF(2));
for (power=0, i=length; i>1; power++) /* length must be power of 2 */
{ if ( (i % 2) == 1) error_bad_range_arg(2);
i=i/2; }
-
+
if ((power % 2) == 1) error_bad_range_arg(2);
rowpower = (power/2);
rows = (1<<rowpower); /* square image */
-
- wcos = Scheme_Array_To_C_Array(ARG_REF(3)); /* CFT twiddle tables */
- if (Array_Length(ARG_REF(3)) != (3*rows/4)) error_bad_range_arg(3);
+
+ wcos = ARRAY_CONTENTS(ARG_REF(3)); /* CFT twiddle tables */
+ if (ARRAY_LENGTH(ARG_REF(3)) != (3*rows/4)) error_bad_range_arg(3);
w3cos = wcos + rows/4;
w3sin = w3cos + rows/4;
-
+
ft_type = (arg_nonnegative_integer(5)); /* rft2d or csft2d */
if (ft_type == 1) {
if ((arg_nonnegative_integer(4)) == 1)
pas_csft2d (1, flag, f1, rows, rowpower, wcos,w3cos,w3sin);
else pas_csft2d (0, flag, f1, rows, rowpower, wcos,w3cos,w3sin);
/* 1 means tables are already made
- 0 means compute new tables */
+ 0 means compute new tables */
}
else error_bad_range_arg(5);
-
- PRIMITIVE_RETURN (NIL);
+
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-/* c RFT2D CSFT2D
+/* c RFT2D CSFT2D
The frequencies are scrabled wrt what cft2d (and the old image-fft) give.
See cs-image-magnitude and cs-image-real which unscrable automatically.
c
*/
/* pas_rft2d
- n = rows of square image, rows is power of 2
- m = rowpower
- Scaling (1/n) is done all-at-once at the end.
+ n = rows of square image, rows is power of 2
+ m = rowpower
+ Scaling (1/n) is done all-at-once at the end.
Time-Reversing is done intermediately, it is more efficient.
*/
void pas_rft2d(tables_ok,flag, x, n,m, wcos,w3cos,w3sin)
void pas_cft_make_twiddle_tables_once();
void C_Array_Time_Reverse();
void pas_rft_forward_loop(), pas_cft_forward_loop();
-
+
if (tables_ok != 1) /* 1 means = tables already made */
pas_cft_make_twiddle_tables_once(n,m, wcos,w3cos,w3sin);
-
+
rows = n;
cols = rows; /* square image */
n2 = n/2;
total_length = rows*rows;
-
+
xrow = x; /* First ROW-WISE */
if (flag == 1) /* forward transform */
for (i=0; i<rows; i++)
{ pas_rft_forward_loop(xrow, n,m, wcos,w3cos,w3sin);
for (j=n2+1; j<n; j++) xrow[j] = (-xrow[j]); /* time-reverse cs-array */
xrow = xrow + cols; }
-
+
Image_Fast_Transpose(x, rows); /* COLUMN-WISE */
-
+
/* TREAT specially rows 0 and n2,
they are real and go into cs-arrays */
if (flag == 1) /* forward transform */
pas_rft_forward_loop(xrow, n,m, wcos,w3cos,w3sin);
for (j=n2+1; j<n; j++) xrow[j] = (-xrow[j]); /* time-reverse cs-array */
xrow = x + n2*cols;
- pas_rft_forward_loop(xrow, n,m, wcos,w3cos,w3sin);
+ pas_rft_forward_loop(xrow, n,m, wcos,w3cos,w3sin);
for (j=n2+1; j<n; j++) xrow[j] = (-xrow[j]); /* time-reverse cs-array */
}
-
- /* TREAT the rest of the rows with CFT
+
+ /* TREAT the rest of the rows with CFT
*/
if (flag != 1) /* backward : conjugate before */
for (i=(n2+1)*cols; i<total_length; i++) x[i] = (-x[i]);
-
+
xrow = x + cols; /* real part */
yrow = x + (rows-1)*cols; /* imag part */
for (i=1; i<n2; i++) /* forward or backward transform */
{ pas_cft_forward_loop(xrow,yrow, n,m, wcos,w3cos,w3sin);
- xrow = xrow + cols;
+ xrow = xrow + cols;
yrow = yrow - cols; }
/* DO NOT TRANSPOSE BACK, leave real-imag in horizontal rows, save.
*/
-
+
if (flag == 1) /* forward : scale */
{ scale = (REAL) (1.0 / ((double) total_length));
for (i=0; i<total_length; i++)
/* pas_csft2d
- n = rows of square image, rows is power of 2
- m = rowpower
- Scaling (1/n) is done all-at-once at the end.
+ n = rows of square image, rows is power of 2
+ m = rowpower
+ Scaling (1/n) is done all-at-once at the end.
Time-Reversing is done intermediately, it is more efficient.
*/
void pas_csft2d(tables_ok,flag, x, n,m, wcos,w3cos,w3sin)
void pas_cft_make_twiddle_tables_once();
void C_Array_Time_Reverse();
void pas_csft_backward_loop(), pas_cft_forward_loop();
-
+
if (tables_ok != 1) /* 1 means = tables already made */
pas_cft_make_twiddle_tables_once(n,m, wcos,w3cos,w3sin);
-
+
rows = n;
cols = rows; /* square image */
n2 = n/2;
total_length = rows*rows;
-
+
/* First ROW-WISE */
-
+
/* TREAT SPECIALLY ROWS 0 and n2, they are cs-arrays and they go into real */
if (flag == 1) /* forward transform */
{ xrow = x + 0 ;
pas_csft_backward_loop(xrow, n,m, wcos,w3cos,w3sin);
xrow = x + n2*cols;
pas_csft_backward_loop(xrow, n,m, wcos,w3cos,w3sin); }
-
+
/* TREAT the rest of the rows with CFT
*/
if (flag != 1) /* backward : conjugate before */
- for (i=(n2+1)*cols; i<total_length; i++) x[i] = (-x[i]);
-
+ for (i=(n2+1)*cols; i<total_length; i++) x[i] = (-x[i]);
+
xrow = x + cols; /* real part */
yrow = x + (rows-1)*cols; /* imag part */
for (i=1; i<n2; i++) /* forward or backward transform */
{ pas_cft_forward_loop(xrow,yrow, n,m, wcos,w3cos,w3sin);
- xrow = xrow + cols;
+ xrow = xrow + cols;
yrow = yrow - cols; }
-
+
if (flag != 1) /* backward : conjugate after */
- for (i=(n2+1)*cols; i<total_length; i++) x[i] = (-x[i]);
-
+ for (i=(n2+1)*cols; i<total_length; i++) x[i] = (-x[i]);
+
Image_Fast_Transpose(x, rows);
- /* Second COLUMN-WISE
+ /* Second COLUMN-WISE
Everything should be cs-arrays now */
-
+
xrow = x;
if (flag == 1) /* forward transform */
for (i=0; i<rows; i++)
for (i=0; i<rows; i++)
{ pas_csft_backward_loop(xrow, n,m, wcos,w3cos,w3sin);
xrow = xrow + cols; }
-
+
if (flag == 1) /* forward : scale */
{ scale = (REAL) (1.0 / ((double) total_length));
for (i=0; i<total_length; i++)
}
-\f
+\f
/* STUFF BEFORE 4-15-1989
*/
void Make_FFT_Tables(w1, w2, n, flag)
REAL *w1, *w2; long n, flag; /* n = length of data */
{ long m, n2=n/2; /* n2 = length of w1,w2 */
- double tm;
+ double tm;
if (flag==1) /* FORWARD FFT */
for (m=0; m<n2; m++) {
tm = TWOPI * ((double) m) / ((double) n);
long i, l, m;
REAL tm;
a = n; /* initially equal to length of data */
-
+
for (m=0; m<n; m++) { g1[m] = f1[m]; g2[m] = f2[m]; }
Make_FFT_Tables(w1,w2,n, flag);
-
+
if ((power % 2) == 1) l = 2; else l = 1; /* even,odd power */
for ( i = l; i <= power ; i = i + 2 ) {
mult(g1,g2,f1,f2,w1,w2);
mult(f1,f2,g1,g2,w1,w2); }
-
+
if (flag==1) { /* FORWARD FFT */
tm = 1. / ((REAL) n); /* normalizing factor */
if (l==1) /* even power */
}
}
-void C_Array_FFT_With_Given_Tables(flag, power, n, f1, f2, g1,g2,w1,w2)
+void C_Array_FFT_With_Given_Tables(flag, power, n, f1, f2, g1,g2,w1,w2)
long flag, power, n; REAL f1[], f2[], g1[], g2[], w1[], w2[];
{ long n2=n>>1, a;
long i, l, m;
REAL tm;
a = n; /* initially equal to length */
-
+
for (m=0; m<n; m++) { g1[m] = f1[m]; g2[m] = f2[m]; }
if ((power % 2) == 1) l = 2; else l = 1; /* even,odd power */
for ( i = l; i <= power ; i = i + 2 ) {
mult(g1,g2,f1,f2,w1,w2);
mult(f1,f2,g1,g2,w1,w2); }
-
+
if (flag==1) { /* FORWARD FFT */
tm = 1. / ((REAL) n); /* normalizing factor */
if (l==1) /* even power */
f1,f2 contain the input data (complex).
f1,f2,fo1,fo2,g1,g2 must be of length L
fft_w1,fft_w2 must be of length L/2
- czt_w1,czt_w2 must be of length max(M,N) ----
+ czt_w1,czt_w2 must be of length max(M,N) ----
;;
RESULT is left on f1,f2 (M complex numbers).
*/
{ long i, maxMN, L, L2;
void Make_CZT_Tables(), CZT_Pre_Multiply(), Make_Chirp_Filter();
void Make_FFT_Tables(), C_Array_FFT_With_Given_Tables(), C_Array_Complex_Multiply_Into_First_One();
-
+
maxMN = max(M,N);
L = 1<<log2_L;
L2 = L/2;
-
+
CZT_Pre_Multiply(phi,rho, f1,f2, N,L);
Make_FFT_Tables(fft_w1,fft_w2, L, 1); /* PREPARE TABLES FOR FORWARD FFT */
C_Array_FFT_With_Given_Tables(1, log2_L, L, f1,f2, g1,g2, fft_w1,fft_w2);
-
+
Make_CZT_Tables(czt_w1,czt_w2, rho, maxMN);
Make_Chirp_Filter(fo1,fo2, N,M,L, czt_w1,czt_w2);
C_Array_FFT_With_Given_Tables(1, log2_L, L, fo1,fo2, g1,g2, fft_w1,fft_w2);
-
+
C_Array_Complex_Multiply_Into_First_One(f1,f2, fo1,fo2, L);
for (i=0;i<L2;i++) fft_w2[i] = (-fft_w2[i]); /* PREPARE TABLES FOR INVERSE FFT */
C_Array_FFT_With_Given_Tables(-1, log2_L, L, f1,f2, g1,g2, fft_w1,fft_w2);
f1[i] = (REAL) tmp;
}
for (i=N;i<L;i++) { f1[i] = 0.0; /* zero pad */
- f2[i] = 0.0; }
+ f2[i] = 0.0; }
}
void Make_Chirp_Filter(fo1,fo2, N,M,L, czt_w1,czt_w2)
}
/* stuff not currently used
-
+
void CZT_Post_Multiply(f1,f2,czt_w1,czt_w2,M)
REAL *f1,*f2,*czt_w1,*czt_w2; long M;
{ long i;
#define take_modulo_one(x, answer) \
{ long ignore_integral_part; \
double modf(); \
- answer = (double) modf( ((double) x), &ignore_integral_part); }
- ^ this only works when answer is double
+ answer = (double) modf( ((double) x), &ignore_integral_part); }
+ ^ this only works when answer is double
*/
/* 2D DFT ---------------- row-column decomposition
(3D not working yet)
*/
-C_Array_2D_FFT_In_Scheme_Heap(flag, nrows, ncols, Real_Array, Imag_Array)
+C_Array_2D_FFT_In_Scheme_Heap(flag, nrows, ncols, Real_Array, Imag_Array)
long flag, nrows, ncols; REAL *Real_Array, *Imag_Array;
{ long i, j;
REAL *Temp_Array;
REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
long nrows_power, ncols_power, Length = nrows*ncols;
-
+
if (nrows==ncols) { /* SQUARE IMAGE, OPTIMIZE... */
Square_Image_2D_FFT_In_Scheme_Heap(flag, nrows, Real_Array, Imag_Array);
}
else { /* NOT A SQUARE IMAGE, CANNOT DO FAST_TRANSPOSE */
/* FIRST (NCOLS-1)POINT FFTS FOR EACH ROW, THEN (NROWS-1)POINT FFTS FOR EACH COLUMN */
-
+
for (ncols_power=0, i=ncols; i>1; ncols_power++) { /* FIND/CHECK POWERS OF ROWS,COLS */
- if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if ( (i % 2) == 1) error_bad_range_arg (2);
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 ( (i % 2) == 1) error_bad_range_arg (1);
+ i=i/2; }
+
Primitive_GC_If_Needed(Length*REAL_SIZE + ((max(nrows,ncols))*3*REAL_SIZE));
Work_Here = (REAL *) Free;
g1 = Work_Here;
f2 = Imag_Array + (i*ncols);
C_Array_FFT_With_Given_Tables(flag, ncols_power, ncols, f1,f2,g1,g2,w1,w2);
}
-
- Temp_Array = Work_Here;
+
+ Temp_Array = Work_Here;
Work_Here = Temp_Array + Length;
Image_Transpose(Real_Array, Temp_Array, nrows, ncols); /* TRANSPOSE: (1) order of frequencies. (2) read columns.*/
Image_Transpose(Imag_Array, Real_Array, nrows, ncols);
f2 = Real_Array + (i*nrows); /* THIS IS IMAG DATA */
C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2);
}
-
+
Image_Transpose(Real_Array, Imag_Array, ncols, nrows); /* DO FIRST THIS !!!, do not screw up Real_Data !!! */
Image_Transpose(Temp_Array, Real_Array, ncols, nrows); /* TRANSPOSE BACK: order of frequencies. */
}
long i;
for (nrows_power=0, i=nrows; i>1; nrows_power++) { /* FIND/CHECK POWERS OF ROWS */
- if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if ( (i % 2) == 1) error_bad_range_arg (2);
i=i/2; }
Primitive_GC_If_Needed(nrows*3*REAL_SIZE);
Work_Here = (REAL *) Free;
}
Image_Fast_Transpose(Real_Array, nrows); /* MUST TRANSPOSE (1) order of frequencies. (2) read columns. */
Image_Fast_Transpose(Imag_Array, nrows);
-
+
for (i=0;i<nrows;i++) { /* COLUMN-WISE */
f1 = Real_Array + (i*nrows);
f2 = Imag_Array + (i*nrows);
Image_Fast_Transpose(Imag_Array, nrows);
}
-C_Array_3D_FFT_In_Scheme_Heap(flag, ndeps, nrows, ncols, Real_Array, Imag_Array)
+C_Array_3D_FFT_In_Scheme_Heap(flag, ndeps, nrows, ncols, Real_Array, Imag_Array)
long flag, ndeps, nrows, ncols; REAL *Real_Array, *Imag_Array;
{ long l, m, n;
REAL *Temp_Array;
REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
long ndeps_power, nrows_power, ncols_power;
-
+
if ((ndeps==nrows) && (nrows==ncols)) { /* CUBIC IMAGE, OPTIMIZE... */
Cube_Space_3D_FFT_In_Scheme_Heap(flag, ndeps, Real_Array, Imag_Array);
}
- else {
+ else {
for (ndeps_power=0, l=ndeps; l>1; ndeps_power++) { /* FIND/CHECK POWERS OF DEPS,ROWS,COLS */
- if ( (l % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if ( (l % 2) == 1) error_bad_range_arg (2);
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);
+ if ( (m % 2) == 1) error_bad_range_arg (2);
+ m=m/2; }
+ for (ncols_power=0, n=ncols; n>1; ncols_power++) {
+ if ( (n % 2) == 1) error_bad_range_arg (2);
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;
-
+{ fast long l, m, n;
+ fast long ndeps_power, Surface_Length;
+ fast REAL *From_Real, *From_Imag;
+ fast 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);
+ if ( (l % 2) == 1) error_bad_range_arg (2);
l=l/2; }
Primitive_GC_If_Needed(ndeps*3*REAL_SIZE);
Work_Here = (REAL *) Free;
w1 = Work_Here + (ndeps<<1);
w2 = Work_Here + (ndeps<<1) + (ndeps>>1);
Make_FFT_Tables(w1, w2, ndeps, flag); /* MAKE TABLES */
-
+
Surface_Length=ndeps*ndeps;
From_Real = Real_Array; From_Imag = Imag_Array;
for (l=0; l<ndeps; l++,From_Real+=Surface_Length,From_Imag+=Surface_Length) { /* DEPTH-WISE */
-
+
f1 = From_Real; f2 = From_Imag;
for (m=0; m<ndeps; m++,f1+=ndeps,f2+=ndeps) { /* ROW-WISE */
C_Array_FFT_With_Given_Tables(flag, ndeps_power, ndeps, f1,f2,g1,g2,w1,w2); }
DEFINE_PRIMITIVE ("ARRAY-FFT!", Prim_array_fft, 3, 3, 0)
{ long length, power, flag, i;
- Pointer answer;
+ SCHEME_OBJECT answer;
REAL *f1,*f2,*g1,*g2,*w1,*w2;
REAL *Work_Here;
PRIMITIVE_HEADER (4);
- flag = arg_nonnegative_integer(1); /* forward or backward */
+ flag = arg_nonnegative_integer(1); /* forward or backward */
CHECK_ARG (2, ARRAY_P); /* input real */
CHECK_ARG (3, ARRAY_P); /* input imag */
-
- length = Array_Length(ARG_REF(2));
- if (length != (Array_Length(ARG_REF(3)))) error_bad_range_arg(2);
-
+
+ length = ARRAY_LENGTH(ARG_REF(2));
+ if (length != (ARRAY_LENGTH(ARG_REF(3)))) error_bad_range_arg(2);
+
for (power=0, i=length; i>1; power++) {
if ( (i % 2) == 1) error_bad_range_arg(2);
i=i/2; }
-
- f1 = Scheme_Array_To_C_Array(ARG_REF(2));
- f2 = Scheme_Array_To_C_Array(ARG_REF(3));
+
+ f1 = ARRAY_CONTENTS(ARG_REF(2));
+ f2 = ARRAY_CONTENTS(ARG_REF(3));
if (f1==f2) error_wrong_type_arg(2);
-
+
Primitive_GC_If_Needed(length*3*REAL_SIZE);
Work_Here = (REAL *) Free;
g1 = Work_Here;
w2 = Work_Here + (length<<1) + (length>>1);
C_Array_FFT(flag, power, length, f1,f2,g1,g2,w1,w2);
-
- PRIMITIVE_RETURN (NIL);
+
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("ARRAY-CZT!", Prim_array_czt, 6,6, 0)
int errcode;
REAL *a,*b,*c,*d;
REAL *f1,*f2,*fo1,*fo2, *g1,*g2, *fft_w1,*fft_w2,*czt_w1,*czt_w2, *Work_Here;
-
+
PRIMITIVE_HEADER (6);
- /* 1 phi=starting point [0,1]*/
- /* 2 rho=resolution [0,1] */
+ phi = (arg_real_number (1)); /* starting point [0,1]*/
+ phi = (arg_real_number (2)); /* resolution [0,1] */
CHECK_ARG (3, ARRAY_P); /* input real */
CHECK_ARG (4, ARRAY_P); /* input imag */
CHECK_ARG (5, ARRAY_P); /* output real */
CHECK_ARG (6, ARRAY_P); /* output imag */
-
- errcode = Scheme_Number_To_Double(ARG_REF(1), &phi);
- if (errcode==1) error_bad_range_arg(1); if (errcode==2) error_wrong_type_arg(1);
- errcode = Scheme_Number_To_Double(ARG_REF(2), &rho);
- if (errcode==1) error_bad_range_arg(2); if (errcode==2) error_wrong_type_arg(2);
-
- a = Scheme_Array_To_C_Array(ARG_REF(3));
- b = Scheme_Array_To_C_Array(ARG_REF(4));
- c = Scheme_Array_To_C_Array(ARG_REF(5));
- d = Scheme_Array_To_C_Array(ARG_REF(6));
-
- N = Array_Length(ARG_REF(3)); /* N = input length */
- M = Array_Length(ARG_REF(5)); /* M = output length */
- if (N!=(Array_Length(ARG_REF(4)))) error_bad_range_arg(3);
- if (M!=(Array_Length(ARG_REF(6)))) error_bad_range_arg(5);
-
+ a = ARRAY_CONTENTS(ARG_REF(3));
+ b = ARRAY_CONTENTS(ARG_REF(4));
+ c = ARRAY_CONTENTS(ARG_REF(5));
+ d = ARRAY_CONTENTS(ARG_REF(6));
+
+ N = ARRAY_LENGTH(ARG_REF(3)); /* N = input length */
+ M = ARRAY_LENGTH(ARG_REF(5)); /* M = output length */
+ if (N!=(ARRAY_LENGTH(ARG_REF(4)))) error_bad_range_arg(3);
+ if (M!=(ARRAY_LENGTH(ARG_REF(6)))) error_bad_range_arg(5);
+
if ((M+N-1) < 4) error_bad_range_arg(5);
log2_L = smallest_power_of_2_ge(M+N-1);
L = 1<<log2_L; /* length of intermediate computation arrays */
maxMN = (((M)<(N)) ? (N) : (M)); /* length of czt tables = maximum(M,N) */
-
+
Primitive_GC_If_Needed( ((7*L) + (2*maxMN)) * REAL_SIZE);
g1 = (REAL *) Free;
g2 = g1 + L;
for (i=0; i<N; i++) { f1[i] = a[i]; /* input data */
f2[i] = b[i]; }
-
+
C_Array_CZT(phi,rho, N,M,log2_L, f1,f2,fo1,fo2, g1,g2, fft_w1,fft_w2,czt_w1,czt_w2);
-
+
for (i=0; i<M; i++) { c[i] = f1[i]; /* results */
d[i] = f2[i]; }
-
- PRIMITIVE_RETURN (NIL);
-}
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
DEFINE_PRIMITIVE ("ARRAY-2D-FFT!", Prim_array_2d_fft, 5, 5, 0)
-{ long flag;
- Pointer answer;
- REAL *Real_Array, *Imag_Array;
- long Length, nrows, ncols;
-
- Primitive_5_Args();
- Arg_1_Type(TC_FIXNUM); /* flag */
- Range_Check(nrows, Arg2, 1, 512, ERR_ARG_2_BAD_RANGE);
- Range_Check(ncols, Arg3, 1, 512, ERR_ARG_3_BAD_RANGE);
- Arg_4_Type(TC_ARRAY); /* real image */
- Arg_5_Type(TC_ARRAY); /* imag image */
- Set_Time_Zone(Zone_Math); /* for timing */
-
- flag = Get_Integer(Arg1);
- Length = Array_Length(Arg4);
- if (Length != (nrows*ncols)) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- if (Length != (Array_Length(Arg5))) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- Real_Array = Scheme_Array_To_C_Array(Arg4);
- Imag_Array = Scheme_Array_To_C_Array(Arg5);
- if (Real_Array==Imag_Array) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
-
- C_Array_2D_FFT_In_Scheme_Heap(flag, nrows, ncols, Real_Array, Imag_Array);
-
- Primitive_GC_If_Needed(4); /* NOW RETURN ANSWERS */
- answer = Make_Pointer(TC_LIST, Free);
- *Free++ = Arg4;
- *Free = Make_Pointer(TC_LIST, Free+1);
- Free += 1;
- *Free++ = Arg5;
- *Free++ = NIL;
- return answer;
+{
+ PRIMITIVE_HEADER (5);
+ {
+ fast long nrows = (arg_integer_in_range (2, 1, 513));
+ fast long ncols = (arg_integer_in_range (3, 1, 513));
+ fast SCHEME_OBJECT real_image = (ARG_REF (4));
+ fast SCHEME_OBJECT imag_image = (ARG_REF (5));
+ CHECK_ARG (4, ARRAY_P);
+ CHECK_ARG (5, ARRAY_P);
+ if (real_image == imag_image)
+ error_wrong_type_arg (5);
+ Set_Time_Zone (Zone_Math);
+ {
+ long length = (ARRAY_LENGTH (real_image));
+ if ((length != (ARRAY_LENGTH (imag_image))) ||
+ (length != (nrows * ncols)))
+ error_bad_range_arg (5);
+ }
+ C_Array_2D_FFT_In_Scheme_Heap
+ ((arg_nonnegative_integer (1)),
+ nrows,
+ ncols,
+ (ARRAY_CONTENTS (real_image)),
+ (ARRAY_CONTENTS (imag_image)));
+ PRIMITIVE_RETURN (cons (real_image, (cons (imag_image, EMPTY_LIST))));
+ }
}
DEFINE_PRIMITIVE ("ARRAY-3D-FFT!", Prim_array_3d_fft, 6, 6, 0)
-{ long flag;
- Pointer answer;
- REAL *Real_Array, *Imag_Array;
- long Length, ndeps, nrows, ncols;
-
- Primitive_6_Args();
- Arg_1_Type(TC_FIXNUM); /* flag */
- Range_Check(ndeps, Arg2, 1, 512, ERR_ARG_2_BAD_RANGE);
- Range_Check(nrows, Arg3, 1, 512, ERR_ARG_2_BAD_RANGE);
- Range_Check(ncols, Arg4, 1, 512, ERR_ARG_3_BAD_RANGE);
- Arg_5_Type(TC_ARRAY); /* real image */
- Arg_6_Type(TC_ARRAY); /* imag image */
- Set_Time_Zone(Zone_Math); /* for timing */
-
- Sign_Extend(Arg1, flag); /* should be 1 or -1 */
- Length = Array_Length(Arg5);
- if (Length != (ndeps*nrows*ncols)) Primitive_Error(ERR_ARG_6_BAD_RANGE);
- if (Length != (Array_Length(Arg6))) Primitive_Error(ERR_ARG_6_BAD_RANGE);
- Real_Array = Scheme_Array_To_C_Array(Arg5);
- Imag_Array = Scheme_Array_To_C_Array(Arg6);
- if (Real_Array==Imag_Array) Primitive_Error(ERR_ARG_6_WRONG_TYPE);
-
- C_Array_3D_FFT_In_Scheme_Heap(flag, ndeps, nrows, ncols, Real_Array, Imag_Array);
-
- Primitive_GC_If_Needed(4); /* NOW RETURN ANSWERS */
- answer = Make_Pointer(TC_LIST, Free);
- *Free++ = Arg5;
- *Free = Make_Pointer(TC_LIST, Free+1);
- Free += 1;
- *Free++ = Arg6;
- *Free++ = NIL;
- return answer;
+{
+ PRIMITIVE_HEADER (6);
+ {
+ fast long ndeps = (arg_integer_in_range (2, 1, 513));
+ fast long nrows = (arg_integer_in_range (3, 1, 513));
+ fast long ncols = (arg_integer_in_range (4, 1, 513));
+ fast SCHEME_OBJECT real_image = (ARG_REF (5));
+ fast SCHEME_OBJECT imag_image = (ARG_REF (6));
+ CHECK_ARG (5, ARRAY_P);
+ CHECK_ARG (6, ARRAY_P);
+ if (real_image == imag_image)
+ error_wrong_type_arg (6);
+ {
+ long length = (ARRAY_LENGTH (real_image));
+ if ((length != (ARRAY_LENGTH (imag_image))) ||
+ (length != (ndeps * nrows * ncols)))
+ error_bad_range_arg (6);
+ }
+ C_Array_3D_FFT_In_Scheme_Heap
+ ((arg_integer (1)),
+ ndeps,
+ nrows,
+ ncols,
+ (ARRAY_CONTENTS (real_image)),
+ (ARRAY_CONTENTS (imag_image)));
+ PRIMITIVE_RETURN (cons (real_image, (cons (imag_image, EMPTY_LIST))));
+ }
}
-
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/fhooks.c,v 9.31 1989/09/20 23:08:15 cph Exp $
+
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/fhooks.c,v 9.30 1989/05/31 01:50:09 jinx Rel $
- *
- * This file contains hooks and handles for the new fluid bindings
- * scheme for multiprocessors.
- */
+/* This file contains hooks and handles for the new fluid bindings
+ scheme for multiprocessors. */
#include "scheme.h"
#include "prims.h"
#include "lookup.h"
#include "locks.h"
\f
-/* (SET-FLUID-BINDINGS! NEW-BINDINGS)
- Sets the microcode fluid-bindings variable. Returns the previous value.
-*/
-
-DEFINE_PRIMITIVE("SET-FLUID-BINDINGS!", Prim_set_fluid_bindings, 1)
-{
- Pointer Result;
- Primitive_1_Arg();
-
- if (Arg1 != NIL)
- Arg_1_Type(TC_LIST);
-
- Result = Fluid_Bindings;
- Fluid_Bindings = Arg1;
- PRIMITIVE_RETURN(Result);
+DEFINE_PRIMITIVE ("SET-FLUID-BINDINGS!", Prim_set_fluid_bindings, 1)
+{
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, APPARENT_LIST_P);
+ {
+ SCHEME_OBJECT result = Fluid_Bindings;
+ Fluid_Bindings = (ARG_REF (1));
+ PRIMITIVE_RETURN (result);
+ }
}
-/* (GET-FLUID-BINDINGS NEW-BINDINGS)
- Gets the microcode fluid-bindings variable.
-*/
-
-DEFINE_PRIMITIVE("GET-FLUID-BINDINGS", Prim_get_fluid_bindings, 0)
+DEFINE_PRIMITIVE ("GET-FLUID-BINDINGS", Prim_get_fluid_bindings, 0)
{
- Primitive_0_Args();
-
- PRIMITIVE_RETURN(Fluid_Bindings);
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (Fluid_Bindings);
}
-/* (WITH-SAVED-FLUID-BINDINGS THUNK)
- Executes THUNK, then restores the previous fluid bindings.
-*/
-
DEFINE_PRIMITIVE ("WITH-SAVED-FLUID-BINDINGS", Prim_with_saved_fluid_bindings, 1, 1, 0)
{
- Primitive_1_Arg();
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- Pop_Primitive_Frame(1);
-
- /* Save previous fluid bindings for later restore */
-
- Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
- Store_Expression(Fluid_Bindings);
- Store_Return(RC_RESTORE_FLUIDS);
- Save_Cont();
- Push(Arg1);
- Push(STACK_FRAME_HEADER);
- Pushed();
- PRIMITIVE_ABORT(PRIM_APPLY);
- /*NOTREACHED*/
+ PRIMITIVE_HEADER (1);
+ {
+ SCHEME_OBJECT thunk = (ARG_REF (1));
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ Pop_Primitive_Frame (1);
+ Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
+ /* Save previous fluid bindings for later restore */
+ Store_Expression (Fluid_Bindings);
+ Store_Return (RC_RESTORE_FLUIDS);
+ Save_Cont ();
+ /* Invoke the thunk. */
+ Push (thunk);
+ Push (STACK_FRAME_HEADER);
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ /*NOTREACHED*/
+ }
}
\f
-/* Utilities for the primitives below. */
+#define lookup_slot(environment, variable) \
+ (lookup_cell ((OBJECT_ADDRESS (variable)), (environment)))
-extern Pointer *lookup_cell();
-
-#define lookup_slot(env, var) lookup_cell(Get_Pointer(var), env)
-
-Pointer
-new_fluid_binding(cell, value, force)
- Pointer *cell;
- Pointer value;
- Boolean force;
+DEFINE_PRIMITIVE ("ADD-FLUID-BINDING!", Prim_add_fluid_binding, 3, 3,
+ "(ADD-FLUID-BINDING! ENVIRONMENT SYMBOL/VARIABLE VALUE)\n\
+Dynamically bind SYMBOL/VARIABLE to VALUE in ENVIRONMENT.\n\
+If SYMBOL/VARIABLE has not been \"fluidized\", do so first.")
{
- fast Pointer trap;
- Lock_Handle set_serializer;
- Pointer new_trap_value;
- long new_trap_kind, trap_kind;
- Pointer saved_extension, saved_value;
+ extern SCHEME_OBJECT * lookup_cell ();
+ static SCHEME_OBJECT new_fluid_binding ();
+ PRIMITIVE_HEADER (3);
+ CHECK_ARG (1, ENVIRONMENT_P);
+ {
+ fast SCHEME_OBJECT environment = (ARG_REF (1));
+ fast SCHEME_OBJECT name = (ARG_REF (2));
+ fast SCHEME_OBJECT * cell;
+ switch (OBJECT_TYPE (name))
+ {
+ /* The next two cases are a temporary fix since compiler doesn't
+ do scode-quote the same way that the interpreter does.
- saved_extension = NIL;
- new_trap_kind = TRAP_FLUID;
- setup_lock(set_serializer, cell);
+ Ultimately we need to redesign deep fluid-let support anyway,
+ so this will go away.
+ */
-new_fluid_binding_restart:
+ case TC_LIST:
+ cell = (lookup_slot (environment, (PAIR_CAR (name))));
+ break;
- trap = *cell;
- new_trap_value = trap;
+ case TC_SCODE_QUOTE:
+ cell =
+ (lookup_slot
+ (environment, (FAST_MEMORY_REF (name, SCODE_QUOTE_OBJECT))));
+ break;
- if (OBJECT_TYPE(trap) == TC_REFERENCE_TRAP)
- {
- get_trap_kind(trap_kind, trap);
- switch(trap_kind)
- {
- case TRAP_DANGEROUS:
- Vector_Set(trap,
- TRAP_TAG,
- Make_Unsigned_Fixnum(TRAP_FLUID | (trap_kind & 1)));
- /* Fall through */
+ case TC_VARIABLE:
+ cell = (lookup_slot (environment, name));
+ break;
- case TRAP_FLUID:
- case TRAP_FLUID_DANGEROUS:
- new_trap_kind = -1;
+ case TC_INTERNED_SYMBOL:
+ case TC_UNINTERNED_SYMBOL:
+ cell = (deep_lookup (environment, name, fake_variable_object));
break;
+
+ default:
+ error_wrong_type_arg (2);
+ }
+ PRIMITIVE_RETURN (new_fluid_binding (cell, (ARG_REF (3)), false));
+ }
+}
\f
- case TRAP_UNBOUND:
- case TRAP_UNBOUND_DANGEROUS:
- if (!force)
- {
- remove_lock(set_serializer);
- Primitive_Error(ERR_UNBOUND_VARIABLE);
- }
- /* Fall through */
+static SCHEME_OBJECT
+new_fluid_binding (cell, value, force)
+ SCHEME_OBJECT * cell;
+ SCHEME_OBJECT value;
+ Boolean force;
+{
+ fast SCHEME_OBJECT trap;
+ Lock_Handle set_serializer;
+ SCHEME_OBJECT new_trap_value;
+ long new_trap_kind = TRAP_FLUID;
+ long trap_kind;
+ SCHEME_OBJECT saved_extension = SHARP_F;
+ SCHEME_OBJECT saved_value;
- case TRAP_UNASSIGNED:
- case TRAP_UNASSIGNED_DANGEROUS:
- new_trap_kind = (TRAP_FLUID | (trap_kind & 1));
- new_trap_value = UNASSIGNED_OBJECT;
- break;
+ setup_lock (set_serializer, cell);
- case TRAP_COMPILER_CACHED:
- case TRAP_COMPILER_CACHED_DANGEROUS:
- saved_extension = Fast_Vector_Ref(*cell, TRAP_EXTRA);
- cell = Nth_Vector_Loc(saved_extension, TRAP_EXTENSION_CELL);
- update_lock(set_serializer, cell);
- saved_value = *cell;
- if (OBJECT_TYPE(saved_value) == TC_REFERENCE_TRAP)
+ new_fluid_binding_restart:
+ trap = (*cell);
+ new_trap_value = trap;
+ if (REFERENCE_TRAP_P (trap))
+ {
+ get_trap_kind (trap_kind, trap);
+ switch (trap_kind)
{
- /* No need to recache uuo links, they must already be recached. */
- saved_extension = NIL;
+ case TRAP_DANGEROUS:
+ MEMORY_SET
+ (trap,
+ TRAP_TAG,
+ (LONG_TO_UNSIGNED_FIXNUM (TRAP_FLUID | (trap_kind & 1))));
+ /* Fall through */
+ case TRAP_FLUID:
+ case TRAP_FLUID_DANGEROUS:
+ new_trap_kind = -1;
+ break;
+
+ case TRAP_UNBOUND:
+ case TRAP_UNBOUND_DANGEROUS:
+ if (! force)
+ {
+ remove_lock (set_serializer);
+ signal_error_from_primitive (ERR_UNBOUND_VARIABLE);
+ }
+ /* Fall through */
+ case TRAP_UNASSIGNED:
+ case TRAP_UNASSIGNED_DANGEROUS:
+ new_trap_kind = (TRAP_FLUID | (trap_kind & 1));
+ new_trap_value = UNASSIGNED_OBJECT;
+ break;
+
+ case TRAP_COMPILER_CACHED:
+ case TRAP_COMPILER_CACHED_DANGEROUS:
+ saved_extension = (FAST_MEMORY_REF ((*cell), TRAP_EXTRA));
+ cell = (MEMORY_LOC (saved_extension, TRAP_EXTENSION_CELL));
+ update_lock (set_serializer, cell);
+ saved_value = (*cell);
+ if (REFERENCE_TRAP_P (saved_value))
+ /* No need to recache uuo links, they must already be recached. */
+ saved_extension = SHARP_F;
+ goto new_fluid_binding_restart;
+
+ default:
+ remove_lock (set_serializer);
+ signal_error_from_primitive (ERR_ILLEGAL_REFERENCE_TRAP);
}
- goto new_fluid_binding_restart;
-
- default:
- remove_lock(set_serializer);
- Primitive_Error(ERR_ILLEGAL_REFERENCE_TRAP);
}
- }
if (new_trap_kind != -1)
- {
- if (GC_allocate_test(2))
{
- remove_lock(set_serializer);
- Primitive_GC(2);
+ if (GC_allocate_test (2))
+ {
+ remove_lock (set_serializer);
+ Primitive_GC (2);
+ }
+ trap = (MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free));
+ (*Free++) = (LONG_TO_UNSIGNED_FIXNUM (new_trap_kind));
+ (*Free++) = new_trap_value;
+ (*cell) = trap;
}
- trap = Make_Pointer(TC_REFERENCE_TRAP, Free);
- *Free++ = Make_Unsigned_Fixnum(new_trap_kind);
- *Free++ = new_trap_value;
- *cell = trap;
- }
-\f
- if (saved_extension != NIL)
- {
- extern long recache_uuo_links();
- long value;
-
- value = recache_uuo_links(saved_extension, saved_value);
- if (value != PRIM_DONE)
+ if (saved_extension != SHARP_F)
{
- remove_lock(set_serializer);
- if (value == PRIM_INTERRUPT)
- {
- Primitive_Interrupt();
- }
- else
- {
- Primitive_Error(value);
- }
+ extern long recache_uuo_links ();
+ long value = (recache_uuo_links (saved_extension, saved_value));
+ if (value != PRIM_DONE)
+ {
+ remove_lock (set_serializer);
+ if (value == PRIM_INTERRUPT)
+ signal_interrupt_from_primitive ();
+ else
+ signal_error_from_primitive (value);
+ }
}
- }
- remove_lock(set_serializer);
+ remove_lock (set_serializer);
/* Fluid_Bindings is per processor private. */
-
- Primitive_GC_If_Needed(4);
- Free[CONS_CAR] = Make_Pointer(TC_LIST, (Free + 2));
- Free[CONS_CDR] = Fluid_Bindings;
- Fluid_Bindings = Make_Pointer(TC_LIST, Free);
- Free += 2;
- Free[CONS_CAR] = trap;
- Free[CONS_CDR] = value;
- Free += 2;
-
- return (NIL);
-}
-\f
-/* (ADD-FLUID-BINDING! ENVIRONMENT SYMBOL-OR-VARIABLE VALUE)
- Looks up symbol-or-variable in environment. If it has not been
- fluidized, fluidizes it. A fluid binding with the specified
- value is created in this interpreter's fluid bindings.
-*/
-
-DEFINE_PRIMITIVE ("ADD-FLUID-BINDING!", Prim_add_fluid_binding, 3, 3, 0)
-{
- Pointer *cell;
- Primitive_3_Args();
-
- if (Arg1 != GLOBAL_ENV)
- Arg_1_Type(TC_ENVIRONMENT);
-
- switch (OBJECT_TYPE(Arg2))
- {
- /* The next two cases are a temporary fix since compiler doesn't
- do scode-quote the same way that the interpreter does.
-
- Ultimately we need to redesign deep fluid-let support anyway,
- so this will go away.
- */
-
- case TC_LIST:
- cell = lookup_slot(Arg1, Fast_Vector_Ref(Arg2, CONS_CAR));
- break;
-
- case TC_SCODE_QUOTE:
- cell = lookup_slot(Arg1, Fast_Vector_Ref(Arg2, SCODE_QUOTE_OBJECT));
- break;
-
- case TC_VARIABLE:
- cell = lookup_slot(Arg1, Arg2);
- break;
-
- case TC_INTERNED_SYMBOL:
- case TC_UNINTERNED_SYMBOL:
- cell = deep_lookup(Arg1, Arg2, fake_variable_object);
- break;
-
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
-
- PRIMITIVE_RETURN(new_fluid_binding(cell, Arg3, false));
+ Fluid_Bindings = (cons ((cons (trap, value)), Fluid_Bindings));
+ return (SHARP_F);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/findprim.c,v 9.40 1989/05/31 01:45:29 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/findprim.c,v 9.41 1989/09/20 23:04:37 cph Exp $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
* The output is a C source file to be compiled and linked with the
* Scheme microcode.
*
- * This program understands the following options (must be given in
+ * This program understands the following options (must be given in
* this order):
*
* -o fname
extern char * malloc ();
result = (malloc (length));
- if (result == NULL)
+ if (result == ((char *) 0))
{
fprintf (stderr, "malloc: unable to allocate %d bytes\n", length);
exit (1);
extern char * realloc ();
result = (realloc (ptr, length));
- if (result == NULL)
+ if (result == ((char *) 0))
{
fprintf (stderr, "realloc: unable to allocate %d bytes\n", length);
exit (1);
dump (TRUE);
exit (1);
}
- else
+ else
{
dprintf ("About to process %s\n", file_name);
process ();
else
{
/* Print declarations. */
- fprintf (output, "extern Pointer\n");
+ fprintf (output, "extern SCHEME_OBJECT\n");
for (count = 0; (count < max_index); count += 1)
fprintf (output, " %s (),\n",
(((* data_buffer) [count]) . c_name));
struct descriptor * primitive_descriptor;
char * error_string;
{
- fprintf (output, "Pointer\n");
+ fprintf (output, "SCHEME_OBJECT\n");
fprintf (output, "%s ()\n", (primitive_descriptor -> c_name));
fprintf (output, "{\n");
fprintf (output, " PRIMITIVE_HEADER (%s);\n",
last = (limit - 1);
/* Print the procedure table. */
- fprintf (output, "\f\nPointer (* (%s_Procedure_Table [])) () = {\n",
+ fprintf (output, "\f\nSCHEME_OBJECT (* (%s_Procedure_Table [])) () = {\n",
the_kind);
for (count = 0; (count < limit); count += 1)
{
for (count = 0; (count < limit); count += 1)
{
fprintf (output,
- " (%s * sizeof(Pointer)),\n",
+ " (%s * sizeof(SCHEME_OBJECT)),\n",
((result_buffer [count]) -> arity));
}
- fprintf (output, " (%s * sizeof(Pointer))\n};\n", inexistent_entry.arity);
+ fprintf (output, " (%s * sizeof(SCHEME_OBJECT))\n};\n", inexistent_entry.arity);
return;
}
{
case ' ':
case '\t':
- case '\n':
+ case '\n':
case '(':
case ')':
case ',': return TRUE;
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixnum.c,v 9.27 1989/02/19 17:51:38 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixnum.c,v 9.28 1989/09/20 23:08:26 cph Exp $
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#include "scheme.h"
#include "prims.h"
-\f
-#define FIXNUM_PRIMITIVE_1(parameter_1) \
- fast long parameter_1; \
- Primitive_1_Arg (); \
- CHECK_ARG (1, FIXNUM_P); \
- Sign_Extend (Arg1, parameter_1)
-
-#define FIXNUM_PRIMITIVE_2(parameter_1, parameter_2) \
- fast long parameter_1, parameter_2; \
- Primitive_2_Args (); \
- CHECK_ARG (1, FIXNUM_P); \
- CHECK_ARG (2, FIXNUM_P); \
- Sign_Extend (Arg1, parameter_1); \
- Sign_Extend (Arg2, parameter_2)
-
-#define FIXNUM_RESULT(fixnum) \
- if (! (Fixnum_Fits (fixnum))) \
- error_bad_range_arg (1); \
- return (Make_Signed_Fixnum (fixnum));
-#define BOOLEAN_RESULT(x) \
- return ((x) ? SHARP_T : NIL)
+static long
+arg_fixnum (n)
+ int n;
+{
+ fast SCHEME_OBJECT argument = (ARG_REF (n));
+ if (! (FIXNUM_P (argument)))
+ error_wrong_type_arg (n);
+ return (FIXNUM_TO_LONG (argument));
+}
\f
/* Predicates */
DEFINE_PRIMITIVE ("ZERO-FIXNUM?", Prim_zero_fixnum, 1, 1, 0)
{
- FIXNUM_PRIMITIVE_1 (x);
- BOOLEAN_RESULT ((Get_Integer (Arg1)) == 0);
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((arg_fixnum (1)) == 0));
}
DEFINE_PRIMITIVE ("NEGATIVE-FIXNUM?", Prim_negative_fixnum, 1, 1, 0)
{
- FIXNUM_PRIMITIVE_1 (x);
- BOOLEAN_RESULT (x < 0);
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((arg_fixnum (1)) < 0));
}
DEFINE_PRIMITIVE ("POSITIVE-FIXNUM?", Prim_positive_fixnum, 1, 1, 0)
{
- FIXNUM_PRIMITIVE_1 (x);
- BOOLEAN_RESULT (x > 0);
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((arg_fixnum (1)) > 0));
}
DEFINE_PRIMITIVE ("EQUAL-FIXNUM?", Prim_equal_fixnum, 2, 2, 0)
{
- FIXNUM_PRIMITIVE_2 (x, y);
- BOOLEAN_RESULT (x == y);
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((arg_fixnum (1)) == (arg_fixnum (2))));
}
DEFINE_PRIMITIVE ("LESS-THAN-FIXNUM?", Prim_less_fixnum, 2, 2, 0)
{
- FIXNUM_PRIMITIVE_2 (x, y);
- BOOLEAN_RESULT (x < y);
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((arg_fixnum (1)) < (arg_fixnum (2))));
}
DEFINE_PRIMITIVE ("GREATER-THAN-FIXNUM?", Prim_greater_fixnum, 2, 2, 0)
{
- FIXNUM_PRIMITIVE_2 (x, y);
- BOOLEAN_RESULT (x > y);
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((arg_fixnum (1)) > (arg_fixnum (2))));
}
\f
/* Operators */
+#define FIXNUM_RESULT(fixnum) \
+{ \
+ fast long result = (fixnum); \
+ if (! (LONG_TO_FIXNUM_P (result))) \
+ error_bad_range_arg (1); \
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM (result)); \
+}
+
DEFINE_PRIMITIVE ("ONE-PLUS-FIXNUM", Prim_one_plus_fixnum, 1, 1, 0)
{
- fast long result;
- FIXNUM_PRIMITIVE_1 (x);
- result = (x + 1);
- FIXNUM_RESULT (result);
+ PRIMITIVE_HEADER (1);
+ FIXNUM_RESULT ((arg_fixnum (1)) + 1);
}
DEFINE_PRIMITIVE ("MINUS-ONE-PLUS-FIXNUM", Prim_m_1_plus_fixnum, 1, 1, 0)
{
- fast long result;
- FIXNUM_PRIMITIVE_1 (x);
- result = (x - 1);
- FIXNUM_RESULT (result);
+ PRIMITIVE_HEADER (1);
+ FIXNUM_RESULT ((arg_fixnum (1)) - 1);
}
DEFINE_PRIMITIVE ("PLUS-FIXNUM", Prim_plus_fixnum, 2, 2, 0)
{
- fast long result;
- FIXNUM_PRIMITIVE_2 (x, y);
- result = (x + y);
- FIXNUM_RESULT (result);
+ PRIMITIVE_HEADER (2);
+ FIXNUM_RESULT ((arg_fixnum (1)) + (arg_fixnum (2)));
}
DEFINE_PRIMITIVE ("MINUS-FIXNUM", Prim_minus_fixnum, 2, 2, 0)
{
- fast long result;
- FIXNUM_PRIMITIVE_2 (x, y);
- result = (x - y);
- FIXNUM_RESULT (result);
+ PRIMITIVE_HEADER (2);
+ FIXNUM_RESULT ((arg_fixnum (1)) - (arg_fixnum (2)));
}
-\f
-/* Fixnum multiplication routine with overflow detection. */
+/* Fixnum multiplication routine with overflow detection. */
#include "mul.c"
DEFINE_PRIMITIVE ("MULTIPLY-FIXNUM", Prim_multiply_fixnum, 2, 2, 0)
{
- fast long result;
- Primitive_2_Args ();
-
+ PRIMITIVE_HEADER (2);
CHECK_ARG (1, FIXNUM_P);
CHECK_ARG (2, FIXNUM_P);
- result = (Mul (Arg1, Arg2));
- if (result == NIL)
- error_bad_range_arg (1);
- return (result);
+ {
+ fast long result = (Mul ((ARG_REF (1)), (ARG_REF (2))));
+ if (result == SHARP_F)
+ error_bad_range_arg (1);
+ PRIMITIVE_RETURN (result);
+ }
}
-
+\f
DEFINE_PRIMITIVE ("DIVIDE-FIXNUM", Prim_divide_fixnum, 2, 2, 0)
{
- /* Returns the CONS of quotient and remainder */
+ fast long numerator;
+ fast long denominator;
fast long quotient;
- FIXNUM_PRIMITIVE_2 (numerator, denominator);
-
+ fast long remainder;
+ PRIMITIVE_HEADER (2);
+ numerator = (arg_fixnum (1));
+ denominator = (arg_fixnum (2));
if (denominator == 0)
error_bad_range_arg (2);
- Primitive_GC_If_Needed (2);
- quotient = (numerator / denominator);
- if (! (Fixnum_Fits (quotient)))
+ /* Now, unbelievable hair because C doesn't fully specify / and %
+ when their arguments are negative. We must get consistent
+ answers for all valid arguments. */
+ if (numerator < 0)
+ {
+ numerator = (- numerator);
+ if (denominator < 0)
+ {
+ denominator = (- denominator);
+ quotient = (numerator / denominator);
+ }
+ else
+ quotient = (- (numerator / denominator));
+ remainder = (- (numerator % denominator));
+ }
+ else
+ {
+ if (denominator < 0)
+ {
+ denominator = (- denominator);
+ quotient = (- (numerator / denominator));
+ }
+ else
+ quotient = (numerator / denominator);
+ remainder = (numerator % denominator);
+ }
+ if (! (LONG_TO_FIXNUM_P (quotient)))
error_bad_range_arg (1);
- Free[CONS_CAR] = (Make_Signed_Fixnum (quotient));
- Free[CONS_CDR] = (Make_Signed_Fixnum (numerator % denominator));
- Free += 2;
- return (Make_Pointer (TC_LIST, (Free - 2)));
+ PRIMITIVE_RETURN
+ (cons ((LONG_TO_FIXNUM (quotient)), (LONG_TO_FIXNUM (remainder))));
}
DEFINE_PRIMITIVE ("GCD-FIXNUM", Prim_gcd_fixnum, 2, 2, 0)
{
+ fast long x;
+ fast long y;
fast long z;
- FIXNUM_PRIMITIVE_2 (x, y);
-
+ PRIMITIVE_HEADER (2);
+ x = (arg_fixnum (1));
+ y = (arg_fixnum (2));
while (y != 0)
{
z = x;
x = y;
y = (z % y);
}
- return (Make_Signed_Fixnum (x));
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM (x));
}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/flonum.c,v 9.27 1989/09/20 23:08:30 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/flonum.c,v 9.26 1989/05/10 21:57:37 arthur Rel $
- *
- * This file contains support for floating point arithmetic. Most
- * of these primitives have been superceded by generic arithmetic.
- */
+/* Floating Point Arithmetic */
#include "scheme.h"
#include "prims.h"
-#include "flonum.h"
#include "zones.h"
-
-#define BOOLEAN_RESULT(x) \
- return ((x) ? SHARP_T : NIL)
\f
- /************************************/
- /* BINARY FLOATING POINT OPERATIONS */
- /************************************/
-
-/* The binary floating point operations return NIL if either argument
- is not a floating point number. Otherwise they return the
- appropriate result.
-*/
-
-DEFINE_PRIMITIVE ("PLUS-FLONUM", Prim_plus_flonum, 2, 2, 0)
+double
+arg_flonum (arg_number)
+ int arg_number;
{
- 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));
+ SCHEME_OBJECT argument = (ARG_REF (arg_number));
+ if (! (FLONUM_P (argument)))
+ error_wrong_type_arg (arg_number);
+ return (FLONUM_TO_DOUBLE (argument));
}
-DEFINE_PRIMITIVE ("MINUS-FLONUM", Prim_minus_flonum, 2, 2, 0)
-{
- Primitive_2_Args();
+#define FLONUM_RESULT(x) PRIMITIVE_RETURN (double_to_flonum (x))
+#define BOOLEAN_RESULT(x) PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (x))
- 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));
-}
+#define FLONUM_SIZE ((BYTES_TO_WORDS (sizeof (double))) + 1)
-DEFINE_PRIMITIVE ("MULTIPLY-FLONUM", Prim_multiply_flonum, 2, 2, 0)
+SCHEME_OBJECT
+double_to_flonum (value)
+ double value;
{
- 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));
-}
-
-DEFINE_PRIMITIVE ("DIVIDE-FLONUM", Prim_divide_flonum, 2, 2, 0)
-{
- 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));
+ ALIGN_FLOAT (Free);
+ Primitive_GC_If_Needed (FLONUM_SIZE);
+ (*Free++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (FLONUM_SIZE - 1)));
+ (*((double *) Free)++) = value;
+ return (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, (Free - FLONUM_SIZE)));
}
\f
- /************************************/
- /* BINARY FLOATING POINT PREDICATES */
- /************************************/
+#define FLONUM_BINARY_OPERATION(operator) \
+{ \
+ PRIMITIVE_HEADER (2); \
+ Set_Time_Zone (Zone_Math); \
+ FLONUM_RESULT ((arg_flonum (1)) operator (arg_flonum (2))); \
+}
-/* 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.
-*/
+DEFINE_PRIMITIVE ("FLONUM-ADD", Prim_flonum_add, 2, 2, 0)
+ FLONUM_BINARY_OPERATION (+)
+DEFINE_PRIMITIVE ("FLONUM-SUBTRACT", Prim_flonum_subtract, 2, 2, 0)
+ FLONUM_BINARY_OPERATION (-)
+DEFINE_PRIMITIVE ("FLONUM-MULTIPLY", Prim_flonum_multiply, 2, 2, 0)
+ FLONUM_BINARY_OPERATION (*)
-DEFINE_PRIMITIVE ("EQUAL-FLONUM?", Prim_equal_flonum, 2, 2, 0)
+DEFINE_PRIMITIVE ("FLONUM-DIVIDE", Prim_flonum_divide, 2, 2, 0)
{
- Primitive_2_Args();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Arg_2_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- BOOLEAN_RESULT ((Get_Float(Arg1)) == (Get_Float(Arg2)));
+ PRIMITIVE_HEADER (2);
+ Set_Time_Zone (Zone_Math);
+ {
+ fast double denominator = (arg_flonum (2));
+ if (denominator == 0)
+ error_bad_range_arg (2);
+ FLONUM_RESULT ((arg_flonum (1)) / denominator);
+ }
}
-DEFINE_PRIMITIVE ("GREATER-THAN-FLONUM?", Prim_greater_flonum, 2, 2, 0)
+DEFINE_PRIMITIVE ("FLONUM-NEGATE", Prim_flonum_negate, 1, 1, 0)
{
- Primitive_2_Args();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Arg_2_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- BOOLEAN_RESULT ((Get_Float(Arg1)) > (Get_Float(Arg2)));
+ PRIMITIVE_HEADER (1);
+ Set_Time_Zone (Zone_Math);
+ FLONUM_RESULT (- (arg_flonum (1)));
}
-DEFINE_PRIMITIVE ("LESS-THAN-FLONUM?", Prim_less_flonum, 2, 2, 0)
+DEFINE_PRIMITIVE ("FLONUM-ABS", Prim_flonum_abs, 1, 1, 0)
{
- Primitive_2_Args();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Arg_2_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- BOOLEAN_RESULT ((Get_Float(Arg1)) < (Get_Float(Arg2)));
+ PRIMITIVE_HEADER (1);
+ Set_Time_Zone (Zone_Math);
+ {
+ fast double x = (arg_flonum (1));
+ FLONUM_RESULT ((x < 0) ? (-x) : x);
+ }
}
-\f
- /***********************************/
- /* UNARY FLOATING POINT OPERATIONS */
- /***********************************/
-
-/* The unary flonum operations return NIL if their argument is
- not a flonum. Otherwise, they return the appropriate result.
-*/
-
-DEFINE_PRIMITIVE ("SINE-FLONUM", Prim_sine_flonum, 1, 1, 0)
-{
- extern double sin();
- Primitive_1_Arg();
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- Flonum_Result(sin(Get_Float(Arg1)));
+#define FLONUM_BINARY_PREDICATE(operator) \
+{ \
+ PRIMITIVE_HEADER (2); \
+ Set_Time_Zone (Zone_Math); \
+ BOOLEAN_RESULT ((arg_flonum (1)) operator (arg_flonum (2))); \
}
-DEFINE_PRIMITIVE ("COSINE-FLONUM", Prim_cosine_flonum, 1, 1, 0)
-{
- extern double cos();
- Primitive_1_Arg();
+DEFINE_PRIMITIVE ("FLONUM-EQUAL?", Prim_flonum_equal_p, 2, 2, 0)
+ FLONUM_BINARY_PREDICATE (==)
+DEFINE_PRIMITIVE ("FLONUM-LESS?", Prim_flonum_less_p, 2, 2, 0)
+ FLONUM_BINARY_PREDICATE (<)
+DEFINE_PRIMITIVE ("FLONUM-GREATER?", Prim_flonum_greater_p, 2, 2, 0)
+ FLONUM_BINARY_PREDICATE (>)
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- Flonum_Result(cos(Get_Float(Arg1)));
+#define FLONUM_UNARY_PREDICATE(operator) \
+{ \
+ PRIMITIVE_HEADER (1); \
+ Set_Time_Zone (Zone_Math); \
+ BOOLEAN_RESULT ((arg_flonum (1)) operator 0); \
}
-DEFINE_PRIMITIVE ("ARCTAN-FLONUM", Prim_arctan_flonum, 1, 1, 0)
-{
- extern double atan();
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- Flonum_Result(atan(Get_Float(Arg1)));
-}
+DEFINE_PRIMITIVE ("FLONUM-ZERO?", Prim_flonum_zero_p, 1, 1, 0)
+ FLONUM_UNARY_PREDICATE (==)
+DEFINE_PRIMITIVE ("FLONUM-POSITIVE?", Prim_flonum_positive_p, 1, 1, 0)
+ FLONUM_UNARY_PREDICATE (>)
+DEFINE_PRIMITIVE ("FLONUM-NEGATIVE?", Prim_flonum_negative_p, 1, 1, 0)
+ FLONUM_UNARY_PREDICATE (<)
\f
-DEFINE_PRIMITIVE ("EXP-FLONUM", Prim_exp_flonum, 1, 1, 0)
-{
- extern double exp();
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- Flonum_Result(exp(Get_Float(Arg1)));
+#define SIMPLE_TRANSCENDENTAL_FUNCTION(function) \
+{ \
+ extern double function (); \
+ PRIMITIVE_HEADER (1); \
+ Set_Time_Zone (Zone_Math); \
+ FLONUM_RESULT (function (arg_flonum (1))); \
+}
+
+#define RESTRICTED_TRANSCENDENTAL_FUNCTION(function, restriction) \
+{ \
+ extern double function (); \
+ PRIMITIVE_HEADER (1); \
+ Set_Time_Zone (Zone_Math); \
+ { \
+ fast double x = (arg_flonum (1)); \
+ if (! (restriction)) \
+ error_bad_range_arg (1); \
+ FLONUM_RESULT (function (x)); \
+ } \
+}
+
+DEFINE_PRIMITIVE ("FLONUM-EXP", Prim_flonum_exp, 1, 1, 0)
+ SIMPLE_TRANSCENDENTAL_FUNCTION (exp)
+DEFINE_PRIMITIVE ("FLONUM-LOG", Prim_flonum_log, 1, 1, 0)
+ RESTRICTED_TRANSCENDENTAL_FUNCTION (log, (x > 0))
+DEFINE_PRIMITIVE ("FLONUM-SIN", Prim_flonum_sin, 1, 1, 0)
+ SIMPLE_TRANSCENDENTAL_FUNCTION (sin)
+DEFINE_PRIMITIVE ("FLONUM-COS", Prim_flonum_cos, 1, 1, 0)
+ SIMPLE_TRANSCENDENTAL_FUNCTION (cos)
+DEFINE_PRIMITIVE ("FLONUM-TAN", Prim_flonum_tan, 1, 1, 0)
+ SIMPLE_TRANSCENDENTAL_FUNCTION (tan)
+DEFINE_PRIMITIVE ("FLONUM-ASIN", Prim_flonum_asin, 1, 1, 0)
+ RESTRICTED_TRANSCENDENTAL_FUNCTION (asin, ((x >= -1) && (x <= 1)))
+DEFINE_PRIMITIVE ("FLONUM-ACOS", Prim_flonum_acos, 1, 1, 0)
+ RESTRICTED_TRANSCENDENTAL_FUNCTION (acos, ((x >= -1) && (x <= 1)))
+DEFINE_PRIMITIVE ("FLONUM-ATAN", Prim_flonum_atan, 1, 1, 0)
+ SIMPLE_TRANSCENDENTAL_FUNCTION (atan)
+
+DEFINE_PRIMITIVE ("FLONUM-ATAN2", Prim_flonum_atan2, 2, 2, 0)
+{
+ extern double atan2 ();
+ PRIMITIVE_HEADER (2);
+ {
+ fast double y = (arg_flonum (1));
+ fast double x = (arg_flonum (2));
+ if ((x == 0) && (y == 0))
+ error_bad_range_arg (2);
+ FLONUM_RESULT (atan2 (y, x));
+ }
}
-DEFINE_PRIMITIVE ("LN-FLONUM", Prim_ln_flonum, 1, 1, 0)
-{
- extern double log();
- Primitive_1_Arg();
+DEFINE_PRIMITIVE ("FLONUM-SQRT", Prim_flonum_sqrt, 1, 1, 0)
+ RESTRICTED_TRANSCENDENTAL_FUNCTION (sqrt, (x >= 0))
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- if (Get_Float(Arg1) <= 0.0)
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- Flonum_Result(log(Get_Float(Arg1)));
-}
-
-DEFINE_PRIMITIVE ("SQRT-FLONUM", Prim_sqrt_flonum, 1, 1, 0)
+DEFINE_PRIMITIVE ("FLONUM-EXPT", Prim_flonum_expt, 2, 2, 0)
{
- extern double sqrt();
- double 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));
+ extern double pow ();
+ PRIMITIVE_HEADER (2);
+ {
+ fast double x = (arg_flonum (1));
+ fast double y = (arg_flonum (2));
+ if (x <= 0)
+ error_bad_range_arg (1);
+ FLONUM_RESULT (pow (x, y));
+ }
}
\f
-DEFINE_PRIMITIVE ("ZERO-FLONUM?", Prim_zero_flonum, 1, 1, 0)
+DEFINE_PRIMITIVE ("FLONUM?", Prim_flonum_p, 1, 1, 0)
{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- BOOLEAN_RESULT (Get_Float(Arg1) == 0.0);
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (FLONUM_P (ARG_REF (1))));
}
-DEFINE_PRIMITIVE ("POSITIVE-FLONUM?", Prim_positive_flonum, 1, 1, 0)
+DEFINE_PRIMITIVE ("FLONUM-INTEGER?", Prim_flonum_integer_p, 1, 1, 0)
{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- BOOLEAN_RESULT (Get_Float(Arg1) > 0.0);
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, FLONUM_P);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (flonum_integer_p (ARG_REF (1))));
}
-DEFINE_PRIMITIVE ("NEGATIVE-FLONUM?", Prim_negative_flonum, 1, 1, 0)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- BOOLEAN_RESULT (Get_Float(Arg1) < 0.0);
+#define FLONUM_CONVERSION(converter) \
+{ \
+ PRIMITIVE_HEADER (1); \
+ Set_Time_Zone (Zone_Math); \
+ CHECK_ARG (1, FLONUM_P); \
+ PRIMITIVE_RETURN (converter (ARG_REF (1))); \
}
-\f
-/* (COERCE-INTEGER-TO-FLONUM FIXNUM-OR-BIGNUM)
- 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.
-*/
-DEFINE_PRIMITIVE ("COERCE-INTEGER-TO-FLONUM", Prim_int_to_float, 1, 1, 0)
-{
- Primitive_1_Arg();
- Set_Time_Zone(Zone_Math);
- if (Type_Code(Arg1)==TC_FIXNUM)
- {
- long Int;
+DEFINE_PRIMITIVE ("FLONUM-FLOOR", Prim_flonum_floor, 1, 1, 0)
+ FLONUM_CONVERSION (flonum_floor)
+DEFINE_PRIMITIVE ("FLONUM-CEILING", Prim_flonum_ceiling, 1, 1, 0)
+ FLONUM_CONVERSION (flonum_ceiling)
+DEFINE_PRIMITIVE ("FLONUM-TRUNCATE", Prim_flonum_truncate, 1, 1, 0)
+ FLONUM_CONVERSION (FLONUM_TRUNCATE)
+DEFINE_PRIMITIVE ("FLONUM-ROUND", Prim_flonum_round, 1, 1, 0)
+ FLONUM_CONVERSION (flonum_round)
- Sign_Extend(Arg1, Int);
- return Allocate_Float((double) Int);
- }
- if (Type_Code(Arg1) == TC_BIG_FIXNUM)
- return Big_To_Float(Arg1);
- return Arg1;
-}
-\f
-/* (TRUNCATE-FLONUM FLONUM)
- Returns the integer corresponding to FLONUM when truncated.
- Returns NIL if FLONUM isn't a floating point number
-*/
-DEFINE_PRIMITIVE ("TRUNCATE-FLONUM", Prim_truncate_flonum, 1, 1, 0)
+DEFINE_PRIMITIVE ("FLONUM-TRUNCATE->EXACT", Prim_flonum_truncate_to_exact, 1, 1, 0)
{
- 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);
+ PRIMITIVE_HEADER (1);
+ Set_Time_Zone (Zone_Math);
+ CHECK_ARG (1, FLONUM_P);
+ PRIMITIVE_RETURN (FLONUM_TO_INTEGER (ARG_REF (1)));
}
-/* (ROUND-FLONUM FLONUM)
- Returns the integer found by rounding off FLONUM (upward), if
- FLONUM is a floating point number. Otherwise returns FLONUM.
-*/
-DEFINE_PRIMITIVE ("ROUND-FLONUM", Prim_round_flonum, 1, 1, 0)
-{
- 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);
+#define FLONUM_EXACT_CONVERSION(converter) \
+{ \
+ PRIMITIVE_HEADER (1); \
+ Set_Time_Zone (Zone_Math); \
+ CHECK_ARG (1, FLONUM_P); \
+ PRIMITIVE_RETURN (FLONUM_TO_INTEGER (converter (ARG_REF (1)))); \
}
+DEFINE_PRIMITIVE ("FLONUM-FLOOR->EXACT", Prim_flonum_floor_to_exact, 1, 1, 0)
+ FLONUM_EXACT_CONVERSION (flonum_floor)
+DEFINE_PRIMITIVE ("FLONUM-CEILING->EXACT", Prim_flonum_ceiling_to_exact, 1, 1, 0)
+ FLONUM_EXACT_CONVERSION (flonum_ceiling)
+DEFINE_PRIMITIVE ("FLONUM-ROUND->EXACT", Prim_flonum_round_to_exact, 1, 1, 0)
+ FLONUM_EXACT_CONVERSION (flonum_round)
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/future.c,v 9.27 1989/09/20 23:08:34 cph Rel $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/future.c,v 9.26 1988/08/15 20:47:36 cph Rel $
-
- Support code for futures
-*/
+/* Support code for futures */
#include "scheme.h"
#include "prims.h"
/* This is how we support future numbering for external metering */
#ifndef New_Future_Number
-#define New_Future_Number() NIL
+#define New_Future_Number() SHARP_F
#else
-Pointer Get_New_Future_Number();
+SCHEME_OBJECT Get_New_Future_Number ();
#endif
/*
-A future is a VECTOR starting with <determined?>, <locked?> and
+A future is a VECTOR starting with <determined?>, <locked?> and
<waiting queue / value>,
where <determined?> is #!false if no value is known yet,
DEFINE_PRIMITIVE ("TOUCH", Prim_touch, 1, 1, 0)
{
- Pointer Result;
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1, Result);
- return Result;
+ SCHEME_OBJECT result;
+ PRIMITIVE_HEADER (1);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), result);
+ PRIMITIVE_RETURN (result);
}
DEFINE_PRIMITIVE ("FUTURE?", Prim_future_p, 1, 1, 0)
{
- Primitive_1_Arg();
-
- return (Type_Code(Arg1) == TC_FUTURE) ? SHARP_T : NIL;
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (FUTURE_P (ARG_REF (1))));
}
\f
/* Utility setting routine for use by the various test and set if
long
Set_If_Equal(Base, Offset, New, Wanted)
- Pointer Base, Wanted, New;
+ SCHEME_OBJECT Base, Wanted, New;
long Offset;
{
Lock_Handle lock;
- Pointer Old_Value, Desired, Remember_Value;
+ SCHEME_OBJECT Old_Value, Desired, Remember_Value;
long success;
- Touch_In_Primitive(Wanted, Desired);
+ 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))
+ Remember_Value = MEMORY_REF (Base, Offset);
+ TOUCH_IN_PRIMITIVE(Remember_Value, Old_Value);
+ lock = Lock_Cell(MEMORY_LOC (Base, Offset));
+ if (Remember_Value != FAST_MEMORY_REF (Base, Offset))
{
Unlock_Cell(lock);
goto Try_Again;
}
if (Old_Value == Desired)
{
- Do_Store_No_Lock(Nth_Vector_Loc(Base, Offset), New);
+ Do_Store_No_Lock(MEMORY_LOC (Base, Offset), New);
success = true;
}
else
return success;
}
\f
-/* (SET-CAR-IF-EQ?! <CONS Cell> <New Value> <Old Value>)
- Replaces the CAR of <CONS Cell> with <New Value> if it used to contain
- <Old Value>. The value returned is either <CONS Cell> (if the modification
- takes place) or '() if it does not.
-*/
-DEFINE_PRIMITIVE ("SET-CAR-IF-EQ?!", Prim_set_car_if_eq, 3, 3, 0)
+DEFINE_PRIMITIVE ("SET-CAR-IF-EQ?!", Prim_set_car_if_eq, 3, 3,
+ "Replace the car of PAIR with NEW-VALUE iff it contains OLD-VALUE.\n\
+Return PAIR if so, otherwise return '().")
{
- Primitive_3_Args();
-
- Arg_1_Type(TC_LIST);
- if (Set_If_Equal(Arg1, CONS_CAR, Arg2, Arg3))
- {
- return Arg1;
- }
- else
+ PRIMITIVE_HEADER (3);
+ CHECK_ARG (1, PAIR_P);
{
- return NIL;
+ fast SCHEME_OBJECT pair = (ARG_REF (1));
+ if (Set_If_Equal (pair, CONS_CAR, (ARG_REF (2)), (ARG_REF (3))))
+ PRIMITIVE_RETURN (pair);
}
+ PRIMITIVE_RETURN (EMPTY_LIST);
}
-
-/* (SET-CDR-IF-EQ?! <CONS Cell> <New Value> <Old Value>)
- Replaces the CDR of <CONS Cell> with <New Value> if it used to contain
- <Old Value>. The value returned is either <CONS Cell> (if the modification
- takes place) or '() if it does not.
-*/
-DEFINE_PRIMITIVE ("SET-CDR-IF-EQ?!", Prim_set_cdr_if_eq, 3, 3, 0)
-{
- Primitive_3_Args();
- Arg_1_Type(TC_LIST);
- if (Set_If_Equal(Arg1, CONS_CDR, Arg2, Arg3))
- {
- return Arg1;
- }
- else
+DEFINE_PRIMITIVE ("SET-CDR-IF-EQ?!", Prim_set_cdr_if_eq, 3, 3,
+ "Replace the cdr of PAIR with NEW-VALUE iff it contains OLD-VALUE.\n\
+Return PAIR if so, otherwise return '().")
+{
+ PRIMITIVE_HEADER (3);
+ CHECK_ARG (1, PAIR_P);
{
- return NIL;
+ fast SCHEME_OBJECT pair = (ARG_REF (1));
+ if (Set_If_Equal (pair, CONS_CDR, (ARG_REF (2)), (ARG_REF (3))))
+ PRIMITIVE_RETURN (pair);
}
+ PRIMITIVE_RETURN (EMPTY_LIST);
}
-\f
+
/* (VECTOR-SET-IF-EQ?! <Vector> <Offset> <New Value> <Old Value>)
Replaces the <Offset>th element of <Vector> with <New Value> if it used
to contain <Old Value>. The value returned is either <Vector> (if
the modification takes place) or '() if it does not.
*/
-DEFINE_PRIMITIVE ("VECTOR-SET-IF-EQ?!", Prim_vector_set_if_eq, 4, 4, 0)
+DEFINE_PRIMITIVE ("VECTOR-SET-IF-EQ?!", Prim_vector_set_if_eq, 4, 4,
+ "Replace VECTOR's INDEX'th element with NEW-VALUE iff it contains OLD-VALUE.\n\
+Return VECTOR if so, otherwise return '().")
{
- 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
+ PRIMITIVE_HEADER (4);
+ CHECK_ARG (1, VECTOR_P);
{
- return NIL;
+ fast SCHEME_OBJECT vector = (ARG_REF (1));
+ if (Set_If_Equal
+ (vector,
+ ((arg_index_integer (2, (VECTOR_LENGTH (vector)))) + 1),
+ (ARG_REF (3)),
+ (ARG_REF (4))))
+ PRIMITIVE_RETURN (vector);
}
+ PRIMITIVE_RETURN (EMPTY_LIST);
}
-/* (SET-CXR-IF-EQ?! <Triple> <Offset> <New Value> <Old Value>)
- Replaces the <Offset>th CXR of <Triple> with <New Value> if it used to
- contain <Old Value>. The value returned is either <Triple> (if
- the modification takes place) or '() if it does not.
-*/
-DEFINE_PRIMITIVE ("SET-CXR-IF-EQ?!", Prim_set_cxr_if_eq, 4, 4, 0)
+DEFINE_PRIMITIVE ("SET-CXR-IF-EQ?!", Prim_set_cxr_if_eq, 4, 4,
+ "Replace HUNK3's INDEX'th element with NEW-VALUE iff it contains OLD-VALUE.\n\
+Return HUNK3 if so, otherwise return '().")
{
- 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
+ PRIMITIVE_HEADER (4);
+ CHECK_ARG (1, HUNK3_P);
{
- return NIL;
+ fast SCHEME_OBJECT hunk3 = (ARG_REF (1));
+ if (Set_If_Equal
+ (hunk3,
+ ((arg_index_integer (2, 3)) + 1),
+ (ARG_REF (3)),
+ (ARG_REF (4))))
+ PRIMITIVE_RETURN (hunk3);
}
+ PRIMITIVE_RETURN (EMPTY_LIST);
}
\f
-/* (FUTURE-REF <Future> <Offset>)
- Returns the <Offset>th slot from the future object. This is
- the equivalent of SYSTEM-VECTOR-REF but works only on future
- objects and doesn't touch.
-*/
-DEFINE_PRIMITIVE ("FUTURE-REF", Prim_future_ref, 2, 2, 0)
+DEFINE_PRIMITIVE ("FUTURE-SIZE", Prim_future_size, 1, 1,
+ "Return the number of elements in FUTURE.\n\
+This is similar to SYSTEM-VECTOR-SIZE,\n\
+but works only on futures and doesn't touch them.")
{
- 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);
+ PRIMITIVE_HEADER (1)
+ CHECK_ARG (1, FUTURE_P);
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (VECTOR_LENGTH (ARG_REF (1))));
}
-/* (FUTURE-SET! <Future> <Offset> <New Value>)
- Modifies the <Offset>th slot from the future object. This is
- the equivalent of SYSTEM-VECTOR-SET! but works only on future
- objects and doesn't touch.
-*/
-DEFINE_PRIMITIVE ("FUTURE-SET!", Prim_future_set, 3, 3, 0)
+DEFINE_PRIMITIVE ("FUTURE-REF", Prim_future_ref, 2, 2,
+ "Return FUTURE's INDEX'th element.\n\
+This is similar to SYSTEM-VECTOR-REF,\n\
+but works only on futures and doesn't touch them.")
{
- 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;
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, FUTURE_P);
+ {
+ fast SCHEME_OBJECT future = (ARG_REF (1));
+ PRIMITIVE_RETURN
+ (VECTOR_REF
+ (future, (arg_index_integer (2, (VECTOR_LENGTH (future))))));
+ }
}
-/* (FUTURE-SIZE <Future>)
- Returns the number of slots in the future object. This is
- the equivalent of SYSTEM-VECTOR-SIZE but works only on future
- objects and doesn't touch.
-*/
-DEFINE_PRIMITIVE ("FUTURE-SIZE", Prim_future_size, 1, 1, 0)
+DEFINE_PRIMITIVE ("FUTURE-SET!", Prim_future_set, 3, 3,
+ "Modify FUTURE's INDEX'th element to be VALUE.\n\
+This is similar to SYSTEM-VECTOR-SET!,\n\
+but works only on futures and doesn't touch them.")
{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_FUTURE);
- return Make_Unsigned_Fixnum(Vector_Length(Arg1));
+ PRIMITIVE_HEADER (3);
+ CHECK_ARG (1, FUTURE_P);
+ {
+ fast SCHEME_OBJECT future = (ARG_REF (1));
+ fast long index = (arg_index_integer (2, (VECTOR_LENGTH (future))));
+ fast SCHEME_OBJECT result = (VECTOR_REF (future, index));
+ VECTOR_SET (future, index, (ARG_REF (3)));
+ PRIMITIVE_RETURN (result);
+ }
}
\f
-/* (LOCK-FUTURE! <Future>)
- Sets the lock flag on the future object, so that it won't be
- spliced-out by the garbage collector. Returns #!false if the
- argument isn't a future (might have been determined in the
- interim), #!TRUE if it is a future. Hangs as long as necessary
- for the lock to take, since Scheme code operates while locked.
- Opposite of UNLOCK-FUTURE!.
-*/
-
-DEFINE_PRIMITIVE ("LOCK-FUTURE!", Prim_lock_future, 1, 1, 0)
+DEFINE_PRIMITIVE ("LOCK-FUTURE!", Prim_lock_future, 1, 1,
+ "Set the lock flag on FUTURE.\n\
+This flag prevents FUTURE from being spliced out by the garbage collector.\n\
+If FUTURE is not a future, return #F immediately,\n\
+otherwise return #T after the lock has been set.\n\
+Will wait as long as necessary for the lock to be set.")
{
- Primitive_1_Arg();
-
- if (Type_Code(Arg1) != TC_FUTURE)
+ PRIMITIVE_HEADER (1);
{
- return NIL;
+ fast SCHEME_OBJECT future = (ARG_REF (1));
+ if (! (FUTURE_P (future)))
+ PRIMITIVE_RETURN (SHARP_F);
+ while (1)
+ {
+ if (INTERRUPT_PENDING_P (INT_Mask))
+ signal_interrupt_from_primitive ();
+ {
+ fast SCHEME_OBJECT lock;
+ SWAP_POINTERS ((MEMORY_LOC (future, FUTURE_LOCK)), SHARP_T, lock);
+ if (lock == SHARP_F)
+ PRIMITIVE_RETURN (SHARP_T);
+ }
+ Sleep (CONTENTION_DELAY);
+ }
}
- while (!(INTERRUPT_PENDING_P(INT_Mask)))
- {
- if (Swap_Pointers(Nth_Vector_Loc(Arg1, FUTURE_LOCK),
- SHARP_T) == NIL)
- {
- return SHARP_T;
- }
- else
- {
- Sleep(CONTENTION_DELAY);
- }
- }
- Primitive_Interrupt();
}
-/* (UNLOCK-FUTURE! <Future>)
- Clears the lock flag on a locked future object, otherwise nothing.
-*/
-
-DEFINE_PRIMITIVE ("UNLOCK-FUTURE!", Prim_unlock_future, 1, 1, 0)
+DEFINE_PRIMITIVE ("UNLOCK-FUTURE!", Prim_unlock_future, 1, 1,
+ "Clear the lock flag on FUTURE.\n\
+If FUTURE is not a future, return #F immediately,\n\
+otherwise return #T after the lock has been cleared.")
{
- Primitive_1_Arg();
-
- if (Type_Code(Arg1) != TC_FUTURE)
- {
- return NIL;
- }
- if (!Future_Is_Locked(Arg1))
- {
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- }
- else
+ PRIMITIVE_HEADER (1);
{
- Vector_Set(Arg1, FUTURE_LOCK, NIL);
- return SHARP_T;
+ fast SCHEME_OBJECT future = (ARG_REF (1));
+ if (! (FUTURE_P (future)))
+ PRIMITIVE_RETURN (SHARP_F);
+ if (! (Future_Is_Locked (future)))
+ error_wrong_type_arg (1);
+ MEMORY_SET (future, FUTURE_LOCK, SHARP_F);
+ PRIMITIVE_RETURN (SHARP_T);
}
}
-\f
-/* (FUTURE->VECTOR <Future>)
- Create a COPY of <future> but with type code vector.
-*/
-DEFINE_PRIMITIVE ("FUTURE->VECTOR", Prim_future_to_vector, 1, 1, 0)
-{
- Pointer Result;
- long Size, i;
- Primitive_1_Arg();
- Result = Make_Pointer(TC_VECTOR, Free);
- if (Type_Code(Arg1) != TC_FUTURE)
- {
- return NIL;
- }
- Size = Vector_Length(Arg1);
- Primitive_GC_If_Needed(Size + 1);
- for (i = 0; i <= Size; i++)
+DEFINE_PRIMITIVE ("FUTURE->VECTOR", Prim_future_to_vector, 1, 1,
+ "Return a newly-allocated vector containing FUTURE's elements.
+If FUTURE is not a future, return #F instead.")
+{
+ PRIMITIVE_HEADER (1);
{
- *Free++ = Vector_Ref(Arg1, i);
+ SCHEME_OBJECT future = (ARG_REF (1));
+ if (! (FUTURE_P (future)))
+ PRIMITIVE_RETURN (SHARP_F);
+ {
+ long length = (VECTOR_LENGTH (future));
+ fast SCHEME_OBJECT * scan_source = (MEMORY_LOC (future, 1));
+ fast SCHEME_OBJECT * end_source = (scan_source + length);
+ SCHEME_OBJECT result =
+ (allocate_marked_vector (TC_VECTOR, length, true));
+ fast SCHEME_OBJECT * scan_result = (MEMORY_LOC (result, 1));
+ while (scan_source < end_source)
+ (*scan_result++) = (MEMORY_FETCH (*scan_source++));
+ PRIMITIVE_RETURN (result);
+ }
}
- return Result;
}
DEFINE_PRIMITIVE ("NON-TOUCHING-EQ?", Prim_future_eq, 2, 2, 0)
{
- Primitive_2_Args();
-
- return ((Arg1==Arg2) ? SHARP_T : NIL);
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((ARG_REF (1)) == (ARG_REF (2))));
}
\f
/* MAKE-INITIAL-PROCESS is called to create a small stacklet which
DEFINE_PRIMITIVE ("MAKE-INITIAL-PROCESS", Prim_make_initial_process, 1, 1, 0)
{
- Pointer Result;
+ SCHEME_OBJECT Result;
long Useful_Length;
- Primitive_1_Arg();
+ PRIMITIVE_HEADER (1);
- Result = Make_Pointer(TC_CONTROL_POINT, Free);
+ Result = MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Free);
Useful_Length = (3 * CONTINUATION_SIZE) + STACK_ENV_EXTRA_SLOTS + 1;
#ifdef USE_STACKLETS
-{
- long Allocated_Length, Waste_Length;
-
- Allocated_Length = (Useful_Length + STACKLET_SLACK + STACKLET_HEADER_SIZE);
- if (Allocated_Length < Default_Stacklet_Size)
- {
- Allocated_Length = Default_Stacklet_Size;
- Waste_Length = ((Allocated_Length + 1) -
- (Useful_Length + STACKLET_HEADER_SIZE));
- }
- else
{
- Waste_Length = (STACKLET_SLACK + 1);
+ long Allocated_Length, Waste_Length;
+
+ Allocated_Length = (Useful_Length + STACKLET_SLACK + STACKLET_HEADER_SIZE);
+ if (Allocated_Length < Default_Stacklet_Size)
+ {
+ Allocated_Length = Default_Stacklet_Size;
+ Waste_Length = ((Allocated_Length + 1) -
+ (Useful_Length + STACKLET_HEADER_SIZE));
+ }
+ else
+ {
+ Waste_Length = (STACKLET_SLACK + 1);
+ }
+ Primitive_GC_If_Needed(Allocated_Length + 1);
+ Free[STACKLET_LENGTH] =
+ MAKE_POINTER_OBJECT (TC_MANIFEST_VECTOR, Allocated_Length);
+ Free[STACKLET_REUSE_FLAG] = SHARP_T;
+ Free[STACKLET_UNUSED_LENGTH] =
+ MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Waste_Length);
+ Free += (Allocated_Length + 1) - Useful_Length;
}
- Primitive_GC_If_Needed(Allocated_Length + 1);
- Free[STACKLET_LENGTH] =
- Make_Pointer(TC_MANIFEST_VECTOR, Allocated_Length);
- Free[STACKLET_REUSE_FLAG] = SHARP_T;
- Free[STACKLET_UNUSED_LENGTH] =
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Waste_Length);
- Free += (Allocated_Length + 1) - Useful_Length;
-}
-\f
+
#else /* not USE_STACKLETS */
Free[STACKLET_LENGTH] =
- Make_Non_Pointer(TC_MANIFEST_VECTOR,
- Useful_Length + STACKLET_HEADER_SIZE - 1);
- Free[STACKLET_REUSE_FLAG] = NIL;
- Free[STACKLET_UNUSED_LENGTH] =
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
+ MAKE_OBJECT (TC_MANIFEST_VECTOR, Useful_Length + STACKLET_HEADER_SIZE - 1);
+ Free[STACKLET_REUSE_FLAG] = SHARP_F;
+ Free[STACKLET_UNUSED_LENGTH] = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0);
Free += STACKLET_HEADER_SIZE;
#endif /* USE_STACKLETS */
- Free[CONTINUATION_EXPRESSION] = MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK());
- Free[CONTINUATION_RETURN_CODE] =
- Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_INT_MASK);
+ Free[CONTINUATION_EXPRESSION] = LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK());
+ Free[CONTINUATION_RETURN_CODE] =
+ MAKE_OBJECT (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_EXPRESSION] = SHARP_F;
+ Free[CONTINUATION_RETURN_CODE] =
+ MAKE_OBJECT (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++ = (ARG_REF (1));
+ Free[CONTINUATION_EXPRESSION] = (ARG_REF (1)); /* For testing & debugging */
+ Free[CONTINUATION_RETURN_CODE] =
+ MAKE_OBJECT (TC_RETURN_CODE, RC_END_OF_COMPUTATION);
Free += CONTINUATION_SIZE;
- return Result;
+ PRIMITIVE_RETURN (Result);
}
\f
/*
DEFINE_PRIMITIVE ("MAKE-CHEAP-FUTURE", Prim_make_cheap_future, 3, 3, 0)
{
- Pointer The_Future;
- Pointer IO_Vector, IO_Cons, IO_Hunk3, Empty_Queue, IO_String;
- Primitive_3_Args();
-
- Primitive_GC_If_Needed(21);
-
- 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++ = Make_Unsigned_Fixnum(0);
-
- IO_Cons = Make_Pointer(TC_LIST,Free);
- *Free++ = Make_Unsigned_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,10);
- *Free++ = NIL; /* No value yet. */
- *Free++ = NIL; /* Not locked. */
- *Free++ = Empty_Queue; /* Put the empty queue here. */
- *Free++ = Arg1; /* The process slot. */
- *Free++ = SHARP_T; /* Status slot. */
- *Free++ = Arg2; /* Original code. */
- *Free++ = IO_Vector; /* Put the I/O system stuff here. */
- *Free++ = NIL; /* Waiting on list. */
- *Free++ = New_Future_Number(); /* Metering number. */
- *Free++ = NIL; /* User data slot */
-
- return The_Future;
+ PRIMITIVE_HEADER (3);
+ {
+ fast SCHEME_OBJECT future = (allocate_marked_vector (TC_FUTURE, 10, true));
+ FAST_MEMORY_SET (future, FUTURE_IS_DETERMINED, SHARP_F);
+ FAST_MEMORY_SET (future, FUTURE_LOCK, SHARP_F);
+ FAST_MEMORY_SET (future, FUTURE_QUEUE, (cons (EMPTY_LIST, EMPTY_LIST)));
+ FAST_MEMORY_SET (future, FUTURE_PROCESS, (ARG_REF (1)));
+ FAST_MEMORY_SET (future, FUTURE_STATUS, SHARP_T);
+ FAST_MEMORY_SET (future, FUTURE_ORIG_CODE, (ARG_REF (2)));
+ /* Put the I/O system stuff here. */
+ FAST_MEMORY_SET
+ (future,
+ FUTURE_PRIVATE,
+ (make_vector
+ (1,
+ (hunk3_cons
+ (SHARP_F,
+ (ARG_REF (3)),
+ (cons ((LONG_TO_UNSIGNED_FIXNUM (0)),
+ (char_pointer_to_string ("")))))),
+ true)));
+ FAST_MEMORY_SET (future, FUTURE_WAITING_ON, EMPTY_LIST);
+ FAST_MEMORY_SET (future, FUTURE_METERING, (New_Future_Number ()));
+ FAST_MEMORY_SET (future, FUTURE_USER, SHARP_F);
+ PRIMITIVE_RETURN (future);
+ }
}
-
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/futures.h,v 9.26 1989/09/20 23:08:39 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/futures.h,v 9.25 1989/05/31 01:50:14 jinx Rel $
- *
- * This file contains macros useful for dealing with futures
- */
-\f
-/* Data structure definition */
-
-/* The IS_DETERMINED slot has one of the following type of values:
- * #!FALSE if the value is not yet known
- * #!TRUE if the value is known and the garbage collector is free
- * to remove the future object in favor of its value everywhere
- * else the value is known, but the GC must leave the future object
-*/
-
-#define FUTURE_VECTOR_HEADER 0
-#define FUTURE_IS_DETERMINED 1
-#define FUTURE_LOCK 2
-#define FUTURE_VALUE 3 /* if known, else */
-#define FUTURE_QUEUE 3 /* tasks waiting for value */
-#define FUTURE_PROCESS 4
-#define FUTURE_STATUS 5
-#define FUTURE_ORIG_CODE 6
-#define FUTURE_PRIVATE 7
-#define FUTURE_WAITING_ON 8
-#define FUTURE_METERING 9
-#define FUTURE_USER 10
-\f
-#define Future_Is_Locked(P) \
- (Vector_Ref((P), FUTURE_LOCK) != NIL)
-
-#define Future_Has_Value(P) \
- (Vector_Ref((P), FUTURE_IS_DETERMINED) != NIL)
-
-#define Future_Value(P) \
- Vector_Ref((P), FUTURE_VALUE)
-
-#define Future_Spliceable(P) \
- ((Vector_Ref((P), FUTURE_IS_DETERMINED) == SHARP_T) && \
- (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) != SHARP_T))
-
-#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; \
- \
- Value = (P); \
- while (OBJECT_TYPE(Value) == TC_FUTURE) \
- { \
- if (Future_Has_Value(Value)) \
- { \
- if (Future_Is_Keep_Slot(Value)) \
- { \
- Log_Touch_Of_Future(Value); \
- } \
- Value = Future_Value(Value); \
- } \
- else \
- { \
- Val = Value; \
- PRIMITIVE_ABORT(PRIM_TOUCH); \
- } \
- } \
- To_Where = Value; \
-}
-
-#define TOUCH_SETUP(object) \
-{ \
- Save_Cont(); \
- Will_Push(STACK_ENV_EXTRA_SLOTS + 2); \
- Push(object); \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER + 1); \
- Pushed(); \
-}
+/* This file contains macros useful for dealing with futures */
\f
-/* NOTES ON FUTURES, derived from the rest of the interpreter code */
+/* NOTES ON FUTURES, derived from the rest of the interpreter code
-/* ASSUMPTION: The syntaxer is hereby assumed NEVER to generate 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.
never contain FUTUREs except possibly as the thunks (which are handled
by the apply code).
-*/
-
-/* OPTIMIZATIONS (?):
+ 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
(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:
+ KNOWN PROBLEMS:
(1) Garbage collector should be modified to splice out futures. DONE.
(2) Purify should be looked at and we should decide what to do about
become constant but not pure).
(3) Look at Impurify and Side-Effect-Impurify to see if futures
- affect them in any way.
-*/
+ affect them in any way. */
+\f
+/* Data structure definition */
+
+/* The IS_DETERMINED slot has one of the following type of values:
+ #F if the value is not yet known;
+ #T 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_PROCESS 4
+#define FUTURE_STATUS 5
+#define FUTURE_ORIG_CODE 6
+#define FUTURE_PRIVATE 7
+#define FUTURE_WAITING_ON 8
+#define FUTURE_METERING 9
+#define FUTURE_USER 10
+
+#define Future_Is_Locked(P) \
+ ((MEMORY_REF ((P), FUTURE_LOCK)) != SHARP_F)
+
+#define Future_Has_Value(P) \
+ ((MEMORY_REF ((P), FUTURE_IS_DETERMINED)) != SHARP_F)
+
+#define Future_Value(P) \
+ (MEMORY_REF ((P), FUTURE_VALUE))
+
+#define Future_Spliceable(P) \
+ (((MEMORY_REF ((P), FUTURE_IS_DETERMINED)) == SHARP_T) && \
+ ((MEMORY_REF ((P), FUTURE_LOCK)) == SHARP_F))
+
+#define Future_Is_Keep_Slot(P) \
+ (! (BOOLEAN_P (MEMORY_REF ((P), FUTURE_IS_DETERMINED))))
+
+#ifndef COMPILE_FUTURES
+
+#define TOUCH_IN_PRIMITIVE(P, To_Where) To_Where = (P)
+#define TOUCH_SETUP(object) Microcode_Termination (TERM_TOUCH)
+#define Log_Touch_Of_Future(F) {}
+#define Call_Future_Logging()
+#define Must_Report_References() (false)
+#define FUTURE_VARIABLE_SPLICE(P, Offset, Value)
+
+#else /* COMPILE_FUTURES */
+\f
+/* 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) \
+{ \
+ SCHEME_OBJECT Value = (P); \
+ while (FUTURE_P (Value)) \
+ { \
+ if (Future_Has_Value (Value)) \
+ { \
+ if (Future_Is_Keep_Slot (Value)) \
+ { \
+ Log_Touch_Of_Future (Value); \
+ } \
+ Value = (Future_Value (Value)); \
+ } \
+ else \
+ { \
+ Val = Value; \
+ PRIMITIVE_ABORT (PRIM_TOUCH); \
+ } \
+ } \
+ (To_Where) = Value; \
+}
+
+#define TOUCH_SETUP(object) \
+{ \
+ Save_Cont (); \
+ Will_Push (STACK_ENV_EXTRA_SLOTS + 2); \
+ Push (object); \
+ Push (Get_Fixed_Obj_Slot (System_Scheduler)); \
+ Push (STACK_FRAME_HEADER + 1); \
+ Pushed (); \
+}
+
+#define FUTURE_VARIABLE_SPLICE(P, Offset, Value) \
+{ \
+ while ((FUTURE_P (Value)) && (Future_Spliceable (Value))) \
+ { \
+ Value = (Future_Value (Value)); \
+ MEMORY_SET (P, Offset, Value); \
+ } \
+}
\f
#ifdef FUTURE_LOGGING
-#define Touched_Futures_Vector() Get_Fixed_Obj_Slot(Touched_Futures)
+#define Touched_Futures_Vector() (Get_Fixed_Obj_Slot (Touched_Futures))
#define Logging_On() \
-(Valid_Fixed_Obj_Vector() && Touched_Futures_Vector())
+ ((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
-*/
+ not yet been informed. */
+
#define Log_Touch_Of_Future(F) \
-if (Logging_On()) \
{ \
- Pointer TFV; \
- long Count; \
- \
- TFV = Touched_Futures_Vector(); \
- Count = Get_Integer(User_Vector_Ref(TFV, 0)) + 1; \
- User_Vector_Ref(TFV, 0) = MAKE_UNSIGNED_FIXNUM(Count); \
- if (Count < Vector_Length(TFV)) \
- { \
- User_Vector_Ref(TFV, Count) = Make_New_Pointer(TC_VECTOR, F); \
- } \
+ if (Logging_On ()) \
+ { \
+ SCHEME_OBJECT TFV = (Touched_Futures_Vector ()); \
+ long Count = \
+ ((UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF (TFV, 0))) + 1); \
+ (VECTOR_REF (TFV, 0)) = (LONG_TO_UNSIGNED_FIXNUM (Count)); \
+ if (Count < (VECTOR_LENGTH (TFV))) \
+ (VECTOR_REF (TFV, Count)) = (OBJECT_NEW_TYPE (TC_VECTOR, F)); \
+ } \
}
/* Call_Future_Logging calls a user defined scheme routine if the vector
- of touched futures has a nonzero length.
-*/
+ of touched futures has a nonzero length. */
+
#define Must_Report_References() \
-( (Logging_On()) && \
- (Get_Integer(User_Vector_Ref(Touched_Futures_Vector(), 0)) > 0))
+ ((Logging_On ()) && \
+ ((UNSIGNED_FIXNUM_TO_LONG \
+ (VECTOR_REF ((Touched_Futures_Vector ()), 0))) \
+ > 0))
-#define Call_Future_Logging() \
+#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; \
+ 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 ()) = SHARP_F; \
goto Apply_Non_Trapping; \
}
#else /* not FUTURE_LOGGING */
-#define Log_Touch_Of_Future(F) { }
+#define Log_Touch_Of_Future(F) {}
#define Call_Future_Logging()
#define Must_Report_References() (false)
#endif /* FUTURE_LOGGING */
-
-#define FUTURE_VARIABLE_SPLICE(P, Offset, Value) \
-{ \
- while ((OBJECT_TYPE(Value) == TC_FUTURE) && Future_Spliceable(Value)) \
- { \
- Value = Future_Value(Value); \
- Vector_Set(P, Offset, Value); \
- } \
-}
-\f
-#else /* not COMPILE_FUTURES */
-
-#define Touch_In_Primitive(P, To_Where) To_Where = (P)
-#define TOUCH_SETUP(object) Microcode_Termination(TERM_TOUCH)
-#define Log_Touch_Of_Future(F) { }
-#define Call_Future_Logging()
-#define Must_Report_References() (false)
-#define FUTURE_VARIABLE_SPLICE(P, Offset, Value)
-
#endif /* COMPILE_FUTURES */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gc.h,v 9.28 1989/07/05 18:34:26 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gc.h,v 9.29 1989/09/20 23:08:43 cph Exp $
*
* Garbage collection related macros of sufficient utility to be
* included in all compilations.
GC_Type_Map[TC] : \
(INVALID_TYPE_CODE(TC)))
-#define GC_Type(Object) GC_Type_Code(OBJECT_TYPE(Object))
+#define GC_Type(Object) GC_Type_Code(OBJECT_TYPE (Object))
#define GC_Type_Non_Pointer(Object) (GC_Type(Object) == GC_Non_Pointer)
#define GC_Type_Cell(Object) (GC_Type(Object) == GC_Cell)
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gccode.h,v 9.41 1989/09/20 23:08:46 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gccode.h,v 9.40 1989/06/08 00:24:34 jinx Rel $
- *
- * 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.
- *
- */
+/* This file contains the macros for use in code which does GC-like
+ loops over memory. It is only included in a few files, unlike
+ gc.h which contains general purpose macros and constants. */
\f
-/* 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.
-*/
+/* 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(OBJECT_TYPE(P))
+ switch (OBJECT_TYPE (P))
#define case_simple_Non_Pointer \
case TC_NULL: \
TC_MANIFEST_SPECIAL_NM_VECTOR
TC_REFERENCE_TRAP
TC_MANIFEST_CLOSURE
- TC_LINKAGE_SECTION
-*/
+ TC_LINKAGE_SECTION */
#define case_compiled_entry_point \
case TC_COMPILED_ENTRY
case_Fasdump_Pair
/* Missing pair types (must be treated specially):
- TC_WEAK_CONS
-*/
+ TC_WEAK_CONS */
#define case_Triple \
case TC_COMBINATION_2: \
case TC_PCOMB2
/* Missing triple types (must be treated specially):
- TC_VARIABLE
-*/
+ TC_VARIABLE */
\f
#define case_Quadruple \
case TC_QUAD
/* Missing vector types (must be treated specially):
TC_FUTURE
- TC_BIG_FLONUM
-*/
+ TC_BIG_FLONUM */
\f
-extern void gc_death();
-extern char gc_death_message_buffer[];
+extern void gc_death ();
+extern char gc_death_message_buffer [];
/* Assumption: A call to GC_BAD_TYPE is followed by the non-pointer code. */
#define GC_BAD_TYPE(name) \
do \
{ \
- sprintf(gc_death_message_buffer, \
- "%s: bad type code (0x%02x)", \
- (name), (OBJECT_TYPE(Temp))); \
- gc_death(TERM_INVALID_TYPE_CODE, gc_death_message_buffer, \
- Scan, To); \
+ sprintf \
+ (gc_death_message_buffer, \
+ "%s: bad type code (0x%02x)", \
+ (name), \
+ (OBJECT_TYPE (Temp))); \
+ gc_death \
+ (TERM_INVALID_TYPE_CODE, \
+ gc_death_message_buffer, \
+ Scan, \
+ To); \
/*NOTREACHED*/ \
} while (0)
#define GC_BAD_TYPE(name) \
do \
{ \
- fprintf(stderr, \
- "\n%s: bad type code (0x%02x) 0x%lx", \
- (name), (OBJECT_TYPE(Temp)), Temp); \
- fprintf(stderr, \
- " -- Treating as non-pointer.\n"); \
+ fprintf \
+ (stderr, \
+ "\n%s: bad type code (0x%02x) 0x%lx", \
+ (name), \
+ (OBJECT_TYPE (Temp)), \
+ Temp); \
+ fprintf (stderr, " -- Treating as non-pointer.\n"); \
/* Fall through */ \
} while (0)
#define GC_Consistency_Check(In_GC) \
{ \
- if And2(In_GC, Consistency_Check) \
+ if And2 (In_GC, Consistency_Check) \
{ \
if ((Old >= Highest_Allocated_Address) || (Old < Heap)) \
{ \
- sprintf(gc_death_message_buffer, \
- "setup_internal: out of range pointer (0x%lx)", \
- Temp); \
- gc_death(TERM_EXIT, gc_death_message_buffer, Scan, To); \
+ sprintf \
+ (gc_death_message_buffer, \
+ "setup_internal: out of range pointer (0x%lx)", \
+ Temp); \
+ gc_death (TERM_EXIT, gc_death_message_buffer, Scan, To); \
/*NOTREACHED*/ \
} \
} \
#define Normal_BH(In_GC, then_what) \
{ \
- if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART) \
+ if (BROKEN_HEART_P (*Old)) \
{ \
- *Scan = Make_New_Pointer(OBJECT_TYPE(Temp), *Old); \
+ *Scan = (MAKE_OBJECT_FROM_OBJECTS (Temp, (*Old))); \
then_what; \
} \
}
#define Setup_Internal(In_GC, Transport_Code, Already_Relocated_Code) \
{ \
- GC_Consistency_Check(In_GC); \
+ GC_Consistency_Check (In_GC); \
if (Old >= Low_Constant) \
- { \
continue; \
- } \
Already_Relocated_Code; \
- New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
+ New_Address = (MAKE_BROKEN_HEART (To)); \
Transport_Code; \
}
#define Setup_Pointer(In_GC, Transport_Code) \
{ \
- Setup_Internal(In_GC, Transport_Code, Normal_BH(In_GC, continue)); \
+ Setup_Internal (In_GC, Transport_Code, Normal_BH (In_GC, continue)); \
}
#define Pointer_End() \
{ \
- *Get_Pointer(Temp) = New_Address; \
- *Scan = Make_New_Pointer(Type_Code(Temp), New_Address); \
+ (* (OBJECT_ADDRESS (Temp))) = New_Address; \
+ (* Scan) = (MAKE_OBJECT_FROM_OBJECTS (Temp, New_Address)); \
}
\f
/* GC Type handlers. These do the actual work. */
#define Transport_Cell() \
{ \
- *To++ = *Old; \
- Pointer_End(); \
+ (*To++) = (*Old); \
+ Pointer_End (); \
}
#define Transport_Pair() \
{ \
- *To++ = *Old++; \
- *To++ = *Old; \
- Pointer_End(); \
+ (*To++) = (*Old++); \
+ (*To++) = (*Old); \
+ Pointer_End (); \
}
#define Transport_Triple() \
{ \
- *To++ = *Old++; \
- *To++ = *Old++; \
- *To++ = *Old; \
- Pointer_End(); \
+ (*To++) = (*Old++); \
+ (*To++) = (*Old++); \
+ (*To++) = (*Old); \
+ Pointer_End (); \
}
#define Transport_Quadruple() \
{ \
- *To++ = *Old++; \
- *To++ = *Old++; \
- *To++ = *Old++; \
- *To++ = *Old; \
- Pointer_End(); \
+ (*To++) = (*Old++); \
+ (*To++) = (*Old++); \
+ (*To++) = (*Old++); \
+ (*To++) = (*Old); \
+ Pointer_End (); \
}
\f
#ifndef In_Fasdump
-/* The Get_Integer below gets the length of the vector.
- Vector_Length(Temp) cannot be used because Temp does
+/* The OBJECT_DATUM 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.
- */
+ "middle" of vectors. */
#define Real_Transport_Vector() \
{ \
- Pointer *Saved_Scan; \
+ SCHEME_OBJECT *Saved_Scan; \
\
Saved_Scan = Scan; \
- Scan = To + 1 + OBJECT_DATUM(*Old); \
+ Scan = (To + 1 + (OBJECT_DATUM (*Old))); \
if ((Consistency_Check) && \
(Scan >= Low_Constant) && \
(To < Low_Constant)) \
- { \
- sprintf(gc_death_message_buffer, \
- "real_transport_vector: vector length too large (%d)", \
- OBJECT_DATUM(*Old)); \
- gc_death(TERM_EXIT, gc_death_message_buffer, Saved_Scan, To); \
- } \
+ { \
+ sprintf \
+ (gc_death_message_buffer, \
+ "real_transport_vector: vector length too large (%d)", \
+ (OBJECT_DATUM (*Old))); \
+ gc_death (TERM_EXIT, gc_death_message_buffer, Saved_Scan, To); \
+ } \
while (To != Scan) \
- { \
- *To++ = *Old++; \
- } \
+ (*To++) = (*Old++); \
Scan = Saved_Scan; \
}
#define Real_Transport_Vector() \
{ \
- Pointer *Saved_Scan; \
+ SCHEME_OBJECT * Saved_Scan; \
\
Saved_Scan = Scan; \
- Scan = To + 1 + Get_Integer(*Old); \
+ Scan = (To + 1 + (OBJECT_DATUM (*Old))); \
if (Scan >= Fixes) \
- { \
- Scan = Saved_Scan; \
- NewFree = To; \
- Fixup = Fixes; \
- return (PRIM_INTERRUPT); \
- } \
+ { \
+ Scan = Saved_Scan; \
+ NewFree = To; \
+ Fixup = Fixes; \
+ return (PRIM_INTERRUPT); \
+ } \
while (To != Scan) \
- { \
- *To++ = *Old++; \
- } \
+ (*To++) = (*Old++); \
Scan = Saved_Scan; \
}
\f
#define Transport_Vector() \
{ \
-Move_Vector: \
- Real_Transport_Vector(); \
- Pointer_End(); \
+ Move_Vector: \
+ Real_Transport_Vector (); \
+ Pointer_End (); \
}
#ifdef FLOATING_ALIGNMENT
#define Transport_Flonum() \
{ \
- Align_Float(To); \
- New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
- Real_Transport_Vector(); \
- Pointer_End(); \
+ ALIGN_FLOAT (To); \
+ New_Address = (MAKE_BROKEN_HEART (To)); \
+ Real_Transport_Vector (); \
+ Pointer_End (); \
}
#else
#define Transport_Future() \
{ \
- if (!(Future_Spliceable(Temp))) \
+ if (! (Future_Spliceable (Temp))) \
goto Move_Vector; \
- *Scan = Future_Value(Temp); \
+ (*Scan) = (Future_Value (Temp)); \
Scan -= 1; \
}
\f
the normal GC pass, weak cons cells are not copied in the normal
manner. Instead the following structure is built:
- Old Space | New Space
+ Old Space | New Space
_______________________ | _______________________
|Broken | New | | | NULL | Old CAR data |
|Heart | Location ======|==>| | |
| type | chain | | | |
|_____________________| | |_____________________|
-*/
+ */
-extern Pointer Weak_Chain;
+extern SCHEME_OBJECT Weak_Chain;
#define Transport_Weak_Cons() \
{ \
- long Car_Type; \
- \
- Car_Type = OBJECT_TYPE(*Old); \
- *To++ = Make_New_Pointer(TC_NULL, *Old); \
+ long Car_Type = (OBJECT_TYPE (*Old)); \
+ (*To++) = (OBJECT_NEW_TYPE (TC_NULL, (*Old))); \
Old += 1; \
- *To++ = *Old; \
- *Old = Make_New_Pointer(Car_Type, Weak_Chain); \
+ (*To++) = (*Old); \
+ *Old = (OBJECT_NEW_TYPE (Car_Type, Weak_Chain)); \
Weak_Chain = Temp; \
- Pointer_End(); \
+ Pointer_End (); \
}
-\f
+
/* Special versions of the above for DumpLoop in Fasdump. This code
only differs from the code above in that it must check whether
- there is enough space to remember the fixup.
- */
+ there is enough space to remember the fixup. */
#define Fasdump_Setup_Pointer(Extra_Code, BH_Code) \
{ \
\
/* It must be transported to New Space */ \
\
- New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
+ New_Address = (MAKE_BROKEN_HEART (To)); \
if ((Fixes - To) < FASDUMP_FIX_BUFFER) \
- { \
- NewFree = To; \
- Fixup = Fixes; \
- return (PRIM_INTERRUPT); \
- } \
- *--Fixes = *Old; \
- *--Fixes = C_To_Scheme(Old); \
+ { \
+ NewFree = To; \
+ Fixup = Fixes; \
+ return (PRIM_INTERRUPT); \
+ } \
+ (*--Fixes) = (*Old); \
+ (*--Fixes) = (ADDRESS_TO_DATUM (Old)); \
Extra_Code; \
}
#define Fasdump_Symbol(global_value) \
{ \
- *To++ = *Old; \
- *To++ = global_value; \
- Pointer_End(); \
+ (*To++) = (*Old); \
+ (*To++) = global_value; \
+ Pointer_End (); \
}
#define Fasdump_Variable() \
{ \
- *To++ = *Old; \
- *To++ = UNCOMPILED_VARIABLE; \
- *To++ = NIL; \
- Pointer_End(); \
+ (*To++) = (*Old); \
+ (*To++) = UNCOMPILED_VARIABLE; \
+ (*To++) = SHARP_F; \
+ Pointer_End (); \
}
\f
/* Compiled Code Relocation Utilities */
/* Is there anything else that can be done here? */
#define GC_NO_COMPILER_STMT() \
- gc_death(TERM_COMPILER_DEATH, \
- "relocate_compiled: No compiler support!", \
- 0, 0)
-
-#define GC_NO_COMPILER_EXPR(value_type) (GC_NO_COMPILER_STMT(), (value_type 0))
-
+ gc_death \
+ (TERM_COMPILER_DEATH, \
+ "relocate_compiled: No compiler support!", \
+ 0, 0)
-#define Relocate_Compiled(obj, nb, ob) GC_NO_COMPILER_EXPR((Pointer))
+#define GC_NO_COMPILER_EXPR(value_type) \
+ ((GC_NO_COMPILER_STMT ()), (value_type 0))
-#define Transport_Compiled() GC_NO_COMPILER_STMT()
-#define Compiled_BH(flag, then_what) GC_NO_COMPILER_STMT()
-
-#define Get_Compiled_Block(var, address) GC_NO_COMPILER_STMT()
+#define Relocate_Compiled(obj, nb, ob) (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT)))
+#define Transport_Compiled() (GC_NO_COMPILER_STMT ())
+#define Compiled_BH(flag, then_what) (GC_NO_COMPILER_STMT ())
+#define Get_Compiled_Block(var, address) (GC_NO_COMPILER_STMT ())
#define FIRST_MANIFEST_CLOSURE_ENTRY(scan) \
- GC_NO_COMPILER_EXPR((machine_word *))
+ (GC_NO_COMPILER_EXPR ((machine_word *)))
-#define VALID_MANIFEST_CLOSURE_ENTRY(word_ptr) GC_NO_COMPILER_EXPR((int))
+#define VALID_MANIFEST_CLOSURE_ENTRY(word_ptr) (GC_NO_COMPILER_EXPR ((int)))
#define NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr) \
- GC_NO_COMPILER_EXPR((machine_word *))
-
-#define MANIFEST_CLOSURE_ENTRY_ADDRESS(ptr) GC_NO_COMPILER_EXPR((Pointer *))
+ (GC_NO_COMPILER_EXPR ((machine_word *)))
-#define MANIFEST_CLOSURE_END(end, start) GC_NO_COMPILER_EXPR((Pointer *))
+#define MANIFEST_CLOSURE_ENTRY_ADDRESS(ptr) \
+ (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT *)))
-#define MANIFEST_CLOSURE_VALID_FITS_P(end, st) GC_NO_COMPILER_EXPR((int))
+#define MANIFEST_CLOSURE_END(end, start) \
+ (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT *)))
+#define MANIFEST_CLOSURE_VALID_FITS_P(end, st) \
+ (GC_NO_COMPILER_EXPR ((int)))
-#define READ_LINKAGE_KIND(header) GC_NO_COMPILER_EXPR((int))
+#define READ_LINKAGE_KIND(header) \
+ (GC_NO_COMPILER_EXPR ((int)))
#define OPERATOR_LINKAGE_KIND 0
+#define READ_CACHE_LINKAGE_COUNT(header) \
+ (GC_NO_COMPILER_EXPR ((int)))
-#define READ_CACHE_LINKAGE_COUNT(header) GC_NO_COMPILER_EXPR((int))
-
-#define READ_OPERATOR_LINKAGE_COUNT(header) GC_NO_COMPILER_EXPR((int))
-
-#define END_OPERATOR_LINKAGE_AREA(scan, count) GC_NO_COMPILER_EXPR((Pointer *))
+#define READ_OPERATOR_LINKAGE_COUNT(header) \
+ (GC_NO_COMPILER_EXPR ((int)))
+#define END_OPERATOR_LINKAGE_AREA(scan, count) \
+ (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT *)))
#define FIRST_OPERATOR_LINKAGE_ENTRY(scan) \
- GC_NO_COMPILER_EXPR((machine_word *))
+ (GC_NO_COMPILER_EXPR ((machine_word *)))
-#define NEXT_LINKAGE_OPERATOR_ENTRY(ptr) GC_NO_COMPILER_EXPR((machine_word *))
+#define NEXT_LINKAGE_OPERATOR_ENTRY(ptr) \
+ (GC_NO_COMPILER_EXPR ((machine_word *)))
-#define OPERATOR_LINKAGE_ENTRY_ADDRESS(ptr) GC_NO_COMPILER_EXPR((Pointer *))
+#define OPERATOR_LINKAGE_ENTRY_ADDRESS(ptr) \
+ (GC_NO_COMPILER_EXPR ((SCHEME_OBJECT *)))
#endif
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gcloop.c,v 9.30 1989/06/08 00:22:49 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gcloop.c,v 9.31 1989/09/20 23:08:50 cph Exp $
*
* This file contains the code for the most primitive part
* of garbage collection.
/* Exports */
-extern Pointer *GCLoop();
+extern SCHEME_OBJECT *GCLoop();
#define GC_Pointer(Code) \
{ \
- Old = Get_Pointer(Temp); \
+ Old = OBJECT_ADDRESS (Temp); \
Code; \
}
\f
#ifdef ENABLE_DEBUGGING_TOOLS
-Pointer
+SCHEME_OBJECT
*gc_scan_trap = NULL,
*gc_free_trap = NULL,
- gc_trap = Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE);
+ gc_trap = MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE);
#define HANDLE_GC_TRAP() \
{ \
#endif
\f
-Pointer *
+SCHEME_OBJECT *
GCLoop(Scan, To_Pointer)
- fast Pointer *Scan;
- Pointer **To_Pointer;
+ fast SCHEME_OBJECT *Scan;
+ SCHEME_OBJECT **To_Pointer;
{
- fast Pointer *To, *Old, Temp, *Low_Constant, New_Address;
+ fast SCHEME_OBJECT *To, *Old, Temp, *Low_Constant, New_Address;
To = *To_Pointer;
Low_Constant = Constant_Space;
Switch_by_GC_Type(Temp)
{
case TC_BROKEN_HEART:
- if (Scan == (Get_Pointer(Temp)))
+ if (Scan == (OBJECT_ADDRESS (Temp)))
{
*To_Pointer = To;
return (Scan);
case TC_MANIFEST_NM_VECTOR:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
- Scan += OBJECT_DATUM(Temp);
+ Scan += OBJECT_DATUM (Temp);
break;
\f
/* Compiled code relocation. */
{
fast long count;
fast machine_word *word_ptr;
- Pointer *end_scan;
+ SCHEME_OBJECT *end_scan;
count = READ_OPERATOR_LINKAGE_COUNT(Temp);
word_ptr = FIRST_OPERATOR_LINKAGE_ENTRY(Scan);
break;
case TC_REFERENCE_TRAP:
- if (OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE)
+ if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
{
/* It is a non pointer. */
break;
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/generic.c,v 9.30 1989/09/20 23:08:54 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/generic.c,v 9.29 1988/09/02 04:13:14 cph Rel $ */
-
#include "scheme.h"
#include "prims.h"
-#include "bignum.h"
-#include "flonum.h"
#include "zones.h"
\f
/* Complex Number Macros. Should have its own file. */
-#define REAL_PART(arg) (Vector_Ref ((arg), COMPLEX_REAL))
-#define IMAG_PART(arg) (Vector_Ref ((arg), COMPLEX_IMAG))
+#define REAL_PART(arg) (MEMORY_REF ((arg), COMPLEX_REAL))
+#define IMAG_PART(arg) (MEMORY_REF ((arg), COMPLEX_IMAG))
-/* Expands ARG thrice. Be careful */
-#define COERCE_REAL_PART(arg) ((COMPLEX_P (arg)) ? (REAL_PART (arg)) : (arg))
+#define COERCE_REAL_PART(arg) \
+ ((COMPLEX_P (arg)) ? (REAL_PART (arg)) : (arg))
#define COERCE_IMAG_PART(arg) \
((COMPLEX_P (arg)) ? (IMAG_PART (arg)) : FIXNUM_ZERO)
#define RETURN_COMPLEX(real, imag) \
{ \
- Pointer _real_value = (real); \
- Pointer _imag_value = (imag); \
- \
- if (basic_zero_p (_imag_value)) \
- PRIMITIVE_RETURN (_real_value); \
- else \
- { \
- Primitive_GC_If_Needed (2); \
- (*Free++) = _real_value; \
- (*Free++) = _imag_value; \
- PRIMITIVE_RETURN (Make_Pointer (TC_COMPLEX, (Free - 2))); \
- } \
+ SCHEME_OBJECT _real_value = (real); \
+ SCHEME_OBJECT _imag_value = (imag); \
+ PRIMITIVE_RETURN \
+ ((real_zero_p (_imag_value)) \
+ ? _real_value \
+ : (system_pair_cons (TC_COMPLEX, _real_value, _imag_value))); \
+}
+
+static double
+bignum_to_double_1 (bignum)
+ SCHEME_OBJECT bignum;
+{
+ if (! (BIGNUM_TO_DOUBLE_P (bignum)))
+ signal_error_from_primitive (ERR_ARG_1_FAILED_COERCION);
+ return (bignum_to_double (bignum));
+}
+
+static double
+bignum_to_double_2 (bignum)
+ SCHEME_OBJECT bignum;
+{
+ if (! (BIGNUM_TO_DOUBLE_P (bignum)))
+ signal_error_from_primitive (ERR_ARG_2_FAILED_COERCION);
+ return (bignum_to_double (bignum));
}
\f
-static Pointer
-basic_zero_p (number)
- fast Pointer number;
-{
+static Boolean
+real_zero_p (number)
+ fast SCHEME_OBJECT number;
+{
switch (OBJECT_TYPE (number))
{
case TC_FIXNUM:
- return ((Get_Integer (number)) == 0);
+ return (FIXNUM_ZERO_P (number));
case TC_BIG_FLONUM:
- return ((Get_Float (number)) == 0.0);
+ return ((FLONUM_TO_DOUBLE (number)) == 0);
case TC_BIG_FIXNUM:
- return (ZERO_BIGNUM (Fetch_Bignum (number)));
+ return (BIGNUM_ZERO_P (number));
default:
error_wrong_type_arg (1);
}
DEFINE_PRIMITIVE ("ZERO?", Prim_zero, 1, 1, 0)
{
- Primitive_1_Arg();
- Set_Time_Zone(Zone_Math);
-
- if (COMPLEX_P (Arg1))
+ PRIMITIVE_HEADER (1);
+ Set_Time_Zone (Zone_Math);
+ {
+ fast SCHEME_OBJECT number = (ARG_REF (1));
PRIMITIVE_RETURN
- ((basic_zero_p (REAL_PART (Arg1)))
- ? (BOOLEAN_TO_OBJECT (basic_zero_p (IMAG_PART (Arg1))))
- : SHARP_F);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (basic_zero_p (Arg1)));
+ (BOOLEAN_TO_OBJECT
+ ((COMPLEX_P (number))
+ ? ((real_zero_p (REAL_PART (number))) &&
+ (real_zero_p (IMAG_PART (number))))
+ : (real_zero_p (number))));
+ }
}
-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);
+#define SIGN_CHECK(operator, bignum_operator) \
+{ \
+ PRIMITIVE_HEADER (1); \
+ Set_Time_Zone (Zone_Math); \
+ { \
+ fast SCHEME_OBJECT number = (ARG_REF (1)); \
+ switch (OBJECT_TYPE (number)) \
+ { \
+ case TC_FIXNUM: \
+ PRIMITIVE_RETURN \
+ (BOOLEAN_TO_OBJECT ((FIXNUM_TO_LONG (number)) operator 0)); \
+ \
+ case TC_BIG_FLONUM: \
+ PRIMITIVE_RETURN \
+ (BOOLEAN_TO_OBJECT \
+ ((FLONUM_TO_DOUBLE (number)) operator 0)); \
+ \
+ case TC_BIG_FIXNUM: \
+ PRIMITIVE_RETURN \
+ (BOOLEAN_TO_OBJECT (bignum_operator (number))); \
+ \
+ default: \
+ error_wrong_type_arg (1); \
+ } \
+ } \
}
+
+DEFINE_PRIMITIVE ("POSITIVE?", Prim_positive, 1, 1, 0)
+ SIGN_CHECK (>, BIGNUM_POSITIVE_P)
+
+DEFINE_PRIMITIVE ("NEGATIVE?", Prim_negative, 1, 1, 0)
+ SIGN_CHECK (<, BIGNUM_NEGATIVE_P)
\f
-int
-Scheme_Integer_To_C_Integer (Arg1, C)
- Pointer Arg1;
- long *C;
+static SCHEME_OBJECT
+real_add_constant (number, offset)
+ fast SCHEME_OBJECT number;
+ fast long offset;
{
- int type = Type_Code(Arg1);
- fast bigdigit *SCAN, *ARG1;
- fast long Answer, i;
- long Length;
+ return
+ ((FIXNUM_P (number))
+ ? (long_to_integer ((FIXNUM_TO_LONG (number)) + offset))
+ : (BIGNUM_P (number))
+ ? (bignum_to_integer (bignum_add (number, (long_to_bignum (offset)))))
+ : (double_to_flonum ((FLONUM_TO_DOUBLE (number)) + ((double) offset))));
+}
- if (type == TC_FIXNUM)
+DEFINE_PRIMITIVE ("1+", Prim_add_one, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
{
- Sign_Extend(Arg1, *C);
- return PRIM_DONE;
+ fast SCHEME_OBJECT number = (ARG_REF (1));
+ PRIMITIVE_RETURN
+ ((REAL_P (number))
+ ? (real_add_constant (number, 1))
+ : (COMPLEX_P (number))
+ ? (system_pair_cons
+ (TC_COMPLEX,
+ (real_add_constant ((REAL_PART (number)), 1)),
+ (IMAG_PART (number))))
+ : ((error_wrong_type_arg (1)), ((SCHEME_OBJECT) 0)));
}
- 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()
+DEFINE_PRIMITIVE ("-1+", Prim_subtract_one, 1, 1, 0)
{
- return Get_Fixed_Obj_Slot(Bignum_One);
-}
-\f
-/* This is more suitable than `Scheme_Integer_To_C_Integer'
- for some purposes. */
-
-long
-object_to_long (object, type_error, range_error)
- Pointer object;
- long type_error, range_error;
-{
- fast long result;
-
- switch (OBJECT_TYPE (object))
- {
- case TC_FIXNUM:
- {
- Sign_Extend (object, result);
- return (result);
- }
-
- case TC_BIG_FIXNUM:
- {
- fast bigdigit *bignum, *scan;
- fast long length;
-
- bignum = (BIGNUM (Get_Pointer (object)));
- length = (LEN (bignum));
- if (length == 0)
- return (0);
- if (length > C_INTEGER_LENGTH_AS_BIGNUM)
- signal_error_from_primitive (range_error);
- scan = (Bignum_Top (bignum));
- result = 0;
- if (length < C_INTEGER_LENGTH_AS_BIGNUM)
- while ((length--) > 0)
- result = ((Mul_Radix (result)) + (*scan--));
- else
- while ((length--) > 0)
- {
- result = (Mul_Radix (result));
- if (result < 0)
- signal_error_from_primitive (range_error);
- result = (result + (*scan--));
- if (result < 0)
- signal_error_from_primitive (range_error);
- }
- return ((NEG_BIGNUM (bignum)) ? (- result) : result);
- }
-
- default:
- signal_error_from_primitive (type_error);
- }
+ PRIMITIVE_HEADER (1);
+ {
+ fast SCHEME_OBJECT number = (ARG_REF (1));
+ PRIMITIVE_RETURN
+ ((REAL_P (number))
+ ? (real_add_constant (number, -1))
+ : (COMPLEX_P (number))
+ ? (system_pair_cons
+ (TC_COMPLEX,
+ (real_add_constant ((REAL_PART (number)), -1)),
+ (IMAG_PART (number))))
+ : ((error_wrong_type_arg (1)), ((SCHEME_OBJECT) 0)));
+ }
}
\f
-#define SIGN_CHECK(Normal_Op, Big_Op) \
+#define TWO_OP_COMPARATOR(GENERAL_OP, BIGNUM_OP) \
{ \
- Primitive_1_Arg (); \
- \
- Set_Time_Zone (Zone_Math); \
switch (OBJECT_TYPE (Arg1)) \
{ \
case TC_FIXNUM: \
{ \
- long Value; \
- \
- Sign_Extend (Arg1, Value); \
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (Value Normal_Op 0)); \
+ switch (OBJECT_TYPE (Arg2)) \
+ { \
+ case TC_FIXNUM: \
+ return \
+ ((FIXNUM_TO_LONG (Arg1)) GENERAL_OP \
+ (FIXNUM_TO_LONG (Arg2))); \
+ case TC_BIG_FLONUM: \
+ return \
+ ((FIXNUM_TO_DOUBLE (Arg1)) GENERAL_OP \
+ (FLONUM_TO_DOUBLE (Arg2))); \
+ case TC_BIG_FIXNUM: \
+ return (BIGNUM_OP ((FIXNUM_TO_BIGNUM (Arg1)), Arg2)); \
+ default: \
+ error_wrong_type_arg (2); \
+ } \
} \
- \
case TC_BIG_FLONUM: \
- PRIMITIVE_RETURN \
- (BOOLEAN_TO_OBJECT ((Get_Float (Arg1)) Normal_Op (0.0))); \
- \
+ { \
+ switch (OBJECT_TYPE (Arg2)) \
+ { \
+ case TC_FIXNUM: \
+ return \
+ ((FLONUM_TO_DOUBLE (Arg1)) GENERAL_OP \
+ (FIXNUM_TO_DOUBLE (Arg2))); \
+ case TC_BIG_FLONUM: \
+ return \
+ ((FLONUM_TO_DOUBLE (Arg1)) GENERAL_OP \
+ (FLONUM_TO_DOUBLE (Arg2))); \
+ case TC_BIG_FIXNUM: \
+ return \
+ ((FLONUM_TO_DOUBLE (Arg1)) GENERAL_OP \
+ (bignum_to_double_2 (Arg2))); \
+ default: \
+ error_wrong_type_arg (2); \
+ } \
+ } \
case TC_BIG_FIXNUM: \
- PRIMITIVE_RETURN \
- (BOOLEAN_TO_OBJECT (((LEN (Fetch_Bignum (Arg1))) != 0) && \
- (Big_Op (Fetch_Bignum (Arg1))))); \
- \
+ { \
+ switch (OBJECT_TYPE (Arg2)) \
+ { \
+ case TC_FIXNUM: \
+ return (BIGNUM_OP (Arg1, (FIXNUM_TO_BIGNUM (Arg2)))); \
+ case TC_BIG_FLONUM: \
+ return \
+ ((bignum_to_double_1 (Arg1)) GENERAL_OP \
+ (FLONUM_TO_DOUBLE (Arg2))); \
+ case TC_BIG_FIXNUM: \
+ return (BIGNUM_OP (Arg1, Arg2)); \
+ default: \
+ error_wrong_type_arg (2); \
+ } \
+ } \
default: \
error_wrong_type_arg (1); \
} \
}
-
-DEFINE_PRIMITIVE ("POSITIVE?", Prim_positive, 1, 1, 0)
- SIGN_CHECK (>, POS_BIGNUM)
-
-DEFINE_PRIMITIVE ("NEGATIVE?", Prim_negative, 1, 1, 0)
- SIGN_CHECK (<, NEG_BIGNUM)
\f
-#define Inc_Dec(Normal_Op, Big_Op, Complex_Op) \
- Primitive_1_Arg(); \
- Set_Time_Zone(Zone_Math); \
- switch (Type_Code(Arg1)) \
- { case TC_COMPLEX: \
- { Primitive_GC_If_Needed(2); \
- *Free++ = Complex_Op(REAL_PART(Arg1)); \
- *Free++ = IMAG_PART(Arg1); \
- return Make_Pointer(TC_COMPLEX, (Free - 2)); \
- } \
-Inc_Dec_Basic_Cases(Normal_Op, Big_Op)
-
-#define Basic_Inc_Dec(Normal_Op, Big_Op) \
- switch (Type_Code(Arg1)) \
- { \
-Inc_Dec_Basic_Cases(Normal_Op, Big_Op)
-
-#define Inc_Dec_Basic_Cases(Normal_Op, Big_Op) \
- 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); \
- }
-
-Pointer
-C_One_Plus (Arg1)
- fast Pointer Arg1;
-{
- Basic_Inc_Dec(+, plus_signed_bignum);
-}
-
-Pointer
-C_One_Minus (Arg1)
- fast Pointer Arg1;
-{
- Basic_Inc_Dec(-, minus_signed_bignum);
-}
-
-DEFINE_PRIMITIVE ("1+", Prim_one_plus, 1, 1, 0)
+static Boolean
+real_equal_p (Arg1, Arg2)
+ fast SCHEME_OBJECT Arg1;
+ fast SCHEME_OBJECT Arg2;
{
- Inc_Dec(+, plus_signed_bignum, C_One_Plus);
- /*NOTREACHED*/
+ TWO_OP_COMPARATOR (==, bignum_equal_p);
}
-DEFINE_PRIMITIVE ("-1+", Prim_m_1_plus, 1, 1, 0)
+static Boolean
+real_less_p (Arg1, Arg2)
+ fast SCHEME_OBJECT Arg1;
+ fast SCHEME_OBJECT Arg2;
{
- Inc_Dec(-, minus_signed_bignum, C_One_Minus);
- /*NOTREACHED*/
+ TWO_OP_COMPARATOR (<, BIGNUM_LESS_P);
}
-\f
-#define Two_Op_Comparator(GENERAL_OP, BIG_OP) \
- Primitive_2_Args(); \
- Set_Time_Zone(Zone_Math); \
- Basic_Two_Op_Comparator(GENERAL_OP, BIG_OP)
-#define Basic_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
- 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 (BOOLEAN_TO_OBJECT (A GENERAL_OP B)); \
- } \
- 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 (BOOLEAN_TO_OBJECT (A GENERAL_OP (Get_Float(Arg2)))); \
- } \
- case TC_BIG_FIXNUM: \
- { Pointer Ans = Fix_To_Big(Arg1); \
- return (BOOLEAN_TO_OBJECT (big_compare(Fetch_Bignum(Ans), \
- Fetch_Bignum(Arg2)) == BIG_OP)); \
- } \
- 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 (BOOLEAN_TO_OBJECT (Get_Float(Arg1) GENERAL_OP B)); \
- } \
- P4_Two_Op_Comparator(GENERAL_OP, BIG_OP)
-
-#define P4_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FLONUM: \
- return \
- (BOOLEAN_TO_OBJECT (Get_Float(Arg1) GENERAL_OP \
- Get_Float(Arg2))); \
- case TC_BIG_FIXNUM: \
- { Pointer A; \
- A = Big_To_Float(Arg2); \
- if (Type_Code(A) == TC_BIG_FLONUM) \
- return \
- (BOOLEAN_TO_OBJECT (Get_Float(Arg1) GENERAL_OP \
- Get_Float(A))); \
- P5_Two_Op_Comparator(GENERAL_OP, BIG_OP)
-\f
-#define P5_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
- Primitive_Error(ERR_ARG_2_FAILED_COERCION); \
- } \
- default: \
- Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
- } \
- } \
- case TC_BIG_FIXNUM: \
- { switch (Type_Code(Arg2)) \
- { case TC_FIXNUM: \
- { Pointer Ans = Fix_To_Big(Arg2); \
- return (BOOLEAN_TO_OBJECT (big_compare(Fetch_Bignum(Arg1), \
- Fetch_Bignum(Ans)) == BIG_OP)); \
- } \
- 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 \
- (BOOLEAN_TO_OBJECT (Get_Float(A) GENERAL_OP \
- Get_Float(Arg2))); \
- 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 (BOOLEAN_TO_OBJECT (big_compare(Fetch_Bignum(Arg1), \
- Fetch_Bignum(Arg2)) == BIG_OP)); \
- default: \
- Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
- } \
- } \
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
- }
-
-Pointer
-Basic_Equal_Number (Arg1, Arg2)
- fast Pointer Arg1, Arg2;
-{
- Basic_Two_Op_Comparator (==, EQUAL);
-}
-
DEFINE_PRIMITIVE ("&=", Prim_equal_number, 2, 2, 0)
{
- Primitive_2_Args ();
+ PRIMITIVE_HEADER (2);
Set_Time_Zone (Zone_Math);
-
- if ((COMPLEX_P (Arg1)) && (COMPLEX_P (Arg2)))
+ {
+ fast SCHEME_OBJECT Arg1 = (ARG_REF (1));
+ fast SCHEME_OBJECT Arg2 = (ARG_REF (2));
PRIMITIVE_RETURN
- (((Basic_Equal_Number ((REAL_PART (Arg1)), (REAL_PART (Arg2)))) == SHARP_T)
- ? (Basic_Equal_Number ((IMAG_PART (Arg1)), (IMAG_PART (Arg2))))
- : SHARP_F);
- else if ((COMPLEX_P (Arg1)) || (COMPLEX_P (Arg2)))
- PRIMITIVE_RETURN (SHARP_F);
- Basic_Two_Op_Comparator (==, EQUAL)
- /*NOTREACHED*/
+ (BOOLEAN_TO_OBJECT
+ ((COMPLEX_P (Arg1))
+ ? ((COMPLEX_P (Arg2)) &&
+ (real_equal_p ((REAL_PART (Arg1)), (REAL_PART (Arg2)))) &&
+ (real_equal_p ((IMAG_PART (Arg1)), (IMAG_PART (Arg2)))))
+ : ((! (COMPLEX_P (Arg2))) &&
+ (real_equal_p (Arg1, Arg2)))));
+ }
}
DEFINE_PRIMITIVE ("&<", Prim_less, 2, 2, 0)
{
- Two_Op_Comparator (<, TWO_BIGGER);
- /*NOTREACHED*/
+ PRIMITIVE_HEADER (2);
+ Set_Time_Zone (Zone_Math);
+ PRIMITIVE_RETURN
+ (BOOLEAN_TO_OBJECT (real_less_p ((ARG_REF (1)), (ARG_REF (2)))));
}
DEFINE_PRIMITIVE ("&>", Prim_greater, 2, 2, 0)
{
- Two_Op_Comparator (>, ONE_BIGGER);
- /*NOTREACHED*/
+ PRIMITIVE_HEADER (2);
+ Set_Time_Zone (Zone_Math);
+ PRIMITIVE_RETURN
+ (BOOLEAN_TO_OBJECT (real_less_p ((ARG_REF (2)), (ARG_REF (1)))));
}
\f
-#define Two_Op_Operator(GENERAL_OP, BIG_OP, COMPLEX_OP) \
- Primitive_2_Args(); \
- Set_Time_Zone(Zone_Math); \
- \
- if ((COMPLEX_P (Arg2))) goto complex_handler; \
- \
- switch (Type_Code(Arg1)) \
- { \
- case TC_COMPLEX: \
- complex_handler: \
- RETURN_COMPLEX \
- ((COMPLEX_OP ((COERCE_REAL_PART (Arg1)), \
- (COERCE_REAL_PART (Arg2)))), \
- (COMPLEX_OP ((COERCE_IMAG_PART (Arg1)), \
- (COERCE_IMAG_PART (Arg2))))); \
-Two_Op_Operator_Basic_Cases(GENERAL_OP, BIG_OP)
-
-#define Basic_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- switch (Type_Code(Arg1)) \
- { \
-Two_Op_Operator_Basic_Cases(GENERAL_OP, BIG_OP)
-
-#define Two_Op_Operator_Basic_Cases(GENERAL_OP, BIG_OP) \
+#define TWO_OP_OPERATOR(FIXNUM_OP, FLONUM_OP, BIGNUM_OP) \
+{ \
+ switch (OBJECT_TYPE (Arg1)) \
+ { \
case TC_FIXNUM: \
- { switch (Type_Code(Arg2)) \
- { case TC_FIXNUM: \
- { fast long A, B, Result; \
- Sign_Extend(Arg1, A); \
- Sign_Extend(Arg2, B); \
- Result = (A GENERAL_OP B); \
- if (Fixnum_Fits(Result)) \
- return Make_Non_Pointer(TC_FIXNUM, Result); \
-P2_Two_Op_Operator(GENERAL_OP, BIG_OP)
-
-#define P2_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- { Pointer Big_Arg1, Big_Arg2, Big_Result; \
- Big_Arg1 = Fix_To_Big(Arg1); \
- Big_Arg2 = Fix_To_Big(Arg2); \
- Bignum_Operation(BIG_OP(Fetch_Bignum(Big_Arg1), \
- Fetch_Bignum(Big_Arg2)), \
- Big_Result); \
- return Big_Result; \
- } \
- } \
-P3_Two_Op_Operator(GENERAL_OP, BIG_OP)
-\f
-#define P3_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FLONUM: \
- { fast long A; \
- Sign_Extend(Arg1, A); \
- Reduced_Flonum_Result(A GENERAL_OP Get_Float(Arg2)); \
- } \
-P4_Two_Op_Operator(GENERAL_OP, BIG_OP)
-
-#define P4_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FIXNUM: \
- { Pointer Big_Arg1 = Fix_To_Big(Arg1); \
- Bignum_Operation(BIG_OP(Fetch_Bignum(Big_Arg1), \
- Fetch_Bignum(Arg2)), \
- Big_Arg1); \
- return Big_Arg1; \
+ { \
+ switch (OBJECT_TYPE (Arg2)) \
+ { \
+ case TC_FIXNUM: \
+ return (FIXNUM_OP (Arg1, Arg2)); \
+ case TC_BIG_FLONUM: \
+ return \
+ (double_to_flonum \
+ ((FIXNUM_TO_DOUBLE (Arg1)) FLONUM_OP \
+ (FLONUM_TO_DOUBLE (Arg2)))); \
+ case TC_BIG_FIXNUM: \
+ return \
+ (bignum_to_integer \
+ (BIGNUM_OP ((FIXNUM_TO_BIGNUM (Arg1)), Arg2))); \
+ default: \
+ error_wrong_type_arg (2); \
} \
- default: \
- Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
- } \
- } \
-P5_Two_Op_Operator(GENERAL_OP, BIG_OP)
-\f
-#define P5_Two_Op_Operator(GENERAL_OP, BIG_OP) \
+ } \
case TC_BIG_FLONUM: \
- { switch (Type_Code(Arg2)) \
- { case TC_FIXNUM: \
- { fast long B; \
- Sign_Extend(Arg2, B); \
- Reduced_Flonum_Result(Get_Float(Arg1) GENERAL_OP B); \
+ { \
+ switch (OBJECT_TYPE (Arg2)) \
+ { \
+ case TC_FIXNUM: \
+ return \
+ (double_to_flonum \
+ ((FLONUM_TO_DOUBLE (Arg1)) FLONUM_OP \
+ (FIXNUM_TO_DOUBLE (Arg2)))); \
+ case TC_BIG_FLONUM: \
+ return \
+ (double_to_flonum \
+ ((FLONUM_TO_DOUBLE (Arg1)) FLONUM_OP \
+ (FLONUM_TO_DOUBLE (Arg2)))); \
+ case TC_BIG_FIXNUM: \
+ return \
+ (double_to_flonum \
+ ((FLONUM_TO_DOUBLE (Arg1)) FLONUM_OP \
+ (bignum_to_double_2 (Arg2)))); \
+ default: \
+ error_wrong_type_arg (2); \
} \
- case TC_BIG_FLONUM: \
- Reduced_Flonum_Result(Get_Float(Arg1) GENERAL_OP \
- Get_Float(Arg2)); \
-P6_Two_Op_Operator(GENERAL_OP, BIG_OP)
-
-#define P6_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FIXNUM: \
- { Pointer B = Big_To_Float(Arg2); \
- if (Type_Code(B) == TC_BIG_FLONUM) \
- { Reduced_Flonum_Result(Get_Float(Arg1) GENERAL_OP \
- Get_Float(B)); \
- } \
- Primitive_Error(ERR_ARG_2_FAILED_COERCION); \
- } \
- default: \
- Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
- } \
- } \
-P7_Two_Op_Operator(GENERAL_OP, BIG_OP)
-\f
-#define P7_Two_Op_Operator(GENERAL_OP, BIG_OP) \
+ } \
case TC_BIG_FIXNUM: \
- { switch (Type_Code(Arg2)) \
- { case TC_FIXNUM: \
- { Pointer Big_Arg2 = Fix_To_Big(Arg2); \
- Bignum_Operation(BIG_OP(Fetch_Bignum(Arg1), \
- Fetch_Bignum(Big_Arg2)), \
- Big_Arg2); \
- return Big_Arg2; \
+ { \
+ switch (OBJECT_TYPE (Arg2)) \
+ { \
+ case TC_FIXNUM: \
+ return \
+ (bignum_to_integer \
+ (BIGNUM_OP (Arg1, (FIXNUM_TO_BIGNUM (Arg2))))); \
+ case TC_BIG_FLONUM: \
+ return \
+ (double_to_flonum \
+ ((bignum_to_double_1 (Arg1)) FLONUM_OP \
+ (FLONUM_TO_DOUBLE (Arg2)))); \
+ case TC_BIG_FIXNUM: \
+ return (bignum_to_integer (BIGNUM_OP (Arg1, Arg2))); \
+ default: \
+ error_wrong_type_arg (2); \
} \
-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)
+ } \
+ default: \
+ error_wrong_type_arg (1); \
+ } \
+}
\f
-#define P9_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FIXNUM: \
- { Pointer Ans; \
- Bignum_Operation(BIG_OP(Fetch_Bignum(Arg1), \
- Fetch_Bignum(Arg2)), \
- Ans); \
- return Ans; \
- } \
- default: \
- Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
- } \
- } \
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
- }
+#define FIXNUM_ADD(x, y) \
+ (long_to_integer ((FIXNUM_TO_LONG (x)) + (FIXNUM_TO_LONG (y))))
+
+#define FIXNUM_SUBTRACT(x, y) \
+ (long_to_integer ((FIXNUM_TO_LONG (x)) - (FIXNUM_TO_LONG (y))))
-static Pointer basic_plus(Arg1, Arg2)
-fast Pointer Arg1, Arg2;
-{
- Basic_Two_Op_Operator(+, plus_signed_bignum);
+static SCHEME_OBJECT
+fixnum_multiply (Arg1, Arg2)
+ fast SCHEME_OBJECT Arg1;
+ fast SCHEME_OBJECT Arg2;
+{
+ extern SCHEME_OBJECT Mul ();
+ fast SCHEME_OBJECT result = (Mul (Arg1, Arg2));
+ return
+ ((result == SHARP_F)
+ ? (bignum_multiply ((FIXNUM_TO_BIGNUM (Arg1)), (FIXNUM_TO_BIGNUM (Arg2))))
+ : result);
}
-static Pointer basic_minus(Arg1, Arg2)
-fast Pointer Arg1, Arg2;
-{
- Basic_Two_Op_Operator(-, minus_signed_bignum);
+static SCHEME_OBJECT
+real_add (Arg1, Arg2)
+ fast SCHEME_OBJECT Arg1;
+ fast SCHEME_OBJECT Arg2;
+{
+ TWO_OP_OPERATOR (FIXNUM_ADD, +, bignum_add);
}
-DEFINE_PRIMITIVE ("&+", Prim_plus, 2, 2, 0)
+static SCHEME_OBJECT
+real_subtract (Arg1, Arg2)
+ fast SCHEME_OBJECT Arg1;
+ fast SCHEME_OBJECT Arg2;
{
- Two_Op_Operator(+, plus_signed_bignum, basic_plus);
- /*NOTREACHED*/
+ TWO_OP_OPERATOR (FIXNUM_SUBTRACT, -, bignum_subtract);
}
-DEFINE_PRIMITIVE ("&-", Prim_minus, 2, 2, 0)
+static SCHEME_OBJECT
+real_multiply (Arg1, Arg2)
+ fast SCHEME_OBJECT Arg1;
+ fast SCHEME_OBJECT Arg2;
{
- Two_Op_Operator(-, minus_signed_bignum, basic_minus);
- /*NOTREACHED*/
+ TWO_OP_OPERATOR (fixnum_multiply, *, bignum_multiply);
}
\f
-static Pointer
-basic_multiply (Arg1, Arg2)
- fast Pointer Arg1, Arg2;
+DEFINE_PRIMITIVE ("&+", Prim_add, 2, 2, 0)
{
- extern Pointer Mul ();
-
- switch (Type_Code(Arg1))
- { case TC_FIXNUM:
- { switch (Type_Code(Arg2))
- { case TC_FIXNUM:
- { fast Pointer Result;
- Result = Mul(Arg1, Arg2);
- if (Result != SHARP_F) 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));
- }
+ PRIMITIVE_HEADER (2);
+ Set_Time_Zone (Zone_Math);
+ {
+ fast SCHEME_OBJECT Arg1 = (ARG_REF (1));
+ fast SCHEME_OBJECT Arg2 = (ARG_REF (2));
+ if ((COMPLEX_P (Arg1)) || (COMPLEX_P (Arg2)))
+ RETURN_COMPLEX
+ ((real_add ((COERCE_REAL_PART (Arg1)), (COERCE_REAL_PART (Arg2)))),
+ (real_add ((COERCE_IMAG_PART (Arg1)), (COERCE_IMAG_PART (Arg2)))));
+ PRIMITIVE_RETURN (real_add (Arg1, Arg2));
+ }
+}
- 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*/
- }
- 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);
+DEFINE_PRIMITIVE ("&-", Prim_subtract, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ Set_Time_Zone (Zone_Math);
+ {
+ fast SCHEME_OBJECT Arg1 = (ARG_REF (1));
+ fast SCHEME_OBJECT Arg2 = (ARG_REF (2));
+ if ((COMPLEX_P (Arg1)) || (COMPLEX_P (Arg2)))
+ RETURN_COMPLEX
+ ((real_subtract ((COERCE_REAL_PART (Arg1)),
+ (COERCE_REAL_PART (Arg2)))),
+ (real_subtract ((COERCE_IMAG_PART (Arg1)),
+ (COERCE_IMAG_PART (Arg2)))));
+ PRIMITIVE_RETURN (real_subtract (Arg1, Arg2));
}
- /*NOTREACHED*/
}
-\f
-static Pointer
+
+static SCHEME_OBJECT
complex_multiply (Arg1, Arg2)
- fast Pointer Arg1, Arg2;
+ fast SCHEME_OBJECT Arg1;
+ fast SCHEME_OBJECT Arg2;
{
RETURN_COMPLEX
- ((basic_minus ((basic_multiply ((COERCE_REAL_PART (Arg1)),
- (COERCE_REAL_PART (Arg2)))),
- (basic_multiply ((COERCE_IMAG_PART (Arg1)),
- (COERCE_IMAG_PART (Arg2)))))),
- (basic_plus ((basic_multiply ((COERCE_REAL_PART (Arg1)),
- (COERCE_IMAG_PART (Arg2)))),
- (basic_multiply ((COERCE_REAL_PART (Arg2)),
- (COERCE_IMAG_PART (Arg1)))))));
+ ((real_subtract ((real_multiply ((COERCE_REAL_PART (Arg1)),
+ (COERCE_REAL_PART (Arg2)))),
+ (real_multiply ((COERCE_IMAG_PART (Arg1)),
+ (COERCE_IMAG_PART (Arg2)))))),
+ (real_add ((real_multiply ((COERCE_REAL_PART (Arg1)),
+ (COERCE_IMAG_PART (Arg2)))),
+ (real_multiply ((COERCE_REAL_PART (Arg2)),
+ (COERCE_IMAG_PART (Arg1)))))));
}
-
+
DEFINE_PRIMITIVE ("&*", Prim_multiply, 2, 2, 0)
{
- /* Mul is machine dependent and lives in "os.c" */
- Primitive_2_Args ();
+ PRIMITIVE_HEADER (2);
Set_Time_Zone (Zone_Math);
-
- PRIMITIVE_RETURN
- (((COMPLEX_P (Arg1)) || (COMPLEX_P (Arg2)))
- ? (complex_multiply (Arg1, Arg2))
- : (basic_multiply (Arg1, Arg2)));
+ {
+ fast SCHEME_OBJECT Arg1 = (ARG_REF (1));
+ fast SCHEME_OBJECT Arg2 = (ARG_REF (2));
+ PRIMITIVE_RETURN
+ (((COMPLEX_P (Arg1)) || (COMPLEX_P (Arg2)))
+ ? (complex_multiply (Arg1, Arg2))
+ : (real_multiply (Arg1, Arg2)));
+ }
+}
+\f
+#define FLONUM_DIVIDE(numerator, denominator) \
+{ \
+ fast double _denominator = (denominator); \
+ if (_denominator == 0) \
+ error_bad_range_arg (2); \
+ return (double_to_flonum ((numerator) / _denominator)); \
+}
+
+static SCHEME_OBJECT
+bignum_real_divide (numerator, denominator)
+ fast SCHEME_OBJECT numerator;
+ fast SCHEME_OBJECT denominator;
+{
+ SCHEME_OBJECT quotient;
+ SCHEME_OBJECT remainder;
+ if (bignum_divide (numerator, denominator, ("ient), (&remainder)))
+ error_bad_range_arg (2);
+ return
+ ((BIGNUM_ZERO_P (remainder))
+ ? (bignum_to_integer (quotient))
+ : (double_to_flonum
+ ((bignum_to_double_1 (numerator)) /
+ (bignum_to_double_2 (denominator)))));
}
\f
-static Pointer
-basic_divide(Arg1, Arg2)
- fast Pointer Arg1, Arg2;
+static SCHEME_OBJECT
+real_divide (Arg1, Arg2)
+ fast SCHEME_OBJECT Arg1;
+ fast SCHEME_OBJECT Arg2;
{
- 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);
- if ((A % B) == 0)
- return (C_Integer_To_Scheme_Integer ((long) (A / B)));
- Result = (double) A / (double) B;
- 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));
- }
- 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) == Make_Unsigned_Fixnum(0))
- return (Vector_Ref(Result, CONS_CAR));
- Sign_Extend(Arg1, A);
- { B = Big_To_Float(Arg2);
- if (Type_Code(B) == TC_BIG_FLONUM)
- { Flonum_Result(A / Get_Float(B));
- }
- Primitive_Error(ERR_ARG_2_FAILED_COERCION);
+ switch (OBJECT_TYPE (Arg1))
+ {
+ case TC_FIXNUM:
+ {
+ switch (OBJECT_TYPE (Arg2))
+ {
+ case TC_FIXNUM:
+ {
+ fast long A = (FIXNUM_TO_LONG (Arg1));
+ fast long B = (FIXNUM_TO_LONG (Arg2));
+ if (B == 0)
+ error_bad_range_arg (2);
+ return
+ (((A % B) == 0)
+ ? (long_to_integer ((long) (A / B)))
+ : (double_to_flonum (((double) A) / ((double) B))));
}
- /*NOTREACHED*/
+ case TC_BIG_FLONUM:
+ FLONUM_DIVIDE
+ ((FIXNUM_TO_DOUBLE (Arg1)), (FLONUM_TO_DOUBLE (Arg2)));
+ case TC_BIG_FIXNUM:
+ return (bignum_real_divide ((FIXNUM_TO_BIGNUM (Arg1)), Arg2));
+ default:
+ error_wrong_type_arg (2);
}
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /*NOTREACHED*/
- }
+ /*NOTREACHED*/
+ }
case TC_BIG_FLONUM:
- { switch (Type_Code(Arg2))
- { case TC_FIXNUM:
- { fast long B;
- Sign_Extend(Arg2, B);
- if (B == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- { Reduced_Flonum_Result(Get_Float(Arg1) / ((double) B));
- }
- }
-
-/* Prim_Divide continues on the next page */
-\f
-/* Prim_Divide, continued */
-
- case TC_BIG_FLONUM:
- if (Get_Float(Arg2) == 0)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Reduced_Flonum_Result(Get_Float(Arg1) / Get_Float(Arg2));
- case TC_BIG_FIXNUM:
- { Pointer B;
- if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- B = Big_To_Float(Arg2);
- if (Type_Code(B) == TC_BIG_FLONUM)
- { Reduced_Flonum_Result(Get_Float(Arg1) / Get_Float(B));
- }
- Primitive_Error(ERR_ARG_2_FAILED_COERCION);
- }
- /*NOTREACHED*/
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /*NOTREACHED*/
- }
- 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) == Make_Unsigned_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);
- Flonum_Result(Get_Float(A) / ((double) B));
- }
- Primitive_Error(ERR_ARG_1_FAILED_COERCION);
+ {
+ switch (OBJECT_TYPE (Arg2))
+ {
+ case TC_FIXNUM:
+ FLONUM_DIVIDE
+ ((FLONUM_TO_DOUBLE (Arg1)), (FIXNUM_TO_DOUBLE (Arg2)));
+ case TC_BIG_FLONUM:
+ FLONUM_DIVIDE
+ ((FLONUM_TO_DOUBLE (Arg1)), (FLONUM_TO_DOUBLE (Arg2)));
+ case TC_BIG_FIXNUM:
+ FLONUM_DIVIDE
+ ((FLONUM_TO_DOUBLE (Arg1)), (bignum_to_double_2 (Arg2)));
+ default:
+ error_wrong_type_arg (2);
}
- /*NOTREACHED*/
- case TC_BIG_FLONUM:
- { Pointer A;
- if (Get_Float(Arg2) == 0.0)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- A = Big_To_Float(Arg1);
- if (Type_Code(A) == TC_BIG_FLONUM)
- { Reduced_Flonum_Result(Get_Float(A) / Get_Float(Arg2));
- }
- Primitive_Error(ERR_ARG_1_FAILED_COERCION);
- }
- /*NOTREACHED*/
-
-/* Prim_Divide continues on the next page */
-\f
-/* Prim_Divide, continued */
-
- case TC_BIG_FIXNUM:
- { Pointer Result, A, B;
- if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1),
- Fetch_Bignum(Arg2)),
- Result);
- if (Vector_Ref(Result, CONS_CDR) == Make_Unsigned_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);
- { Flonum_Result(Get_Float(A) / Get_Float(B));
- }
- }
- Primitive_Error(ERR_ARG_2_FAILED_COERCION);
- }
- /*NOTREACHED*/
- Primitive_Error(ERR_ARG_1_FAILED_COERCION);
+ /*NOTREACHED*/
+ }
+ case TC_BIG_FIXNUM:
+ {
+ switch (OBJECT_TYPE (Arg2))
+ {
+ case TC_FIXNUM:
+ return (bignum_real_divide (Arg1, (FIXNUM_TO_BIGNUM (Arg2))));
+ case TC_BIG_FLONUM:
+ FLONUM_DIVIDE
+ ((bignum_to_double_1 (Arg1)), (FLONUM_TO_DOUBLE (Arg2)));
+ case TC_BIG_FIXNUM:
+ return (bignum_real_divide (Arg1, Arg2));
+ default:
+ error_wrong_type_arg (2);
}
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /*NOTREACHED*/
- }
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- }
+ /*NOTREACHED*/
+ }
+ default:
+ error_wrong_type_arg (1);
+ }
/*NOTREACHED*/
}
\f
-static Pointer
+static SCHEME_OBJECT
complex_divide (Arg1, Arg2)
- Pointer Arg1, Arg2;
-{
- fast Pointer real1, real2, imag1, imag2;
- fast Pointer temp;
-
- real1 = (COERCE_REAL_PART (Arg1));
- real2 = (COERCE_REAL_PART (Arg2));
- imag1 = (COERCE_IMAG_PART (Arg1));
- imag2 = (COERCE_IMAG_PART (Arg2));
-
- temp = (basic_divide ((MAKE_UNSIGNED_FIXNUM (1)),
- (basic_plus ((basic_multiply (real2, real2)),
- (basic_multiply (imag2, imag2))))));
+ SCHEME_OBJECT Arg1, Arg2;
+{
+ fast SCHEME_OBJECT real1 = (COERCE_REAL_PART (Arg1));
+ fast SCHEME_OBJECT real2 = (COERCE_REAL_PART (Arg2));
+ fast SCHEME_OBJECT imag1 = (COERCE_IMAG_PART (Arg1));
+ fast SCHEME_OBJECT imag2 = (COERCE_IMAG_PART (Arg2));
+ fast SCHEME_OBJECT temp =
+ (real_divide ((LONG_TO_UNSIGNED_FIXNUM (1)),
+ (real_add ((real_multiply (real2, real2)),
+ (real_multiply (imag2, imag2))))));
RETURN_COMPLEX
- ((basic_multiply ((basic_plus ((basic_multiply (real1, real2)),
- (basic_multiply (imag1, imag2)))),
- temp)),
- (basic_multiply ((basic_minus ((basic_multiply (real2, imag1)),
- (basic_multiply (real1, imag2)))),
- temp)));
+ ((real_multiply ((real_add ((real_multiply (real1, real2)),
+ (real_multiply (imag1, imag2)))),
+ temp)),
+ (real_multiply ((real_subtract ((real_multiply (real2, imag1)),
+ (real_multiply (real1, imag2)))),
+ temp)));
}
DEFINE_PRIMITIVE ("&/", Prim_divide, 2, 2, 0)
{
- Primitive_2_Args ();
-
+ PRIMITIVE_HEADER (2);
Set_Time_Zone (Zone_Math);
- PRIMITIVE_RETURN
- (((COMPLEX_P (Arg1)) || (COMPLEX_P (Arg2)))
- ? (complex_divide (Arg1, Arg2))
- : (basic_divide (Arg1, Arg2)));
-}
-\f
-DEFINE_PRIMITIVE ("INTEGER-DIVIDE", Prim_integer_divide, 2, 2, 0)
-{
- Primitive_2_Args ();
-
- Set_Time_Zone (Zone_Math);
- switch (Type_Code(Arg1))
- { case TC_FIXNUM:
- { switch (Type_Code(Arg2))
- { case TC_FIXNUM:
- { fast long A, B, C, D;
- Pointer *Cons_Cell;
- Sign_Extend(Arg1, A);
- Sign_Extend(Arg2, B);
- if (B == 0)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Primitive_GC_If_Needed(2);
- /* These (C & D) are necessary because Make_Non_Pointer casts to
- Pointer which is unsigned long, and then the arithmetic is wrong
- if the operations are placed in the macro "call". */
- C = A / B;
- D = A % B;
- Cons_Cell = Free;
- Free += 2;
- Cons_Cell[CONS_CAR] = Make_Non_Pointer(TC_FIXNUM, C);
- Cons_Cell[CONS_CDR] = Make_Non_Pointer(TC_FIXNUM, D);
- return Make_Pointer(TC_LIST, Cons_Cell);
- }
- case TC_BIG_FIXNUM:
- { Pointer Big_Arg1, Pair;
- if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Big_Arg1 = Fix_To_Big(Arg1);
- Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Big_Arg1),
- Fetch_Bignum(Arg2)),
- Pair);
- return Pair;
- }
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /*NOTREACHED*/
- }
-
-/* Prim_Integer_Divide continues on the next page */
-\f
-/* Prim_Integer_Divide, continued */
-
- case TC_BIG_FIXNUM:
- { switch (Type_Code(Arg2))
- { case TC_FIXNUM:
- { Pointer Big_Arg2, Pair;
- if (Get_Integer(Arg2) == 0)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Big_Arg2 = Fix_To_Big(Arg2);
- Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1),
- Fetch_Bignum(Big_Arg2)),
- Pair);
- return Pair;
- }
- case TC_BIG_FIXNUM:
- { Pointer Pair;
- if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1),
- Fetch_Bignum(Arg2)),
- Pair);
- return Pair;
- }
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /*NOTREACHED*/
- }
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ {
+ fast SCHEME_OBJECT Arg1 = (ARG_REF (1));
+ fast SCHEME_OBJECT Arg2 = (ARG_REF (2));
+ PRIMITIVE_RETURN
+ (((COMPLEX_P (Arg1)) || (COMPLEX_P (Arg2)))
+ ? (complex_divide (Arg1, Arg2))
+ : (real_divide (Arg1, Arg2)));
}
- /*NOTREACHED*/
}
\f
/* Generic sqrt and transcendental functions are created by generalizing
- their floating point counterparts.
-*/
+ their floating point counterparts. */
-#define Generic_Function(Routine) \
- 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); \
- }
-
-/* This horrible hack because there are no lambda-expressions in C. */
-
-#define Generic_Restriction(Lambda, Routine, Restriction) \
-double \
-Lambda(arg) \
- fast double arg; \
-{ \
- double Routine(); \
- \
- if (arg Restriction 0.0) \
- Primitive_Error(ERR_ARG_1_BAD_RANGE); \
- return Routine(arg); \
-}
-\f
-/* And here the functions themselves */
-
-Generic_Restriction(Scheme_Sqrt, sqrt, <)
-Generic_Restriction(Scheme_Ln, log, <=)
-
-DEFINE_PRIMITIVE ("SQRT", Prim_sqrt, 1, 1, 0)
+static double
+scheme_sqrt (x)
+ fast double x;
{
- Generic_Function(Scheme_Sqrt);
- /*NOTREACHED*/
+ extern double sqrt ();
+ if (x < 0)
+ error_bad_range_arg (1);
+ return (sqrt (x));
}
-DEFINE_PRIMITIVE ("EXP", Prim_exp, 1, 1, 0)
+static double
+scheme_ln (x)
+ fast double x;
{
- Generic_Function(exp);
- /*NOTREACHED*/
+ extern double log ();
+ if (x < 0)
+ error_bad_range_arg (1);
+ return (log (x));
}
-DEFINE_PRIMITIVE ("LOG", Prim_ln, 1, 1, 0)
-{
- Generic_Function(Scheme_Ln);
- /*NOTREACHED*/
-}
+extern double exp ();
+extern double sin ();
+extern double cos ();
+extern double atan ();
-DEFINE_PRIMITIVE ("SIN", Prim_sine, 1, 1, 0)
-{
- Generic_Function(sin);
- /*NOTREACHED*/
-}
-
-DEFINE_PRIMITIVE ("COS", Prim_cosine, 1, 1, 0)
-{
- Generic_Function(cos);
- /*NOTREACHED*/
+#define GENERIC_FUNCTION(fun) \
+{ \
+ PRIMITIVE_HEADER (1); \
+ Set_Time_Zone (Zone_Math); \
+ { \
+ fast SCHEME_OBJECT number = (ARG_REF (1)); \
+ switch (OBJECT_TYPE (number)) \
+ { \
+ case TC_FIXNUM: \
+ PRIMITIVE_RETURN \
+ (double_to_flonum (fun (FIXNUM_TO_DOUBLE (number)))); \
+ case TC_BIG_FLONUM: \
+ PRIMITIVE_RETURN \
+ (double_to_flonum (fun (FLONUM_TO_DOUBLE (number)))); \
+ case TC_BIG_FIXNUM: \
+ PRIMITIVE_RETURN \
+ (double_to_flonum (fun (bignum_to_double_1 (number)))); \
+ default: \
+ error_wrong_type_arg (1); \
+ } \
+ } \
}
+DEFINE_PRIMITIVE ("SQRT", Prim_sqrt, 1, 1, 0)
+ GENERIC_FUNCTION (scheme_sqrt)
+DEFINE_PRIMITIVE ("EXP", Prim_exp, 1, 1, 0)
+ GENERIC_FUNCTION (exp)
+DEFINE_PRIMITIVE ("LOG", Prim_log, 1, 1, 0)
+ GENERIC_FUNCTION (scheme_ln)
+DEFINE_PRIMITIVE ("SIN", Prim_sin, 1, 1, 0)
+ GENERIC_FUNCTION (sin);
+DEFINE_PRIMITIVE ("COS", Prim_cos, 1, 1, 0)
+ GENERIC_FUNCTION (cos)
DEFINE_PRIMITIVE ("&ATAN", Prim_arctan, 1, 1, 0)
-{
- Generic_Function(atan);
- /*NOTREACHED*/
-}
-\f
-/* Coercions from Floating point to integers.
-
- There are four possible ways to coerce:
-
- - Truncate : towards 0.
- - Round : towards closest integer.
- - Floor : towards -infinity.
- - Ceiling : towards +infinity.
-
- All these primitives differ only in how floating point numbers
- are mapped before they are truncated.
-*/
-
-#ifdef HAS_FLOOR
-
-extern double floor(), ceil();
-
-#else
-
-double
-floor(arg)
- double arg;
-{
- long temp;
- double narg;
-
- temp = ((long) arg);
- narg = ((double) temp);
- if ((narg == arg) || (arg > 0.0))
- return (narg);
- else
- return (narg - 1.0);
-}
-
-double
-ceil(arg)
- double arg;
-{
- long temp;
- double narg;
-
- temp = ((long) arg);
- narg = ((double) temp);
- if ((narg == arg) || (arg < 0.0))
- return (narg);
- else
- return (narg + 1.0);
-}
-
-#endif
+ GENERIC_FUNCTION (atan)
\f
-#define Truncate_Mapping(arg) arg
-#define Round_Mapping(arg) ((arg) >= 0.0 ? ((arg) + 0.5) : ((arg) - 0.5))
-#define Floor_Mapping(arg) floor(arg)
-#define Ceiling_Mapping(arg) ceil(arg)
-
-#define Flonum_To_Integer(How_To_Do_It) \
- Primitive_1_Arg(); \
- \
- Set_Time_Zone(Zone_Math); \
- switch (Type_Code(Arg1)) \
+#define FLONUM_TO_INTEGER_PRIMITIVE(mapping) \
+{ \
+ PRIMITIVE_HEADER (1); \
+ Set_Time_Zone (Zone_Math); \
{ \
- case TC_FIXNUM : \
- case TC_BIG_FIXNUM: \
- return Arg1; \
- case TC_BIG_FLONUM: \
- { \
- fast double Arg, temp; \
- Pointer Result; \
- \
- Arg = Get_Float(Arg1); \
- temp = How_To_Do_It(Arg); \
- 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); \
- }
-
-DEFINE_PRIMITIVE ("TRUNCATE", Prim_truncate, 1, 1, 0)
-{
- Flonum_To_Integer(Truncate_Mapping);
- /*NOTREACHED*/
+ fast SCHEME_OBJECT number = (ARG_REF (1)); \
+ PRIMITIVE_RETURN \
+ ((FLONUM_P (number)) \
+ ? (FLONUM_TO_INTEGER (mapping (number))) \
+ : (INTEGER_P (number)) \
+ ? number \
+ : ((error_wrong_type_arg (1)), ((SCHEME_OBJECT) 0))); \
+ } \
}
+DEFINE_PRIMITIVE ("TRUNCATE", Prim_truncate, 1, 1, 0)
+ FLONUM_TO_INTEGER_PRIMITIVE (FLONUM_TRUNCATE)
DEFINE_PRIMITIVE ("ROUND", Prim_round, 1, 1, 0)
-{
- Flonum_To_Integer(Round_Mapping);
- /*NOTREACHED*/
-}
-
+ FLONUM_TO_INTEGER_PRIMITIVE (flonum_round)
DEFINE_PRIMITIVE ("FLOOR", Prim_floor, 1, 1, 0)
-{
- Flonum_To_Integer(Floor_Mapping);
- /*NOTREACHED*/
-}
-
+ FLONUM_TO_INTEGER_PRIMITIVE (flonum_floor)
DEFINE_PRIMITIVE ("CEILING", Prim_ceiling, 1, 1, 0)
-{
- Flonum_To_Integer(Ceiling_Mapping);
- /*NOTREACHED*/
-}
+ FLONUM_TO_INTEGER_PRIMITIVE (flonum_ceiling)
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/history.h,v 9.25 1989/09/20 23:08:59 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/history.h,v 9.24 1988/08/15 20:48:56 cph Rel $
- *
- * History maintenance data structures and support.
- *
- */
+/* History maintenance data structures and support. */
\f
-/*
- * 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.
- */
+/* 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 RIB_NEXT_REDUCTION 2
#define RIB_MARK 2
-#define HISTORY_MARK_TYPE (UNMARKED_HISTORY_TYPE ^ MARKED_HISTORY_TYPE)
-#define HISTORY_MARK_MASK (HISTORY_MARK_TYPE << ADDRESS_LENGTH)
+#define HISTORY_MARK_TYPE (UNMARKED_HISTORY_TYPE ^ MARKED_HISTORY_TYPE)
+#define HISTORY_MARK_MASK (HISTORY_MARK_TYPE << DATUM_LENGTH)
#if ((UNMARKED_HISTORY_TYPE | HISTORY_MARK_TYPE) != MARKED_HISTORY_TYPE)
#include "error: Bad history types in types.h and history.h"
#endif
-#define HISTORY_MARK(object) \
-{ \
- (object) |= (HISTORY_MARK_MASK); \
-}
-
-#define HISTORY_UNMARK(object) \
-{ \
- (object) &= (~HISTORY_MARK_MASK); \
-}
+#define HISTORY_MARK(object) (object) |= HISTORY_MARK_MASK
+#define HISTORY_UNMARK(object) (object) &=~ HISTORY_MARK_MASK
+#define HISTORY_MARKED_P(object) (((object) & HISTORY_MARK_MASK) != 0)
-#define HISTORY_MARKED_P(object) ((object) & HISTORY_MARK_MASK)
-\f
-/* 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.
- */
+/* 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 #F to signify this. If
+ there is no previous restore history then the history pointer is #F
+ and the offset is 0. */
#define Save_History(Return_Code) \
{ \
- if (Prev_Restore_History_Stacklet == NULL) \
- Push(NIL); \
- else \
- Push(Make_Pointer(TC_CONTROL_POINT, \
- Prev_Restore_History_Stacklet)); \
- Push(Make_Non_Pointer(TC_FIXNUM, Prev_Restore_History_Offset)); \
- Store_Expression(Make_Pointer(UNMARKED_HISTORY_TYPE, History)); \
- Store_Return((Return_Code)); \
- Save_Cont(); \
- History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History)); \
+ Push \
+ ((Prev_Restore_History_Stacklet == NULL) \
+ ? SHARP_F \
+ : (MAKE_POINTER_OBJECT \
+ (TC_CONTROL_POINT, Prev_Restore_History_Stacklet))); \
+ Push (LONG_TO_UNSIGNED_FIXNUM (Prev_Restore_History_Offset)); \
+ Store_Expression \
+ (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History)); \
+ Store_Return (Return_Code); \
+ Save_Cont (); \
+ History = (OBJECT_ADDRESS (Get_Fixed_Obj_Slot (Dummy_History))); \
}
\f
/* History manipulation in the interpreter. */
#ifdef COMPILE_HISTORY
-#define New_Subproblem(Expr, Env) \
+
+#define New_Subproblem(expression, environment) \
{ \
- fast Pointer *Rib; \
- \
- History = Get_Pointer(History[HIST_NEXT_SUBPROBLEM]); \
- HISTORY_MARK(History[HIST_MARK]); \
- Rib = Get_Pointer(History[HIST_RIB]); \
- HISTORY_MARK(Rib[RIB_MARK]); \
- Rib[RIB_ENV] = Env; \
- Rib[RIB_EXP] = Expr; \
+ History = (OBJECT_ADDRESS (History [HIST_NEXT_SUBPROBLEM])); \
+ HISTORY_MARK (History [HIST_MARK]); \
+ { \
+ fast SCHEME_OBJECT * Rib = (OBJECT_ADDRESS (History [HIST_RIB])); \
+ HISTORY_MARK (Rib [RIB_MARK]); \
+ (Rib [RIB_ENV]) = (environment); \
+ (Rib [RIB_EXP]) = (expression); \
+ } \
}
-#define Reuse_Subproblem(Expr, Env) \
+#define Reuse_Subproblem(expression, environment) \
{ \
- fast Pointer *Rib; \
- \
- Rib = Get_Pointer(History[HIST_RIB]); \
- HISTORY_MARK(Rib[RIB_MARK]); \
- Rib[RIB_ENV] = Env; \
- Rib[RIB_EXP] = Expr; \
+ fast SCHEME_OBJECT * Rib = (OBJECT_ADDRESS (History [HIST_RIB])); \
+ HISTORY_MARK (Rib [RIB_MARK]); \
+ (Rib [RIB_ENV]) = (environment); \
+ (Rib [RIB_EXP]) = (expression); \
}
-#define New_Reduction(Expr, Env) \
+#define New_Reduction(expression, environment) \
{ \
- fast Pointer *Rib; \
- \
- Rib = Get_Pointer(Fast_Vector_Ref(History[HIST_RIB], \
- RIB_NEXT_REDUCTION)); \
- History[HIST_RIB] = Make_Pointer(UNMARKED_HISTORY_TYPE, Rib); \
- Rib[RIB_ENV] = Env; \
- Rib[RIB_EXP] = Expr; \
- HISTORY_UNMARK(Rib[RIB_MARK]); \
+ fast SCHEME_OBJECT * Rib = \
+ (OBJECT_ADDRESS \
+ (FAST_MEMORY_REF ((History [HIST_RIB]), RIB_NEXT_REDUCTION))); \
+ (History [HIST_RIB]) = \
+ (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, Rib)); \
+ (Rib [RIB_ENV]) = (environment); \
+ (Rib [RIB_EXP]) = (expression); \
+ HISTORY_UNMARK (Rib [RIB_MARK]); \
}
#define End_Subproblem() \
{ \
- HISTORY_UNMARK(History[HIST_MARK]); \
- History = Get_Pointer(History[HIST_PREV_SUBPROBLEM]); \
+ HISTORY_UNMARK (History [HIST_MARK]); \
+ History = (OBJECT_ADDRESS (History [HIST_PREV_SUBPROBLEM])); \
}
#else /* not COMPILE_HISTORY */
-#define New_Subproblem(Expr, Env) { }
-#define Reuse_Subproblem(Expr, Env) { }
-#define New_Reduction(Expr, Env) { }
-#define End_Subproblem() { }
+#define New_Subproblem(Expr, Env) {}
+#define Reuse_Subproblem(Expr, Env) {}
+#define New_Reduction(Expr, Env) {}
+#define End_Subproblem() {}
#endif /* COMPILE_HISTORY */
\f
#define Compiler_New_Reduction() \
{ \
- New_Reduction(NIL, \
- Make_Non_Pointer(TC_RETURN_CODE, \
- RC_POP_FROM_COMPILED_CODE)); \
+ New_Reduction \
+ (SHARP_F, \
+ (MAKE_OBJECT (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)); \
+ New_Subproblem \
+ (SHARP_F, \
+ (MAKE_OBJECT (TC_RETURN_CODE, RC_POP_FROM_COMPILED_CODE))); \
}
-#define Compiler_End_Subproblem() \
-{ \
- End_Subproblem(); \
-}
+#define Compiler_End_Subproblem End_Subproblem
#else /* not COMPILE_HISTORY */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.36 1989/05/31 01:50:19 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.37 1989/09/20 23:09:04 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
#include "winder.h"
#include "history.h"
\f
-/* (APPLY FN LIST-OF-ARGUMENTS)
- Calls the function FN to the arguments specified in the list
- LIST-OF-ARGUMENTS. FN must be a primitive procedure, compound
- procedure, or control point. */
-
DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2, 0)
{
- fast Pointer scan_list, *scan_stack;
- fast long number_of_args, i;
-#ifdef PARALLEL_PROCESSOR
- Pointer *saved_stack_pointer;
+ SCHEME_OBJECT procedure;
+ SCHEME_OBJECT argument_list;
+ fast long number_of_args;
+#ifdef LOSING_PARALLEL_PROCESSOR
+ SCHEME_OBJECT * saved_stack_pointer;
#endif
- Primitive_2_Args();
-
+ PRIMITIVE_HEADER (2);
+ procedure = (ARG_REF (1));
+ argument_list = (ARG_REF (2));
/* 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
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.
- */
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- Touch_In_Primitive( Arg2, scan_list);
- number_of_args = 0;
- while (OBJECT_TYPE( scan_list) == TC_LIST)
+ is sufficiently high that it probably makes up for the time saved. */
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
{
- number_of_args += 1;
- Touch_In_Primitive( Vector_Ref( scan_list, CONS_CDR), scan_list);
- }
- if (scan_list != NIL)
- {
- signal_error_from_primitive( ERR_ARG_2_WRONG_TYPE);
+ fast SCHEME_OBJECT scan_list;
+ TOUCH_IN_PRIMITIVE (argument_list, scan_list);
+ number_of_args = 0;
+ while (PAIR_P (scan_list))
+ {
+ number_of_args += 1;
+ TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
+ }
+ if (scan_list != EMPTY_LIST)
+ error_wrong_type_arg (2);
}
#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));
+ Primitive_GC_If_Needed
+ (New_Stacklet_Size (number_of_args + STACK_ENV_EXTRA_SLOTS + 1));
#endif
- Pop_Primitive_Frame( 2);
-\f
- Will_Push( (number_of_args + STACK_ENV_EXTRA_SLOTS + 1));
-#ifdef PARALLEL_PROCESSOR
+ Pop_Primitive_Frame (2);
+ Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1);
+#ifdef LOSING_PARALLEL_PROCESSOR
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 PARALLEL_PROCESSOR
- /* Check for abominable case of someone bashing the arg list. */
- if (OBJECT_TYPE( scan_list) != TC_LIST)
- {
- Stack_Pointer = saved_stack_pointer;
- signal_error_from_primitive (ERR_ARG_2_BAD_RANGE);
- }
+ fast long i;
+ fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
+ fast SCHEME_OBJECT scan_list;
+ Stack_Pointer = scan_stack;
+ TOUCH_IN_PRIMITIVE (argument_list, scan_list);
+ for (i = number_of_args; (i > 0); i -= 1)
+ {
+#ifdef LOSING_PARALLEL_PROCESSOR
+ /* This half-measure should be replaced by some kind of lock
+ or something else that guarantees that the code will win. */
+ /* Check for abominable case of someone bashing the arg list. */
+ if (! (PAIR_P (scan_list)))
+ {
+ Stack_Pointer = saved_stack_pointer;
+ error_bad_range_arg (2);
+ }
#endif
- *scan_stack++ = Vector_Ref( scan_list, CONS_CAR);
- Touch_In_Primitive ((Vector_Ref (scan_list, CONS_CDR)), scan_list);
- i -= 1;
+ (*scan_stack++) = (PAIR_CAR (scan_list));
+ TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
+ }
}
- Push (Arg1); /* The procedure */
- Push ((STACK_FRAME_HEADER + number_of_args));
+ Push (procedure);
+ Push (STACK_FRAME_HEADER + number_of_args);
Pushed ();
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
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.
-*/
+ >>> return hook that may be in the stack. */
-#define CWCC(Return_Code) \
+#define CWCC(return_code, reuse_flag, receiver_expression) \
{ \
- fast Pointer *From_Where; \
- \
- CWCC_1(); \
- Pop_Primitive_Frame(1); \
+ SCHEME_OBJECT receiver = (receiver_expression); \
+ CWCC_1 (); \
+ 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_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK())); \
- Store_Return(RC_RESTORE_INT_MASK); \
- Save_Cont(); \
- Pushed(); \
- /* \
- There is no history to use since the last control point was formed. \
- */ \
+ { \
+ (* 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 (LONG_TO_FIXNUM (FETCH_INTERRUPT_MASK())); \
+ Store_Return (RC_RESTORE_INT_MASK); \
+ Save_Cont (); \
+ Pushed (); \
+ /* There is no history to use since the \
+ last control point was formed. */ \
Prev_Restore_History_Stacklet = NULL; \
Prev_Restore_History_Offset = 0; \
- CWCC_2(); \
- /* we just cleared the stack so there MUST be room */ \
- /* Will_Push(3); */ \
- Push(Control_Point); \
- Push(Arg1); /* Function */ \
- Push(STACK_FRAME_HEADER + 1); \
- /* Pushed(); */ \
+ { \
+ SCHEME_OBJECT control_point; \
+ CWCC_2 (control_point, reuse_flag); \
+ /* we just cleared the stack so there MUST be room */ \
+ /* Will_Push(3); */ \
+ Push (control_point); \
+ Push (receiver); \
+ Push (STACK_FRAME_HEADER + 1); \
+ /* Pushed(); */ \
+ } \
}
\f
#ifdef USE_STACKLETS
#define CWCC_1() \
{ \
- Primitive_GC_If_Needed(2 * Default_Stacklet_Size); \
+ Primitive_GC_If_Needed (2 * Default_Stacklet_Size); \
}
-#define CWCC_2() \
+#define CWCC_2(target, reuse_flag) \
{ \
- Control_Point = Get_Current_Stacklet(); \
- Allocate_New_Stacklet(3); \
+ (target) = (Get_Current_Stacklet ()); \
+ Allocate_New_Stacklet (3); \
}
#else /* not USE_STACKLETS */
#define CWCC_1() \
{ \
- Primitive_GC_If_Needed((Stack_Top - Stack_Pointer) + \
- STACKLET_HEADER_SIZE + \
- CONTINUATION_SIZE + \
- HISTORY_SIZE); \
+ Primitive_GC_If_Needed \
+ ((Stack_Top - Stack_Pointer) + \
+ STACKLET_HEADER_SIZE + \
+ CONTINUATION_SIZE + \
+ HISTORY_SIZE); \
}
-#define CWCC_2() \
+#define CWCC_2(target, reuse_flag) \
{ \
- fast long i, Stack_Cells; \
- \
- 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_REUSE_FLAG] = SHARP_T; \
- Free[STACKLET_UNUSED_LENGTH] = \
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0); \
- Free += STACKLET_HEADER_SIZE; \
- for (i = Stack_Cells; --i >= 0; ) \
+ fast long n_words = (Stack_Top - Stack_Pointer); \
+ (target) = \
+ (allocate_marked_vector \
+ (TC_CONTROL_POINT, \
+ (n_words + (STACKLET_HEADER_SIZE - 1)), \
+ false)); \
+ FAST_MEMORY_SET ((target), STACKLET_REUSE_FLAG, (reuse_flag)); \
+ FAST_MEMORY_SET \
+ ((target), \
+ STACKLET_UNUSED_LENGTH, \
+ (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0))); \
{ \
- *Free++ = Pop(); \
+ fast SCHEME_OBJECT * scan = \
+ (MEMORY_LOC ((target), STACKLET_HEADER_SIZE)); \
+ while ((n_words--) > 0) \
+ (*scan++) = (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(); \
+ if (Consistency_Check && (Stack_Pointer != Stack_Top)) \
+ Microcode_Termination (TERM_BAD_STACK); \
+ Will_Push (CONTINUATION_SIZE); \
+ Store_Return (RC_JOIN_STACKLETS); \
+ Store_Expression (target); \
+ Save_Cont (); \
+ Pushed (); \
}
#endif /* USE_STACKLETS */
will be copied on every throw. The user level CATCH is built on
this primitive but is not the same, since it handles dynamic state
while the primitive does not; it assumes that the microcode sets
- and clears the appropriate reuse flags for copying.
-*/
+ and clears the appropriate reuse flags for copying. */
DEFINE_PRIMITIVE ("CALL-WITH-CURRENT-CONTINUATION", Prim_catch, 1, 1, 0)
{
- Pointer Control_Point;
- Primitive_1_Arg ();
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- CWCC (RC_RESTORE_HISTORY);
- Vector_Set (Control_Point, STACKLET_REUSE_FLAG, NIL);
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ CWCC (RC_RESTORE_HISTORY, SHARP_F, (ARG_REF (1)));
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
}
DEFINE_PRIMITIVE ("NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION", Prim_non_reentrant_catch, 1, 1, 0)
{
- Pointer Control_Point;
- Primitive_1_Arg ();
-
+ PRIMITIVE_HEADER (1);
PRIMITIVE_CANONICALIZE_CONTEXT();
-
#ifdef USE_STACKLETS
-
- CWCC (RC_RESTORE_DONT_COPY_HISTORY);
-
+ CWCC (RC_RESTORE_DONT_COPY_HISTORY, SHARP_T, (ARG_REF (1)));
#else
/* When there are no stacklets, it is identical to the reentrant version. */
-
- CWCC (RC_RESTORE_HISTORY);
- Vector_Set (Control_Point, STACKLET_REUSE_FLAG, NIL);
-
+ CWCC (RC_RESTORE_HISTORY, SHARP_F, (ARG_REF (1)));
#endif
-
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
}
-\f
-/* (DISABLE-INTERRUPTS! INTERRUPTS)
- Disables the interrupts specified by INTERRUPTS. These interrupts
- will trigger when the corresponding bits are enabled by ENABLE-INTERRUPTS!,
- SET-INTERRUPT-ENABLES!, WITH-INTERRUPT-MASK, or a throw.
- See intrpt.h for more information on interrupts.
-*/
-DEFINE_PRIMITIVE ("DISABLE-INTERRUPTS!", Prim_disable_interrupts, 1, 1, 0)
-{
- long previous;
- PRIMITIVE_HEADER (1);
-
- previous = (FETCH_INTERRUPT_MASK ());
- SET_INTERRUPT_MASK (previous & (~((arg_fixnum (1)) & INT_Mask)));
- PRIMITIVE_RETURN (MAKE_SIGNED_FIXNUM (previous));
-}
-
-/* (ENABLE-INTERRUPTS! INTERRUPTS)
- Enables the interrupts specified by INTERRUPTS. At the next interrupt
- point, any pending interrupts which were previously disabled will trigger.
- See intrpt.h for more information on interrupts.
-*/
-DEFINE_PRIMITIVE ("ENABLE-INTERRUPTS!", Prim_enable_interrupts, 1, 1, 0)
-{
- long previous;
- PRIMITIVE_HEADER (1);
-
- previous = (FETCH_INTERRUPT_MASK ());
- SET_INTERRUPT_MASK (previous | ((arg_fixnum (1)) & INT_Mask));
- PRIMITIVE_RETURN (MAKE_SIGNED_FIXNUM (previous));
-}
-/* (ERROR-PROCEDURE arg1 arg2 arg3)
- Passes its arguments along to the appropriate Scheme error handler
- after turning off history, etc.
-*/
-DEFINE_PRIMITIVE ("ERROR-PROCEDURE", Prim_error_procedure, 3, 3, 0)
+DEFINE_PRIMITIVE ("WITHIN-CONTROL-POINT", Prim_within_control_point, 2, 2, 0)
{
- Primitive_3_Args();
-
+ PRIMITIVE_HEADER (2);
PRIMITIVE_CANONICALIZE_CONTEXT();
- /*
- This is done outside the Will_Push because the space for it
- is guaranteed by the interpreter before it gets here.
- If done inside, this could break when using stacklets.
- */
- Back_Out_Of_Primitive();
- Save_Cont();
- Will_Push(HISTORY_SIZE+STACK_ENV_EXTRA_SLOTS+4);
- 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();
+ CHECK_ARG (1, CONTROL_POINT_P);
+ {
+ fast SCHEME_OBJECT control_point = (ARG_REF (1));
+ SCHEME_OBJECT thunk = (ARG_REF (2));
+ Our_Throw (false, control_point);
+ Within_Stacklet_Backout ();
+ Our_Throw_Part_2 ();
+ Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
+ Push (thunk);
+ Push (STACK_FRAME_HEADER);
+ Pushed ();
+ }
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
}
\f
-/* (GET-FIXED-OBJECTS-VECTOR)
- 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.
-*/
-DEFINE_PRIMITIVE ("GET-FIXED-OBJECTS-VECTOR", Prim_get_fixed_objects_vector, 0, 0, 0)
+DEFINE_PRIMITIVE ("ERROR-PROCEDURE", Prim_error_procedure, 3, 3, 0)
{
- Primitive_0_Args ();
+ PRIMITIVE_HEADER (3);
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ {
+ fast SCHEME_OBJECT message = (ARG_REF (1));
+ fast SCHEME_OBJECT irritants = (ARG_REF (2));
+ fast SCHEME_OBJECT environment = (ARG_REF (3));
+ /* This is done outside the Will_Push because the space for it
+ is guaranteed by the interpreter before it gets here.
+ If done inside, this could break when using stacklets. */
+ Back_Out_Of_Primitive ();
+ Save_Cont ();
+ Will_Push (HISTORY_SIZE + STACK_ENV_EXTRA_SLOTS + 4);
+ Stop_History ();
+ /* Stepping should be cleared here! */
+ Push (environment);
+ Push (irritants);
+ Push (message);
+ Push (Get_Fixed_Obj_Slot (Error_Procedure));
+ Push (STACK_FRAME_HEADER + 3);
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ /*NOTREACHED*/
+ }
+}
- if (Valid_Fixed_Obj_Vector ())
- PRIMITIVE_RETURN (Get_Fixed_Obj_Slot (Me_Myself));
- else
- PRIMITIVE_RETURN (NIL);
+DEFINE_PRIMITIVE ("SCODE-EVAL", Prim_scode_eval, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ CHECK_ARG (2, ENVIRONMENT_P);
+ {
+ fast SCHEME_OBJECT expression = (ARG_REF (1));
+ fast SCHEME_OBJECT environment = (ARG_REF (2));
+ Pop_Primitive_Frame (2);
+ Store_Env (environment);
+ Store_Expression (expression);
+ }
+ PRIMITIVE_ABORT (PRIM_DO_EXPRESSION);
+ /*NOTREACHED*/
}
\f
-/* (FORCE DELAYED-OBJECT)
- 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. */
-
-#define DELAYED_P(object) ((OBJECT_TYPE (object)) == TC_DELAYED)
-
DEFINE_PRIMITIVE ("FORCE", Prim_force, 1, 1, 0)
{
- fast Pointer thunk;
PRIMITIVE_HEADER (1);
-
- CHECK_ARG (1, DELAYED_P);
- thunk = (ARG_REF (1));
- switch (Vector_Ref (thunk, THUNK_SNAPPED))
- {
- case SHARP_T:
- PRIMITIVE_RETURN (Vector_Ref (thunk, THUNK_VALUE));
-
- case FIXNUM_ZERO:
- {
- /* New-style thunk used by compiled code. */
- PRIMITIVE_CANONICALIZE_CONTEXT();
- Pop_Primitive_Frame (1);
- Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
- Store_Return (RC_SNAP_NEED_THUNK);
- Store_Expression (thunk);
- Save_Cont ();
- Push (Vector_Ref (thunk, THUNK_VALUE));
- Push (STACK_FRAME_HEADER);
- Pushed ();
- PRIMITIVE_ABORT (PRIM_APPLY);
- /*NOTREACHED*/
- }
-
- default:
+ CHECK_ARG (1, PROMISE_P);
+ {
+ fast SCHEME_OBJECT thunk = (ARG_REF (1));
+ switch (MEMORY_REF (thunk, THUNK_SNAPPED))
{
- /* Old-style thunk used by interpreted code. */
- PRIMITIVE_CANONICALIZE_CONTEXT();
- Pop_Primitive_Frame (1);
- Will_Push (CONTINUATION_SIZE);
- Store_Return (RC_SNAP_NEED_THUNK);
- Store_Expression (thunk);
- Save_Cont ();
- Pushed ();
- Store_Env (Fast_Vector_Ref (thunk, THUNK_ENVIRONMENT));
- Store_Expression (Fast_Vector_Ref (thunk, THUNK_PROCEDURE));
- PRIMITIVE_ABORT (PRIM_DO_EXPRESSION);
- /*NOTREACHED*/
+ case SHARP_T:
+ PRIMITIVE_RETURN (MEMORY_REF (thunk, THUNK_VALUE));
+
+ case FIXNUM_ZERO:
+ {
+ /* New-style thunk used by compiled code. */
+ PRIMITIVE_CANONICALIZE_CONTEXT();
+ Pop_Primitive_Frame (1);
+ Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
+ Store_Return (RC_SNAP_NEED_THUNK);
+ Store_Expression (thunk);
+ Save_Cont ();
+ Push (MEMORY_REF (thunk, THUNK_VALUE));
+ Push (STACK_FRAME_HEADER);
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ /*NOTREACHED*/
+ }
+
+ default:
+ {
+ /* Old-style thunk used by interpreted code. */
+ PRIMITIVE_CANONICALIZE_CONTEXT();
+ Pop_Primitive_Frame (1);
+ Will_Push (CONTINUATION_SIZE);
+ Store_Return (RC_SNAP_NEED_THUNK);
+ Store_Expression (thunk);
+ Save_Cont ();
+ Pushed ();
+ Store_Env (FAST_MEMORY_REF (thunk, THUNK_ENVIRONMENT));
+ Store_Expression (FAST_MEMORY_REF (thunk, THUNK_PROCEDURE));
+ PRIMITIVE_ABORT (PRIM_DO_EXPRESSION);
+ /*NOTREACHED*/
+ }
}
- }
+ }
}
\f
-/* (EXECUTE-AT-NEW-STATE-POINT SPACE BEFORE DURING AFTER)
- 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.
-*/
+/* State Space Implementation */
+
DEFINE_PRIMITIVE ("EXECUTE-AT-NEW-STATE-POINT", Prim_execute_at_new_point, 4, 4, 0)
{
- Pointer New_Point, Old_Point;
- Primitive_4_Args();
+ PRIMITIVE_HEADER (4);
- PRIMITIVE_CANONICALIZE_CONTEXT();
- guarantee_state_point();
- if (Arg1 == NIL)
- Old_Point = Current_State_Point;
- else
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ guarantee_state_point ();
{
- Arg_1_Type(TC_VECTOR);
- if (Vector_Ref(Arg1, STATE_SPACE_TAG) !=
- Get_Fixed_Obj_Slot(State_Space_Tag))
+ SCHEME_OBJECT old_point;
+ if ((ARG_REF (1)) == SHARP_F)
+ old_point = Current_State_Point;
+ else
+ {
+ CHECK_ARG (1, STATE_SPACE_P);
+ old_point =
+ (FAST_MEMORY_REF ((ARG_REF (1)), STATE_SPACE_NEAREST_POINT));
+ }
{
- signal_error_from_primitive(ERR_ARG_1_WRONG_TYPE);
+ SCHEME_OBJECT new_point =
+ (allocate_marked_vector (TC_VECTOR, STATE_POINT_LENGTH, true));
+ SCHEME_OBJECT during_thunk = (ARG_REF (3));
+ FAST_MEMORY_SET
+ (new_point, STATE_POINT_TAG, (Get_Fixed_Obj_Slot (State_Point_Tag)));
+ FAST_MEMORY_SET (new_point, STATE_POINT_BEFORE_THUNK, (ARG_REF (2)));
+ FAST_MEMORY_SET (new_point, STATE_POINT_AFTER_THUNK, (ARG_REF (4)));
+ FAST_MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, old_point);
+ FAST_MEMORY_SET
+ (new_point,
+ STATE_POINT_DISTANCE_TO_ROOT,
+ (1 + (FAST_MEMORY_REF (old_point, STATE_POINT_DISTANCE_TO_ROOT))));
+
+ Pop_Primitive_Frame (4);
+ 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 (during_thunk);
+ Push (STACK_FRAME_HEADER);
+ /* Push the continuation to go with the stack frame */
+ Store_Expression (SHARP_F);
+ Store_Return (RC_INTERNAL_APPLY);
+ Save_Cont ();
+ Pushed ();
+ Translate_To_Point (new_point);
+ /*NOTREACHED*/
}
- 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);
- /*NOTREACHED*/
}
-\f
-/* (MAKE-STATE-SPACE MUTABLE?)
- 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.
-*/
-DEFINE_PRIMITIVE ("MAKE-STATE-SPACE", Prim_make_state_space, 1, 1, 0)
+
+DEFINE_PRIMITIVE ("TRANSLATE-TO-STATE-POINT", Prim_translate_to_point, 1, 1, 0)
{
- 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] = Make_Unsigned_Fixnum(0);
- Free += STATE_POINT_SIZE;
- if (Arg1 == NIL)
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ CHECK_ARG (1, STATE_POINT_P);
{
- Current_State_Point = New_Point;
- PRIMITIVE_RETURN( NIL);
+ SCHEME_OBJECT state_point = (ARG_REF (1));
+ Pop_Primitive_Frame (1);
+ Translate_To_Point (state_point);
+ /*NOTREACHED*/
}
- else
+}
+\f
+DEFINE_PRIMITIVE ("MAKE-STATE-SPACE", Prim_make_state_space, 1, 1,
+ "Return a newly-allocated state-space.
+Argument MUTABLE?, if not #F, means return a mutable state-space.
+Otherwise, -the- immutable state-space is saved internally.")
+{
+ PRIMITIVE_HEADER (1);
{
- Pointer New_Space;
-
- 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);
- PRIMITIVE_RETURN( New_Space);
+ fast SCHEME_OBJECT new_point =
+ (allocate_marked_vector (TC_VECTOR, STATE_POINT_LENGTH, true));
+ FAST_MEMORY_SET
+ (new_point, STATE_POINT_TAG, (Get_Fixed_Obj_Slot (State_Point_Tag)));
+ FAST_MEMORY_SET (new_point, STATE_POINT_BEFORE_THUNK, SHARP_F);
+ FAST_MEMORY_SET (new_point, STATE_POINT_AFTER_THUNK, SHARP_F);
+ FAST_MEMORY_SET
+ (new_point, STATE_POINT_DISTANCE_TO_ROOT, (LONG_TO_UNSIGNED_FIXNUM (0)));
+ if ((ARG_REF (1)) == SHARP_F)
+ {
+ FAST_MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, SHARP_F);
+ Current_State_Point = new_point;
+ PRIMITIVE_RETURN (SHARP_F);
+ }
+ else
+ {
+ fast SCHEME_OBJECT new_space =
+ (allocate_marked_vector (TC_VECTOR, STATE_SPACE_LENGTH, true));
+ FAST_MEMORY_SET
+ (new_space, STATE_SPACE_TAG, (Get_Fixed_Obj_Slot (State_Space_Tag)));
+ FAST_MEMORY_SET (new_space, STATE_SPACE_NEAREST_POINT, new_point);
+ FAST_MEMORY_SET (new_point, STATE_POINT_NEARER_POINT, new_space);
+ PRIMITIVE_RETURN (new_space);
+ }
}
}
-\f
+
DEFINE_PRIMITIVE ("CURRENT-DYNAMIC-STATE", Prim_current_dynamic_state, 1, 1, 0)
{
- Primitive_1_Arg();
+ PRIMITIVE_HEADER (1);
- guarantee_state_point();
- if (Arg1 == NIL)
- {
- PRIMITIVE_RETURN( Current_State_Point);
- }
- Arg_1_Type(TC_VECTOR);
- if (Fast_Vector_Ref(Arg1, STATE_SPACE_TAG) !=
- Get_Fixed_Obj_Slot(State_Space_Tag))
- {
- signal_error_from_primitive(ERR_ARG_1_WRONG_TYPE);
- }
- PRIMITIVE_RETURN( Vector_Ref(Arg1, STATE_SPACE_NEAREST_POINT));
+ guarantee_state_point ();
+ if ((ARG_REF (1)) == SHARP_F)
+ PRIMITIVE_RETURN (Current_State_Point);
+ CHECK_ARG (1, STATE_SPACE_P);
+ PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), STATE_SPACE_NEAREST_POINT));
}
DEFINE_PRIMITIVE ("SET-CURRENT-DYNAMIC-STATE!", Prim_set_dynamic_state, 1, 1, 0)
{
- 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))
- signal_error_from_primitive(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
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, STATE_POINT_P);
{
- Result = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT);
- Vector_Set(State_Space, STATE_SPACE_NEAREST_POINT, Arg1);
+ fast SCHEME_OBJECT state_point = (ARG_REF (1));
+ fast SCHEME_OBJECT state_space = (Find_State_Space (state_point));
+ fast SCHEME_OBJECT result;
+ if (state_space == SHARP_F)
+ {
+ guarantee_state_point ();
+ result = Current_State_Point;
+ Current_State_Point = state_point;
+ }
+ else
+ {
+ result = (MEMORY_REF (state_space, STATE_SPACE_NEAREST_POINT));
+ MEMORY_SET (state_space, STATE_SPACE_NEAREST_POINT, state_point);
+ }
+ PRIMITIVE_RETURN (result);
}
- PRIMITIVE_RETURN( Result);
}
\f
-/* (SCODE-EVAL SCODE-EXPRESSION ENVIRONMENT)
- 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.
-*/
-DEFINE_PRIMITIVE ("SCODE-EVAL", Prim_scode_eval, 2, 2, 0)
-{
- Primitive_2_Args();
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- if (OBJECT_TYPE(Arg2) != GLOBAL_ENV)
- Arg_2_Type(TC_ENVIRONMENT);
- Pop_Primitive_Frame(2);
- Store_Env(Arg2);
- Store_Expression(Arg1);
- PRIMITIVE_ABORT( PRIM_DO_EXPRESSION);
- /*NOTREACHED*/
-}
+/* Interrupts */
DEFINE_PRIMITIVE ("GET-INTERRUPT-ENABLES", Prim_get_interrupt_enables, 0, 0,
"Returns the current interrupt mask.")
{
PRIMITIVE_HEADER (0);
-
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (FETCH_INTERRUPT_MASK ()));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (FETCH_INTERRUPT_MASK ()));
}
DEFINE_PRIMITIVE ("SET-INTERRUPT-ENABLES!", Prim_set_interrupt_enables, 1, 1,
"Sets the interrupt mask to NEW-INT-ENABLES; returns previous mask value.\n\
See `mask_interrupt_enables' for more information on interrupts.")
{
- long previous;
PRIMITIVE_HEADER (1);
-
- previous = (FETCH_INTERRUPT_MASK ());
- SET_INTERRUPT_MASK ((FIXNUM_ARG (1)) & INT_Mask);
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (previous));
+ {
+ long previous = (FETCH_INTERRUPT_MASK ());
+ SET_INTERRUPT_MASK ((arg_integer (1)) & INT_Mask);
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (previous));
+ }
}
-DEFINE_PRIMITIVE ("CLEAR-INTERRUPTS!", Prim_clear_interrupts, 1, 1,
+DEFINE_PRIMITIVE ("CLEAR-INTERRUPTS!", Prim_clear_interrupts, 1, 1,
"Clears the interrupt bits in the MASK argument.\n\
The bits in MASK are interpreted as for `get-interrupt-enables'.")
{
PRIMITIVE_HEADER (1);
-
- CLEAR_INTERRUPT ((FIXNUM_ARG (1)) & INT_Mask);
- PRIMITIVE_RETURN (SHARP_F);
+ CLEAR_INTERRUPT ((arg_integer (1)) & INT_Mask);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
-/* (GET-FLUID-BINDINGS)
- Gets the microcode fluid-bindings variable. */
-DEFINE_PRIMITIVE ("GET-FLUID-BINDINGS", Prim_get_fluid_bindings, 0, 0, 0)
+DEFINE_PRIMITIVE ("DISABLE-INTERRUPTS!", Prim_disable_interrupts, 1, 1, 0)
{
- PRIMITIVE_HEADER (0);
-
- PRIMITIVE_RETURN (Fluid_Bindings);
+ PRIMITIVE_HEADER (1);
+ {
+ fast long previous = (FETCH_INTERRUPT_MASK ());
+ SET_INTERRUPT_MASK (previous &~ ((arg_integer (1)) & INT_Mask));
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM (previous));
+ }
}
-/* (SET-FLUID-BINDINGS! NEW-BINDINGS)
- Sets the microcode fluid-bindings variable.
- Returns the previous value. */
-
-DEFINE_PRIMITIVE ("SET-FLUID-BINDINGS!", Prim_set_fluid_bindings, 1, 1, 0)
+DEFINE_PRIMITIVE ("ENABLE-INTERRUPTS!", Prim_enable_interrupts, 1, 1, 0)
{
- Pointer new_bindings;
- Pointer old_bindings;
PRIMITIVE_HEADER (1);
-
- new_bindings = (ARG_REF (1));
- if (! ((new_bindings == NIL) || (PAIR_P (new_bindings))))
- error_wrong_type_arg (1);
- old_bindings = Fluid_Bindings;
- Fluid_Bindings = new_bindings;
- PRIMITIVE_RETURN (old_bindings);
+ {
+ fast long previous = (FETCH_INTERRUPT_MASK ());
+ SET_INTERRUPT_MASK (previous | ((arg_integer (1)) & INT_Mask));
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM (previous));
+ }
}
\f
-/* (SET-CURRENT-HISTORY! TRIPLE)
- 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.
+DEFINE_PRIMITIVE ("WITH-INTERRUPT-MASK", Prim_with_interrupt_mask, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ {
+ long new_mask = (INT_Mask & (arg_integer (1)));
+ SCHEME_OBJECT thunk = (ARG_REF (2));
+ SCHEME_OBJECT old_mask = (LONG_TO_FIXNUM (FETCH_INTERRUPT_MASK ()));
+ Pop_Primitive_Frame (2);
+ Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 2);
+ Store_Return (RC_RESTORE_INT_MASK);
+ Store_Expression (old_mask);
+ Save_Cont ();
+ Push (old_mask);
+ Push (thunk);
+ Push (STACK_FRAME_HEADER + 1);
+ Pushed ();
+ SET_INTERRUPT_MASK (new_mask);
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ /*NOTREACHED*/
+ }
+}
- This primitive pops its own frame and escapes back to the interpreter
- because it modifies one of the registers that the interpreter caches
- (History).
+DEFINE_PRIMITIVE ("WITH-INTERRUPTS-REDUCED", Prim_with_interrupts_reduced, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_CANONICALIZE_CONTEXT();
+ {
+ long new_mask = (INT_Mask & (arg_integer (1)));
+ SCHEME_OBJECT thunk = (ARG_REF (2));
+ long old_mask = (FETCH_INTERRUPT_MASK ());
+ Pop_Primitive_Frame (2);
+ Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 2);
+ Store_Return (RC_RESTORE_INT_MASK);
+ Store_Expression (old_mask);
+ Save_Cont ();
+ Push (LONG_TO_FIXNUM (old_mask));
+ Push (thunk);
+ Push (STACK_FRAME_HEADER + 1);
+ Pushed ();
+ SET_INTERRUPT_MASK
+ ((new_mask > old_mask) ? new_mask : (new_mask & old_mask));
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ /*NOTREACHED*/
+ }
+}
+\f
+/* History */
- The longjmp forces the interpreter to recache. */
+SCHEME_OBJECT
+initialize_history ()
+{
+ /* Dummy History Structure */
+ History = (Make_Dummy_History ());
+ return
+ (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, (Make_Dummy_History ())));
+}
DEFINE_PRIMITIVE ("SET-CURRENT-HISTORY!", Prim_set_current_history, 1, 1, 0)
{
- Primitive_1_Arg();
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- if (!(HUNK3_P(Arg1)))
- error_wrong_type_arg (1);
-
- Val = *History;
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ CHECK_ARG (1, HUNK3_P);
+ Val = (*History);
#ifdef COMPILE_HISTORY
- History = Get_Pointer(Arg1);
+ History = (OBJECT_ADDRESS (ARG_REF (1)));
#else
- History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History));
+ History = (OBJECT_ADDRESS (Get_Fixed_Obj_Slot (Dummy_History)));
#endif
- Pop_Primitive_Frame( 1);
- PRIMITIVE_ABORT( PRIM_POP_RETURN);
+ Pop_Primitive_Frame (1);
+ PRIMITIVE_ABORT (PRIM_POP_RETURN);
/*NOTREACHED*/
}
-/* (SET-FIXED-OBJECTS-VECTOR! VECTOR)
- 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.
-*/
-DEFINE_PRIMITIVE ("SET-FIXED-OBJECTS-VECTOR!", Prim_set_fixed_objects_vector, 1, 1, 0)
+DEFINE_PRIMITIVE ("WITH-HISTORY-DISABLED", Prim_with_history_disabled, 1, 1, 0)
{
- Pointer Result;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_VECTOR);
- if (Vector_Length(Arg1) < NFixed_Objects)
- {
- signal_error_from_primitive (ERR_ARG_1_BAD_RANGE);
- }
-
- if (Valid_Fixed_Obj_Vector())
- {
- Result = Get_Fixed_Obj_Slot(Me_Myself);
- }
- else
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
{
- Result = NIL;
+ SCHEME_OBJECT thunk = (ARG_REF (1));
+ /* Remove one reduction from the history before saving it */
+ SCHEME_OBJECT * first_rib = (OBJECT_ADDRESS (History [HIST_RIB]));
+ SCHEME_OBJECT * second_rib =
+ (OBJECT_ADDRESS (first_rib [RIB_NEXT_REDUCTION]));
+ if ((first_rib != second_rib) &&
+ (! (HISTORY_MARKED_P (first_rib [RIB_MARK]))))
+ {
+ HISTORY_MARK (second_rib [RIB_MARK]);
+ {
+ SCHEME_OBJECT * rib = first_rib;
+ while (1)
+ {
+ fast SCHEME_OBJECT * next_rib =
+ (OBJECT_ADDRESS (rib [RIB_NEXT_REDUCTION]));
+ if (next_rib == first_rib)
+ break;
+ rib = next_rib;
+ }
+ /* This maintains the mark in (History [HIST_RIB]). */
+ (History [HIST_RIB]) =
+ (MAKE_POINTER_OBJECT ((OBJECT_TYPE (History [HIST_RIB])), rib));
+ }
+ }
+ Pop_Primitive_Frame (1);
+ Stop_History ();
+ Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
+ Push (thunk);
+ Push (STACK_FRAME_HEADER);
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ /*NOTREACHED*/
}
- Set_Fixed_Obj_Hook(Arg1);
- Set_Fixed_Obj_Slot(Me_Myself, Arg1);
- PRIMITIVE_RETURN( Result);
}
\f
-/* (TRANSLATE-TO-STATE-POINT STATE_POINT)
- 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.
-*/
-DEFINE_PRIMITIVE ("TRANSLATE-TO-STATE-POINT", Prim_translate_to_point, 1, 1, 0)
-{
- Primitive_1_Arg();
+/* Miscellaneous State */
- PRIMITIVE_CANONICALIZE_CONTEXT();
- Arg_1_Type(TC_VECTOR);
- if (Vector_Ref(Arg1, STATE_POINT_TAG) != Get_Fixed_Obj_Slot(State_Point_Tag))
- signal_error_from_primitive(ERR_ARG_1_WRONG_TYPE);
- Pop_Primitive_Frame(1);
- Translate_To_Point(Arg1);
- /*NOTREACHED*/
+DEFINE_PRIMITIVE ("GET-FLUID-BINDINGS", Prim_get_fluid_bindings, 0, 0, 0)
+{
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (Fluid_Bindings);
}
-/* (WITH-HISTORY-DISABLED THUNK)
- 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.
-*/
-DEFINE_PRIMITIVE ("WITH-HISTORY-DISABLED", Prim_with_history_disabled, 1, 1, 0)
+DEFINE_PRIMITIVE ("SET-FLUID-BINDINGS!", Prim_set_fluid_bindings, 1, 1, 0)
{
- Pointer *First_Rib, *Rib, *Second_Rib;
- Primitive_1_Arg();
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- /* 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 (!((HISTORY_MARKED_P(First_Rib[RIB_MARK])) ||
- (First_Rib == Second_Rib)))
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, APPARENT_LIST_P);
{
- HISTORY_MARK(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 */
- }
- /* This maintains the mark in History[HIST_RIB] */
- History[HIST_RIB] = Make_Pointer(OBJECT_TYPE(History[HIST_RIB]), Rib);
+ SCHEME_OBJECT old_bindings = Fluid_Bindings;
+ Fluid_Bindings = (ARG_REF (1));
+ PRIMITIVE_RETURN (old_bindings);
}
- Pop_Primitive_Frame(1);
- Stop_History();
- Will_Push(STACK_ENV_EXTRA_SLOTS+1);
- Push(Arg1);
- Push(STACK_FRAME_HEADER);
- Pushed();
- PRIMITIVE_ABORT( PRIM_APPLY);
- /*NOTREACHED*/
}
-\f
-/* Called with a mask and a thunk */
-DEFINE_PRIMITIVE ("WITH-INTERRUPT-MASK", Prim_with_interrupt_mask, 2, 2, 0)
+DEFINE_PRIMITIVE ("GET-FIXED-OBJECTS-VECTOR", Prim_get_fixed_objects_vector, 0, 0, 0)
{
- Pointer mask;
- Primitive_2_Args();
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- Arg_1_Type(TC_FIXNUM);
- Pop_Primitive_Frame(2);
- mask = MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK());
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2));
- Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(mask);
- Save_Cont();
-
- Push(mask); /* Current interrupt mask */
- Push(Arg2); /* Function to call */
- Push(STACK_FRAME_HEADER+1);
- Pushed();
- SET_INTERRUPT_MASK(INT_Mask & Get_Integer(Arg1));
- PRIMITIVE_ABORT( PRIM_APPLY);
- /*NOTREACHED*/
+ PRIMITIVE_HEADER (0);
+ if (Valid_Fixed_Obj_Vector ())
+ PRIMITIVE_RETURN (Get_Fixed_Obj_Slot (Me_Myself));
+ PRIMITIVE_RETURN (SHARP_F);
}
-/* Called with a mask and a thunk */
-
-DEFINE_PRIMITIVE ("WITH-INTERRUPTS-REDUCED", Prim_with_interrupts_reduced, 2, 2, 0)
+DEFINE_PRIMITIVE ("SET-FIXED-OBJECTS-VECTOR!", Prim_set_fixed_objects_vector, 1, 1, 0)
{
- Pointer mask;
- long new_interrupt_mask, old_interrupt_mask;
- Primitive_2_Args();
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- Arg_1_Type(TC_FIXNUM);
- Pop_Primitive_Frame(2);
- mask = MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK());
-
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2));
- Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(mask);
- Save_Cont();
-
- Push(mask); /* Current interrupt mask */
- Push(Arg2); /* Function to call */
- Push(STACK_FRAME_HEADER+1);
- Pushed();
- new_interrupt_mask = (INT_Mask & Get_Integer( Arg1));
- old_interrupt_mask = FETCH_INTERRUPT_MASK();
- if (new_interrupt_mask > old_interrupt_mask)
- {
- SET_INTERRUPT_MASK(new_interrupt_mask);
- }
- else
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, VECTOR_P);
{
- SET_INTERRUPT_MASK(new_interrupt_mask & old_interrupt_mask);
+ fast SCHEME_OBJECT vector = (ARG_REF (1));
+ if ((VECTOR_LENGTH (vector)) < NFixed_Objects)
+ error_bad_range_arg (1);
+ {
+ SCHEME_OBJECT result =
+ ((Valid_Fixed_Obj_Vector ())
+ ? (Get_Fixed_Obj_Slot (Me_Myself))
+ : SHARP_F);
+ Set_Fixed_Obj_Hook (vector);
+ Set_Fixed_Obj_Slot (Me_Myself, vector);
+ PRIMITIVE_RETURN (result);
+ }
}
- PRIMITIVE_ABORT( PRIM_APPLY);
- /*NOTREACHED*/
-}
-\f
-/* (WITHIN-CONTROL-POINT CONTROL-POINT THUNK)
- 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.
-*/
-DEFINE_PRIMITIVE ("WITHIN-CONTROL-POINT", Prim_within_control_point, 2, 2, 0)
-{
- Primitive_2_Args();
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- 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();
- PRIMITIVE_ABORT( PRIM_APPLY);
- /*NOTREACHED*/
}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hunk.c,v 9.26 1989/09/20 23:09:10 cph Rel $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hunk.c,v 9.25 1988/08/15 20:49:17 cph Rel $
- *
- * Support for Hunk3s (triples)
- */
+/* Support for Hunk3s (triples) */
#include "scheme.h"
#include "prims.h"
+\f
+SCHEME_OBJECT
+hunk3_cons (cxr0, cxr1, cxr2)
+ SCHEME_OBJECT cxr0;
+ SCHEME_OBJECT cxr1;
+ SCHEME_OBJECT cxr2;
+{
+ Primitive_GC_If_Needed (3);
+ (*Free++) = cxr0;
+ (*Free++) = cxr1;
+ (*Free++) = cxr2;
+ return (MAKE_POINTER_OBJECT (TC_HUNK3, (Free - 3)));
+}
-/* (HUNK3-CONS FIRST SECOND THIRD)
- Returns a triple consisting of the specified values.
-*/
DEFINE_PRIMITIVE ("HUNK3-CONS", Prim_hunk3_cons, 3, 3, 0)
{
- Primitive_3_Args();
-
- Primitive_GC_If_Needed(3);
- *Free++ = Arg1;
- *Free++ = Arg2;
- *Free++ = Arg3;
- return Make_Pointer(TC_HUNK3, Free-3);
+ PRIMITIVE_HEADER (3);
+ PRIMITIVE_RETURN (hunk3_cons ((ARG_REF (1)), (ARG_REF (2)), (ARG_REF (3))));
}
-\f
-/* (HUNK3-CXR TRIPLE N)
- Returns the Nth item from the TRIPLE. N must be 0, 1, or 2.
-*/
+
DEFINE_PRIMITIVE ("HUNK3-CXR", Prim_hunk3_cxr, 2, 2, 0)
{
- long Offset;
- Primitive_2_Args();
-
- CHECK_ARG(1, HUNK3_P);
- CHECK_ARG(2, FIXNUM_P);
- Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE);
- return Vector_Ref(Arg1, Offset);
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, HUNK3_P);
+ PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), (arg_index_integer (2, 3))));
}
-/* (HUNK3-SET-CXR! TRIPLE N VALUE)
- Stores VALUE in the Nth item of TRIPLE. N must be 0, 1, or 2.
- Returns the previous contents.
-*/
DEFINE_PRIMITIVE ("HUNK3-SET-CXR!", Prim_hunk3_set_cxr, 3, 3, 0)
{
- long Offset;
- Primitive_3_Args();
-
- CHECK_ARG(1, HUNK3_P);
- CHECK_ARG(2, FIXNUM_P);
- 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);
+ PRIMITIVE_HEADER (3);
+ CHECK_ARG (1, HUNK3_P);
+ {
+ fast SCHEME_OBJECT hunk3 = (ARG_REF (1));
+ fast long index = (arg_index_integer (2, 3));
+ fast SCHEME_OBJECT object = (ARG_REF (3));
+ SIDE_EFFECT_IMPURIFY (hunk3, object);
+ MEMORY_SET (hunk3, index, object);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
-/* (SYSTEM-HUNK3-CXR0 GC-TRIPLE)
- 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.
-*/
+#define ARG_GC_TRIPLE(arg_number) \
+ (((GC_Type (ARG_REF (arg_number))) == GC_Triple) \
+ ? (ARG_REF (arg_number)) \
+ : ((error_wrong_type_arg (arg_number)), ((SCHEME_OBJECT) 0)))
+
DEFINE_PRIMITIVE ("SYSTEM-HUNK3-CXR0", Prim_sys_h3_0, 1, 1, 0)
{
- Primitive_1_Arg();
-
- Arg_1_GC_Type(GC_Triple);
- return Vector_Ref(Arg1, 0);
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (MEMORY_REF ((ARG_GC_TRIPLE (1)), 0));
}
-/* (SYSTEM-HUNK3-CXR1 GC-TRIPLE)
- 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.
-*/
DEFINE_PRIMITIVE ("SYSTEM-HUNK3-CXR1", Prim_sys_h3_1, 1, 1, 0)
{
- Primitive_1_Arg();
-
- Arg_1_GC_Type(GC_Triple);
- return Vector_Ref(Arg1, 1);
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (MEMORY_REF ((ARG_GC_TRIPLE (1)), 1));
}
-/* (SYSTEM-HUNK3-CXR2 GC-TRIPLE)
- 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.
-*/
DEFINE_PRIMITIVE ("SYSTEM-HUNK3-CXR2", Prim_sys_h3_2, 1, 1, 0)
{
- Primitive_1_Arg();
-
- Arg_1_GC_Type(GC_Triple);
- return Vector_Ref(Arg1, 2);
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (MEMORY_REF ((ARG_GC_TRIPLE (1)), 2));
}
-\f
-/* (SYSTEM-HUNK3-SET-CXR0! GC-TRIPLE NEW-CONTENTS)
- 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
- the previous contents.
-*/
+
DEFINE_PRIMITIVE ("SYSTEM-HUNK3-SET-CXR0!", Prim_sh3_set_0, 2, 2, 0)
{
- Primitive_2_Args();
- Arg_1_GC_Type(GC_Triple);
-
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, 0), Arg2);
+ PRIMITIVE_HEADER (2);
+ {
+ SCHEME_OBJECT hunk3 = (ARG_GC_TRIPLE (1));
+ SCHEME_OBJECT object = (ARG_REF (2));
+ SIDE_EFFECT_IMPURIFY (hunk3, object);
+ MEMORY_SET (hunk3, 0, object);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-/* (SYSTEM-HUNK3-SET-CXR1! GC-TRIPLE NEW-CONTENTS)
- 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 the previous contents.
-*/
DEFINE_PRIMITIVE ("SYSTEM-HUNK3-SET-CXR1!", Prim_sh3_set_1, 2, 2, 0)
{
- Primitive_2_Args();
- Arg_1_GC_Type(GC_Triple);
-
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, 1), Arg2);
+ PRIMITIVE_HEADER (2);
+ {
+ SCHEME_OBJECT hunk3 = (ARG_GC_TRIPLE (1));
+ SCHEME_OBJECT object = (ARG_REF (2));
+ SIDE_EFFECT_IMPURIFY (hunk3, object);
+ MEMORY_SET (hunk3, 1, object);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
-/* (SYSTEM-HUNK3-SET-CXR2! GC-TRIPLE NEW-CONTENTS)
- 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 the previous contents.
-*/
+
DEFINE_PRIMITIVE ("SYSTEM-HUNK3-SET-CXR2!", Prim_sh3_set_2, 2, 2, 0)
{
- Primitive_2_Args();
- Arg_1_GC_Type(GC_Triple);
-
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, 2), Arg2);
+ PRIMITIVE_HEADER (2);
+ {
+ SCHEME_OBJECT hunk3 = (ARG_GC_TRIPLE (1));
+ SCHEME_OBJECT object = (ARG_REF (2));
+ SIDE_EFFECT_IMPURIFY (hunk3, object);
+ MEMORY_SET (hunk3, 2, object);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/image.c,v 9.29 1989/09/20 23:09:13 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/image.c,v 9.28 1989/06/22 21:52:26 pas Rel $ */
-
#include "scheme.h"
#include "prims.h"
-#include "flonum.h"
#include "array.h"
#include <math.h>
\f
-/* IMAGE PROCESSING... */
-/* (much comes from array.c) */
+void
+arg_image (arg_number, nrows, ncols, array)
+ int arg_number;
+ long * nrows;
+ long * ncols;
+ REAL ** array;
+{
+ fast SCHEME_OBJECT argument = (ARG_REF (arg_number));
+ fast SCHEME_OBJECT rest;
+ fast SCHEME_OBJECT first;
+ fast SCHEME_OBJECT second;
+ fast SCHEME_OBJECT third;
+ if (! (PAIR_P (argument))) goto loser;
+ first = (PAIR_CAR (argument));
+ if (! (UNSIGNED_FIXNUM_P (first))) goto loser;
+ rest = (PAIR_CDR (argument));
+ if (! (PAIR_P (rest))) goto loser;
+ second = (PAIR_CAR (rest));
+ if (! (UNSIGNED_FIXNUM_P (second))) goto loser;
+ rest = (PAIR_CDR (rest));
+ if (! (PAIR_P (rest))) goto loser;
+ third = (PAIR_CAR (rest));
+ if (! (ARRAY_P (third))) goto loser;
+ if ((PAIR_CDR (rest)) != EMPTY_LIST) goto loser;
+ (*nrows) = (UNSIGNED_FIXNUM_TO_LONG (first));
+ (*ncols) = (UNSIGNED_FIXNUM_TO_LONG (second));
+ (*array) = (ARRAY_CONTENTS (third));
+ return;
+ loser:
+ error_bad_range_arg (arg_number);
+ /* NOTREACHED */
+}
-DEFINE_PRIMITIVE ("READ-IMAGE-FROM-ASCII-FILE", Prim_read_image_from_ascii_file, 1, 1, 0)
-{ long Length, int_pixel_value1, int_pixel_value2, i, j;
- long nrows, ncols, array_index;
- FILE *fopen(), *fp;
- char *file_string;
- REAL *To_Here;
- REAL *From_Here_1, *From_Here_2;
- Pointer Result, Array_Data_Result, *Orig_Free;
- int Error_Number;
- long allocated_cells;
- Boolean Open_File();
-
- Primitive_1_Args();
- Arg_1_Type(TC_CHARACTER_STRING);
-
- if (!(Open_File(Arg1, "r", &fp))) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- fscanf(fp, "%d %d \n", &nrows, &ncols);
- if ((ncols > 512) || (nrows>512)) {
- printf("read-image-ascii-file: ncols, nrows must be <= 512\n");
- return(NIL);
- }
- Length = nrows * ncols;
- printf("nrows is %d \n", nrows);
- printf("ncols is %d \n", ncols);
- printf("Reading data file ...\n");
-
- /* ALLOCATE SPACE */
- Primitive_GC_If_Needed(6);
- Orig_Free = Free;
- Free += 6;
- Result = Make_Pointer(TC_LIST, Orig_Free);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
-
- /* Allocate_Array(Array_Data_Result, Length, allocated_cells); */
- allocated_cells = (Length*REAL_SIZE) + ARRAY_HEADER_SIZE;
- Primitive_GC_If_Needed(allocated_cells);
- Array_Data_Result = Make_Pointer(TC_ARRAY, Free);
- Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
- Free[ARRAY_LENGTH] = Length;
- Free = Free+allocated_cells;
-
- *Orig_Free++ = Array_Data_Result;
- *Orig_Free = NIL;
- /* END ALLOCATION */
-
- To_Here = Scheme_Array_To_C_Array(Array_Data_Result);
-
- for (i=0; i<Length; i++)
- { fscanf( fp, "%d%d", &int_pixel_value1, &int_pixel_value2);
- *To_Here++ = ((REAL) int_pixel_value1);
- *To_Here++ = ((REAL) int_pixel_value2); /* faster reading ? */
+#define MAKE_IMAGE(nrows, ncols, array) \
+ (cons ((LONG_TO_UNSIGNED_FIXNUM (nrows)), \
+ (cons ((LONG_TO_UNSIGNED_FIXNUM (ncols)), \
+ (cons ((array), EMPTY_LIST))))))
+\f
+static int
+read_byte (fp)
+ fast FILE * fp;
+{
+ int result = (getc (fp));
+ if (ferror (fp))
+ error_external_return ();
+ return (result);
+}
+
+static int
+read_word (fp)
+ fast FILE * fp;
+{
+ int result = (getw (fp));
+ if (ferror (fp))
+ error_external_return ();
+ return (result);
+}
+
+static void
+write_word (fp, datum)
+ fast FILE * fp;
+ int datum;
+{
+ if ((putw (datum, fp)) != 0)
+ error_external_return ();
+ return;
+}
+
+static int
+read_2bint (fp)
+ fast FILE * fp;
+{
+ int msd = (getc (fp));
+ if (ferror (fp))
+ error_external_return ();
+ {
+ int lsd = (getc (fp));
+ if (ferror (fp))
+ error_external_return ();
+ {
+ int result = ((msd << 8) | lsd);
+ return (((result & (1 << 15)) == 0) ? result : ((-1 << 16) | result));
+ }
}
- printf("File read. Length is %d \n", i);
- Close_File(fp);
+}
- return Result;
+static void
+write_2bint (fp, datum)
+ fast FILE * fp;
+ int datum;
+{
+ if (((putc (((datum >> 8) & 0xFF), fp)) == EOF) ||
+ ((putc ((datum & 0xFF), fp)) == EOF))
+ error_external_return ();
+ return;
}
\f
+DEFINE_PRIMITIVE ("READ-IMAGE-FROM-ASCII-FILE", Prim_read_image_from_ascii_file, 1, 1, 0)
+{
+ fast FILE * fp;
+ long nrows;
+ long ncols;
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, STRING_P);
+ fp = (fopen ((ARG_REF (1)), "r"));
+ if (fp == ((FILE *) 0))
+ error_bad_range_arg (1);
+ fscanf (fp, "%d %d \n", (&nrows), (&ncols));
+ if ((ferror (fp)) || ((ncols > 512) || (nrows > 512)))
+ error_external_return ();
+ {
+ fast long length = (nrows * ncols);
+ SCHEME_OBJECT array = (allocate_array (length));
+ fast REAL * scan = (ARRAY_CONTENTS (array));
+ while ((length--) > 0)
+ {
+ int one;
+ int two;
+ fscanf (fp, "%d%d", (&one), (&two));
+ if (ferror (fp))
+ error_external_return ();
+ (*scan++) = ((REAL) one);
+ (*scan++) = ((REAL) two);
+ }
+ if ((fclose (fp)) != 0)
+ error_external_return ();
+ PRIMITIVE_RETURN (MAKE_IMAGE (nrows, ncols, array));
+ }
+}
+
DEFINE_PRIMITIVE ("READ-IMAGE-FROM-CBIN-FILE", Prim_read_image_from_cbin_file, 1, 1, 0)
-{ long Length, i,j;
- long nrows, ncols, array_index;
- FILE *fopen(), *fp;
- char *file_string;
- REAL *To_Here;
- Pointer Result, Array_Data_Result, *Orig_Free;
- int Error_Number;
- long allocated_cells;
- Boolean Open_File();
-
- Primitive_1_Args();
- Arg_1_Type(TC_CHARACTER_STRING);
-
- if (!(Open_File(Arg1, "r", &fp))) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- if (feof(fp)!=0) { printf("Datafile is empty!"); return NIL; }
- nrows = getw(fp); ncols = getw(fp);
- Length = nrows * ncols;
-
- /* ALLOCATE SPACE */
- Primitive_GC_If_Needed(6);
- Orig_Free = Free;
- Free += 6;
- Result = Make_Pointer(TC_LIST, Orig_Free);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- Allocate_Array(Array_Data_Result, Length, allocated_cells);
- *Orig_Free++ = Array_Data_Result;
- *Orig_Free = NIL;
- /* END ALLOCATION */
-
- To_Here = Scheme_Array_To_C_Array(Array_Data_Result);
-
- /* READING IN BIN int FORMAT */
- for (i=0;i<Length;i++) {
- if (feof(fp)!=0) { printf("not enough values read, last read i-1 %d , value %d\n", (i-1), *(To_Here-1));
- return NIL; }
- *To_Here++ = ((REAL) getw(fp));
+{
+ fast FILE * fp;
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, STRING_P);
+ fp = (fopen ((ARG_REF (1)), "r"));
+ if (fp == ((FILE *) 0))
+ error_bad_range_arg (1);
+ {
+ int nrows = (read_word (fp));
+ int ncols = (read_word (fp));
+ long length = (nrows * ncols);
+ SCHEME_OBJECT array = (allocate_array (length));
+ fast REAL * scan = (ARRAY_CONTENTS (array));
+ while ((length--) > 0)
+ (*scan++) = (read_word (fp));
+ if ((fclose (fp)) != 0)
+ error_external_return ();
+ PRIMITIVE_RETURN (MAKE_IMAGE (nrows, ncols, array));
}
-
- Close_File(fp);
- return Result;
}
\f
-/* 2BINT FORMAT = integer stored in 2 consecutive bytes.
- We need to use 2bint because on many machines (bobcats included)
- "putw", and "getw" use 4 byte integers (C int) ---> waste lots of space.
- */
DEFINE_PRIMITIVE ("READ-IMAGE-FROM-2BINT-FILE", Prim_read_image_from_2bint_file, 1, 1, 0)
-{ long Length, i,j;
- long nrows, ncols, array_index;
- FILE *fopen(), *fp;
- char *file_string;
- REAL *To_Here;
- Pointer Result, Array_Data_Result, *Orig_Free;
- int Error_Number;
- long allocated_cells;
- Boolean Open_File();
- int foo1,foo2;
-
- Primitive_1_Args();
- Arg_1_Type(TC_CHARACTER_STRING);
-
- if (!(Open_File(Arg1, "r", &fp))) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- if (feof(fp)!=0) { printf("Datafile is empty!"); return NIL; }
- nrows = getw(fp); ncols = getw(fp);
- Length = nrows * ncols;
-
- /* ALLOCATE SPACE */
- Primitive_GC_If_Needed(6);
- Orig_Free = Free;
- Free += 6;
- Result = Make_Pointer(TC_LIST, Orig_Free);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- Allocate_Array(Array_Data_Result, Length, allocated_cells);
- *Orig_Free++ = Array_Data_Result;
- *Orig_Free = NIL;
- /* END ALLOCATION */
-
- To_Here = Scheme_Array_To_C_Array(Array_Data_Result);
-
- for (i=0;i<Length;i++) {
- if (feof(fp)!=0) { printf("not enough values read, last read i-1 %d , value %d\n", (i-1), *(To_Here-1));
- return NIL; }
- foo1=getc(fp); foo2=getc(fp); /* Read 2BYTE INT FORMAT */
- *To_Here++ = ((REAL)
- ((foo1<<8) ^ foo2) ); /* put together the integer */
+{
+ fast FILE * fp;
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, STRING_P);
+ fp = (fopen ((ARG_REF (1)), "r"));
+ if (fp == ((FILE *) 0))
+ error_bad_range_arg (1);
+ {
+ int nrows = (read_word (fp));
+ int ncols = (read_word (fp));
+ fast long length = (nrows * ncols);
+ SCHEME_OBJECT array = (allocate_array (length));
+ fast REAL * scan = (ARRAY_CONTENTS (array));
+ while ((length--) > 0)
+ (*scan++) = ((REAL) (read_2bint (fp)));
+ if ((fclose (fp)) != 0)
+ error_external_return ();
+ PRIMITIVE_RETURN (MAKE_IMAGE (nrows, ncols, array));
}
-
- Close_File(fp);
- return Result;
}
DEFINE_PRIMITIVE ("WRITE-IMAGE-2BINT", Prim_write_image_2bint, 2, 2, 0)
-{ long Length, i,j;
- Pointer Pnrows, Pncols, Prest, Parray;
- REAL *Array;
- int nrows, ncols, number,foo1,foo2;
- FILE *fopen(), *fp;
- char *file_string; int Error_Number; Boolean Open_File();
-
- Primitive_2_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
- Arg_2_Type(TC_CHARACTER_STRING);
- if (!(Open_File(Arg2, "w", &fp))) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- 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, 1024, ERR_ARG_1_BAD_RANGE); /* arbitrary size bound on images */
- Range_Check(ncols, Pncols, 0, 1024, ERR_ARG_1_BAD_RANGE);
- Length = nrows * ncols;
- Array = Scheme_Array_To_C_Array(Parray);
-
- /*_________________________________*/
- putw(nrows, fp); /* putw is 4 bytes on bobcats */
- putw(ncols, fp); /* so below use putc */
- for (i=0;i<Length;i++) {
- number = ((int) Array[i]);
- foo2 = number;
- foo1 = (number>>8); /* high order byte */
- putc(foo1, fp);
- putc(foo2, fp); /* low order byte */
+{
+ int nrows;
+ int ncols;
+ SCHEME_OBJECT array;
+ fast FILE * fp;
+ PRIMITIVE_HEADER (2);
+ arg_image (1, (&nrows), (&ncols), (&array));
+ CHECK_ARG (2, STRING_P);
+ fp = (fopen ((ARG_REF (2)), "2"));
+ if (fp == ((FILE *) 0))
+ error_bad_range_arg (2);
+ {
+ fast long length = (nrows * ncols);
+ fast REAL * scan = (ARRAY_CONTENTS (array));
+ write_word (fp, nrows);
+ write_word (fp, ncols);
+ while ((length--) > 0)
+ write_2bint (fp, ((int) (*scan++)));
}
- Close_File(fp);
- /*_________________________________*/
- PRIMITIVE_RETURN(SHARP_T);
+ if ((fclose (fp)) != 0)
+ error_external_return ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
+\f
DEFINE_PRIMITIVE ("READ-IMAGE-FROM-CTSCAN-FILE", Prim_read_image_from_ctscan_file, 1, 1, 0)
-{ long Length, i,j;
- long nrows, ncols, array_index;
- FILE *fopen(), *fp;
- char *file_string;
- REAL *Array;
- Pointer Result, Array_Data_Result, *Orig_Free;
- int Error_Number;
- long allocated_cells;
- Boolean Open_File();
-
- Primitive_1_Args();
- Arg_1_Type(TC_CHARACTER_STRING);
-
- if (!(Open_File(Arg1, "r", &fp))) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- if (feof(fp)!=0) { printf("Datafile is empty!"); return NIL; }
- nrows = 512; ncols = 512;
- Length = nrows * ncols;
-
- /* ALLOCATE SPACE */
- Primitive_GC_If_Needed(6);
- Orig_Free = Free;
- Free += 6;
- Result = Make_Pointer(TC_LIST, Orig_Free);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- Allocate_Array(Array_Data_Result, Length, allocated_cells);
- *Orig_Free++ = Array_Data_Result;
- *Orig_Free = NIL;
- /* END ALLOCATION */
-
- Array = Scheme_Array_To_C_Array(Array_Data_Result);
- Image_Read_From_CTSCAN_File(fp,Array,nrows,ncols);
- Close_File(fp);
- return Result;
-}
-
-Image_Read_From_CTSCAN_File(fp,Array,nrows,ncols)
- FILE *fp; REAL *Array; long nrows,ncols;
-{ int i,m;
- long Length=nrows*ncols;
- int first_header_bytes = 2048;
- int second_header_bytes = 3150-(2048+1024);
- int word1, word2;
- long number;
- int *Widths;
- char ignore;
- REAL *Temp_Row;
- int array_index;
-
- Primitive_GC_If_Needed(512); /* INTEGER_SIZE is = 1 scheme pointer */
- Widths = ((int *) Free);
- for (i=0;i<first_header_bytes;i++) ignore = getc(fp);
- for (i = 0; i<512; i++) {
- word1 = ((int) getc(fp));
- word2 = ((int) getc(fp));
- number = ((word1<<8) | word2); /* bitwise inclusive or */
- Widths[i] = number; /* THESE ARE HALF THE NROW-WIDTHs ! */
+{
+ fast FILE * fp;
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, STRING_P);
+ fp = (fopen ((ARG_REF (1)), "r"));
+ if (fp == ((FILE *) 0))
+ error_bad_range_arg (1);
+ Primitive_GC_If_Needed (BYTES_TO_WORDS (512 * (sizeof (int))));
+ {
+ int nrows = 512;
+ int ncols = 512;
+ SCHEME_OBJECT array = (allocate_array (nrows * ncols));
+ REAL * Array = (ARRAY_CONTENTS (array));
+ fast int * Widths = ((int *) Free);
+ fast int i;
+ /* Discard header */
+ for (i = 0; (i < 2048); i += 1)
+ (void) read_byte (fp);
+ for (i = 0; (i < 512); i += 1)
+ (Widths [i]) = (read_2bint (fp));
+ for (i = 0; (i < (nrows * ncols)); i += 1)
+ (Array [i]) = 0;
+ for (i = 0; (i < 512); i += 1)
+ {
+ fast int array_index = ((i * 512) + (256 - (Widths [i])));
+ fast int m;
+ for (m = 0; (m < (2 * (Widths [i]))); m += 1)
+ (Array [array_index + m]) = ((REAL) (read_2bint (fp)));
+ }
+ /* CTSCAN images are upside down */
+ Primitive_GC_If_Needed (512 * REAL_SIZE);
+ Image_Mirror_Upside_Down (Array, nrows, ncols, ((REAL *) Free));
+ if ((fclose (fp)) != 0)
+ error_external_return ();
+ PRIMITIVE_RETURN (MAKE_IMAGE (nrows, ncols, array));
}
-
- for (i=0;i<Length;i++) Array[i] = 0; /* initialize with zeros */
-
- for (i = 0; i<512; i++) {
- array_index = i*512 + (256-Widths[i]); /* note the offset */
- for (m=array_index; m<(array_index + 2*Widths[i]); m++) {
- word1 = ((int) getc(fp)); word2 = ((int) getc(fp));
- number = ((word1<<8) | word2); /* bitwise inclusive or */
- Array[m] = ((REAL) number); /* do I need to explicitly sign-extend? */
- }
- }
- Primitive_GC_If_Needed(512*REAL_SIZE);
- Temp_Row = ((REAL *) Free);
- Image_Mirror_Upside_Down(Array,nrows,ncols,Temp_Row); /* CTSCAN images are upside down */
}
-Image_Mirror_Upside_Down(Array,nrows,ncols,Temp_Row)
- REAL *Array, *Temp_Row; long nrows,ncols;
+Image_Mirror_Upside_Down (Array,nrows,ncols,Temp_Row)
+ REAL * Array;
+ long nrows;
+ long ncols;
+ REAL * Temp_Row;
{ int i;
REAL *M_row, *N_row;
for (i=0;i<(nrows/2);i++) {
C_Array_Copy(Temp_Row, M_row, ncols);
}
}
-
-
-/* The following does not work, to be fixed.
- */
+\f
+/* The following does not work, to be fixed. */
DEFINE_PRIMITIVE ("IMAGE-DOUBLE-TO-FLOAT!", Prim_image_double_to_float, 1, 1, 0)
-{ long Length;
+{
+ long Length;
long i,j;
- long nrows, ncols;
long allocated_cells;
+ long nrows, ncols;
+ SCHEME_OBJECT array;
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)));
+ fast double temp_value_cell;
+ float *To_Here;
+ PRIMITIVE_HEADER (1);
+ arg_image (1, (&nrows), (&ncols), (&array));
+ Array = ((double *) (ARRAY_CONTENTS (array)));
From_Here = Array;
- To_Here = ((float *) (Array));
+ To_Here = ((float *) (Array));
Length = nrows * ncols;
for (i=0;i<Length;i++) {
To_Here++;
}
/* and now SIDE-EFFECT the ARRAY_HEADER */
- allocated_cells = (Length *
- ((sizeof(Pointer)+sizeof(float)-1) / sizeof(Pointer)) +
- ARRAY_HEADER_SIZE);
- *(Nth_Vector_Loc(Parray, ARRAY_HEADER)) =
- Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
- /* see array.h to understand the above */
-
- return Arg1;
+ SET_VECTOR_LENGTH (array, ((Length * FLOAT_SIZE) + 1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
-
-
\f
-DEFINE_PRIMITIVE ("SUBIMAGE-COPY!",
- Prim_subimage_copy, 12,12, 0)
-{ long r1,c1, r2,c2, at1r,at1c,at2r,at2c, mr,mc;
- long nn;
- REAL *x,*y;
- void subimage_copy();
+DEFINE_PRIMITIVE ("SUBIMAGE-COPY!", Prim_subimage_copy, 12, 12, 0)
+{
+ long r1, c1, r2, c2, at1r, at1c, at2r, at2c, mr, mc;
+ REAL * x;
+ REAL * y;
+ void subimage_copy ();
PRIMITIVE_HEADER (12);
- CHECK_ARG (1, FIXNUM_P); /* rows 1 */
- CHECK_ARG (2, FIXNUM_P); /* cols 1 */
- CHECK_ARG (3, ARRAY_P); /* image array 1 = source array */
- CHECK_ARG (4, FIXNUM_P); /* rows 2 */
- CHECK_ARG (5, FIXNUM_P); /* cols 2 */
- CHECK_ARG (6, ARRAY_P); /* image array 2 = destination array */
-
- CHECK_ARG (7, FIXNUM_P); /* at1 row */
- CHECK_ARG (8, FIXNUM_P); /* at1 col */
- CHECK_ARG (9, FIXNUM_P); /* at2 row */
- CHECK_ARG (10, FIXNUM_P); /* at2 col */
- CHECK_ARG (11, FIXNUM_P); /* m row */
- CHECK_ARG (12, FIXNUM_P); /* m col */
-
- x = Scheme_Array_To_C_Array(ARG_REF(3));
- y = Scheme_Array_To_C_Array(ARG_REF(6));
- r1 = arg_nonnegative_integer(1);
- c1 = arg_nonnegative_integer(2);
- r2 = arg_nonnegative_integer(4);
- c2 = arg_nonnegative_integer(5);
-
- nn = r1*c1;
- if (nn != Array_Length(ARG_REF(3))) error_bad_range_arg(3);
- nn = r2*c2;
- if (nn != Array_Length(ARG_REF(6))) error_bad_range_arg(6);
-
- at1r = arg_nonnegative_integer(7);
- at1c = arg_nonnegative_integer(8);
- at2r = arg_nonnegative_integer(9);
- at2c = arg_nonnegative_integer(10);
- mr = arg_nonnegative_integer(11);
- mc = arg_nonnegative_integer(12);
-
- if (((at1r+mr)>r1) || ((at1c+mc)>c1)) error_bad_range_arg(7);
- if (((at2r+mr)>r2) || ((at2c+mc)>c2)) error_bad_range_arg(9);
-
- subimage_copy(x,y, r1,c1,r2,c2, at1r,at1c,at2r,at2c, mr,mc);
-
- PRIMITIVE_RETURN (NIL);
+ CHECK_ARG (3, ARRAY_P); /* image array 1 = source array */
+ CHECK_ARG (6, ARRAY_P); /* image array 2 = destination array */
+ r1 = (arg_nonnegative_integer (1));
+ c1 = (arg_nonnegative_integer (2));
+ if ((r1 * c1) != (ARRAY_LENGTH (ARG_REF (3))))
+ error_bad_range_arg (3);
+ x = (ARRAY_CONTENTS (ARG_REF (3)));
+ r2 = arg_nonnegative_integer (4);
+ c2 = arg_nonnegative_integer (5);
+ if ((r2 * c2) != (ARRAY_LENGTH (ARG_REF (6))))
+ error_bad_range_arg (6);
+ y = (ARRAY_CONTENTS (ARG_REF (6)));
+ at1r = (arg_nonnegative_integer (7));
+ at1c = (arg_nonnegative_integer (8));
+ at2r = (arg_nonnegative_integer (9));
+ at2c = (arg_nonnegative_integer (10));
+ mr = (arg_nonnegative_integer (11));
+ mc = (arg_nonnegative_integer (12));
+ if (((at1r + mr) > r1) || ((at1c + mc) > c1))
+ error_bad_range_arg (7);
+ if (((at2r + mr) > r2) || ((at2c + mc) > c2))
+ error_bad_range_arg (9);
+ subimage_copy (x, y, r1, c1, r2, c2, at1r, at1c, at2r, at2c, mr, mc);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-void subimage_copy(x,y, r1,c1,r2,c2, at1r,at1c,at2r,at2c, mr,mc)
- REAL *x,*y; long r1,c1,r2,c2, at1r,at1c,at2r,at2c, mr,mc;
+void
+subimage_copy (x,y, r1,c1,r2,c2, at1r,at1c,at2r,at2c, mr,mc)
+ REAL *x,*y;
+ long r1,c1,r2,c2, at1r,at1c,at2r,at2c, mr,mc;
{ long i,j;
REAL *xrow,*yrow;
xrow = x + at1r*c1 + at1c;
yrow = y + at2r*c2 + at2c; /* A(i,j)--->Array[i*ncols+j] */
-
+
for (i=0; i<mr; i++) {
for (j=0; j<mc; j++) yrow[j] = xrow[j];
xrow = xrow + c1;
yrow = yrow + c2;
}
}
-
-
-
+\f
/* image-operation-2
- groups together procedures that use 2 image-arrays
- (usually side-effecting the 2nd image, but not necessarily)
- */
+ groups together procedures that use 2 image-arrays
+ (usually side-effecting the 2nd image, but not necessarily) */
-DEFINE_PRIMITIVE ("IMAGE-OPERATION-2!",
- Prim_image_operation_2, 5,5, 0)
+DEFINE_PRIMITIVE ("IMAGE-OPERATION-2!", Prim_image_operation_2, 5,5, 0)
{ long rows, cols, nn, opcode;
REAL *x,*y;
void image_laplacian();
CHECK_ARG (3, FIXNUM_P); /* cols */
CHECK_ARG (4, ARRAY_P); /* image array 1 */
CHECK_ARG (5, ARRAY_P); /* image array 2 */
-
- x = Scheme_Array_To_C_Array(ARG_REF(4));
- y = Scheme_Array_To_C_Array(ARG_REF(5));
+
+ x = ARRAY_CONTENTS(ARG_REF(4));
+ y = ARRAY_CONTENTS(ARG_REF(5));
rows = arg_nonnegative_integer(2);
cols = arg_nonnegative_integer(3);
nn = rows*cols;
- if (nn != Array_Length(ARG_REF(4))) error_bad_range_arg(4);
- if (nn != Array_Length(ARG_REF(5))) error_bad_range_arg(5);
-
+ if (nn != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
+ if (nn != ARRAY_LENGTH(ARG_REF(5))) error_bad_range_arg(5);
+
opcode = arg_nonnegative_integer(1);
-
+
if (opcode==1)
image_laplacian(x,y,rows,cols); /* result in y */
else if (opcode==2)
error_bad_range_arg(1); /* illegal opcode */
else
error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (NIL);
+
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
/* Laplacian form [4,-1,-1,-1,-1]/4
- A(i,j) --> Array[i*ncols + j]
- With no knowledge outside boundary, assume laplace(edge-point)=0.0 (no wrap-around, no artificial bndry)
- */
-void image_laplacian(x,y, nrows,ncols)
+ A(i,j) --> Array[i*ncols + j]
+ With no knowledge outside boundary,
+ assume laplace(edge-point)=0.0 (no wrap-around, no artificial bndry) */
+void
+image_laplacian (x,y, nrows,ncols)
REAL *x, *y;
long nrows, ncols;
{ long i,j, nrows1, ncols1;
nrows1=nrows-1; ncols1=ncols-1;
- if ((nrows<2)||(ncols<2)) return; /* no need todo anything for 1-point image */
+ /* no need todo anything for 1-point image */
+ if ((nrows<2)||(ncols<2))
+ return;
/* */
i=0;j=0; y[i*ncols+j] = 0.0; /* NE corner */
i=0;j=ncols1; y[i*ncols+j] = 0.0; /* NW corner */
j=ncols1; for (i=1;i<nrows1;i++) y[i*ncols+j] = 0.0; /* WEST column */
/* */
for (i=1;i<nrows1;i++)
- for (j=1;j<ncols1;j++) y[i*ncols+j] = /* interior of image */
- x[i*ncols+j] - (.25)*(x[i*ncols+(j-1)] + x[i*ncols+(j+1)] + x[(i-1)*ncols+j] + x[(i+1)*ncols+j]);
+ for (j=1;j<ncols1;j++)
+ y[i*ncols+j] =
+ x[i*ncols+j] -
+ ((x[i*ncols+(j-1)] +
+ x[i*ncols+(j+1)] +
+ x[(i-1)*ncols+j] +
+ x[(i+1)*ncols+j])
+ / 4);
+ return;
}
-
-
+\f
DEFINE_PRIMITIVE ("IMAGE-DOUBLE-BY-INTERPOLATION", Prim_image_double_by_interpolation, 1, 1, 0)
{ long nrows, ncols, Length;
- Pointer Pnrows, Pncols, Prest, Parray;
+ SCHEME_OBJECT Parray;
REAL *Array, *To_Here;
- Pointer Result, Array_Data_Result, *Orig_Free;
- long allocated_cells;
- /* */
- 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, 1024, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 1024, ERR_ARG_1_BAD_RANGE);
- Length=nrows*ncols;
- /* */
- /* ALLOCATE SPACE */
- Primitive_GC_If_Needed(6);
- Orig_Free = Free;
- Free += 6;
- Result = Make_Pointer(TC_LIST, Orig_Free);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, (2*nrows));
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, (2*ncols));
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- Allocate_Array(Array_Data_Result, (4*Length), allocated_cells); /* NOTICE (4 * LENGTH) */
- *Orig_Free++ = Array_Data_Result;
- *Orig_Free = NIL;
- /* END ALLOCATION */
- /* */
- Array = Scheme_Array_To_C_Array(Parray);
- C_image_double_by_interpolation(Array, (Scheme_Array_To_C_Array(Array_Data_Result)), nrows, ncols);
+ SCHEME_OBJECT Result, array;
+ PRIMITIVE_HEADER (1);
+ arg_image (1, (&nrows), (&ncols), (&Parray));
+ Array = (ARRAY_CONTENTS (Parray));
+ array = (allocate_array (4 * nrows * ncols));
+ Result = (MAKE_IMAGE (nrows, ncols, array));
+
+ Array = ARRAY_CONTENTS(Parray);
+ C_image_double_by_interpolation
+ (Array, (ARRAY_CONTENTS(array)), nrows, ncols);
PRIMITIVE_RETURN(Result);
}
/* double image by linear interpolation.
---new_array must be 4 times as long ---
- A(i,j) --> Array[i*ncols + j]
- magnification in a south-east direction (i.e. replication of pixels in South-East corner)
- */
-C_image_double_by_interpolation(array, new_array, nrows, ncols)
+ A(i,j) --> Array[i*ncols + j]
+ magnification in a south-east direction
+ (i.e. replication of pixels in South-East corner) */
+C_image_double_by_interpolation (array, new_array, nrows, ncols)
REAL *array, *new_array;
long nrows, ncols;
{ long i,j, nrows1, ncols1, nrows2, ncols2;
nrows1=nrows-1; ncols1=ncols-1;
nrows2=2*nrows; ncols2=2*ncols;
- if ((nrows<2)||(ncols<2)) return(1); /* no need todo anything for 1-point image */
- /* */
+ /* no need todo anything for 1-point image */
+ if ((nrows<2)||(ncols<2)) return(1);
i=nrows1; for (j=0;j<ncols1;j++) /* SOUTH row */
{ new_array[(2*i)*ncols2+(2*j)] = array[i*ncols+j];
new_array[(2*i+1)*ncols2+(2*j)] = array[i*ncols+j];
- new_array[(2*i)*ncols2+(2*j)+1] = .5*(array[i*ncols+j]+array[i*ncols+j+1]);
+ new_array[(2*i)*ncols2+(2*j)+1] =
+ ((array[i*ncols+j]+array[i*ncols+j+1]) / 2);
new_array[(2*i+1)*ncols2+(2*j)+1] = new_array[(2*i)*ncols2+(2*j)+1];
}
j=ncols1; for (i=0;i<nrows1;i++) /* WEST column */
{ new_array[(2*i)*ncols2+(2*j)] = array[i*ncols+j];
new_array[(2*i)*ncols2+(2*j)+1] = array[i*ncols+j];
- new_array[(2*i+1)*ncols2+(2*j)] = .5*(array[i*ncols+j]+array[(i+1)*ncols+j]);
+ new_array[(2*i+1)*ncols2+(2*j)] =
+ ((array[i*ncols+j]+array[(i+1)*ncols+j]) / 2);
new_array[(2*i+1)*ncols2+(2*j)+1] = new_array[(2*i+1)*ncols2+(2*j)];
}
- i=nrows1;j=ncols1; { /* SW corner */
- new_array[(2*i)*ncols2+(2*j)] = array[i*ncols+j];
+ i=nrows1;j=ncols1; { /* SW corner */
+ new_array[(2*i)*ncols2+(2*j)] = array[i*ncols+j];
new_array[(2*i)*ncols2+(2*j)+1] = array[i*ncols+j];
new_array[(2*i+1)*ncols2+(2*j)] = array[i*ncols+j];
new_array[(2*i+1)*ncols2+(2*j)+1] = array[i*ncols+j];
/* */
for (i=0;i<nrows1;i++)
for (j=0;j<ncols1;j++) { /* interior of image */
- new_array[(2*i)*ncols2+(2*j)] = array[i*ncols+j];
- new_array[(2*i)*ncols2+(2*j)+1] = .5*(array[i*ncols+j]+array[i*ncols+j+1]);
- new_array[(2*i+1)*ncols2+(2*j)] = .5*(array[i*ncols+j]+array[(i+1)*ncols+j]);
- new_array[(2*i+1)*ncols2+(2*j)+1] = .25*(array[i*ncols+j] + array[i*ncols+j+1] +
- array[(i+1)*ncols+j] + array[(i+1)*ncols+j+1]);
+ new_array[(2*i)*ncols2+(2*j)] = array[i*ncols+j];
+ new_array[(2*i)*ncols2+(2*j)+1] =
+ ((array[i*ncols+j]+array[i*ncols+j+1]) / 2);
+ new_array[(2*i+1)*ncols2+(2*j)] =
+ ((array[i*ncols+j]+array[(i+1)*ncols+j]) / 2);
+ new_array[(2*i+1)*ncols2+(2*j)+1] =
+ ((array[i*ncols+j] +
+ array[i*ncols+j+1] +
+ array[(i+1)*ncols+j] +
+ array[(i+1)*ncols+j+1])
+ / 4);
}
}
-
+\f
DEFINE_PRIMITIVE ("IMAGE-MAKE-RING", Prim_image_make_ring, 4, 4, 0)
-{ long Length, i,j;
- long nrows, ncols;
- long Min_Cycle, Max_Cycle;
- long low_cycle, high_cycle;
- REAL *Ring_Array;
- Pointer Result, Ring_Array_Result, *Orig_Free;
- long allocated_cells;
-
- Primitive_4_Args();
- Arg_1_Type(TC_FIXNUM);
- Range_Check(nrows, Arg1, 0, 1024, ERR_ARG_1_BAD_RANGE);
- Arg_2_Type(TC_FIXNUM);
- Range_Check(ncols, Arg2, 0, 1024, ERR_ARG_2_BAD_RANGE);
- Length = nrows*ncols;
- Min_Cycle=0;
- Max_Cycle=min((nrows/2),(ncols/2));
- Arg_3_Type(TC_FIXNUM);
- Range_Check(low_cycle, Arg3, Min_Cycle, Max_Cycle, ERR_ARG_3_BAD_RANGE);
- Arg_4_Type(TC_FIXNUM);
- Range_Check(high_cycle, Arg4, Min_Cycle, Max_Cycle, ERR_ARG_4_BAD_RANGE);
- if (high_cycle<low_cycle) Primitive_Error(ERR_ARG_4_BAD_RANGE);
-
- /* Allocate Space */
- Primitive_GC_If_Needed(6);
- Orig_Free = Free;
- Free += 6;
- Result = Make_Pointer(TC_LIST, Orig_Free);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- Allocate_Array(Ring_Array_Result, Length, allocated_cells);
- *Orig_Free++ = Ring_Array_Result;
- *Orig_Free = NIL;
- /* end allocation */
-
- Ring_Array = Scheme_Array_To_C_Array(Ring_Array_Result);
- C_Image_Make_Ring(Ring_Array, nrows, ncols, low_cycle, high_cycle);
- return Result;
+{
+ PRIMITIVE_HEADER (4);
+ {
+ long nrows = (arg_nonnegative_integer (1));
+ long ncols = (arg_nonnegative_integer (2));
+ long Length = (nrows * ncols);
+ long high_cycle =
+ (arg_index_integer (4, ((min ((nrows / 2), (ncols / 2))) + 1)));
+ long low_cycle = (arg_index_integer (3, (high_cycle + 1)));
+ SCHEME_OBJECT Ring_Array_Result = (allocate_array (Length));
+ SCHEME_OBJECT Result = (MAKE_IMAGE (nrows, ncols, Ring_Array_Result));
+ REAL * Ring_Array = (ARRAY_CONTENTS (Ring_Array_Result));
+ C_Image_Make_Ring (Ring_Array, nrows, ncols, low_cycle, high_cycle);
+ PRIMITIVE_RETURN (Result);
+ }
}
-C_Image_Make_Ring(Ring_Array, nrows, ncols, low_cycle, high_cycle) REAL *Ring_Array;
-long nrows, ncols, low_cycle, high_cycle;
+C_Image_Make_Ring (Ring_Array, nrows, ncols, low_cycle, high_cycle)
+ REAL *Ring_Array;
+ long nrows, ncols, low_cycle, high_cycle;
{ long Square_LC=low_cycle*low_cycle, Square_HC=high_cycle*high_cycle;
long i, j, m, n, radial_cycle;
long nrows2=nrows/2, ncols2=ncols/2;
- for (i=0; i<nrows; i++) {
+ for (i=0; i<nrows; i++) {
for (j=0; j<ncols; j++) {
m = ((i<nrows2) ? i : (nrows-i));
n = ((j<ncols2) ? j : (ncols-j));
else Ring_Array[i*ncols+j] = 1;
}}
}
+\f
+/* Periodic-shift without side-effects for code simplicity. */
-/* Periodic-shift without side-effects for code-simplicity
- */
DEFINE_PRIMITIVE ("IMAGE-PERIODIC-SHIFT", Prim_image_periodic_shift, 3, 3, 0)
-{ 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, 1024, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 1024, 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;
+{
+ long nrows;
+ long ncols;
+ REAL * Array;
+ PRIMITIVE_HEADER (3);
+ {
+ SCHEME_OBJECT Parray;
+ arg_image (1, (&nrows), (&ncols), (&Parray));
+ Array = (ARRAY_CONTENTS (Parray));
+ }
+ {
+ long ver_shift = ((arg_integer (2)) % nrows);
+ long hor_shift = ((arg_integer (3)) % ncols);
+ SCHEME_OBJECT array = (allocate_array (nrows * ncols));
+ SCHEME_OBJECT Result = (MAKE_IMAGE (nrows, ncols, array));
+ C_Image_Periodic_Shift
+ (Array,
+ (ARRAY_CONTENTS (array)),
+ nrows,
+ ncols,
+ ver_shift,
+ hor_shift);
+ PRIMITIVE_RETURN (Result);
+ }
}
-/* ASSUMES hor_shift<nrows, ver_shift<ncols
- */
+/* ASSUMES ((hor_shift < nrows) && (ver_shift < ncols)) */
+
C_Image_Periodic_Shift(Array, New_Array, nrows, ncols, ver_shift, hor_shift)
REAL *Array, *New_Array; long nrows, ncols, hor_shift, ver_shift;
{ long i, j, ver_index, hor_index;
REAL *To_Here;
To_Here = New_Array;
- for (i=0;i<nrows;i++) {
+ for (i=0;i<nrows;i++) {
for (j=0;j<ncols;j++) {
ver_index = (i+ver_shift) % nrows;
if (ver_index<0) ver_index = nrows+ver_index; /* wrapping around */
*To_Here++ = Array[ver_index*ncols + hor_index];
}}
}
+\f
+/* Rotations and stuff */
-
-/* Rotations and stuff
- */
DEFINE_PRIMITIVE ("IMAGE-TRANSPOSE!", Prim_image_transpose, 1, 1, 0)
-{ long Length;
- Pointer Pnrows, Pncols, Prest, Parray;
- long nrows, ncols;
- REAL *Array, *Temp_Array;
-
- Primitive_1_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
-
- Pnrows = Vector_Ref(Arg1, CONS_CAR);
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Pncols = Vector_Ref(Prest, CONS_CAR);
- Prest = Vector_Ref(Prest, CONS_CDR);
- Parray = Vector_Ref(Prest, CONS_CAR);
- if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- Range_Check(nrows, Pnrows, 0, 1024, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 1024, ERR_ARG_1_BAD_RANGE);
-
- Array = Scheme_Array_To_C_Array(Parray);
-
- if (nrows==ncols) {
- Image_Fast_Transpose(Array, nrows); /* side-effecting ... */
+{
+ long nrows;
+ long ncols;
+ REAL * Array;
+ PRIMITIVE_HEADER (1);
+ {
+ SCHEME_OBJECT Parray;
+ arg_image (1, (&nrows), (&ncols), (&Parray));
+ Array = (ARRAY_CONTENTS (Parray));
}
- else {
- REAL *New_Array;
- long Length=nrows*ncols;
- Primitive_GC_If_Needed(Length*REAL_SIZE); /* making space in scheme heap */
- New_Array = ((REAL *) Free);
- Image_Transpose(Array, New_Array, nrows, ncols);
- C_Array_Copy(New_Array, Array, Length);
+ if (nrows == ncols)
+ {
+ Image_Fast_Transpose (Array, nrows); /* side-effecting ... */
+ }
+ else
+ {
+ REAL *New_Array;
+ long Length = (nrows * ncols);
+ /* making space in scheme heap */
+ Primitive_GC_If_Needed (Length * REAL_SIZE);
+ New_Array = ((REAL *) Free);
+ Image_Transpose (Array, New_Array, nrows, ncols);
+ C_Array_Copy (New_Array, Array, Length);
+ }
+ {
+ SCHEME_OBJECT argument = (ARG_REF (1));
+ SET_PAIR_CAR (argument, (LONG_TO_UNSIGNED_FIXNUM (ncols)));
+ SET_PAIR_CAR ((PAIR_CDR (argument)), (LONG_TO_UNSIGNED_FIXNUM (nrows)));
+ PRIMITIVE_RETURN (argument);
}
-
- Vector_Set(Arg1, CONS_CAR, Make_Pointer(TC_FIXNUM, ncols) ); /* swithing nrows, ncols */
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Vector_Set(Prest, CONS_CAR, Make_Pointer(TC_FIXNUM, nrows) );
- return Arg1;
}
DEFINE_PRIMITIVE ("IMAGE-ROTATE-90CLW!", Prim_image_rotate_90clw, 1, 1, 0)
-{ long Length;
- Pointer Pnrows, Pncols, Prest, Parray;
- long nrows, ncols;
- REAL *Array, *Temp_Array;
-
- Primitive_1_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
-
- Pnrows = Vector_Ref(Arg1, CONS_CAR);
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Pncols = Vector_Ref(Prest, CONS_CAR);
- Prest = Vector_Ref(Prest, CONS_CDR);
- Parray = Vector_Ref(Prest, CONS_CAR);
- if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- Range_Check(nrows, Pnrows, 0, 1024, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 1024, ERR_ARG_1_BAD_RANGE);
- Length = nrows*ncols;
-
- Primitive_GC_If_Needed(Length*REAL_SIZE);
- Temp_Array = ((REAL *) Free);
- Array = Scheme_Array_To_C_Array(Parray);
- Image_Rotate_90clw(Array, Temp_Array, nrows, ncols);
- C_Array_Copy(Temp_Array, Array, Length);
-
- Vector_Set(Arg1, CONS_CAR, Make_Pointer(TC_FIXNUM, ncols) ); /* swithing nrows, ncols */
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Vector_Set(Prest, CONS_CAR, Make_Pointer(TC_FIXNUM, nrows) );
- return Arg1;
+{
+ long nrows;
+ long ncols;
+ REAL * Array;
+ long Length;
+ PRIMITIVE_HEADER (1);
+ {
+ SCHEME_OBJECT Parray;
+ arg_image (1, (&nrows), (&ncols), (&Parray));
+ Array = (ARRAY_CONTENTS (Parray));
+ }
+ Length = (nrows * ncols);
+ Primitive_GC_If_Needed (Length * REAL_SIZE);
+ {
+ REAL * Temp_Array = ((REAL *) Free);
+ Image_Rotate_90clw (Array, Temp_Array, nrows, ncols);
+ C_Array_Copy (Temp_Array, Array, Length);
+ }
+ {
+ SCHEME_OBJECT argument = (ARG_REF (1));
+ SET_PAIR_CAR (argument, (LONG_TO_UNSIGNED_FIXNUM (ncols)));
+ SET_PAIR_CAR ((PAIR_CDR (argument)), (LONG_TO_UNSIGNED_FIXNUM (nrows)));
+ PRIMITIVE_RETURN (argument);
+ }
}
-
+\f
DEFINE_PRIMITIVE ("IMAGE-ROTATE-90CCLW!", Prim_image_rotate_90cclw, 1, 1, 0)
-{ long Length;
- Pointer Pnrows, Pncols, Prest, Parray;
- long nrows, ncols;
- REAL *Array, *Temp_Array;
-
- Primitive_1_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
-
- Pnrows = Vector_Ref(Arg1, CONS_CAR);
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Pncols = Vector_Ref(Prest, CONS_CAR);
- Prest = Vector_Ref(Prest, CONS_CDR);
- Parray = Vector_Ref(Prest, CONS_CAR);
- if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- Range_Check(nrows, Pnrows, 0, 1024, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 1024, ERR_ARG_1_BAD_RANGE);
- Length = nrows*ncols;
-
- Primitive_GC_If_Needed(Length*REAL_SIZE);
- Temp_Array = ((REAL *) Free);
- Array = Scheme_Array_To_C_Array(Parray);
- Image_Rotate_90cclw(Array, Temp_Array, nrows, ncols);
- C_Array_Copy(Temp_Array, Array, Length);
-
- Vector_Set(Arg1, CONS_CAR, Make_Pointer(TC_FIXNUM, ncols) ); /* swithing nrows, ncols */
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Vector_Set(Prest, CONS_CAR, Make_Pointer(TC_FIXNUM, nrows) );
- return Arg1;
+{
+ long nrows;
+ long ncols;
+ REAL * Array;
+ long Length;
+ PRIMITIVE_HEADER (1);
+ {
+ SCHEME_OBJECT Parray;
+ arg_image (1, (&nrows), (&ncols), (&Parray));
+ Array = (ARRAY_CONTENTS (Parray));
+ }
+ Length = (nrows * ncols);
+ Primitive_GC_If_Needed (Length * REAL_SIZE);
+ {
+ REAL * Temp_Array = ((REAL *) Free);
+ Image_Rotate_90cclw (Array, Temp_Array, nrows, ncols);
+ C_Array_Copy (Temp_Array, Array, Length);
+ }
+ {
+ SCHEME_OBJECT argument = (ARG_REF (1));
+ SET_PAIR_CAR (argument, (LONG_TO_UNSIGNED_FIXNUM (ncols)));
+ SET_PAIR_CAR ((PAIR_CDR (argument)), (LONG_TO_UNSIGNED_FIXNUM (nrows)));
+ PRIMITIVE_RETURN (argument);
+ }
}
DEFINE_PRIMITIVE ("IMAGE-MIRROR!", Prim_image_mirror, 1, 1, 0)
-{ long Length;
- Pointer Pnrows, Pncols, Prest, Parray;
- long nrows, ncols;
- REAL *Array, *Temp_Array;
-
- Primitive_1_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
-
- Pnrows = Vector_Ref(Arg1, CONS_CAR);
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Pncols = Vector_Ref(Prest, CONS_CAR);
- Prest = Vector_Ref(Prest, CONS_CDR);
- Parray = Vector_Ref(Prest, CONS_CAR);
- if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- Range_Check(nrows, Pnrows, 0, 1024, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 1024, ERR_ARG_1_BAD_RANGE);
- Length = nrows*ncols;
-
- Array = Scheme_Array_To_C_Array(Parray);
- C_Mirror_Image(Array, nrows, ncols); /* side-effecting... */
-
- return Arg1;
+{
+ long nrows;
+ long ncols;
+ REAL * Array;
+ PRIMITIVE_HEADER (1);
+ {
+ SCHEME_OBJECT Parray;
+ arg_image (1, (&nrows), (&ncols), (&Parray));
+ Array = (ARRAY_CONTENTS (Parray));
+ }
+ C_Mirror_Image (Array, nrows, ncols); /* side-effecting... */
+ PRIMITIVE_RETURN (ARG_REF (1));
}
-
+\f
/* C routines referred to above */
-/*
- IMAGE_FAST_TRANSPOSE
- A(i,j) <-> A(j,i) .
- UNWRAP: A(i,j) ----> Array[i*ncols + j] convention:= fix row & go by columns .
- UNWRAP is a bijection from the compact plane to the compact interval.
- */
-Image_Fast_Transpose(Array, nrows) /* for square images */
- REAL *Array; long nrows;
+/* IMAGE_FAST_TRANSPOSE
+ A(i,j) <-> A(j,i) .
+ UNWRAP: A(i,j) ----> Array[i*ncols + j]
+ convention:= fix row & go by columns .
+ UNWRAP is a bijection from the compact plane to the compact interval. */
+
+Image_Fast_Transpose (Array, nrows) /* for square images */
+ REAL *Array;
+ long nrows;
{ long i, j;
long from, to;
REAL temp;
for (i=0;i<nrows;i++) {
for (j=i;j<nrows;j++) {
from = i*nrows + j;
- to = j*nrows + i; /* (columns transposed-image) = ncols */
+ to = j*nrows + i; /* (columns transposed-image) = ncols */
temp = Array[from];
Array[from] = Array[to];
Array[to] = temp;
}}
}
-/*
- IMAGE_TRANSPOSE
- A(i,j) -> B(j,i) .
- UNWRAP: A(i,j) ----> Array[i*ncols + j] convention:= fix row & go by columns .
- UNWRAP is a bijection from the compact plane to the compact interval.
- */
-Image_Transpose(Array, New_Array, nrows, ncols)
- REAL *Array, *New_Array; long nrows, ncols;
+/* IMAGE_TRANSPOSE
+ A(i,j) -> B(j,i) .
+ UNWRAP: A(i,j) ----> Array[i*ncols + j]
+ convention:= fix row & go by columns .
+ UNWRAP is a bijection from the compact plane to the compact interval. */
+
+Image_Transpose (Array, New_Array, nrows, ncols)
+ REAL *Array, *New_Array;
+ long nrows, ncols;
{ long i, j;
for (i=0;i<nrows;i++) {
for (j=0;j<ncols;j++) {
- New_Array[j*nrows + i] = Array[i*ncols + j]; /* (columns transposed-image) = nrows */
+ /* (columns transposed-image) = nrows */
+ New_Array[j*nrows + i] = Array[i*ncols + j];
}}
}
-/*
- IMAGE_ROTATE_90CLW
- A(i,j) <-> A(j, (nrows-1)-i) .
- UNWRAP: A(i,j) ----> Array[i*ncols + j] convention:= fix row & go by columns
- UNWRAP is a bijection from the compact plane to the compact interval.
- */
-Image_Rotate_90clw(Array, Rotated_Array, nrows, ncols)
- REAL *Array, *Rotated_Array; long nrows, ncols;
+/* IMAGE_ROTATE_90CLW
+ A(i,j) <-> A(j, (nrows-1)-i) .
+ UNWRAP: A(i,j) ----> Array[i*ncols + j]
+ convention:= fix row & go by columns
+ UNWRAP is a bijection from the compact plane to the compact interval. */
+
+Image_Rotate_90clw (Array, Rotated_Array, nrows, ncols)
+ REAL *Array, *Rotated_Array;
+ long nrows, ncols;
{ long i, j;
for (i=0;i<nrows;i++) {
for (j=0;j<ncols;j++) {
- Rotated_Array[(j*nrows) + ((nrows-1)-i)] = Array[i*ncols+j]; /* (columns rotated_image) =nrows */
+ /* (columns rotated_image) =nrows */
+ Rotated_Array[(j*nrows) + ((nrows-1)-i)] = Array[i*ncols+j];
}}
}
-
-/*
- ROTATION 90degrees COUNTER-CLOCK-WISE:
- A(i,j) <-> A((nrows-1)-j, i) . (minus 1 because we start from 0).
- UNWRAP: A(i,j) ----> Array[i*ncols + j] because of convention:= fix row & go by columns
- UNWRAP is a bijection from the compact plane to the compact interval.
- */
-Image_Rotate_90cclw(Array, Rotated_Array, nrows, ncols)
- REAL *Array, *Rotated_Array; long nrows, ncols;
+\f
+/* ROTATION 90degrees COUNTER-CLOCK-WISE:
+ A(i,j) <-> A((nrows-1)-j, i) . (minus 1 because we start from 0).
+ UNWRAP: A(i,j) ----> Array[i*ncols + j]
+ because of convention:= fix row & go by columns
+ UNWRAP is a bijection from the compact plane to the compact interval. */
+
+Image_Rotate_90cclw (Array, Rotated_Array, nrows, ncols)
+ REAL *Array, *Rotated_Array;
+ long nrows, ncols;
{ long i, j;
- register long from_index, to_index;
+ fast long from_index, to_index;
long Length=nrows*ncols;
for (i=0;i<nrows;i++) {
for (j=0;j<ncols;j++) {
from_index = i*ncols +j;
- to_index = ((ncols-1)-j)*nrows + i; /* (columns rotated-image) = nrows */
+ /* (columns rotated-image) = nrows */
+ to_index = ((ncols-1)-j)*nrows + i;
Rotated_Array[to_index] = Array[from_index];
}}
}
-/*
- IMAGE_MIRROR:
- A(i,j) <-> A(i, (ncols-1)-j) [ The -1 is there because we count from 0] .
- A(i,j) -------> Array[i*ncols + j] fix row, read column convention.
- */
-C_Mirror_Image(Array, nrows, ncols) REAL *Array; long nrows, ncols;
+/* IMAGE_MIRROR:
+ A(i,j) <-> A(i, (ncols-1)-j) [ The -1 is there because we count from 0] .
+ A(i,j) -------> Array[i*ncols + j] fix row, read column convention. */
+
+C_Mirror_Image (Array, nrows, ncols)
+ REAL *Array;
+ long nrows, ncols;
{ long i, j;
long ncols2=ncols/2, Length=nrows*ncols;
REAL temp;
long from, to;
-
+
for (i=0; i<Length; i += ncols) {
- for (j=0; j<ncols2; j++) { /* DO NOT UNDO the reflections */
+ for (j=0; j<ncols2; j++) { /* DO NOT UNDO the reflections */
from = i + j; /* i is really i*nrows */
to = i + (ncols-1)-j;
temp = Array[from];
}}
}
-/*
- IMAGE_ROTATE_90CLW_MIRROR:
- A(i,j) <-> A(j, i) this should be identical to image_transpose (see above).
- UNWRAP: A(i,j) ----> Array[i*ncols + j] because of convention:= fix row & go by columns
- UNWRAP is a bijection from the compact plane to the compact interval.
- */
-C_Rotate_90clw_Mirror_Image(Array, Rotated_Array, nrows, ncols)
- REAL *Array, *Rotated_Array; long nrows, ncols;
+/* IMAGE_ROTATE_90CLW_MIRROR:
+ A(i,j) <-> A(j, i)
+ this should be identical to image_transpose (see above).
+ UNWRAP: A(i,j) ----> Array[i*ncols + j]
+ because of convention:= fix row & go by columns
+ UNWRAP is a bijection from the compact plane to the compact interval. */
+
+C_Rotate_90clw_Mirror_Image (Array, Rotated_Array, nrows, ncols)
+ REAL *Array, *Rotated_Array;
+ long nrows, ncols;
{ long i, j;
long from, to, Length=nrows*ncols;
-
+
for (i=0;i<nrows;i++) {
for (j=0;j<ncols;j++) {
from = i*ncols +j;
- to = j*nrows +i; /* the columns of the rotated image are nrows! */
+ /* the columns of the rotated image are nrows! */
+ to = j*nrows +i;
Rotated_Array[to] = Array[from];
}}
}
-
-
-/* More Image Manipulation -----------------------
- */
-
-DEFINE_PRIMITIVE ("SQUARE-IMAGE-TIME-REVERSE!",
- Prim_square_image_time_reverse, 2,2, 0)
+\f
+DEFINE_PRIMITIVE ("SQUARE-IMAGE-TIME-REVERSE!", Prim_square_image_time_reverse, 2,2, 0)
{ long i, rows;
REAL *a;
void square_image_time_reverse();
PRIMITIVE_HEADER (2);
CHECK_ARG (1, ARRAY_P);
CHECK_ARG (2, FIXNUM_P);
- a = Scheme_Array_To_C_Array(ARG_REF(1));
+ a = ARRAY_CONTENTS(ARG_REF(1));
rows = arg_nonnegative_integer(2);
- if ((rows*rows) != Array_Length(ARG_REF(1))) error_bad_range_arg(1);
+ if ((rows*rows) != ARRAY_LENGTH(ARG_REF(1))) error_bad_range_arg(1);
square_image_time_reverse(a,rows);
-
- PRIMITIVE_RETURN (NIL);
+
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-/* Square Image Time reverse
+/* Square Image Time reverse
is combination of one-dimensional time-reverse
row-wise and column-wise.
- It can be done slightly more efficiently than below.
- */
-void square_image_time_reverse(x,rows)
+ It can be done slightly more efficiently than below. */
+
+void
+square_image_time_reverse (x,rows)
REAL *x;
long rows;
{ long i,cols;
REAL *xrow, *yrow;
void C_Array_Time_Reverse();
cols = rows; /* square image */
-
+
xrow = x;
for (i=0; i<rows; i++) /* row-wise */
{ C_Array_Time_Reverse(xrow,cols);
xrow = xrow + cols; }
-
+
Image_Fast_Transpose(x, rows);
-
+
xrow = x;
for (i=0; i<rows; i++) /* column-wise */
{ C_Array_Time_Reverse(xrow,cols);
xrow = xrow + cols; }
-
+
Image_Fast_Transpose(x, rows);
}
-
-
\f
-/* cs-images
- */
+/* cs-images */
-/* operation-1
- groups together procedures that operate on 1 cs-image-array
- (side-effecting the image)
- */
+/* operation-1
+ groups together procedures that operate on 1 cs-image-array
+ (side-effecting the image) */
-DEFINE_PRIMITIVE ("CS-IMAGE-OPERATION-1!",
- Prim_cs_image_operation_1, 3,3, 0)
+DEFINE_PRIMITIVE ("CS-IMAGE-OPERATION-1!", Prim_cs_image_operation_1, 3,3, 0)
{ long rows, opcode;
REAL *a;
void cs_image_magnitude(), cs_image_real_part(), cs_image_imag_part();
CHECK_ARG (1, FIXNUM_P); /* operation opcode */
CHECK_ARG (2, FIXNUM_P); /* rows */
CHECK_ARG (3, ARRAY_P); /* input and output image array */
-
- a = Scheme_Array_To_C_Array(ARG_REF(3));
+
+ a = ARRAY_CONTENTS(ARG_REF(3));
rows = arg_nonnegative_integer(2); /* square images only */
- if ((rows*rows) != Array_Length(ARG_REF(3))) error_bad_range_arg(1);
+ if ((rows*rows) != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(1);
opcode = arg_nonnegative_integer(1);
-
+
if (opcode==1)
cs_image_magnitude(a,rows);
else if (opcode==2)
cs_image_imag_part(a,rows);
else
error_bad_range_arg(3); /* illegal opcode */
-
- PRIMITIVE_RETURN (NIL);
+
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-void cs_array_real_part(a,n)
- REAL *a; long n;
+void
+cs_array_real_part (a,n)
+ REAL *a;
+ long n;
{ long i,n2; /* works both for even and odd length */
n2 = n/2;
for (i=n2+1;i<n;i++) a[i] = a[n-i]; /* copy real values into place */
/* even signal */
}
-void cs_array_imag_part(a,n)
- REAL *a; long n;
+void
+cs_array_imag_part (a,n)
+ REAL *a;
+ long n;
{ long i,n2;
n2 = n/2; /* integer division truncates down */
for (i=n2+1; i<n; i++) /* works both for even and odd length */
if (2*n2 == n) /* even length, n2 is real only */
a[n2] = 0.0;
}
+\f
+/* From now on (below), assume that cs-images (rows=cols)
+ have always EVEN LENGTH which is true when they come from FFTs */
-
-
-/* From now on (below), assume that cs-images (rows=cols) have always EVEN LENGTH
- which is true when they come from FFTs
- */
-
-
-
-/* In the following 3 time-reverse the bottom half rows
- is done to match the frequencies of complex-images
- coming from cft2d.
+/* In the following 3 time-reverse the bottom half rows
+ is done to match the frequencies of complex-images
+ coming from cft2d.
Also transpose is needed to match frequencies identically
-
+
#|
;; Scrabling of frequencies in cs-images
-
+
;; start from real image 4x4
-
+
;; rft2d is a cs-image
- (3.5 .375 -2.75 1.875 -.25 0. 0. -.25 -.25 -.125 0. .125 .25 .25 0. 0.)
-
- ;; cft2d transposed
+ (3.5 .375 -2.75 1.875 -.25 0. 0. -.25 -.25 -.125 0. .125
+ .25 .25 0. 0.)
+
+ ;; cft2d transposed
;; real
- 3.5 .375 -2.75 .375
+ 3.5 .375 -2.75 .375
-.25 0. 0. -.25 ; same as cs-image
-.25 -.125 0. -.125
-.25 -.25 0. 0. ; row3 = copy 1 + time-reverse
0. .125 0. -.125
-.25 0. 0. -.25 ; row 3 = copy 1 + negate + time-reverse
|#
-
+
*/
-void cs_image_magnitude(x,rows)
+void
+cs_image_magnitude (x,rows)
REAL *x;
long rows;
{ long i,j, cols, n,n2, nj; /* result = real ordinary image */
cols = rows; /* input cs-image is square */
n = rows;
n2 = n/2;
-
+
xrow = x;
cs_array_magnitude(xrow, n); /* row 0 is cs-array */
xrow = x + n2*cols;
cs_array_magnitude(xrow, n); /* row n2 is cs-array */
-
+
xrow = x + cols; /* real part */
yrow = x + (rows-1)*cols; /* imag part */
for (i=1; i<n2; i++) {
- xrow[ 0] = (REAL) sqrt((double) xrow[ 0]*xrow[ 0] + yrow[ 0]*yrow[ 0]);
- xrow[n2] = (REAL) sqrt((double) xrow[n2]*xrow[n2] + yrow[n2]*yrow[n2]);
+ xrow[ 0] = (REAL) sqrt((double) xrow[ 0]*xrow[ 0] + yrow[ 0]*yrow[ 0]);
+ xrow[n2] = (REAL) sqrt((double) xrow[n2]*xrow[n2] + yrow[n2]*yrow[n2]);
yrow[ 0] = xrow[ 0];
yrow[n2] = xrow[n2];
for (j=1; j<n2; j++) {
nj = n-j;
- xrow[ j] = (REAL) sqrt((double) xrow[ j]*xrow[ j] + yrow[ j]*yrow[ j]);
- xrow[nj] = (REAL) sqrt((double) xrow[nj]*xrow[nj] + yrow[nj]*yrow[nj]);
+ xrow[ j] = (REAL) sqrt((double) xrow[ j]*xrow[ j] + yrow[ j]*yrow[ j]);
+ xrow[nj] = (REAL) sqrt((double) xrow[nj]*xrow[nj] + yrow[nj]*yrow[nj]);
yrow[j] = xrow[nj];
- yrow[nj] = xrow[ j]; /* Bottom rows: copy (even) and time-reverse */
+ yrow[nj] = xrow[ j]; /* Bottom rows: copy (even) and time-reverse */
}
xrow = xrow + cols;
yrow = yrow - cols; }
Image_Fast_Transpose(x, n);
}
-
-
-void cs_image_real_part(x,rows)
+\f
+void
+cs_image_real_part (x,rows)
REAL *x;
long rows;
{ long i,j,cols, n,n2;
cols = rows; /* square image */
n = rows;
n2 = n/2;
-
+
xrow = x;
cs_array_real_part(xrow, n); /* row 0 is cs-array */
xrow = x + n2*cols;
cs_array_real_part(xrow, n); /* row n2 is cs-array */
-
+
xrow = x + cols; /* real part */
yrow = x + (rows-1)*cols; /* imag part */
for (i=1; i<n2; i++) {
- yrow[0] = xrow[0]; /* copy real part into imaginary's place (even) */
+ /* copy real part into imaginary's place (even) */
+ yrow[0] = xrow[0];
for (j=1; j<n; j++)
- yrow[j] = xrow[n-j]; /* Bottom rows: copy and time-reverse */
+ yrow[j] = xrow[n-j]; /* Bottom rows: copy and time-reverse */
xrow = xrow + cols;
- yrow = yrow - cols; }
+ yrow = yrow - cols; }
Image_Fast_Transpose(x, n);
}
-void cs_image_imag_part(x,rows)
+void
+cs_image_imag_part (x,rows)
REAL *x;
long rows;
{ long i,j,cols, n,n2, nj;
cols = rows; /* square image */
n = rows;
n2 = n/2;
-
+
xrow = x;
cs_array_imag_part(xrow, n); /* row 0 is cs-array */
xrow = x + n2*cols;
cs_array_imag_part(xrow, n); /* row n2 is cs-array */
-
+
xrow = x + cols; /* real part */
yrow = x + (rows-1)*cols; /* imag part */
for (i=1; i<n2; i++) {
- xrow[0] = yrow[0]; /* copy the imaginary part into real's place */
+ xrow[0] = yrow[0]; /* copy the imaginary part into real's place */
xrow[n2] = yrow[n2];
- yrow[0] = (-yrow[0]); /* negate (odd) */
+ yrow[0] = (-yrow[0]); /* negate (odd) */
yrow[n2] = (-yrow[n2]);
for (j=1;j<n2; j++) {
nj = n-j;
- xrow[j] = yrow[j]; /* copy the imaginary part into real's place */
+ xrow[j] = yrow[j]; /* copy the imaginary part into real's place */
xrow[nj] = yrow[nj];
- yrow[j] = (-xrow[nj]); /* Bottom rows: negate (odd) and time-reverse */
+ /* Bottom rows: negate (odd) and time-reverse */
+ yrow[j] = (-xrow[nj]);
yrow[nj] = (-xrow[j]); }
xrow = xrow + cols;
yrow = yrow - cols; }
Image_Fast_Transpose(x, n);
}
-
\f
/* cs-image-operation-2
- groups together procedures that use 2 cs-image-arrays
- (usually side-effecting the 2nd image, but not necessarily)
- */
+ groups together procedures that use 2 cs-image-arrays
+ (usually side-effecting the 2nd image, but not necessarily) */
-DEFINE_PRIMITIVE ("CS-IMAGE-OPERATION-2!",
- Prim_cs_image_operation_2, 4,4, 0)
+DEFINE_PRIMITIVE ("CS-IMAGE-OPERATION-2!", Prim_cs_image_operation_2, 4, 4, 0)
{ long rows, nn, opcode;
REAL *x,*y;
void cs_image_multiply_into_second_one();
CHECK_ARG (2, FIXNUM_P); /* rows */
CHECK_ARG (3, ARRAY_P); /* image array 1 */
CHECK_ARG (4, ARRAY_P); /* image array 2 */
-
- x = Scheme_Array_To_C_Array(ARG_REF(3));
- y = Scheme_Array_To_C_Array(ARG_REF(4));
+
+ x = ARRAY_CONTENTS(ARG_REF(3));
+ y = ARRAY_CONTENTS(ARG_REF(4));
rows = arg_nonnegative_integer(2); /* square images only */
nn = rows*rows;
- if (nn != Array_Length(ARG_REF(3))) error_bad_range_arg(3);
- if (nn != Array_Length(ARG_REF(4))) error_bad_range_arg(4);
-
+ if (nn != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
+ if (nn != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
+
opcode = arg_nonnegative_integer(1);
-
+
if (opcode==1)
cs_image_multiply_into_second_one(x,y,rows); /* result in y */
else if (opcode==2)
error_bad_range_arg(1); /* illegal opcode */
else
error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (NIL);
-}
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
-void cs_image_multiply_into_second_one(x,y, rows)
+void
+cs_image_multiply_into_second_one (x,y, rows)
REAL *x,*y;
long rows;
{ long i,j,cols, n,n2;
cols = rows; /* square image */
n = rows;
n2 = n/2;
-
+
xrow= x; yrow= y;
cs_array_multiply_into_second_one(xrow,yrow, n,n2); /* row 0 */
-
+
xrow= x+n2*cols; yrow= y+n2*cols;
cs_array_multiply_into_second_one(xrow,yrow, n,n2); /* row n2 */
-
- xrow_r= x+cols; yrow_r= y+cols;
+
+ xrow_r= x+cols; yrow_r= y+cols;
xrow_i= x+(n-1)*cols; yrow_i= y+(n-1)*cols;
for (i=1; i<n2; i++) {
for (j=0; j<n; j++) {
xrow_i= xrow_i-cols; yrow_i= yrow_i-cols;
}
}
+\f
+/* cs-image-operation-2x! is just like cs-image-operation-2!
+ but takes an additional flonum argument. */
-/*
- cs-image-operation-2x! is just like cs-image-operation-2!
- but takes an additional flonum argument.
- */
-
-DEFINE_PRIMITIVE ("CS-IMAGE-OPERATION-2x!",
- Prim_cs_image_operation_2x, 5,5, 0)
+DEFINE_PRIMITIVE ("CS-IMAGE-OPERATION-2x!", Prim_cs_image_operation_2x, 5, 5, 0)
{ long rows, nn, opcode;
REAL *x,*y, flonum_arg;
- int errcode;
void cs_image_divide_into_z();
PRIMITIVE_HEADER (5);
CHECK_ARG (1, FIXNUM_P); /* operation opcode */
CHECK_ARG (2, FIXNUM_P); /* rows */
CHECK_ARG (3, ARRAY_P); /* image array 1 */
CHECK_ARG (4, ARRAY_P); /* image array 2 */
-
- errcode = Scheme_Number_To_REAL(ARG_REF(5), &flonum_arg); /* extra argument */
- if (errcode==1) error_bad_range_arg(5); if (errcode==2) error_wrong_type_arg(5);
-
- x = Scheme_Array_To_C_Array(ARG_REF(3));
- y = Scheme_Array_To_C_Array(ARG_REF(4));
+ flonum_arg = (arg_real (5));
+
+ x = ARRAY_CONTENTS(ARG_REF(3));
+ y = ARRAY_CONTENTS(ARG_REF(4));
rows = arg_nonnegative_integer(2); /* square images only */
nn = rows*rows;
- if (nn != Array_Length(ARG_REF(3))) error_bad_range_arg(3);
- if (nn != Array_Length(ARG_REF(4))) error_bad_range_arg(4);
-
+ if (nn != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
+ if (nn != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
+
opcode = arg_nonnegative_integer(1);
-
+
if (opcode==1)
cs_image_divide_into_z( x,y, x, rows, flonum_arg); /* result in x */
else if (opcode==2)
cs_image_divide_into_z( x,y, y, rows, flonum_arg); /* result in y */
else
error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (NIL);
-}
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
-/* The convention for inf values in division 1/0
- is just like in arrays
- */
+/* The convention for inf values in division 1/0 is just like in arrays */
-void cs_image_divide_into_z(x,y, z, rows, inf) /* z can be either x or y */
- REAL *x,*y,*z, inf;
+void
+cs_image_divide_into_z (x,y, z, rows, inf)
+ REAL *x,*y,*z, inf; /* z can be either x or y */
long rows;
{ long i,j,cols, n,n2;
REAL temp, radius;
- REAL *ar_,*ai_, *br_,*bi_, *zr_,*zi_; /* Letters a,b correspond to x,y */
+ REAL *ar_,*ai_, *br_,*bi_, *zr_,*zi_; /* Letters a,b correspond to x,y */
REAL *xrow,*yrow,*zrow;
cols = rows; /* square image */
n = rows;
n2 = n/2;
-
+
xrow= x; yrow= y; zrow= z;
cs_array_divide_into_z( xrow,yrow, zrow, n,n2, inf); /* row 0 */
-
- xrow= x+n2*cols; yrow= y+n2*cols; zrow= z+n2*cols;
+
+ xrow= x+n2*cols; yrow= y+n2*cols; zrow= z+n2*cols;
cs_array_divide_into_z( xrow,yrow, zrow, n,n2, inf); /* row n2 */
-
+
ar_= x+cols; br_= y+cols; zr_= z+cols;
ai_= x+(n-1)*cols; bi_= y+(n-1)*cols; zi_= z+(n-1)*cols;
for (i=1; i<n2; i++) {
for (j=0; j<n; j++) {
- radius = br_[j]*br_[j] + bi_[j]*bi_[j]; /* b^2 denominator = real^2 + imag^2 */
-
+ /* b^2 denominator = real^2 + imag^2 */
+ radius = br_[j]*br_[j] + bi_[j]*bi_[j];
+
if (radius == 0.0) {
if (ar_[j] == 0.0) zr_[j] = 1.0;
else zr_[j] = ar_[j] * inf;
else {
temp = ar_[j]*br_[j] + ai_[j]*bi_[j];
zi_[j] = (ai_[j]*br_[j] - ar_[j]*bi_[j]) / radius; /* imag part */
- zr_[j] = temp / radius; /* real part */
+ zr_[j] = temp / radius; /* real part */
}}
ar_= ar_+cols; br_= br_+cols; zr_= zr_+cols;
ai_= ai_-cols; bi_= bi_-cols; zi_= zi_-cols;
}
}
-
-
\f
/* operation-3
- groups together procedures that use 3 cs-image-arrays
- (usually side-effecting the 3rd image, but not necessarily)
- */
+ groups together procedures that use 3 cs-image-arrays
+ (usually side-effecting the 3rd image, but not necessarily) */
-DEFINE_PRIMITIVE ("CS-IMAGE-OPERATION-3!",
- Prim_cs_image_operation_3, 5,5, 0)
+DEFINE_PRIMITIVE ("CS-IMAGE-OPERATION-3!", Prim_cs_image_operation_3, 5, 5, 0)
{ long rows, nn, opcode;
REAL *x,*y,*z;
void tr_complex_image_to_cs_image();
CHECK_ARG (3, ARRAY_P); /* image array 1 */
CHECK_ARG (4, ARRAY_P); /* image array 2 */
CHECK_ARG (5, ARRAY_P); /* image array 3 */
-
- x = Scheme_Array_To_C_Array(ARG_REF(3));
- y = Scheme_Array_To_C_Array(ARG_REF(4));
- z = Scheme_Array_To_C_Array(ARG_REF(5));
+
+ x = ARRAY_CONTENTS(ARG_REF(3));
+ y = ARRAY_CONTENTS(ARG_REF(4));
+ z = ARRAY_CONTENTS(ARG_REF(5));
rows = arg_nonnegative_integer(2); /* square images only */
nn = rows*rows;
- if (nn != Array_Length(ARG_REF(3))) error_bad_range_arg(3);
- if (nn != Array_Length(ARG_REF(4))) error_bad_range_arg(4);
- if (nn != Array_Length(ARG_REF(5))) error_bad_range_arg(5);
-
+ if (nn != ARRAY_LENGTH(ARG_REF(3))) error_bad_range_arg(3);
+ if (nn != ARRAY_LENGTH(ARG_REF(4))) error_bad_range_arg(4);
+ if (nn != ARRAY_LENGTH(ARG_REF(5))) error_bad_range_arg(5);
+
opcode = arg_nonnegative_integer(1);
-
+
if (opcode==1)
tr_complex_image_to_cs_image(x,y, z,rows); /* result in z */
else if (opcode==2)
error_bad_range_arg(1); /* illegal opcode */
else
error_bad_range_arg(1); /* illegal opcode */
-
- PRIMITIVE_RETURN (NIL);
+
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-/* x and y must be ALREADY TRANSPOSED real and imaginary parts
- */
-void tr_complex_image_to_cs_image(x,y, z,rows)
+/* x and y must be ALREADY TRANSPOSED real and imaginary parts */
+void
+tr_complex_image_to_cs_image (x,y, z,rows)
REAL *x,*y,*z;
long rows;
{ long i,j,cols, n,n2, n2_1_n;
cols = rows; /* square image */
n = rows;
n2 = n/2;
-
- xrow= x; yrow= y; zrow= z;
- for (j=0; j<=n2; j++) zrow[j] = xrow[j]; /* real part of row 0 (cs-array) */
- for (j=n2+1; j<n; j++) zrow[j] = yrow[n-j]; /* imag part of row 0 */
-
+
+ xrow= x; yrow= y; zrow= z;
+ for (j=0; j<=n2; j++)
+ /* real part of row 0 (cs-array) */
+ zrow[j] = xrow[j];
+ for (j=n2+1; j<n; j++)
+ /* imag part of row 0 */
+ zrow[j] = yrow[n-j];
xrow= x+n2*cols; yrow= y+n2*cols; zrow= z+n2*cols;
- for (j=0; j<=n2; j++) zrow[j] = xrow[j]; /* real part of row n2 (cs-array) */
- for (j=n2+1; j<n; j++) zrow[j] = yrow[n-j]; /* imag part of row n2 */
-
+ for (j=0; j<=n2; j++)
+ /* real part of row n2 (cs-array) */
+ zrow[j] = xrow[j];
+ for (j=n2+1; j<n; j++)
+ /* imag part of row n2 */
+ zrow[j] = yrow[n-j];
xrow= x+cols; zrow= z+cols; n2_1_n = (n2-1)*cols;
- for (j=0; j<n2_1_n; j++) zrow[j] = xrow[j]; /* real rows 1,2,..,n2-1 */
-
- yrow= y+(n2-1)*cols; zrow= z+(n2+1)*cols; /* imag rows n2+1,n2+2,... */
+ for (j=0; j<n2_1_n; j++)
+ /* real rows 1,2,..,n2-1 */
+ zrow[j] = xrow[j];
+ yrow= y+(n2-1)*cols;
+ /* imag rows n2+1,n2+2,... */
+ zrow= z+(n2+1)*cols;
for (i=1; i<n2; i++) {
for (j=0; j<n; j++) zrow[j] = yrow[j];
zrow = zrow + cols;
yrow = yrow - cols;
- }
+ }
}
-
-
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/image.h,v 9.23 1989/09/20 23:09:19 cph Rel $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
Technology nor of any adaptation thereof in any advertising,
promotional, or sales literature without prior written consent from
MIT in each case. */
+\f
+extern Image_Fast_Transpose ();
+/* REAL * Array;
+ long nrows;
+ OPTIMIZATION for square images */
+
+extern Image_Transpose ();
+/* REAL * Array;
+ REAL * New_Array;
+ long nrows;
+ long ncols; */
+
+extern Image_Rotate_90clw ();
+/* REAL * Array;
+ REAL * Rotated_Array;
+ long nrows;
+ long ncols; */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/image.h,v 9.22 1988/08/15 20:49:39 cph Rel $ */
+extern Image_Rotate_90cclw ();
+/* REAL * Array;
+ REAL * Rotated_Array;
+ long nrows;
+ long ncols; */
-extern Image_Fast_Transpose(); /* REAL *Array; long nrows; OPTIMIZATION for square images */
-extern Image_Transpose(); /* REAL *Array, *New_Array; long nrows, ncols; */
-extern Image_Rotate_90clw(); /* REAL *Array, *Rotated_Array; long nrows, ncols; */
-extern Image_Rotate_90cclw(); /* REAL *Array, *Rotated_Array; long nrows, ncols; */
-extern Image_Mirror(); /* REAL *Array; long nrows, ncols; */
+extern Image_Mirror ();
+/* REAL * Array;
+ long nrows;
+ long ncols; */
-extern Image_Mirror_Upside_Down(); /* Array,nrows,ncols,Temp_Array;
- REAL *Array,*Temp_Row; long nrows, ncols; */
-extern Image_Read_From_CTSCAN_File(); /* FILE *fp; REAL *Array; long nrows, ncols */
+extern Image_Mirror_Upside_Down ();
+/* REAL * Array;
+ long nrows;
+ long ncols;
+ REAL * Temp_Row; */
-extern Image_Rotate_90clw_Mirror(); /* REAL *Array, *Rotated_Array; long nrows, ncols; */
+extern Image_Rotate_90clw_Mirror ();
+/* REAL * Array;
+ REAL * Rotated_Array;
+ long nrows;
+ long ncols; */
-extern Image_Draw_Magnify_N_Times_With_Offset_Scale();
-extern Image_Draw_Magnify_N_Times_With_Offset_Scale_Only();
+extern Image_Draw_Magnify_N_Times_With_Offset_Scale ();
+extern Image_Draw_Magnify_N_Times_With_Offset_Scale_Only ();
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/intercom.c,v 9.26 1989/05/31 01:50:26 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/intercom.c,v 9.27 1989/09/20 23:09:24 cph Exp $
*
* Single-processor simulation of locking, propagating, and
* communicating stuff.
\f
DEFINE_PRIMITIVE ("GLOBAL-INTERRUPT", Prim_send_global_interrupt, 3, 3, 0)
{
- long Saved_Zone, Which_Level;
- Primitive_3_Args();
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- Arg_1_Type(TC_FIXNUM);
- Range_Check(Which_Level, Arg1, 0, 3, ERR_ARG_1_BAD_RANGE);
- Save_Time_Zone(Zone_Global_Int);
- Pop_Primitive_Frame(3);
- Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
- Store_Return(RC_FINISH_GLOBAL_INT);
- Store_Expression(Arg1);
- Save_Cont();
- Push(Arg3);
- Push(STACK_FRAME_HEADER);
- Pushed();
- Restore_Time_Zone();
- PRIMITIVE_ABORT(PRIM_APPLY);
+ long Which_Level;
+ SCHEME_OBJECT work;
+ SCHEME_OBJECT test;
+ long Saved_Zone;
+ PRIMITIVE_HEADER (3);
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ Which_Level = (arg_index_integer (1, 4));
+ work = (ARG_REF (2)); /* Why is this being ignored? -- CPH */
+ test = (ARG_REF (3));
+ Save_Time_Zone (Zone_Global_Int);
+ Pop_Primitive_Frame (3);
+ Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
+ Store_Return (RC_FINISH_GLOBAL_INT);
+ Store_Expression (LONG_TO_UNSIGNED_FIXNUM (Which_Level));
+ Save_Cont ();
+ Push (test);
+ Push (STACK_FRAME_HEADER);
+ Pushed ();
+ Restore_Time_Zone ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
}
-Pointer
-Global_Int_Part_2(Which_Level, Do_It)
- Pointer Do_It, Which_Level;
+SCHEME_OBJECT
+Global_Int_Part_2 (Which_Level, Do_It)
+ SCHEME_OBJECT Which_Level;
+ SCHEME_OBJECT Do_It;
{
- return Do_It;
+ return (Do_It);
}
\f
DEFINE_PRIMITIVE ("PUT-WORK", Prim_put_work, 1, 1, 0)
{
- Pointer The_Queue, Queue_Tail, New_Entry;
- Primitive_1_Arg();
-
- The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
- if (The_Queue == NIL)
- {
- Primitive_GC_If_Needed(4);
- The_Queue = Make_Pointer(TC_LIST, Free);
- Set_Fixed_Obj_Slot(The_Work_Queue, The_Queue);
- *Free++ = NIL;
- *Free++ = NIL;
- }
- else
- {
- Primitive_GC_If_Needed(2);
- }
- Queue_Tail = Vector_Ref(The_Queue, CONS_CDR);
- New_Entry = Make_Pointer(TC_WEAK_CONS, Free);
- *Free++ = Arg1;
- *Free++ = NIL;
- Vector_Set(The_Queue, CONS_CDR, New_Entry);
- if (Queue_Tail == NIL)
+ PRIMITIVE_HEADER (1);
{
- Vector_Set(The_Queue, CONS_CAR, New_Entry);
- }
- else
- {
- Vector_Set(Queue_Tail, CONS_CDR, New_Entry);
+ SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
+ if (queue == EMPTY_LIST)
+ {
+ queue = (cons (EMPTY_LIST, EMPTY_LIST));
+ Set_Fixed_Obj_Slot (The_Work_Queue, queue);
+ }
+ {
+ SCHEME_OBJECT queue_tail = (PAIR_CDR (queue));
+ SCHEME_OBJECT new_entry = (cons ((ARG_REF (1)), EMPTY_LIST));
+ SET_PAIR_CDR (queue, new_entry);
+ if (queue_tail == EMPTY_LIST)
+ SET_PAIR_CAR (queue, new_entry);
+ else
+ SET_PAIR_CDR (queue_tail, new_entry);
+ }
}
- PRIMITIVE_RETURN(SHARP_T);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
+
DEFINE_PRIMITIVE ("PUT-WORK-IN-FRONT", Prim_put_work_in_front, 1, 1, 0)
{
- Pointer The_Queue, Queue_Head, New_Entry;
- Primitive_1_Arg();
-
- The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
- if (The_Queue == NIL)
- { Primitive_GC_If_Needed(4);
- The_Queue = Make_Pointer(TC_LIST, Free);
- Set_Fixed_Obj_Slot(The_Work_Queue, The_Queue);
- *Free++ = NIL;
- *Free++ = NIL;
- }
- else
+ PRIMITIVE_HEADER (1);
{
- Primitive_GC_If_Needed(2);
- }
-
- Queue_Head = Vector_Ref(The_Queue, CONS_CDR);
- New_Entry = Make_Pointer(TC_WEAK_CONS, Free);
- *Free++ = Arg1;
- *Free++ = Queue_Head;
- Vector_Set(The_Queue, CONS_CAR, New_Entry);
- if (Queue_Head == NIL)
- {
- Vector_Set(The_Queue, CONS_CDR, New_Entry);
+ SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
+ if (queue == EMPTY_LIST)
+ {
+ queue = (cons (EMPTY_LIST, EMPTY_LIST));
+ Set_Fixed_Obj_Slot (The_Work_Queue, queue);
+ }
+ {
+ SCHEME_OBJECT queue_head = (PAIR_CAR (queue));
+ SCHEME_OBJECT new_entry = (cons ((ARG_REF (1)), queue_head));
+ SET_PAIR_CAR (queue, new_entry);
+ if (queue_head == EMPTY_LIST)
+ SET_PAIR_CDR (queue, new_entry);
+ }
}
- PRIMITIVE_RETURN(SHARP_T);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
+
DEFINE_PRIMITIVE ("DRAIN-WORK-QUEUE!", Prim_drain_queue, 0, 0, 0)
{
- Pointer The_Queue;
- Primitive_0_Args();
-
- The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
- Set_Fixed_Obj_Slot(The_Work_Queue, NIL);
- PRIMITIVE_RETURN((The_Queue != NIL) ?
- Vector_Ref(The_Queue, CONS_CAR) :
- NIL);
+ PRIMITIVE_HEADER (0);
+ {
+ SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
+ Set_Fixed_Obj_Slot (The_Work_Queue, EMPTY_LIST);
+ PRIMITIVE_RETURN ((queue != EMPTY_LIST) ? (PAIR_CAR (queue)) : EMPTY_LIST);
+ }
}
DEFINE_PRIMITIVE ("PEEK-AT-WORK-QUEUE", Prim_peek_queue, 0, 0, 0)
{
- Pointer The_Queue, This_Cons, Last_Cons;
- Primitive_0_Args();
-
- The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
- if (The_Queue == NIL) return NIL;
-
- Last_Cons = NIL;
- for (The_Queue = Vector_Ref(The_Queue, CONS_CAR);
- The_Queue != NIL;
- The_Queue = Vector_Ref(The_Queue, CONS_CDR))
+ PRIMITIVE_HEADER (0);
{
- Primitive_GC_If_Needed(2);
- This_Cons = Make_Pointer(TC_LIST, Free);
- *Free++ = Vector_Ref(The_Queue, CONS_CAR);
- *Free++ = Last_Cons;
- Last_Cons = This_Cons;
+ fast SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
+ if (queue == EMPTY_LIST)
+ PRIMITIVE_RETURN (EMPTY_LIST);
+ /* Reverse the queue and return it.
+ (Why is it being reversed? -- cph) */
+ {
+ fast SCHEME_OBJECT this_pair = (PAIR_CAR (queue));
+ fast SCHEME_OBJECT result = EMPTY_LIST;
+ while (this_pair != EMPTY_LIST)
+ {
+ result = (cons ((PAIR_CAR (this_pair)), result));
+ this_pair = (PAIR_CDR (this_pair));
+ }
+ PRIMITIVE_RETURN (result);
+ }
}
-
- PRIMITIVE_RETURN(This_Cons);
}
\f
DEFINE_PRIMITIVE ("GET-WORK", Prim_get_work, 1, 1, 0)
{
- Pointer Get_Work();
- Pointer result;
- Primitive_1_Arg();
-
- result = Get_Work(Arg1);
- PRIMITIVE_RETURN(result);
-}
-
-Pointer Get_Work(Arg1)
- Pointer Arg1;
-{
- Pointer The_Queue, Queue_Head, Result, The_Prim;
-
- /* This gets this primitive's code which is in the expression register. */
- The_Prim = Regs[REGBLOCK_PRIMITIVE];
- 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))
+ PRIMITIVE_HEADER (1);
{
- if (Arg1 == NIL)
+ SCHEME_OBJECT thunk = (ARG_REF (1));
+ /* This gets this primitive's code which is in the expression register. */
+ SCHEME_OBJECT primitive = (Regs [REGBLOCK_PRIMITIVE]);
+ SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
+ SCHEME_OBJECT queue_head =
+ ((queue == EMPTY_LIST) ? EMPTY_LIST : (PAIR_CAR (queue)));
+ if (queue_head == EMPTY_LIST)
+ {
+ if (thunk == SHARP_F)
+ {
+ fprintf (stderr,
+ "\nNo work available, but some has been requested!\n");
+ Microcode_Termination (TERM_EXIT);
+ }
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ Pop_Primitive_Frame (1);
+ Will_Push ((2 * (STACK_ENV_EXTRA_SLOTS + 1)) + 1 + CONTINUATION_SIZE);
+ /* When the thunk returns, call the primitive again.
+ If there's still no work, we lose. */
+ Push (SHARP_F);
+ Push (primitive);
+ Push (STACK_FRAME_HEADER + 1);
+ Store_Expression (SHARP_F);
+ Store_Return (RC_INTERNAL_APPLY);
+ Save_Cont ();
+ /* Invoke the thunk. */
+ Push (thunk);
+ Push (STACK_FRAME_HEADER);
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ }
{
- printf("\nNo work available, but some has been requested!\n");
- Microcode_Termination(TERM_EXIT);
+ SCHEME_OBJECT result = (PAIR_CAR (queue_head));
+ queue_head = (PAIR_CDR (queue_head));
+ SET_PAIR_CAR (queue, queue_head);
+ if (queue_head == EMPTY_LIST)
+ SET_PAIR_CDR (queue, EMPTY_LIST);
+ PRIMITIVE_RETURN (result);
}
- else
- {
- PRIMITIVE_CANONICALIZE_CONTEXT();
- 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(The_Prim);
- Push(STACK_FRAME_HEADER+1);
- Store_Expression(NIL);
- Store_Return(RC_INTERNAL_APPLY);
- Save_Cont();
- Push(Arg1);
- Push(STACK_FRAME_HEADER);
- Pushed();
- PRIMITIVE_ABORT(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);
}
\f
DEFINE_PRIMITIVE ("AWAIT-SYNCHRONY", Prim_await_sync, 1, 1, 0)
{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_LIST);
- if (Type_Code(Vector_Ref(Arg1, CONS_CDR)) != TC_FIXNUM)
- {
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- }
- PRIMITIVE_RETURN(SHARP_T);
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, PAIR_P);
+ if (! (FIXNUM_P (PAIR_CDR (ARG_REF (1)))))
+ error_bad_range_arg (1);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("N-INTERPRETERS", Prim_n_interps, 0, 0, 0)
{
- Primitive_0_Args();
-
- PRIMITIVE_RETURN(MAKE_UNSIGNED_FIXNUM(1));
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1));
}
DEFINE_PRIMITIVE ("MY-PROCESSOR-NUMBER", Prim_my_proc, 0, 0, 0)
{
- Primitive_0_Args();
-
- PRIMITIVE_RETURN(MAKE_UNSIGNED_FIXNUM(0));
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
}
DEFINE_PRIMITIVE ("MY-INTERPRETER-NUMBER", Prim_my_interp_number, 0, 0, 0)
{
- Primitive_0_Args();
-
- PRIMITIVE_RETURN(MAKE_UNSIGNED_FIXNUM(0));
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
}
DEFINE_PRIMITIVE ("ZERO-ZONES", Prim_zero_zones, 0, 0, 0)
{
long i;
- Primitive_0_Args();
-
+ PRIMITIVE_HEADER (0);
#ifdef METERING
for (i=0; i < Max_Meters; i++)
{
Old_Time=Sys_Clock();
#endif
- PRIMITIVE_RETURN(SHARP_T);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
/* These are really used by GC on a true parallel machine */
DEFINE_PRIMITIVE ("GC-NEEDED?", Prim_gc_needed, 0, 0, 0)
{
- Primitive_0_Args();
-
- if ((Free + GC_Space_Needed) >= MemTop)
- {
- PRIMITIVE_RETURN(SHARP_T);
- }
- else
- {
- PRIMITIVE_RETURN(NIL);
- }
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((Free + GC_Space_Needed) >= MemTop));
}
DEFINE_PRIMITIVE ("SLAVE-GC-BEFORE-SYNC", Prim_slave_before, 0, 0, 0)
{
- Primitive_0_Args();
-
- PRIMITIVE_RETURN(SHARP_T);
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("SLAVE-GC-AFTER-SYNC", Prim_slave_after, 0, 0, 0)
{
- Primitive_0_Args();
-
- PRIMITIVE_RETURN(SHARP_T);
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("MASTER-GC-BEFORE-SYNC", Prim_master_before, 0, 0, 0)
{
- Primitive_0_Args();
-
- PRIMITIVE_RETURN(SHARP_T);
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-/* This primitive caches the Scheme object for the garbage collector
- primitive so that it does not have to perform a potentially
- expensive search each time.
-*/
-
DEFINE_PRIMITIVE ("MASTER-GC-LOOP", Prim_master_gc, 1, 1, 0)
{
- static Pointer gc_prim = NIL;
- extern Pointer make_primitive();
- Primitive_1_Arg();
-
+ static SCHEME_OBJECT gc_prim = SHARP_F;
+ extern SCHEME_OBJECT make_primitive ();
+ PRIMITIVE_HEADER (1);
PRIMITIVE_CANONICALIZE_CONTEXT();
- if (gc_prim == NIL)
+ /* This primitive caches the Scheme object for the garbage collector
+ primitive so that it does not have to perform a potentially
+ expensive search each time. */
+ if (gc_prim == SHARP_F)
+ gc_prim = (make_primitive ("GARBAGE-COLLECT"));
{
- gc_prim = make_primitive("GARBAGE-COLLECT");
+ SCHEME_OBJECT argument = (ARG_REF (1));
+ Pop_Primitive_Frame (1);
+ Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
+ Push (argument);
+ Push (gc_prim);
+ Push (STACK_FRAME_HEADER + 1);
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
}
- Pop_Primitive_Frame(1);
- Will_Push(STACK_ENV_EXTRA_SLOTS + 2);
- Push(Arg1);
- Push(gc_prim);
- Push(STACK_FRAME_HEADER + 1);
- Pushed();
- PRIMITIVE_ABORT(PRIM_APPLY);
}
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intern.c,v 9.51 1989/09/20 23:09:28 cph Rel $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intern.c,v 9.50 1989/08/28 18:28:55 cph Exp $ */
-
/* String hash functions and interning of symbols. */
#include "scheme.h"
#include "prims.h"
#include "trap.h"
-#include "string.h"
\f
/* Hashing strings */
static unsigned int
string_hash (string)
- Pointer string;
+ SCHEME_OBJECT string;
{
- fast unsigned char * scan;
- fast unsigned char * end;
- fast unsigned int result;
-
- scan = ((unsigned char *) (string_pointer (string, 0)));
- end = (scan + (string_length (string)));
- result = 0;
+ fast unsigned char * scan = (STRING_LOC (string, 0));
+ fast unsigned char * end = (scan + (STRING_LENGTH (string)));
+ fast unsigned int result = 0;
while (scan < end)
{
result <<= 1;
static Boolean
string_equal (string1, string2)
- Pointer string1, string2;
+ SCHEME_OBJECT string1, string2;
{
- fast char * scan1;
- fast char * scan2;
- fast long length;
- fast char * end1;
-
- scan1 = (string_pointer (string1, 0));
- scan2 = (string_pointer (string2, 0));
+ fast unsigned char * scan1 = (STRING_LOC (string1, 0));
+ fast unsigned char * scan2 = (STRING_LOC (string2, 0));
+ fast long length = (STRING_LENGTH (string1));
+ fast unsigned char * end1 = (scan1 + length);
if (scan1 == scan2)
return (true);
- length = (string_length (string1));
- if (length != (string_length (string2)))
+ if (length != (STRING_LENGTH (string2)))
return (false);
- end1 = (scan1 + length);
-
while (scan1 < end1)
if ((*scan1++) != (*scan2++))
return (false);
return (true);
}
\f
-static Pointer *
+static SCHEME_OBJECT *
find_symbol_internal (string)
- Pointer string;
+ SCHEME_OBJECT string;
{
- fast Pointer * bucket;
+ fast SCHEME_OBJECT * bucket;
{
- fast Pointer obarray = (Get_Fixed_Obj_Slot (OBArray));
+ fast SCHEME_OBJECT obarray = (Get_Fixed_Obj_Slot (OBArray));
bucket =
- (Nth_Vector_Loc (obarray,
- (((string_hash (string)) % (Vector_Length (obarray)))
- + 1)));
+ (MEMORY_LOC (obarray,
+ (((string_hash (string)) % (VECTOR_LENGTH (obarray)))
+ + 1)));
}
while ((*bucket) != EMPTY_LIST)
{
- fast Pointer symbol = (Vector_Ref ((*bucket), CONS_CAR));
- if (string_equal (string, (Fast_Vector_Ref (symbol, SYMBOL_NAME))))
- return (Nth_Vector_Loc ((*bucket), CONS_CAR));
- bucket = (Nth_Vector_Loc ((*bucket), CONS_CDR));
+ fast SCHEME_OBJECT symbol = (PAIR_CAR (*bucket));
+ if (string_equal (string, (FAST_MEMORY_REF (symbol, SYMBOL_NAME))))
+ return (PAIR_CAR_LOC (*bucket));
+ bucket = (PAIR_CDR_LOC (*bucket));
}
return (bucket);
}
/* Set this to be informed of symbols as they are interned. */
void (*intern_symbol_hook) () = ((void (*) ()) 0);
-static Pointer
+static SCHEME_OBJECT
link_new_symbol (symbol, cell)
- Pointer symbol;
- Pointer * cell;
+ SCHEME_OBJECT symbol;
+ SCHEME_OBJECT * cell;
{
/* `symbol' does not exist yet in obarray. `cell' points to the
cell containing the final '() in the list. Replace this
with a cons of the new symbol and '() (i.e. extend the
list in the bucket by 1 new element). */
- fast Pointer result =
- (MAKE_OBJECT (TC_INTERNED_SYMBOL, (OBJECT_DATUM (symbol))));
- Primitive_GC_If_Needed (2);
- (*cell) = (Make_Pointer (TC_LIST, Free));
- (Free [CONS_CAR]) = result;
- (Free [CONS_CDR]) = EMPTY_LIST;
- Free += 2;
+ fast SCHEME_OBJECT result = (OBJECT_NEW_TYPE (TC_INTERNED_SYMBOL, symbol));
+ (*cell) = (cons (result, EMPTY_LIST));
if (intern_symbol_hook != ((void (*) ()) 0))
(*intern_symbol_hook) (result);
return (result);
}
\f
-Pointer
+SCHEME_OBJECT
find_symbol (string)
- Pointer string;
+ SCHEME_OBJECT string;
{
- fast Pointer result = (* (find_symbol_internal (string)));
+ fast SCHEME_OBJECT result = (* (find_symbol_internal (string)));
return ((result == EMPTY_LIST) ? SHARP_F : result);
}
-Pointer
+SCHEME_OBJECT
string_to_symbol (string)
- Pointer string;
+ SCHEME_OBJECT string;
{
- fast Pointer * cell = (find_symbol_internal (string));
+ fast SCHEME_OBJECT * cell = (find_symbol_internal (string));
if ((*cell) != EMPTY_LIST)
return (*cell);
Primitive_GC_If_Needed (2);
{
- fast Pointer symbol = (Make_Pointer (TC_UNINTERNED_SYMBOL, Free));
+ fast SCHEME_OBJECT symbol =
+ (MAKE_POINTER_OBJECT (TC_UNINTERNED_SYMBOL, Free));
(Free [SYMBOL_NAME]) = string;
(Free [SYMBOL_GLOBAL_VALUE]) = UNBOUND_OBJECT;
Free += 2;
}
}
-Pointer
+SCHEME_OBJECT
intern_symbol (symbol)
- Pointer symbol;
+ SCHEME_OBJECT symbol;
{
- fast Pointer * cell =
- (find_symbol_internal (Fast_Vector_Ref (symbol, SYMBOL_NAME)));
+ fast SCHEME_OBJECT * cell =
+ (find_symbol_internal (FAST_MEMORY_REF (symbol, SYMBOL_NAME)));
return
(((*cell) != EMPTY_LIST)
? (*cell)
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (string_hash (ARG_REF (1))));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (string_hash (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("STRING-HASH-MOD", Prim_string_hash_mod, 2, 2,
CHECK_ARG (1, STRING_P);
PRIMITIVE_RETURN
- (MAKE_UNSIGNED_FIXNUM
+ (LONG_TO_UNSIGNED_FIXNUM
((string_hash (ARG_REF (1))) % (arg_nonnegative_integer (2))));
}
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.52 1989/09/20 23:09:32 cph Exp $
+
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.51 1989/06/08 00:23:42 jinx Rel $
- *
- * This file contains the heart of the Scheme Scode
- * interpreter
- *
- */
+/* This file contains the heart of the SCode interpreter. */
-#define In_Main_Interpreter true
+#define In_Main_Interpreter true
#include "scheme.h"
#include "locks.h"
#include "trap.h"
#include "lookup.h"
+#include "winder.h"
#include "history.h"
#include "cmpint.h"
#include "zones.h"
*
* 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
+ * 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.
#define RESULT_OF_PURIFY(success) \
{ \
- Pointer words_free; \
+ SCHEME_OBJECT words_free; \
\
- words_free = (Make_Unsigned_Fixnum (MemTop - Free)); \
- Val = (Make_Pointer (TC_LIST, Free)); \
+ words_free = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free)); \
+ Val = (MAKE_POINTER_OBJECT (TC_LIST, Free)); \
(*Free++) = (success); \
(*Free++) = words_free; \
}
}
#define Reduces_To_Nth(N) \
- Reduces_To(Fast_Vector_Ref(Fetch_Expression(), (N)))
+ Reduces_To(FAST_MEMORY_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))); \
+ Store_Expression(FAST_MEMORY_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))); \
+ Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), (N))); \
Reuse_Subproblem(Fetch_Expression(), Fetch_Env()); \
goto Do_Expression; \
}
-
-#define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT))
\f
/***********************/
/* Macros for Stepping */
/***********************/
#define Fetch_Trapper(field) \
- Vector_Ref(Get_Fixed_Obj_Slot(Stepper_State), (field))
+ MEMORY_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 ARG_TYPE_ERROR(Arg_No, Err_No) \
{ \
- fast Pointer *Arg, Orig_Arg; \
+ fast SCHEME_OBJECT *Arg, Orig_Arg; \
\
Arg = &(Stack_Ref((Arg_No - 1) + STACK_ENV_FIRST_ARG)); \
Orig_Arg = *Arg; \
\
- if (OBJECT_TYPE(*Arg) != TC_FUTURE) \
+ if (OBJECT_TYPE (*Arg) != TC_FUTURE) \
{ \
Pop_Return_Error(Err_No); \
} \
\
- while ((OBJECT_TYPE(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
+ while ((OBJECT_TYPE (*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
{ \
if (Future_Is_Keep_Slot(*Arg)) \
{ \
} \
*Arg = Future_Value(*Arg); \
} \
- if (OBJECT_TYPE(*Arg) != TC_FUTURE) \
+ if (OBJECT_TYPE (*Arg) != TC_FUTURE) \
{ \
goto Apply_Non_Trapping; \
} \
#define Apply_Future_Check(Name, Object) \
{ \
- fast Pointer *Arg, Orig_Answer; \
+ fast SCHEME_OBJECT *Arg, Orig_Answer; \
\
Arg = &(Object); \
Orig_Answer = *Arg; \
\
- while (Type_Code(*Arg) == TC_FUTURE) \
+ while (OBJECT_TYPE (*Arg) == TC_FUTURE) \
{ \
if (Future_Has_Value(*Arg)) \
{ \
else \
{ \
Store_Return(RC_INTERNAL_APPLY); \
- Val = NIL; \
+ Val = SHARP_F; \
TOUCH_SETUP(*Arg); \
*Arg = Orig_Answer; \
goto Internal_Apply; \
#define Pop_Return_Val_Check() \
{ \
- fast Pointer Orig_Val = Val; \
+ fast SCHEME_OBJECT Orig_Val = Val; \
\
- while (OBJECT_TYPE(Val) == TC_FUTURE) \
+ while (OBJECT_TYPE (Val) == TC_FUTURE) \
{ \
if (Future_Has_Value(Val)) \
{ \
Push(Val); \
Save_Env(); \
Store_Return(RC_REPEAT_DISPATCH); \
- Store_Expression(MAKE_SIGNED_FIXNUM(CODE_MAP(Which_Way))); \
+ Store_Expression(LONG_TO_FIXNUM(CODE_MAP(Which_Way))); \
Save_Cont(); \
Pushed(); \
Call_Future_Logging(); \
#else /* not COMPILE_FUTURES */
-#define Pop_Return_Val_Check()
+#define Pop_Return_Val_Check()
#define Apply_Future_Check(Name, Object) Name = (Object)
#define PROCEED_AFTER_PRIMITIVE() \
{ \
- Regs[REGBLOCK_PRIMITIVE] = NIL; \
- LOG_FUTURES(); \
+ (Regs [REGBLOCK_PRIMITIVE]) = SHARP_F; \
+ LOG_FUTURES (); \
}
\f
/*
Boolean dumped_p;
{
long Which_Way;
- fast Pointer *Reg_Block, *Reg_Stack_Pointer, *Reg_History;
+ fast SCHEME_OBJECT *Reg_Block, *Reg_Stack_Pointer, *Reg_History;
extern long enter_compiled_expression();
extern long apply_compiled_procedure();
\f
case PRIM_TOUCH:
{
- Pointer temp;
+ SCHEME_OBJECT temp;
temp = Val;
BACK_OUT_AFTER_PRIMITIVE();
/* fall through */
case CODE_MAP(ERR_ARG_3_WRONG_TYPE):
ARG_TYPE_ERROR(3, ERR_ARG_3_WRONG_TYPE);
-
+
default:
{
if (!CODE_MAPPED_P(Which_Way))
if (Eval_Debug)
{ Print_Expression(Fetch_Expression(), "Eval, expression");
- CRLF();
+ printf ("\n");
}
/* The expression register has an Scode item in it which
* the Expression register, and processing continues at
* Do_Expression.
*/
-\f
+
/* Handling of Eval Trapping.
If we are handling traps and there is an Eval Trap set,
turn off all trapping and then go to Internal_Apply to call the
user supplied eval hook with the expression to be evaluated and the
- environment.
-
-*/
+ 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();
+ if (Microcode_Does_Stepping &&
+ Trapping &&
+ ((Fetch_Eval_Trapper ()) != SHARP_F))
+ {
+ Stop_Trapping ();
+ Will_Push (4);
+ Push (Fetch_Env ());
+ Push (Fetch_Expression ());
+ Push (Fetch_Eval_Trapper ());
+ Push (STACK_FRAME_HEADER + 2);
+ Pushed ();
goto Apply_Non_Trapping;
}
\f
Eval_Non_Trapping:
Eval_Ucode_Hook();
- switch (OBJECT_TYPE(Fetch_Expression()))
+ switch (OBJECT_TYPE (Fetch_Expression()))
{
default:
#if false
case TC_REFERENCE_TRAP:
case TC_RETURN_CODE:
case TC_UNINTERNED_SYMBOL:
- case TC_TRUE:
+ case TC_TRUE:
case TC_VECTOR:
case TC_VECTOR_16B:
case TC_VECTOR_1B:
{
long Array_Length;
- Array_Length = (Vector_Length(Fetch_Expression()) - 1);
+ Array_Length = (VECTOR_LENGTH (Fetch_Expression()) - 1);
#ifdef USE_STACKLETS
/* Save_Env, Finger */
Eval_GC_Check(New_Stacklet_Size(Array_Length + 1 + 1 + CONTINUATION_SIZE));
#endif /* USE_STACKLETS */
Will_Push(Array_Length + 1 + 1 + CONTINUATION_SIZE);
Stack_Pointer = Simulate_Pushing(Array_Length);
- Push(Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Array_Length));
+ Push(MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Array_Length));
/* The finger: last argument number */
Pushed();
if (Array_Length == 0)
Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
Save_Env();
Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1, {});
-
+
case TC_COMBINATION_2:
- Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
Save_Env();
Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {});
case TC_COMPILED_ENTRY:
{
- Pointer compiled_expression;
+ SCHEME_OBJECT compiled_expression;
compiled_expression = (Fetch_Expression ());
execute_compiled_setup();
case TC_DELAY:
/* Deliberately omitted: Eval_GC_Check(2); */
- Val = Make_Pointer(TC_DELAYED, Free);
+ Val = MAKE_POINTER_OBJECT (TC_DELAYED, Free);
Free[THUNK_ENVIRONMENT] = Fetch_Env();
- Free[THUNK_PROCEDURE] =
- Fast_Vector_Ref(Fetch_Expression(), DELAY_OBJECT);
+ Free[THUNK_PROCEDURE] =
+ FAST_MEMORY_REF (Fetch_Expression(), DELAY_OBJECT);
Free += 2;
- break;
+ break;
case TC_DISJUNCTION:
Will_Push(CONTINUATION_SIZE + 1);
case TC_EXTENDED_LAMBDA: /* Close the procedure */
/* Deliberately omitted: Eval_GC_Check(2); */
- Val = Make_Pointer(TC_EXTENDED_PROCEDURE, Free);
+ Val = MAKE_POINTER_OBJECT (TC_EXTENDED_PROCEDURE, Free);
Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
Free += 2;
#ifdef COMPILE_FUTURES
case TC_FUTURE:
if (Future_Has_Value(Fetch_Expression()))
- { Pointer Future = Fetch_Expression();
+ { SCHEME_OBJECT Future = Fetch_Expression();
if (Future_Is_Keep_Slot(Future)) Log_Touch_Of_Future(Future);
Reduces_To_Nth(FUTURE_VALUE);
}
case TC_LAMBDA: /* Close the procedure */
case TC_LEXPR:
/* Deliberately omitted: Eval_GC_Check(2); */
- Val = Make_Pointer(TC_PROCEDURE, Free);
+ Val = MAKE_POINTER_OBJECT (TC_PROCEDURE, Free);
Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
Free += 2;
case TC_PCOMB0:
Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
- Store_Expression(Make_New_Pointer(TC_PRIMITIVE, Fetch_Expression()));
+ Store_Expression (OBJECT_NEW_TYPE (TC_PRIMITIVE, (Fetch_Expression ())));
goto Primitive_Internal_Apply;
case TC_PCOMB1:
Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {});
case TC_SCODE_QUOTE:
- Val = Fast_Vector_Ref(Fetch_Expression(), SCODE_QUOTE_OBJECT);
+ Val = FAST_MEMORY_REF (Fetch_Expression(), SCODE_QUOTE_OBJECT);
break;
case TC_SEQUENCE_2:
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
-
+
case TC_VARIABLE:
{
long temp;
#ifndef No_In_Line_Lookup
- fast Pointer *cell;
+ fast SCHEME_OBJECT *cell;
Set_Time_Zone(Zone_Lookup);
- cell = Get_Pointer(Fetch_Expression());
+ cell = OBJECT_ADDRESS (Fetch_Expression());
lookup(cell, Fetch_Env(), cell, repeat_variable_lookup);
lookup_end_restart:
- Val = Fetch(cell[0]);
- if (Type_Code(Val) != TC_REFERENCE_TRAP)
+ Val = MEMORY_FETCH (cell[0]);
+ if (OBJECT_TYPE (Val) != TC_REFERENCE_TRAP)
{
Set_Time_Zone(Zone_Working);
goto Pop_Return;
case TRAP_UNASSIGNED_DANGEROUS:
case TRAP_FLUID_DANGEROUS:
case TRAP_COMPILER_CACHED_DANGEROUS:
- cell = Get_Pointer(Fetch_Expression());
+ cell = OBJECT_ADDRESS (Fetch_Expression());
temp =
deep_lookup_end(deep_lookup(Fetch_Env(),
cell[VARIABLE_SYMBOL],
goto Pop_Return;
case TRAP_COMPILER_CACHED:
- cell = Nth_Vector_Loc(Fast_Vector_Ref(Val, TRAP_EXTRA),
+ cell = MEMORY_LOC (FAST_MEMORY_REF (Val, TRAP_EXTRA),
TRAP_EXTENSION_CELL);
goto lookup_end_restart;
*/
Pop_Return:
- Pop_Return_Ucode_Hook();
+ Pop_Return_Ucode_Hook();
Restore_Cont();
if (Consistency_Check &&
- (Type_Code(Fetch_Return()) != TC_RETURN_CODE))
+ (OBJECT_TYPE (Fetch_Return()) != TC_RETURN_CODE))
{ Push(Val); /* For possible stack trace */
Save_Cont();
Export_Registers();
if (Eval_Debug)
{ Print_Return("Pop_Return, return code");
Print_Expression(Val, "Pop_Return, value");
- CRLF();
+ printf ("\n");
};
/* Dispatch on the return code. A BREAK here will cause
* common occurrence.
*/
- switch (Get_Integer(Fetch_Return()))
+ switch (OBJECT_DATUM (Fetch_Return()))
{
case RC_COMB_1_PROCEDURE:
Restore_Env();
Push(Val); /* Arg. 1 */
- Push(NIL); /* Operator */
+ Push(SHARP_F); /* Operator */
Push(STACK_FRAME_HEADER + 1);
Finished_Eventual_Pushing(CONTINUATION_SIZE);
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN);
case RC_COMB_2_PROCEDURE:
Restore_Env();
Push(Val); /* Arg 1, just calculated */
- Push(NIL); /* Function */
+ Push(SHARP_F); /* Function */
Push(STACK_FRAME_HEADER + 2);
Finished_Eventual_Pushing(CONTINUATION_SIZE);
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN);
{ long Arg_Number;
Restore_Env();
- Arg_Number = Get_Integer(Stack_Ref(STACK_COMB_FINGER))-1;
+ Arg_Number = OBJECT_DATUM (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);
+ Stack_Ref(STACK_COMB_FINGER) =
+ MAKE_OBJECT (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! */
+ the stack parser may create them with #F 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 */
+ Push(FAST_MEMORY_REF (Fetch_Expression(), 0)); /* Frame Size */
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
}
Pop_Return_Val_Check();
End_Subproblem();
Restore_Env();
- Reduces_To_Nth((Val==NIL)? COND_ALTERNATIVE : COND_CONSEQUENT);
+ Reduces_To_Nth ((Val == SHARP_F) ? COND_ALTERNATIVE : COND_CONSEQUENT);
case RC_DISJUNCTION_DECIDE:
- /* Return predicate if it isn't NIL; else do ALTERNATIVE */
+ /* Return predicate if it isn't #F; else do ALTERNATIVE */
Pop_Return_Val_Check();
End_Subproblem();
Restore_Env();
- if (Val != NIL) goto Pop_Return;
+ if (Val != SHARP_F) 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:
/* Should be called RC_REDO_EVALUATION. */
Store_Env(Pop());
case RC_EXECUTE_ACCESS_FINISH:
{
long Result;
- Pointer value;
+ SCHEME_OBJECT value;
Pop_Return_Val_Check();
value = Val;
- if (Environment_P(Val))
+ if (ENVIRONMENT_P (Val))
{ Result = Symbol_Lex_Ref(value,
- Fast_Vector_Ref(Fetch_Expression(),
+ FAST_MEMORY_REF (Fetch_Expression(),
ACCESS_NAME));
Import_Val();
if (Result == PRIM_DONE)
case RC_EXECUTE_ASSIGNMENT_FINISH:
{
long temp;
- Pointer value;
+ SCHEME_OBJECT value;
Lock_Handle set_serializer;
#ifndef No_In_Line_Lookup
- Pointer bogus_unassigned;
- fast Pointer *cell;
+ SCHEME_OBJECT bogus_unassigned;
+ fast SCHEME_OBJECT *cell;
Set_Time_Zone(Zone_Lookup);
Restore_Env();
- cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
+ cell = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME));
lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup);
value = Val;
Val = *cell;
- if (Type_Code(*cell) != TC_REFERENCE_TRAP)
+ if (OBJECT_TYPE (*cell) != TC_REFERENCE_TRAP)
{
normal_assignment_done:
*cell = value;
case TRAP_FLUID_DANGEROUS:
case TRAP_COMPILER_CACHED_DANGEROUS:
remove_lock(set_serializer);
- cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
+ cell = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME));
temp =
deep_assignment_end(deep_lookup(Fetch_Env(),
cell[VARIABLE_SYMBOL],
case TRAP_COMPILER_CACHED:
{
- Pointer extension, references;
+ SCHEME_OBJECT extension, references;
- extension = Fast_Vector_Ref(Val, TRAP_EXTRA);
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
+ extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
- if (Fast_Vector_Ref(references, TRAP_REFERENCES_OPERATOR) != NIL)
+ if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
+ != SHARP_F)
{
/* There are uuo links.
false);
goto external_assignment_return;
}
- cell = Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL);
+ cell = MEMORY_LOC (extension, TRAP_EXTENSION_CELL);
update_lock(set_serializer, cell);
goto assignment_end_after_lock;
- }
+ }
/* Interpret() continues on the next page */
\f
if (value == UNASSIGNED_OBJECT)
value = bogus_unassigned;
-
+
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
Set_Time_Zone(Zone_Lookup);
Restore_Env();
temp = Lex_Set(Fetch_Env(),
- Vector_Ref(Fetch_Expression(), ASSIGN_NAME),
+ MEMORY_REF (Fetch_Expression(), ASSIGN_NAME),
value);
Import_Val();
- if (temp == PRIM_DONE)
+ if (temp == PRIM_DONE)
{
End_Subproblem();
Set_Time_Zone(Zone_Working);
value);
Interrupt(PENDING_INTERRUPTS());
}
-
+
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case RC_EXECUTE_DEFINITION_FINISH:
{
- Pointer value;
+ SCHEME_OBJECT value;
long result;
value = Val;
Restore_Env();
Export_Registers();
result = Local_Set(Fetch_Env(),
- Fast_Vector_Ref(Fetch_Expression(), DEFINE_NAME),
+ FAST_MEMORY_REF (Fetch_Expression(), DEFINE_NAME),
Val);
Import_Registers();
if (result == PRIM_DONE)
case RC_EXECUTE_IN_PACKAGE_CONTINUE:
Pop_Return_Val_Check();
- if (Environment_P(Val))
+ if (ENVIRONMENT_P (Val))
{
End_Subproblem();
Store_Env(Val);
{
/* This just reinvokes the handler */
- Pointer info, handler;
+ SCHEME_OBJECT info, handler;
info = (STACK_REF (0));
Save_Cont();
\f
/* Internal_Apply, the core of the application mechanism.
- Branch here to perform a function application.
+ Branch here to perform a function application.
At this point the top of the stack contains an application frame
which consists of the following elements (see sdata.h):
#define Prepare_Apply_Interrupt() \
{ \
Store_Return(RC_INTERNAL_APPLY); \
- Store_Expression(NIL); \
+ Store_Expression(SHARP_F); \
Save_Cont(); \
}
-
+
#define Apply_Error(N) \
{ \
Store_Return(RC_INTERNAL_APPLY); \
- Store_Expression(NIL); \
- Val = NIL; \
+ Store_Expression(SHARP_F); \
+ Val = SHARP_F; \
Pop_Return_Error(N); \
}
case RC_INTERNAL_APPLY:
Internal_Apply:
- if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Apply_Trapper() != NIL))
+ if (Microcode_Does_Stepping &&
+ Trapping &&
+ ((Fetch_Apply_Trapper ()) != SHARP_F))
{
long Count;
- Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER));
+ Count = OBJECT_DATUM (Stack_Ref(STACK_ENV_HEADER));
Top_Of_Stack() = Fetch_Apply_Trapper();
Push(STACK_FRAME_HEADER + Count);
Stop_Trapping();
- }
+ }
Apply_Non_Trapping:
long Interrupts;
Interrupts = (PENDING_INTERRUPTS());
- Store_Expression(NIL);
- Val = NIL;
+ Store_Expression(SHARP_F);
+ Val = SHARP_F;
Prepare_Apply_Interrupt();
Interrupt(Interrupts);
}
Apply_Ucode_Hook();
- {
- fast Pointer Function;
+ {
+ fast SCHEME_OBJECT Function;
Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION));
- switch(Type_Code(Function))
- {
+ switch(OBJECT_TYPE (Function))
+ {
case TC_ENTITY:
{
*/
nargs = Pop();
- Push(Fast_Vector_Ref(Function, ENTITY_OPERATOR));
+ Push(FAST_MEMORY_REF (Function, ENTITY_OPERATOR));
Push(nargs + 1);
/* This must be done to prevent an infinite push loop by
an entity whose handler is the entity itself or some
{
fast long nargs;
- nargs = Get_Integer(Pop());
- Function = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR);
+ nargs = OBJECT_DATUM (Pop());
+ Function = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR);
{
- fast Pointer formals;
+ fast SCHEME_OBJECT formals;
Apply_Future_Check(formals,
- Fast_Vector_Ref(Function, LAMBDA_FORMALS));
+ FAST_MEMORY_REF (Function, LAMBDA_FORMALS));
- if ((nargs != Vector_Length(formals)) &&
- ((Type_Code(Function) != TC_LEXPR) ||
- (nargs < Vector_Length(formals))))
+ if ((nargs != VECTOR_LENGTH (formals)) &&
+ ((OBJECT_TYPE (Function) != TC_LEXPR) ||
+ (nargs < VECTOR_LENGTH (formals))))
{
Push(STACK_FRAME_HEADER + nargs - 1);
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
}
- if (Eval_Debug)
+ if (Eval_Debug)
{
- Print_Expression(Make_Unsigned_Fixnum(nargs),
+ Print_Expression(LONG_TO_UNSIGNED_FIXNUM(nargs),
"APPLY: Number of arguments");
}
}
{
- fast Pointer *scan;
+ fast SCHEME_OBJECT *scan;
scan = Free;
- Store_Env(Make_Pointer(TC_ENVIRONMENT, scan));
- *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, nargs);
+ Store_Env(MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan));
+ *scan++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, nargs);
while(--nargs >= 0)
*scan++ = Pop();
Free = scan;
- Reduces_To(Fast_Vector_Ref(Function, LAMBDA_SCODE));
+ Reduces_To(FAST_MEMORY_REF (Function, LAMBDA_SCODE));
}
}
case TC_CONTROL_POINT:
{
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
+ if (OBJECT_DATUM (Stack_Ref(STACK_ENV_HEADER)) !=
STACK_ENV_FIRST_ARG)
{
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
*/
case TC_PRIMITIVE:
- {
+ {
fast long nargs;
if (!IMPLEMENTED_PRIMITIVE_P(Function))
}
/* Note that the first test below will fail for lexpr primitives. */
-
- nargs = ((OBJECT_DATUM(Stack_Ref(STACK_ENV_HEADER))) -
+
+ nargs = ((OBJECT_DATUM (Stack_Ref(STACK_ENV_HEADER))) -
(STACK_ENV_FIRST_ARG - 1));
if (nargs != PRIMITIVE_ARITY(Function))
{
{
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
- Regs[REGBLOCK_LEXPR_ACTUALS] = ((Pointer) nargs);
+ Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) nargs);
}
Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
case TC_EXTENDED_PROCEDURE:
{
- Pointer lambda;
+ SCHEME_OBJECT lambda;
long nargs, nparams, formals, params, auxes,
rest_flag, size;
fast long i;
- fast Pointer *scan;
+ fast SCHEME_OBJECT *scan;
- nargs = Get_Integer(Pop()) - STACK_FRAME_HEADER;
+ nargs = OBJECT_DATUM (Pop()) - STACK_FRAME_HEADER;
- if (Eval_Debug)
+ if (Eval_Debug)
{
- Print_Expression(Make_Unsigned_Fixnum(nargs+STACK_FRAME_HEADER),
+ Print_Expression(LONG_TO_UNSIGNED_FIXNUM(nargs+STACK_FRAME_HEADER),
"APPLY: Number of arguments");
}
- lambda = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR);
+ lambda = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR);
Apply_Future_Check(Function,
- Fast_Vector_Ref(lambda, ELAMBDA_NAMES));
- nparams = Vector_Length(Function) - 1;
+ FAST_MEMORY_REF (lambda, ELAMBDA_NAMES));
+ nparams = VECTOR_LENGTH (Function) - 1;
Apply_Future_Check(Function, Get_Count_Elambda(lambda));
formals = Elambda_Formals_Count(Function);
/* Interpret(), continued */
scan = Free;
- Store_Env(Make_Pointer(TC_ENVIRONMENT, scan));
- *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, size);
+ Store_Env(MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan));
+ *scan++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, size);
if (nargs <= params)
{
for (i = (params - nargs); --i >= 0; )
*scan++ = UNASSIGNED_OBJECT;
if (rest_flag)
- *scan++ = NIL;
+ *scan++ = EMPTY_LIST;
for (i = auxes; --i >= 0; )
*scan++ = UNASSIGNED_OBJECT;
}
else
{
/* rest_flag must be true. */
- Pointer list;
-
- list = Make_Pointer(TC_LIST, (scan + size));
+ SCHEME_OBJECT list;
+
+ list = MAKE_POINTER_OBJECT (TC_LIST, (scan + size));
for (i = (params + 1); --i >= 0; )
*scan++ = Pop();
*scan++ = list;
for (i = auxes; --i >= 0; )
*scan++ = UNASSIGNED_OBJECT;
- /* Now scan == Get_Pointer(list) */
+ /* Now scan == OBJECT_ADDRESS (list) */
for (i = (nargs - params); --i >= 0; )
{
*scan++ = Pop();
- *scan = Make_Pointer(TC_LIST, (scan + 1));
+ *scan = MAKE_POINTER_OBJECT (TC_LIST, (scan + 1));
scan += 1;
}
- scan[-1] = NIL;
+ scan[-1] = EMPTY_LIST;
}
Free = scan;
case TC_COMPILED_ENTRY:
{
apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
- Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
+ OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));
Export_Registers();
Which_Way = apply_compiled_procedure();
case PRIM_APPLY:
{
- compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS +
- Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
+ compiler_apply_procedure
+ (STACK_ENV_EXTRA_SLOTS +
+ OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));
goto Internal_Apply;
}
*/
execute_compiled_backout();
- Val = Make_Non_Pointer( TC_COMPILED_ENTRY,
- Fetch_Expression());
+ Val =
+ (OBJECT_NEW_TYPE (TC_COMPILED_ENTRY, (Fetch_Expression ())));
Pop_Return_Error( Which_Way);
}
system without compiler support.
*/
- Store_Expression(NIL);
+ Store_Expression(SHARP_F);
Store_Return(RC_REENTER_COMPILED_CODE);
Pop_Return_Error(Which_Way);
}
/* Expression contains the space in which we are moving */
{
long From_Count;
- Pointer Thunk, New_Location;
+ SCHEME_OBJECT Thunk, New_Location;
- From_Count = Get_Integer(Stack_Ref(TRANSLATE_FROM_DISTANCE));
+ From_Count =
+ (UNSIGNED_FIXNUM_TO_LONG (Stack_Ref (TRANSLATE_FROM_DISTANCE)));
if (From_Count != 0)
- { Pointer Current = Stack_Ref(TRANSLATE_FROM_POINT);
- Stack_Ref(TRANSLATE_FROM_DISTANCE) = Make_Unsigned_Fixnum((From_Count - 1));
- Thunk = Fast_Vector_Ref(Current, STATE_POINT_AFTER_THUNK);
- New_Location = Fast_Vector_Ref(Current, STATE_POINT_NEARER_POINT);
+ { SCHEME_OBJECT Current = Stack_Ref(TRANSLATE_FROM_POINT);
+ Stack_Ref(TRANSLATE_FROM_DISTANCE) =
+ (LONG_TO_UNSIGNED_FIXNUM (From_Count - 1));
+ Thunk = FAST_MEMORY_REF (Current, STATE_POINT_AFTER_THUNK);
+ New_Location = FAST_MEMORY_REF (Current, STATE_POINT_NEARER_POINT);
Stack_Ref(TRANSLATE_FROM_POINT) = New_Location;
if ((From_Count == 1) &&
- (Stack_Ref(TRANSLATE_TO_DISTANCE) == Make_Unsigned_Fixnum(0)))
+ (Stack_Ref(TRANSLATE_TO_DISTANCE) == LONG_TO_UNSIGNED_FIXNUM(0)))
Stack_Pointer = Simulate_Popping(4);
else Save_Cont();
}
else
{
long To_Count;
- fast Pointer To_Location;
+ fast SCHEME_OBJECT To_Location;
fast long i;
- To_Count = (Get_Integer(Stack_Ref(TRANSLATE_TO_DISTANCE))- 1);
+ To_Count =
+ (UNSIGNED_FIXNUM_TO_LONG (Stack_Ref (TRANSLATE_TO_DISTANCE)) - 1);
To_Location = Stack_Ref(TRANSLATE_TO_POINT);
for (i = 0; i < To_Count; i++)
{
- To_Location = Fast_Vector_Ref(To_Location, STATE_POINT_NEARER_POINT);
+ To_Location =
+ (FAST_MEMORY_REF (To_Location, STATE_POINT_NEARER_POINT));
}
- Thunk = Fast_Vector_Ref(To_Location, STATE_POINT_BEFORE_THUNK);
+ Thunk = FAST_MEMORY_REF (To_Location, STATE_POINT_BEFORE_THUNK);
New_Location = To_Location;
- Stack_Ref(TRANSLATE_TO_DISTANCE) = Make_Unsigned_Fixnum(To_Count);
- if (To_Count == 0)
+ Stack_Ref(TRANSLATE_TO_DISTANCE) = LONG_TO_UNSIGNED_FIXNUM(To_Count);
+ if (To_Count == 0)
{
Stack_Pointer = Simulate_Popping(4);
}
Save_Cont();
}
}
- if (Fetch_Expression() != NIL)
+ if ((Fetch_Expression ()) != SHARP_F)
{
- Vector_Set(Fetch_Expression(), STATE_SPACE_NEAREST_POINT, New_Location);
+ MEMORY_SET
+ ((Fetch_Expression ()), STATE_SPACE_NEAREST_POINT, New_Location);
}
else
{
End_Subproblem();
Push(Val); /* Argument value */
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB1_FN_SLOT));
+ Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB1_FN_SLOT));
Primitive_Internal_Apply:
- if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Apply_Trapper() != NIL))
+ if (Microcode_Does_Stepping &&
+ Trapping &&
+ ((Fetch_Apply_Trapper ()) != SHARP_F))
{
/* Does this work in the stacklet case?
We may have a non-contiguous frame. -- Jinx
*/
- Will_Push(3);
+ Will_Push(3);
Push(Fetch_Expression());
Push(Fetch_Apply_Trapper());
Push(STACK_FRAME_HEADER + 1 +
*/
{
- fast Pointer primitive;
+ fast SCHEME_OBJECT primitive;
primitive = Fetch_Expression();
Export_Regs_Before_Primitive();
End_Subproblem();
Push(Val); /* Value of arg. 1 */
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB2_FN_SLOT));
+ Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB2_FN_SLOT));
goto Primitive_Internal_Apply;
case RC_PCOMB2_DO_1:
End_Subproblem();
Push(Val); /* Save value of arg. 1 */
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB3_FN_SLOT));
+ Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB3_FN_SLOT));
goto Primitive_Internal_Apply;
/* Interpret() continues on the next page */
case RC_PCOMB3_DO_1:
{
- Pointer Temp;
+ SCHEME_OBJECT Temp;
Temp = Pop(); /* Value of arg. 3 */
Restore_Env();
case RC_PURIFY_GC_1:
{
- Pointer GC_Daemon_Proc, Result;
+ SCHEME_OBJECT GC_Daemon_Proc, Result;
RENAME_CRITICAL_SECTION ("purify pass 2");
Export_Registers();
Result = Purify_Pass_2(Fetch_Expression());
Import_Registers();
- if (Result == NIL)
+ if (Result == SHARP_F)
{
/* 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. */
- RESULT_OF_PURIFY (NIL);
+ RESULT_OF_PURIFY (SHARP_F);
EXIT_CRITICAL_SECTION ({ Export_Registers(); });
break;
}
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
- if (GC_Daemon_Proc == NIL)
+ if (GC_Daemon_Proc == SHARP_F)
{
RESULT_OF_PURIFY (SHARP_T);
EXIT_CRITICAL_SECTION ({ Export_Registers(); });
break;
}
RENAME_CRITICAL_SECTION( "purify daemon 2");
- Store_Expression(NIL);
+ Store_Expression(SHARP_F);
Store_Return(RC_PURIFY_GC_2);
Save_Cont();
Will_Push(2);
break;
case RC_REPEAT_DISPATCH:
- Sign_Extend(Fetch_Expression(), Which_Way);
+ Which_Way = (FIXNUM_TO_LONG (Fetch_Expression ()));
Restore_Env();
Val = Pop();
Restore_Cont();
case RC_RESTORE_DONT_COPY_HISTORY:
{
- Pointer Stacklet;
+ SCHEME_OBJECT Stacklet;
- Prev_Restore_History_Offset = Get_Integer(Pop());
+ Prev_Restore_History_Offset = OBJECT_DATUM (Pop());
Stacklet = Pop();
- History = Get_Pointer(Fetch_Expression());
+ History = OBJECT_ADDRESS (Fetch_Expression());
if (Prev_Restore_History_Offset == 0)
{
Prev_Restore_History_Stacklet = NULL;
}
- else if (Stacklet == NIL)
+ else if (Stacklet == SHARP_F)
{
Prev_Restore_History_Stacklet = NULL;
}
else
{
- Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ Prev_Restore_History_Stacklet = OBJECT_ADDRESS (Stacklet);
}
break;
}
case RC_RESTORE_HISTORY:
{
- Pointer Stacklet;
+ SCHEME_OBJECT Stacklet;
Export_Registers();
if (! Restore_History(Fetch_Expression()))
Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1));
}
Import_Registers();
- Prev_Restore_History_Offset = Get_Integer(Pop());
+ Prev_Restore_History_Offset = OBJECT_DATUM (Pop());
Stacklet = Pop();
if (Prev_Restore_History_Offset == 0)
Prev_Restore_History_Stacklet = NULL;
else
- { if (Stacklet == NIL)
+ { if (Stacklet == SHARP_F)
{ Prev_Restore_History_Stacklet = NULL;
Get_End_Of_Stacklet()[-Prev_Restore_History_Offset] =
- Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
+ MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_HISTORY);
}
else
- { Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ { Prev_Restore_History_Stacklet = OBJECT_ADDRESS (Stacklet);
Prev_Restore_History_Stacklet[-Prev_Restore_History_Offset] =
- Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
+ MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_HISTORY);
}
}
break;
case RC_RESTORE_FLUIDS:
Fluid_Bindings = Fetch_Expression();
- /* Why is this here? -- Jinx */
+ /* Why is this here? -- Jinx */
COMPILER_SETUP_INTERRUPT();
break;
- case RC_RESTORE_INT_MASK:
- SET_INTERRUPT_MASK(Get_Integer(Fetch_Expression()));
+ case RC_RESTORE_INT_MASK:
+ SET_INTERRUPT_MASK (UNSIGNED_FIXNUM_TO_LONG (Fetch_Expression()));
break;
/* Interpret() continues on the next page */
/* Interpret(), continued */
case RC_RESTORE_TO_STATE_POINT:
- { Pointer Where_To_Go = Fetch_Expression();
+ { SCHEME_OBJECT Where_To_Go = Fetch_Expression();
Will_Push(CONTINUATION_SIZE);
/* Restore the contents of Val after moving to point */
Store_Expression(Val);
/* Interpret(), continued */
case RC_SNAP_NEED_THUNK:
- Vector_Set(Fetch_Expression(), THUNK_SNAPPED, SHARP_T);
- Vector_Set(Fetch_Expression(), THUNK_VALUE, Val);
+ MEMORY_SET (Fetch_Expression(), THUNK_SNAPPED, SHARP_T);
+ MEMORY_SET (Fetch_Expression(), THUNK_VALUE, Val);
break;
case RC_AFTER_MEMORY_UPDATE:
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.32 1989/09/20 23:09:41 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.31 1989/03/27 23:15:28 jinx Rel $
- *
- * Macros used by the interpreter and some utilities.
- *
- */
+/* Macros used by the interpreter and some utilities. */
\f
/********************/
/* OPEN CODED RACKS */
#define Will_Push(N) \
{ \
- Pointer *Will_Push_Limit; \
+ SCHEME_OBJECT *Will_Push_Limit; \
\
Internal_Will_Push((N)); \
Will_Push_Limit = Simulate_Pushing(N)
#define Store_Expression(P) Expression = (P)
#define Store_Env(P) Env = (P)
#define Store_Return(P) \
- Return = Make_Non_Pointer(TC_RETURN_CODE, (P))
+ Return = MAKE_OBJECT (TC_RETURN_CODE, (P))
#define Save_Env() Push(Env)
#define Restore_Env() Env = Pop()
Print_Return(RESTORE_CONT_RETURN_MESSAGE); \
Print_Expression(Fetch_Expression(), \
RESTORE_CONT_EXPR_MESSAGE); \
- CRLF(); \
+ printf ("\n"); \
} \
}
Print_Return(CONT_PRINT_RETURN_MESSAGE); \
Print_Expression(Fetch_Expression(), \
CONT_PRINT_EXPR_MESSAGE); \
- CRLF(); \
+ printf ("\n"); \
} \
}
*/
#define PRIMITIVE_TABLE_INDEX(primitive) \
-((primitive) & HALF_ADDRESS_MASK)
+((primitive) & HALF_DATUM_MASK)
#define PRIMITIVE_VIRTUAL_INDEX(primitive) \
-(((primitive) >> HALF_ADDRESS_LENGTH) & HALF_ADDRESS_MASK)
+(((primitive) >> HALF_DATUM_LENGTH) & HALF_DATUM_MASK)
#define MAKE_PRIMITIVE_OBJECT(virtual, real) \
-(Make_Non_Pointer(TC_PRIMITIVE, (((virtual) << HALF_ADDRESS_LENGTH) | (real))))
+(MAKE_OBJECT (TC_PRIMITIVE, (((virtual) << HALF_DATUM_LENGTH) | (real))))
/* Does this fail for the first unimplemented primitive if there are no
implemented primitives?
#define INTERNAL_APPLY_PRIMITIVE(loc, primitive) \
{ \
Regs[REGBLOCK_PRIMITIVE] = primitive; \
- loc = ((*(Primitive_Procedure_Table[PRIMITIVE_TABLE_INDEX(primitive)]))()); \
- Regs[REGBLOCK_PRIMITIVE] = NIL; \
+ loc = \
+ ((* \
+ (Primitive_Procedure_Table \
+ [PRIMITIVE_TABLE_INDEX (primitive)])) \
+ ()); \
+ Regs[REGBLOCK_PRIMITIVE] = SHARP_F; \
}
/* This is only valid for implemented primitives. */
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intrpt.h,v 1.7 1989/09/20 23:09:45 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intrpt.h,v 1.6 1989/07/05 21:36:36 cph Rel $
- *
- * Interrupt manipulation utilities.
- */
+/* Interrupt manipulation utilities. */
\f
/* Interrupt bits -- scanned from LSB (1) to MSB (16) */
#define COMPILER_SETUP_INTERRUPT() \
{ \
- Regs[REGBLOCK_MEMTOP] = ((INTERRUPT_PENDING_P(INT_Mask)) ? \
- ((Pointer) -1) : \
- ((Pointer) MemTop)); \
+ (Regs [REGBLOCK_MEMTOP]) = \
+ ((INTERRUPT_PENDING_P (INT_Mask)) \
+ ? ((SCHEME_OBJECT) -1) \
+ : ((SCHEME_OBJECT) MemTop)); \
}
#define FETCH_INTERRUPT_MASK() (IntEnb)
#define WITHIN_CRITICAL_SECTION_P() \
(critical_section_name != ((char *) NULL))
-
+
#define CRITICAL_SECTION_NAME() \
(critical_section_name)
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/list.c,v 9.28 1989/09/20 23:09:49 cph Rel $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/list.c,v 9.27 1989/08/28 18:28:59 cph Exp $
- *
- * List creation and manipulation primitives.
- */
+/* List creation and manipulation primitives. */
#include "scheme.h"
#include "prims.h"
\f
-Pointer
+DEFINE_PRIMITIVE ("PAIR?", Prim_pair, 1, 1, 0)
+{
+ fast SCHEME_OBJECT object;
+ PRIMITIVE_HEADER (1);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PAIR_P (object)));
+}
+
+SCHEME_OBJECT
cons (car, cdr)
- Pointer car;
- Pointer cdr;
+ SCHEME_OBJECT car;
+ SCHEME_OBJECT cdr;
{
- Pointer result = (Make_Pointer (TC_LIST, Free));
Primitive_GC_If_Needed (2);
(*Free++) = car;
(*Free++) = cdr;
- return (result);
+ return (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2)));
}
DEFINE_PRIMITIVE ("CONS", Prim_cons, 2, 2, 0)
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN (cons ((ARG_REF (1)), (ARG_REF (2))));
}
-
+
DEFINE_PRIMITIVE ("CAR", Prim_car, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, PAIR_P);
- PRIMITIVE_RETURN (Vector_Ref ((ARG_REF (1)), CONS_CAR));
+ PRIMITIVE_RETURN (PAIR_CAR (ARG_REF (1)));
}
DEFINE_PRIMITIVE ("CDR", Prim_cdr, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, PAIR_P);
- PRIMITIVE_RETURN (Vector_Ref ((ARG_REF (1)), CONS_CDR));
+ PRIMITIVE_RETURN (PAIR_CDR (ARG_REF (1)));
+}
+
+DEFINE_PRIMITIVE ("SET-CAR!", Prim_set_car, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, PAIR_P);
+ {
+ fast SCHEME_OBJECT pair = (ARG_REF (1));
+ fast SCHEME_OBJECT car = (ARG_REF (2));
+ SIDE_EFFECT_IMPURIFY (pair, car);
+ SET_PAIR_CAR (pair, car);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("SET-CDR!", Prim_set_cdr, 2, 2, 0)
+{
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, PAIR_P);
+ {
+ fast SCHEME_OBJECT pair = (ARG_REF (1));
+ fast SCHEME_OBJECT cdr = (ARG_REF (2));
+ SIDE_EFFECT_IMPURIFY (pair, cdr);
+ SET_PAIR_CDR (pair, cdr);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
/* (GENERAL-CAR-CDR LIST DIRECTIONS)
1 = NOP 101 = CDAR
10 = CDR 110 = CADR
11 = CAR 111 = CAAR
- 100 = CDDR ...
-*/
-DEFINE_PRIMITIVE ("GENERAL-CAR-CDR", Prim_general_car_cdr, 2, 2, 0)
-{
- fast long CAR_CDR_Pattern;
- Primitive_2_Args();
+ 100 = CDDR ... */
- Arg_2_Type(TC_FIXNUM);
- CAR_CDR_Pattern = Get_Integer(Arg2);
- while (CAR_CDR_Pattern > 1)
- {
- Touch_In_Primitive(Arg1, Arg1);
- if (Type_Code(Arg1) != TC_LIST)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Arg1 =
- Vector_Ref(Arg1,
- ((CAR_CDR_Pattern & 1) == 0) ? CONS_CDR : CONS_CAR);
- CAR_CDR_Pattern >>= 1;
- }
- return Arg1;
-}
-\f
-/* (ASSQ ITEM A-LIST)
- Searches the association list A-LIST for ITEM, using EQ? for
- testing equality. Returns NIL if ITEM is not found, or the tail
- of the list whose CAAR is ITEM.
-*/
-DEFINE_PRIMITIVE ("ASSQ", Prim_assq, 2, 2, 0)
+DEFINE_PRIMITIVE ("GENERAL-CAR-CDR", Prim_general_car_cdr, 2, 2, 0)
{
- Pointer This_Assoc_Pair, Key;
- Primitive_2_Args();
-
- Touch_In_Primitive(Arg1, Arg1);
- Touch_In_Primitive(Arg2, Arg2);
- while (Type_Code(Arg2) == TC_LIST)
+ PRIMITIVE_HEADER (2);
{
- 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);
+ fast SCHEME_OBJECT object = (ARG_REF (1));
+ fast long CAR_CDR_Pattern = (arg_nonnegative_integer (2));
+ while (CAR_CDR_Pattern > 1)
+ {
+ TOUCH_IN_PRIMITIVE (object, object);
+ if (! (PAIR_P (object)))
+ error_wrong_type_arg (1);
+ object =
+ (((CAR_CDR_Pattern & 1) == 0)
+ ? (PAIR_CDR (object))
+ : (PAIR_CAR (object)));
+ CAR_CDR_Pattern >>= 1;
+ }
+ PRIMITIVE_RETURN (object);
}
- if (Arg2 != NIL)
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- return NIL;
}
-/* (LENGTH LIST)
- Returns the number of items in the list.
- LENGTH will loop forever if given a circular structure.
-*/
DEFINE_PRIMITIVE ("LENGTH", Prim_length, 1, 1, 0)
{
- fast long i;
- Primitive_1_Arg();
+ fast SCHEME_OBJECT list;
+ fast long i = 0;
+ PRIMITIVE_HEADER (1);
- 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 Make_Unsigned_Fixnum(i);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), list);
+ while (PAIR_P (list))
+ {
+ i += 1;
+ TOUCH_IN_PRIMITIVE ((PAIR_CDR (list)), list);
+ }
+ if (list != EMPTY_LIST)
+ error_wrong_type_arg (1);
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (i));
}
\f
-/* (MEMQ ITEM LIST)
- Searches LIST for ITEM, using EQ? as a test. Returns NIL if it
- is not found, or the sublist of LIST whose CAR is ITEM.
-*/
DEFINE_PRIMITIVE ("MEMQ", Prim_memq, 2, 2, 0)
{
- 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)
- Stores VALUE in the CAR of PAIR. Returns the previous CAR of PAIR.
-*/
-DEFINE_PRIMITIVE ("SET-CAR!", Prim_set_car, 2, 2, 0)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_LIST);
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CAR), Arg2);
+ fast SCHEME_OBJECT key;
+ fast SCHEME_OBJECT list;
+ fast SCHEME_OBJECT list_key;
+ PRIMITIVE_HEADER (2);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), key);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (2)), list);
+ while (PAIR_P (list))
+ {
+ TOUCH_IN_PRIMITIVE ((PAIR_CAR (list)), list_key);
+ if (list_key == key)
+ PRIMITIVE_RETURN (list);
+ TOUCH_IN_PRIMITIVE ((PAIR_CDR (list)), list);
+ }
+ if (list != EMPTY_LIST)
+ error_wrong_type_arg (2);
+ PRIMITIVE_RETURN (SHARP_F);
}
-/* (SET-CDR! PAIR VALUE)
- Stores VALUE in the CDR of PAIR. Returns the previous CDR of PAIR.
-*/
-DEFINE_PRIMITIVE ("SET-CDR!", Prim_set_cdr, 2, 2, 0)
+DEFINE_PRIMITIVE ("ASSQ", Prim_assq, 2, 2, 0)
{
- Primitive_2_Args();
+ fast SCHEME_OBJECT key;
+ fast SCHEME_OBJECT alist;
+ fast SCHEME_OBJECT association;
+ fast SCHEME_OBJECT association_key;
+ PRIMITIVE_HEADER (2);
- Arg_1_Type(TC_LIST);
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CDR), Arg2);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), key);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (2)), alist);
+ while (PAIR_P (alist))
+ {
+ TOUCH_IN_PRIMITIVE ((PAIR_CAR (alist)), association);
+ if (! (PAIR_P (association)))
+ error_wrong_type_arg (2);
+ TOUCH_IN_PRIMITIVE ((PAIR_CAR (association)), association_key);
+ if (association_key == key)
+ PRIMITIVE_RETURN (association);
+ TOUCH_IN_PRIMITIVE ((PAIR_CDR (alist)), alist);
+ }
+ if (alist != EMPTY_LIST)
+ error_wrong_type_arg (2);
+ PRIMITIVE_RETURN (SHARP_F);
}
\f
-/* (PAIR? OBJECT)
- Returns #!TRUE if OBJECT has the type-code LIST (ie if it was
- created by CONS). Returns NIL otherwise.
-*/
-DEFINE_PRIMITIVE ("PAIR?", Prim_pair, 1, 1, 0)
+DEFINE_PRIMITIVE ("SYSTEM-PAIR?", Prim_sys_pair, 1, 1, 0)
{
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1, Arg1);
- if (Type_Code(Arg1) == TC_LIST)
- return SHARP_T;
- else
- return NIL;
+ fast SCHEME_OBJECT object;
+ PRIMITIVE_HEADER (1);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (GC_PAIR_P (object)));
}
-/* (SYSTEM-PAIR? OBJECT)
- Returns #!TRUE if the garbage collector type of OBJECT is PAIR.
-*/
-DEFINE_PRIMITIVE ("SYSTEM-PAIR?", Prim_sys_pair, 1, 1, 0)
+SCHEME_OBJECT
+system_pair_cons (type, car, cdr)
+ long type;
+ SCHEME_OBJECT car;
+ SCHEME_OBJECT cdr;
{
- Primitive_1_Arg();
+ Primitive_GC_If_Needed (2);
+ (*Free++) = car;
+ (*Free++) = cdr;
+ return (MAKE_POINTER_OBJECT (type, (Free - 2)));
+}
- Touch_In_Primitive(Arg1, Arg1);
- if (GC_Type_List(Arg1))
- return SHARP_T;
- else
- return NIL;
+DEFINE_PRIMITIVE ("SYSTEM-PAIR-CONS", Prim_sys_pair_cons, 3, 3, 0)
+{
+ PRIMITIVE_HEADER (3);
+ {
+ long type = (arg_index_integer (1, (MAX_TYPE_CODE + 1)));
+ if ((GC_Type_Code (type)) != GC_Pair)
+ error_bad_range_arg (1);
+ PRIMITIVE_RETURN (system_pair_cons (type, (ARG_REF (2)), (ARG_REF (3))));
+ }
}
-\f
-/* (SYSTEM-PAIR-CAR GC-PAIR)
- Same as CAR, but for anything of GC type PAIR.
-*/
+
DEFINE_PRIMITIVE ("SYSTEM-PAIR-CAR", Prim_sys_pair_car, 1, 1, 0)
{
- Primitive_1_Arg();
-
- Arg_1_GC_Type(GC_Pair);
- return Vector_Ref(Arg1, CONS_CAR);
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, GC_PAIR_P);
+ PRIMITIVE_RETURN (PAIR_CAR (ARG_REF (1)));
}
-/* (SYSTEM-PAIR-CDR GC-PAIR)
- Same as CDR, but for anything of GC type PAIR.
-*/
DEFINE_PRIMITIVE ("SYSTEM-PAIR-CDR", Prim_sys_pair_cdr, 1, 1, 0)
{
- Primitive_1_Arg();
-
- Arg_1_GC_Type(GC_Pair);
- return Vector_Ref(Arg1, CONS_CDR);
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, GC_PAIR_P);
+ PRIMITIVE_RETURN (PAIR_CDR (ARG_REF (1)));
}
-/* (SYSTEM-PAIR-CONS TYPE-CODE OBJECT-1 OBJECT-2)
- Like CONS, but returns an object with the specified type code
- (not limited to type code LIST).
-*/
-DEFINE_PRIMITIVE ("SYSTEM-PAIR-CONS", Prim_sys_pair_cons, 3, 3, 0)
+DEFINE_PRIMITIVE ("SYSTEM-PAIR-SET-CAR!", Prim_sys_set_car, 2, 2, 0)
{
- long Type;
- Primitive_3_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_Pair)
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, GC_PAIR_P);
{
- Primitive_GC_If_Needed(2);
- *Free++ = Arg2;
- *Free++ = Arg3;
- return Make_Pointer(Type, Free-2);
+ fast SCHEME_OBJECT pair = (ARG_REF (1));
+ fast SCHEME_OBJECT car = (ARG_REF (2));
+ SIDE_EFFECT_IMPURIFY (pair, car);
+ SET_PAIR_CAR (pair, car);
}
- else
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- /*NOTREACHED*/
-}
-
-\f
-/* (SYSTEM-PAIR-SET-CAR! GC-PAIR NEW_CAR)
- Same as SET-CAR!, but for anything of GC type PAIR.
-*/
-DEFINE_PRIMITIVE ("SYSTEM-PAIR-SET-CAR!", Prim_sys_set_car, 2, 2, 0)
-{
- Primitive_2_Args();
-
- Arg_1_GC_Type(GC_Pair);
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CAR), Arg2);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-/* (SYSTEM-PAIR-SET-CDR! GC-PAIR NEW_CDR)
- Same as SET-CDR!, but for anything of GC type PAIR.
-*/
DEFINE_PRIMITIVE ("SYSTEM-PAIR-SET-CDR!", Prim_sys_set_cdr, 2, 2, 0)
{
- Primitive_2_Args();
-
- Arg_1_GC_Type(GC_Pair);
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CDR), Arg2);
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (1, GC_PAIR_P);
+ {
+ fast SCHEME_OBJECT pair = (ARG_REF (1));
+ fast SCHEME_OBJECT cdr = (ARG_REF (2));
+ SIDE_EFFECT_IMPURIFY (pair, cdr);
+ SET_PAIR_CDR (pair, cdr);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/load.c,v 9.28 1989/09/20 23:09:52 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/load.c,v 9.27 1988/08/15 20:50:59 cph Rel $
- *
- * This file contains common code for reading internal
- * format binary files.
- *
- */
+/* This file contains common code for reading internal
+ format binary files. */
\f
#include "fasl.h"
#define FASL_FILE_NOT_FASL 2
#define FASL_FILE_BAD_MACHINE 3
#define FASL_FILE_BAD_VERSION 4
-#define FASL_FILE_BAD_SUBVERSION 5
+#define FASL_FILE_BAD_SUBVERSION 5
#define FASL_FILE_BAD_PROCESSOR 6
#define FASL_FILE_BAD_INTERFACE 7
Primitive_Table_Size, Primitive_Table_Length,
dumped_processor_type, dumped_interface_version;
-static Pointer
+static SCHEME_OBJECT
Ext_Prim_Vector,
dumped_utilities;
\f
printf("Stack Top = 0x%lx\n", Dumped_Stack_Top);
printf("\nDumped Objects:\n\n");
- printf("Dumped object at 0x%lx (as read from file)\n", Dumped_Object);
+ printf("Dumped object at 0x%lx (as read from file)\n", Dumped_Object);
printf("Compiled code utilities vector = 0x%lx\n", dumped_utilities);
- if (Ext_Prim_Vector != NIL)
+ if (Ext_Prim_Vector != SHARP_F)
{
printf("External primitives vector = 0x%lx\n", Ext_Prim_Vector);
}
long
Read_Header()
{
- Pointer Buffer[FASL_HEADER_LENGTH];
- Pointer Pointer_Heap_Base, Pointer_Const_Base;
+ SCHEME_OBJECT Buffer[FASL_HEADER_LENGTH];
+ SCHEME_OBJECT Pointer_Heap_Base, Pointer_Const_Base;
if (Load_Data(FASL_HEADER_LENGTH, ((char *) Buffer)) !=
FASL_HEADER_LENGTH)
return (FASL_FILE_NOT_FASL);
}
NORMALIZE_HEADER(Buffer,
- (sizeof(Buffer) / sizeof(Pointer)),
+ (sizeof(Buffer) / sizeof(SCHEME_OBJECT)),
Buffer[FASL_Offset_Heap_Base],
Buffer[FASL_Offset_Heap_Count]);
- Heap_Count = Get_Integer(Buffer[FASL_Offset_Heap_Count]);
+ Heap_Count = OBJECT_DATUM (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]);
+ Heap_Base = OBJECT_DATUM (Pointer_Heap_Base);
+ Dumped_Object = OBJECT_DATUM (Buffer[FASL_Offset_Dumped_Obj]);
+ Const_Count = OBJECT_DATUM (Buffer[FASL_Offset_Const_Count]);
Pointer_Const_Base = Buffer[FASL_Offset_Const_Base];
- Const_Base = Datum(Pointer_Const_Base);
+ Const_Base = OBJECT_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_Stack_Top = OBJECT_DATUM (Buffer[FASL_Offset_Stack_Top]);
Dumped_Heap_Top =
- C_To_Scheme(Nth_Vector_Loc(Pointer_Heap_Base, Heap_Count));
+ ADDRESS_TO_DATUM (MEMORY_LOC (Pointer_Heap_Base, Heap_Count));
Dumped_Constant_Top =
- C_To_Scheme(Nth_Vector_Loc(Pointer_Const_Base, Const_Count));
+ ADDRESS_TO_DATUM (MEMORY_LOC (Pointer_Const_Base, Const_Count));
\f
if (Sub_Version < FASL_MERGED_PRIMITIVES)
{
Primitive_Table_Length = 0;
Primitive_Table_Size = 0;
Ext_Prim_Vector =
- Make_Non_Pointer(TC_CELL, Datum(Buffer[FASL_Offset_Ext_Loc]));
+ (OBJECT_NEW_TYPE (TC_CELL, (Buffer [FASL_Offset_Ext_Loc])));
}
else
{
- Primitive_Table_Length = Get_Integer(Buffer[FASL_Offset_Prim_Length]);
- Primitive_Table_Size = Get_Integer(Buffer[FASL_Offset_Prim_Size]);
- Ext_Prim_Vector = NIL;
+ Primitive_Table_Length = OBJECT_DATUM (Buffer[FASL_Offset_Prim_Length]);
+ Primitive_Table_Size = OBJECT_DATUM (Buffer[FASL_Offset_Prim_Size]);
+ Ext_Prim_Vector = SHARP_F;
}
if (Sub_Version < FASL_INTERFACE_VERSION)
band_p = false;
dumped_processor_type = 0;
dumped_interface_version = 0;
- dumped_utilities = NIL;
+ dumped_utilities = SHARP_F;
}
else
{
- Pointer temp;
+ SCHEME_OBJECT temp;
temp = Buffer[FASL_Offset_Ci_Version];
if ((Test1 & 0xff) == TC_BROKEN_HEART &&
(Test2 & 0xff) == TC_BROKEN_HEART &&
- (Type_Code(Test1) != TC_BROKEN_HEART ||
- Type_Code(Test2) != TC_BROKEN_HEART))
+ (OBJECT_TYPE (Test1) != TC_BROKEN_HEART ||
+ OBJECT_TYPE (Test2) != TC_BROKEN_HEART))
{
Byte_Invert_Fasl_Files = true;
Byte_Invert_Region(Header, Headsize);
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/locks.h,v 9.24 1989/09/20 23:09:56 cph Rel $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/locks.h,v 9.23 1988/09/29 04:59:13 jinx Rel $
-
- Contains everything needed to lock and unlock parts of
- the heap, pure/constant space and the like.
- It also contains intercommunication stuff as well.
-*/
+/* Contains everything needed to lock and unlock parts of
+ the heap, pure/constant space and the like.
+ It also contains intercommunication stuff as well. */
typedef long *Lock_Handle; /* Address of lock word */
#define CONTENTION_DELAY 10 /* For "slow" locks, back off */
/* -*-C-*-
-Copyright (c) 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/lookprm.c,v 1.4 1989/09/20 23:09:59 cph Rel $
+
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/lookprm.c,v 1.3 1988/09/29 04:59:28 jinx Rel $
- *
- * This file contains environment manipulation primitives.
- * It makes heavy use of procedures in lookup.c
- */
+/* This file contains environment manipulation primitives.
+ It makes heavy use of procedures in lookup.c */
#include "scheme.h"
#include "locks.h"
\f
/* Utility macros */
-#define ENVIRONMENT_P(env) \
- ((OBJECT_TYPE(env) == TC_ENVIRONMENT) || \
- (OBJECT_TYPE(env) == GLOBAL_ENV))
-
#define VALID_ENVIRONMENT_P(env) \
- ((OBJECT_TYPE(env) == TC_ENVIRONMENT) || \
- ((OBJECT_TYPE(env) == GLOBAL_ENV) && \
- (OBJECT_DATUM(env) == GO_TO_GLOBAL)))
+ ((OBJECT_TYPE (env) == TC_ENVIRONMENT) || \
+ ((OBJECT_TYPE (env) == GLOBAL_ENV) && \
+ (OBJECT_DATUM (env) == GO_TO_GLOBAL)))
/* This used to be more paranoid, and check for interned symbols,
rather than normal symbols. Does it matter?
}
\f
/* (LOCAL-ASSIGNMENT ENVIRONMENT SYMBOL VALUE)
- Should be called *DEFINE.
+ Should be called LEXICAL-DEFINE.
If the variable specified by SYMBOL already exists in the
lexical ENVIRONMENT, then its value there is changed to VALUE.
the specified variable to the value. Returns SYMBOL.
Indistinguishable from evaluating
- (define <symbol> <value>) in <environment>.
-*/
+ (define <symbol> <value>) in <environment>. */
DEFINE_PRIMITIVE ("LOCAL-ASSIGNMENT", Prim_local_assignment, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
-
- standard_lookup_primitive(Local_Set(ARG_REF (1), ARG_REF (2), ARG_REF (3)));
+ standard_lookup_primitive
+ (Local_Set ((ARG_REF (1)), (ARG_REF (2)), (ARG_REF (3))));
}
/* (LEXICAL-UNASSIGNED? ENVIRONMENT SYMBOL)
- Returns #!TRUE if the variable corresponding to SYMBOL is bound
+ Returns #T if the variable corresponding to SYMBOL is bound
but has the special UNASSIGNED value in ENVIRONMENT. Returns
- NIL otherwise. Does a complete lexical search for SYMBOL
+ #F otherwise. Does a complete lexical search for SYMBOL
starting in ENVIRONMENT.
- The special form (unassigned? <symbol>) is built on top of this.
-*/
+ The special form (unassigned? <symbol>) is built on top of this. */
DEFINE_PRIMITIVE ("LEXICAL-UNASSIGNED?", Prim_unassigned_test, 2, 2, 0)
{
- extern long Symbol_Lex_unassigned_p();
+ extern long Symbol_Lex_unassigned_p ();
PRIMITIVE_HEADER (2);
-
- standard_lookup_primitive(Symbol_Lex_unassigned_p(ARG_REF (1), ARG_REF (2)));
+ standard_lookup_primitive
+ (Symbol_Lex_unassigned_p ((ARG_REF (1)), (ARG_REF (2))));
}
/* (LEXICAL-UNBOUND? ENVIRONMENT SYMBOL)
- Returns #!TRUE if the variable corresponding to SYMBOL has no
- binding in ENVIRONMENT. Returns NIL otherwise. Does a complete
+ Returns #T if the variable corresponding to SYMBOL has no
+ binding in ENVIRONMENT. Returns #F otherwise. Does a complete
lexical search for SYMBOL starting in ENVIRONMENT.
- The special form (unbound? <symbol>) is built on top of this.
-*/
+ The special form (unbound? <symbol>) is built on top of this. */
DEFINE_PRIMITIVE ("LEXICAL-UNBOUND?", Prim_unbound_test, 2, 2, 0)
{
- extern long Symbol_Lex_unbound_p();
+ extern long Symbol_Lex_unbound_p ();
PRIMITIVE_HEADER (2);
-
- standard_lookup_primitive(Symbol_Lex_unbound_p(ARG_REF (1), ARG_REF (2)));
+ standard_lookup_primitive
+ (Symbol_Lex_unbound_p ((ARG_REF (1)), (ARG_REF (2))));
}
\f
/* (LEXICAL-UNREFERENCEABLE? ENVIRONMENT SYMBOL)
switch (Result)
{
case PRIM_DONE:
- PRIMITIVE_RETURN(NIL);
+ PRIMITIVE_RETURN (SHARP_F);
case PRIM_INTERRUPT:
signal_interrupt_from_primitive();
/*NOTREACHED*/
}
\f
-Pointer
+SCHEME_OBJECT
extract_or_create_cache(frame, sym)
- Pointer frame, sym;
+ SCHEME_OBJECT frame, sym;
{
- extern Pointer compiler_cache_variable[];
+ extern SCHEME_OBJECT compiler_cache_variable[];
extern long compiler_cache();
- Pointer *cell, value;
+ SCHEME_OBJECT *cell, value;
long trap_kind, result;
cell = deep_lookup(frame, sym, compiler_cache_variable);
- value = Fetch(cell[0]);
+ value = MEMORY_FETCH (cell[0]);
if (REFERENCE_TRAP_P(value))
{
get_trap_kind(trap_kind, value);
case TRAP_COMPILER_CACHED:
case TRAP_COMPILER_CACHED_DANGEROUS:
- return (Fast_Vector_Ref(value, TRAP_EXTRA));
+ return (FAST_MEMORY_REF (value, TRAP_EXTRA));
/* This should list the traps explicitely */
default:
break;
}
}
- result = compiler_cache(cell, frame, sym, NIL, 0,
+ result = compiler_cache(cell, frame, sym, SHARP_F, 0,
TRAP_REFERENCES_LOOKUP, true);
if (result != PRIM_DONE)
{
else
signal_error_from_primitive(result);
}
- value = Fetch(cell[0]);
- return (Fast_Vector_Ref(value, TRAP_EXTRA));
+ value = MEMORY_FETCH (cell[0]);
+ return (FAST_MEMORY_REF (value, TRAP_EXTRA));
}
void
error_bad_environment(arg)
long arg;
{
- if (OBJECT_TYPE(ARG_REF(arg)) == GLOBAL_ENV)
+ if (OBJECT_TYPE (ARG_REF(arg)) == GLOBAL_ENV)
error_bad_range_arg(arg);
else
error_wrong_type_arg(arg);
DEFINE_PRIMITIVE ("ENVIRONMENT-LINK-NAME", Prim_environment_link_name, 3, 3, 0)
{
- extern Pointer *scan_frame();
+ extern SCHEME_OBJECT *scan_frame();
- Pointer target, source, sym;
- Pointer cache, *cell, *value_cell;
+ SCHEME_OBJECT target, source, sym;
+ SCHEME_OBJECT cache, *cell, *value_cell;
PRIMITIVE_HEADER (3);
target = ARG_REF (1);
if (!VALID_ENVIRONMENT_P(source))
error_bad_environment(2);
-
+
if (!VALID_ENVIRONMENT_P(target))
error_bad_environment(1);
cache = extract_or_create_cache(source, sym);
\f
- if (OBJECT_TYPE(target) == GLOBAL_ENV)
+ if (OBJECT_TYPE (target) == GLOBAL_ENV)
{
long trap_kind;
- Pointer value;
+ SCHEME_OBJECT value;
- cell = Nth_Vector_Loc(sym, SYMBOL_GLOBAL_VALUE);
- value = Fetch(cell[0]);
+ cell = MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE);
+ value = MEMORY_FETCH (cell[0]);
if (!REFERENCE_TRAP_P(value))
/* The variable is bound! */
case TRAP_UNBOUND_DANGEROUS:
{
/* Allocate new trap object. */
- fast Pointer *trap;
+ fast SCHEME_OBJECT *trap;
Primitive_GC_If_Needed(2);
trap = Free;
Free += 2;
- trap[0] = MAKE_UNSIGNED_FIXNUM((trap_kind == TRAP_UNBOUND) ?
+ trap[0] = LONG_TO_UNSIGNED_FIXNUM((trap_kind == TRAP_UNBOUND) ?
TRAP_COMPILER_CACHED :
TRAP_COMPILER_CACHED_DANGEROUS);
trap[1] = cache;
- Store(cell[0], Make_Pointer(TC_REFERENCE_TRAP, trap));
+ MEMORY_STORE (cell[0], MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, trap));
PRIMITIVE_RETURN(SHARP_T);
}
-\f
+\f
case TRAP_COMPILER_CACHED:
case TRAP_COMPILER_CACHED_DANGEROUS:
{
- if (Vector_Ref(Vector_Ref(value, TRAP_EXTRA), TRAP_EXTENSION_CELL) !=
+ if (MEMORY_REF (MEMORY_REF (value, TRAP_EXTRA), TRAP_EXTENSION_CELL) !=
UNBOUND_OBJECT)
{
/* It is bound */
signal_error_from_primitive(ERR_BAD_SET);
}
lookup_primitive_action(compiler_uncache(cell, sym));
- value_cell = Nth_Vector_Loc(cache, TRAP_EXTENSION_CELL);
+ value_cell = MEMORY_LOC (cache, TRAP_EXTENSION_CELL);
lookup_primitive_action
(compiler_recache(shadowed_value_cell, value_cell, target,
- sym, Fetch(value_cell[0]), false, true));
- Vector_Set(value, TRAP_EXTRA, cache);
+ sym, MEMORY_FETCH (value_cell[0]), false, true));
+ MEMORY_SET (value, TRAP_EXTRA, cache);
PRIMITIVE_RETURN(SHARP_T);
}
\f
else
{
- Pointer *trap;
+ SCHEME_OBJECT *trap;
cell = scan_frame(target, sym, fake_variable_object, 0, true);
/* Is it bound? */
- if ((cell != ((Pointer *) NULL)) &&
- (Fetch(cell[0]) != DANGEROUS_UNBOUND_OBJECT))
+ if ((cell != ((SCHEME_OBJECT *) NULL)) &&
+ (MEMORY_FETCH (cell[0]) != DANGEROUS_UNBOUND_OBJECT))
{
signal_error_from_primitive(ERR_BAD_SET);
}
Free += 2;
trap[1] = cache;
- lookup_primitive_action(extend_frame(target, sym, NIL, target, false));
+ lookup_primitive_action(extend_frame(target, sym, SHARP_F, target, false));
- if (cell == ((Pointer *) NULL))
+ if (cell == ((SCHEME_OBJECT *) NULL))
{
- trap[0] = MAKE_UNSIGNED_FIXNUM(TRAP_COMPILER_CACHED);
+ trap[0] = LONG_TO_UNSIGNED_FIXNUM(TRAP_COMPILER_CACHED);
cell = scan_frame(target, sym, fake_variable_object, 0, true);
- if (cell == ((Pointer *) NULL))
+ if (cell == ((SCHEME_OBJECT *) NULL))
signal_error_from_primitive(ERR_BAD_FRAME);
}
else
{
- trap[0] = MAKE_UNSIGNED_FIXNUM(TRAP_COMPILER_CACHED_DANGEROUS);
+ trap[0] = LONG_TO_UNSIGNED_FIXNUM(TRAP_COMPILER_CACHED_DANGEROUS);
}
- if (Fetch(cell[0]) != DANGEROUS_UNBOUND_OBJECT)
+ if (MEMORY_FETCH (cell[0]) != DANGEROUS_UNBOUND_OBJECT)
signal_error_from_primitive(ERR_BAD_FRAME);
- value_cell = Nth_Vector_Loc(cache, TRAP_EXTENSION_CELL);
+ value_cell = MEMORY_LOC (cache, TRAP_EXTENSION_CELL);
lookup_primitive_action
(compiler_recache(shadowed_value_cell, value_cell, target,
- sym, Fetch(value_cell[0]), false, true));
- Store(cell[0], Make_Pointer(TC_REFERENCE_TRAP, trap));
+ sym, MEMORY_FETCH (value_cell[0]), false, true));
+ MEMORY_STORE (cell[0], MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, trap));
PRIMITIVE_RETURN(SHARP_T);
}
}
/* -*-C-*-
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/lookup.c,v 9.41 1988/09/29 04:59:45 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/lookup.c,v 9.42 1989/09/20 23:10:03 cph Exp $
*
* This file contains symbol lookup and modification routines. See
* Hal Abelson for a paper describing and justifying the algorithm.
/* Useful constants. */
/* This is returned by various procedures to cause a Scheme
- unbound variable error to be signalled.
+ unbound variable error to be signalled.
*/
-Pointer unbound_trap_object[] = { UNBOUND_OBJECT };
+SCHEME_OBJECT unbound_trap_object[] = { UNBOUND_OBJECT };
/* This is returned by lookup to force a deep lookup when the variable
needs to be recompiled.
*/
-Pointer uncompiled_trap_object[] = { DANGEROUS_UNBOUND_OBJECT };
+SCHEME_OBJECT uncompiled_trap_object[] = { DANGEROUS_UNBOUND_OBJECT };
/* This is returned by lookup to cause a Scheme broken compiled
variable error to be signalled.
*/
-Pointer illegal_trap_object[] = { ILLEGAL_OBJECT };
+SCHEME_OBJECT illegal_trap_object[] = { ILLEGAL_OBJECT };
/* This is passed to deep_lookup as the variable to compile when
we don't really have a variable.
*/
-Pointer fake_variable_object[3];
+SCHEME_OBJECT fake_variable_object[3];
\f
/* scan_frame searches a frame for a given name.
If it finds the names, it stores into hunk the path by which it was
cell if the variable was not found in this frame.
*/
-extern Pointer *scan_frame();
+extern SCHEME_OBJECT *scan_frame();
-Pointer *
+SCHEME_OBJECT *
scan_frame(frame, sym, hunk, depth, unbound_valid_p)
- Pointer frame, sym, *hunk;
+ SCHEME_OBJECT frame, sym, *hunk;
long depth;
Boolean unbound_valid_p;
{
Lock_Handle compile_serializer;
- fast Pointer *scan, temp;
+ fast SCHEME_OBJECT *scan, temp;
fast long count;
- temp = Vector_Ref(frame, ENVIRONMENT_FUNCTION);
+ temp = MEMORY_REF (frame, ENVIRONMENT_FUNCTION);
- if (OBJECT_TYPE(temp) == AUX_LIST_TYPE)
+ if (OBJECT_TYPE (temp) == AUX_LIST_TYPE)
{
/* Search for an auxiliary binding. */
- Pointer *start;
+ SCHEME_OBJECT *start;
- scan = Get_Pointer(temp);
+ scan = OBJECT_ADDRESS (temp);
start = scan;
count = Lexical_Offset(scan[AUX_LIST_COUNT]);
scan += AUX_LIST_FIRST;
while (--count >= 0)
{
- if (Fast_Vector_Ref(*scan, CONS_CAR) == sym)
+ if (FAST_PAIR_CAR (*scan) == sym)
{
- Pointer *cell;
+ SCHEME_OBJECT *cell;
- cell = Nth_Vector_Loc(*scan, CONS_CDR);
- if (Fetch(cell[0]) == DANGEROUS_UNBOUND_OBJECT)
+ cell = PAIR_CDR_LOC (*scan);
+ if (MEMORY_FETCH (cell[0]) == DANGEROUS_UNBOUND_OBJECT)
{
/* A dangerous unbound object signals that
a definition here must become dangerous,
but is not a real bining.
*/
- return (unbound_valid_p ? (cell) : ((Pointer *) NULL));
+ return (unbound_valid_p ? (cell) : ((SCHEME_OBJECT *) NULL));
}
setup_lock(compile_serializer, hunk);
- hunk[VARIABLE_COMPILED_TYPE] = Make_Non_Pointer(AUX_REF, depth);
+ hunk[VARIABLE_COMPILED_TYPE] = MAKE_OBJECT (AUX_REF, depth);
hunk[VARIABLE_OFFSET] = Make_Local_Offset(scan - start);
remove_lock(compile_serializer);
return (cell);
}
- scan += 1;
+ scan += 1;
}
- temp = Vector_Ref(temp, ENV_EXTENSION_PROCEDURE);
+ temp = MEMORY_REF (temp, ENV_EXTENSION_PROCEDURE);
}
\f
/* Search for a formal parameter. */
- temp = Fast_Vector_Ref(Fast_Vector_Ref(temp, PROCEDURE_LAMBDA_EXPR),
+ temp = FAST_MEMORY_REF (FAST_MEMORY_REF (temp, PROCEDURE_LAMBDA_EXPR),
LAMBDA_FORMALS);
- for (count = Vector_Length(temp) - 1,
- scan = Nth_Vector_Loc(temp, VECTOR_DATA + 1);
+ for (count = VECTOR_LENGTH (temp) - 1,
+ scan = MEMORY_LOC (temp, VECTOR_DATA + 1);
count > 0;
count -= 1,
scan += 1)
{
fast long offset;
- offset = 1 + Vector_Length(temp) - count;
+ offset = 1 + VECTOR_LENGTH (temp) - count;
setup_lock(compile_serializer, hunk);
if (depth != 0)
{
- hunk[VARIABLE_COMPILED_TYPE] = Make_Non_Pointer(FORMAL_REF, depth);
+ hunk[VARIABLE_COMPILED_TYPE] = MAKE_OBJECT (FORMAL_REF, depth);
hunk[VARIABLE_OFFSET] = Make_Local_Offset(offset);
}
else
{
hunk[VARIABLE_COMPILED_TYPE] = Make_Local_Offset(offset);
- hunk[VARIABLE_OFFSET] = NIL;
+ hunk[VARIABLE_OFFSET] = SHARP_F;
}
remove_lock(compile_serializer);
- return (Nth_Vector_Loc(frame, offset));
+ return (MEMORY_LOC (frame, offset));
}
}
- return ((Pointer *) NULL);
+ return ((SCHEME_OBJECT *) NULL);
}
\f
/* The lexical lookup procedure.
deep_lookup searches env for an occurrence of sym. When it finds
it, it stores into hunk the path by which it was found, so that
future references do not spend the time to find it again.
- It returns a pointer to the value cell, or a bogus value cell if
+ It returns a pointer to the value cell, or a bogus value cell if
the variable was unbound.
*/
-Pointer *
+SCHEME_OBJECT *
deep_lookup(env, sym, hunk)
- Pointer env, sym, *hunk;
+ SCHEME_OBJECT env, sym, *hunk;
{
Lock_Handle compile_serializer;
- fast Pointer frame;
+ fast SCHEME_OBJECT frame;
fast long depth;
for (depth = 0, frame = env;
- OBJECT_TYPE(frame) != GLOBAL_ENV;
+ OBJECT_TYPE (frame) != GLOBAL_ENV;
depth += 1,
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION),
+ frame = FAST_MEMORY_REF (MEMORY_REF (frame, ENVIRONMENT_FUNCTION),
PROCEDURE_ENVIRONMENT))
{
- fast Pointer *cell;
+ fast SCHEME_OBJECT *cell;
cell = scan_frame(frame, sym, hunk, depth, false);
- if (cell != ((Pointer *) NULL))
+ if (cell != ((SCHEME_OBJECT *) NULL))
{
return (cell);
}
/* The reference is global. */
- if (OBJECT_DATUM(frame) != GO_TO_GLOBAL)
+ if (OBJECT_DATUM (frame) != GO_TO_GLOBAL)
{
return (unbound_trap_object);
}
setup_lock(compile_serializer, hunk);
- hunk[VARIABLE_COMPILED_TYPE] = Make_New_Pointer(TC_UNINTERNED_SYMBOL, sym);
- hunk[VARIABLE_OFFSET] = NIL;
+ hunk[VARIABLE_COMPILED_TYPE] = (OBJECT_NEW_TYPE (TC_UNINTERNED_SYMBOL, sym));
+ hunk[VARIABLE_OFFSET] = SHARP_F;
remove_lock(compile_serializer);
- return (Nth_Vector_Loc(sym, SYMBOL_GLOBAL_VALUE));
+ return (MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE));
}
\f
/* Shallow lookup performed "out of line" by various procedures.
It takes care of invoking deep_lookup when necessary.
*/
-extern Pointer *lookup_cell();
+extern SCHEME_OBJECT *lookup_cell();
-Pointer *
+SCHEME_OBJECT *
lookup_cell(hunk, env)
- Pointer *hunk, env;
+ SCHEME_OBJECT *hunk, env;
{
- Pointer *cell, value;
+ SCHEME_OBJECT *cell, value;
long trap_kind;
lookup(cell, env, hunk, repeat_lookup_cell);
- value = Fetch(cell[0]);
+ value = MEMORY_FETCH (cell[0]);
- if (OBJECT_TYPE(value) != TC_REFERENCE_TRAP)
+ if (OBJECT_TYPE (value) != TC_REFERENCE_TRAP)
{
return (cell);
}
long
deep_lookup_end(cell, hunk)
- Pointer *cell;
- Pointer *hunk;
+ SCHEME_OBJECT *cell;
+ SCHEME_OBJECT *hunk;
{
long trap_kind, return_value;
Boolean repeat_p;
do {
repeat_p = false;
- Val = Fetch(cell[0]);
- FUTURE_VARIABLE_SPLICE (((Pointer) cell), 0, Val);
+ Val = MEMORY_FETCH (cell[0]);
+ FUTURE_VARIABLE_SPLICE (((SCHEME_OBJECT) cell), 0, Val);
if (!(REFERENCE_TRAP_P(Val)))
{
return (PRIM_DONE);
\f
case TRAP_DANGEROUS:
{
- Pointer trap_value;
+ SCHEME_OBJECT trap_value;
trap_value = Val;
- Val = (Vector_Ref (trap_value, TRAP_EXTRA));
+ Val = (MEMORY_REF (trap_value, TRAP_EXTRA));
FUTURE_VARIABLE_SPLICE (trap_value, TRAP_EXTRA, Val);
return_value = PRIM_DONE;
break;
case TRAP_COMPILER_CACHED:
case TRAP_COMPILER_CACHED_DANGEROUS:
- cell = Nth_Vector_Loc(Vector_Ref(Val, TRAP_EXTRA),
- TRAP_EXTENSION_CELL);
+ cell = MEMORY_LOC (MEMORY_REF (Val, TRAP_EXTRA), TRAP_EXTENSION_CELL);
repeat_p = true;
if (trap_kind == TRAP_COMPILER_CACHED)
continue;
setup_lock(compile_serializer, hunk);
hunk[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- hunk[VARIABLE_OFFSET] = NIL;
+ hunk[VARIABLE_OFFSET] = SHARP_F;
remove_lock(compile_serializer);
}
long
lookup_end(cell, env, hunk)
- Pointer *cell, env, *hunk;
+ SCHEME_OBJECT *cell, env, *hunk;
{
long trap_kind;
lookup_end_restart:
- Val = Fetch(cell[0]);
- FUTURE_VARIABLE_SPLICE (((Pointer) cell), 0, Val);
+ Val = MEMORY_FETCH (cell[0]);
+ FUTURE_VARIABLE_SPLICE (((SCHEME_OBJECT) cell), 0, Val);
if (!(REFERENCE_TRAP_P(Val)))
{
hunk));
case TRAP_COMPILER_CACHED:
- cell = Nth_Vector_Loc(Vector_Ref(Val, TRAP_EXTRA),
- TRAP_EXTENSION_CELL);
+ cell = MEMORY_LOC (MEMORY_REF (Val, TRAP_EXTRA), TRAP_EXTENSION_CELL);
goto lookup_end_restart;
case TRAP_FLUID:
long
deep_assignment_end(cell, hunk, value, force)
- fast Pointer *cell;
- Pointer *hunk, value;
+ fast SCHEME_OBJECT *cell;
+ SCHEME_OBJECT *hunk, value;
Boolean force;
{
Lock_Handle set_serializer;
long trap_kind, return_value;
- Pointer bogus_unassigned, extension, saved_extension, saved_value;
+ SCHEME_OBJECT bogus_unassigned, extension, saved_extension, saved_value;
Boolean repeat_p, uncompile_p, fluid_lock_p;
/* State variables */
- saved_extension = NIL;
+ saved_extension = SHARP_F;
uncompile_p = false;
fluid_lock_p = false;
\f
switch(trap_kind)
{
case TRAP_DANGEROUS:
- Val = Vector_Ref(Val, TRAP_EXTRA);
+ Val = MEMORY_REF (Val, TRAP_EXTRA);
if (value == UNASSIGNED_OBJECT)
{
*cell = DANGEROUS_UNASSIGNED_OBJECT;
}
else
{
- Do_Store_No_Lock ((Nth_Vector_Loc (*cell, TRAP_EXTRA)), value);
+ Do_Store_No_Lock ((MEMORY_LOC (*cell, TRAP_EXTRA)), value);
}
UNCOMPILE(PRIM_DONE);
UNCOMPILE(ERR_UNBOUND_VARIABLE)
}
/* Fall through */
-
+
case TRAP_UNASSIGNED:
Val = bogus_unassigned;
*cell = value;
Val = bogus_unassigned;
if (value != UNASSIGNED_OBJECT)
{
- Pointer result;
+ SCHEME_OBJECT result;
if (GC_allocate_test(2))
{
Request_GC(2);
ABORT(PRIM_INTERRUPT);
}
- result = Make_Pointer(TC_REFERENCE_TRAP, Free);
+ result = MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free);
*Free++ = DANGEROUS_OBJECT;
*Free++ = value;
*cell = result;
/* Fall through */
case TRAP_COMPILER_CACHED:
- extension = Fast_Vector_Ref(Val, TRAP_EXTRA);
+ extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
compiler_cache_assignment:
{
- Pointer references;
+ SCHEME_OBJECT references;
/* Unlock and lock at the new value cell. */
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
- cell = Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
+ cell = MEMORY_LOC (extension, TRAP_EXTENSION_CELL);
update_lock(set_serializer, cell);
- if (Fast_Vector_Ref(references, TRAP_REFERENCES_OPERATOR) != NIL)
+ if (FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR) != SHARP_F)
{
- if (saved_extension != NIL)
+ if (saved_extension != SHARP_F)
{
ABORT(ERR_BROKEN_VARIABLE_CACHE);
}
UNCOMPILE(ERR_ILLEGAL_REFERENCE_TRAP);
}
} while (repeat_p);
-\f
- if (saved_extension != NIL)
+\f
+ if (saved_extension != SHARP_F)
{
long recache_uuo_links();
*/
update_lock(set_serializer,
- Nth_Vector_Loc(saved_extension, TRAP_EXTENSION_CELL));
+ MEMORY_LOC (saved_extension, TRAP_EXTENSION_CELL));
}
/* NOTE:
recache_uuo_links can take an arbitrary amount of time since
there may be an internal lock and the code may have to uncache
arbitrarily many links.
- Deadlock should not occur since both locks are always acquired
+ Deadlock should not occur since both locks are always acquired
in the same order.
*/
setup_lock(compile_serializer, hunk);
hunk[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- hunk[VARIABLE_OFFSET] = NIL;
+ hunk[VARIABLE_OFFSET] = SHARP_F;
remove_lock(compile_serializer);
}
long
assignment_end(cell, env, hunk, value)
- fast Pointer *cell;
- Pointer env, *hunk, value;
+ fast SCHEME_OBJECT *cell;
+ SCHEME_OBJECT env, *hunk, value;
{
Lock_Handle set_serializer;
- Pointer bogus_unassigned;
+ SCHEME_OBJECT bogus_unassigned;
long temp;
bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
\f
case TRAP_COMPILER_CACHED:
{
- Pointer extension, references;
+ SCHEME_OBJECT extension, references;
- extension = Fast_Vector_Ref(Val, TRAP_EXTRA);
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
+ extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
- if (Fast_Vector_Ref(references, TRAP_REFERENCES_OPERATOR) != NIL)
+ if (FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR) != SHARP_F)
{
/* There are uuo links.
wimp out and let deep_assignment_end handle it.
remove_lock(set_serializer);
return (deep_assignment_end(cell, hunk, value, false));
}
- cell = Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL);
+ cell = MEMORY_LOC (extension, TRAP_EXTENSION_CELL);
update_lock(set_serializer, cell);
goto assignment_end_after_lock;
}
this processor's fluid "binding" list. It is just like ASSQ.
*/
-Pointer *
+SCHEME_OBJECT *
lookup_fluid(trap)
- fast Pointer trap;
+ fast SCHEME_OBJECT trap;
{
- fast Pointer fluids, *this_pair;
+ fast SCHEME_OBJECT fluids, *this_pair;
fluids = Fluid_Bindings;
while (PAIR_P(fluids))
{
- this_pair = Get_Pointer(Fast_Vector_Ref(fluids, CONS_CAR));
+ this_pair = OBJECT_ADDRESS (FAST_PAIR_CAR (fluids));
if (this_pair[CONS_CAR] == trap)
{
return (&this_pair[CONS_CDR]);
}
- fluids = Fast_Vector_Ref(fluids, CONS_CDR);
+ fluids = FAST_PAIR_CDR (fluids);
}
/* Not found in fluid binding alist, so use default. */
fprintf(stderr, "Fluid not found, using default.\n");
}
- return (Nth_Vector_Loc(trap, TRAP_EXTRA));
+ return (MEMORY_LOC (trap, TRAP_EXTRA));
}
\f
/* Utilities for definition.
long
definition(cell, value, shadowed_p)
- Pointer *cell, value;
+ SCHEME_OBJECT *cell, value;
Boolean shadowed_p;
{
if (shadowed_p)
return (redefinition(cell, value));
}
}
-}
+}
\f
long
dangerize(cell, sym)
- fast Pointer *cell;
- Pointer sym;
+ fast SCHEME_OBJECT *cell;
+ SCHEME_OBJECT sym;
{
Lock_Handle set_serializer;
fast long temp;
- Pointer trap;
+ SCHEME_OBJECT trap;
setup_lock(set_serializer, cell);
if (!(REFERENCE_TRAP_P(*cell)))
Request_GC(2);
return (PRIM_INTERRUPT);
}
- trap = Make_Pointer(TC_REFERENCE_TRAP, Free);
+ trap = MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free);
*Free++ = DANGEROUS_OBJECT;
*Free++ = *cell;
*cell = trap;
case TRAP_COMPILER_CACHED:
Do_Store_No_Lock
- ((Nth_Vector_Loc (*cell, TRAP_TAG)),
- (Make_Unsigned_Fixnum (TRAP_COMPILER_CACHED_DANGEROUS)));
+ ((MEMORY_LOC (*cell, TRAP_TAG)),
+ (LONG_TO_UNSIGNED_FIXNUM (TRAP_COMPILER_CACHED_DANGEROUS)));
/* Fall through */
case TRAP_COMPILER_CACHED_DANGEROUS:
case TRAP_FLUID:
Do_Store_No_Lock
- ((Nth_Vector_Loc (*cell, TRAP_TAG)),
- (Make_Unsigned_Fixnum (TRAP_FLUID_DANGEROUS)));
+ ((MEMORY_LOC (*cell, TRAP_TAG)),
+ (LONG_TO_UNSIGNED_FIXNUM (TRAP_FLUID_DANGEROUS)));
break;
case TRAP_UNBOUND:
long
extend_frame(env, sym, value, original_frame, recache_p)
- Pointer env, sym, value, original_frame;
+ SCHEME_OBJECT env, sym, value, original_frame;
Boolean recache_p;
{
Lock_Handle extension_serializer;
- Pointer extension, the_procedure;
- fast Pointer *scan;
+ SCHEME_OBJECT extension, the_procedure;
+ fast SCHEME_OBJECT *scan;
long aux_count;
- if (OBJECT_TYPE(env) == GLOBAL_ENV)
+ if (OBJECT_TYPE (env) == GLOBAL_ENV)
{
/* *UNDEFINE*: If undefine is ever implemented, this code need not
change: There are no shadowed bindings that need to be
recached.
*/
- if (OBJECT_DATUM(env) != GO_TO_GLOBAL)
+ if (OBJECT_DATUM (env) != GO_TO_GLOBAL)
{
return ((env == original_frame) ? ERR_BAD_FRAME : PRIM_DONE);
}
else if (env == original_frame)
{
- return (redefinition(Nth_Vector_Loc(sym, SYMBOL_GLOBAL_VALUE),
+ return (redefinition(MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE),
value));
}
else
{
- return (dangerize(Nth_Vector_Loc(sym, SYMBOL_GLOBAL_VALUE), sym));
+ return (dangerize(MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE), sym));
}
}
\f
- the_procedure = Vector_Ref(env, ENVIRONMENT_FUNCTION);
- if (OBJECT_TYPE(the_procedure) == AUX_LIST_TYPE)
- the_procedure = Vector_Ref(the_procedure, ENV_EXTENSION_PROCEDURE);
+ the_procedure = MEMORY_REF (env, ENVIRONMENT_FUNCTION);
+ if (OBJECT_TYPE (the_procedure) == AUX_LIST_TYPE)
+ the_procedure = MEMORY_REF (the_procedure, ENV_EXTENSION_PROCEDURE);
/* Search the formals. */
{
fast long count;
- Pointer formals;
+ SCHEME_OBJECT formals;
- formals = Fast_Vector_Ref(Fast_Vector_Ref(the_procedure,
+ formals = FAST_MEMORY_REF (FAST_MEMORY_REF (the_procedure,
PROCEDURE_LAMBDA_EXPR),
LAMBDA_FORMALS);
- for (count = Vector_Length(formals) - 1,
- scan = Nth_Vector_Loc(formals, VECTOR_DATA + 1);
+ for (count = VECTOR_LENGTH (formals) - 1,
+ scan = MEMORY_LOC (formals, VECTOR_DATA + 1);
count > 0;
count -= 1)
{
{
long offset;
- offset = 1 + Vector_Length(formals) - count;
+ offset = 1 + VECTOR_LENGTH (formals) - count;
if (env == original_frame)
{
- return (redefinition(Nth_Vector_Loc(env, offset), value));
+ return (redefinition(MEMORY_LOC (env, offset), value));
}
else
{
- return (dangerize(Nth_Vector_Loc(env, offset), sym));
+ return (dangerize(MEMORY_LOC (env, offset), sym));
}
}
}
redo_aux_lookup:
- setup_lock(extension_serializer, Get_Pointer(env));
- extension = Fast_Vector_Ref(env, ENVIRONMENT_FUNCTION);
- if (OBJECT_TYPE(extension) != AUX_LIST_TYPE)
+ setup_lock(extension_serializer, OBJECT_ADDRESS (env));
+ extension = FAST_MEMORY_REF (env, ENVIRONMENT_FUNCTION);
+ if (OBJECT_TYPE (extension) != AUX_LIST_TYPE)
{
fast long i;
return (PRIM_INTERRUPT);
}
scan = Free;
- extension = Make_Pointer(AUX_LIST_TYPE, scan);
+ extension = MAKE_POINTER_OBJECT (AUX_LIST_TYPE, scan);
scan[ENV_EXTENSION_HEADER] =
- Make_Non_Pointer(TC_MANIFEST_VECTOR, (AUX_LIST_INITIAL_SIZE - 1));
+ MAKE_OBJECT (TC_MANIFEST_VECTOR, (AUX_LIST_INITIAL_SIZE - 1));
scan[ENV_EXTENSION_PARENT_FRAME] =
- Vector_Ref(the_procedure, PROCEDURE_ENVIRONMENT);
+ MEMORY_REF (the_procedure, PROCEDURE_ENVIRONMENT);
scan[ENV_EXTENSION_PROCEDURE] = the_procedure;
for (i = AUX_CHUNK_SIZE, scan += AUX_LIST_FIRST;
--i >= 0;)
- *scan++ = NIL;
+ *scan++ = SHARP_F;
Free = scan;
- Do_Store_No_Lock ((Nth_Vector_Loc (env, ENVIRONMENT_FUNCTION)), extension);
+ Do_Store_No_Lock ((MEMORY_LOC (env, ENVIRONMENT_FUNCTION)), extension);
}
- aux_count = Lexical_Offset(Fast_Vector_Ref(extension, AUX_LIST_COUNT));
+ aux_count = Lexical_Offset(FAST_MEMORY_REF (extension, AUX_LIST_COUNT));
remove_lock(extension_serializer);
\f
/* Search the aux list. */
{
fast long count;
- scan = Get_Pointer(extension);
+ scan = OBJECT_ADDRESS (extension);
count = aux_count;
scan += AUX_LIST_FIRST;
while (--count >= 0)
{
- if (Fast_Vector_Ref(*scan, CONS_CAR) == sym)
+ if (FAST_PAIR_CAR (*scan) == sym)
{
- scan = Nth_Vector_Loc(*scan, CONS_CDR);
+ scan = PAIR_CDR_LOC (*scan);
/* This is done only because of compiler cached variables.
In their absence, this conditional is unnecessary.
of bindings if undefine is ever implemented. See the
comments above.
*/
- if (Fetch(scan[0]) == DANGEROUS_UNBOUND_OBJECT)
+ if (MEMORY_FETCH (scan[0]) == DANGEROUS_UNBOUND_OBJECT)
{
long temp;
-
+
temp =
compiler_uncache
- (deep_lookup(Fast_Vector_Ref(extension,
+ (deep_lookup(FAST_MEMORY_REF (extension,
ENV_EXTENSION_PARENT_FRAME),
sym,
fake_variable_object),
return (dangerize(scan, sym));
}
}
- scan += 1;
+ scan += 1;
}
}
\f
fast long temp;
temp =
- extend_frame(Fast_Vector_Ref(extension, ENV_EXTENSION_PARENT_FRAME),
- sym, NIL, original_frame, recache_p);
+ extend_frame(FAST_MEMORY_REF (extension, ENV_EXTENSION_PARENT_FRAME),
+ sym, SHARP_F, original_frame, recache_p);
if (temp != PRIM_DONE)
{
something in the meantime in this frame.
*/
- setup_lock(extension_serializer, Get_Pointer(env));
- temp = Lexical_Offset(Fast_Vector_Ref(extension, AUX_LIST_COUNT));
+ setup_lock(extension_serializer, OBJECT_ADDRESS (env));
+ temp = Lexical_Offset(FAST_MEMORY_REF (extension, AUX_LIST_COUNT));
- if ((extension != Fast_Vector_Ref(env, ENVIRONMENT_FUNCTION)) ||
+ if ((extension != FAST_MEMORY_REF (env, ENVIRONMENT_FUNCTION)) ||
(temp != aux_count))
{
remove_lock(extension_serializer);
goto redo_aux_lookup;
}
-\f
- scan = Get_Pointer(extension);
+\f
+ scan = OBJECT_ADDRESS (extension);
- if ((temp + (AUX_LIST_FIRST - 1)) == Get_Integer(scan[VECTOR_LENGTH]))
+ if ((temp + (AUX_LIST_FIRST - 1)) == (VECTOR_LENGTH (extension)))
{
fast long i;
- fast Pointer *fast_free;
+ fast SCHEME_OBJECT *fast_free;
i = ((2 * temp) + AUX_LIST_FIRST);
i -= 1;
scan += 1;
- *fast_free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, i);
+ *fast_free++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, i);
for (i = (temp + (AUX_LIST_FIRST - 1)); --i >= 0; )
*fast_free++ = *scan++;
for (i = temp; --i >= 0; )
- *fast_free++ = NIL;
+ *fast_free++ = SHARP_F;
scan = Free;
Free = fast_free;
Do_Store_No_Lock
- ((Nth_Vector_Loc (env, ENVIRONMENT_FUNCTION)),
- (Make_Pointer (AUX_LIST_TYPE, scan)));
+ ((MEMORY_LOC (env, ENVIRONMENT_FUNCTION)),
+ (MAKE_POINTER_OBJECT (AUX_LIST_TYPE, scan)));
}
-\f
+\f
if (GC_allocate_test(2))
{
remove_lock(extension_serializer);
}
{
- Pointer result;
+ SCHEME_OBJECT result;
- result = Make_Pointer(TC_LIST, Free);
+ result = MAKE_POINTER_OBJECT (TC_LIST, Free);
*Free++ = sym;
*Free++ = DANGEROUS_UNBOUND_OBJECT;
long
Lex_Ref(env, var)
- Pointer env, var;
+ SCHEME_OBJECT env, var;
{
- fast Pointer *cell;
- Pointer *hunk;
+ fast SCHEME_OBJECT *cell;
+ SCHEME_OBJECT *hunk;
- hunk = Get_Pointer(var);
+ hunk = OBJECT_ADDRESS (var);
lookup(cell, env, hunk, repeat_lex_ref_lookup);
return (lookup_end(cell, env, hunk));
}
long
Symbol_Lex_Ref(env, sym)
- Pointer env, sym;
+ SCHEME_OBJECT env, sym;
{
return (deep_lookup_end(deep_lookup(env, sym, fake_variable_object),
fake_variable_object));
long
Lex_Set(env, var, value)
- Pointer env, var, value;
+ SCHEME_OBJECT env, var, value;
{
- fast Pointer *cell;
- Pointer *hunk;
+ fast SCHEME_OBJECT *cell;
+ SCHEME_OBJECT *hunk;
- hunk = Get_Pointer(var);
+ hunk = OBJECT_ADDRESS (var);
lookup(cell, env, hunk, repeat_lex_set_lookup);
return (assignment_end(cell, env, hunk, value));
}
long
Symbol_Lex_Set(env, sym, value)
- Pointer env, sym, value;
+ SCHEME_OBJECT env, sym, value;
{
return (deep_assignment_end(deep_lookup(env, sym, fake_variable_object),
fake_variable_object,
\f
long
Local_Set(env, sym, value)
- Pointer env, sym, value;
+ SCHEME_OBJECT env, sym, value;
{
long result;
{
fprintf(stderr,
"\n;; Local_Set: defining %s.",
- Scheme_String_To_C_String(Vector_Ref(sym, SYMBOL_NAME)));
+ (STRING_LOC ((MEMORY_REF (sym, SYMBOL_NAME)), 0)));
}
result = extend_frame(env, sym, value, env, true);
Val = sym;
long
safe_lex_ref (env, var)
- Pointer env, var;
+ SCHEME_OBJECT env, var;
{
return (safe_reference_transform (Lex_Ref (env, var)));
}
long
safe_symbol_lex_ref (env, sym)
- Pointer env, sym;
+ SCHEME_OBJECT env, sym;
{
return (safe_reference_transform (Symbol_Lex_Ref (env, sym)));
}
case ERR_UNBOUND_VARIABLE:
case PRIM_DONE:
- Val = NIL;
+ Val = SHARP_F;
return (PRIM_DONE);
default:
long
Symbol_Lex_unassigned_p( frame, symbol)
- Pointer frame, symbol;
+ SCHEME_OBJECT frame, symbol;
{
return (unassigned_p_transform (Symbol_Lex_Ref (frame, symbol)));
}
long
Symbol_Lex_unbound_p( frame, symbol)
- Pointer frame, symbol;
+ SCHEME_OBJECT frame, symbol;
{
long result;
case ERR_UNASSIGNED_VARIABLE:
case PRIM_DONE:
{
- Val = NIL;
+ Val = SHARP_F;
return (PRIM_DONE);
}
used, but is provided for completeness.
*/
-Pointer *
+SCHEME_OBJECT *
force_definition(env, symbol, message)
- fast Pointer env;
- Pointer symbol;
+ fast SCHEME_OBJECT env;
+ SCHEME_OBJECT symbol;
long *message;
{
- fast Pointer previous;
+ fast SCHEME_OBJECT previous;
- if (OBJECT_TYPE(env) == GLOBAL_ENV)
+ if (OBJECT_TYPE (env) == GLOBAL_ENV)
{
- return ((Pointer *) NULL);
+ return ((SCHEME_OBJECT *) NULL);
}
do
{
previous = env;
- env = Fast_Vector_Ref(Vector_Ref(env, ENVIRONMENT_FUNCTION),
+ env = FAST_MEMORY_REF (MEMORY_REF (env, ENVIRONMENT_FUNCTION),
PROCEDURE_ENVIRONMENT);
- } while (OBJECT_TYPE(env) != GLOBAL_ENV);
+ } while (OBJECT_TYPE (env) != GLOBAL_ENV);
*message = Local_Set(previous, symbol, UNASSIGNED_OBJECT);
if (*message != PRIM_DONE)
- return ((Pointer *) NULL);
+ return ((SCHEME_OBJECT *) NULL);
return
deep_lookup(previous, symbol, fake_variable_object);
}
if needed, and stores it or a related object in the location
specified by (block, offset). It adds this reference to the
appropriate reference list for further updating.
-
+
If the reference is a lookup reference, the cache itself is stored.
If the reference is an assignment reference, there are two possibilities:
assignment references cached, and no fake cache had been installed,
a fake cache is created and all the assignment references are
updated to point to it.
- */
+ */
\f
#ifndef PARALLEL_PROCESSOR
#define compiler_cache_consistency_check() \
{ \
- Pointer *new_cell; \
+ SCHEME_OBJECT *new_cell; \
\
compiler_cache_variable[VARIABLE_SYMBOL] = name; \
new_cell = lookup_cell(compiler_cache_variable, env); \
#endif /* PARALLEL_PROCESSOR */
-extern Pointer compiler_cache_variable[];
+extern SCHEME_OBJECT compiler_cache_variable[];
extern long compiler_cache();
-Pointer compiler_cache_variable[3];
+SCHEME_OBJECT compiler_cache_variable[3];
\f
long
compiler_cache(cell, env, name, block, offset, kind, first_time)
- fast Pointer *cell;
- Pointer env, name, block;
+ fast SCHEME_OBJECT *cell;
+ SCHEME_OBJECT env, name, block;
long offset, kind;
Boolean first_time;
{
long cache_reference_end();
Lock_Handle set_serializer;
- fast Pointer trap, references, extension;
- Pointer trap_value, store_trap_tag, store_extension;
+ fast SCHEME_OBJECT trap, references, extension;
+ SCHEME_OBJECT trap_value, store_trap_tag, store_extension;
long trap_kind, return_value;
- store_trap_tag = NIL;
- store_extension = NIL;
+ store_trap_tag = SHARP_F;
+ store_extension = SHARP_F;
trap_kind = TRAP_COMPILER_CACHED;
compiler_cache_retry:
break;
case TRAP_DANGEROUS:
- trap_value = Fast_Vector_Ref(trap, TRAP_EXTRA);
+ trap_value = FAST_MEMORY_REF (trap, TRAP_EXTRA);
trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
break;
break;
case TRAP_FLUID_DANGEROUS:
- store_trap_tag = Make_Unsigned_Fixnum(TRAP_FLUID);
+ store_trap_tag = LONG_TO_UNSIGNED_FIXNUM(TRAP_FLUID);
trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
break;
case TRAP_COMPILER_CACHED:
case TRAP_COMPILER_CACHED_DANGEROUS:
- extension = Fast_Vector_Ref(trap, TRAP_EXTRA);
+ extension = FAST_MEMORY_REF (trap, TRAP_EXTRA);
update_lock(set_serializer,
- Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL));
- trap_value = Fast_Vector_Ref(extension, TRAP_EXTENSION_CELL);
+ MEMORY_LOC (extension, TRAP_EXTENSION_CELL));
+ trap_value = FAST_MEMORY_REF (extension, TRAP_EXTENSION_CELL);
trap_kind = -1;
break;
if (trap_kind != -1)
{
- Pointer new_trap, list;
+ SCHEME_OBJECT new_trap;
#if false
/* This is included in the check above. */
}
#endif
- new_trap = Make_Pointer(TC_REFERENCE_TRAP, Free);
- *Free++ = Make_Unsigned_Fixnum(trap_kind);
- extension = Make_Pointer(TRAP_EXTENSION_TYPE, (Free + 1));
+ new_trap = MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free);
+ *Free++ = LONG_TO_UNSIGNED_FIXNUM(trap_kind);
+ extension = MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, (Free + 1));
*Free++ = extension;
*Free++ = trap_value;
*Free++ = name;
- *Free++ = NIL;
- references = Make_Pointer(TRAP_REFERENCES_TYPE, (Free + 1));
+ *Free++ = SHARP_F;
+ references = MAKE_POINTER_OBJECT (TRAP_REFERENCES_TYPE, (Free + 1));
*Free++ = references;
- *Free++ = NIL;
- *Free++ = NIL;
- *Free++ = NIL;
+ *Free++ = EMPTY_LIST;
+ *Free++ = EMPTY_LIST;
+ *Free++ = EMPTY_LIST;
*cell = new_trap; /* Do_Store_No_Lock ? */
- if (store_trap_tag != NIL)
+ if (store_trap_tag != SHARP_F)
{
/* Do_Store_No_Lock ? */
- Fast_Vector_Set(trap, TRAP_TAG, store_trap_tag);
+ FAST_MEMORY_SET (trap, TRAP_TAG, store_trap_tag);
}
update_lock(set_serializer,
- Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL));
+ MEMORY_LOC (extension, TRAP_EXTENSION_CELL));
}
- if (block == NIL)
+ if (block == SHARP_F)
{
/* It is not really from compiled code.
The environment linking stuff wants a cc cache instead.
}
\f
/* There already is a compiled code cache.
- Maybe this should clean up all the cache lists?
+ Maybe this should clean up all the cache lists?
*/
{
void fix_references();
long add_reference();
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
if (((kind == TRAP_REFERENCES_ASSIGNMENT) &&
- (Fast_Vector_Ref(references, TRAP_REFERENCES_OPERATOR) != NIL)) ||
+ ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
+ != EMPTY_LIST)) ||
((kind == TRAP_REFERENCES_OPERATOR) &&
- (Fast_Vector_Ref(references, TRAP_REFERENCES_ASSIGNMENT) != NIL)))
+ ((FAST_MEMORY_REF (references, TRAP_REFERENCES_ASSIGNMENT))
+ != EMPTY_LIST)))
{
- store_extension = Fast_Vector_Ref(extension, TRAP_EXTENSION_CLONE);
- if (store_extension == NIL)
+ store_extension = FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE);
+ if (store_extension == SHARP_F)
{
#if false
/* This is included in the check above. */
return (PRIM_INTERRUPT);
}
#endif
- store_extension = Make_Pointer(TRAP_EXTENSION_TYPE, Free);
+ store_extension = MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free);
*Free++ = EXPENSIVE_ASSIGNMENT_OBJECT;
- *Free++ = Fast_Vector_Ref(extension, TRAP_EXTENSION_NAME);
+ *Free++ = FAST_MEMORY_REF (extension, TRAP_EXTENSION_NAME);
*Free++ = extension;
*Free++ = references;
- Fast_Vector_Set(extension, TRAP_EXTENSION_CLONE, store_extension);
+ FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, store_extension);
if (kind == TRAP_REFERENCES_OPERATOR)
{
- fix_references(Nth_Vector_Loc(references,
+ fix_references(MEMORY_LOC (references,
TRAP_REFERENCES_ASSIGNMENT),
store_extension);
}
}
}
-
- return_value = add_reference(Nth_Vector_Loc(references, kind),
+
+ return_value = add_reference(MEMORY_LOC (references, kind),
block,
- Make_Unsigned_Fixnum(offset));
+ LONG_TO_UNSIGNED_FIXNUM(offset));
if (return_value != PRIM_DONE)
{
compiler_cache_epilog();
cache_reference_end(kind, extension, store_extension,
block, offset, value)
long kind, offset;
- Pointer extension, store_extension, block, value;
+ SCHEME_OBJECT extension, store_extension, block, value;
{
extern void
store_variable_cache();
{
default:
case TRAP_REFERENCES_ASSIGNMENT:
- if (store_extension != NIL)
+ if (store_extension != SHARP_F)
{
store_variable_cache(store_extension, block, offset);
return (PRIM_DONE);
long
compiler_cache_reference(env, name, block, offset, kind, first_time)
- Pointer env, name, block;
+ SCHEME_OBJECT env, name, block;
long offset, kind;
Boolean first_time;
{
- Pointer *cell;
+ SCHEME_OBJECT *cell;
cell = deep_lookup(env, name, compiler_cache_variable);
if (cell == unbound_trap_object)
\f
/* This procedure updates all the references in the cached reference
list pointed at by slot to hold value. It also eliminates "empty"
- pairs (pairs whose weakly held block has vanished).
+ pairs (pairs whose weakly held block has vanished).
*/
void
fix_references(slot, extension)
- fast Pointer *slot, extension;
+ fast SCHEME_OBJECT *slot, extension;
{
- fast Pointer pair, block;
+ fast SCHEME_OBJECT pair, block;
- while (*slot != NIL)
+ while (*slot != EMPTY_LIST)
{
- pair = Fast_Vector_Ref(*slot, CONS_CAR);
- block = Fast_Vector_Ref(pair, CONS_CAR);
- if (block == NIL)
+ pair = FAST_PAIR_CAR (*slot);
+ block = FAST_PAIR_CAR (pair);
+ if (block == SHARP_F)
{
- *slot = Fast_Vector_Ref(*slot, CONS_CDR);
+ *slot = FAST_PAIR_CDR (*slot);
}
else
{
store_variable_cache(extension,
block,
- Get_Integer(Fast_Vector_Ref(pair, CONS_CDR)));
- slot = Nth_Vector_Loc(*slot, CONS_CDR);
+ OBJECT_DATUM (FAST_PAIR_CDR (pair)));
+ slot = PAIR_CDR_LOC (*slot);
}
}
return;
long
add_reference(slot, block, offset)
- fast Pointer *slot;
- Pointer block, offset;
+ fast SCHEME_OBJECT *slot;
+ SCHEME_OBJECT block, offset;
{
- fast Pointer pair;
+ fast SCHEME_OBJECT pair;
- while (*slot != NIL)
+ while (*slot != EMPTY_LIST)
{
- pair = Fast_Vector_Ref(*slot, CONS_CAR);
- if (Fast_Vector_Ref(pair, CONS_CAR) == NIL)
+ pair = FAST_PAIR_CAR (*slot);
+ if (FAST_PAIR_CAR (pair) == SHARP_F)
{
- Fast_Vector_Set(pair, CONS_CAR, block);
- Fast_Vector_Set(pair, CONS_CDR, offset);
+ FAST_SET_PAIR_CAR (pair, block);
+ FAST_SET_PAIR_CDR (pair, offset);
return (PRIM_DONE);
}
- slot = Nth_Vector_Loc(*slot, CONS_CDR);
+ slot = PAIR_CDR_LOC (*slot);
}
if (GC_allocate_test(4))
return (PRIM_INTERRUPT);
}
- *slot = Make_Pointer(TC_LIST, Free);
- *Free = Make_Pointer(TC_WEAK_CONS, (Free + 2));
+ *slot = MAKE_POINTER_OBJECT (TC_LIST, Free);
+ *Free = MAKE_POINTER_OBJECT (TC_WEAK_CONS, (Free + 2));
Free += 1;
- *Free++ = NIL;
+ *Free++ = EMPTY_LIST;
*Free++ = block;
*Free++ = offset;
return (PRIM_DONE);
}
\f
-extern Pointer compiled_block_environment();
+extern SCHEME_OBJECT compiled_block_environment();
static long
trap_map_table[] = {
long
compiler_uncache_slot(slot, sym, kind)
- fast Pointer *slot;
- Pointer sym;
+ fast SCHEME_OBJECT *slot;
+ SCHEME_OBJECT sym;
long kind;
{
- fast Pointer temp, pair;
- Pointer block, offset, new_extension;
+ fast SCHEME_OBJECT temp, pair;
+ SCHEME_OBJECT block, offset, new_extension;
- for (temp = *slot; temp != NIL; temp = *slot)
+ for (temp = *slot; temp != EMPTY_LIST; temp = *slot)
{
- pair = Fast_Vector_Ref(temp, CONS_CAR);
- block = Fast_Vector_Ref(pair, CONS_CAR);
- if (block != NIL)
+ pair = FAST_PAIR_CAR (temp);
+ block = FAST_PAIR_CAR (pair);
+ if (block != SHARP_F)
{
- offset = Fast_Vector_Ref(pair, CONS_CDR);
+ offset = FAST_PAIR_CDR (pair);
if (GC_allocate_test(4))
{
Request_GC(4);
return (PRIM_INTERRUPT);
}
- new_extension = Make_Pointer(TRAP_EXTENSION_TYPE, Free);
+ new_extension = MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free);
*Free++ = REQUEST_RECACHE_OBJECT;
*Free++ = sym;
*Free++ = block;
result = make_fake_uuo_link(new_extension,
block,
- Get_Integer(offset));
+ OBJECT_DATUM (offset));
if (result != PRIM_DONE)
return (result);
}
{
extern void store_variable_cache();
- store_variable_cache(new_extension, block, Get_Integer(offset));
+ store_variable_cache(new_extension, block, OBJECT_DATUM (offset));
}
}
- *slot = Fast_Vector_Ref(temp, CONS_CDR);
+ *slot = FAST_PAIR_CDR (temp);
}
return (PRIM_DONE);
}
long
compiler_uncache(value_cell, sym)
- Pointer *value_cell, sym;
+ SCHEME_OBJECT *value_cell, sym;
{
Lock_Handle set_serializer;
- Pointer val, extension, references;
+ SCHEME_OBJECT val, extension, references;
long trap_kind, temp, i, index;
setup_lock(set_serializer, value_cell);
compiler_uncache_prolog();
- extension = Fast_Vector_Ref(val, TRAP_EXTRA);
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
- update_lock(set_serializer, Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL));
+ extension = FAST_MEMORY_REF (val, TRAP_EXTRA);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
+ update_lock(set_serializer, MEMORY_LOC (extension, TRAP_EXTENSION_CELL));
/* Uncache all of the lists. */
for (i = TRAP_MAP_TABLE_SIZE; --i >= 0; )
{
index = trap_map_table[i];
- temp = compiler_uncache_slot(Nth_Vector_Loc(references, index),
+ temp = compiler_uncache_slot(MEMORY_LOC (references, index),
sym, index);
if (temp != PRIM_DONE)
{
/* Remove the clone extension if there is one. */
- Fast_Vector_Set(extension, TRAP_EXTENSION_CLONE, NIL);
+ FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, SHARP_F);
compiler_uncache_epilog();
remove_lock(set_serializer);
return (PRIM_DONE);
recaches (at the definition point) all the references that need to
point to the new cell.
- It does this in two phases:
+ It does this in two phases:
- First (by means of compiler_recache_split) it splits all
references into those that need to be updated and those that do
/* Required by compiler_uncache macro. */
-Pointer *shadowed_value_cell = ((Pointer *) NULL);
+SCHEME_OBJECT *shadowed_value_cell = ((SCHEME_OBJECT *) NULL);
/* Each extension is a hunk4. */
Boolean
environment_ancestor_or_self_p(ancestor, descendant)
- fast Pointer ancestor, descendant;
+ fast SCHEME_OBJECT ancestor, descendant;
{
- while (OBJECT_TYPE(descendant) != GLOBAL_ENV)
+ while (OBJECT_TYPE (descendant) != GLOBAL_ENV)
{
if (descendant == ancestor)
return (true);
- descendant = Fast_Vector_Ref(Vector_Ref(descendant,
- ENVIRONMENT_FUNCTION),
- PROCEDURE_ENVIRONMENT);
+ descendant = FAST_MEMORY_REF (MEMORY_REF (descendant,
+ ENVIRONMENT_FUNCTION),
+ PROCEDURE_ENVIRONMENT);
}
return (descendant == ancestor);
}
long
compiler_recache_split(slot, sym, definition_env, memoize_cell)
- fast Pointer *slot;
- Pointer sym, definition_env, **memoize_cell;
+ fast SCHEME_OBJECT *slot;
+ SCHEME_OBJECT sym, definition_env, **memoize_cell;
{
fast long count;
- Pointer weak_pair, block, reference_env, invalid_head;
- fast Pointer *last_invalid;
+ SCHEME_OBJECT weak_pair, block, reference_env, invalid_head;
+ fast SCHEME_OBJECT *last_invalid;
count = 0;
last_invalid = &invalid_head;
- while (*slot != NIL)
+ while (*slot != EMPTY_LIST)
{
- weak_pair = Fast_Vector_Ref(*slot, CONS_CAR);
- block = Fast_Vector_Ref(weak_pair, CONS_CAR);
- if (block == NIL)
+ weak_pair = FAST_PAIR_CAR (*slot);
+ block = FAST_PAIR_CAR (weak_pair);
+ if (block == SHARP_F)
{
- *slot = Fast_Vector_Ref(*slot, CONS_CDR);
+ *slot = FAST_PAIR_CDR (*slot);
continue;
}
reference_env = compiled_block_environment(block);
if (!environment_ancestor_or_self_p(definition_env, reference_env))
{
- slot = Nth_Vector_Loc(*slot, CONS_CDR);
+ slot = PAIR_CDR_LOC (*slot);
}
else
{
count += 1;
*last_invalid = *slot;
- last_invalid = Nth_Vector_Loc(*slot, CONS_CDR);
+ last_invalid = PAIR_CDR_LOC (*slot);
*slot = *last_invalid;
}
}
- *last_invalid = NIL;
+ *last_invalid = EMPTY_LIST;
*memoize_cell = slot;
*slot = invalid_head;
return (count);
}
\f
/* This recaches the entries pointed out by cell and adds them
- to the list in slot. It also sets to NIL the contents
+ to the list in slot. It also sets to #F the contents
of cell.
Note that this reuses the pairs and weak pairs that used to be
long
compiler_recache_slot(extension, sym, kind, slot, cell, value)
- Pointer extension, sym, value;
- fast Pointer *slot, *cell;
+ SCHEME_OBJECT extension, sym, value;
+ fast SCHEME_OBJECT *slot, *cell;
long kind;
{
- fast Pointer pair, weak_pair;
- Pointer clone, tail;
+ fast SCHEME_OBJECT pair, weak_pair;
+ SCHEME_OBJECT clone, tail;
long result;
- /* This is NIL if there isn't one.
+ /* This is #F if there isn't one.
This makes cache_reference_end do the right thing.
*/
- clone = Fast_Vector_Ref(extension, TRAP_EXTENSION_CLONE);
+ clone = FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE);
tail = *slot;
for (pair = *cell; pair != NULL; pair = *cell)
{
- weak_pair = Fast_Vector_Ref(pair, CONS_CAR);
+ weak_pair = FAST_PAIR_CAR (pair);
result = cache_reference_end(kind, extension, clone,
- Fast_Vector_Ref(weak_pair, CONS_CAR),
- Get_Integer(Fast_Vector_Ref(weak_pair,
- CONS_CDR)),
+ FAST_PAIR_CAR (weak_pair),
+ OBJECT_DATUM (FAST_PAIR_CDR (weak_pair)),
value);
if (result != PRIM_DONE)
{
}
*slot = pair;
- slot = Nth_Vector_Loc(pair, CONS_CDR);
+ slot = PAIR_CDR_LOC (pair);
*cell = *slot;
}
*slot = tail;
long
compiler_recache(old_value_cell, new_value_cell, env, sym, value,
shadowed_p, link_p)
- Pointer *old_value_cell, *new_value_cell, env, sym, value;
+ SCHEME_OBJECT *old_value_cell, *new_value_cell, env, sym, value;
Boolean shadowed_p, link_p;
{
Lock_Handle set_serializer_1, set_serializer_2;
- Pointer
+ SCHEME_OBJECT
old_value, references, extension, new_extension, new_trap,
*trap_info_table[TRAP_MAP_TABLE_SIZE];
long
trap_kind, temp, i, index, total_size, total_count, conflict_count;
-
+
setup_locks(set_serializer_1, old_value_cell,
set_serializer_2, new_value_cell);
-
+
if ((!link_p) && (*new_value_cell != DANGEROUS_UNBOUND_OBJECT))
{
/* Another processor has redefined this word in the meantime.
compiler_recache_prolog();
- extension = Fast_Vector_Ref(old_value, TRAP_EXTRA);
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
+ extension = FAST_MEMORY_REF (old_value, TRAP_EXTRA);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
update_lock(set_serializer_1,
- Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL));
+ MEMORY_LOC (extension, TRAP_EXTENSION_CELL));
\f
/*
Split each slot and compute the amount to allocate.
for (i = TRAP_MAP_TABLE_SIZE; --i >= 0; )
{
index = trap_map_table[i];
- temp = compiler_recache_split(Nth_Vector_Loc(references, index),
+ temp = compiler_recache_split(MEMORY_LOC (references, index),
sym, env, &trap_info_table[i]);
-
+
if (temp != 0)
{
conflict_count += trap_conflict_table[i];
if ((conflict_count == 2) &&
((!link_p) ||
- (new_value_cell[TRAP_EXTENSION_CLONE] == NIL)))
+ (new_value_cell[TRAP_EXTENSION_CLONE] == SHARP_F)))
{
total_size += SPACE_PER_EXTENSION;
}
if (link_p)
{
- new_extension = Make_Pointer(TRAP_EXTENSION_TYPE, new_value_cell);
+ new_extension = MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, new_value_cell);
references = new_value_cell[TRAP_EXTENSION_REFERENCES];
}
else
skip this binding.
*/
- references = Make_Pointer(TRAP_REFERENCES_TYPE, Free);
+ references = MAKE_POINTER_OBJECT (TRAP_REFERENCES_TYPE, Free);
- *Free++ = NIL;
- *Free++ = NIL;
- *Free++ = NIL;
+ *Free++ = EMPTY_LIST;
+ *Free++ = EMPTY_LIST;
+ *Free++ = EMPTY_LIST;
- new_extension = Make_Pointer(TRAP_EXTENSION_TYPE, Free);
+ new_extension = MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free);
*Free++ = value;
*Free++ = sym;
- *Free++ = NIL;
+ *Free++ = SHARP_F;
*Free++ = references;
- new_trap = Make_Pointer(TC_REFERENCE_TRAP, Free);
- *Free++ = Make_Unsigned_Fixnum((shadowed_p ?
+ new_trap = MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free);
+ *Free++ = LONG_TO_UNSIGNED_FIXNUM((shadowed_p ?
TRAP_COMPILER_CACHED_DANGEROUS :
TRAP_COMPILER_CACHED));
*Free++ = new_extension;
}
-
+
if ((conflict_count == 2) &&
- (Vector_Ref(new_extension, TRAP_EXTENSION_CLONE) == NIL))
+ (MEMORY_REF (new_extension, TRAP_EXTENSION_CLONE) == SHARP_F))
{
- Pointer clone;
+ SCHEME_OBJECT clone;
- clone = Make_Pointer(TRAP_EXTENSION_TYPE, Free);
+ clone = MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free);
*Free++ = EXPENSIVE_ASSIGNMENT_OBJECT;
*Free++ = sym;
*Free++ = new_extension;
*Free++ = references;
- Fast_Vector_Set(new_extension, TRAP_EXTENSION_CLONE, clone);
+ FAST_MEMORY_SET (new_extension, TRAP_EXTENSION_CLONE, clone);
}
\f
/*
{
index = trap_map_table[i];
temp = compiler_recache_slot(new_extension, sym, index,
- Nth_Vector_Loc(references, index),
+ MEMORY_LOC (references, index),
trap_info_table[i],
value);
if (temp != PRIM_DONE)
{
- extern char *Abort_Names[], *Error_Names[];
+ extern char *Abort_Names[];
/* We've lost BIG. */
long
recache_uuo_links(extension, old_value)
- Pointer extension, old_value;
+ SCHEME_OBJECT extension, old_value;
{
long update_uuo_links();
- Pointer value;
+ SCHEME_OBJECT value;
long return_value;
- value = Fast_Vector_Ref(extension, TRAP_EXTENSION_CELL);
+ value = FAST_MEMORY_REF (extension, TRAP_EXTENSION_CELL);
if (REFERENCE_TRAP_P(value))
{
if (REFERENCE_TRAP_P(old_value))
so it is safe to "revert" the value.
*/
- Fast_Vector_Set(extension, TRAP_EXTENSION_CELL, old_value);
+ FAST_MEMORY_SET (extension, TRAP_EXTENSION_CELL, old_value);
}
return (return_value);
}
long
make_recache_uuo_link(value, extension, block, offset)
- Pointer value, extension, block;
+ SCHEME_OBJECT value, extension, block;
long offset;
{
extern long make_fake_uuo_link();
\f
long
update_uuo_links(value, extension, handler)
- Pointer value, extension;
+ SCHEME_OBJECT value, extension;
long (*handler)();
{
- Pointer references, pair, block;
- fast Pointer *slot;
+ SCHEME_OBJECT references, pair, block;
+ fast SCHEME_OBJECT *slot;
long return_value;
update_uuo_prolog();
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
- slot = Nth_Vector_Loc(references, TRAP_REFERENCES_OPERATOR);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
+ slot = MEMORY_LOC (references, TRAP_REFERENCES_OPERATOR);
- while (*slot != NIL)
+ while (*slot != EMPTY_LIST)
{
- pair = Fast_Vector_Ref(*slot, CONS_CAR);
- block = Fast_Vector_Ref(pair, CONS_CAR);
- if (block == NIL)
+ pair = FAST_PAIR_CAR (*slot);
+ block = FAST_PAIR_CAR (pair);
+ if (block == SHARP_F)
{
- *slot = Fast_Vector_Ref(*slot, CONS_CDR);
+ *slot = FAST_PAIR_CDR (*slot);
}
else
{
return_value =
(*handler)(value, extension, block,
- Get_Integer(Fast_Vector_Ref(pair, CONS_CDR)));
+ OBJECT_DATUM (FAST_PAIR_CDR (pair)));
if (return_value != PRIM_DONE)
{
update_uuo_epilog();
return (return_value);
}
- slot = Nth_Vector_Loc(*slot, CONS_CDR);
+ slot = PAIR_CDR_LOC (*slot);
}
}
/* If there are no uuo links left, and there is an extension clone,
remove it, and make assignment references point to the real value
- cell.
+ cell.
*/
-
- if ((Fast_Vector_Ref(references, TRAP_REFERENCES_OPERATOR) == NIL) &&
- (Fast_Vector_Ref(extension, TRAP_EXTENSION_CLONE) != NIL))
+
+ if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR) == EMPTY_LIST) &&
+ (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE) != SHARP_F))
{
- Fast_Vector_Set(extension, TRAP_EXTENSION_CLONE, NIL);
- fix_references(Nth_Vector_Loc(references, TRAP_REFERENCES_ASSIGNMENT),
+ FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, SHARP_F);
+ fix_references(MEMORY_LOC (references, TRAP_REFERENCES_ASSIGNMENT),
extension);
}
update_uuo_epilog();
long
compiler_reference_trap(extension, kind, handler)
- Pointer extension;
+ SCHEME_OBJECT extension;
long kind;
long (*handler)();
{
long offset, temp;
- Pointer block;
+ SCHEME_OBJECT block;
try_again:
- if (Vector_Ref(extension, TRAP_EXTENSION_CELL) != REQUEST_RECACHE_OBJECT)
+ if (MEMORY_REF (extension, TRAP_EXTENSION_CELL) != REQUEST_RECACHE_OBJECT)
{
- return ((*handler)(Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL),
+ return ((*handler)(MEMORY_LOC (extension, TRAP_EXTENSION_CELL),
fake_variable_object));
}
- block = Fast_Vector_Ref(extension, TRAP_EXTENSION_BLOCK);
- offset = Get_Integer(Fast_Vector_Ref(extension, TRAP_EXTENSION_OFFSET));
+ block = FAST_MEMORY_REF (extension, TRAP_EXTENSION_BLOCK);
+ offset = OBJECT_DATUM (FAST_MEMORY_REF (extension, TRAP_EXTENSION_OFFSET));
compiler_trap_prolog();
- temp =
+ temp =
compiler_cache_reference(compiled_block_environment(block),
- Fast_Vector_Ref(extension, TRAP_EXTENSION_NAME),
+ FAST_MEMORY_REF (extension, TRAP_EXTENSION_NAME),
block, offset, kind, false);
compiler_trap_epilog();
if (temp != PRIM_DONE)
value.
*/
- extern Pointer extract_uuo_link();
+ extern SCHEME_OBJECT extract_uuo_link();
Val = extract_uuo_link(block, offset);
return (PRIM_DONE);
case TRAP_REFERENCES_LOOKUP:
default:
{
- extern Pointer extract_variable_cache();
+ extern SCHEME_OBJECT extract_variable_cache();
extension = extract_variable_cache(block, offset);
/* This is paranoid on a single processor, but it does not hurt.
long
compiler_cache_lookup(name, block, offset)
- Pointer name, block;
+ SCHEME_OBJECT name, block;
long offset;
{
return (compiler_cache_reference(compiled_block_environment(block),
long
compiler_cache_assignment(name, block, offset)
- Pointer name, block;
+ SCHEME_OBJECT name, block;
long offset;
{
return (compiler_cache_reference(compiled_block_environment(block),
long
compiler_cache_operator(name, block, offset)
- Pointer name, block;
+ SCHEME_OBJECT name, block;
long offset;
{
return (compiler_cache_reference(compiled_block_environment(block),
}
\f
extern long complr_operator_reference_trap();
-extern Pointer compiler_var_error();
+extern SCHEME_OBJECT compiler_var_error();
long
complr_operator_reference_trap(frame_slot, extension)
- Pointer *frame_slot, extension;
+ SCHEME_OBJECT *frame_slot, extension;
{
long temp;
return (PRIM_DONE);
}
-Pointer
+SCHEME_OBJECT
compiler_var_error(extension, environment)
- Pointer extension, environment;
+ SCHEME_OBJECT extension, environment;
{
- return (Vector_Ref(extension, TRAP_EXTENSION_NAME));
+ return (MEMORY_REF (extension, TRAP_EXTENSION_NAME));
}
/* Utility for compiler_assignment_trap, below.
- Necessary because C lacks lambda. Argh!
+ Necessary because C lacks lambda. Argh!
*/
-static Pointer saved_compiler_assignment_value;
+static SCHEME_OBJECT saved_compiler_assignment_value;
long
compiler_assignment_end(cell, hunk)
- Pointer *cell, *hunk;
+ SCHEME_OBJECT *cell, *hunk;
{
return (deep_assignment_end(cell, hunk,
saved_compiler_assignment_value, false));
long
compiler_lookup_trap(extension)
- Pointer extension;
+ SCHEME_OBJECT extension;
{
return (compiler_reference_trap(extension,
TRAP_REFERENCES_LOOKUP,
long
compiler_safe_lookup_trap (extension)
- Pointer extension;
+ SCHEME_OBJECT extension;
{
return (safe_reference_transform (compiler_lookup_trap (extension)));
}
long
compiler_unassigned_p_trap (extension)
- Pointer extension;
+ SCHEME_OBJECT extension;
{
return (unassigned_p_transform (compiler_lookup_trap (extension)));
}
long
compiler_assignment_trap(extension, value)
- Pointer extension, value;
+ SCHEME_OBJECT extension, value;
{
saved_compiler_assignment_value = value;
return (compiler_reference_trap(extension,
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/lookup.h,v 9.44 1989/09/20 23:10:10 cph Rel $
+
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/lookup.h,v 9.43 1989/08/28 18:29:03 cph Exp $ */
-
/* Macros and declarations for the variable lookup code. */
-extern Pointer
+extern SCHEME_OBJECT
*deep_lookup(),
*lookup_fluid(),
*force_definition();
deep_lookup_end(),
deep_assignment_end();
-extern Pointer
+extern SCHEME_OBJECT
unbound_trap_object[],
uncompiled_trap_object[],
illegal_trap_object[],
#endif /* b32 */
#ifndef UNCOMPILED_VARIABLE /* Safe version */
-#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0)
+#define UNCOMPILED_VARIABLE MAKE_OBJECT (UNCOMPILED_REF, 0)
#endif
/* Macros for speedy variable reference. */
#if (LOCAL_REF == 0)
#define Lexical_Offset(Ind) ((long) (Ind))
-#define Make_Local_Offset(Ind) ((Pointer) (Ind))
+#define Make_Local_Offset(Ind) ((SCHEME_OBJECT) (Ind))
#else
-#define Lexical_Offset(Ind) OBJECT_DATUM(Ind)
-#define Make_Local_Offset(Ind) Make_Non_Pointer(LOCAL_REF, Ind)
+#define Lexical_Offset(Ind) OBJECT_DATUM (Ind)
+#define Make_Local_Offset(Ind) MAKE_OBJECT (LOCAL_REF, Ind)
#endif
\f
#include "error: lookup.h inconsistency detected."
#endif
-#define get_offset(hunk) Lexical_Offset(Fetch(hunk[VARIABLE_OFFSET]))
+#define get_offset(hunk) Lexical_Offset(MEMORY_FETCH (hunk[VARIABLE_OFFSET]))
#ifdef PARALLEL_PROCESSOR
#define verify(type_code, variable, code, label) \
{ \
variable = code; \
- if (OBJECT_TYPE(Fetch(hunk[VARIABLE_COMPILED_TYPE])) != \
+ if (OBJECT_TYPE (MEMORY_FETCH (hunk[VARIABLE_COMPILED_TYPE])) != \
type_code) \
goto label; \
}
#define verified_offset(variable, code) variable
-/* Unlike Lock_Cell, cell must be (Pointer *). This currently does
+/* Unlike Lock_Cell, cell must be (SCHEME_OBJECT *). This currently does
not matter, but might on a machine with address mapping.
*/
#define Future_Variable_Splice(Vbl, Ofs, Val)
#endif
\f
-/* Pointer *cell, env, *hunk; */
+/* SCHEME_OBJECT *cell, env, *hunk; */
#define lookup(cell, env, hunk, label) \
{ \
- fast Pointer frame; \
- long offset; \
+ fast SCHEME_OBJECT frame; \
\
label: \
\
- frame = Fetch(hunk[VARIABLE_COMPILED_TYPE]); \
+ frame = (MEMORY_FETCH (hunk [VARIABLE_COMPILED_TYPE])); \
\
- switch (OBJECT_TYPE(frame)) \
+ switch (OBJECT_TYPE (frame)) \
{ \
case GLOBAL_REF: \
/* frame is a pointer to the same symbol. */ \
- cell = Nth_Vector_Loc(frame, SYMBOL_GLOBAL_VALUE); \
+ cell = MEMORY_LOC (frame, SYMBOL_GLOBAL_VALUE); \
break; \
\
case LOCAL_REF: \
- cell = Nth_Vector_Loc(env, Lexical_Offset(frame)); \
+ cell = MEMORY_LOC (env, Lexical_Offset(frame)); \
break; \
\
case FORMAL_REF: \
/* Done here rather than in a separate case because of \
peculiarities of the bobcat compiler. \
*/ \
- cell = ((OBJECT_TYPE(frame) == UNCOMPILED_REF) ? \
+ cell = ((OBJECT_TYPE (frame) == UNCOMPILED_REF) ? \
uncompiled_trap_object : \
illegal_trap_object); \
break; \
frame = env; \
while(--depth >= 0) \
{ \
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
+ frame = FAST_MEMORY_REF (MEMORY_REF (frame, ENVIRONMENT_FUNCTION), \
PROCEDURE_ENVIRONMENT); \
} \
\
- cell = Nth_Vector_Loc(frame, \
+ cell = MEMORY_LOC (frame, \
verified_offset(offset, get_offset(hunk))); \
\
break; \
frame = env; \
while(--depth >= 0) \
{ \
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
+ frame = FAST_MEMORY_REF (MEMORY_REF (frame, ENVIRONMENT_FUNCTION), \
PROCEDURE_ENVIRONMENT); \
} \
\
- frame = Vector_Ref(frame, ENVIRONMENT_FUNCTION); \
- if (OBJECT_TYPE(frame) != AUX_LIST_TYPE) \
+ frame = MEMORY_REF (frame, ENVIRONMENT_FUNCTION); \
+ if (OBJECT_TYPE (frame) != AUX_LIST_TYPE) \
{ \
cell = uncompiled_trap_object; \
break; \
} \
depth = verified_offset(offset, get_offset(hunk)); \
- if (depth > Vector_Length(frame)) \
+ if (depth > VECTOR_LENGTH (frame)) \
{ \
cell = uncompiled_trap_object; \
break; \
} \
- frame = Vector_Ref(frame, depth); \
- if ((frame == NIL) || \
- (Fast_Vector_Ref(frame, CONS_CAR) != hunk[VARIABLE_SYMBOL])) \
+ frame = MEMORY_REF (frame, depth); \
+ if ((frame == SHARP_F) || \
+ (FAST_PAIR_CAR (frame) != hunk[VARIABLE_SYMBOL])) \
{ \
cell = uncompiled_trap_object; \
break; \
} \
- cell = Nth_Vector_Loc(frame, CONS_CDR); \
+ cell = PAIR_CDR_LOC (frame); \
break; \
}
\f
extern long compiler_recache();
-extern Pointer *shadowed_value_cell;
+extern SCHEME_OBJECT *shadowed_value_cell;
#define compiler_uncache(cell, sym) \
(shadowed_value_cell = cell, PRIM_DONE)
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.40 1989/09/20 23:10:15 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.39 1989/08/28 18:29:06 cph Exp $ */
-
/* Memory management top level.
The memory management code is spread over 3 files:
/* Imports */
-extern Pointer *GCLoop();
+extern SCHEME_OBJECT *GCLoop();
/* Exports */
| |
| 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
Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
{
- Pointer test_value;
+ SCHEME_OBJECT test_value;
/* Consistency check 1 */
if (Our_Heap_Size == 0)
}
/* Allocate */
- Highest_Allocated_Address =
- Allocate_Heap_Space(Stack_Allocation_Size(Our_Stack_Size) +
+ Highest_Allocated_Address =
+ ALLOCATE_HEAP_SPACE(Stack_Allocation_Size(Our_Stack_Size) +
(2 * Our_Heap_Size) +
Our_Constant_Size +
HEAP_BUFFER_SPACE);
/* Initialize the various global parameters */
Heap += HEAP_BUFFER_SPACE;
- Initial_Align_Float(Heap);
+ INITIAL_ALIGN_FLOAT(Heap);
Unused_Heap = Heap + Our_Heap_Size;
- Align_Float(Unused_Heap);
+ ALIGN_FLOAT (Unused_Heap);
Constant_Space = Heap + 2*Our_Heap_Size;
- Align_Float(Constant_Space);
+ ALIGN_FLOAT (Constant_Space);
/* Consistency check 3 */
- test_value = (Make_Pointer(LAST_TYPE_CODE, Highest_Allocated_Address));
+ test_value = (MAKE_POINTER_OBJECT (LAST_TYPE_CODE, Highest_Allocated_Address));
- if (((OBJECT_TYPE(test_value)) != LAST_TYPE_CODE) ||
- ((Get_Pointer(test_value)) != Highest_Allocated_Address))
+ if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) ||
+ ((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address))
{
fprintf(stderr,
- "Largest address does not fit in datum field of Pointer.\n");
+ "Largest address does not fit in datum field of object.\n");
fprintf(stderr,
"Allocate less space or re-compile without Heap_In_Low_Memory.\n");
exit(1);
void
GCFlip()
{
- Pointer *Temp;
+ SCHEME_OBJECT *Temp;
Temp = Unused_Heap;
Unused_Heap = Heap_Bottom;
collector, which looks at both old and new space.
*/
-Pointer Weak_Chain;
+SCHEME_OBJECT Weak_Chain;
void
Fix_Weak_Chain()
{
- fast Pointer *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant;
+ fast SCHEME_OBJECT *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant;
Low_Constant = Constant_Space;
while (Weak_Chain != EMPTY_LIST)
{
- Old_Weak_Cell = Get_Pointer(Weak_Chain);
- Scan = Get_Pointer(*Old_Weak_Cell++);
+ Old_Weak_Cell = OBJECT_ADDRESS (Weak_Chain);
+ Scan = OBJECT_ADDRESS (*Old_Weak_Cell++);
Weak_Chain = *Old_Weak_Cell;
Old_Car = *Scan;
- Temp = Make_New_Pointer(OBJECT_TYPE(Weak_Chain), Old_Car);
- Weak_Chain = Make_New_Pointer(TC_NULL, Weak_Chain);
+ Temp = (MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, Old_Car));
+ Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain));
switch(GC_Type(Temp))
{ case GC_Non_Pointer:
continue;
case GC_Special:
- if (OBJECT_TYPE(Temp) != TC_REFERENCE_TRAP)
+ if (OBJECT_TYPE (Temp) != TC_REFERENCE_TRAP)
{
/* No other special type makes sense here. */
goto fail;
}
- if (OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE)
+ if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
{
*Scan = Temp;
continue;
case GC_Triple:
case GC_Quadruple:
case GC_Vector:
- Old = Get_Pointer(Old_Car);
+ Old = OBJECT_ADDRESS (Old_Car);
if (Old >= Low_Constant)
{
*Scan = Temp;
continue;
case GC_Compiled:
- Old = Get_Pointer(Old_Car);
+ Old = OBJECT_ADDRESS (Old_Car);
if (Old >= Low_Constant)
{
*Scan = Temp;
Temp);
*Scan = SHARP_F;
continue;
-
+
default: /* Non Marked Headers and Broken Hearts */
fail:
fprintf(stderr,
- 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.
\f
void GC()
{
- Pointer
+ SCHEME_OBJECT
*Root, *Result, *Check_Value,
The_Precious_Objects, *Root2;
Set_Fixed_Obj_Slot(Lost_Objects_Base, SHARP_F);
*Free++ = Fixed_Objects;
- *Free++ = Make_Pointer(UNMARKED_HISTORY_TYPE, History);
+ *Free++ = MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History);
*Free++ = Undefined_Primitives;
*Free++ = Undefined_Primitives_Arity;
*Free++ = Get_Current_Stacklet();
- *Free++ = ((Prev_Restore_History_Stacklet == NULL) ?
- SHARP_F :
- Make_Pointer(TC_CONTROL_POINT, Prev_Restore_History_Stacklet));
+ *Free++ =
+ ((Prev_Restore_History_Stacklet == NULL)
+ ? SHARP_F
+ : MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Prev_Restore_History_Stacklet));
*Free++ = Current_State_Point;
*Free++ = Fluid_Bindings;
Fixed_Objects = *Root++;
Set_Fixed_Obj_Slot(Precious_Objects, *Root2);
- Set_Fixed_Obj_Slot(Lost_Objects_Base, Make_Pointer(TC_ADDRESS, Root2));
+ Set_Fixed_Obj_Slot
+ (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (Root2))));
- History = Get_Pointer(*Root++);
+ History = OBJECT_ADDRESS (*Root++);
Undefined_Primitives = *Root++;
Undefined_Primitives_Arity = *Root++;
}
else
{
- Prev_Restore_History_Stacklet = Get_Pointer(*Root++);
+ Prev_Restore_History_Stacklet = OBJECT_ADDRESS (*Root++);
}
Current_State_Point = *Root++;
Fluid_Bindings = *Root++;
DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0)
{
+ long new_gc_reserve;
extern unsigned long gc_counter;
- Pointer GC_Daemon_Proc;
- Primitive_1_Arg();
+ SCHEME_OBJECT GC_Daemon_Proc;
+ PRIMITIVE_HEADER (1);
PRIMITIVE_CANONICALIZE_CONTEXT();
- Arg_1_Type(TC_FIXNUM);
+ new_gc_reserve = (arg_nonnegative_integer (1));
if (Free > Heap_Top)
{
fprintf(stderr,
}
ENTER_CRITICAL_SECTION ("garbage collector");
gc_counter += 1;
- GC_Reserve = (UNSIGNED_FIXNUM_VALUE (Arg1));
+ GC_Reserve = new_gc_reserve;
GCFlip();
GC();
CLEAR_INTERRUPT(INT_GC);
{
Will_Push(CONTINUATION_SIZE);
Store_Return(RC_NORMAL_GC_DONE);
- Store_Expression(Make_Unsigned_Fixnum(MemTop - Free));
+ Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free));
Save_Cont();
Pushed();
PRIMITIVE_ABORT(PRIM_POP_RETURN);
}
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
Store_Return(RC_NORMAL_GC_DONE);
- Store_Expression(Make_Unsigned_Fixnum(MemTop - Free));
+ Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free));
Save_Cont();
Push(GC_Daemon_Proc);
Push(STACK_FRAME_HEADER);
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/missing.c,v 9.23 1989/09/20 23:10:19 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/missing.c,v 9.22 1988/08/15 20:52:00 cph Rel $
- * This file contains utilities potentially missing from the math library
- */
-
-#ifdef DEBUG_MISSING
-#include "config.h"
-#endif
+/* This file contains utilities potentially missing from the math library. */
\f
-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 x = ((value < 0) ? (-value) : value);
+ int e = 0;
+ if (x > 1)
+ {
+ while (1)
+ {
+ x /= 2;
+ if (x > 1)
+ {
+ register double xr = (x / 2);
+ register double r = 4;
+ register int n = 1;
+ while (xr > 1)
+ {
+ x = xr;
+ xr /= r;
+ r *= r;
+ n += n;
+ }
+ if (xr < 1)
+ e += n;
+ else
+ {
+ x = (xr / 2);
+ e += (n + n + 1);
+ break;
+ }
+ }
+ else if (x < 1)
+ {
+ e += 1;
+ break;
+ }
+ else
+ {
+ x /= 2;
+ e += 2;
+ break;
+ }
+ }
+ }
+ else if (x < 1)
+ {
+ while (1)
+ {
+ if (x < 0.5)
+ {
+ register double xr = (x * 4);
+ register double r = 4;
+ register int n = 1;
+ while (xr < 1)
+ {
+ x = xr;
+ xr *= r;
+ r *= r;
+ n += n;
+ }
+ e -= n;
+ }
+ else
+ break;
+ }
+ }
+ (*eptr) = e;
+ return ((value < 0) ? (-x) : x);
}
-
-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];
+\f
+double
+ldexp (value, exponent)
+ double value;
+ int exponent;
+{
+ fast double x = value;
+ fast double e = exponent;
+ fast double r = 2;
+ if (e > 0)
+ {
+ if (e == 1)
+ return (x * 2);
+ while (1)
+ {
+ if ((e % 2) != 0)
+ x *= r;
+ e /= 2;
+ if (e == 1)
+ return (x * r * r);
+ r *= r;
+ }
}
- mant /= 2.0;
- exponent += 1;
+ else if (e < 0)
+ {
+ e = (-e);
+ if (e == 1)
+ return (x / 2);
+ while (1)
+ {
+ if ((e % 2) != 0)
+ x /= r;
+ e /= 2;
+ if (e == 1)
+ return ((x / r) / r);
+ r *= r;
+ }
+ }
+ else
+ return (x);
+}
+\f
+double
+modf (value, iptr)
+ double value;
+ double * iptr;
+{
+ int exponent;
+ double significand = (frexp (value, (&exponent)));
+ if ((significand == 0) || (exponent <= 0))
+ {
+ (*iptr) = 0;
+ return (value);
+ }
+ {
+ register double s =
+ ((((significand < 0) ? (-significand) : significand) * 2) - 1);
+ register double e = (exponent - 1);
+ register double n = 1;
+ while (1)
+ {
+ if (e == 0)
+ break;
+ s *= 2;
+ e -= 1;
+ n *= 2;
+ if (s >= 1)
+ {
+ s -= 1;
+ n += 1;
+ if (s <= 0)
+ {
+ /* Multiply n by 2^e */
+ register double b = 2;
+ if (e == 0)
+ break;
+ while (1)
+ {
+ if ((e % 2) == 1)
+ {
+ n *= b;
+ if (e == 1)
+ break;
+ e -= 1;
+ }
+ b *= b;
+ e /= 2;
+ }
+ break;
+ }
+ }
+ }
+ (*iptr) = n;
+ return (s);
}
- *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;
+double
+floor (x)
+ double x;
+{
+ double iptr;
+ double fraction = (modf (x, (&iptr)));
+ return ((fraction < 0) ? (iptr - 1) : iptr);
}
+double
+ceil (x)
+ double x;
+{
+ double iptr;
+ double fraction = (modf (x, (&iptr)));
+ return ((fraction > 0) ? (iptr + 1) : iptr);
+}
\f
#ifdef DEBUG_MISSING
#include <stdio.h>
-main()
-{ double input, output;
+main ()
+{
+ double input;
+ double 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));
- }
+ while (1)
+ {
+ 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
-
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/mul.c,v 9.27 1989/09/20 23:10:22 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/mul.c,v 9.26 1989/02/19 17:51:47 jinx Rel $
- *
- * This file contains the fixnum multiplication procedure.
- * Returns NIL if the result does not fit in a fixnum.
- * Note: The portable version has only been tried on machines with
- * long = 32 bits. This file is included in the appropriate os file.
- */
+/* This file contains the fixnum multiplication procedure. Returns
+ SHARP_F if the result does not fit in a fixnum. Note: The portable
+ version has only been tried on machines with long = 32 bits. This
+ file is included in the appropriate os file. */
\f
-extern Pointer Mul();
+extern SCHEME_OBJECT Mul ();
+
+#if (TYPE_CODE_LENGTH == 8)
#if defined(vax) && defined(bsd)
coded in assembly language. -- JINX
*/
-Pointer
+SCHEME_OBJECT
Mul(Arg1, Arg2)
- Pointer Arg1, Arg2;
+ SCHEME_OBJECT Arg1, Arg2;
{
register long A, B, C;
- Sign_Extend(Arg1, A);
- Sign_Extend(Arg2, B);
+ A = (FIXNUM_TO_LONG (Arg1));
+ B = (FIXNUM_TO_LONG (Arg2));
asm(" emul r11,r10,$0,r10"); /* A is in 11, B in 10 */
C = A;
A = B; /* What is all this shuffling? -- JINX */
if (((B == 0) && (A & (-1 << 23)) == 0) ||
((B == -1) && (A & (-1 << 23)) == (-1 << 23)))
{
- return (MAKE_SIGNED_FIXNUM(A));
+ return (LONG_TO_FIXNUM(A));
}
else
{
- return (NIL);
+ return (SHARP_F);
}
}
-#endif
+#endif /* vax+bsd */
\f
/* 68k family code. Uses hp9000s200 conventions for the new compiler. */
* for the compiler.
*/
-#if (NIL != 0) || (TC_FIXNUM != 0x1A)
+#if (SHARP_F != 0) || (TC_FIXNUM != 0x1A)
#include "Error: types changed. Change assembly language appropriately"
#endif
#endif /* not MC68020 */
#endif /* hp9000s200 */
\f
+#endif /* (TYPE_CODE_LENGTH == 8) */
+
#ifndef MUL_HANDLED
-#define HALF_WORD_SIZE ((sizeof(long)*CHAR_SIZE)/2)
+#define HALF_WORD_SIZE ((sizeof(long)*CHAR_BIT)/2)
#define HALF_WORD_MASK (1<<HALF_WORD_SIZE)-1
-#define MAX_MIDDLE (1<<((ADDRESS_LENGTH-1)-HALF_WORD_SIZE))
-#define MAX_FIXNUM (1<<ADDRESS_LENGTH)
+#define MAX_MIDDLE (1<<((DATUM_LENGTH-1)-HALF_WORD_SIZE))
+#define MAX_FIXNUM (1<<DATUM_LENGTH)
#define ABS(x) (((x) < 0) ? -(x) : (x))
-Pointer
+SCHEME_OBJECT
Mul(Arg1, Arg2)
- Pointer Arg1, Arg2;
+ SCHEME_OBJECT Arg1, Arg2;
{
long A, B, C;
fast unsigned long Hi_A, Hi_B, Lo_A, Lo_B, Lo_C, Middle_C;
Boolean Sign;
- Sign_Extend(Arg1, A);
- Sign_Extend(Arg2, B);
+ A = (FIXNUM_TO_LONG (Arg1));
+ B = (FIXNUM_TO_LONG (Arg2));
Sign = ((A < 0) == (B < 0));
A = ABS(A);
B = ABS(B);
Hi_A = ((A >> HALF_WORD_SIZE) & HALF_WORD_MASK);
Hi_B = ((B >> HALF_WORD_SIZE) & HALF_WORD_MASK);
if ((Hi_A > 0) && (Hi_B > 0))
- return (NIL);
+ return (SHARP_F);
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);
+ return (SHARP_F);
Middle_C = (Lo_A * Hi_B) + (Hi_A * Lo_B);
if (Middle_C >= MAX_MIDDLE)
- return (NIL);
+ return (SHARP_F);
C = Lo_C + (Middle_C << HALF_WORD_SIZE);
- if (Fixnum_Fits(C))
+ if (LONG_TO_FIXNUM_P(C))
{
if (Sign || (C == 0))
- return (MAKE_UNSIGNED_FIXNUM(C));
+ return (LONG_TO_UNSIGNED_FIXNUM(C));
else
- return (MAKE_UNSIGNED_FIXNUM(MAX_FIXNUM - C));
+ return (LONG_TO_UNSIGNED_FIXNUM(MAX_FIXNUM - C));
}
- return (NIL);
+ return (SHARP_F);
}
#endif /* not MUL_HANDLED */
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 9.32 1989/09/20 23:10:26 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 9.31 1989/08/28 18:29:10 cph Exp $ */
-
-/* This file contains definitions pertaining to the C view of
- Scheme pointers: widths of fields, extraction macros, pre-computed
- extraction masks, etc. */
+/* This file defines the macros which define and manipulate Scheme
+ objects. This is the lowest level of abstraction in this program. */
\f
-/* The C type Pointer is defined at the end of config.h
- The definition of POINTER_LENGTH here assumes that Pointer is the same
- as unsigned long. If that ever changes, this definition must also.
- POINTER_LENGTH is defined this way to make it available to
- the preprocessor. */
-
-/* The value in Wsize.c for TYPE_CODE_LENGTH must match this!! */
-
+/* The value in "Wsize.c" for `TYPE_CODE_LENGTH' must match this!! */
#ifndef TYPE_CODE_LENGTH
-#define TYPE_CODE_LENGTH 8
-#endif
-
-#if (TYPE_CODE_LENGTH == 8)
-#define MAX_TYPE_CODE 0xFF
-#endif
-
-#if (TYPE_CODE_LENGTH == 6)
-#define MAX_TYPE_CODE 0x3F
+#define TYPE_CODE_LENGTH 8
#endif
#ifdef MIN_TYPE_CODE_LENGTH
#include ";; inconsistency between object.h and types.h: MIN_TYPE_CODE_LENGTH"
#endif
#endif
-
-#ifndef MAX_TYPE_CODE
-#define MAX_TYPE_CODE ((1 << TYPE_CODE_LENGTH) - 1)
-#endif
-#define POINTER_LENGTH ULONG_SIZE
-
#ifdef b32 /* 32 bit word versions */
-
#if (TYPE_CODE_LENGTH == 8)
-#define ADDRESS_LENGTH 24
-#define ADDRESS_MASK 0x00FFFFFF
-#define TYPE_CODE_MASK 0xFF000000
+#define MAX_TYPE_CODE 0xFF
+#define DATUM_LENGTH 24
#define FIXNUM_LENGTH 23
#define FIXNUM_SIGN_BIT 0x00800000
#define SIGN_MASK 0xFF800000
#define SMALLEST_FIXNUM ((long) 0xFF800000)
#define BIGGEST_FIXNUM ((long) 0x007FFFFF)
-#define HALF_ADDRESS_LENGTH 12
-#define HALF_ADDRESS_MASK 0x00000FFF
-#endif /* (TYPE_CODE_LENGTH == 8) */
+#define HALF_DATUM_LENGTH 12
+#define HALF_DATUM_MASK 0x00000FFF
+#ifndef OBJECT_MASKS_DEFINED
+#define DATUM_MASK 0x00FFFFFF
+#define TYPE_CODE_MASK 0xFF000000
+#endif /* not OBJECT_MASKS_DEFINED */
+
+#endif /* (TYPE_CODE_LENGTH == 8) */
#if (TYPE_CODE_LENGTH == 6)
-#define ADDRESS_LENGTH 26
-#define ADDRESS_MASK 0x03FFFFFF
-#define TYPE_CODE_MASK 0XFC000000
+
+#define MAX_TYPE_CODE 0x3F
+#define DATUM_LENGTH 26
#define FIXNUM_LENGTH 25
#define FIXNUM_SIGN_BIT 0x02000000
#define SIGN_MASK 0xFE000000
#define SMALLEST_FIXNUM ((long) 0xFE000000)
#define BIGGEST_FIXNUM ((long) 0x01FFFFFF)
-#define HALF_ADDRESS_LENGTH 13
-#define HALF_ADDRESS_MASK 0x00001FFF
-#endif /* (TYPE_CODE_LENGTH == 6) */
+#define HALF_DATUM_LENGTH 13
+#define HALF_DATUM_MASK 0x00001FFF
+
+#ifndef OBJECT_MASKS_DEFINED
+#define DATUM_MASK 0x03FFFFFF
+#define TYPE_CODE_MASK 0XFC000000
+#endif /* not OBJECT_MASKS_DEFINED */
+#endif /* (TYPE_CODE_LENGTH == 6) */
#endif /* b32 */
+#ifndef DATUM_LENGTH /* Safe versions */
-#ifndef ADDRESS_LENGTH /* Safe versions */
-#define ADDRESS_LENGTH (POINTER_LENGTH-TYPE_CODE_LENGTH)
-#define ADDRESS_MASK ((1 << ADDRESS_LENGTH) - 1)
-#define TYPE_CODE_MASK (~ADDRESS_MASK)
+#define MAX_TYPE_CODE ((1 << TYPE_CODE_LENGTH) - 1)
+#define DATUM_LENGTH (OBJECT_LENGTH - TYPE_CODE_LENGTH)
/* FIXNUM_LENGTH does NOT include the sign bit! */
-#define FIXNUM_LENGTH (ADDRESS_LENGTH - 1)
+#define FIXNUM_LENGTH (DATUM_LENGTH - 1)
#define FIXNUM_SIGN_BIT (1 << FIXNUM_LENGTH)
-#define SIGN_MASK (TYPE_CODE_MASK | FIXNUM_SIGN_BIT)
+#define SIGN_MASK ((long) (-1 << FIXNUM_LENGTH))
#define SMALLEST_FIXNUM ((long) (-1 << FIXNUM_LENGTH))
-#define BIGGEST_FIXNUM ((long) (~(-1 << FIXNUM_LENGTH)))
-#define HALF_ADDRESS_LENGTH (ADDRESS_LENGTH / 2)
-#define HALF_ADDRESS_MASK ((1 << HALF_ADDRESS_LENGTH) - 1)
-#endif /* ADDRESS_LENGTH */
+#define BIGGEST_FIXNUM ((1 << FIXNUM_LENGTH) - 1)
+#define HALF_DATUM_LENGTH (DATUM_LENGTH / 2)
+#define HALF_DATUM_MASK ((1 << HALF_DATUM_LENGTH) - 1)
+
+#ifndef OBJECT_MASKS_DEFINED
+#define DATUM_MASK ((1 << DATUM_LENGTH) - 1)
+#define TYPE_CODE_MASK (~ DATUM_MASK)
+#endif /* not OBJECT_MASKS_DEFINED */
+
+#endif /* DATUM_LENGTH */
\f
+/* Basic object structure */
+
#ifndef OBJECT_TYPE
-#ifndef UNSIGNED_SHIFT /* Portable version */
-#define OBJECT_TYPE(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE)
-#else /* Faster for logical shifts */
-#define OBJECT_TYPE(P) ((P) >> ADDRESS_LENGTH)
+#ifdef UNSIGNED_SHIFT
+/* Faster for logical shifts */
+#define OBJECT_TYPE(object) ((object) >> DATUM_LENGTH)
+#else
+/* Portable version */
+#define OBJECT_TYPE(object) (((object) >> DATUM_LENGTH) & MAX_TYPE_CODE)
#endif
-#endif /* OBJECT_TYPE */
-
-#ifndef OBJECT_DATUM
-#define OBJECT_DATUM(P) ((P) & ADDRESS_MASK)
#endif
-#ifndef MAKE_OBJECT
-#define MAKE_OBJECT(TC, D) \
- ((((unsigned) (TC)) << ADDRESS_LENGTH) | (OBJECT_DATUM (D)))
-#endif
+#define OBJECT_DATUM(object) ((object) & DATUM_MASK)
+#define OBJECT_ADDRESS(object) (DATUM_TO_ADDRESS ((object) & DATUM_MASK))
-/* compatibility definitions */
-#define Type_Code(P) (OBJECT_TYPE (P))
-#define Datum(P) (OBJECT_DATUM (P))
-\f
-#ifndef Heap_In_Low_Memory /* Portable version */
+#define MAKE_OBJECT(type, datum) \
+ ((((unsigned int) (type)) << DATUM_LENGTH) | (datum))
-typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */
+#define OBJECT_NEW_DATUM(type_object, datum) \
+ (((type_object) & TYPE_CODE_MASK) | (datum))
-extern Pointer *Memory_Base;
+#define OBJECT_NEW_TYPE(type, datum_object) \
+ (MAKE_OBJECT ((type), (OBJECT_DATUM (datum_object))))
-/* The "-1" in the value returned is a guarantee that there is one
- word reserved exclusively for use by the garbage collector. */
+#define MAKE_OBJECT_FROM_OBJECTS(type_object, datum_object) \
+ (((type_object) & TYPE_CODE_MASK) | ((datum_object) & DATUM_MASK))
-#define Allocate_Heap_Space(space) \
- (Memory_Base = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \
- Heap = Memory_Base, \
- ((Memory_Base + (space)) - 1))
+#define MAKE_POINTER_OBJECT(type, address) \
+ (MAKE_OBJECT ((type), (ADDRESS_TO_DATUM (address))))
-#define Get_Pointer(P) ((Pointer *) (Memory_Base + (OBJECT_DATUM (P))))
-#define C_To_Scheme(P) ((Pointer) ((P) - Memory_Base))
+#define OBJECT_NEW_ADDRESS(object, address) \
+ (OBJECT_NEW_DATUM ((object), (ADDRESS_TO_DATUM (address))))
-#else /* not Heap_In_Low_Memory */
-/* Storing absolute addresses */
+#ifdef Heap_In_Low_Memory /* Storing absolute addresses */
typedef long relocation_type; /* Used to relocate pointers on fasload */
-#define Allocate_Heap_Space(space) \
- (Heap = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \
+/* The "-1" in the value returned is a guarantee that there is one
+ word reserved exclusively for use by the garbage collector. */
+#define ALLOCATE_HEAP_SPACE(space) \
+ (Heap = \
+ ((SCHEME_OBJECT *) (malloc ((sizeof (SCHEME_OBJECT)) * (space)))), \
((Heap + (space)) - 1))
-#define Get_Pointer(P) ((Pointer *) (OBJECT_DATUM (P)))
-#define C_To_Scheme(P) ((Pointer) (P))
+#define DATUM_TO_ADDRESS(datum) ((SCHEME_OBJECT *) (datum))
+#define ADDRESS_TO_DATUM(address) ((SCHEME_OBJECT) (address))
-#endif /* Heap_In_Low_Memory */
-\f
-#define Make_Pointer(TC, A) MAKE_OBJECT((TC), C_To_Scheme(A))
-#define Make_Non_Pointer(TC, D) MAKE_OBJECT(TC, ((Pointer) (D)))
+#else /* not Heap_In_Low_Memory (portable version) */
-/* (Make_New_Pointer (TC, A)) may be more efficient than
- (Make_Pointer (TC, (Get_Pointer (A)))) */
+/* Used to relocate pointers on fasload */
+typedef SCHEME_OBJECT * relocation_type;
+extern SCHEME_OBJECT * memory_base;
-#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) | (OBJECT_DATUM ((Pointer) (A))))
-
-#define Address(P) (OBJECT_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) (OBJECT_DATUM (Fast_Vector_Ref((P), 0)))
+/* The "-1" in the value returned is a guarantee that there is one
+ word reserved exclusively for use by the garbage collector. */
+#define ALLOCATE_HEAP_SPACE(space) \
+ (memory_base = \
+ ((SCHEME_OBJECT *) (malloc ((sizeof (SCHEME_OBJECT)) * (space)))), \
+ Heap = memory_base, \
+ ((memory_base + (space)) - 1))
-/* General case vector handling requires atomicity for parallel processors */
+#define DATUM_TO_ADDRESS(datum) ((SCHEME_OBJECT *) ((datum) + memory_base))
+#define ADDRESS_TO_DATUM(address) ((SCHEME_OBJECT) ((address) - memory_base))
-#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)
+#endif /* Heap_In_Low_Memory */
\f
+/* Lots of type predicates */
+
#define FIXNUM_P(object) ((OBJECT_TYPE (object)) == TC_FIXNUM)
#define BIGNUM_P(object) ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM)
#define FLONUM_P(object) ((OBJECT_TYPE (object)) == TC_BIG_FLONUM)
#define PAIR_P(object) ((OBJECT_TYPE (object)) == TC_LIST)
#define WEAK_PAIR_P(object) ((OBJECT_TYPE (object)) == TC_WEAK_CONS)
#define VECTOR_P(object) ((OBJECT_TYPE (object)) == TC_VECTOR)
+#define BOOLEAN_P(object) (((object) == SHARP_T) || ((object) == SHARP_F))
#define REFERENCE_TRAP_P(object) ((OBJECT_TYPE (object)) == TC_REFERENCE_TRAP)
+#define PRIMITIVE_P(object) ((OBJECT_TYPE (object)) == TC_PRIMITIVE)
+#define FUTURE_P(object) ((OBJECT_TYPE (object)) == TC_FUTURE)
+#define PROMISE_P(object) ((OBJECT_TYPE (object)) == TC_DELAYED)
+#define APPARENT_LIST_P(object) (((object) == EMPTY_LIST) || (PAIR_P (object)))
+#define CONTROL_POINT_P(object) ((OBJECT_TYPE (object)) == TC_CONTROL_POINT)
+#define BROKEN_HEART_P(object) ((OBJECT_TYPE (object)) == TC_BROKEN_HEART)
+#define GC_NON_POINTER_P(object) ((GC_Type (object)) == GC_Non_Pointer)
+#define GC_CELL_P(object) ((GC_Type (object)) == GC_Cell)
+#define GC_PAIR_P(object) ((GC_Type (object)) == GC_Pair)
+#define GC_TRIPLE_P(object) ((GC_Type (object)) == GC_Triple)
+#define GC_QUADRUPLE_P(object) ((GC_Type (object)) == GC_Quadruple)
+#define GC_VECTOR_P(object) ((GC_Type (object)) == GC_Vector)
+
+#define COMPILED_CODE_ADDRESS_P(object) \
+ ((OBJECT_TYPE (object)) == TC_COMPILED_ENTRY)
+
+#define STACK_ADDRESS_P(object) \
+ ((OBJECT_TYPE (object)) == TC_STACK_ENVIRONMENT)
#define NON_MARKED_VECTOR_P(object) \
((OBJECT_TYPE (object)) == TC_NON_MARKED_VECTOR)
((OBJECT_TYPE (object)) == TC_COMPLEX))
#define HUNK3_P(object) \
- (((OBJECT_TYPE(object)) == TC_HUNK3_A) || \
- ((OBJECT_TYPE(object)) == TC_HUNK3_B))
+ (((OBJECT_TYPE (object)) == TC_HUNK3_A) || \
+ ((OBJECT_TYPE (object)) == TC_HUNK3_B))
+
+#define INTERPRETER_APPLICABLE_P interpreter_applicable_p
+
+#define ENVIRONMENT_P(env) \
+ ((OBJECT_TYPE (env) == TC_ENVIRONMENT) || \
+ (OBJECT_TYPE (env) == GLOBAL_ENV))
\f
-#define MAKE_FIXNUM(N) (Make_Non_Pointer (TC_FIXNUM, (N)))
-#define FIXNUM_NEGATIVE_P(fixnum) (((fixnum) & FIXNUM_SIGN_BIT) != 0)
-#define MAKE_UNSIGNED_FIXNUM(N) (FIXNUM_ZERO + (N))
-#define UNSIGNED_FIXNUM_VALUE OBJECT_DATUM
-#define MAKE_SIGNED_FIXNUM MAKE_FIXNUM
-#define NONNEGATIVE_FIXNUM_P(x) ((FIXNUM_P (x)) && (! (FIXNUM_NEGATIVE_P (x))))
+/* Memory Operations */
+
+/* The FAST_ operations are used only where the object is known to be
+ immutable. On a parallel processor they don't require atomic
+ references. */
+
+#define FAST_MEMORY_REF(object, offset) \
+ ((OBJECT_ADDRESS (object)) [(offset)])
+
+#define FAST_MEMORY_SET(object, offset, value) \
+ ((OBJECT_ADDRESS (object)) [(offset)]) = (value)
+
+#define MEMORY_LOC(object, offset) \
+ (& ((OBJECT_ADDRESS (object)) [(offset)]))
+
+/* General case memory access requires atomicity for parallel processors. */
+
+#define MEMORY_REF(object, offset) \
+ (MEMORY_FETCH ((OBJECT_ADDRESS (object)) [(offset)]))
+
+#define MEMORY_SET(object, offset, value) \
+ MEMORY_STORE (((OBJECT_ADDRESS (object)) [(offset)]), (value))
+
+/* Pair Operations */
+
+#define FAST_PAIR_CAR(pair) (FAST_MEMORY_REF ((pair), CONS_CAR))
+#define FAST_PAIR_CDR(pair) (FAST_MEMORY_REF ((pair), CONS_CDR))
+#define FAST_SET_PAIR_CAR(pair, car) FAST_MEMORY_SET ((pair), CONS_CAR, (car))
+#define FAST_SET_PAIR_CDR(pair, cdr) FAST_MEMORY_SET ((pair), CONS_CDR, (cdr))
+#define PAIR_CAR_LOC(pair) (MEMORY_LOC ((pair), CONS_CAR))
+#define PAIR_CDR_LOC(pair) (MEMORY_LOC ((pair), CONS_CDR))
-#define FIXNUM_VALUE(fixnum, target) \
-do \
+#define PAIR_CAR(pair) (MEMORY_REF ((pair), CONS_CAR))
+#define PAIR_CDR(pair) (MEMORY_REF ((pair), CONS_CDR))
+#define SET_PAIR_CAR(pair, car) MEMORY_SET ((pair), CONS_CAR, (car))
+#define SET_PAIR_CDR(pair, cdr) MEMORY_SET ((pair), CONS_CDR, (cdr))
+
+/* Vector Operations */
+
+#define VECTOR_LENGTH(vector) (OBJECT_DATUM (FAST_MEMORY_REF ((vector), 0)))
+
+#define SET_VECTOR_LENGTH(vector, length) \
+ FAST_MEMORY_SET \
+ ((vector), \
+ 0, \
+ (OBJECT_NEW_DATUM ((FAST_MEMORY_REF ((vector), 0)), (length))));
+
+#define FAST_VECTOR_REF(vector, index) \
+ (FAST_MEMORY_REF ((vector), ((index) + 1)))
+
+#define FAST_VECTOR_SET(vector, index, value) \
+ FAST_MEMORY_SET ((vector), ((index) + 1), (value))
+
+#define VECTOR_LOC(vector, index) (MEMORY_LOC ((vector), ((index) + 1)))
+#define VECTOR_REF(vector, index) (MEMORY_REF ((vector), ((index) + 1)))
+
+#define VECTOR_SET(vector, index, value) \
+ MEMORY_SET ((vector), ((index) + 1), (value))
+\f
+/* String Operations */
+
+/* Add 1 byte to length to account for '\0' at end of string.
+ Add 1 word to length to account for string header word. */
+#define STRING_LENGTH_TO_GC_LENGTH(length) \
+ ((BYTES_TO_WORDS ((length) + 1)) + 1)
+
+#define STRING_LENGTH(string) \
+ ((long) (MEMORY_REF ((string), STRING_LENGTH_INDEX)))
+
+#define SET_STRING_LENGTH(string, length) do \
{ \
- (target) = (UNSIGNED_FIXNUM_VALUE (fixnum)); \
- if (FIXNUM_NEGATIVE_P (target)) \
- (target) |= (-1 << ADDRESS_LENGTH); \
+ MEMORY_SET ((string), STRING_LENGTH_INDEX, (length)); \
+ STRING_SET ((string), (length), '\0'); \
} while (0)
-/* Compatibility */
-#define Make_Unsigned_Fixnum MAKE_UNSIGNED_FIXNUM
-#define Make_Signed_Fixnum MAKE_FIXNUM
-#define Get_Integer OBJECT_DATUM
-#define Sign_Extend FIXNUM_VALUE
+/* Subtract 1 to account for the fact that we maintain a '\0'
+ at the end of the string. */
+#define MAXIMUM_STRING_LENGTH(string) \
+ ((long) ((((VECTOR_LENGTH (string)) - 1) * (sizeof (SCHEME_OBJECT))) - 1))
-#define BOOLEAN_TO_OBJECT(expression) ((expression) ? SHARP_T : SHARP_F)
+#define SET_MAXIMUM_STRING_LENGTH(string, length) \
+ SET_VECTOR_LENGTH ((string), (STRING_LENGTH_TO_GC_LENGTH (length)))
+
+#define STRING_LOC(string, index) \
+ (((unsigned char *) (MEMORY_LOC (string, STRING_CHARS))) + (index))
+
+#define STRING_REF(string, index) \
+ ((int) (* (STRING_LOC ((string), (index)))))
+
+#define STRING_SET(string, index, c_char) \
+ (* (STRING_LOC ((string), (index)))) = (c_char)
+
+/* Character Operations */
+
+#define ASCII_LENGTH CHAR_BIT /* CHAR_BIT in config.h - 8 for unix */
+#define CODE_LENGTH 7
+#define BITS_LENGTH 5
+#define MIT_ASCII_LENGTH 12
+
+#define CHAR_BITS_META 01
+#define CHAR_BITS_CONTROL 02
+#define CHAR_BITS_CONTROL_META 03
+
+#define MAX_ASCII (1 << ASCII_LENGTH)
+#define MAX_CODE (1 << CODE_LENGTH)
+#define MAX_BITS (1 << BITS_LENGTH)
+#define MAX_MIT_ASCII (1 << MIT_ASCII_LENGTH)
+
+#define MASK_ASCII (MAX_ASCII - 1)
+#define CHAR_MASK_CODE (MAX_CODE - 1)
+#define CHAR_MASK_BITS (MAX_BITS - 1)
+#define MASK_MIT_ASCII (MAX_MIT_ASCII - 1)
+
+#define ASCII_TO_CHAR(ascii) (MAKE_OBJECT (TC_CHARACTER, (ascii)))
+#define CHAR_TO_ASCII_P(object) ((OBJECT_DATUM (object)) < MAX_ASCII)
+#define CHAR_TO_ASCII(object) ((object) & MASK_ASCII)
+
+#define MAKE_CHAR(bucky_bits, code) \
+ (MAKE_OBJECT \
+ (TC_CHARACTER, \
+ (((unsigned long) (bucky_bits)) << (CODE_LENGTH)) | (code)))
+
+#define CHAR_BITS(chr) \
+ ((((unsigned long) (OBJECT_DATUM (chr))) >> CODE_LENGTH) & CHAR_MASK_BITS)
+
+#define CHAR_CODE(chr) ((OBJECT_DATUM (chr)) & CHAR_MASK_CODE)
+\f
+/* Fixnum Operations */
+
+#define FIXNUM_ZERO_P(fixnum) ((OBJECT_DATUM (fixnum)) == 0)
+#define FIXNUM_NEGATIVE_P(fixnum) (((fixnum) & FIXNUM_SIGN_BIT) != 0)
+#define UNSIGNED_FIXNUM_P(x) ((FIXNUM_P (x)) && (! (FIXNUM_NEGATIVE_P (x))))
+#define FIXNUM_EQUAL_P(x, y) ((OBJECT_DATUM (x)) == (OBJECT_DATUM (y)))
+#define FIXNUM_LESS_P(x, y) ((FIXNUM_TO_LONG (x)) < (FIXNUM_TO_LONG (y)))
+
+#define FIXNUM_POSITIVE_P(fixnum) \
+ (! ((FIXNUM_ZERO_P (fixnum)) || (FIXNUM_NEGATIVE_P (fixnum))))
+
+#define UNSIGNED_FIXNUM_TO_LONG(fixnum) ((long) (OBJECT_DATUM (fixnum)))
+#define LONG_TO_UNSIGNED_FIXNUM_P(value) (((value) & SIGN_MASK) == 0)
+#define LONG_TO_UNSIGNED_FIXNUM(value) (FIXNUM_ZERO + (value))
+#define LONG_TO_FIXNUM(value) (OBJECT_NEW_TYPE (TC_FIXNUM, (value)))
-#define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N))
-#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1))))
+#define LONG_TO_FIXNUM_P(value) \
+ ((((value) & SIGN_MASK) == 0) || (((value) & SIGN_MASK) == SIGN_MASK))
-#define Fixnum_Fits(x) \
- ((((x) & SIGN_MASK) == 0) || \
- (((x) & SIGN_MASK) == SIGN_MASK))
+#if 0
+/* #ifdef __GNUC__
+ Still doesn't compile correctly as of GCC 1.35! */
-#define BYTES_TO_POINTERS(nbytes) \
- (((nbytes) + ((sizeof (Pointer)) - 1)) / (sizeof (Pointer)))
+#define FIXNUM_TO_LONG(fixnum) \
+ ({ \
+ long _temp = ((long) (OBJECT_DATUM (fixnum))); \
+ (((_temp & FIXNUM_SIGN_BIT) != 0) \
+ ? (_temp | (-1 << DATUM_LENGTH)) \
+ : _temp); \
+ })
-#define Is_Constant(address) \
+#else
+
+#define FIXNUM_TO_LONG(fixnum) \
+ ((FIXNUM_NEGATIVE_P (fixnum)) \
+ ? (((long) (OBJECT_DATUM (fixnum))) | ((long) (-1 << DATUM_LENGTH))) \
+ : ((long) (OBJECT_DATUM (fixnum))))
+
+#endif
+
+#define FIXNUM_TO_DOUBLE(fixnum) ((double) (FIXNUM_TO_LONG (fixnum)))
+
+#define DOUBLE_TO_FIXNUM_P(number) \
+ (((number) > (((double) SMALLEST_FIXNUM) - 0.5)) && \
+ ((number) < (((double) BIGGEST_FIXNUM) + 0.5)))
+
+#ifdef HAVE_DOUBLE_TO_LONG_BUG
+#define DOUBLE_TO_FIXNUM double_to_fixnum
+#else
+#define DOUBLE_TO_FIXNUM(number) (LONG_TO_FIXNUM ((long) (number)))
+#endif
+\f
+/* Bignum Operations */
+
+#define BIGNUM_ZERO_P(bignum) \
+ ((bignum_test (bignum)) == bignum_comparison_equal)
+
+#define BIGNUM_NEGATIVE_P(bignum) \
+ ((bignum_test (bignum)) == bignum_comparison_less)
+
+#define BIGNUM_POSITIVE_P(bignum) \
+ ((bignum_test (bignum)) == bignum_comparison_greater)
+
+#define BIGNUM_LESS_P(x, y) \
+ ((bignum_compare ((x), (y))) == bignum_comparison_less)
+
+#define BIGNUM_TO_LONG_P(bignum) \
+ (bignum_fits_in_word_p ((bignum), ((sizeof (long)) * CHAR_BIT), 1))
+
+/* If precision should not be lost,
+ compare to FLONUM_MANTISSA_BITS instead. */
+#define BIGNUM_TO_DOUBLE_P(bignum) \
+ (bignum_fits_in_word_p ((bignum), MAX_FLONUM_EXPONENT, 0))
+
+/* Flonum Operations */
+
+#define FLONUM_TO_DOUBLE(object) \
+ (* ((double *) (MEMORY_LOC ((object), 1))))
+
+#define FLOAT_TO_FLONUM(expression) \
+ (double_to_flonum ((double) (expression)))
+
+#define FLONUM_TRUNCATE(object) \
+ (double_to_flonum (double_truncate (FLONUM_TO_DOUBLE (object))))
+
+/* Numeric Type Conversions */
+
+#define BIGNUM_TO_FIXNUM_P(bignum) \
+ (bignum_fits_in_word_p ((bignum), (FIXNUM_LENGTH + 1), 1))
+
+#define FIXNUM_TO_BIGNUM(fixnum) (long_to_bignum (FIXNUM_TO_LONG (fixnum)))
+#define FIXNUM_TO_FLONUM(fixnum) (double_to_flonum (FIXNUM_TO_DOUBLE (fixnum)))
+#define BIGNUM_TO_FIXNUM(bignum) (LONG_TO_FIXNUM (bignum_to_long (bignum)))
+#define BIGNUM_TO_FLONUM_P BIGNUM_TO_DOUBLE_P
+#define BIGNUM_TO_FLONUM(bignum) (double_to_flonum (bignum_to_double (bignum)))
+#define FLONUM_TO_BIGNUM(flonum) (double_to_bignum (FLONUM_TO_DOUBLE (flonum)))
+#define FLONUM_TO_INTEGER(x) (double_to_integer (FLONUM_TO_DOUBLE (x)))
+#define INTEGER_TO_FLONUM_P integer_to_double_p
+#define INTEGER_TO_FLONUM(n) (double_to_flonum (integer_to_double (n)))
+\f
+#define BOOLEAN_TO_OBJECT(expression) ((expression) ? SHARP_T : SHARP_F)
+#define OBJECT_TO_BOOLEAN(object) ((object) != SHARP_F)
+
+#define MAKE_BROKEN_HEART(address) \
+ (BROKEN_HEART_ZERO + (ADDRESS_TO_DATUM (address)))
+
+#define BYTES_TO_WORDS(nbytes) \
+ (((nbytes) + ((sizeof (SCHEME_OBJECT)) - 1)) / (sizeof (SCHEME_OBJECT)))
+
+#define ADDRESS_CONSTANT_P(address) \
(((address) >= Constant_Space) && ((address) < Free_Constant))
-#define Is_Pure(address) \
- ((Is_Constant (address)) && (Pure_Test (address)))
+#define ADDRESS_PURE_P(address) \
+ ((ADDRESS_CONSTANT_P (address)) && (Pure_Test (address)))
-#define Side_Effect_Impurify(Old_Pointer, Will_Contain) \
-if ((Is_Constant (Get_Pointer (Old_Pointer))) && \
+#define SIDE_EFFECT_IMPURIFY(Old_Pointer, Will_Contain) \
+if ((ADDRESS_CONSTANT_P (OBJECT_ADDRESS (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); \
-\f
+ (! (ADDRESS_CONSTANT_P (OBJECT_ADDRESS (Will_Contain)))) && \
+ (Pure_Test (OBJECT_ADDRESS (Old_Pointer)))) \
+ signal_error_from_primitive (ERR_WRITE_INTO_PURE_SPACE); \
+
#ifdef FLOATING_ALIGNMENT
#define FLOATING_BUFFER_SPACE \
- ((FLOATING_ALIGNMENT + 1)/sizeof(Pointer))
+ ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT)))
#define HEAP_BUFFER_SPACE \
(TRAP_MAX_IMMEDIATE + 1 + FLOATING_BUFFER_SPACE)
/* The space is there, find the correct position. */
-#define Initial_Align_Float(Where) \
+#define INITIAL_ALIGN_FLOAT(Where) \
{ \
while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
Where -= 1; \
}
-#define Align_Float(Where) \
+#define ALIGN_FLOAT(Where) \
{ \
while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
- *Where++ = (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, 0)); \
+ *Where++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); \
}
#else not FLOATING_ALIGNMENT
#define HEAP_BUFFER_SPACE (TRAP_MAX_IMMEDIATE + 1)
-#define Initial_Align_Float(Where)
-#define Align_Float(Where)
+#define INITIAL_ALIGN_FLOAT(Where)
+#define ALIGN_FLOAT(Where)
#endif FLOATING_ALIGNMENT
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/ppband.c,v 9.34 1989/08/28 18:28:03 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/ppband.c,v 9.35 1989/09/20 23:04:42 cph Exp $
Copyright (c) 1987, 1989 Massachusetts Institute of Technology
\f
/* These are needed by load.c */
-static Pointer *Memory_Base;
+static SCHEME_OBJECT * memory_base;
long
Load_Data(Count, To_Where)
{
extern int fread();
- return (fread(To_Where, sizeof(Pointer), Count, stdin));
+ return (fread(To_Where, sizeof(SCHEME_OBJECT), Count, stdin));
}
long
#ifdef Heap_In_Low_Memory
#ifdef spectrum
-#define File_To_Pointer(P) ((((long) (P)) & ADDRESS_MASK) / sizeof(Pointer))
+#define File_To_Pointer(P) \
+ ((((long) (P)) & DATUM_MASK) / sizeof(SCHEME_OBJECT))
#else
-#define File_To_Pointer(P) ((P) / sizeof(Pointer))
+#define File_To_Pointer(P) ((P) / sizeof(SCHEME_OBJECT))
#endif /* spectrum */
#else
-#define File_To_Pointer(P) (P)
+#define File_To_Pointer(P) (P)
#endif
#ifndef Conditional_Bug
#define Relocate(P) (Relocate_Into(Relocate_Temp, P), Relocate_Temp)
#endif
-static Pointer *Data, *end_of_memory;
+static SCHEME_OBJECT *Data, *end_of_memory;
Boolean
scheme_string(From, Quoted)
Chars = ((char *) &Data[From + STRING_CHARS]);
if (Chars < ((char *) end_of_memory))
{
- Count = ((long) (Data[From + STRING_LENGTH]));
+ Count = ((long) (Data[From + STRING_LENGTH_INDEX]));
if (&Chars[Count] < ((char *) end_of_memory))
{
if (Quoted)
return (false);
}
-#define via(File_Address) Relocate(OBJECT_DATUM(Data[File_Address]))
+#define via(File_Address) Relocate(OBJECT_DATUM (Data[File_Address]))
void
scheme_symbol(From)
long From;
{
- Pointer *symbol;
+ SCHEME_OBJECT *symbol;
symbol = &Data[From+SYMBOL_NAME];
if ((symbol >= end_of_memory) ||
long Points_To;
printf("%5lx: %2lx|%6lx ", Location, Type, The_Datum);
- Points_To = Relocate((Pointer *) The_Datum);
+ Points_To = Relocate((SCHEME_OBJECT *) The_Datum);
switch (Type)
{ /* "Strange" cases */
case TC_NULL:
if (The_Datum == 0)
{
- printf("NIL\n");
+ printf("#F\n");
return;
}
NON_POINTER("NULL");
case TC_TRUE:
if (The_Datum == 0)
{
- printf("TRUE\n");
+ printf("#T\n");
return;
}
/* fall through */
scheme_symbol(Points_To);
return;
- case TC_UNINTERNED_SYMBOL:
+ case TC_UNINTERNED_SYMBOL:
PRINT_OBJECT("UNINTERNED-SYMBOL", Points_To);
printf(" = ");
scheme_symbol(Points_To);
case TC_FIXNUM:
PRINT_OBJECT("FIXNUM", The_Datum);
- Sign_Extend(The_Datum, Points_To);
+ Points_To = (FIXNUM_TO_LONG (The_Datum));
printf(" = %ld\n", Points_To);
return;
return;
}
\f
-Pointer *
+SCHEME_OBJECT *
show_area(area, start, end, name)
- fast Pointer *area;
+ fast SCHEME_OBJECT *area;
long start;
fast long end;
char *name;
printf("\n%s contents:\n\n", name);
for (i = start; i < end; area++, i++)
{
- if ((OBJECT_TYPE(*area) == TC_MANIFEST_NM_VECTOR) ||
- (OBJECT_TYPE(*area) == TC_MANIFEST_CLOSURE) ||
- (OBJECT_TYPE(*area) == TC_LINKAGE_SECTION))
+ if ((OBJECT_TYPE (*area) == TC_MANIFEST_NM_VECTOR) ||
+ (OBJECT_TYPE (*area) == TC_MANIFEST_CLOSURE) ||
+ (OBJECT_TYPE (*area) == TC_LINKAGE_SECTION))
{
fast long j, count;
count =
- ((OBJECT_TYPE(*area) == TC_LINKAGE_SECTION)
+ ((OBJECT_TYPE (*area) == TC_LINKAGE_SECTION)
? (READ_CACHE_LINKAGE_COUNT (*area))
: (OBJECT_DATUM (*area)));
- Display(i, OBJECT_TYPE(*area), OBJECT_DATUM(*area));
+ Display(i, OBJECT_TYPE (*area), OBJECT_DATUM (*area));
area += 1;
for (j = 0; j < count ; j++, area++)
{
printf(" %02lx%06lx\n",
- OBJECT_TYPE(*area), OBJECT_DATUM(*area));
+ OBJECT_TYPE (*area), OBJECT_DATUM (*area));
}
i += count;
area -= 1;
}
else
{
- Display(i, OBJECT_TYPE(*area), OBJECT_DATUM(*area));
+ Display(i, OBJECT_TYPE (*area), OBJECT_DATUM (*area));
}
}
return (area);
int argc;
char **argv;
{
- fast Pointer *Next;
+ fast SCHEME_OBJECT *Next;
long total_length, load_length;
if (argc == 1)
sscanf(argv[3], "%d", &Heap_Count);
printf("Heap Base = 0x%lx; Constant Base = 0x%lx; Heap Count = %ld\n",
Heap_Base, Const_Base, Heap_Count);
- }
+ }
\f
load_length = (Heap_Count + Const_Count + Primitive_Table_Size);
- Data = ((Pointer *) malloc(sizeof(Pointer) * (load_length + 4)));
+ Data = ((SCHEME_OBJECT *) malloc(sizeof(SCHEME_OBJECT) * (load_length + 4)));
if (Data == NULL)
{
fprintf(stderr, "Allocation of %ld words failed.\n", (load_length + 4));
fast long entries, count;
/* This is done in case the file is short. */
- end_of_memory[0] = ((Pointer) 0);
- end_of_memory[1] = ((Pointer) 0);
- end_of_memory[2] = ((Pointer) 0);
- end_of_memory[3] = ((Pointer) 0);
+ end_of_memory[0] = ((SCHEME_OBJECT) 0);
+ end_of_memory[1] = ((SCHEME_OBJECT) 0);
+ end_of_memory[2] = ((SCHEME_OBJECT) 0);
+ end_of_memory[3] = ((SCHEME_OBJECT) 0);
entries = Primitive_Table_Length;
printf("\nPrimitive table: number of entries = %ld\n\n", entries);
((count < entries) && (Next < end_of_memory));
count += 1)
{
- Sign_Extend(*Next++, arity);
+ arity = (FIXNUM_TO_LONG (*Next));
+ Next += 1;
size = (OBJECT_DATUM (*Next));
printf("Number = %3lx; Arity = %2ld; Name = ", count, arity);
scheme_string((Next - Data), true);
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prename.h,v 1.2 1988/05/13 03:01:07 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prename.h,v 1.3 1989/09/20 23:10:32 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
{ "SYSTEM-MEMORY-REF", "PRIMITIVE-OBJECT-REF" },
{ "SYSTEM-MEMORY-SET!", "PRIMITIVE-OBJECT-SET!" },
{ "OBJECT-NEW-TYPE", "OBJECT-SET-TYPE" },
- { "PRIMITIVE-OBJECT-NEW-TYPE", "PRIMITIVE-OBJECT-SET-TYPE" }
+ { "PRIMITIVE-OBJECT-NEW-TYPE", "PRIMITIVE-OBJECT-SET-TYPE" },
+ { "SINE-FLONUM", "FLONUM-SIN" },
+ { "COSINE-FLONUM", "FLONUM-COS" },
+ { "ATAN-FLONUM", "FLONUM-ATAN" },
+ { "EXP-FLONUM", "FLONUM-EXP" },
+ { "LN-FLONUM", "FLONUM-LOG" },
+ { "SQRT-FLONUM", "FLONUM-SQRT" },
+ { "PLUS-FLONUM", "FLONUM-ADD" },
+ { "MINUS-FLONUM", "FLONUM-SUBTRACT" },
+ { "MULTIPLY-FLONUM", "FLONUM-MULTIPLY" },
+ { "DIVIDE-FLONUM", "FLONUM-DIVIDE" },
+ { "ZERO-FLONUM?", "FLONUM-ZERO?" },
+ { "POSITIVE-FLONUM?", "FLONUM-POSITIVE?" },
+ { "NEGATIVE-FLONUM?", "FLONUM-NEGATIVE?" },
+ { "EQUAL-FLONUM?", "FLONUM-EQUAL?" },
+ { "LESS-THAN-FLONUM?", "FLONUM-LESS?" },
+ { "GREATER-THAN-FLONUM?", "FLONUM-GREATER?" },
+ { "TRUNCATE-FLONUM", "FLONUM-TRUNCATE->EXACT" }
};
-#define N_ALIASES 12
+#define N_ALIASES 29
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.c,v 9.32 1989/08/28 18:29:14 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.c,v 9.33 1989/09/20 23:10:35 cph Rel $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
\f
/* Low level object manipulation */
-/* (PRIMITIVE-OBJECT-TYPE OBJECT)
- Returns the type code of OBJECT as an unsigned integer. */
-
-DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-TYPE", Prim_prim_obj_type, 1, 1, 0)
+DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-TYPE", Prim_prim_obj_type, 1, 1,
+ "Return the type code of OBJECT as an unsigned integer.")
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (OBJECT_TYPE (ARG_REF (1))));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (OBJECT_TYPE (ARG_REF (1))));
}
-/* (PRIMITIVE-OBJECT-GC-TYPE OBJECT)
- Returns an unsigned integer indicating the GC type of the object. */
-
-DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-GC-TYPE", Prim_prim_obj_gc_type, 1, 1, 0)
+DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-GC-TYPE", Prim_prim_obj_gc_type, 1, 1,
+ "Return an unsigned integer indicating the GC type of the object.")
{
- PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN
- (MAKE_SIGNED_FIXNUM (GC_Type_Map [OBJECT_TYPE (ARG_REF (1))]));
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM (GC_Type_Map [OBJECT_TYPE (ARG_REF (1))]));
}
-/* (PRIMITIVE-OBJECT-TYPE? TYPE-CODE OBJECT)
- Return #T if the type code of OBJECT is TYPE-CODE, else #F. */
-
-DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-TYPE?", Prim_prim_obj_type_p, 2, 2, 0)
+DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-TYPE?", Prim_prim_obj_type_p, 2, 2,
+ "Return #T if TYPE-CODE is OBJECT's type code, else #F.")
{
PRIMITIVE_HEADER (2);
-
PRIMITIVE_RETURN
- (((OBJECT_TYPE (ARG_REF (2))) ==
- (arg_index_integer (1, (MAX_TYPE_CODE + 1))))
- ? SHARP_T
- : NIL);
+ (BOOLEAN_TO_OBJECT
+ ((OBJECT_TYPE (ARG_REF (2))) ==
+ (arg_index_integer (1, (MAX_TYPE_CODE + 1)))));
}
-/* (PRIMITIVE-OBJECT-DATUM OBJECT)
- Returns the datum part of OBJECT as an unsigned integer. */
-
-DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-DATUM", Prim_prim_obj_datum, 1, 1, 0)
+DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-DATUM", Prim_prim_obj_datum, 1, 1,
+ "Return the datum part of OBJECT as an unsigned integer.")
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (OBJECT_DATUM (ARG_REF (1))));
+ PRIMITIVE_RETURN (long_to_integer (OBJECT_DATUM (ARG_REF (1))));
}
-\f
+
DEFINE_PRIMITIVE ("MAKE-NON-POINTER-OBJECT", Prim_make_non_pointer_object, 1, 1,
"Convert the unsigned integer NUMBER into a fixnum.\n\
-The result has a fixnum type and a datum of NUMBER.")
+Assert: (= (OBJECT-DATUM (MAKE-NON-POINTER-OBJECT X)) X).")
{
- fast Pointer result;
- fast long datum;
PRIMITIVE_HEADER (1);
-
- datum = (object_to_long ((ARG_REF (1)),
- ERR_ARG_1_WRONG_TYPE,
- ERR_ARG_1_BAD_RANGE));
-
- result = (MAKE_FIXNUM (datum));
- if ((datum < 0) ||
- (!(FIXNUM_P(result))) ||
- ((OBJECT_DATUM(result)) != datum))
- {
- error_bad_range_arg (1);
- }
- PRIMITIVE_RETURN (result);
+ PRIMITIVE_RETURN
+ (LONG_TO_UNSIGNED_FIXNUM (arg_index_integer (1, (1 << DATUM_LENGTH))));
}
-/* (PRIMITIVE-OBJECT-SET-TYPE TYPE-CODE OBJECT)
- Returns a new object with TYPE-CODE and the datum part of OBJECT. */
-
-DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-SET-TYPE", Prim_prim_obj_set_type, 2, 2, 0)
+DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-SET-TYPE", Prim_prim_obj_set_type, 2, 2,
+ "Return a new object made from TYPE-CODE and the datum part of OBJECT.")
{
PRIMITIVE_HEADER (2);
-
PRIMITIVE_RETURN
- (Make_New_Pointer ((arg_index_integer (1, (MAX_TYPE_CODE + 1))),
- (ARG_REF (2))));
+ (OBJECT_NEW_TYPE
+ ((arg_index_integer (1, (MAX_TYPE_CODE + 1))), (ARG_REF (2))));
}
-/* (PRIMITIVE-OBJECT-EQ? OBJECT-1 OBJECT-2)
- Returns #T if the two objects have the same type code and datum.
- Returns #F otherwise. */
-
DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-EQ?", Prim_prim_obj_eq_p, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
-
- PRIMITIVE_RETURN (((ARG_REF (1)) == (ARG_REF (2))) ? SHARP_T : NIL);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((ARG_REF (1)) == (ARG_REF (2))));
}
\f
/* Low level memory references.
DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-REF", Prim_prim_obj_ref, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
-
- PRIMITIVE_RETURN (Vector_Ref ((ARG_REF (1)), (arg_nonnegative_integer (2))));
+ PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), (arg_nonnegative_integer (2))));
}
/* (PRIMITIVE-OBJECT-SET! OBJECT INDEX VALUE)
DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-SET!", Prim_prim_obj_set, 3, 3, 0)
{
- fast long index;
PRIMITIVE_HEADER (3);
-
- index = (arg_nonnegative_integer (2));
- PRIMITIVE_RETURN
- (Swap_Pointers (Nth_Vector_Loc ((ARG_REF (1)), index), (ARG_REF (3))));
+ MEMORY_SET ((ARG_REF (1)), (arg_nonnegative_integer (2)), (ARG_REF (3)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
+
/* Safe versions of the object manipulators.
These touch their arguments, and provide GC safety tests. */
DEFINE_PRIMITIVE ("OBJECT-TYPE", Prim_object_type, 1, 1, 0)
{
- fast Pointer object;
+ fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
-
- Touch_In_Primitive ((ARG_REF (1)), object);
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (OBJECT_TYPE (object)));
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (OBJECT_TYPE (object)));
}
DEFINE_PRIMITIVE ("OBJECT-GC-TYPE", Prim_object_gc_type, 1, 1, 0)
{
- fast Pointer object;
- PRIMITIVE_HEADER (1);
-
- Touch_In_Primitive ((ARG_REF (1)), object);
- PRIMITIVE_RETURN (MAKE_SIGNED_FIXNUM (GC_Type (object)));
+ fast SCHEME_OBJECT object;
+ PRIMITIVE_HEADER (1);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
+ PRIMITIVE_RETURN (LONG_TO_FIXNUM (GC_Type (object)));
}
DEFINE_PRIMITIVE ("OBJECT-TYPE?", Prim_object_type_p, 2, 2, 0)
{
- fast Pointer object;
+ fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (2);
-
- Touch_In_Primitive ((ARG_REF (2)), object);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (2)), object);
PRIMITIVE_RETURN
- (((OBJECT_TYPE (object)) ==
- (arg_index_integer (1, (MAX_TYPE_CODE + 1))))
- ? SHARP_T
- : NIL);
+ (BOOLEAN_TO_OBJECT
+ ((OBJECT_TYPE (object)) ==
+ (arg_index_integer (1, (MAX_TYPE_CODE + 1)))));
}
DEFINE_PRIMITIVE ("OBJECT-DATUM", Prim_object_datum, 1, 1, 0)
{
- fast Pointer object;
+ fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
-
- Touch_In_Primitive ((ARG_REF (1)), object);
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (OBJECT_DATUM (object)));
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
+ PRIMITIVE_RETURN (long_to_integer (OBJECT_DATUM (object)));
}
\f
DEFINE_PRIMITIVE ("OBJECT-SET-TYPE", Prim_object_set_type, 2, 2, 0)
{
fast long type_code;
- fast Pointer object;
+ fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (2);
-
type_code = (arg_index_integer (1, (MAX_TYPE_CODE + 1)));
- Touch_In_Primitive ((ARG_REF (2)), object);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (2)), object);
{
fast long gc_type_code;
(gc_type_code == (GC_Type (object))))))
error_bad_range_arg (1);
}
- PRIMITIVE_RETURN (Make_New_Pointer (type_code, object));
+ PRIMITIVE_RETURN (OBJECT_NEW_TYPE (type_code, object));
}
/* (EQ? OBJECT-1 OBJECT-2)
DEFINE_PRIMITIVE ("EQ?", Prim_eq, 2, 2, 0)
{
- fast Pointer object_1;
- fast Pointer object_2;
+ fast SCHEME_OBJECT object_1;
+ fast SCHEME_OBJECT object_2;
PRIMITIVE_HEADER (2);
-
- Touch_In_Primitive ((ARG_REF (1)), object_1);
- Touch_In_Primitive ((ARG_REF (2)), object_2);
- PRIMITIVE_RETURN ((object_1 == object_2) ? SHARP_T : NIL);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object_1);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (2)), object_2);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (object_1 == object_2));
}
/* (NOT OBJECT)
DEFINE_PRIMITIVE ("NOT", Prim_not, 1, 1, 0)
{
- fast Pointer object;
+ fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
-
- Touch_In_Primitive ((ARG_REF (1)), object);
- PRIMITIVE_RETURN ((object == NIL) ? SHARP_T : NIL);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (object == SHARP_F));
}
\f
/* Cells */
DEFINE_PRIMITIVE ("MAKE-CELL", Prim_make_cell, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
Primitive_GC_If_Needed (1);
(*Free++) = (ARG_REF (1));
- PRIMITIVE_RETURN (Make_Pointer (TC_CELL, (Free - 1)));
+ PRIMITIVE_RETURN (MAKE_POINTER_OBJECT (TC_CELL, (Free - 1)));
}
/* (CELL? OBJECT)
DEFINE_PRIMITIVE ("CELL?", Prim_cell_p, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN ((CELL_P (ARG_REF (1))) ? SHARP_T : NIL);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (CELL_P (ARG_REF (1))));
}
/* (CELL-CONTENTS CELL)
DEFINE_PRIMITIVE ("CELL-CONTENTS", Prim_cell_contents, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN (Vector_Ref ((CELL_ARG (1)), CELL_CONTENTS));
+ PRIMITIVE_RETURN (MEMORY_REF ((CELL_ARG (1)), CELL_CONTENTS));
}
/* (SET-CELL-CONTENTS! CELL OBJECT)
DEFINE_PRIMITIVE ("SET-CELL-CONTENTS!", Prim_set_cell_contents, 2, 2, 0)
{
- fast Pointer cell;
- fast Pointer object;
+ fast SCHEME_OBJECT cell;
+ fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (2);
-
cell = (CELL_ARG (1));
object = (ARG_REF (2));
- Side_Effect_Impurify (cell, object);
- PRIMITIVE_RETURN
- (Swap_Pointers ((Nth_Vector_Loc (cell, CELL_CONTENTS)), object));
+ SIDE_EFFECT_IMPURIFY (cell, object);
+ MEMORY_SET (cell, CELL_CONTENTS, object);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.h,v 9.41 1989/09/20 23:10:39 cph Rel $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.h,v 9.40 1988/08/15 20:52:55 cph Rel $ */
-\f
-/*
- Primitive declarations.
-
+/* Primitive declarations.
Note that the following cannot be changed without changing
- Findprim.c.
-*/
+ Findprim.c. */
-extern Pointer (*(Primitive_Procedure_Table[]))();
+extern SCHEME_OBJECT (*(Primitive_Procedure_Table[]))();
extern int Primitive_Arity_Table[];
extern int Primitive_Count_Table[];
extern char *Primitive_Name_Table[];
extern char *Primitive_Documentation_Table[];
extern long MAX_PRIMITIVE;
-#define CHUNK_SIZE 20 /* Grow undefined vector by this much */
+#define CHUNK_SIZE 20 /* Grow undefined vector by this much */
-extern Pointer Undefined_Primitives;
-extern Pointer Undefined_Primitives_Arity;
+extern SCHEME_OBJECT Undefined_Primitives;
+extern SCHEME_OBJECT Undefined_Primitives_Arity;
/* Utility macros */
#define NUMBER_OF_DEFINED_PRIMITIVES() (MAX_PRIMITIVE + 1)
-#define NUMBER_OF_UNDEFINED_PRIMITIVES() \
-((Undefined_Primitives == NIL) ? \
- 0 : \
- Get_Integer(User_Vector_Ref(Undefined_Primitives, 0)))
+#define NUMBER_OF_UNDEFINED_PRIMITIVES() \
+ ((Undefined_Primitives == SHARP_F) \
+ ? 0 \
+ : (UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF (Undefined_Primitives, 0))))
-#define NUMBER_OF_PRIMITIVES() \
-(NUMBER_OF_UNDEFINED_PRIMITIVES() + \
- NUMBER_OF_DEFINED_PRIMITIVES())
+#define NUMBER_OF_PRIMITIVES() \
+ ((NUMBER_OF_UNDEFINED_PRIMITIVES ()) + (NUMBER_OF_DEFINED_PRIMITIVES ()))
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 9.36 1989/09/20 23:10:42 cph Exp $
+
Copyright (c) 1987, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 9.35 1989/08/28 18:29:17 cph Exp $ */
-
/* This file contains some macros for defining primitives,
for argument type or value checking, and for accessing
the arguments. */
\f
/* Definition of primitives. */
-#define DEFINE_PRIMITIVE(scheme_name, fn_name, min_args, max_args, doc_string) \
-extern Pointer fn_name (); \
-Pointer fn_name ()
+#define DEFINE_PRIMITIVE(scheme_name, fn_name, min_args, max_args, doc) \
+extern SCHEME_OBJECT fn_name (); \
+SCHEME_OBJECT fn_name ()
/* Can be used for `max_args' in `DEFINE_PRIMITIVE' to indicate that
the primitive has no upper limit on its arity. */
#define LEXPR (-1)
-/* This form is obsolete. Use DEFINE_PRIMITIVE instead. */
-#define Define_Primitive(fn_name, arity, scheme_name) \
- DEFINE_PRIMITIVE (scheme_name, fn_name, arity, arity, 0)
-
+/* Primitives should have this as their first statement. */
#ifdef ENABLE_PRIMITIVE_PROFILING
-#define primitive_entry_hook() record_primitive_entry (Fetch_Expression ())
+#define PRIMITIVE_HEADER(n_args) record_primitive_entry (Fetch_Expression ())
#else
-#define primitive_entry_hook() {}
+#define PRIMITIVE_HEADER(n_args) {}
#endif
-/* This is new header for primitives, which gives better control over
- variable allocation than older `Primitive_N_Args' macros. */
-
-#define PRIMITIVE_HEADER(n_args) primitive_entry_hook ()
-
/* Primitives return by performing one of the following operations. */
-
#define PRIMITIVE_RETURN(value) return (value)
+#define PRIMITIVE_ABORT(action) longjmp ((*Back_To_Eval), (action))
-#define PRIMITIVE_ABORT(action) longjmp(*Back_To_Eval, (action))
-
-extern void canonicalize_primitive_context();
-
-#define PRIMITIVE_CANONICALIZE_CONTEXT() \
-{ \
- canonicalize_primitive_context(); \
-}
-\f
-/* Preambles for primitive procedures. These store the arguments into
- * local variables for fast access.
- */
-
-#define Primitive_0_Args() primitive_entry_hook ()
-
-#define Primitive_1_Args() fast Pointer Arg1 = Stack_Ref(0); \
- primitive_entry_hook ()
+extern void canonicalize_primitive_context ();
+#define PRIMITIVE_CANONICALIZE_CONTEXT canonicalize_primitive_context
-#define Primitive_1_Arg() Primitive_1_Args()
-
-#define Primitive_2_Args() fast Pointer Arg1 = Stack_Ref(0); \
- fast Pointer Arg2 = Stack_Ref(1); \
- primitive_entry_hook ()
-
-#define Primitive_3_Args() fast Pointer Arg1 = Stack_Ref(0); \
- fast Pointer Arg2 = Stack_Ref(1); \
- fast Pointer Arg3 = Stack_Ref(2); \
- primitive_entry_hook ()
-
-#define Primitive_4_Args() fast Pointer Arg1 = Stack_Ref(0); \
- fast Pointer Arg2 = Stack_Ref(1); \
- fast Pointer Arg3 = Stack_Ref(2); \
- fast Pointer Arg4 = Stack_Ref(3); \
- primitive_entry_hook ()
-
-#define Primitive_5_Args() fast Pointer Arg1 = Stack_Ref(0); \
- fast Pointer Arg2 = Stack_Ref(1); \
- fast Pointer Arg3 = Stack_Ref(2); \
- fast Pointer Arg4 = Stack_Ref(3); \
- fast Pointer Arg5 = Stack_Ref(4); \
- primitive_entry_hook ()
-
-#define Primitive_6_Args() fast Pointer Arg1 = Stack_Ref(0); \
- fast Pointer Arg2 = Stack_Ref(1); \
- fast Pointer Arg3 = Stack_Ref(2); \
- fast Pointer Arg4 = Stack_Ref(3); \
- fast Pointer Arg5 = Stack_Ref(4); \
- fast Pointer Arg6 = Stack_Ref(5); \
- primitive_entry_hook ()
-\f
-#define Primitive_7_Args() fast Pointer Arg1 = Stack_Ref(0); \
- fast Pointer Arg2 = Stack_Ref(1); \
- fast Pointer Arg3 = Stack_Ref(2); \
- fast Pointer Arg4 = Stack_Ref(3); \
- fast Pointer Arg5 = Stack_Ref(4); \
- fast Pointer Arg6 = Stack_Ref(5); \
- fast Pointer Arg7 = Stack_Ref(6); \
- primitive_entry_hook ()
-
-#define Primitive_8_Args() fast Pointer Arg1 = Stack_Ref(0); \
- fast Pointer Arg2 = Stack_Ref(1); \
- fast Pointer Arg3 = Stack_Ref(2); \
- fast Pointer Arg4 = Stack_Ref(3); \
- fast Pointer Arg5 = Stack_Ref(4); \
- fast Pointer Arg6 = Stack_Ref(5); \
- fast Pointer Arg7 = Stack_Ref(6); \
- fast Pointer Arg8 = Stack_Ref(7); \
- primitive_entry_hook ()
-
-#define Primitive_9_Args() fast Pointer Arg1 = Stack_Ref(0); \
- fast Pointer Arg2 = Stack_Ref(1); \
- fast Pointer Arg3 = Stack_Ref(2); \
- fast Pointer Arg4 = Stack_Ref(3); \
- fast Pointer Arg5 = Stack_Ref(4); \
- fast Pointer Arg6 = Stack_Ref(5); \
- fast Pointer Arg7 = Stack_Ref(6); \
- fast Pointer Arg8 = Stack_Ref(7); \
- fast Pointer Arg9 = Stack_Ref(8); \
- primitive_entry_hook ()
-
-#define Primitive_10_Args() fast Pointer Arg1 = Stack_Ref(0); \
- fast Pointer Arg2 = Stack_Ref(1); \
- fast Pointer Arg3 = Stack_Ref(2); \
- fast Pointer Arg4 = Stack_Ref(3); \
- fast Pointer Arg5 = Stack_Ref(4); \
- fast Pointer Arg6 = Stack_Ref(5); \
- fast Pointer Arg7 = Stack_Ref(6); \
- fast Pointer Arg8 = Stack_Ref(7); \
- fast Pointer Arg9 = Stack_Ref(8); \
- fast Pointer Arg10 = Stack_Ref(9); \
- primitive_entry_hook ()
-\f
/* Various utilities */
-#define Primitive_Error signal_error_from_primitive
-#define Primitive_Interrupt signal_interrupt_from_primitive
-
#define Primitive_GC(Amount) \
{ \
Request_GC (Amount); \
- Primitive_Interrupt (); \
+ signal_interrupt_from_primitive (); \
}
#define Primitive_GC_If_Needed(Amount) \
{ \
- if (GC_Check (Amount)) Primitive_GC(Amount); \
+ if (GC_Check (Amount)) Primitive_GC (Amount); \
}
-#define Range_Check(To_Where, P, Low, High, Error) \
-{ \
- To_Where = UNSIGNED_FIXNUM_VALUE (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); \
-}
-
-#define CHECK_ARG(argument, type_p) \
-do \
+#define CHECK_ARG(argument, type_p) do \
{ \
if (! (type_p (ARG_REF (argument)))) \
error_wrong_type_arg (argument); \
#define ARG_LOC(argument) (STACK_LOC (argument - 1))
#define ARG_REF(argument) (STACK_REF (argument - 1))
-
#define LEXPR_N_ARGUMENTS() (Regs [REGBLOCK_LEXPR_ACTUALS])
-
+\f
+extern void signal_error_from_primitive ();
+extern void signal_interrupt_from_primitive ();
+extern void error_wrong_type_arg ();
+extern void error_bad_range_arg ();
+extern void error_external_return ();
+extern long arg_integer ();
extern long arg_nonnegative_integer ();
extern long arg_index_integer ();
-extern long object_to_long ();
-extern Pointer allocate_non_marked_vector ();
-extern Pointer allocate_marked_vector ();
-\f
-/* Instances of the following should be flushed. */
-
-#define Arg_1_Type(TC) \
-do { if ((OBJECT_TYPE (Arg1)) != (TC)) error_wrong_type_arg (1); } while (0)
-
-#define Arg_2_Type(TC) \
-do { if ((OBJECT_TYPE (Arg2)) != (TC)) error_wrong_type_arg (2); } while (0)
-
-#define Arg_3_Type(TC) \
-do { if ((OBJECT_TYPE (Arg3)) != (TC)) error_wrong_type_arg (3); } while (0)
-
-#define Arg_4_Type(TC) \
-do { if ((OBJECT_TYPE (Arg4)) != (TC)) error_wrong_type_arg (4); } while (0)
-
-#define Arg_5_Type(TC) \
-do { if ((OBJECT_TYPE (Arg5)) != (TC)) error_wrong_type_arg (5); } while (0)
-
-#define Arg_6_Type(TC) \
-do { if ((OBJECT_TYPE (Arg6)) != (TC)) error_wrong_type_arg (6); } while (0)
-
-#define Arg_7_Type(TC) \
-do { if ((OBJECT_TYPE (Arg7)) != (TC)) error_wrong_type_arg (7); } while (0)
-
-#define Arg_8_Type(TC) \
-do { if ((OBJECT_TYPE (Arg8)) != (TC)) error_wrong_type_arg (8); } while (0)
-
-#define Arg_9_Type(TC) \
-do { if ((OBJECT_TYPE (Arg9)) != (TC)) error_wrong_type_arg (9); } while (0)
-
-#define Arg_10_Type(TC) \
-do { if ((OBJECT_TYPE (Arg10)) != (TC)) error_wrong_type_arg (10); } while (0)
-
-
-#define Arg_1_GC_Type(GCTC) \
-do { if ((GC_Type (Arg1)) != GCTC) error_wrong_type_arg (1); } while (0)
-
-#define Arg_2_GC_Type(GCTC) \
-do { if ((GC_Type (Arg2)) != GCTC) error_wrong_type_arg (2); } while (0)
-
-#define Arg_3_GC_Type(GCTC) \
-do { if ((GC_Type (Arg3)) != GCTC) error_wrong_type_arg (3); } while (0)
-\f
-#define FIXNUM_ARG arg_fixnum
+extern long arg_integer_in_range ();
+extern double arg_real_number ();
+extern double arg_real_in_range ();
+extern long arg_ascii_char ();
+extern long arg_ascii_integer ();
#define UNSIGNED_FIXNUM_ARG(arg) \
((FIXNUM_P (ARG_REF (arg))) \
- ? (UNSIGNED_FIXNUM_VALUE (ARG_REF (arg))) \
- : ((long) (error_wrong_type_arg (arg))))
+ ? (UNSIGNED_FIXNUM_TO_LONG (ARG_REF (arg))) \
+ : ((error_wrong_type_arg (arg)), 0))
#define STRING_ARG(arg) \
((STRING_P (ARG_REF (arg))) \
- ? (Scheme_String_To_C_String (ARG_REF (arg))) \
- : ((char *) (error_wrong_type_arg (arg))))
+ ? ((char *) (STRING_LOC ((ARG_REF (arg)), 0))) \
+ : ((error_wrong_type_arg (arg)), ((char *) 0)))
-#define BOOLEAN_ARG(arg) ((ARG_REF (arg)) != NIL)
+#define BOOLEAN_ARG(arg) ((ARG_REF (arg)) != SHARP_F)
#define CELL_ARG(arg) \
((CELL_P (ARG_REF (arg))) \
? (ARG_REF (arg)) \
- : ((Pointer) (error_wrong_type_arg (arg))))
+ : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0)))
#define PAIR_ARG(arg) \
((PAIR_P (ARG_REF (arg))) \
? (ARG_REF (arg)) \
- : ((Pointer) (error_wrong_type_arg (arg))))
+ : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0)))
#define WEAK_PAIR_ARG(arg) \
((WEAK_PAIR_P (ARG_REF (arg))) \
? (ARG_REF (arg)) \
- : ((Pointer) (error_wrong_type_arg (arg))))
+ : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0)))
#define VECTOR_ARG(arg) \
((VECTOR_P (ARG_REF (arg))) \
? (ARG_REF (arg)) \
- : ((Pointer) (error_wrong_type_arg (arg))))
+ : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0)))
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/primutl.c,v 9.50 1989/05/04 15:13:50 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/primutl.c,v 9.51 1989/09/20 23:10:47 cph Exp $
*
* This file contains the support routines for mapping primitive names
* to numbers within the microcode. Primitives are written in C
#include "prims.h"
#include <ctype.h>
\f
-Pointer Undefined_Primitives = NIL;
-Pointer Undefined_Primitives_Arity = NIL;
+SCHEME_OBJECT Undefined_Primitives = SHARP_F;
+SCHEME_OBJECT Undefined_Primitives_Arity = SHARP_F;
/* Common utilities. */
/* This version performs a log (base 2) search.
The table is assumed to be ordered alphabetically.
*/
-
+
long
primitive_name_to_code(name, table, size)
char *name;
}
else
{
- Pointer entry;
+ SCHEME_OBJECT entry;
long arity;
- entry = User_Vector_Ref(Undefined_Primitives_Arity,
- (number - MAX_PRIMITIVE));
- if (entry == NIL)
+ entry = VECTOR_REF (Undefined_Primitives_Arity, (number - MAX_PRIMITIVE));
+ if (entry == SHARP_F)
{
return ((long) UNKNOWN_PRIMITIVE_ARITY);
}
else
{
- Sign_Extend(entry, arity);
+ arity = FIXNUM_TO_LONG (entry);
}
return (arity);
}
\f
/* Externally visible utilities */
-extern Pointer make_primitive();
+extern SCHEME_OBJECT make_primitive();
-Pointer
+SCHEME_OBJECT
make_primitive(name)
char *name;
{
- Pointer search_for_primitive();
+ SCHEME_OBJECT search_for_primitive();
- return (search_for_primitive(NIL, name, true, true,
+ return (search_for_primitive(SHARP_F, name, true, true,
UNKNOWN_PRIMITIVE_ARITY));
}
-extern Pointer find_primitive();
+extern SCHEME_OBJECT find_primitive();
-Pointer
+SCHEME_OBJECT
find_primitive(name, intern_p, allow_p, arity)
- Pointer name;
+ SCHEME_OBJECT name;
Boolean intern_p, allow_p;
int arity;
{
- Pointer search_for_primitive();
+ SCHEME_OBJECT search_for_primitive();
- return (search_for_primitive(name, Scheme_String_To_C_String(name),
+ return (search_for_primitive(name, (STRING_LOC (name, 0)),
intern_p, allow_p, arity));
}
\f
long
primitive_to_arity(primitive)
- Pointer primitive;
+ SCHEME_OBJECT primitive;
{
return (primitive_code_to_arity(PRIMITIVE_NUMBER(primitive)));
}
char *
primitive_to_documentation (primitive)
- Pointer primitive;
+ SCHEME_OBJECT primitive;
{
return (primitive_code_to_documentation (PRIMITIVE_NUMBER (primitive)));
}
long
primitive_to_arguments(primitive)
- Pointer primitive;
+ SCHEME_OBJECT primitive;
{
long arity;
this code will still work because the characters will still be there.
*/
- Pointer scheme_string;
+ SCHEME_OBJECT scheme_string;
- scheme_string = User_Vector_Ref(Undefined_Primitives,
- (code - MAX_PRIMITIVE));
- string = Scheme_String_To_C_String(scheme_string);
+ scheme_string = VECTOR_REF (Undefined_Primitives, (code - MAX_PRIMITIVE));
+ string = ((char *) (STRING_LOC (scheme_string, 0)));
}
return (string);
}
char *
primitive_to_name(primitive)
- Pointer primitive;
+ SCHEME_OBJECT primitive;
{
return (primitive_code_to_name(PRIMITIVE_NUMBER(primitive)));
}
/* this avoids some consing. */
-Pointer
+SCHEME_OBJECT
primitive_name(code)
int code;
{
- Pointer scheme_string;
+ SCHEME_OBJECT scheme_string;
if (code <= MAX_PRIMITIVE)
{
- scheme_string = C_String_To_Scheme_String(Primitive_Name_Table[code]);
+ scheme_string = char_pointer_to_string(Primitive_Name_Table[code]);
}
else
{
- scheme_string = User_Vector_Ref(Undefined_Primitives,
- (code - MAX_PRIMITIVE));
+ scheme_string = VECTOR_REF (Undefined_Primitives, (code - MAX_PRIMITIVE));
}
return (scheme_string);
}
\f
/*
- scheme_name can be NIL, meaning cons up from c_name as needed.
+ scheme_name can be #F, meaning cons up from c_name as needed.
c_name must always be provided.
*/
-Pointer
+SCHEME_OBJECT
search_for_primitive(scheme_name, c_name, intern_p, allow_p, arity)
- Pointer scheme_name;
+ SCHEME_OBJECT scheme_name;
char *c_name;
Boolean intern_p, allow_p;
int arity;
{
long i, Max, old_arity;
- Pointer *Next;
+ SCHEME_OBJECT *Next;
i = primitive_name_to_code(c_name,
&Primitive_Name_Table[0],
}
else
{
- return (MAKE_SIGNED_FIXNUM(old_arity));
+ return (LONG_TO_FIXNUM(old_arity));
}
}
/* Search the undefined primitives table if allowed. */
if (!allow_p)
{
- return (NIL);
+ return (SHARP_F);
}
\f
/* The vector should be sorted for faster comparison. */
Max = NUMBER_OF_UNDEFINED_PRIMITIVES();
if (Max > 0)
{
- Next = Nth_Vector_Loc(Undefined_Primitives, 2);
+ Next = MEMORY_LOC (Undefined_Primitives, 2);
for (i = 1; i <= Max; i++)
{
- Pointer temp;
+ SCHEME_OBJECT temp;
temp = *Next++;
- if (strcmp_ci(c_name, Scheme_String_To_C_String(temp)) == 0)
+ if (strcmp_ci(c_name, (STRING_LOC (temp, 0))) == 0)
{
if (arity != UNKNOWN_PRIMITIVE_ARITY)
{
- temp = User_Vector_Ref(Undefined_Primitives_Arity, i);
- if (temp == NIL)
- {
- User_Vector_Set(Undefined_Primitives_Arity,
- i,
- MAKE_SIGNED_FIXNUM(arity));
- }
+ temp = VECTOR_REF (Undefined_Primitives_Arity, i);
+ if (temp == SHARP_F)
+ VECTOR_SET
+ (Undefined_Primitives_Arity, i, (LONG_TO_FIXNUM (arity)));
else
{
- Sign_Extend(temp, old_arity);
+ old_arity = FIXNUM_TO_LONG (temp);
if (arity != old_arity)
{
return (temp);
if (!intern_p)
{
- return (NIL);
+ return (SHARP_F);
}
- if (scheme_name == NIL)
+ if (scheme_name == SHARP_F)
{
- scheme_name = C_String_To_Scheme_String(c_name);
+ scheme_name = char_pointer_to_string(c_name);
}
\f
if ((Max % CHUNK_SIZE) == 0)
- {
- Primitive_GC_If_Needed(2 * (Max + CHUNK_SIZE + 2));
- if (Max > 0)
- {
- Next = Nth_Vector_Loc(Undefined_Primitives, 2);
- }
- Undefined_Primitives = Make_Pointer(TC_VECTOR, Free);
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, (Max + CHUNK_SIZE + 1));
- *Free++ = Make_Unsigned_Fixnum(Max + 1);
- for (i = 0; i < Max; i++)
- {
- *Free++ = Fetch(*Next++);
- }
- *Free++ = scheme_name;
- for (i = 1; i < CHUNK_SIZE; i++)
- {
- *Free++ = NIL;
- }
- if (Max > 0)
- {
- Next = Nth_Vector_Loc(Undefined_Primitives_Arity, 2);
- }
- Undefined_Primitives_Arity = Make_Pointer(TC_VECTOR, Free);
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, (Max + CHUNK_SIZE + 1));
- *Free++ = NIL;
- for (i = 0; i < Max; i++)
- {
- *Free++ = Fetch(*Next++);
- }
- *Free++ = ((arity != UNKNOWN_PRIMITIVE_ARITY) ?
- (MAKE_SIGNED_FIXNUM(arity)) :
- NIL);
- for (i = 1; i < CHUNK_SIZE; i++)
{
- *Free++ = NIL;
+ if (Max > 0)
+ Next = (MEMORY_LOC (Undefined_Primitives, 2));
+ Undefined_Primitives =
+ (allocate_marked_vector (TC_VECTOR, (Max + CHUNK_SIZE + 1), true));
+ FAST_MEMORY_SET
+ (Undefined_Primitives, 1, (LONG_TO_UNSIGNED_FIXNUM (Max + 1)));
+ for (i = 0; (i < Max); i += 1)
+ FAST_MEMORY_SET
+ (Undefined_Primitives, (i + 2), (MEMORY_FETCH (*Next++)));
+ FAST_MEMORY_SET (Undefined_Primitives, (Max + 2), scheme_name);
+ for (i = 1; (i < CHUNK_SIZE); i += 1)
+ FAST_MEMORY_SET (Undefined_Primitives, (i + Max + 2), SHARP_F);
+
+ if (Max > 0)
+ Next = (MEMORY_LOC (Undefined_Primitives_Arity, 2));
+ Undefined_Primitives_Arity =
+ (allocate_marked_vector (TC_VECTOR, (Max + CHUNK_SIZE + 1), true));
+ FAST_MEMORY_SET (Undefined_Primitives_Arity, 1, SHARP_F);
+ for (i = 0; (i < Max); i += 1)
+ FAST_MEMORY_SET
+ (Undefined_Primitives_Arity, (i + 2), (MEMORY_FETCH (*Next++)));
+ FAST_MEMORY_SET
+ (Undefined_Primitives_Arity,
+ (Max + 2),
+ ((arity != UNKNOWN_PRIMITIVE_ARITY)
+ ? (LONG_TO_FIXNUM (arity))
+ : SHARP_F));
+ for (i = 1; (i < CHUNK_SIZE); i += 1)
+ FAST_MEMORY_SET (Undefined_Primitives, (i + Max + 2), SHARP_F);
+
+ Max += 1;
}
- Max += 1;
- }
else
{
Max += 1;
- User_Vector_Set(Undefined_Primitives, Max, scheme_name);
+ VECTOR_SET (Undefined_Primitives, Max, scheme_name);
if (arity != UNKNOWN_PRIMITIVE_ARITY)
{
- User_Vector_Set(Undefined_Primitives_Arity,
- Max,
- MAKE_SIGNED_FIXNUM(arity));
+ VECTOR_SET (Undefined_Primitives_Arity, Max, (LONG_TO_FIXNUM (arity)));
}
- User_Vector_Set(Undefined_Primitives, 0, (MAKE_UNSIGNED_FIXNUM(Max)));
+ VECTOR_SET (Undefined_Primitives, 0, (LONG_TO_UNSIGNED_FIXNUM(Max)));
}
return (MAKE_PRIMITIVE_OBJECT((MAX_PRIMITIVE + Max), (MAX_PRIMITIVE + 1)));
}
\f
/* Dumping and loading primitive object references. */
-extern Pointer
+extern SCHEME_OBJECT
*load_renumber_table,
dump_renumber_primitive(),
*initialize_primitive_table(),
extern void install_primitive_table();
-Pointer *load_renumber_table;
-static Pointer *internal_renumber_table;
-static Pointer *external_renumber_table;
+SCHEME_OBJECT *load_renumber_table;
+static SCHEME_OBJECT *internal_renumber_table;
+static SCHEME_OBJECT *external_renumber_table;
static long next_primitive_renumber;
-Pointer *
+SCHEME_OBJECT *
initialize_primitive_table(where, end)
- fast Pointer *where;
- Pointer *end;
+ fast SCHEME_OBJECT *where;
+ SCHEME_OBJECT *end;
{
- Pointer *top;
+ SCHEME_OBJECT *top;
fast long number_of_primitives;
number_of_primitives = NUMBER_OF_PRIMITIVES();
next_primitive_renumber = 0;
while (--number_of_primitives >= 0)
- {
- *where++ = NIL;
- }
+ (*where++) = SHARP_F;
}
return (top);
}
\f
-Pointer
+SCHEME_OBJECT
dump_renumber_primitive(primitive)
- fast Pointer primitive;
+ fast SCHEME_OBJECT primitive;
{
fast long number;
- fast Pointer result;
+ fast SCHEME_OBJECT result;
number = PRIMITIVE_NUMBER(primitive);
result = internal_renumber_table[number];
- if (result == NIL)
+ if (result == SHARP_F)
{
- result = Make_Non_Pointer(OBJECT_TYPE(primitive),
- next_primitive_renumber);
+ result = (OBJECT_NEW_DATUM (primitive, next_primitive_renumber));
internal_renumber_table[number] = result;
external_renumber_table[next_primitive_renumber] = primitive;
next_primitive_renumber += 1;
}
else
{
- return (Make_New_Pointer(OBJECT_TYPE(primitive), result));
+ return (MAKE_OBJECT_FROM_OBJECTS (primitive, result));
}
}
-Pointer *
+/* Is supposed to have a null character. */
+static char null_string [] = "";
+
+SCHEME_OBJECT *
copy_primitive_information(code, start, end)
long code;
- fast Pointer *start, *end;
+ fast SCHEME_OBJECT * start;
+ fast SCHEME_OBJECT * end;
{
- extern Pointer *copy_c_string_to_scheme_string();
-
if (start < end)
+ (*start++) = (LONG_TO_FIXNUM (primitive_code_to_arity ((int) code)));
{
- *start++ = MAKE_SIGNED_FIXNUM(primitive_code_to_arity(((int) code)));
+ fast char * source = (primitive_code_to_name ((int) code));
+ SCHEME_OBJECT * saved = start;
+ start += STRING_CHARS;
+ {
+ fast char * dest = ((char *) start);
+ fast char * limit = ((char *) end);
+ if (source == ((char *) 0))
+ source = ((char *) (& (null_string [0])));
+ while ((dest < limit) && (((*dest++) = (*source++)) != '\0'))
+ ;
+ if (dest >= limit)
+ while ((*source++) != '\0')
+ dest += 1;
+ {
+ long char_count = ((dest - 1) - ((char *) start));
+ long word_count = (STRING_LENGTH_TO_GC_LENGTH (char_count));
+ start = (saved + 1 + word_count);
+ if (start < end)
+ {
+ (saved [STRING_HEADER]) =
+ (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, word_count));
+ (saved [STRING_LENGTH_INDEX]) = ((SCHEME_OBJECT) char_count);
+ }
+ return (start);
+ }
+ }
}
- return
- copy_c_string_to_scheme_string(primitive_code_to_name(((int) code)),
- start,
- end);
}
\f
-Pointer *
+SCHEME_OBJECT *
cons_primitive_table(start, end, length)
- Pointer *start, *end;
+ SCHEME_OBJECT *start, *end;
long *length;
{
- Pointer *saved;
+ SCHEME_OBJECT *saved;
long count, code;
saved = start;
return (start);
}
-Pointer *
+SCHEME_OBJECT *
cons_whole_primitive_table(start, end, length)
- Pointer *start, *end;
+ SCHEME_OBJECT *start, *end;
long *length;
{
- Pointer *saved;
+ SCHEME_OBJECT *saved;
long count, number_of_primitives;
number_of_primitives = NUMBER_OF_PRIMITIVES();
\f
void
install_primitive_table(table, length, flush_p)
- fast Pointer *table;
+ fast SCHEME_OBJECT *table;
fast long length;
Boolean flush_p;
{
- fast Pointer *translation_table;
- Pointer result;
+ fast SCHEME_OBJECT *translation_table;
+ SCHEME_OBJECT result;
long arity;
if (flush_p)
{
- Undefined_Primitives = NIL;
- Undefined_Primitives_Arity = NIL;
+ Undefined_Primitives = SHARP_F;
+ Undefined_Primitives_Arity = SHARP_F;
}
translation_table = load_renumber_table;
while (--length >= 0)
{
- Sign_Extend(*table, arity);
+ arity = FIXNUM_TO_LONG (*table);
table += 1;
result =
- search_for_primitive(Make_Pointer(TC_CHARACTER_STRING, table),
+ search_for_primitive(MAKE_POINTER_OBJECT (TC_CHARACTER_STRING, table),
((char *) (&table[STRING_CHARS])),
true, true, arity);
- if (OBJECT_TYPE(result) != TC_PRIMITIVE)
+ if (OBJECT_TYPE (result) != TC_PRIMITIVE)
{
- Primitive_Error(ERR_WRONG_ARITY_PRIMITIVES);
+ signal_error_from_primitive (ERR_WRONG_ARITY_PRIMITIVES);
}
*translation_table++ = result;
- table += (1 + OBJECT_DATUM(*table));
+ table += (1 + OBJECT_DATUM (*table));
}
return;
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/pruxfs.c,v 9.35 1989/08/07 03:14:18 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/pruxfs.c,v 9.36 1989/09/20 23:12:43 cph Exp $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
-#include "string.h"
#include <pwd.h>
#include <grp.h>
#include <sys/types.h>
/* This returns the string that `perror' would have printed, except
that it is not terminated by a newline. */
-Pointer
+SCHEME_OBJECT
system_error_message (s)
char * s;
{
char * error_message;
char unknown_error [64];
extern char * malloc ();
- Pointer result;
+ SCHEME_OBJECT result;
if ((errno >= 0) && (errno <= sys_nerr))
error_message = (sys_errlist [errno]);
if (s == NULL)
{
result = (allocate_string (strlen (error_message)));
- strcpy ((string_pointer (result, 0)), error_message);
+ strcpy ((STRING_LOC (result, 0)), error_message);
}
else
{
result = (allocate_string ((strlen (s)) + (strlen (error_message)) + 2));
- sprintf ((string_pointer (result, 0)), "%s: %s", s, error_message);
+ sprintf ((STRING_LOC (result, 0)), "%s: %s", s, error_message);
}
return (result);
}
char * variable_value;
extern char * getenv ();
PRIMITIVE_HEADER (1);
-
- CHECK_ARG (1, STRING_P);
- variable_value = (getenv (Scheme_String_To_C_String (ARG_REF (1))));
+ variable_value = (getenv (STRING_ARG (1)));
PRIMITIVE_RETURN
- ((variable_value == NULL)
+ ((variable_value == ((char *) 0))
? SHARP_F
- : (C_String_To_Scheme_String (variable_value)));
+ : (char_pointer_to_string (variable_value)));
}
-DEFINE_PRIMITIVE ("CURRENT-USER-NAME", Prim_get_user_name, 0, 0,
+DEFINE_PRIMITIVE ("CURRENT-USER-NAME", Prim_get_user_name, 0, 0,
"Returns (as a string) the user name of the user running Scheme.")
{
char * user_name;
unsigned short getuid ();
struct passwd *entry;
struct passwd *getpwuid ();
-
+
entry = (getpwuid (getuid ()));
if (entry == NULL)
error_external_return ();
user_name = (entry -> pw_name);
}
- PRIMITIVE_RETURN (C_String_To_Scheme_String (user_name));
+ PRIMITIVE_RETURN (char_pointer_to_string (user_name));
}
DEFINE_PRIMITIVE ("GET-USER-HOME-DIRECTORY", Prim_get_user_home_directory, 1, 1,
struct passwd * entry;
struct passwd * getpwnam ();
PRIMITIVE_HEADER (1);
-
- CHECK_ARG (1, STRING_P);
- entry = (getpwnam (Scheme_String_To_C_String (ARG_REF (1))));
+ entry = (getpwnam (STRING_ARG (1)));
PRIMITIVE_RETURN
- ((entry == NULL)
+ ((entry == ((struct passwd *) 0))
? SHARP_F
- : (C_String_To_Scheme_String (entry -> pw_dir)));
+ : (char_pointer_to_string (entry -> pw_dir)));
}
\f
DEFINE_PRIMITIVE ("CURRENT-FILE-TIME", Prim_current_file_time, 0, 0,
extern long time ();
PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (time ((long *) 0)));
+ PRIMITIVE_RETURN (long_to_integer (time ((long *) 0)));
}
DEFINE_PRIMITIVE ("FILE-TIME->STRING", Prim_file_time_to_string, 1, 1,
"Converts a file system time stamp into a date/time string.")
{
- extern long object_to_long ();
long clock;
char * time_string;
PRIMITIVE_HEADER (1);
-
- clock =
- (object_to_long ((ARG_REF (1)),
- ERR_ARG_1_WRONG_TYPE,
- ERR_ARG_1_BAD_RANGE));
+ CHECK_ARG (1, INTEGER_P);
+ {
+ fast SCHEME_OBJECT number = (ARG_REF (1));
+ if (! (integer_to_long_p (number)))
+ error_bad_range_arg (1);
+ clock = (integer_to_long (number));
+ }
time_string = (ctime (& clock));
if ((time_string [24]) == '\n')
(time_string [24]) = '\0';
- PRIMITIVE_RETURN (C_String_To_Scheme_String (time_string));
+ PRIMITIVE_RETURN (char_pointer_to_string (time_string));
}
DEFINE_PRIMITIVE ("UID->STRING", Prim_uid_to_string, 1, 1,
PRIMITIVE_RETURN
((entry == NULL)
? SHARP_F
- : (C_String_To_Scheme_String (entry -> pw_name)));
+ : (char_pointer_to_string (entry -> pw_name)));
}
DEFINE_PRIMITIVE ("GID->STRING", Prim_gid_to_string, 1, 1,
PRIMITIVE_RETURN
((entry == NULL)
? SHARP_F
- : (C_String_To_Scheme_String (entry -> gr_name)));
+ : (char_pointer_to_string (entry -> gr_name)));
}
\f
DEFINE_PRIMITIVE ("FILE-DIRECTORY?", Prim_file_directory_p, 1, 1,
if ((stat ((STRING_ARG (1)), (& stat_result))) < 0)
PRIMITIVE_RETURN (SHARP_F);
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM ((stat_result . st_mode) & 07777));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((stat_result . st_mode) & 07777));
}
DEFINE_PRIMITIVE ("SET-FILE-MODES!", Prim_set_file_modes, 2, 2,
"Return mode bits of FILE, as an integer.")
{
PRIMITIVE_HEADER (2);
-
if ((chmod ((STRING_ARG (1)), (arg_index_integer (2, 010000)))) < 0)
error_external_return ();
PRIMITIVE_RETURN (SHARP_F);
DEFINE_PRIMITIVE ("FILE-ACCESS", Prim_file_access, 2, 2, 0)
{
- char * filename;
PRIMITIVE_HEADER (1);
-
PRIMITIVE_RETURN
(((access ((STRING_ARG (1)), (arg_index_integer (2, 8)))) >= 0)
? SHARP_T
{
unsigned short geteuid ();
PRIMITIVE_HEADER (0);
-
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (geteuid ()));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (geteuid ()));
}
DEFINE_PRIMITIVE ("CURRENT-GID", Prim_current_gid, 0, 0,
unsigned short getegid ();
PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (getegid ()));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (getegid ()));
}
\f
/* The following is originally from GNU Emacs. */
#ifdef S_IFLNK
-static Pointer
+static SCHEME_OBJECT
file_symlink_p (filename)
- Pointer filename;
+ SCHEME_OBJECT filename;
{
char *buf;
int bufsize;
int valsize;
- Pointer val;
+ SCHEME_OBJECT val;
extern char *malloc ();
extern void free ();
if (buf == NULL)
error_external_return ();
valsize =
- (readlink ((Scheme_String_To_C_String (filename)), buf, bufsize));
+ (readlink ((STRING_LOC (filename, 0)), buf, bufsize));
if (valsize < bufsize)
break;
/* Buffer was not long enough */
return (SHARP_F);
}
(buf [valsize]) = '\0';
- val = (C_String_To_Scheme_String (buf));
+ val = (char_pointer_to_string (buf));
free (buf);
return (val);
}
#define lstat stat
#endif
-DEFINE_PRIMITIVE ("FILE-ATTRIBUTES", Prim_file_attributes, 1, 1,
+DEFINE_PRIMITIVE ("FILE-ATTRIBUTES", Prim_file_attributes, 1, 1,
"Given a file name, returns attribute information about the file.\n\
If the file exists and its status information is accessible, the result\n\
is a vector of 10 items (see the reference manual for details). Otherwise\n\
the result is #F.")
{
struct stat stat_result;
- extern Pointer allocate_marked_vector ();
- Pointer result;
- extern Pointer allocate_string ();
- Pointer modes;
+ extern SCHEME_OBJECT allocate_marked_vector ();
+ SCHEME_OBJECT result;
+ extern SCHEME_OBJECT allocate_string ();
+ SCHEME_OBJECT modes;
PRIMITIVE_HEADER (1);
- CHECK_ARG (1, STRING_P);
- if ((lstat ((Scheme_String_To_C_String (ARG_REF (1))), (& stat_result))) < 0)
+ if ((lstat ((STRING_ARG (1)), (& stat_result))) < 0)
PRIMITIVE_RETURN (SHARP_F);
result = (allocate_marked_vector (TC_VECTOR, 10, true));
modes = (allocate_string (10));
switch ((stat_result . st_mode) & S_IFMT)
{
case S_IFDIR:
- User_Vector_Set (result, 0, SHARP_T);
+ VECTOR_SET (result, 0, SHARP_T);
break;
#ifdef S_IFLNK
case S_IFLNK:
- User_Vector_Set (result, 0, (file_symlink_p (ARG_REF (1))));
+ VECTOR_SET (result, 0, (file_symlink_p (ARG_REF (1))));
break;
#endif
default:
- User_Vector_Set (result, 0, SHARP_F);
+ VECTOR_SET (result, 0, SHARP_F);
break;
}
- User_Vector_Set (result, 1, (MAKE_UNSIGNED_FIXNUM (stat_result . st_nlink)));
- User_Vector_Set (result, 2, (MAKE_UNSIGNED_FIXNUM (stat_result . st_uid)));
- User_Vector_Set (result, 3, (MAKE_UNSIGNED_FIXNUM (stat_result . st_gid)));
- User_Vector_Set
- (result, 4, (C_Integer_To_Scheme_Integer (stat_result . st_atime)));
- User_Vector_Set
- (result, 5, (C_Integer_To_Scheme_Integer (stat_result . st_mtime)));
- User_Vector_Set
- (result, 6, (C_Integer_To_Scheme_Integer (stat_result . st_ctime)));
- User_Vector_Set
- (result, 7, (C_Integer_To_Scheme_Integer (stat_result . st_size)));
- filemodestring ((& stat_result), (string_pointer (modes, 0)));
- User_Vector_Set (result, 8, modes);
- User_Vector_Set (result, 9, (MAKE_UNSIGNED_FIXNUM (stat_result . st_ino)));
+ VECTOR_SET (result, 1, (LONG_TO_UNSIGNED_FIXNUM (stat_result . st_nlink)));
+ VECTOR_SET (result, 2, (LONG_TO_UNSIGNED_FIXNUM (stat_result . st_uid)));
+ VECTOR_SET (result, 3, (LONG_TO_UNSIGNED_FIXNUM (stat_result . st_gid)));
+ VECTOR_SET (result, 4, (long_to_integer (stat_result . st_atime)));
+ VECTOR_SET (result, 5, (long_to_integer (stat_result . st_mtime)));
+ VECTOR_SET (result, 6, (long_to_integer (stat_result . st_ctime)));
+ VECTOR_SET (result, 7, (long_to_integer (stat_result . st_size)));
+ filemodestring ((& stat_result), (STRING_LOC (modes, 0)));
+ VECTOR_SET (result, 8, modes);
+ VECTOR_SET (result, 9, (LONG_TO_UNSIGNED_FIXNUM (stat_result . st_ino)));
PRIMITIVE_RETURN (result);
}
\f
-/* filemodestring - set file attribute data
+/* filemodestring - set file attribute data
Filemodestring converts the data in the st_mode field of file
status block `s' to a 10 character attribute string, which it
{
extern int system ();
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (system (STRING_ARG (1))));
+ PRIMITIVE_RETURN (long_to_integer (system (STRING_ARG (1))));
}
-static Pointer file_touch ();
+static SCHEME_OBJECT file_touch ();
DEFINE_PRIMITIVE ("FILE-TOUCH", Prim_file_touch, 1, 1,
"Given a file name, changes the times of the file to the current time.\n\
PRIMITIVE_RETURN (file_touch (STRING_ARG (1)));
}
-static Pointer
+static SCHEME_OBJECT
file_touch (filename)
char * filename;
{
file, read one byte, and write it back in place. */
if (((file_status . st_mode) & S_IFMT) != S_IFREG)
- return (C_String_To_Scheme_String ("can only touch regular files"));
+ return (char_pointer_to_string ("can only touch regular files"));
fd = (open (filename, O_RDWR, 0666));
if (fd < 0)
{
(void) ftruncate (fd, 0);
(void) close (fd);
- return (C_String_To_Scheme_String ("read: eof encountered"));
+ return (char_pointer_to_string ("read: eof encountered"));
}
if ((result < 0) && (errno != EINTR))
{
if (result == 0)
{
(void) close (fd);
- return (C_String_To_Scheme_String ("read: eof encountered"));
+ return (char_pointer_to_string ("read: eof encountered"));
}
if ((result < 0) && (errno != EINTR))
{
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbmap.h,v 9.29 1989/09/20 23:10:51 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbmap.h,v 9.28 1989/08/28 18:29:21 cph Exp $
- *
- * This file contains macros and declarations for Bintopsb.c
- * and Psbtobin.c
- *
- */
+/* This file contains macros and declarations for "Bintopsb.c"
+ and "Psbtobin.c". */
\f
/* These definitions insure that the appropriate code is extracted
from the included files.
#include "types.h"
#include "object.h"
#include "bignum.h"
+#include "bignumint.h"
#include "bitstr.h"
#include "sdata.h"
#include "const.h"
#include "gccode.h"
-#include "char.h"
#ifdef HAS_FREXP
extern double frexp(), ldexp();
#define NROOTS 1
-/* Types to recognize external object references. Any occurrence of these
+/* 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 HEAP_CODE TC_CHARACTER
#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)
-/*
- 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 to_pointer(size) \
- (((size) + (sizeof(Pointer) - 1)) / sizeof(Pointer))
-
-#define bigdigit_to_pointer(ndig) \
- to_pointer((ndig) * sizeof(bigdigit))
+#define to_pointer BYTES_TO_WORDS
#define float_to_pointer \
- to_pointer(sizeof(double))
+ BYTES_TO_WORDS(sizeof(double))
#define flonum_to_pointer(nchars) \
((nchars) * (1 + float_to_pointer))
#define char_to_pointer(nchars) \
- to_pointer(nchars)
+ BYTES_TO_WORDS(nchars)
#define pointer_to_char(npoints) \
- ((npoints) * sizeof(Pointer))
+ ((npoints) * sizeof(SCHEME_OBJECT))
\f
/* Status flags */
/* Global data */
#ifndef Heap_In_Low_Memory
-static Pointer *Memory_Base;
+static SCHEME_OBJECT * memory_base;
#endif
static long
compiler_processor_type = 0,
compiler_interface_version = 0;
-static Pointer
- compiler_utilities = NIL;
+static SCHEME_OBJECT
+ compiler_utilities = SHARP_F;
\f
/* Utilities */
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.36 1989/09/20 23:04:46 cph Exp $
+
Copyright (c) 1987, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.35 1989/08/28 18:28:07 cph Exp $
- *
- * This File contains the code to translate portable format binary
- * files to internal format.
- *
- */
+/* This file contains the code to translate portable format binary
+ files to internal format. */
\f
/* Cheap renames */
Dumped_Pure_Base, Pure_Objects, Pure_Count,
Primitive_Table_Length;
-static Pointer
+static SCHEME_OBJECT
*Heap,
*Heap_Base, *Heap_Table, *Heap_Object_Base, *Free,
*Constant_Base, *Constant_Table,
long
Write_Data(Count, From_Where)
long Count;
- Pointer *From_Where;
+ SCHEME_OBJECT *From_Where;
{
extern int fwrite();
- return (fwrite(((char *) From_Where), sizeof(Pointer),
+ return (fwrite(((char *) From_Where), sizeof(SCHEME_OBJECT),
Count, internal_file));
}
}
}
\f
-Pointer *
+SCHEME_OBJECT *
read_a_string_internal(To, maxlen)
- Pointer *To;
+ SCHEME_OBJECT *To;
long maxlen;
{
long ilen, Pointer_Count;
Pointer_Count = STRING_CHARS + char_to_pointer(maxlen);
To[STRING_HEADER] =
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1));
- To[STRING_LENGTH] = ((Pointer) len);
+ MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1));
+ To[STRING_LENGTH_INDEX] = ((SCHEME_OBJECT) len);
/* Space */
return (To + Pointer_Count);
}
-Pointer *
+SCHEME_OBJECT *
read_a_string(To, Slot)
- Pointer *To, *Slot;
+ SCHEME_OBJECT *To, *Slot;
{
long maxlen;
- *Slot = Make_Pointer(TC_CHARACTER_STRING, To);
+ *Slot = MAKE_POINTER_OBJECT(TC_CHARACTER_STRING, To);
fscanf(portable_file, "%ld", &maxlen);
return (read_a_string_internal(To, maxlen));
}
#endif
\f
-Pointer *
+SCHEME_OBJECT *
read_an_integer(The_Type, To, Slot)
int The_Type;
- Pointer *To;
- Pointer *Slot;
+ SCHEME_OBJECT *To;
+ SCHEME_OBJECT *Slot;
{
Boolean negative;
- long size_in_bits;
+ fast long length_in_bits;
getc(portable_file); /* Space */
negative = ((getc(portable_file)) == '-');
- fscanf(portable_file, "%ld", &size_in_bits);
- if ((size_in_bits <= fixnum_to_bits) &&
+ {
+ long l;
+ fscanf (portable_file, "%ld", (&l));
+ length_in_bits = l;
+ }
+ if ((length_in_bits <= fixnum_to_bits) &&
(The_Type == TC_FIXNUM))
{
fast long Value = 0;
fast long ndigits;
long digit;
- if (size_in_bits != 0)
+ if (length_in_bits != 0)
{
for(Normalization = 0,
- ndigits = hex_digits(size_in_bits);
+ ndigits = hex_digits(length_in_bits);
--ndigits >= 0;
Normalization += 4)
{
{
Value = -Value;
}
- *Slot = MAKE_SIGNED_FIXNUM(Value);
+ *Slot = LONG_TO_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))
+ else if (length_in_bits == 0)
{
- fprintf(stderr,
- "%s: Fixnum too large, coercing to bignum.\n",
- program_name);
+ SCHEME_OBJECT bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, To));
+ long gc_length = (BIGNUM_LENGTH_TO_GC_LENGTH (0));
+ (*To) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, gc_length));
+ BIGNUM_SET_HEADER (bignum, 0, 0);
+ (*Slot) = bignum;
+ return (To + gc_length + 1);
}
- 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;
- )
+ else
{
- for ( ;
- (nbits < SHIFT) && (ndigits > 0);
- ndigits -= 1, nbits += 4)
- {
- long digit;
-
- read_hex_digit(digit);
- Temp |= (((unsigned long) digit) << nbits);
- }
- *The_Bignum++ = Rem_Radix(Temp);
- Temp = Div_Radix(Temp);
- nbits -= SHIFT;
+ SCHEME_OBJECT bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, To));
+ bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (length_in_bits));
+ long gc_length = (BIGNUM_LENGTH_TO_GC_LENGTH (length));
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ fast bignum_digit_type accumulator = 0;
+ fast int bits_in_digit =
+ ((length_in_bits < BIGNUM_DIGIT_LENGTH)
+ ? length_in_bits
+ : BIGNUM_DIGIT_LENGTH);
+ fast int position = 0;
+ int hex_digit;
+ while (length_in_bits > 0)
+ {
+ read_hex_digit (hex_digit);
+ if (bits_in_digit > 4)
+ {
+ accumulator |= (hex_digit << position);
+ length_in_bits -= 4;
+ position += 4;
+ bits_in_digit -= 4;
+ }
+ else if (bits_in_digit == 4)
+ {
+ (*scan++) = (accumulator | (hex_digit << position));
+ accumulator = 0;
+ position = 0;
+ length_in_bits -= 4;
+ bits_in_digit =
+ ((length_in_bits < BIGNUM_DIGIT_LENGTH)
+ ? length_in_bits
+ : BIGNUM_DIGIT_LENGTH);
+ }
+ else
+ {
+ (*scan++) =
+ (accumulator |
+ ((hex_digit & ((1 << bits_in_digit) - 1)) << position));
+ accumulator = (hex_digit >> bits_in_digit);
+ position = (4 - bits_in_digit);
+ length_in_bits -= 4;
+ if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
+ bits_in_digit = BIGNUM_DIGIT_LENGTH;
+ else if (length_in_bits > 0)
+ bits_in_digit = length_in_bits;
+ else
+ {
+ (*scan) = accumulator;
+ break;
+ }
+ }
+ }
+ (*To) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, gc_length));
+ BIGNUM_SET_HEADER (bignum, length, negative);
+ (*Slot) = bignum;
+ return (To + gc_length + 1);
}
- *Slot = Make_Pointer(TC_BIG_FIXNUM, To);
- return (To + Length);
- }
}
\f
-Pointer *
+SCHEME_OBJECT *
read_a_bit_string(To, Slot)
- Pointer *To, *Slot;
+ SCHEME_OBJECT *To, *Slot;
{
long size_in_bits, size_in_words;
- Pointer the_bit_string;
+ SCHEME_OBJECT the_bit_string;
fscanf(portable_file, "%ld", &size_in_bits);
- size_in_words = (1 + bits_to_pointers (size_in_bits));
+ size_in_words = (1 + (BIT_STRING_LENGTH_TO_GC_LENGTH (size_in_bits)));
- the_bit_string = Make_Pointer(TC_BIT_STRING, To);
- *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, size_in_words);
+ the_bit_string = MAKE_POINTER_OBJECT (TC_BIT_STRING, To);
+ *To++ = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, size_in_words);
*To = size_in_bits;
To += size_in_words;
if (size_in_bits != 0)
{
unsigned long temp;
- fast Pointer *scan;
+ fast SCHEME_OBJECT *scan;
fast long bits_remaining, bits_accumulated;
- fast Pointer accumulator, next_word;
+ fast SCHEME_OBJECT accumulator, next_word;
accumulator = 0;
bits_accumulated = 0;
- scan = bit_string_low_ptr(the_bit_string);
+ scan = BIT_STRING_LOW_PTR(the_bit_string);
for(bits_remaining = size_in_bits;
bits_remaining > 0;
bits_remaining -= 4)
{
read_hex_digit(temp);
- if ((bits_accumulated + 4) > POINTER_LENGTH)
+ if ((bits_accumulated + 4) > OBJECT_LENGTH)
{
accumulator |=
- ((temp & low_mask(POINTER_LENGTH - bits_accumulated)) <<
+ ((temp & LOW_MASK(OBJECT_LENGTH - bits_accumulated)) <<
bits_accumulated);
- *(inc_bit_string_ptr(scan)) = accumulator;
- accumulator = (temp >> (POINTER_LENGTH - bits_accumulated));
- bits_accumulated -= (POINTER_LENGTH - 4);
- temp &= low_mask(bits_accumulated);
+ *(INC_BIT_STRING_PTR(scan)) = accumulator;
+ accumulator = (temp >> (OBJECT_LENGTH - bits_accumulated));
+ bits_accumulated -= (OBJECT_LENGTH - 4);
+ temp &= LOW_MASK(bits_accumulated);
}
else
{
}
if (bits_accumulated != 0)
{
- *(inc_bit_string_ptr(scan)) = accumulator;
+ *(INC_BIT_STRING_PTR(scan)) = accumulator;
}
}
*Slot = the_bit_string;
#define dflmin() 0.0 /* Cop out */
#define dflmax() ((the_max == 0.0) ? compute_max() : the_max)
-double
+double
compute_max()
{
fast double Result;
return (Result);
}
\f
-double
+double
read_a_flonum()
{
Boolean negative;
return (Result);
}
\f
-Pointer *
+SCHEME_OBJECT *
Read_External(N, Table, To)
long N;
- fast Pointer *Table, *To;
+ fast SCHEME_OBJECT *Table, *To;
{
- fast Pointer *Until = &Table[N];
+ fast SCHEME_OBJECT *Until = &Table[N];
int The_Type;
while (Table < Until)
getc(portable_file); /* Space */
VMS_BUG(the_char_code = 0);
fscanf( portable_file, "%3lx", &the_char_code);
- *Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
+ *Table++ = MAKE_OBJECT (TC_CHARACTER, the_char_code);
continue;
}
\f
{
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));
+ ALIGN_FLOAT (To);
+ *Table++ = MAKE_POINTER_OBJECT (TC_BIG_FLONUM, To);
+ *To++ = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (float_to_pointer));
*((double *) To) = The_Flonum;
To += float_to_pointer;
continue;
void
Move_Memory(From, N, To)
- fast Pointer *From, *To;
+ fast SCHEME_OBJECT *From, *To;
long N;
{
- fast Pointer *Until;
+ fast SCHEME_OBJECT *Until;
Until = &From[N];
while (From < Until)
void
Relocate_Objects(from, how_many, disp)
- fast Pointer *from;
+ fast SCHEME_OBJECT *from;
fast long disp;
long how_many;
{
- fast Pointer *Until;
+ fast SCHEME_OBJECT *Until;
Until = &from[how_many];
while (from < Until)
{
- switch(OBJECT_TYPE(*from))
+ switch(OBJECT_TYPE (*from))
{
case TC_FIXNUM:
case TC_CHARACTER:
case TC_BIG_FIXNUM:
case TC_BIG_FLONUM:
case TC_CHARACTER_STRING:
- *from++ == MAKE_OBJECT(OBJECT_TYPE(*from), (disp + OBJECT_DATUM(*from)));
+ *from++ ==
+ (OBJECT_NEW_DATUM ((*from), (disp + OBJECT_DATUM (*from))));
break;
default:
fprintf(stderr,
"%s: Unknown External Object Reference with Type 0x%02x",
program_name,
- OBJECT_TYPE(*from));
+ OBJECT_TYPE (*from));
inconsistency();
}
}
#else
-static Pointer *Relocate_Temp;
+static SCHEME_OBJECT *Relocate_Temp;
#define Relocate(Addr) \
(Relocate_Into(Relocate_Temp, Addr), Relocate_Temp)
#endif
\f
-Pointer *
+SCHEME_OBJECT *
Read_Pointers_and_Relocate(how_many, to)
fast long how_many;
- fast Pointer *to;
+ fast SCHEME_OBJECT *to;
{
int The_Type;
long The_Datum;
#if false
- Align_Float(to);
+ ALIGN_FLOAT (to);
#endif
while (--how_many >= 0)
case CONSTANT_CODE:
*to++ = Constant_Table[The_Datum];
continue;
-
+
case HEAP_CODE:
*to++ = Heap_Table[The_Datum];
continue;
-
+
case TC_MANIFEST_NM_VECTOR:
- *to++ = Make_Non_Pointer(The_Type, The_Datum);
+ *to++ = MAKE_OBJECT (The_Type, The_Datum);
{
fast long count;
-
+
count = The_Datum;
how_many -= count;
while (--count >= 0)
\f
case TC_COMPILED_ENTRY:
{
- Pointer *temp;
+ SCHEME_OBJECT *temp;
long base_type, base_datum;
fscanf(portable_file, "%02x %lx", &base_type, &base_datum);
temp = Relocate(base_datum);
- *to++ = Make_Pointer(base_type,
- ((Pointer *) (&(((char *) temp)[The_Datum]))));
+ *to++ =
+ (MAKE_POINTER_OBJECT
+ (base_type, ((SCHEME_OBJECT *) (&(((char *) temp)[The_Datum])))));
break;
}
case TC_PRIMITIVE:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case_simple_Non_Pointer:
- *to++ = Make_Non_Pointer(The_Type, The_Datum);
+ *to++ = MAKE_OBJECT (The_Type, The_Datum);
continue;
case TC_MANIFEST_CLOSURE:
case TC_REFERENCE_TRAP:
if (The_Datum <= TRAP_MAX_IMMEDIATE)
{
- *to++ = Make_Non_Pointer(The_Type, The_Datum);
+ *to++ = MAKE_OBJECT (The_Type, The_Datum);
continue;
}
/* It is a pointer, fall through. */
default:
/* Should be stricter */
- *to++ = Make_Pointer(The_Type, Relocate(The_Datum));
+ *to++ = MAKE_POINTER_OBJECT (The_Type, Relocate(The_Datum));
continue;
}
}
#if false
- Align_Float(to);
+ ALIGN_FLOAT (to);
#endif
return (to);
}
\f
static Boolean primitive_warn = false;
-Pointer *
+SCHEME_OBJECT *
read_primitives(how_many, where)
fast long how_many;
- fast Pointer *where;
+ fast SCHEME_OBJECT *where;
{
long arity;
{
primitive_warn = true;
}
- *where++ = MAKE_SIGNED_FIXNUM(arity);
+ *where++ = LONG_TO_FIXNUM(arity);
where = read_a_string_internal(where, ((long) -1));
}
return (where);
void
print_external_objects(area_name, Table, N)
char *area_name;
- fast Pointer *Table;
+ fast SCHEME_OBJECT *Table;
fast long N;
{
- fast Pointer *Table_End = &Table[N];
+ fast SCHEME_OBJECT *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))
+ switch (OBJECT_TYPE (*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);
+ (FIXNUM_TO_LONG (*Table)));
break;
}
case TC_CHARACTER:
fprintf(stderr,
"Table[%6d] = string \"%s\"\n",
(N - (Table_End - Table)),
- ((char *) Nth_Vector_Loc(*Table, STRING_CHARS)));
+ ((char *) MEMORY_LOC (*Table, STRING_CHARS)));
break;
\f
case TC_BIG_FIXNUM:
fprintf(stderr,
"Table[%6d] = Flonum %lf\n",
(N - (Table_End - Table)),
- (* ((double *) Nth_Vector_Loc(*Table, 1))));
+ (* ((double *) MEMORY_LOC (*Table, 1))));
break;
default:
READ_HEADER("Heap Count", "%ld", Heap_Count);
READ_HEADER("Dumped Heap Base", "%ld", Dumped_Heap_Base);
READ_HEADER("Heap Objects", "%ld", Heap_Objects);
-
+
READ_HEADER("Constant Count", "%ld", Constant_Count);
READ_HEADER("Dumped Constant Base", "%ld", Dumped_Constant_Base);
READ_HEADER("Constant Objects", "%ld", Constant_Objects);
-
+
READ_HEADER("Pure Count", "%ld", Pure_Count);
READ_HEADER("Dumped Pure Base", "%ld", Dumped_Pure_Base);
READ_HEADER("Pure Objects", "%ld", Pure_Objects);
-
+
READ_HEADER("& Dumped Object", "%ld", Dumped_Object_Addr);
-
+
READ_HEADER("Number of flonums", "%ld", NFlonums);
READ_HEADER("Number of integers", "%ld", NIntegers);
READ_HEADER("Number of bits in integers", "%ld", NBits);
READ_HEADER("Number of bits in bit strings", "%ld", NBBits);
READ_HEADER("Number of character strings", "%ld", NStrings);
READ_HEADER("Number of characters in strings", "%ld", NChars);
-
+
READ_HEADER("Primitive Table Length", "%ld", Primitive_Table_Length);
READ_HEADER("Number of characters in primitives", "%ld", NPChars);
-
+
READ_HEADER("CPU type", "%ld", compiler_processor_type);
READ_HEADER("Compiled code interface version", "%ld",
compiler_interface_version);
Constant_Count + Constant_Objects +
Pure_Count + Pure_Objects +
flonum_to_pointer(NFlonums) +
- ((NIntegers * (1 + bignum_header_to_pointer)) +
- (bigdigit_to_pointer(bits_to_bigdigit(NBits)))) +
+ ((NIntegers * (2 + (BYTES_TO_WORDS (sizeof (bignum_digit_type))))) +
+ (BYTES_TO_WORDS (BIGNUM_BITS_TO_DIGITS (NBits)))) +
((NStrings * (1 + STRING_CHARS)) +
(char_to_pointer(NChars))) +
((NBitstrs * (1 + BIT_STRING_FIRST_WORD)) +
- (bits_to_pointers(NBBits))) +
+ (BIT_STRING_LENGTH_TO_GC_LENGTH(NBBits))) +
((Primitive_Table_Length * (2 + STRING_CHARS)) +
(char_to_pointer(NPChars))));
-
- Allocate_Heap_Space(Size);
+
+ ALLOCATE_HEAP_SPACE (Size);
if (Heap == NULL)
{
fprintf(stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
+ "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
program_name, Size);
quit(1);
}
Heap += HEAP_BUFFER_SPACE;
- Initial_Align_Float(Heap);
+ INITIAL_ALIGN_FLOAT(Heap);
return (Size - HEAP_BUFFER_SPACE);
}
\f
void
do_it()
{
- Pointer *primitive_table_end;
+ SCHEME_OBJECT *primitive_table_end;
Boolean result;
long Size;
Heap_Base = &Heap_Table[Heap_Objects];
Heap_Object_Base =
Read_External(Heap_Objects, Heap_Table, Heap_Base);
-
+
/* The various 2s below are for SNMV headers. */
Pure_Table = &Heap_Object_Base[Heap_Count];
Constant_Base = &Pure_Object_Base[Pure_Count + 2];
Constant_Object_Base =
Read_External(Constant_Objects, Constant_Table, Constant_Base);
-
+
primitive_table = &Constant_Object_Base[Constant_Count + 2];
WHEN((primitive_table > Constant_Table),
primitive_table_end can be well below Constant_Table, since
the memory allocation is conservative (it rounds up), and all
the slack ends up between them.
- */
+ */
WHEN((primitive_table_end > Constant_Table),
"primitive_table_end overran Constant_Table");
/* Dump the objects */
{
- Pointer *Dumped_Object;
+ SCHEME_OBJECT *Dumped_Object;
Relocate_Into(Dumped_Object, Dumped_Object_Addr);
Pure_Length = (Constant_Base - Pure_Base) + 1;
Total_Length = (Free_Constant - Pure_Base) + 4;
Pure_Base[-2] =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, (Pure_Length - 1));
+ MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, (Pure_Length - 1));
Pure_Base[-1] =
- Make_Non_Pointer(PURE_PART, Total_Length);
+ MAKE_OBJECT (PURE_PART, Total_Length);
Constant_Base[-2] =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
Constant_Base[-1] =
- Make_Non_Pointer(CONSTANT_PART, (Pure_Length - 1));
+ MAKE_OBJECT (CONSTANT_PART, (Pure_Length - 1));
Free_Constant[0] =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
Free_Constant[1] =
- Make_Non_Pointer(END_OF_BLOCK, Total_Length);
+ MAKE_OBJECT (END_OF_BLOCK, Total_Length);
result = Write_File(Dumped_Object,
(Free - Heap_Base), Heap_Base,
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.39 1989/06/08 00:25:19 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.40 1989/09/20 23:10:54 cph Exp $
*
* This file contains the code that copies objects into pure
* and constant space.
/* Imports */
extern void GCFlip(), GC();
-extern Pointer *GCLoop();
+extern SCHEME_OBJECT *GCLoop();
\f
/* This is a copy of GCLoop, with mode handling added, and
debugging printout removed.
#define Purify_Pointer(Code) \
{ \
- Old = Get_Pointer(Temp); \
+ Old = OBJECT_ADDRESS (Temp); \
if ((GC_Mode == CONSTANT_COPY) && \
(Old > Low_Constant)) \
continue; \
#define Indirect_BH(In_GC) \
{ \
- if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART) \
+ if (OBJECT_TYPE (*Old) == TC_BROKEN_HEART) \
continue; \
}
#define Transport_Vector_Indirect() \
{ \
Real_Transport_Vector(); \
- *Get_Pointer(Temp) = New_Address; \
+ *OBJECT_ADDRESS (Temp) = New_Address; \
}
\f
-Pointer *
+SCHEME_OBJECT *
PurifyLoop(Scan, To_Pointer, GC_Mode)
- fast Pointer *Scan;
- Pointer **To_Pointer;
+ fast SCHEME_OBJECT *Scan;
+ SCHEME_OBJECT **To_Pointer;
int GC_Mode;
{
- fast Pointer *To, *Old, Temp, *Low_Constant, New_Address;
+ fast SCHEME_OBJECT *To, *Old, Temp, *Low_Constant, New_Address;
To = *To_Pointer;
Low_Constant = Constant_Space;
Switch_by_GC_Type(Temp)
{
case TC_BROKEN_HEART:
- if (Scan == (Get_Pointer(Temp)))
+ if (Scan == (OBJECT_ADDRESS (Temp)))
{
*To_Pointer = To;
return Scan;
case TC_MANIFEST_NM_VECTOR:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
- Scan += Get_Integer(Temp);
+ Scan += OBJECT_DATUM (Temp);
break;
\f
/* Compiled code relocation. */
{
fast long count;
fast machine_word *word_ptr;
- Pointer *end_scan;
+ SCHEME_OBJECT *end_scan;
count = READ_OPERATOR_LINKAGE_COUNT(Temp);
word_ptr = FIRST_OPERATOR_LINKAGE_ENTRY(Scan);
*/
case TC_REFERENCE_TRAP:
- if ((OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE) ||
+ if ((OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE) ||
(GC_Mode == PURE_COPY))
{
/* It is a non pointer. */
case TC_UNINTERNED_SYMBOL:
if (GC_Mode == PURE_COPY)
{
- Temp = Vector_Ref(Temp, SYMBOL_NAME);
+ Temp = MEMORY_REF (Temp, SYMBOL_NAME);
Purify_Pointer(Setup_Internal(false,
Transport_Vector_Indirect(),
Indirect_BH(false)));
/* Fall through */
case_Purify_Vector:
- purify_vector:
Setup_Pointer_for_Purify(Transport_Vector());
break;
#define Purify_Really_Pure 2
#define Purify_N_Slots 2
-Pointer Purify(Object, Purify_Object)
-Pointer Object, Purify_Object;
+SCHEME_OBJECT
+Purify (Object, Purify_Object)
+ SCHEME_OBJECT Object, Purify_Object;
{ long Length;
- Pointer *Heap_Start, *Result, Answer;
+ SCHEME_OBJECT *Heap_Start, *Result, Answer;
/* Pass 1 -- Copy object to new heap, then GC into that heap */
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] = Make_Unsigned_Fixnum(Length);
+ MAKE_OBJECT (TC_MANIFEST_VECTOR, Purify_N_Slots);
+ Free[Purify_Length] = LONG_TO_UNSIGNED_FIXNUM(Length);
Free[Purify_Really_Pure] = Purify_Object;
- Answer = Make_Pointer(TC_VECTOR, Free);
+ Answer = MAKE_POINTER_OBJECT (TC_VECTOR, Free);
Free += Purify_N_Slots+1;
return Answer;
}
\f
-Pointer Purify_Pass_2(Info)
-Pointer Info;
+SCHEME_OBJECT
+Purify_Pass_2 (Info)
+ SCHEME_OBJECT Info;
{
long Length;
Boolean Purify_Object;
- Pointer *New_Object, Relocated_Object, *Result, Answer;
+ SCHEME_OBJECT *New_Object, Relocated_Object, *Result;
long Pure_Length, Recomputed_Length;
- Length = Get_Integer(Fast_Vector_Ref(Info, Purify_Length));
- if (Fast_Vector_Ref(Info, Purify_Really_Pure) == NIL)
+ Length = OBJECT_DATUM (FAST_MEMORY_REF (Info, Purify_Length));
+ if (FAST_MEMORY_REF (Info, Purify_Really_Pure) == SHARP_F)
Purify_Object = false;
else
Purify_Object = true;
Relocated_Object = *Heap_Bottom;
if (!Test_Pure_Space_Top(Free_Constant+Length+6))
- return NIL;
+ return SHARP_F;
New_Object = Free_Constant;
GCFlip();
- *Free_Constant++ = NIL; /* Will hold pure space header */
+ *Free_Constant++ = SHARP_F; /* Will hold pure space header */
*Free_Constant++ = Relocated_Object;
if (Purify_Object)
{
}
else
Pure_Length = 3;
- *Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *Free_Constant++ = Make_Non_Pointer(CONSTANT_PART, Pure_Length);
+ *Free_Constant++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *Free_Constant++ = MAKE_OBJECT (CONSTANT_PART, Pure_Length);
if (Purify_Object)
{
Result = PurifyLoop(New_Object + 1, &Free_Constant, CONSTANT_COPY);
}
}
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));
+ *Free_Constant++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *Free_Constant++ = MAKE_OBJECT (END_OF_BLOCK, (Recomputed_Length + 5));
#ifndef FLOATING_ALIGNMENT
if (Length > Recomputed_Length)
{
}
#endif
*New_Object++ =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, Pure_Length);
- *New_Object = Make_Non_Pointer(PURE_PART, (Recomputed_Length + 5));
+ MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, Pure_Length);
+ *New_Object = MAKE_OBJECT (PURE_PART, (Recomputed_Length + 5));
GC();
Set_Pure_Top();
return (SHARP_T);
copying is done by PurifyLoop above.
Once the copy is complete we run a full GC which handles the
- broken hearts which now point into pure space. On a
+ 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.
DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0)
{
- long Saved_Zone;
- Pointer Object, Lost_Objects, Purify_Result, Daemon;
- Primitive_3_Args();
+ long new_gc_reserve;
+ SCHEME_OBJECT Object, Purify_Result, Daemon;
+ PRIMITIVE_HEADER (3);
PRIMITIVE_CANONICALIZE_CONTEXT();
Save_Time_Zone(Zone_Purify);
- if ((Arg2 != SHARP_T) && (Arg2 != NIL))
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Arg_3_Type(TC_FIXNUM);
+ CHECK_ARG (2, BOOLEAN_P);
+ new_gc_reserve = (arg_nonnegative_integer (3));
/* 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);
- GC_Reserve = (Get_Integer (Arg3));
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), Object);
+ GC_Reserve = new_gc_reserve;
ENTER_CRITICAL_SECTION ("purify pass 1");
- Purify_Result = Purify(Object, Arg2);
- Pop_Primitive_Frame(3);
+ Purify_Result = (Purify (Object, (ARG_REF (2))));
+ Pop_Primitive_Frame (3);
Daemon = Get_Fixed_Obj_Slot(GC_Daemon);
- if (Daemon == NIL)
+ if (Daemon == SHARP_F)
{
- Pointer words_free;
+ SCHEME_OBJECT words_free;
RENAME_CRITICAL_SECTION ("purify pass 2");
Purify_Result = Purify_Pass_2(Purify_Result);
- words_free = (Make_Unsigned_Fixnum (MemTop - Free));
- Val = (Make_Pointer (TC_LIST, Free));
+ words_free = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));
+ Val = (MAKE_POINTER_OBJECT (TC_LIST, Free));
(*Free++) = Purify_Result;
(*Free++) = words_free;
PRIMITIVE_ABORT(PRIM_POP_RETURN);
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.36 1989/06/08 00:25:32 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.37 1989/09/20 23:10:58 cph Exp $ */
/* Pure/Constant space utilities. */
\f
static void
Update(From, To, Was, Will_Be)
- fast Pointer *From, *To, *Was, *Will_Be;
+ fast SCHEME_OBJECT *From, *To, *Was, *Will_Be;
{
fast long count;
{
if (GC_Type_Special(*From))
{
- switch(OBJECT_TYPE(*From))
+ switch(OBJECT_TYPE (*From))
{
case TC_MANIFEST_NM_VECTOR:
- From += OBJECT_DATUM(*From);
+ From += OBJECT_DATUM (*From);
continue;
/* The following two type codes assume that none of the protected
{
count = READ_OPERATOR_LINKAGE_COUNT(*From);
From = END_OPERATOR_LINKAGE_AREA(From, count);
- continue;
+ continue;
}
\f
case TC_MANIFEST_CLOSURE:
}
if (GC_Type_Non_Pointer(*From))
continue;
- if (Get_Pointer(*From) == Was)
- *From = Make_Pointer(OBJECT_TYPE(*From), Will_Be);
+ if (OBJECT_ADDRESS (*From) == Was)
+ *From = MAKE_POINTER_OBJECT (OBJECT_TYPE (*From), Will_Be);
}
return;
}
\f
long
Make_Impure(Object, New_Object)
- Pointer Object, *New_Object;
+ SCHEME_OBJECT Object, *New_Object;
{
- Pointer *New_Address, *End_Of_Area;
- fast Pointer *Obj_Address, *Constant_Address;
+ SCHEME_OBJECT *New_Address, *End_Of_Area;
+ fast SCHEME_OBJECT *Obj_Address, *Constant_Address;
long Length, Block_Length;
fast long i;
Microcode_Termination(TERM_NON_POINTER_RELOCATION);
#endif
return (ERR_ARG_1_WRONG_TYPE);
-
+
case TC_BIG_FLONUM:
case TC_FUTURE:
case_Vector:
- Length = Vector_Length(Object) + 1;
+ Length = VECTOR_LENGTH (Object) + 1;
break;
case_Quadruple:
case_compiled_entry_point:
default:
fprintf(stderr, "\nImpurify: Bad type code = 0x%02x.\n",
- OBJECT_TYPE(Object));
+ OBJECT_TYPE (Object));
#ifdef BAD_TYPES_LETHAL
Microcode_Termination(TERM_INVALID_TYPE_CODE);
/*NOTREACHED*/
Constant_Address = Free_Constant;
- Obj_Address = Get_Pointer(Object);
+ Obj_Address = OBJECT_ADDRESS (Object);
if (!Test_Pure_Space_Top(Constant_Address + Length))
{
return (ERR_IMPURIFY_OUT_OF_SPACE);
}
- Block_Length = Get_Integer(*(Constant_Address-1));
+ Block_Length = OBJECT_DATUM (*(Constant_Address-1));
Constant_Address -= 2;
New_Address = Constant_Address;
block, or something like it. -- JINX
*/
- if (OBJECT_TYPE(Object) == TC_BIG_FLONUM)
+ if (OBJECT_TYPE (Object) == TC_BIG_FLONUM)
{
- Pointer *Start;
+ SCHEME_OBJECT *Start;
Start = Constant_Address;
- Align_Float(Constant_Address);
+ ALIGN_FLOAT (Constant_Address);
for (i = 0; i < Length; i++)
*Constant_Address++ = *Obj_Address++;
Length = Constant_Address - Start;
for (i = Length; --i >= 0; )
{
*Constant_Address++ = *Obj_Address;
- *Obj_Address++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, i);
+ *Obj_Address++ = MAKE_OBJECT (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);
+ *Constant_Address++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *Constant_Address++ = MAKE_OBJECT (END_OF_BLOCK, Block_Length + Length);
*(New_Address + 2 - Block_Length) =
- Make_Non_Pointer(PURE_PART, Block_Length + Length);
+ MAKE_OBJECT (PURE_PART, Block_Length + Length);
Obj_Address -= Length;
Free_Constant = Constant_Address;
EXIT_CRITICAL_SECTION ({});
- *New_Object = (Make_Pointer(OBJECT_TYPE(Object), New_Address));
+ *New_Object = (MAKE_POINTER_OBJECT (OBJECT_TYPE (Object), New_Address));
return (PRIM_DONE);
}
\f
-/* (PRIMITIVE-IMPURIFY OBJECT)
- Remove an object from pure space so it can be side effected.
- The object is placed in constant space instead.
-*/
-DEFINE_PRIMITIVE ("PRIMITIVE-IMPURIFY", Prim_impurify, 1, 1, 0)
+DEFINE_PRIMITIVE ("PRIMITIVE-IMPURIFY", Prim_impurify, 1, 1,
+ "Remove OBJECT from pure space so it can be side effected.\n\
+The object is placed in constant space instead.")
{
- long result;
- Pointer New_Object;
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1, Arg1);
- result = Make_Impure(Arg1, &New_Object);
- if (result == PRIM_DONE)
+ PRIMITIVE_HEADER (1);
{
- PRIMITIVE_RETURN(New_Object);
+ fast SCHEME_OBJECT old_object;
+ SCHEME_OBJECT new_object;
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), old_object);
+ {
+ fast long result = (Make_Impure (old_object, (&new_object)));
+ if (result != PRIM_DONE)
+ signal_error_from_primitive (result);
+ }
+ PRIMITIVE_RETURN (new_object);
}
- else
- Primitive_Error(result);
- /*NOTREACHED*/
}
\f
-extern Pointer * find_constant_space_block();
+extern SCHEME_OBJECT * find_constant_space_block();
-Pointer *
+SCHEME_OBJECT *
find_constant_space_block(obj_address)
- fast Pointer *obj_address;
+ fast SCHEME_OBJECT *obj_address;
{
- fast Pointer *where, *low_constant;
+ fast SCHEME_OBJECT *where, *low_constant;
#ifdef FLOATING_ALIGNMENT
- fast Pointer float_align_value;
+ fast SCHEME_OBJECT float_align_value;
- float_align_value = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
+ float_align_value = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0);
#endif
low_constant = Constant_Space;
where -= 1;
#endif
- where -= (1 + Get_Integer(*where));
+ where -= (1 + OBJECT_DATUM (*where));
if (where <= obj_address)
return (where);
}
- return ((Pointer *) NULL);
+ return ((SCHEME_OBJECT *) NULL);
}
Boolean
Pure_Test(obj_address)
- Pointer *obj_address;
+ SCHEME_OBJECT *obj_address;
{
- Pointer *block;
+ SCHEME_OBJECT *block;
block = find_constant_space_block (obj_address);
- if (block == ((Pointer *) NULL))
+ if (block == ((SCHEME_OBJECT *) NULL))
{
return (false);
}
return
- ((Boolean) (obj_address <= (block + 1 + (Get_Integer(*(block + 1))))));
+ ((Boolean) (obj_address <= (block + 1 + (OBJECT_DATUM (*(block + 1))))));
}
\f
-/* (PURE? OBJECT)
- 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).
-*/
-DEFINE_PRIMITIVE ("PURE?", Prim_pure_p, 1, 1, 0)
+DEFINE_PRIMITIVE ("PURE?", Prim_pure_p, 1, 1,
+ "Return #T if OBJECT is pure (i.e. it doesn't point to any other object,\n\
+or it is in a pure section of the constant space).")
{
- Primitive_1_Arg();
-
- if ((GC_Type_Non_Pointer(Arg1)) ||
- (GC_Type_Special(Arg1)))
- return SHARP_T;
- Touch_In_Primitive(Arg1, Arg1);
+ PRIMITIVE_HEADER (1);
{
- extern Pointer *compiled_entry_to_block_address();
- Pointer *Obj_Address;
-
- Obj_Address =
- ((GC_Type_Compiled(Arg1))
- ? (compiled_entry_to_block_address(Arg1))
- : (Get_Pointer(Arg1)));
- if (Is_Pure(Obj_Address))
- return SHARP_T;
+ fast SCHEME_OBJECT object = (ARG_REF (1));
+ if ((GC_Type_Non_Pointer (object)) ||
+ (GC_Type_Special (object)))
+ PRIMITIVE_RETURN (SHARP_T);
+ TOUCH_IN_PRIMITIVE (object, object);
+ {
+ extern SCHEME_OBJECT * compiled_entry_to_block_address ();
+ SCHEME_OBJECT * address =
+ ((GC_Type_Compiled (object))
+ ? (compiled_entry_to_block_address (object))
+ : (OBJECT_ADDRESS (object)));
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (ADDRESS_PURE_P (address)));
+ }
}
- return NIL;
}
-/* (CONSTANT? OBJECT)
- Returns #!TRUE if the object is in constant space or isn't a
- pointer.
-*/
-DEFINE_PRIMITIVE ("CONSTANT?", Prim_constant_p, 1, 1, 0)
+DEFINE_PRIMITIVE ("CONSTANT?", Prim_constant_p, 1, 1,
+ "Return #T if OBJECT is in constant space or isn't a pointer.")
{
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1, Arg1);
- return ((GC_Type_Non_Pointer(Arg1)) ||
- (GC_Type_Special(Arg1)) ||
- (Is_Constant(Get_Pointer(Arg1)))) ?
- SHARP_T : NIL;
+ PRIMITIVE_HEADER (1);
+ {
+ fast SCHEME_OBJECT object = (ARG_REF (1));
+ if ((GC_Type_Non_Pointer (object)) ||
+ (GC_Type_Special (object)))
+ PRIMITIVE_RETURN (SHARP_T);
+ TOUCH_IN_PRIMITIVE (object, object);
+ PRIMITIVE_RETURN
+ (BOOLEAN_TO_OBJECT (ADDRESS_CONSTANT_P (OBJECT_ADDRESS (object))));
+ }
}
-/* (GET-NEXT-CONSTANT)
- Returns the next free address in constant space.
-*/
-DEFINE_PRIMITIVE ("GET-NEXT-CONSTANT", Prim_get_next_constant, 0, 0, 0)
+DEFINE_PRIMITIVE ("GET-NEXT-CONSTANT", Prim_get_next_constant, 0, 0,
+ "Return the next free address in constant space.")
{
- Pointer *Next_Address;
-
- Next_Address = (Free_Constant + 1);
- Primitive_0_Args();
- return Make_Pointer(TC_ADDRESS, Next_Address);
+ SCHEME_OBJECT * next_address = (Free_Constant + 1);
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (next_address)));
}
\f
/* copy_to_constant_space is a microcode utility procedure.
space left.
*/
-extern Pointer *copy_to_constant_space();
+extern SCHEME_OBJECT *copy_to_constant_space();
-Pointer *
+SCHEME_OBJECT *
copy_to_constant_space(source, nobjects)
- fast Pointer *source;
+ fast SCHEME_OBJECT *source;
long nobjects;
{
- fast Pointer *dest;
+ fast SCHEME_OBJECT *dest;
fast long i;
- Pointer *result;
+ SCHEME_OBJECT *result;
dest = Free_Constant;
if (!Test_Pure_Space_Top(dest + nobjects + 6))
"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);
+ *dest++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 3);
+ *dest++ = MAKE_OBJECT (PURE_PART, nobjects + 5);
+ *dest++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *dest++ = MAKE_OBJECT (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);
+ *dest++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *dest++ = MAKE_OBJECT (END_OF_BLOCK, nobjects + 5);
Free_Constant = dest;
return result;
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/regex.c,v 1.8 1989/05/01 19:38:27 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/regex.c,v 1.9 1989/09/20 23:11:02 cph Rel $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
should have been included along with this file. */
#include "scheme.h"
-#include "char.h"
#include "syntax.h"
#include "regex.h"
+
+extern char * malloc ();
+extern char * realloc ();
+extern void free ();
\f
#ifndef SIGN_EXTEND_CHAR
#define SIGN_EXTEND_CHAR(x) (x)
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/regex.h,v 1.3 1989/05/01 19:38:37 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/regex.h,v 1.4 1989/09/20 23:11:06 cph Rel $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
/* Followed by two bytes giving relative address of place to
resume at in case of failure. */
- regexpcode_on_failure_jump,
+ regexpcode_on_failure_jump,
/* Throw away latest failure point and then jump to address. */
regexpcode_finalize_jump,
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/returns.h,v 9.36 1989/09/20 23:11:10 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/returns.h,v 9.35 1989/03/27 23:16:00 jinx Rel $
- *
- * Return codes. These are placed in Return when an
- * interpreter operation needs to operate in several
- * phases. This must correspond with UTABMD.SCM
- *
- */
+/* Return codes. These are placed in Return when an
+ interpreter operation needs to operate in several phases. */
\f
/* These names are also in storage.c.
- * Please maintain consistency.
- * Names should not exceed 31 characters.
- */
+ Please maintain consistency.
+ Names should not exceed 31 characters. */
#define RC_END_OF_COMPUTATION 0x00
/* formerly RC_RESTORE_CONTROL_POINT 0x01 */
#define RC_PCOMB3_DO_2 0x19
#define RC_PCOMB3_DO_1 0x1A
#define RC_PCOMB3_APPLY 0x1B
-\f
#define RC_SNAP_NEED_THUNK 0x1C
#define RC_REENTER_COMPILED_CODE 0x1D
/* formerly RC_GET_CHAR_REPEAT 0x1E */
#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
/* formerly #define RC_REPEAT_PRIMITIVE 0x42 */
-#define RC_COMP_INTERRUPT_RESTART 0x43
+#define RC_COMP_INTERRUPT_RESTART 0x43
/* formerly RC_COMP_RECURSION_GC 0x44 */
#define RC_RESTORE_INT_MASK 0x45
#define RC_HALT 0x46
/* 0x25 */ "RESTARTABLE_EXIT", \
/* 0x26 */ "", \
/* 0x27 */ "", \
-\f \
/* 0x28 */ "COMP_ASSIGNMENT_RESTART", \
/* 0x29 */ "POP_FROM_COMPILED_CODE", \
/* 0x2A */ "RETURN_TRAP_POINT", \
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/rgxprim.c,v 1.7 1988/08/15 20:54:28 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/rgxprim.c,v 1.8 1989/09/20 23:11:16 cph Rel $
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#include "scheme.h"
#include "prims.h"
-#include "string.h"
-#include "char.h"
#include "edwin.h"
#include "syntax.h"
#include "regex.h"
\f
#define RE_CHAR_SET_P(object) \
((STRING_P (object)) && \
- ((string_length (object)) == (MAX_ASCII / ASCII_LENGTH)))
+ ((STRING_LENGTH (object)) == (MAX_ASCII / ASCII_LENGTH)))
#define CHAR_SET_P(argument) \
- ((STRING_P (argument)) && ((string_length (argument)) == MAX_ASCII))
+ ((STRING_P (argument)) && ((STRING_LENGTH (argument)) == MAX_ASCII))
#define CHAR_TRANSLATION_P(argument) \
- ((STRING_P (argument)) && ((string_length (argument)) == MAX_ASCII))
+ ((STRING_P (argument)) && ((STRING_LENGTH (argument)) == MAX_ASCII))
#define RE_REGISTERS_P(object) \
- (((object) == NIL) || \
+ (((object) == SHARP_F) || \
((VECTOR_P (object)) && \
- ((Vector_Length (object)) == (RE_NREGS + RE_NREGS))))
+ ((VECTOR_LENGTH (object)) == (RE_NREGS + RE_NREGS))))
#define RE_MATCH_RESULTS(result, vector) do \
{ \
if ((result) >= 0) \
{ \
- if ((vector) != NIL) \
+ if ((vector) != SHARP_F) \
{ \
int i; \
long index; \
for (i = 0; (i < RE_NREGS); i += 1) \
{ \
index = ((registers . start) [i]); \
- User_Vector_Set \
+ VECTOR_SET \
(vector, \
i, \
((index == -1) \
- ? NIL \
- : (C_Integer_To_Scheme_Integer (index)))); \
+ ? SHARP_F \
+ : (long_to_integer (index)))); \
index = ((registers . end) [i]); \
- User_Vector_Set \
+ VECTOR_SET \
(vector, \
(i + RE_NREGS), \
((index == -1) \
- ? NIL \
- : (C_Integer_To_Scheme_Integer (index)))); \
+ ? SHARP_F \
+ : (long_to_integer (index)))); \
} \
} \
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (result)); \
+ PRIMITIVE_RETURN (long_to_integer (result)); \
} \
else if ((result) == (-1)) \
- PRIMITIVE_RETURN (NIL); \
+ PRIMITIVE_RETURN (SHARP_F); \
else if ((result) == (-2)) \
error_bad_range_arg (1); \
else \
{
int ascii;
PRIMITIVE_HEADER (2);
-
CHECK_ARG (1, RE_CHAR_SET_P);
ascii = (arg_ascii_integer (2));
- (* (string_pointer ((ARG_REF (1)), (ascii / ASCII_LENGTH)))) |=
+ (* (STRING_LOC ((ARG_REF (1)), (ascii / ASCII_LENGTH)))) |=
(1 << (ascii % ASCII_LENGTH));
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("RE-COMPILE-FASTMAP", Prim_re_compile_fastmap, 4, 4, 0)
{
- fast Pointer pattern;
+ fast SCHEME_OBJECT pattern;
fast int can_be_null;
PRIMITIVE_HEADER (4);
-
CHECK_ARG (1, STRING_P);
pattern = (ARG_REF (1));
CHECK_ARG (2, CHAR_TRANSLATION_P);
CHECK_ARG (3, SYNTAX_TABLE_P);
CHECK_ARG (4, CHAR_SET_P);
-
can_be_null =
(re_compile_fastmap
- ((string_pointer (pattern, 0)),
- (string_pointer (pattern, (string_length (pattern)))),
- (string_pointer ((ARG_REF (2)), 0)),
+ ((STRING_LOC (pattern, 0)),
+ (STRING_LOC (pattern, (STRING_LENGTH (pattern)))),
+ (STRING_LOC ((ARG_REF (2)), 0)),
(ARG_REF (3)),
- (string_pointer ((ARG_REF (4)), 0))));
-
+ (STRING_LOC ((ARG_REF (4)), 0))));
if (can_be_null >= 0)
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (can_be_null));
+ PRIMITIVE_RETURN (long_to_integer (can_be_null));
else if (can_be_null == (-2))
error_bad_range_arg (1);
else
the appropriate indices for the match registers. */
#define RE_SUBSTRING_PRIMITIVE(procedure) \
- fast Pointer regexp; \
+{ \
+ fast SCHEME_OBJECT regexp; \
long match_start, match_end, text_end; \
- char *text; \
+ unsigned char * text; \
struct re_buffer buffer; \
struct re_registers registers; \
int result; \
PRIMITIVE_HEADER (7); \
- \
CHECK_ARG (1, STRING_P); \
regexp = (ARG_REF (1)); \
CHECK_ARG (2, CHAR_TRANSLATION_P); \
CHECK_ARG (5, STRING_P); \
match_start = (arg_nonnegative_integer (6)); \
match_end = (arg_nonnegative_integer (7)); \
- text = (string_pointer ((ARG_REF (5)), 0)); \
- text_end = (string_length (ARG_REF (5))); \
- \
+ text = (STRING_LOC ((ARG_REF (5)), 0)); \
+ text_end = (STRING_LENGTH (ARG_REF (5))); \
if (match_end > text_end) error_bad_range_arg (7); \
if (match_start > match_end) error_bad_range_arg (6); \
- \
re_buffer_initialize \
- ((& buffer), (string_pointer ((ARG_REF (2)), 0)), (ARG_REF (3)), \
+ ((& buffer), (STRING_LOC ((ARG_REF (2)), 0)), (ARG_REF (3)), \
text, 0, text_end, text_end, text_end); \
- \
result = \
- (procedure ((string_pointer (regexp, 0)), \
- (string_pointer (regexp, (string_length (regexp)))), \
+ (procedure ((STRING_LOC (regexp, 0)), \
+ (STRING_LOC (regexp, (STRING_LENGTH (regexp)))), \
(& buffer), \
- (((ARG_REF (4)) == NIL) ? NULL : (& registers)), \
+ (((ARG_REF (4)) == SHARP_F) ? NULL : (& registers)), \
(& (text [match_start])), \
(& (text [match_end])))); \
- RE_MATCH_RESULTS (result, (ARG_REF (4)))
+ RE_MATCH_RESULTS (result, (ARG_REF (4))); \
+}
DEFINE_PRIMITIVE ("RE-MATCH-SUBSTRING", Prim_re_match_substring, 7, 7, 0)
-{ RE_SUBSTRING_PRIMITIVE (re_match); }
+ RE_SUBSTRING_PRIMITIVE (re_match)
DEFINE_PRIMITIVE ("RE-SEARCH-SUBSTRING-FORWARD", Prim_re_search_substr_forward, 7, 7, 0)
-{ RE_SUBSTRING_PRIMITIVE (re_search_forward); }
+ RE_SUBSTRING_PRIMITIVE (re_search_forward)
DEFINE_PRIMITIVE ("RE-SEARCH-SUBSTRING-BACKWARD", Prim_re_search_substr_backward, 7, 7, 0)
-{ RE_SUBSTRING_PRIMITIVE (re_search_backward); }
+ RE_SUBSTRING_PRIMITIVE (re_search_backward)
\f
#define RE_BUFFER_PRIMITIVE(procedure) \
- fast Pointer regexp, group; \
+{ \
+ fast SCHEME_OBJECT regexp, group; \
long match_start, match_end, text_start, text_end, gap_start; \
- char *text; \
+ unsigned char * text; \
struct re_buffer buffer; \
struct re_registers registers; \
int result; \
- Primitive_7_Args (); \
- \
+ PRIMITIVE_HEADER (7); \
CHECK_ARG (1, STRING_P); \
regexp = (ARG_REF (1)); \
CHECK_ARG (2, CHAR_TRANSLATION_P); \
group = (ARG_REF (5)); \
match_start = (arg_nonnegative_integer (6)); \
match_end = (arg_nonnegative_integer (7)); \
- \
- text = (string_pointer ((GROUP_TEXT (group)), 0)); \
+ text = (STRING_LOC ((GROUP_TEXT (group)), 0)); \
text_start = (MARK_POSITION (GROUP_START_MARK (group))); \
text_end = (MARK_POSITION (GROUP_END_MARK (group))); \
gap_start = (GROUP_GAP_START (group)); \
- \
if (match_end > gap_start) \
{ \
match_end += (GROUP_GAP_LENGTH (group)); \
if (match_start >= gap_start) \
match_start += (GROUP_GAP_LENGTH (group)); \
} \
- \
if (match_start > match_end) error_bad_range_arg (6); \
if (match_end > text_end) error_bad_range_arg (7); \
if (match_start < text_start) error_bad_range_arg (6); \
- \
re_buffer_initialize \
- ((& buffer), (string_pointer ((ARG_REF (2)), 0)), (ARG_REF (3)), \
+ ((& buffer), (STRING_LOC ((ARG_REF (2)), 0)), (ARG_REF (3)), \
text, text_start, text_end, gap_start, (GROUP_GAP_END (group))); \
- \
result = \
- (procedure ((string_pointer (regexp, 0)), \
- (string_pointer (regexp, (string_length (regexp)))), \
+ (procedure ((STRING_LOC (regexp, 0)), \
+ (STRING_LOC (regexp, (STRING_LENGTH (regexp)))), \
(& buffer), \
- (((ARG_REF (4)) == NIL) ? NULL : (& registers)), \
+ (((ARG_REF (4)) == SHARP_F) ? NULL : (& registers)), \
(& (text [match_start])), \
(& (text [match_end])))); \
- RE_MATCH_RESULTS (result, (ARG_REF (4)))
+ RE_MATCH_RESULTS (result, (ARG_REF (4))); \
+}
DEFINE_PRIMITIVE ("RE-MATCH-BUFFER", Prim_re_match_buffer, 7, 7, 0)
-{ RE_BUFFER_PRIMITIVE (re_match); }
+ RE_BUFFER_PRIMITIVE (re_match)
DEFINE_PRIMITIVE ("RE-SEARCH-BUFFER-FORWARD", Prim_re_search_buffer_forward, 7, 7, 0)
-{ RE_BUFFER_PRIMITIVE (re_search_forward); }
+ RE_BUFFER_PRIMITIVE (re_search_forward)
DEFINE_PRIMITIVE ("RE-SEARCH-BUFFER-BACKWARD", Prim_re_search_buffer_backward, 7, 7, 0)
-{ RE_BUFFER_PRIMITIVE (re_search_backward); }
+ RE_BUFFER_PRIMITIVE (re_search_backward)
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sample.c,v 9.23 1989/08/22 18:08:48 cph Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sample.c,v 9.24 1989/09/20 23:11:19 cph Rel $ */
\f
/* This file is intended to help you find out how to write primitives.
Many concepts needed to write primitives can be found by looking
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
+ this must be a SCHEME_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
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". */
+ element of the pair. The macro MAKE_POINTER_OBJECT 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 ("NEW-CONS", Prim_new_cons, 2, 2, 0)
{
- Pointer * Temp;
PRIMITIVE_HEADER (2);
-
- /* 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] = (ARG_REF (1));
- Temp[CONS_CDR] = (ARG_REF (2));
-
- /* Return the pair, which points to the location of the car */
- PRIMITIVE_RETURN (Make_Pointer (TC_LIST, Temp));
+ PRIMITIVE_RETURN (cons ((ARG_REF (1)), (ARG_REF (2))));
}
/* 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
+ to the next pair. Also, scheme objects are of type SCHEME_OBJECT
(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 ("WHY-SHOULDNT-THE-NAME-BE-RANDOM?", Prim_utterly_random, 3, 3, 0)
{
- /* Hold the end result in a temporary variable while we
- fill in the list. */
- Pointer * Result;
PRIMITIVE_HEADER (3);
-
- /* Check to see if there is enough space on the heap. */
- Primitive_GC_If_Needed (6);
- Result = Free;
- Free[CONS_CAR] = (ARG_REF (1));
-
- /* 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] = (ARG_REF (2));
-
- /* 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] = (ARG_REF (3));
-
- /* Make the last CDR a () to make a "proper" list */
- Free[CONS_CDR] = EMPTY_LIST;
-
- /* Bump Free over to the first available location */
- Free += 2;
- PRIMITIVE_RETURN (Make_Pointer (TC_LIST, Result));
+ PRIMITIVE_RETURN
+ (cons ((ARG_REF (1)),
+ (cons ((ARG_REF (2)),
+ (cons ((ARG_REF (3)),
+ EMPTY_LIST))))));
}
-/* 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. */
+/* Here is a primitive that tries to add 3 to its argument. */
DEFINE_PRIMITIVE ("3+", Prim_add_3, 1, 1, 0)
{
- long value;
- int flag;
PRIMITIVE_HEADER (1);
-
- flag = (Scheme_Integer_To_C_Integer ((ARG_REF (1)), (&value)));
- if (flag != PRIM_DONE)
- /* If flag is not equal to PRIM_DONE, then it is one of two
- errors. We can signal either error by calling
- `signal_error_from_primitive' with that error code. */
- signal_error_from_primitive (flag);
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (value + 3));
+ PRIMITIVE_RETURN (long_to_integer ((arg_integer (1)) + 3));
}
-
-/* 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. */
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scheme.h,v 9.30 1989/09/20 23:11:23 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scheme.h,v 9.29 1988/08/15 20:54:47 cph Rel $
- *
- * General declarations for the SCode interpreter. This
- * file is INCLUDED by others and contains declarations only.
- */
+/* General declarations for the SCode interpreter. This
+ file is INCLUDED by others and contains declarations only. */
\f
/* Certain debuggers cannot really deal with variables in registers.
- When debugging, NO_REGISTERS can be defined.
-*/
+ When debugging, NO_REGISTERS can be defined. */
#ifdef NO_REGISTERS
#define fast
#endif
#define forward extern /* For forward references */
-\f
+
#include <setjmp.h>
#include <stdio.h>
#include "bkpt.h" /* Shadows some defaults */
#include "default.h" /* Defaults for various hooks. */
#include "extern.h" /* External declarations */
+#include "bignum.h" /* Bignum declarations */
#include "prim.h" /* Declarations for primitives. */
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scode.h,v 9.23 1988/08/15 20:54:55 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scode.h,v 9.24 1989/09/20 23:11:26 cph Rel $
*
* Format of the SCode representation of programs. Each of these
* is described in terms of the slots in the data structure.
/* Selectors */
-#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 Get_Body_Elambda(Addr) (FAST_MEMORY_REF (Addr, ELAMBDA_SCODE))
+#define Get_Names_Elambda(Addr) (FAST_MEMORY_REF (Addr, ELAMBDA_NAMES))
+#define Get_Count_Elambda(Addr) (FAST_MEMORY_REF (Addr, ELAMBDA_ARG_COUNT))
#define Elambda_Formals_Count(Addr) \
((((long) Addr) & EL_FORMALS_MASK) >> EL_FORMALS_SHIFT)
#define Elambda_Opts_Count(Addr) \
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sdata.h,v 9.30 1988/08/15 20:55:03 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sdata.h,v 9.31 1989/09/20 23:11:29 cph Rel $
*
* Description of the user data objects. This should parallel the
* file SDATA.SCM in the runtime system.
/* ADDRESS
* is a FIXNUM. It represents a 24-bit address. Not a pointer type.
- */
+ */
/* BIG_FIXNUM (bignum).
* See the file BIGNUM.C
* followed by the characters themselves.
*/
#define STRING_HEADER 0
-#define STRING_LENGTH 1
+#define STRING_LENGTH_INDEX 1
#define STRING_CHARS 2
\f
/* COMPILED_PROCEDURE */
*/
#define STACKLET_HEADER_SIZE 3
-#define STACKLET_LENGTH 0 /* = VECTOR_LENGTH */
+#define STACKLET_LENGTH 0
#define STACKLET_REUSE_FLAG 1
#define STACKLET_UNUSED_LENGTH 2
*/
/* FIXNUM
- * Small integer. Fits in the datum portion of a Scheme Pointer.
+ * Small integer. Fits in the datum portion of a SCHEME_OBJECT.
*/
/* HUNK3
/* 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.
+ * APPLYed in the same way an object of type PROCEDURE can be.
*/
/* PROCEDURE (formerly CLOSURE)
* 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
-\f
/* When in RC_MOVE_TO_ADJACENT_POINT in the interpreter, the following
information is available on the stack (placed there by
Translate_To_Point
* 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.
+ * currently used.
*/
/* VECTOR_1B
/* -*-C-*-
-Copyright (c) 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/sgraph.h,v 1.5 1989/09/20 23:05:07 cph Rel $
+
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/sgraph.h,v 1.4 1988/07/16 07:19:59 cph Rel $ */
-
#include <starbase.c.h>
\f
/* Bobcat graphics primitives. Interface to the Starbase package*/
extern float sb_zmax;
extern void sb_close_device ();
-
-/* Generic dispatch of coordinates. No BIGNUM support yet. */
-
-#define Make_Flonum(pointer, flonum, integer, error) \
-{ \
- switch (Type_Code (pointer)) \
- { \
- case TC_FIXNUM: \
- Sign_Extend (pointer, integer); \
- flonum = ((float) integer); \
- break; \
- case TC_BIG_FLONUM: \
- flonum = ((float) (Get_Float (pointer))); \
- break; \
- default: \
- Primitive_Error (error); \
- } \
-}
-
-/* Easier to use flonum arg conversion. */
-#define FLONUM_ARG(argno, target) \
-{ \
- fast Pointer argument; \
- fast long fixnum_value; \
- \
- argument = (ARG_REF (argno)); \
- switch (Type_Code (argument)) \
- { \
- case TC_FIXNUM: \
- Sign_Extend (argument, fixnum_value); \
- target = ((float) fixnum_value); \
- break; \
- \
- case TC_BIG_FLONUM: \
- target = ((float) (Get_Float (argument))); \
- break; \
- \
- default: \
- error_wrong_type_arg (argno); \
- } \
-}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/sgraph_a.c,v 1.8 1989/09/20 23:05:10 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/sgraph_a.c,v 1.7 1989/08/09 02:13:48 pas Exp $ */
-
#include "scheme.h"
#include "prims.h"
-#include "flonum.h"
#include "Sgraph.h"
#include "array.h"
-
+\f
#ifndef STARBASE_COLOR_TABLE_START
#define STARBASE_COLOR_TABLE_START 0
#endif
#define STARBASE_COLOR_TABLE_SIZE 16
#endif
-float Color_Table[STARBASE_COLOR_TABLE_SIZE][3];
-
+float Color_Table [STARBASE_COLOR_TABLE_SIZE] [3];
+static void
+arg_plotting_box (arg_number, plotting_box)
+ int arg_number;
+ float * plotting_box;
+{
+ fast SCHEME_OBJECT object;
+ fast int i;
+ TOUCH_IN_PRIMITIVE ((ARG_REF (arg_number)), object);
+ for (i = 0; (i < 4); i += 1)
+ {
+ if (! (PAIR_P (object)))
+ error_wrong_type_arg (arg_number);
+ {
+ fast SCHEME_OBJECT number = (PAIR_CAR (object));
+ if (! (REAL_P (number)))
+ error_wrong_type_arg (arg_number);
+ if (! (real_number_to_double_p (number)))
+ error_bad_range_arg (arg_number);
+ (plotting_box [i]) = (real_number_to_double (number));
+ }
+ TOUCH_IN_PRIMITIVE ((PAIR_CDR (object)), object);
+ }
+ if (object != EMPTY_LIST)
+ error_wrong_type_arg (arg_number);
+ return;
+}
+\f
DEFINE_PRIMITIVE ("PLOT-ARRAY-IN-BOX-WITH-OFFSET-SCALE", Prim_plot_array_in_box_with_offset_scale, 5, 5, 0)
{
- float Plotting_Box[4]; /* x_min, y_min, x_max, y_max */
- long Length; int fill_with_lines;
- REAL *Array, Scale, Offset;
- Pointer Answer, *Orig_Free;
- int Error_Number;
- Primitive_5_Args();
-
- Arg_1_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
- Array = Scheme_Array_To_C_Array(Arg1);
-
- Arg_2_Type(TC_LIST);
- Get_Plotting_Box(Plotting_Box, Arg2);
-
- Error_Number = Scheme_Number_To_REAL(Arg3, &Offset);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
-
- Error_Number = Scheme_Number_To_REAL(Arg4, &Scale);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_4_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_4_WRONG_TYPE);
-
- Arg_5_Type(TC_FIXNUM);
- Range_Check(fill_with_lines, Arg5, 0, 1, ERR_ARG_1_BAD_RANGE); /* plot only points or fill with lines */
-
- Plot_C_Array_With_Offset_Scale(Array, Length, Plotting_Box, fill_with_lines, Offset, Scale);
-
- Primitive_GC_If_Needed(4);
- Answer = Make_Pointer(TC_LIST, Free);
- Orig_Free = Free;
- Free += 4;
- Store_Reduced_Flonum_Result(Offset, *Orig_Free);
- Orig_Free++;
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- Store_Reduced_Flonum_Result(Scale, *Orig_Free);
- Orig_Free++;
- *Orig_Free = EMPTY_LIST;
- PRIMITIVE_RETURN(Answer);
+ fast SCHEME_OBJECT array;
+ float plotting_box [4];
+ REAL scale;
+ REAL offset;
+ PRIMITIVE_HEADER (5);
+ CHECK_ARG (1, ARRAY_P);
+ array = (ARG_REF (1));
+ arg_plotting_box (2, plotting_box);
+ offset = (arg_real (3));
+ scale = (arg_real (4));
+ Plot_C_Array_With_Offset_Scale
+ ((ARRAY_CONTENTS (array)),
+ (ARRAY_LENGTH (array)),
+ plotting_box,
+ (arg_index_integer (5, 2)),
+ offset,
+ scale);
+ PRIMITIVE_RETURN
+ (cons ((double_to_flonum ((double) (offset))),
+ (cons ((double_to_flonum ((double) (scale))),
+ EMPTY_LIST))));
}
-#define max(x,y) (((x)<(y)) ? (y) : (x))
-#define min(x,y) (((x)<(y)) ? (x) : (y))
-
-Plot_C_Array_With_Offset_Scale(Array, Length, Plotting_Box, fill_with_lines, Offset, Scale)
+Plot_C_Array_With_Offset_Scale (Array, Length, Plotting_Box, fill_with_lines,
+ Offset, Scale)
float *Plotting_Box; long Length;
- int fill_with_lines; /* plots filled with lines from 0 to y(t) */
+ int fill_with_lines; /* plots filled with lines from 0 to y(t) */
REAL *Array, Scale, Offset;
{
float box_x_min = Plotting_Box[0],
box_y_max = Plotting_Box[3];
float Box_Length = box_x_max - box_x_min,
Box_Height = box_y_max - box_y_min;
- register float x_position, y_position, index_inc, clipped_offset;
+ fast float x_position, y_position, index_inc, clipped_offset;
long i;
-
+
index_inc = ((float) Box_Length/Length);
x_position = box_x_min;
if (fill_with_lines == 0)
else
{ /* fill with lines */
clipped_offset = min( max(box_y_min, ((float) Offset)), box_y_max);
- /* fill from zero-line but do not go outside box, (don't bother with starbase clipping) */
+ /* fill from zero-line but do not go outside box,
+ (don't bother with starbase clipping) */
for (i = 0; i < Length; i++)
{
y_position = ((float) (Offset + (Scale * Array[i])));
}
make_picture_current(screen_handle);
}
-\f
-Get_Plotting_Box(Plotting_Box, Arg2)
- float *Plotting_Box;
- Pointer Arg2;
-{
- Pointer List;
- long i, fixnum;
- Touch_In_Primitive(Arg2, List);
- for (i = 0; i < 4; i++)
- {
- Make_Flonum(Vector_Ref(List, CONS_CAR), Plotting_Box[i], fixnum,
- ERR_ARG_2_WRONG_TYPE);
- Touch_In_Primitive( Vector_Ref(List, CONS_CDR), List );
- }
- if (List != EMPTY_LIST)
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
-}
-\f
Plot_Box(Box)
float *Box;
{
\f
DEFINE_PRIMITIVE ("CLEAR-BOX", Prim_clear_box, 1, 1, 0)
{
- float Plotting_Box[4]; /* x_min, y_min, x_max, y_max */
- Primitive_1_Args();
-
- Arg_1_Type(TC_LIST);
- Get_Plotting_Box(Plotting_Box, Arg1);
- C_Clear_Rectangle(Plotting_Box);
- PRIMITIVE_RETURN(SHARP_F);
+ float Plotting_Box [4]; /* x_min, y_min, x_max, y_max */
+ PRIMITIVE_HEADER (1);
+ arg_plotting_box (1, Plotting_Box);
+ C_Clear_Rectangle (Plotting_Box);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
+
C_Clear_Rectangle(Box)
float *Box;
{
xposition = 0.0;
yposition = 0.0;
move2d(screen_handle, xposition, yposition);
-
- clip_rectangle(screen_handle, Box[0], Box[2], Box[1], Box[3]); /* shuffle around the coords */
+ /* shuffle around the coords */
+ clip_rectangle (screen_handle, Box[0], Box[2], Box[1], Box[3]);
clear_control(screen_handle, CLEAR_CLIP_RECTANGLE);
clear_view_surface(screen_handle);
make_picture_current(screen_handle);
- clear_control(screen_handle, CLEAR_DISPLAY_SURFACE); /* back to the default */
+ /* back to the default */
+ clear_control(screen_handle, CLEAR_DISPLAY_SURFACE);
clip_rectangle(screen_handle, sb_xmin, sb_xmax, sb_ymin, sb_ymax);
}
\f
-DEFINE_PRIMITIVE ("BOX-MOVE", Prim_box_move, 2, 2, 0)
+DEFINE_PRIMITIVE ("BOX-MOVE", Prim_box_move, 2, 2, 0)
{
float From_Box[4]; /* x_min, y_min, x_max, y_max */
float To_Box[4];
float x_source, y_source, x_dest, y_dest, x_length, y_length;
- Primitive_2_Args();
-
- Arg_1_Type(TC_LIST);
- Arg_1_Type(TC_LIST);
- Get_Plotting_Box(From_Box, Arg1);
- Get_Plotting_Box( To_Box, Arg2);
-
+ PRIMITIVE_HEADER (2);
+ arg_plotting_box (1, From_Box);
+ arg_plotting_box (1, To_Box);
x_source = From_Box[0]; y_source = From_Box[3];
x_dest = To_Box[0]; y_dest = To_Box[3];
- y_length = From_Box[3] - From_Box[1]; /* notice convention of matrix row, column! */
+ /* notice convention of matrix row, column! */
+ y_length = From_Box[3] - From_Box[1];
x_length = From_Box[2] - From_Box[0];
- if ((y_length != (To_Box[3]-To_Box[1])) || (x_length != (To_Box[2]-To_Box[0])))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- block_move(screen_handle, x_source, y_source, ((int) x_length), ((int) y_length),
- x_dest, y_dest);
- PRIMITIVE_RETURN(SHARP_F);
+ if ((y_length != (To_Box[3]-To_Box[1])) ||
+ (x_length != (To_Box[2]-To_Box[0])))
+ error_bad_range_arg (2);
+ block_move
+ (screen_handle,
+ x_source, y_source,
+ ((int) x_length), ((int) y_length),
+ x_dest, y_dest);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
-DEFINE_PRIMITIVE ("BOX-ROTATE-MOVE", Prim_box_rotate_move, 2, 2, 0)
+
+DEFINE_PRIMITIVE ("BOX-ROTATE-MOVE", Prim_box_rotate_move, 2, 2, 0)
{
float From_Box[4];
float To_Box[4];
float x_source, y_source, x_dest, y_dest, x_length, y_length;
- Primitive_2_Args();
- Arg_1_Type(TC_LIST);
- Arg_1_Type(TC_LIST);
-
- Get_Plotting_Box(From_Box, Arg1);
- Get_Plotting_Box( To_Box, Arg2);
-
+ PRIMITIVE_HEADER (2);
+ arg_plotting_box (1, From_Box);
+ arg_plotting_box (1, To_Box);
x_source = From_Box[0]; y_source = From_Box[3];
x_dest = To_Box[0]; y_dest = To_Box[3];
x_length = From_Box[3] - From_Box[1];
y_length = From_Box[2] - From_Box[0];
- if ((x_length != (To_Box[3]-To_Box[1])) || (y_length != (To_Box[2]-To_Box[0])))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- block_read(screen_handle, x_source, y_source, ((int) x_length), ((int) y_length),
- x_dest, y_dest);
+ if ((x_length != (To_Box[3]-To_Box[1])) ||
+ (y_length != (To_Box[2]-To_Box[0])))
+ error_bad_range_arg (2);
+ block_read
+ (screen_handle,
+ x_source, y_source,
+ ((int) x_length), ((int) y_length),
+ x_dest, y_dest);
#if false
- Char_Array_90clw();
+ Char_Array_90clw ();
#else
- fprintf(stderr, "\nPrim_Box_Rotate_Move: Char_Array_90clw undefined.\n");
- Primitive_Error(ERR_EXTERNAL_RETURN);
+ fprintf (stderr, "\nPrim_Box_Rotate_Move: Char_Array_90clw undefined.\n");
+ error_external_return ();
#endif
-
- block_read(screen_handle, x_source, y_source, ((int) x_length), ((int) y_length),
- x_dest, y_dest);
- PRIMITIVE_RETURN(SHARP_F);
+ block_read
+ (screen_handle,
+ x_source, y_source,
+ ((int) x_length), ((int) y_length),
+ x_dest, y_dest);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
\f
-/*_________________________________ image drawing ___________________________ */
-
-/*
- ;; Image Drawing (halftoning)
- ;; HG = Hard Grey levels (i.e. output device greys)
- ;; SG = Soft Grey levels (i.e. simulated grey levels)
- ;; There are 3 methods: PSAM, OD, BN (see below)
- There are also the old 16-color drawing routines.
-*/
-
-/*
- ;; PSAM (Pulse-Surface-Area Modulation) works only for 2 HG grey levels.
- ;; It maps 1 pxl to a square of 16 pxls.
- ;; The distribution of on/off pxls in the square gives 16 grey levels.
- ;; It's the most efficient for B&W monitors, but see below for better quality drawing using OD and BN.
- ;; Halftoning using OD and BN works for any number of grey levels, and there are many methods available (see below).
-
- IMAGE-PSAM-ATXY-WMM fixed magnification 1pxl->16pxls
- Draw line (width 4) by line. Pdata space needed = (4*ncols*16) .
- ;; The following 2 primitives simply take in arguments, and allocate space,
- ;; They call C_image_psam_atxy_wmm to do the actual drawing.
- */
+/* Image Drawing (halftoning)
+ HG = Hard Grey levels (i.e. output device greys)
+ SG = Soft Grey levels (i.e. simulated grey levels)
+ There are 3 methods: PSAM, OD, BN (see below)
+ There are also the old 16-color drawing routines. */
+
+/* PSAM (Pulse-Surface-Area Modulation) works only for 2 HG grey
+ levels. It maps 1 pxl to a square of 16 pxls. The distribution of
+ on/off pxls in the square gives 16 grey levels. It's the most
+ efficient for B&W monitors, but see below for better quality
+ drawing using OD and BN. Halftoning using OD and BN works for any
+ number of grey levels, and there are many methods available (see
+ below).
+
+ IMAGE-PSAM-ATXY-WMM fixed magnification 1pxl->16pxls Draw line
+ (width 4) by line. Pdata space needed = (4 * ncols * 16). The
+ following 2 primitives simply take in arguments, and allocate
+ space, They call C_image_psam_atxy_wmm to do the actual drawing. */
DEFINE_PRIMITIVE ("IMAGE-PSAM-ATXY-WMM", Prim_image_psam_atxy_wmm, 5, 5, 0)
-{ REAL x_at, y_at;
- Pointer Pnrows, Pncols, Prest, Parray;
- Pointer *Orig_Free;
- long nrows, ncols, Length;
- REAL *Array, Min,Max;
- unsigned char *pdata;
- int Error_Number;
-
- Primitive_5_Args();
- Arg_1_Type(TC_LIST); /* '(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) != EMPTY_LIST)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Array = Scheme_Array_To_C_Array(Parray); /* ARRAY */
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE); /* NROWS */
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE); /* NCOLS */
- Error_Number = Scheme_Number_To_REAL(Arg2, &x_at); /* X_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg3, &y_at); /* Y_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
-
- Error_Number = Scheme_Number_To_REAL(Arg4, &Min);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_4_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_4_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg5, &Max);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
- Length = nrows*ncols;
-
- Primitive_GC_If_Needed( (16*4*ncols) * sizeof(unsigned char) );
- pdata = ((unsigned char *) Free);
- /* the following draws the picture, clipping values outside Min,Max */
- C_image_psam_atxy_wmm(Array, pdata, nrows, ncols,
- ((float) x_at), ((float) y_at),
- Min, Max);
- PRIMITIVE_RETURN(SHARP_T);
+{
+ long nrows, ncols;
+ REAL * Array;
+ PRIMITIVE_HEADER (5);
+ arg_image (1, (&nrows), (&ncols), (&Array));
+ Primitive_GC_If_Needed (BYTES_TO_WORDS (16 * ncols));
+ C_image_psam_atxy_wmm
+ (Array,
+ ((unsigned char *) Free),
+ nrows,
+ ncols,
+ ((float) (arg_real (2))),
+ ((float) (arg_real (3))),
+ (arg_real (4)),
+ (arg_real (5)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("IMAGE-PSAM-ATXY-WOMM", Prim_image_psam_atxy_womm, 5, 5, 0)
-{ REAL x_at, y_at;
- Pointer Pnrows, Pncols, Prest, Parray;
- Pointer *Orig_Free;
- long nrows, ncols, Length;
- REAL *Array, Min,Max;
- unsigned char *pdata;
- int Error_Number;
- Primitive_5_Args();
-
- Arg_1_Type(TC_LIST); /* '(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) != EMPTY_LIST)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Array = Scheme_Array_To_C_Array(Parray); /* ARRAY */
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE); /* NROWS */
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE); /* NCOLS */
- Error_Number = Scheme_Number_To_REAL(Arg2, &x_at); /* X_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg3, &y_at); /* Y_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
-
- Error_Number = Scheme_Number_To_REAL(Arg4, &Min);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_4_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_4_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg5, &Max);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
- Length = nrows*ncols;
-
- Primitive_GC_If_Needed( (16*4*ncols) * sizeof(unsigned char) );
- pdata = ((unsigned char *) Free);
- C_image_psam_atxy_womm(Array, pdata, nrows, ncols,
- ((float) x_at), ((float) y_at),
- Min, Max);
- PRIMITIVE_RETURN(SHARP_T);
+{
+ long nrows, ncols;
+ REAL * Array;
+ PRIMITIVE_HEADER (5);
+ arg_image (1, (&nrows), (&ncols), (&Array));
+ Primitive_GC_If_Needed (BYTES_TO_WORDS (16 * ncols));
+ C_image_psam_atxy_womm
+ (Array,
+ ((unsigned char *) Free),
+ nrows,
+ ncols,
+ ((float) (arg_real (2))),
+ ((float) (arg_real (3))),
+ (arg_real (4)),
+ (arg_real (5)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
+\f
DEFINE_PRIMITIVE ("IMAGE-HT-OD-ATXY-WMM", Prim_image_ht_od_atxy_wmm, 7, 7, 0)
-{ REAL x_at, y_at;
- Pointer Pnrows, Pncols, Prest, Parray;
- Pointer *Orig_Free;
- long nrows, ncols, Length, HG, ODmethod;
- REAL *Array, Min,Max;
- unsigned char *pdata;
- int Error_Number;
-
- Primitive_7_Args();
- Arg_1_Type(TC_LIST); /* '(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) != EMPTY_LIST)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Array = Scheme_Array_To_C_Array(Parray); /* ARRAY */
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE); /* NROWS */
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE); /* NCOLS */
- Error_Number = Scheme_Number_To_REAL(Arg2, &x_at); /* X_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg3, &y_at); /* Y_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
-
- Error_Number = Scheme_Number_To_REAL(Arg4, &Min);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_4_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_4_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg5, &Max);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
- Length = nrows*ncols;
- Arg_6_Type(TC_FIXNUM);
- Range_Check(HG, Arg6, 1, 256, ERR_ARG_6_BAD_RANGE); /* don't expect more color levels than this */
- Arg_7_Type(TC_FIXNUM);
- Range_Check(ODmethod, Arg7, 0, 7, ERR_ARG_7_BAD_RANGE); /* see below HT_OD_TABLE_MAX_INDEX */
-
- Primitive_GC_If_Needed( ncols * sizeof(unsigned char) );
- pdata = ((unsigned char *) Free);
- /* the following draws the picture, clipping values outside Min,Max */
- C_image_ht_od_atxy_wmm(Array, pdata, nrows,ncols,
- ((float) x_at), ((float) y_at), Min,Max,
- HG,ODmethod);
- PRIMITIVE_RETURN(SHARP_T);
+{
+ long nrows, ncols;
+ REAL * Array;
+ PRIMITIVE_HEADER (7);
+ arg_image (1, (&nrows), (&ncols), (&Array));
+ Primitive_GC_If_Needed (BYTES_TO_WORDS (ncols));
+ C_image_ht_od_atxy_wmm
+ (Array,
+ ((unsigned char *) Free),
+ nrows,
+ ncols,
+ ((float) (arg_real (2))),
+ ((float) (arg_real (3))),
+ (arg_real (4)),
+ (arg_real (5)),
+ (arg_integer_in_range (6, 1, 257)),
+ (arg_integer_in_range (7, 0, 8)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("IMAGE-HT-BN-ATXY-WMM", Prim_image_ht_bn_atxy_wmm, 7, 7, 0)
-{ REAL x_at, y_at;
- Pointer Pnrows, Pncols, Prest, Parray;
- Pointer *Orig_Free;
- long nrows, ncols, Length, HG, BNmethod;
- REAL *Array, Min,Max;
- unsigned char *pdata;
- int Error_Number;
- float **er_rows;
-
- Primitive_7_Args();
- Arg_1_Type(TC_LIST); /* '(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) != EMPTY_LIST)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Array = Scheme_Array_To_C_Array(Parray); /* ARRAY */
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE); /* NROWS */
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE); /* NCOLS */
- Error_Number = Scheme_Number_To_REAL(Arg2, &x_at); /* X_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg3, &y_at); /* Y_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
-
- Error_Number = Scheme_Number_To_REAL(Arg4, &Min);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_4_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_4_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg5, &Max);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
- Length = nrows*ncols;
- Arg_6_Type(TC_FIXNUM);
- Range_Check(HG, Arg6, 1, 256, ERR_ARG_6_BAD_RANGE); /* don't expect more color levels than this */
- Arg_7_Type(TC_FIXNUM);
- Range_Check(BNmethod, Arg7, 0, 2, ERR_ARG_7_BAD_RANGE); /* 3 masks (methods) available, see below */
-
- Primitive_GC_If_Needed( (ncols*sizeof(unsigned char)) + (3*(ncols+4) * sizeof(float)) );
- /* 1-row for pdata, and 3 rows of 2+ncols+2 length for er_rows */
- /* Primitive_GC_If_Needed takes either number of bytes, or number of scheme pointers,it works either way. */
+{
+ long nrows, ncols;
+ REAL * Array;
+ unsigned char * pdata;
+ float ** er_rows;
+ PRIMITIVE_HEADER (7);
+ arg_image (1, (&nrows), (&ncols), (&Array));
+ Primitive_GC_If_Needed
+ (BYTES_TO_WORDS
+ (/* pdata */
+ ncols +
+ /* er_rows header */
+ (3 * (sizeof (float *))) +
+ /* er_rows data */
+ (3 * (ncols + 4) * (sizeof (float)))));
pdata = ((unsigned char *) Free);
- er_rows = ((float **) (pdata+ncols));
- er_rows[0] = ((float *) (er_rows+3));
- er_rows[1] = er_rows[0] + (ncols+4);
- er_rows[2] = er_rows[1] + (ncols+4);
-
- C_image_ht_bn_atxy_wmm(Array, pdata, nrows,ncols,
- ((float) x_at), ((float) y_at), Min,Max,
- HG,BNmethod, er_rows);
- PRIMITIVE_RETURN(SHARP_T);
+ er_rows = ((float **) (pdata + ncols));
+ (er_rows [0]) = ((float *) (er_rows + 3));
+ (er_rows [1]) = ((er_rows [0]) + (ncols + 4));
+ (er_rows [2]) = ((er_rows [1]) + (ncols + 4));
+ C_image_ht_bn_atxy_wmm
+ (Array,
+ pdata,
+ nrows,
+ ncols,
+ ((float) (arg_real (2))),
+ ((float) (arg_real (3))),
+ (arg_real (4)),
+ (arg_real (5)),
+ (arg_integer_in_range (6, 1, 257)),
+ (arg_nonnegative_integer (7, 3)),
+ er_rows);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
+\f
#define MINTEGER long
DEFINE_PRIMITIVE ("IMAGE-HT-IBN-ATXY-WMM", Prim_image_ht_ibn_atxy_wmm, 8, 8, 0)
-{ REAL x_at, y_at;
- Pointer Pnrows, Pncols, Prest, Parray;
- Pointer *Orig_Free;
- long nrows, ncols, Length, HG, BNmethod;
- REAL *Array, Min,Max;
- unsigned char *pdata;
- int Error_Number;
- MINTEGER **er_rows, PREC_SCALE;
-
- Primitive_8_Args();
- Arg_1_Type(TC_LIST); /* '(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) != EMPTY_LIST)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Array = Scheme_Array_To_C_Array(Parray); /* ARRAY */
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE); /* NROWS */
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE); /* NCOLS */
- Error_Number = Scheme_Number_To_REAL(Arg2, &x_at); /* X_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg3, &y_at); /* Y_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
-
- Error_Number = Scheme_Number_To_REAL(Arg4, &Min);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_4_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_4_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg5, &Max);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
- Length = nrows*ncols;
- Arg_6_Type(TC_FIXNUM);
- Range_Check(HG, Arg6, 1, 256, ERR_ARG_6_BAD_RANGE); /* don't expect more color levels than this */
- Arg_7_Type(TC_FIXNUM);
- Range_Check(BNmethod, Arg7, 0, 2, ERR_ARG_7_BAD_RANGE); /* 3 masks (methods) available, see below */
- Arg_8_Type(TC_FIXNUM);
- Range_Check(PREC_SCALE, Arg8, 1, (1<<(8*sizeof(MINTEGER)-2))/64,
- ERR_ARG_8_BAD_RANGE); /* avoid overflow, BN~64, see below */
-
- Primitive_GC_If_Needed( (ncols*sizeof(unsigned char)) + (3*(ncols+4) * sizeof(MINTEGER)) );
- /* 1-row for pdata, and 3 rows of 2+ncols+2 length for er_rows */
- /* Primitive_GC_If_Needed takes either number of bytes, or number of scheme pointers,it works either way. */
+{
+ long nrows, ncols;
+ REAL * Array;
+ unsigned char * pdata;
+ MINTEGER ** er_rows;
+ PRIMITIVE_HEADER (8);
+ arg_image (1, (&nrows), (&ncols), (&Array));
+ Primitive_GC_If_Needed
+ (BYTES_TO_WORDS
+ (/* pdata */
+ ncols +
+ /* er_rows header */
+ (3 * (sizeof (MINTEGER *))) +
+ /* er_rows data */
+ (3 * (ncols + 4) * (sizeof (MINTEGER)))));
pdata = ((unsigned char *) Free);
- er_rows = ((MINTEGER **) (pdata+ncols));
- er_rows[0] = ((MINTEGER *) (er_rows+3));
- er_rows[1] = er_rows[0] + (ncols+4);
- er_rows[2] = er_rows[1] + (ncols+4);
-
- C_image_ht_ibn_atxy_wmm(Array, pdata, nrows,ncols,
- ((float) x_at), ((float) y_at), Min,Max,
- HG,BNmethod, er_rows, PREC_SCALE);
- PRIMITIVE_RETURN(SHARP_T);
+ er_rows = ((MINTEGER **) (pdata + ncols));
+ (er_rows [0]) = ((MINTEGER *) (er_rows + 3));
+ (er_rows [1]) = (er_rows [0]) + (ncols + 4);
+ (er_rows [2]) = (er_rows [1]) + (ncols + 4);
+ C_image_ht_ibn_atxy_wmm
+ (Array,
+ pdata,
+ nrows,
+ ncols,
+ ((float) (arg_real (2))),
+ ((float) (arg_real (3))),
+ (arg_real (4)),
+ (arg_real (5)),
+ (arg_integer_in_range (6, 1, 257)),
+ (arg_index_integer (7, 3)),
+ er_rows,
+ (arg_integer_in_range
+ (8, 1, ((1 << ((8 * (sizeof (MINTEGER))) - 2)) / 64))));
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-
\f
/* THE FOLLOWING 3 ROUTINES ARE THE OLD 16-color drawing routines
- they also do magnification.
- */
+ they also do magnification. */
/* color_table entries 0 and 1 are not used */
/* Just like in array-plotting,
#define MINIMUM_INTENSITY_INDEX 2
#define MAXIMUM_INTENSITY_INDEX 15
-/* ARGS = (image x_at y_at magnification) magnification can be 1, 2, or 3
- */
+/* ARGS = (image x_at y_at magnification) magnification can be 1, 2, or 3 */
DEFINE_PRIMITIVE ("DRAW-MAGNIFY-IMAGE-AT-XY", Prim_draw_magnify_image_at_xy, 4, 4, 0)
{
- REAL x_at, y_at;
- Pointer Pnrows, Pncols, Prest, Parray, Answer;
- Pointer *Orig_Free;
- long nrows, ncols, Length;
- REAL *Array;
- unsigned char *pdata;
- int Error_Number;
+ long nrows;
+ long ncols;
+ long Length;
+ REAL * Array;
long Magnification;
- REAL Offset, Scale; /* To make intensities fit in [2,15] */
- Primitive_4_Args();
-
- Arg_1_Type(TC_LIST); /* '(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) != EMPTY_LIST)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Array = Scheme_Array_To_C_Array(Parray); /* ARRAY */
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE); /* NROWS */
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE); /* NCOLS */
- Error_Number = Scheme_Number_To_REAL(Arg2, &x_at); /* X_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg3, &y_at); /* Y_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
- Arg_4_Type(TC_FIXNUM);
- Range_Check(Magnification, Arg4, 1, 100, ERR_ARG_4_BAD_RANGE);
-
- Length = nrows*ncols;
-
- { REAL Array_Min, Array_Max;
- long nmin, nmax;
-
- C_Array_Find_Min_Max(Array, Length, &nmin, &nmax);
- Array_Min = Array[nmin]; Array_Max = Array[nmax];
- Find_Offset_Scale_For_Linear_Map(Array_Min, Array_Max,
- 2.0, 15.0, &Offset, &Scale); /* Do not use colors 0 and 1 */
-
- Primitive_GC_If_Needed( (Magnification*ncols) * sizeof(unsigned char) );
- pdata = ((unsigned char *) Free);
- Image_Draw_Magnify_N_Times_With_Offset_Scale(Array, pdata, nrows, ncols,
- ((float) x_at), ((float) y_at),
- Offset, Scale,
- Magnification);
- PRIMITIVE_RETURN(SHARP_T);
+ REAL Offset;
+ REAL Scale;
+ REAL Array_Min, Array_Max;
+ long nmin;
+ long nmax;
+ PRIMITIVE_HEADER (4);
+ arg_image (1, (&nrows), (&ncols), (&Array));
+ Magnification = (arg_integer_in_range (4, 1, 101));
+ Length = (nrows * ncols);
+ {
+ C_Array_Find_Min_Max (Array, Length, &nmin, &nmax);
+ Array_Min = (Array [nmin]);
+ Array_Max = (Array [nmax]);
+ /* Do not use colors 0 and 1 */
+ Find_Offset_Scale_For_Linear_Map
+ (Array_Min, Array_Max, 2.0, 15.0, &Offset, &Scale);
+ Primitive_GC_If_Needed (BYTES_TO_WORDS (Magnification * ncols));
+ Image_Draw_Magnify_N_Times_With_Offset_Scale
+ (Array,
+ ((unsigned char *) Free),
+ nrows,
+ ncols,
+ ((float) (arg_real (2))),
+ ((float) (arg_real (3))),
+ Offset,
+ Scale,
+ Magnification);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
}
\f
DEFINE_PRIMITIVE ("DRAW-MAGNIFY-IMAGE-AT-XY-WITH-MIN-MAX", Prim_draw_magnify_image_at_xy_with_min_max, 6, 6, 0)
{
- REAL x_at, y_at;
- Pointer Pnrows, Pncols, Prest, Parray, Answer;
- Pointer *Orig_Free;
- long nrows, ncols, Length;
- REAL *Array, Offset, Scale, Min,Max;
- unsigned char *pdata;
- int Error_Number;
+ long nrows;
+ long ncols;
+ REAL * Array;
+ REAL Offset;
+ REAL Scale;
long Magnification;
-
- Primitive_6_Args();
- Arg_1_Type(TC_LIST); /* '(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) != EMPTY_LIST) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Array = Scheme_Array_To_C_Array(Parray); /* ARRAY */
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE); /* NROWS */
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE); /* NCOLS */
- Error_Number = Scheme_Number_To_REAL(Arg2, &x_at); /* X_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg3, &y_at); /* Y_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
-
- Error_Number = Scheme_Number_To_REAL(Arg4, &Min);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_4_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_4_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg5, &Max);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
- Arg_6_Type(TC_FIXNUM);
- Range_Check(Magnification, Arg6, 1, 100, ERR_ARG_6_BAD_RANGE);
-
- Length = nrows*ncols;
-
- /* NOW MAKE THE PICTURE, CLIPPING MIN, MAX */
- Find_Offset_Scale_For_Linear_Map(Min, Max,
- 2.0, 15.0, &Offset, &Scale); /* Do not use colors 0 and 1 */
-
- Primitive_GC_If_Needed( (Magnification*ncols) * sizeof(unsigned char) );
- pdata = ((unsigned char *) Free);
- Image_Draw_Magnify_N_Times_With_Offset_Scale(Array, pdata, nrows, ncols,
- ((float) x_at), ((float) y_at),
- Offset, Scale,
- Magnification);
- PRIMITIVE_RETURN(SHARP_T);
+ PRIMITIVE_HEADER (6);
+ arg_image (1, (&nrows), (&ncols), (&Array));
+ Magnification = (arg_integer_in_range (4, 1, 101));
+ /* Do not use colors 0 and 1 */
+ Find_Offset_Scale_For_Linear_Map
+ ((arg_real (4)), (arg_real (5)), 2.0, 15.0, &Offset, &Scale);
+ Primitive_GC_If_Needed (BYTES_TO_WORDS (Magnification * ncols));
+ Image_Draw_Magnify_N_Times_With_Offset_Scale
+ (Array,
+ ((unsigned char *) Free),
+ nrows,
+ ncols,
+ ((float) (arg_real (2))),
+ ((float) (arg_real (3))),
+ Offset,
+ Scale,
+ Magnification);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
+
DEFINE_PRIMITIVE ("DRAW-MAGNIFY-IMAGE-AT-XY-ONLY-BETWEEN-MIN-MAX", Prim_draw_magnify_image_at_xy_only_between_min_max, 6, 6, 0)
{
- REAL x_at, y_at;
- Pointer Pnrows, Pncols, Prest, Parray, Answer;
- Pointer *Orig_Free;
- long nrows, ncols, Length;
- REAL *Array, Offset, Scale, Min,Max;
- unsigned char *pdata;
- int Error_Number;
+ long nrows;
+ long ncols;
+ REAL * Array;
+ REAL Offset;
+ REAL Scale;
long Magnification;
-
- Primitive_6_Args();
- Arg_1_Type(TC_LIST); /* '(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) != EMPTY_LIST) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Array = Scheme_Array_To_C_Array(Parray); /* ARRAY */
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE); /* NROWS */
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE); /* NCOLS */
- Error_Number = Scheme_Number_To_REAL(Arg2, &x_at); /* X_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg3, &y_at); /* Y_AT */
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
-
- Error_Number = Scheme_Number_To_REAL(Arg4, &Min);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_4_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_4_WRONG_TYPE);
- Error_Number = Scheme_Number_To_REAL(Arg5, &Max);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
- Arg_6_Type(TC_FIXNUM);
- Range_Check(Magnification, Arg6, 1, 100, ERR_ARG_6_BAD_RANGE);
- Length = nrows*ncols;
-
- /* NOW MAKE THE PICTURE, CLIPPING MIN, MAX */
- Find_Offset_Scale_For_Linear_Map(Min, Max,
- 2.0, 15.0, &Offset, &Scale); /* Do not use colors 0 and 1 */
-
- Primitive_GC_If_Needed( (Magnification*ncols) * sizeof(unsigned char) );
- pdata = ((unsigned char *) Free);
- Image_Draw_Magnify_N_Times_With_Offset_Scale_Only(Array, pdata, nrows, ncols,
- ((float) x_at), ((float) y_at),
- Offset, Scale,
- Magnification);
- PRIMITIVE_RETURN(SHARP_T);
+ PRIMITIVE_HEADER (6);
+ arg_image (1, (&nrows), (&ncols), (&Array));
+ Magnification = (arg_integer_in_range (4, 1, 101));
+ /* Do not use colors 0 and 1 */
+ Find_Offset_Scale_For_Linear_Map
+ ((arg_real (4)), (arg_real (5)), 2.0, 15.0, &Offset, &Scale);
+ Primitive_GC_If_Needed (BYTES_TO_WORDS (Magnification * ncols));
+ Image_Draw_Magnify_N_Times_With_Offset_Scale_Only
+ (Array,
+ ((unsigned char *) Free),
+ nrows,
+ ncols,
+ ((float) (arg_real (2))),
+ ((float) (arg_real (3))),
+ Offset,
+ Scale,
+ Magnification);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
-
-/*_______________________________________________________________________________*/
/* Below are the real drawing routines */
/* ht = halftoning
od = ordered-dither (dispersed dot), Ulichney terminology
bn = blue noise (also called: minimized average error)
psam = pulse surface area modulation
- Also, there are the old drawing routines for 16 colors, which are basically
- fixed threshold ordered dither.
- */
+ Also, there are the old drawing routines for 16 colors, which are basically
+ fixed threshold ordered dither. */
/* The macro Adjust_Value_Wmm is used by most drawing routines.
The macro Adjust_Value_Womm is used only by psam-atxy-womm.
- REAL value, newvalue, ngreys_min, ngreys_max, Vmin,Vmax, offset,scale;
- offset, scale must be such as to map (min,max) into (ngreys_min,ngreys_max)
- */
-#define Adjust_Value_Wmm(value, newvalue, ngreys_min, ngreys_max, Vmin, Vmax, offset, scale) \
-{ if (value >= Vmax) newvalue = ngreys_max; \
- else if (value <= Vmin) newvalue = ngreys_min; \
- else newvalue = offset + (value * scale); }
-#define Adjust_Value_Womm(value, newvalue, ngreys_min, ngreys_max, Vmin, Vmax, offset, scale) \
-{ if (value >= Vmax) newvalue = ngreys_min; \
- else if (value <= Vmin) newvalue = ngreys_min; \
- else newvalue = offset + (value * scale); }
+ REAL value, newvalue, ngreys_min, ngreys_max, Vmin,Vmax, offset,scale;
+ offset, scale must be such as to map (min,max)
+ into (ngreys_min,ngreys_max) */
+#define Adjust_Value_Wmm(value, newvalue, ngreys_min, ngreys_max, Vmin, Vmax, offset, scale) \
+{ \
+ if (value >= Vmax) \
+ newvalue = ngreys_max; \
+ else if (value <= Vmin) \
+ newvalue = ngreys_min; \
+ else \
+ newvalue = offset + (value * scale); \
+}
-/* The following geometrical map is slightly tricky.
- */
-void Find_Offset_Scale_For_Linear_Map(Min,Max, New_Min, New_Max, Offset, Scale)
- REAL Min,Max, New_Min, New_Max, *Offset, *Scale;
-{ /* no local variables */
- if ((Min == Max) && (Max == 0.0))
- { *Scale = 0.0; *Offset = (New_Max + New_Min) / 2.0; }
- else if (Min == Max)
- { *Scale = 0.25 * (mabs( (New_Max - New_Min) / Max ) );
- *Offset = (New_Max + New_Min) / 2.0; }
- else
- { *Scale = (New_Max - New_Min) / (Max - Min);
- *Offset = New_Min- ((*Scale) * Min); }
+#define Adjust_Value_Womm(value, newvalue, ngreys_min, ngreys_max, Vmin, Vmax, offset, scale) \
+{ \
+ if (value >= Vmax) \
+ newvalue = ngreys_min; \
+ else if (value <= Vmin) \
+ newvalue = ngreys_min; \
+ else \
+ newvalue = offset + (value * scale); \
}
#define Round_REAL(x) ((long) ((x >= 0) ? (x+.5) : (x-.5)))
-/* Ordered Dither MASKS
- A mask is a SQUARE matrix of threshold values,
+/* Ordered Dither MASKS
+ A mask is a SQUARE matrix of threshold values,
that is effectively replicated periodically all over the image.
-
+
ht_od_table[][0] ---> int SG; number of soft greys
- ht_od_table[][1] ---> int SGarray_nrows; nrows=ncols i.e. square matrix of threshold values
- ht_od_table[][2+i] ----> int SGarray[36]; threshold values with range [0,SG).
-
+ ht_od_table[][1] ---> int SGarray_nrows;
+ nrows=ncols i.e. square matrix of threshold values
+ ht_od_table[][2+i] ----> int SGarray[36];
+ threshold values with range [0,SG).
+
ATTENTION: Currently, the LARGEST SGarray is 6X6 MATRIX
*/
-static int ht_od_table[8][2+36] =
-{ {2,1, 1}, /* fixed threshold at halfpoint */
- {3,2, 1,2,2,1}, /* this one and following 4 come from Ulichney p.135 */
+static int ht_od_table[8][2+36] =
+{ {2,1, 1}, /* fixed threshold at halfpoint */
+ /* this one and following 4 come from Ulichney p.135 */
+ {3,2, 1,2,2,1},
{5,3, 2,3,2, 4,1,4, 2,3,2},
{9,4, 1,8,2,7, 5,3,6,4, 2,7,1,8, 6,4,5,3},
{17,5, 2,16,3,13,2, 10,6,11,7,10, 4,14,1,15,4, 12,8,9,5,12, 2,16,3,13,2},
- {33,6, 1,30,8,28,2,29, 17,9,24,16,18,10, 5,25,3,32,6,26, 21,13,19,11,22,14, 2,29,7,27,1,30, 18,10,23,15,17,9},
- {4,2, 0,2,3,1}, /* this one and following 1 come from Jarvis,Judice,Ninke: CGIP 5, p.23 */
+ {33,6, 1,30,8,28,2,29, 17,9,24,16,18,10, 5,25,3,32,6,26, 21,13,19,11,22,14,
+ 2,29,7,27,1,30, 18,10,23,15,17,9},
+ /* this one and following 1 come from Jarvis,Judice,Ninke: CGIP 5, p.23 */
+ {4,2, 0,2,3,1},
{17,4, 0,8,2,10, 12,4,14,6, 3,11,1,9, 15,7,13,5}
};
#define HT_OD_TABLE_MAX_INDEX 7
/* ordered dither
- pdata must have length ncols
- HG= Hardware Grey levels (output pixel values 0,HG-1)
- ODmethod is index for ht_od method
+ pdata must have length ncols
+ HG= Hardware Grey levels (output pixel values 0,HG-1)
+ ODmethod is index for ht_od method
*/
-C_image_ht_od_atxy_wmm(Array, pdata, nrows,ncols, x_at,y_at, Min,Max, HG,ODmethod)
- REAL Array[], Min,Max;
- unsigned char *pdata;
+C_image_ht_od_atxy_wmm (Array, pdata, nrows,ncols, x_at,y_at, Min,Max,
+ HG,ODmethod)
+ REAL Array[], Min,Max;
+ unsigned char *pdata;
int nrows,ncols,HG,ODmethod;
float x_at,y_at;
{ int i,j, SG, *SGarray, SGarray_nrows, dither, pixel, array_index;
- REAL REAL_pixel, value, offset,scale, HG1_SG;
+ REAL REAL_pixel, value, offset,scale, HG1_SG;
/* static int ht_od_table[][]; */
/* void Find_Offset_Scale_For_Linear_Map(); */
-
- if (ODmethod>HT_OD_TABLE_MAX_INDEX) {printf("HT_OD methods 0,7 only\n");fflush(stdout);return(0);};
+
+ if (ODmethod>HT_OD_TABLE_MAX_INDEX)
+ error_external_return ();
SG = ht_od_table[ODmethod][0];
SGarray_nrows = ht_od_table[ODmethod][1]; /* nrows=ncols */
SGarray = &(ht_od_table[ODmethod][2]); /* square matrix */
-
+
HG1_SG = ((REAL) ((HG-1)*SG));
- Find_Offset_Scale_For_Linear_Map(Min, Max,
- 0.0, HG1_SG, &offset, &scale); /* HG output greys */
+ Find_Offset_Scale_For_Linear_Map
+ (Min, Max, 0.0, HG1_SG, &offset, &scale); /* HG output greys */
array_index=0;
for (i=0; i<nrows; i++)
{ for (j=0; j<ncols; j++)
{ value = Array[array_index++];
Adjust_Value_Wmm(value, REAL_pixel, 0.0, HG1_SG, Min,Max, offset,scale);
- pixel = ((long) REAL_pixel); /* Turn into integer--- integer arithmetic gives speed */
- if (pixel == HG1_SG) pixel = pixel-1; /* this special case is necessary to avoid ouput_pxl greater than.. */
- /* */
+ /* Turn into integer--- integer arithmetic gives speed */
+ pixel = ((long) REAL_pixel);
+ /* this special case is necessary to avoid ouput_pxl greater than.. */
+ if (pixel == HG1_SG) pixel = pixel-1;
dither = SGarray[ (i%SGarray_nrows)*SGarray_nrows + (j%SGarray_nrows) ];
- /* Array[ row_index * ncols + column_index ] ---- Read threshold value */
- /* */
- pdata[j] = ((unsigned char) ((pixel + SG - dither) / SG)); /* integer division */ }
+ /* integer division */ }
+ pdata[j] = ((unsigned char) ((pixel + SG - dither) / SG));
block_write(screen_handle, x_at, (y_at-((float) i)), ncols, 1, pdata, 0);
}
}
-
+\f
/* Blue Noise (minimized average error)
- pdata must have length ncols
- HG= Hardware Grey levels (output pixel values 0,HG-1)
- BNmethod is index for ht_bn method
- */
-/*
- er_rows[][] should be 3 arrays of integers, of length (ncols+2*ER_C), which store previous errors, (ALLOCATED STORAGE)
- ER_R is number of error rows, (currently 3)
- ER_C is number of extra columns (to the left and to the right) of each er_row,
- they always contain ZEROS and serve to simplify the error summing process, i.e. we don't have
- to check for i,j bounds at edges, (no conditionals in the sum loop).
- Also, the code handles all cases in a uniform manner.
- (for better explanation get pas halftoning notes)
- */
-C_image_ht_bn_atxy_wmm(Array, pdata, nrows,ncols, x_at,y_at, Min,Max, HG,BNmethod, er_rows)
- REAL Array[], Min,Max;
- unsigned char *pdata;
- int nrows,ncols,HG,BNmethod;
- float x_at,y_at, **er_rows;
-{ /* no local vars */
- if (BNmethod==0)
- C_image_ht_bn_atxy_wmm_0_(Array, pdata, nrows,ncols, x_at,y_at, Min,Max, HG, er_rows);
- else if (BNmethod==1)
- C_image_ht_bn_atxy_wmm_1_(Array, pdata, nrows,ncols, x_at,y_at, Min,Max, HG, er_rows);
- else if (BNmethod==2)
- C_image_ht_bn_atxy_wmm_2_(Array, pdata, nrows,ncols, x_at,y_at, Min,Max, HG, er_rows);
+ pdata must have length ncols
+ HG= Hardware Grey levels (output pixel values 0,HG-1)
+ BNmethod is index for ht_bn method
+
+ er_rows[][] should be 3 arrays of integers, of length (ncols+2*ER_C),
+ which store previous errors, (ALLOCATED STORAGE)
+ ER_R is number of error rows, (currently 3)
+ ER_C is number of extra columns (to the left and to the right)
+ of each er_row, they always contain ZEROS and serve to simplify the
+ error summing process, i.e. we don't have to check for i,j bounds
+ at edges, (no conditionals in the sum loop). Also, the code handles
+ all cases in a uniform manner (for better explanation get PAS
+ halftoning notes). */
+
+C_image_ht_bn_atxy_wmm (Array, pdata, nrows, ncols, x_at, y_at, Min, Max,
+ HG, BNmethod, er_rows)
+ REAL Array [];
+ REAL Min;
+ REAL Max;
+ unsigned char * pdata;
+ int nrows;
+ int ncols;
+ int HG;
+ int BNmethod;
+ float x_at;
+ float y_at;
+ float ** er_rows;
+{
+ if (BNmethod == 0)
+ C_image_ht_bn_atxy_wmm_0_
+ (Array, pdata, nrows, ncols, x_at, y_at, Min, Max, HG, er_rows);
+ else if (BNmethod == 1)
+ C_image_ht_bn_atxy_wmm_1_
+ (Array, pdata, nrows, ncols, x_at, y_at, Min, Max, HG, er_rows);
+ else if (BNmethod == 2)
+ C_image_ht_bn_atxy_wmm_2_
+ (Array, pdata, nrows, ncols, x_at, y_at, Min, Max, HG, er_rows);
else
- {printf("HT_BN methods 0,1,2 only\n");fflush(stdout);};
+ {
+ fprintf (stderr, "\nHT_BN methods 0,1,2 only\n");
+ fflush (stderr);
+ }
}
+\f
+/* the following 3 routines are identical,
+ except for the mask weight numbers in computing ersum,
+ the sole reason for this duplication is speed (if any) */
-/*
- the following 3 routines are identical,
- except for the mask weight numbers in computing ersum,
- the sole reason for this duplication is speed (if any)
- */
-
-/* FLOYD-STEINBERG-75
- */
-C_image_ht_bn_atxy_wmm_0_(Array, pdata, nrows,ncols, x_at,y_at, Min,Max, HG, er_rows)
+/* FLOYD-STEINBERG-75 */
+C_image_ht_bn_atxy_wmm_0_ (Array, pdata, nrows, ncols, x_at, y_at, Min, Max,
+ HG, er_rows)
REAL Array[], Min,Max;
- unsigned char *pdata;
+ unsigned char *pdata;
int nrows,ncols,HG;
float x_at,y_at, **er_rows;
-{ int i,j, m, array_index;
+{
+ int i, j, m, array_index;
int row_offset, col_offset, INT_pixel;
- REAL REAL_pixel, value, offset,scale, HG1_2;
- float ersum, weight, pixel, *temp;
- static int ER_R=3, ER_R1=2, ER_C=2, ER_C1=1;
-
- for (i=0;i<ER_R;i++)
- for (j=0;j<ncols+(2*ER_C);j++) er_rows[i][j] = 0.0; /* initialize error rows */
- HG1_2 = ((REAL) ((HG-1)*2)); /* notice this is REAL number */
- Find_Offset_Scale_For_Linear_Map(Min, Max,
- 0.0, HG1_2, &offset, &scale); /* HG output greys */
- array_index=0;
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- ersum = (1.0/16.0)*er_rows[ER_R1+(-1)][ER_C+(-1)+j] + (5.0/16.0)*er_rows[ER_R1+(-1)][ER_C+(0)+j]
- + (3.0/16.0)*er_rows[ER_R1+(-1)][ER_C+(1)+j] + (7.0/16.0)*er_rows[ER_R1+(0)][ER_C+(-1)+j];
- /* this encodes the FLOYD-STEINBERG-75 mask for computating the average error correction */
- value = Array[array_index++];
- Adjust_Value_Wmm(value, REAL_pixel, 0.0, HG1_2, Min,Max, offset,scale);
- /* */
- pixel = ((float) REAL_pixel) + ersum; /* corrected intensity */
- INT_pixel = ((long) ((pixel + 1) / 2.0)); /* the (long) does truncation, this corresponds to "IF J>R/2 R 0" */
- pdata[j] = ((unsigned char) INT_pixel); /* output pixel to be painted */
- er_rows[ER_R1][ER_C +j] = (pixel/2.0) - ((float) INT_pixel); /* error estimate */
+ REAL REAL_pixel, value, offset,scale, HG1_2;
+ float ersum, weight, pixel;
+ static int
+ ER_R = 3,
+ ER_R1 = 2,
+ ER_C = 2,
+ ER_C1 = 1;
+
+ /* initialize error rows */
+ for (i = 0; (i < ER_R); i += 1)
+ for (j = 0; (j < (ncols + (2 * ER_C))); j += 1)
+ (er_rows [i] [j]) = 0.0;
+ /* notice this is REAL number */
+ HG1_2 = ((REAL) ((HG - 1) * 2));
+ /* HG output greys */
+ Find_Offset_Scale_For_Linear_Map (Min, Max, 0.0, HG1_2, &offset, &scale);
+ array_index = 0;
+ for (i = 0; (i < nrows); i += 1)
+ {
+ for (j = 0; (j < ncols); j += 1)
+ {
+ ersum =
+ (((1.0 / 16.0) * (er_rows [ER_R1 - 1] [ER_C + j - 1])) +
+ ((5.0 / 16.0) * (er_rows [ER_R1 - 1] [ER_C + j])) +
+ ((3.0 / 16.0) * (er_rows [ER_R1 - 1] [ER_C + j + 1])) +
+ ((7.0 / 16.0) * (er_rows [ER_R1] [ER_C + j - 1])));
+ /* this encodes the FLOYD-STEINBERG-75 mask for computing
+ the average error correction */
+ value = (Array [array_index++]);
+ Adjust_Value_Wmm
+ (value, REAL_pixel, 0.0, HG1_2, Min, Max, offset, scale);
+ /* corrected intensity */
+ pixel = (((float) REAL_pixel) + ersum);
+ /* the (long) does truncation, this corresponds to "IF J>R/2 R 0" */
+ INT_pixel = ((long) ((pixel + 1) / 2.0));
+ /* output pixel to be painted */
+ (pdata [j]) = ((unsigned char) INT_pixel);
+ /* error estimate */
+ (er_rows [ER_R1] [ER_C + j]) = ((pixel / 2.0) - ((float) INT_pixel));
+ }
+ /* paint a row */
+ block_write
+ (screen_handle, x_at, (y_at - ((float) i)), ncols, 1, pdata, 0);
+ /* rotate rows */
+ {
+ float * temp = (er_rows [0]);
+ (er_rows [0]) = (er_rows [1]);
+ (er_rows [1]) = (er_rows [2]);
+ (er_rows [2]) = temp;
+ }
+ /* initialize (clean up) the new error row */
+ for (m = ER_C; (m < ncols); m += 1)
+ (er_rows [2] [m]) = 0.0;
}
- block_write(screen_handle, x_at, (y_at-((float) i)), ncols, 1, pdata, 0); /* paint a row */
- /* */
- temp = er_rows[0]; /* rotate rows */
- er_rows[0] = er_rows[1];
- er_rows[1] = er_rows[2];
- er_rows[2] = temp;
- for (m=ER_C;m<ncols;m++) er_rows[2][m]=0.0; /* initialize (clean up) the new error row */
- }
}
-
-/* JARVIS-JUDICE-NINKE-76 mask
- */
-C_image_ht_bn_atxy_wmm_1_(Array, pdata, nrows,ncols, x_at,y_at, Min,Max, HG, er_rows)
+\f
+/* JARVIS-JUDICE-NINKE-76 mask */
+C_image_ht_bn_atxy_wmm_1_ (Array, pdata, nrows,ncols, x_at,y_at, Min,Max,
+ HG, er_rows)
REAL Array[], Min,Max;
- unsigned char *pdata;
+ unsigned char *pdata;
int nrows,ncols,HG;
float x_at,y_at, **er_rows;
{ int i,j, m, array_index;
REAL REAL_pixel, value, offset,scale, HG1_2;
float ersum, weight, pixel, *temp;
static int ER_R=3, ER_R1=2, ER_C=2, ER_C1=1;
-
- for (i=0;i<ER_R;i++)
- for (j=0;j<ncols+(2*ER_C);j++) er_rows[i][j] = 0.0; /* initialize error rows */
+
+ /* initialize error rows */
+ for (i=0;i<ER_R;i++)
+ for (j=0;j<ncols+(2*ER_C);j++)
+ er_rows[i][j] = 0.0;
HG1_2 = ((REAL) ((HG-1)*2)); /* notice this is REAL number */
- Find_Offset_Scale_For_Linear_Map(Min, Max,
- 0.0, HG1_2, &offset, &scale); /* HG output greys */
+ /* HG output greys */
+ Find_Offset_Scale_For_Linear_Map
+ (Min, Max, 0.0, HG1_2, &offset, &scale);
array_index=0;
for (i=0;i<nrows;i++) {
for (j=0;j<ncols;j++) {
- ersum = (1.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(-2)+j] + (3.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(-1)+j] +
- (5.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(0)+j] + (3.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(1)+j] +
- (1.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(2)+j] /* first row ends */
- + (3.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(-2)+j] + (5.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(-1)+j] +
- (7.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(0)+j] + (5.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(1)+j] +
- (3.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(2)+j] /* second row ends */
- + (5.0/48.0)*er_rows[ER_R1+(0)][ER_C+(-2)+j] + (7.0/48.0)*er_rows[ER_R1+(0)][ER_C+(-1)+j];
- /* this encodes the JARVIS-JUDICE-NINKE-76 mask for computating the average error correction */
+ ersum =
+ ((1.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(-2)+j] +
+ (3.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(-1)+j] +
+ (5.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(0)+j] +
+ (3.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(1)+j] +
+ (1.0/48.0)*er_rows[ER_R1+(-2)][ER_C+(2)+j] +
+ (3.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(-2)+j] +
+ (5.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(-1)+j] +
+ (7.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(0)+j] +
+ (5.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(1)+j] +
+ (3.0/48.0)*er_rows[ER_R1+(-1)][ER_C+(2)+j] +
+ (5.0/48.0)*er_rows[ER_R1+(0)][ER_C+(-2)+j] +
+ (7.0/48.0)*er_rows[ER_R1+(0)][ER_C+(-1)+j]);
+ /* this encodes the JARVIS-JUDICE-NINKE-76 mask
+ for computating the average error correction */
value = Array[array_index++];
Adjust_Value_Wmm(value, REAL_pixel, 0.0, HG1_2, Min,Max, offset,scale);
- /* */
+ /* */
pixel = ((float) REAL_pixel) + ersum; /* corrected intensity */
- INT_pixel = ((long) ((pixel + 1) / 2.0)); /* the (long) does truncation, this corresponds to "IF J>R/2 R 0" */
- pdata[j] = ((unsigned char) INT_pixel); /* output pixel to be painted */
- er_rows[ER_R1][ER_C +j] = (pixel/2.0) - ((float) INT_pixel); /* error estimate */
+ /* the (long) does truncation, this corresponds to "IF J>R/2 R 0" */
+ INT_pixel = ((long) ((pixel + 1) / 2.0));
+ pdata[j] = ((unsigned char) INT_pixel); /* output pixel to be painted */
+ /* error estimate */
+ er_rows[ER_R1][ER_C +j] = (pixel/2.0) - ((float) INT_pixel);
}
- block_write(screen_handle, x_at, (y_at-((float) i)), ncols, 1, pdata, 0); /* paint a row */
- /* */
+ /* paint a row */
+ block_write(screen_handle, x_at, (y_at-((float) i)), ncols, 1, pdata, 0);
temp = er_rows[0]; /* rotate rows */
er_rows[0] = er_rows[1];
er_rows[1] = er_rows[2];
er_rows[2] = temp;
- for (m=ER_C;m<ncols;m++) er_rows[2][m]=0.0; /* initialize (clean up) the new error row */
+ /* initialize (clean up) the new error row */
+ for (m=ER_C;m<ncols;m++) er_rows[2][m]=0.0;
}
}
-
-/* STUCKI-81 mask
- */
-C_image_ht_bn_atxy_wmm_2_(Array, pdata, nrows,ncols, x_at,y_at, Min,Max, HG, er_rows)
+\f
+/* STUCKI-81 mask */
+C_image_ht_bn_atxy_wmm_2_ (Array, pdata, nrows,ncols, x_at,y_at, Min,Max,
+ HG, er_rows)
REAL Array[], Min,Max;
- unsigned char *pdata;
+ unsigned char *pdata;
int nrows,ncols,HG;
float x_at,y_at, **er_rows;
{ int i,j, m, array_index;
REAL REAL_pixel, value, offset,scale, HG1_2;
float ersum, weight, pixel, *temp;
static int ER_R=3, ER_R1=2, ER_C=2, ER_C1=1;
-
- for (i=0;i<ER_R;i++)
- for (j=0;j<ncols+(2*ER_C);j++) er_rows[i][j] = 0.0; /* initialize error rows */
- HG1_2 = ((REAL) ((HG-1)*2)); /* notice this is REAL number */
- Find_Offset_Scale_For_Linear_Map(Min, Max,
- 0.0, HG1_2, &offset, &scale); /* HG output greys */
+
+ for (i=0;i<ER_R;i++)
+ for (j=0;j<ncols+(2*ER_C);j++)
+ er_rows[i][j] = 0.0;
+ HG1_2 = ((REAL) ((HG-1)*2));
+ Find_Offset_Scale_For_Linear_Map(Min, Max, 0.0, HG1_2, &offset, &scale);
array_index=0;
for (i=0;i<nrows;i++) {
for (j=0;j<ncols;j++) {
- ersum = (1.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(-2)+j] + (2.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(-1)+j] +
- (4.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(0)+j] + (2.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(1)+j] +
- (1.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(2)+j] /* first row ends */
- + (2.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(-2)+j] + (4.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(-1)+j] +
- (8.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(0)+j] + (4.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(1)+j] +
- (2.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(2)+j] /* second row ends */
- + (4.0/42.0)*er_rows[ER_R1+(0)][ER_C+(-2)+j] + (8.0/42.0)*er_rows[ER_R1+(0)][ER_C+(-1)+j];
- /* this encodes the STUCKI-81 mask for computating the average error correction */
+ ersum =
+ ((1.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(-2)+j] +
+ (2.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(-1)+j] +
+ (4.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(0)+j] +
+ (2.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(1)+j] +
+ (1.0/42.0)*er_rows[ER_R1+(-2)][ER_C+(2)+j] +
+ (2.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(-2)+j] +
+ (4.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(-1)+j] +
+ (8.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(0)+j] +
+ (4.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(1)+j] +
+ (2.0/42.0)*er_rows[ER_R1+(-1)][ER_C+(2)+j] +
+ (4.0/42.0)*er_rows[ER_R1+(0)][ER_C+(-2)+j] +
+ (8.0/42.0)*er_rows[ER_R1+(0)][ER_C+(-1)+j]);
+ /* this encodes the STUCKI-81 mask
+ for computating the average error correction */
value = Array[array_index++];
Adjust_Value_Wmm(value, REAL_pixel, 0.0, HG1_2, Min,Max, offset,scale);
- /* */
- pixel = ((float) REAL_pixel) + ersum; /* corrected intensity */
- INT_pixel = ((long) ((pixel + 1) / 2.0)); /* the (long) does truncation, this corresponds to "IF J>R/2 R 0" */
- pdata[j] = ((unsigned char) INT_pixel); /* output pixel to be painted */
- er_rows[ER_R1][ER_C +j] = (pixel/2.0) - ((float) INT_pixel); /* error estimate */
+ /* */
+ pixel = ((float) REAL_pixel) + ersum; /* corrected intensity */
+ /* the (long) does truncation, this corresponds to "IF J>R/2 R 0" */
+ INT_pixel = ((long) ((pixel + 1) / 2.0));
+ pdata[j] = ((unsigned char) INT_pixel); /* output pixel to be painted */
+ /* error estimate */
+ er_rows[ER_R1][ER_C +j] = (pixel/2.0) - ((float) INT_pixel);
}
- block_write(screen_handle, x_at, (y_at-((float) i)), ncols, 1, pdata, 0); /* paint a row */
- /* */
+ block_write (screen_handle, x_at, (y_at-((float) i)), ncols, 1, pdata, 0);
temp = er_rows[0]; /* rotate rows */
er_rows[0] = er_rows[1];
er_rows[1] = er_rows[2];
er_rows[2] = temp;
- for (m=ER_C;m<ncols;m++) er_rows[2][m]=0.0; /* initialize (clean up) the new error row */
+ /* initialize (clean up) the new error row */
+ for (m=ER_C;m<ncols;m++)
+ er_rows[2][m]=0.0;
}
}
-
-
-/* INTEGER BLUE NOISE
- pdata must have length ncols
- HG= Hardware Grey levels (output pixel values 0,HG-1)
- BNmethod is index for ht_ibn method
+\f
+/* INTEGER BLUE NOISE
+ pdata must have length ncols
+ HG= Hardware Grey levels (output pixel values 0,HG-1)
+ BNmethod is index for ht_ibn method
IBN = integer blue noise
- uses integer arithmetic for speed, but also has different effect
+ uses integer arithmetic for speed, but also has different effect
depending on the scaling of the integer intensities and error-corrections.
A scale of PREC_SCALE=4 gives a very clear picture, with EDGE-INHANCEMENT.
*/
/*
ht_ibn_table[][0] ---> int BN; sum of error weights
- ht_ibn_table[][1] ---> int BNentries; number of weight entries
+ ht_ibn_table[][1] ---> int BNentries; number of weight entries
ht_ibn_table[][2+i+0,1,2] ----> int row_offset,col_offset,weight;
*/
-static int ht_ibn_table[3][2+(3*12)] =
+static int ht_ibn_table[3][2+(3*12)] =
{ {16,4, -1,-1,1, -1,0,5, -1,1,3, 0,-1,7},
{48,12, -2,-2,1, -2,-1,3, -2,0,5, -2,1,3, -2,2,1,
-1,-2,3, -1,-1,5, -1,0,7, -1,1,5, -1,2,3,
0,-2,4, 0,-1,8}
};
-/*
- er_rows[][] should be 3 arrays of integers, of length (ncols+2*ER_C), which store previous errors, (ALLOCATED STORAGE)
+/*
+ er_rows[][] should be 3 arrays of integers, of length (ncols+2*ER_C),
+ which store previous errors, (ALLOCATED STORAGE)
ER_R is number of error rows, (currently 3)
- ER_C is number of extra columns (to the left and to the right) of each er_row,
- they always contain ZEROS and serve to simplify the error summing process, i.e. we don't have
- to check for i,j bounds at edges, (no conditionals in the sum loop).
+ ER_C is number of extra columns (to the left and right) of each er_row,
+ they always contain ZEROS and serve to simplify the error summing process,
+ i.e. we don't have to check for i,j bounds at edges
+ (no conditionals in the sum loop).
Also, the code handles all cases in a uniform manner.
- (for better explanation get pas halftoning notes)
- */
-C_image_ht_ibn_atxy_wmm(Array, pdata, nrows,ncols, x_at,y_at, Min,Max, HG,BNmethod, er_rows, PREC_SCALE)
- REAL Array[], Min,Max;
- unsigned char *pdata;
+ (for better explanation get pas halftoning notes) */
+
+C_image_ht_ibn_atxy_wmm (Array, pdata, nrows,ncols, x_at,y_at, Min,Max,
+ HG,BNmethod, er_rows, PREC_SCALE)
+ REAL Array[], Min,Max;
+ unsigned char *pdata;
int nrows,ncols,HG,BNmethod;
MINTEGER **er_rows, PREC_SCALE;
float x_at,y_at;
{ int i,j, m, BNentries, array_index, row_offset, col_offset;
- MINTEGER BN, ersum, weight, PREC_2, PREC, *temp, pixel;
- /* PREC is a scale factor that varies the precision in ersum -- using integer arithmetic for speed */
- REAL REAL_pixel, value, offset,scale, HG1_2_PREC;
+ MINTEGER BN, ersum, weight, PREC_2, PREC, *temp, pixel;
+ /* PREC is a scale factor that varies the precision in ersum
+ -- using integer arithmetic for speed */
+ REAL REAL_pixel, value, offset,scale, HG1_2_PREC;
static int ER_R=3, ER_R1=2, ER_C=2, ER_C1=1;
-
- for (i=0;i<ER_R;i++)
- for (j=0;j<ncols+(2*ER_C);j++) er_rows[i][j] = 0; /* initialize error rows */
+
+ for (i=0;i<ER_R;i++)
+ for (j=0;j<ncols+(2*ER_C);j++) er_rows[i][j] = 0;
BN = ((MINTEGER) ht_ibn_table[BNmethod][0]);
BNentries = ht_ibn_table[BNmethod][1];
- /* */
HG1_2_PREC = ((REAL) PREC_SCALE);
/* HG1_2_PREC = ((REAL) ( (1<<( 8*(sizeof(MINTEGER))-1 )) / BN)); */
/* max_intensity maps to (max_integer/BN), so that */
- PREC_2 = ((MINTEGER) HG1_2_PREC) / ((MINTEGER) (HG-1)); /* neither ersum*BN nor (max_intensity + ersum) overflow */
+ /* neither ersum*BN nor (max_intensity + ersum) overflow */
+ PREC_2 = ((MINTEGER) HG1_2_PREC) / ((MINTEGER) (HG-1));
PREC = PREC_2 / 2;
- /* */
- Find_Offset_Scale_For_Linear_Map(Min, Max,
- 0.0, HG1_2_PREC, &offset, &scale); /* HG output greys */
- array_index=0;
+ Find_Offset_Scale_For_Linear_Map
+ (Min, Max, 0.0, HG1_2_PREC, &offset, &scale);
+ array_index=0;
for (i=0;i<nrows;i++) {
for (j=0;j<ncols;j++) {
ersum=0;
- for (m=0;m<(3*BNentries); m=m+3) { row_offset = ht_ibn_table[BNmethod][2+m+0]; /* should be 0,1,2 */
- col_offset = ht_ibn_table[BNmethod][2+m+1];
- weight = ((MINTEGER) ht_ibn_table[BNmethod][2+m+2]);
- ersum += weight * er_rows[ER_R1+row_offset][ER_C +j+ col_offset]; } /*ATT*/
+ for (m=0;m<(3*BNentries); m=m+3)
+ {
+ row_offset = ht_ibn_table[BNmethod][2+m+0]; /* should be 0,1,2 */
+ col_offset = ht_ibn_table[BNmethod][2+m+1];
+ weight = ((MINTEGER) ht_ibn_table[BNmethod][2+m+2]);
+ ersum += weight * er_rows[ER_R1+row_offset][ER_C +j+ col_offset];
+ }
ersum = ersum / BN;
- /* */
value = Array[array_index++];
- Adjust_Value_Wmm(value, REAL_pixel, 0.0, HG1_2_PREC, Min,Max, offset,scale);
- pixel = ((MINTEGER) REAL_pixel); /* Turn into integer--- integer arithmetic gives speed */
- /* */
+ Adjust_Value_Wmm
+ (value, REAL_pixel, 0.0, HG1_2_PREC, Min,Max, offset,scale);
+ pixel = ((MINTEGER) REAL_pixel);
pixel = pixel + ersum; /* corrected intensity */
- ersum = ((pixel + PREC) / PREC_2); /* integer division -- ersum is used as temp -- */
- pdata[j] = ((unsigned char) ersum); /* output pixel to be painted -- range is 0,HG1 -- */
- er_rows[ER_R1][ER_C +j] = pixel - (PREC_2*ersum); /* error estimate */
+ ersum = ((pixel + PREC) / PREC_2);
+ pdata[j] = ((unsigned char) ersum);
+ er_rows[ER_R1][ER_C +j] = pixel - (PREC_2*ersum);
}
- block_write(screen_handle, x_at, (y_at-((float) i)), ncols, 1, pdata, 0); /* paint a row */
- /* */
+ block_write (screen_handle, x_at, (y_at-((float) i)), ncols, 1, pdata, 0);
temp = er_rows[0]; /* rotate rows */
er_rows[0] = er_rows[1];
er_rows[1] = er_rows[2];
er_rows[2] = temp;
- for (m=0;m<(ncols+(2*ER_C));m++) er_rows[2][m]=0; /* initialize (clean up) the new error row */
- }
-}
-
-
-
-/* PSAM drawing (see scheme primitives above, for description)
- Pdata must be 4*16*ncols in size.
- */
-C_image_psam_atxy_wmm(Array, pdata, nrows, ncols, x_origin, y_origin, Min,Max)
- REAL Array[], Min,Max;
- unsigned char *pdata; /* pdata should have length 16*4*ncols */
- long nrows, ncols;
- float x_origin, y_origin;
-{ register long i,j, i4;
- register long array_index, pdata_index;
- long ncols4 = 4 * ncols;
- long color_index;
- REAL REAL_pixel, value, offset,scale;
-
- Find_Offset_Scale_For_Linear_Map(Min, Max,
- 0.0, 15.0, &offset, &scale); /* 16 grey levels */
-
- array_index=0; i4=0;
- for (i=0; i<nrows; i++)
- { pdata_index = 0;
- for (j=0; j<ncols; j++)
- { value = Array[array_index++];
- Adjust_Value_Wmm(value, REAL_pixel, 0.0, 15.0, Min,Max, offset,scale);
- color_index = ((long) (REAL_pixel + .5)); /* integer between 0 and 15 */
- /* */
- my_write_dither(pdata, pdata_index, ncols4, color_index);
- pdata_index = pdata_index + 4; /* dependency between this and my_write_dither */
- }
- block_write(screen_handle, x_origin, y_origin-i4, ncols4, 4, pdata, 0);
- i4 = i4+4;
+ for (m=0;m<(ncols+(2*ER_C));m++) er_rows[2][m]=0;
}
- /* A(i,j) --> Array[i*ncols + j] */
}
-
-/* Same as above, except use Adjust_Value_Womm.
- */
-C_image_psam_atxy_womm(Array, pdata, nrows, ncols, x_origin, y_origin, Min,Max)
- REAL Array[], Min,Max;
- unsigned char *pdata; /* pdata should have length 16*4*ncols */
- long nrows, ncols;
- float x_origin, y_origin;
-{ register long i,j, i4;
- register long array_index, pdata_index;
- long ncols4 = 4*ncols;
- long color_index;
- REAL REAL_pixel, value, offset,scale;
-
- Find_Offset_Scale_For_Linear_Map(Min, Max,
- 0.0, 15.0, &offset, &scale); /* 16 grey levels */
- array_index=0; i4=0;
- for (i=0; i<nrows; i++)
- { pdata_index = 0;
- for (j=0; j<ncols; j++)
- { value = Array[array_index++];
- Adjust_Value_Womm(value, REAL_pixel, 0.0, 15.0, Min,Max, offset,scale); /* ONLY DIFFERENCE WITH PREVIOUS ONE */
- color_index = ((long) (REAL_pixel + .5)); /* integer between 0 and 15 */
- /* */
- my_write_dither(pdata, pdata_index, ncols4, color_index);
- pdata_index = pdata_index + 4; /* dependency between this and my_write_dither */
- }
- block_write(screen_handle, x_origin, y_origin-i4, ncols4, 4, pdata, 0);
- i4 = i4+4;
- }
- /* A(i,j) --> Array[i*ncols + j] */
-}
-
+\f
/* psam dither[11] is left out, { 1,1,0,1, 1,1,1,0, 0,1,1,0, 1,0,1,1 } */
/* The following routine writes a 4x4 dither cell
in 4 consecutive rows of pdata. It assumes a lot about
- pdata and the other args passed to it. READ carefully.
- Designed TO BE USED BY C_image_psam_atxy_wmm
-*/
-
-my_write_dither(pdata, pdata_row_index, ncols , color_index)
- unsigned char *pdata;
- long pdata_row_index, ncols;
- long color_index; /* should be 0 to 15 */
-{ static unsigned char dither_table[16][16] = {{ 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0 },
- { 0,0,0,0, 0,1,0,0, 0,0,0,0, 0,0,0,0 },
- { 0,0,0,0, 0,1,0,0, 0,0,1,0, 0,0,0,0 },
- { 0,0,0,0, 0,1,1,0, 0,0,1,0, 0,0,0,0 },
- { 0,0,0,0, 0,1,1,0, 0,1,1,0, 0,0,0,0 },
- { 1,0,0,0, 0,1,1,0, 0,1,1,0, 0,0,0,0 },
- { 1,0,0,0, 0,1,1,0, 0,1,1,0, 0,0,0,1 },
- { 1,0,0,1, 0,1,1,0, 0,1,1,0, 0,0,0,1 },
- { 1,0,0,1, 0,1,1,0, 0,1,1,0, 1,0,0,1 },
- { 1,1,0,1, 0,1,1,0, 0,1,1,0, 1,0,0,1 },
- { 1,1,0,1, 1,1,1,0, 0,1,1,0, 1,0,0,1 },
- { 1,1,0,1, 1,1,1,0, 0,1,1,1, 1,0,1,1 },
- { 1,1,0,1, 1,1,1,0, 1,1,1,1, 1,0,1,1 },
- { 1,1,1,1, 1,1,1,0, 1,1,1,1, 1,0,1,1 },
- { 1,1,1,1, 1,1,1,0, 1,1,1,1, 1,1,1,1 },
- { 1,1,1,1, 1,1,1,1, 1,1,1,1, 1,1,1,1 }};
- long i, row_start,m;
- long dither_index; /* do not mix up the counters, indexes */
- dither_index=0;
- for (i=0;i<4;i++) { row_start = pdata_row_index + (i*ncols);
- for (m=row_start; m<row_start+4; m++)
- pdata[m] = dither_table[color_index][dither_index++]; }
+ pdata and the other args passed to it; read carefully.
+ Designed to be used by C_image_psam_atxy_wmm. */
+
+static void
+write_dither (pdata, ncols, color_index)
+ unsigned char * pdata;
+ long ncols;
+ long color_index; /* should be 0 to 15 */
+{
+ static unsigned char dither_table [16] [16] =
+ {
+ { 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0 },
+ { 0,0,0,0, 0,1,0,0, 0,0,0,0, 0,0,0,0 },
+ { 0,0,0,0, 0,1,0,0, 0,0,1,0, 0,0,0,0 },
+ { 0,0,0,0, 0,1,1,0, 0,0,1,0, 0,0,0,0 },
+ { 0,0,0,0, 0,1,1,0, 0,1,1,0, 0,0,0,0 },
+ { 1,0,0,0, 0,1,1,0, 0,1,1,0, 0,0,0,0 },
+ { 1,0,0,0, 0,1,1,0, 0,1,1,0, 0,0,0,1 },
+ { 1,0,0,1, 0,1,1,0, 0,1,1,0, 0,0,0,1 },
+ { 1,0,0,1, 0,1,1,0, 0,1,1,0, 1,0,0,1 },
+ { 1,1,0,1, 0,1,1,0, 0,1,1,0, 1,0,0,1 },
+ { 1,1,0,1, 1,1,1,0, 0,1,1,0, 1,0,0,1 },
+ { 1,1,0,1, 1,1,1,0, 0,1,1,1, 1,0,1,1 },
+ { 1,1,0,1, 1,1,1,0, 1,1,1,1, 1,0,1,1 },
+ { 1,1,1,1, 1,1,1,0, 1,1,1,1, 1,0,1,1 },
+ { 1,1,1,1, 1,1,1,0, 1,1,1,1, 1,1,1,1 },
+ { 1,1,1,1, 1,1,1,1, 1,1,1,1, 1,1,1,1 }
+ };
+ long dither_index = 0;
+ long i;
+ for (i = 0; (i < 4); i += 1)
+ {
+ fast unsigned char * scan_row = (pdata + (i * ncols));
+ fast unsigned char * end_row = (scan_row + 4);
+ while (scan_row < end_row)
+ (*scan_row++) = (dither_table [color_index] [dither_index++]);
+ }
}
\f
+/* PSAM drawing (see scheme primitives above, for description)
+ Pdata must be (16 * ncols) bytes in size. */
+
+#define DEFINE_PSAM_DRAWING(procedure_name, adjustment) \
+procedure_name (array, pdata, nrows, ncols, x_origin, y_origin, Min, Max) \
+ fast REAL * array; \
+ REAL Min; \
+ REAL Max; \
+ unsigned char * pdata; \
+ long nrows; \
+ long ncols; \
+ float x_origin; \
+ float y_origin; \
+{ \
+ long ncols4 = (4 * ncols); \
+ fast float y = y_origin; \
+ fast long i; \
+ long color_index; \
+ REAL REAL_pixel; \
+ REAL offset; \
+ REAL scale; \
+ Find_Offset_Scale_For_Linear_Map \
+ (Min, Max, 0.0, 15.0, &offset, &scale); \
+ for (i = 0; (i < nrows); i += 1) \
+ { \
+ fast unsigned char * scan_pdata = pdata; \
+ fast unsigned char * end_pdata = (scan_pdata + ncols4); \
+ while (scan_pdata < end_pdata) \
+ { \
+ REAL value = (*array++); \
+ adjustment \
+ (value, REAL_pixel, 0.0, 15.0, Min, Max, offset, scale); \
+ color_index = ((long) (REAL_pixel + 0.5)); \
+ write_dither (scan_pdata, ncols4, color_index); \
+ scan_pdata += 4; \
+ } \
+ block_write (screen_handle, x_origin, y, ncols4, 4, pdata, 0); \
+ y += 4; \
+ } \
+}
+
+DEFINE_PSAM_DRAWING (C_image_psam_atxy_wmm, Adjust_Value_Wmm)
+DEFINE_PSAM_DRAWING (C_image_psam_atxy_womm, Adjust_Value_Womm)
+\f
/* Below are the OLD DRAWING ROUTINES for 16 color monitors.
In effect they are fixed threshold, with 16 HG levels.
The only difference is they also do magnification by replicating pixels.
*/
-/* Image_Draw_Magnify_N_Times : N^2 in area
+/* Image_Draw_Magnify_N_Times : N^2 in area
*/
-Image_Draw_Magnify_N_Times_With_Offset_Scale(Array, pdata, nrows, ncols,
- x_origin, y_origin, Offset, Scale, N)
+Image_Draw_Magnify_N_Times_With_Offset_Scale (Array, pdata, nrows, ncols,
+ x_origin, y_origin,
+ Offset, Scale, N)
REAL Array[], Offset, Scale;
unsigned char *pdata;
long nrows, ncols, N;
float x_origin, y_origin;
-{ register long i,j,m;
- register long array_index;
+{ fast long i,j,m;
+ fast long array_index;
long ncolsN= N * ncols;
long nrowsN= N * nrows;
- register unsigned char pixel;
- register REAL REAL_pixel;
-
+ fast unsigned char pixel;
+ fast REAL REAL_pixel;
+
array_index = 0;
for (i = 0; i < nrowsN;) /* note that i is NOT incremented here */
{ for (j = 0; j < ncolsN;) /* note that j is NOT incremented here */
}
}
-/* Image_Draw_Magnify_N_Times_Only : N^2 in area
- This procedure throws away (i.e. maps to SCREEN_BACKGROUND_COLOR)
+/* Image_Draw_Magnify_N_Times_Only : N^2 in area
+ This procedure throws away (i.e. maps to SCREEN_BACKGROUND_COLOR)
all values outside the range given by Offset,Scale.
*/
-Image_Draw_Magnify_N_Times_With_Offset_Scale_Only(Array, pdata, nrows, ncols,
- x_origin, y_origin, Offset, Scale, N)
+Image_Draw_Magnify_N_Times_With_Offset_Scale_Only (Array, pdata, nrows, ncols,
+ x_origin, y_origin,
+ Offset, Scale, N)
REAL Array[], Offset, Scale;
unsigned char *pdata;
long nrows, ncols, N;
float x_origin, y_origin;
-{ register long i,j,m;
- register long array_index;
+{ fast long i,j,m;
+ fast long array_index;
long ncolsN= N * ncols;
long nrowsN= N * nrows;
- register unsigned char pixel;
- register REAL REAL_pixel;
-
+ fast unsigned char pixel;
+ fast REAL REAL_pixel;
+
array_index = 0;
for (i=0; i<nrowsN;) /* note that i is NOT incremented here */
{ for (j=0; j<ncolsN;) /* note that j is NOT incremented here */
{ REAL_pixel = Offset + (Array[array_index++] * Scale);
- if (REAL_pixel > 15.0) pixel = SCREEN_BACKGROUND_COLOR;
- else if (REAL_pixel < 2.0) pixel = SCREEN_BACKGROUND_COLOR;
- else pixel = ((unsigned char) (Round_REAL(REAL_pixel)));
- for (m=0; m<N; m++)
+ if (REAL_pixel > 15.0)
+ pixel = SCREEN_BACKGROUND_COLOR;
+ else if (REAL_pixel < 2.0)
+ pixel = SCREEN_BACKGROUND_COLOR;
+ else
+ pixel = ((unsigned char) (Round_REAL(REAL_pixel)));
+ for (m=0; m<N; m++)
{ pdata[j] = pixel;
j++; }
}
*/
\f
-/*_______________________ Grey Level Manipulations _____________________ */
+/* Grey Level Manipulations */
DEFINE_PRIMITIVE ("NEW-COLOR", Prim_new_color, 4, 4, 0)
-{ int i, err;
+{
long index;
- float red, green, blue;
- Primitive_4_Args();
-
- Range_Check(index, Arg1, STARBASE_COLOR_TABLE_START, (STARBASE_COLOR_TABLE_SIZE - 1), ERR_ARG_1_BAD_RANGE);
- Float_Range_Check(red, Arg2, 0, 1, ERR_ARG_2_BAD_RANGE);
- Float_Range_Check(green, Arg3, 0, 1, ERR_ARG_3_BAD_RANGE);
- Float_Range_Check(blue, Arg4, 0, 1, ERR_ARG_4_BAD_RANGE);
-
- inquire_color_table(screen_handle, STARBASE_COLOR_TABLE_START, STARBASE_COLOR_TABLE_SIZE, Color_Table);
- Color_Table[index][0] = red;
- Color_Table[index][1] = green;
- Color_Table[index][2] = blue;
- define_color_table(screen_handle, STARBASE_COLOR_TABLE_START, STARBASE_COLOR_TABLE_SIZE, Color_Table);
- PRIMITIVE_RETURN(SHARP_T);
-}
-\f
-DEFINE_PRIMITIVE ("INQUIRE-COLORS", Prim_inquire_colors, 0, 0, 0)
-{ int i;
- Primitive_0_Args();
-
- inquire_color_table(screen_handle, STARBASE_COLOR_TABLE_START, STARBASE_COLOR_TABLE_SIZE, Color_Table);
- for (i = 0; i < STARBASE_COLOR_TABLE_SIZE; i++)
- printf("%d %f %f %f\n", i, Color_Table[i][0], Color_Table[i][1], Color_Table[i][2]); /* implem. dependent */
- PRIMITIVE_RETURN(SHARP_T);
+ PRIMITIVE_HEADER (4);
+ index =
+ (arg_integer_in_range
+ (1, STARBASE_COLOR_TABLE_START, STARBASE_COLOR_TABLE_SIZE));
+ inquire_color_table
+ (screen_handle,
+ STARBASE_COLOR_TABLE_START,
+ STARBASE_COLOR_TABLE_SIZE,
+ Color_Table);
+ (Color_Table [index] [0]) =
+ (arg_real_in_range (2, ((double) 0), ((double) 1)));
+ (Color_Table [index] [1]) =
+ (arg_real_in_range (3, ((double) 0), ((double) 1)));
+ (Color_Table [index] [2]) =
+ (arg_real_in_range (4, ((double) 0), ((double) 1)));
+ define_color_table
+ (screen_handle,
+ STARBASE_COLOR_TABLE_START,
+ STARBASE_COLOR_TABLE_SIZE,
+ Color_Table);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("INQUIRE-COLOR", Prim_inquire_color, 1, 1, 0)
-{ int i; int index;
- Pointer Answer, *Orig_Free;
- REAL red, green, blue;
- Primitive_1_Args();
-
- Arg_1_Type(TC_FIXNUM);
- Range_Check(index, Arg1, STARBASE_COLOR_TABLE_START,
- (STARBASE_COLOR_TABLE_SIZE-1), ERR_ARG_1_BAD_RANGE);
- inquire_color_table(screen_handle, STARBASE_COLOR_TABLE_START,
- STARBASE_COLOR_TABLE_SIZE, Color_Table);
- red = ((REAL) Color_Table[index][0]);
- green = ((REAL) Color_Table[index][1]);
- blue = ((REAL) Color_Table[index][2]);
- Primitive_GC_If_Needed(6);
- Answer = Make_Pointer(TC_LIST, Free);
- Orig_Free = Free;
- Free += 6;
- Store_Reduced_Flonum_Result(red, *Orig_Free);
- Orig_Free++;
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- Store_Reduced_Flonum_Result(green, *Orig_Free);
- Orig_Free++;
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- Store_Reduced_Flonum_Result(blue, *Orig_Free);
- Orig_Free++;
- *Orig_Free = EMPTY_LIST;
- PRIMITIVE_RETURN(Answer);
+{
+ int index;
+ PRIMITIVE_HEADER (1);
+ index =
+ (arg_integer_in_range
+ (1, STARBASE_COLOR_TABLE_START, STARBASE_COLOR_TABLE_SIZE));
+ inquire_color_table
+ (screen_handle,
+ STARBASE_COLOR_TABLE_START,
+ STARBASE_COLOR_TABLE_SIZE,
+ Color_Table);
+ PRIMITIVE_RETURN
+ (cons ((double_to_flonum ((double) (Color_Table[index][0]))),
+ (cons ((double_to_flonum ((double) (Color_Table[index][1]))),
+ (cons ((double_to_flonum ((double) (Color_Table[index][2]))),
+ EMPTY_LIST))))));
}
\f
DEFINE_PRIMITIVE ("READ-COLORS-FROM-FILE", Prim_read_colors_from_file, 1, 1, 0)
-{ long i;
- FILE *fopen(), *fp;
- char *file_string;
- Boolean Open_File();
- Primitive_1_Args();
-
- Arg_1_Type(TC_CHARACTER_STRING);
- if (!(Open_File(Arg1, "r", &fp)))
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- if (feof(fp)!=0)
- {
- fprintf(stderr, "\nColor Datafile is empty!\n");
- Primitive_Error(ERR_EXTERNAL_RETURN);
- }
- for (i = 0; i < STARBASE_COLOR_TABLE_SIZE; i++)
- fscanf(fp,"%f %f %f\n", &Color_Table[i][0],
- &Color_Table[i][1], &Color_Table[i][2]);
- Close_File(fp); /* fflush(stdout); */
- define_color_table(screen_handle, STARBASE_COLOR_TABLE_START,
- STARBASE_COLOR_TABLE_SIZE, Color_Table);
- PRIMITIVE_RETURN(SHARP_T);
+{
+ long i;
+ FILE * fp;
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, STRING_P);
+ fp = (fopen ((ARG_REF (1)), "r"));
+ if (fp == ((FILE *) 0))
+ error_bad_range_arg (1);
+ if (feof (fp))
+ {
+ fprintf (stderr, "\nColor Datafile is empty!\n");
+ error_external_return ();
+ }
+ for (i = 0; (i < STARBASE_COLOR_TABLE_SIZE); i += 1)
+ fscanf (fp, "%f %f %f\n",
+ (& (Color_Table [i] [0])),
+ (& (Color_Table [i] [1])),
+ (& (Color_Table [i] [2])));
+ if ((fclose (fp)) != 0)
+ error_external_return ();
+ define_color_table
+ (screen_handle,
+ STARBASE_COLOR_TABLE_START,
+ STARBASE_COLOR_TABLE_SIZE,
+ Color_Table);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("SAVE-COLORS-IN-FILE", Prim_save_colors_in_file, 1, 1, 0)
-{ long i;
- FILE *fopen(), *fp;
- char *file_string;
- 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);
- inquire_color_table(screen_handle, STARBASE_COLOR_TABLE_START,
- STARBASE_COLOR_TABLE_SIZE, Color_Table);
- for (i = 0; i < STARBASE_COLOR_TABLE_SIZE; i++)
- fprintf(fp,"%f %f %f\n", Color_Table[i][0], Color_Table[i][1], Color_Table[i][2]);
- Close_File(fp);
- PRIMITIVE_RETURN(SHARP_T);
+{
+ long i;
+ FILE * fp;
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, STRING_P);
+ fp = (fopen ((ARG_REF (1)), "r"));
+ if (fp == ((FILE *) 0))
+ error_bad_range_arg (1);
+ inquire_color_table
+ (screen_handle,
+ STARBASE_COLOR_TABLE_START,
+ STARBASE_COLOR_TABLE_SIZE,
+ Color_Table);
+ for (i = 0; (i < STARBASE_COLOR_TABLE_SIZE); i += 1)
+ fprintf (fp, "%f %f %f\n",
+ (Color_Table [i] [0]),
+ (Color_Table [i] [1]),
+ (Color_Table [i] [2]));
+ if ((fclose (fp)) != 0)
+ error_external_return ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-/* END */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/sgx.c,v 1.6 1989/06/22 23:01:50 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/sgx.c,v 1.7 1989/09/20 23:04:51 cph Rel $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
#include <X/Xhp.h>
#include "scheme.h"
#include "prims.h"
-#include "flonum.h"
#include "Sgraph.h"
\f
static Display * display = NULL;
X server is running on the named display.")
{
PRIMITIVE_HEADER (1);
-
/* Only one display at a time. */
close_display ();
-
/* Grab error handlers. */
XErrorHandler (x_error_handler);
XIOErrorHandler (x_io_error_handler);
-
display =
(XOpenDisplay (((ARG_REF (1)) == SHARP_F) ? NULL : (STRING_ARG (1))));
window = 0;
(filename [0]) = '\0';
raster_state = 0;
- PRIMITIVE_RETURN ((display != NULL) ? SHARP_T : SHARP_F);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (display != NULL));
}
DEFINE_PRIMITIVE ("X-GRAPHICS-CLOSE-DISPLAY", Prim_x_graphics_close_display, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
close_display ();
- PRIMITIVE_RETURN (SHARP_F);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
static void
}
\f
/* (X-GRAPHICS-OLD-OPEN-WINDOW x y width height border-width)
-
Opens a window at the given position, with the given border width,
on the current display. If another window was previously opened
using this primitive, it is closed. */
{
XhpArgItem arglist [7];
PRIMITIVE_HEADER (5);
-
GUARANTEE_DISPLAY ();
-
/* Allow only one window open at a time. */
close_window ();
-
/* Open the window with the given arguments. */
window =
(XCreateWindow (RootWindow,
XFlush ();
(filename [0]) = '\0';
raster_state = 0;
-
/* Create a starbase device file. */
if ((XhpFile ((& (filename [0])), window, display)) == 0)
{
close_window ();
error_external_return ();
}
-
/* Return the filename so it can be passed to starbase. */
- PRIMITIVE_RETURN (C_String_To_Scheme_String (& (filename [0])));
+ PRIMITIVE_RETURN (char_pointer_to_string (& (filename [0])));
}
DEFINE_PRIMITIVE ("X-GRAPHICS-CLOSE-WINDOW", Prim_x_graphics_close_window, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
close_window ();
- PRIMITIVE_RETURN (SHARP_F);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
static void
DEFINE_PRIMITIVE ("X-GRAPHICS-MAP-WINDOW", Prim_x_graphics_map_window, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
GUARANTEE_WINDOW ();
XMapWindow (window);
XFlush ();
- PRIMITIVE_RETURN (SHARP_F);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("X-GRAPHICS-UNMAP-WINDOW", Prim_x_graphics_unmap_window, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
GUARANTEE_WINDOW ();
XUnmapWindow (window);
XFlush ();
- PRIMITIVE_RETURN (SHARP_F);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("X-GRAPHICS-RAISE-WINDOW", Prim_x_graphics_raise_window, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
GUARANTEE_WINDOW ();
XRaiseWindow (window);
XFlush ();
- PRIMITIVE_RETURN (SHARP_F);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("X-GRAPHICS-LOWER-WINDOW", Prim_x_graphics_lower_window, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
GUARANTEE_WINDOW ();
XLowerWindow (window);
XFlush ();
- PRIMITIVE_RETURN (SHARP_F);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("X-GRAPHICS-CONFIGURE-WINDOW", Prim_x_graphics_configure_window, 4, 4, 0)
{
PRIMITIVE_HEADER (4);
-
GUARANTEE_WINDOW ();
if (raster_state != 0)
error_external_return ();
(arg_nonnegative_integer (3)),
(arg_nonnegative_integer (4)));
XFlush ();
- PRIMITIVE_RETURN (SHARP_F);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
/* Routines to control the backup raster. */
DEFINE_PRIMITIVE ("X-GRAPHICS-CREATE-RASTER", Prim_x_graphics_create_raster, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
GUARANTEE_WINDOW ();
delete_raster ();
XhpRetainWindow (window, XhpCREATE_RASTER);
XFlush ();
raster_state = 1;
- PRIMITIVE_RETURN (SHARP_F);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("X-GRAPHICS-DELETE-RASTER", Prim_x_graphics_delete_raster, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
GUARANTEE_WINDOW ();
delete_raster ();
- PRIMITIVE_RETURN (SHARP_F);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
static void
DEFINE_PRIMITIVE ("X-GRAPHICS-START-RETAIN", Prim_x_graphics_start_retain, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
GUARANTEE_WINDOW ();
GUARANTEE_RASTER ();
XhpRetainWindow (window, XhpSTART_RETAIN);
XFlush ();
- PRIMITIVE_RETURN (SHARP_F);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("X-GRAPHICS-STOP-RETAIN", Prim_x_graphics_stop_retain, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
GUARANTEE_WINDOW ();
GUARANTEE_RASTER ();
XhpRetainWindow (window, XhpSTOP_RETAIN);
XFlush ();
- PRIMITIVE_RETURN (SHARP_F);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/sgx11.c,v 1.1 1989/02/24 09:24:50 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/sgx11.c,v 1.2 1989/09/20 23:04:57 cph Rel $
Copyright (c) 1989 Massachusetts Institute of Technology
DEFINE_PRIMITIVE ("X-GRAPHICS-DISPLAY-NAME", Prim_x_graphics_display_name, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
PRIMITIVE_RETURN
- (C_String_To_Scheme_String
+ (char_pointer_to_string
(XDisplayName (((ARG_REF (1)) == SHARP_F) ? NULL : (STRING_ARG (1)))));
}
DEFINE_PRIMITIVE ("X-GRAPHICS-GRAB-ERROR-HANDLERS", Prim_x_graphics_grab_error_handlers, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
XSetErrorHandler (x_error_handler);
XSetIOErrorHandler (x_io_error_handler);
- PRIMITIVE_RETURN (SHARP_F);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.27 1989/09/20 23:11:35 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.26 1988/08/15 20:55:15 cph Rel $ */
-
/* This file contains macros for manipulating stacks and stacklets. */
\f
#ifdef USE_STACKLETS
Microcode_Termination(TERM_STACK_ALLOCATION_FAILED); \
} \
Stack_Guard = (Free + STACKLET_HEADER_SIZE); \
- *Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, \
- (Default_Stacklet_Size - 1)); \
+ *Free = \
+ (MAKE_OBJECT (TC_MANIFEST_VECTOR, (Default_Stacklet_Size - 1))); \
Free += Default_Stacklet_Size; \
Stack_Pointer = Free; \
Free_Stacklets = NULL; \
{ \
Current_Stacklet[STACKLET_REUSE_FLAG] = SHARP_T; \
Current_Stacklet[STACKLET_UNUSED_LENGTH] = \
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, \
- (Stack_Pointer - Stack_Guard)); \
+ MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Stack_Pointer - Stack_Guard)); \
}
#ifdef ENABLE_DEBUGGING_TOOLS
/* 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); \
+ *Free_Constant = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Free_Constant);\
Where = Free_Constant
#define Get_Current_Stacklet() \
- Make_Pointer(TC_CONTROL_POINT, Current_Stacklet)
+ (MAKE_POINTER_OBJECT (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)))))
+ (MEMORY_LOC \
+ (Where, \
+ (STACKLET_HEADER_SIZE + \
+ (OBJECT_DATUM (MEMORY_REF (Where, STACKLET_UNUSED_LENGTH))))))
#define Set_Current_Stacklet(Where) \
{ \
- Pointer Our_Where; \
+ SCHEME_OBJECT Our_Where; \
\
Our_Where = (Where); \
- Stack_Guard = Nth_Vector_Loc(Our_Where, STACKLET_HEADER_SIZE); \
+ Stack_Guard = MEMORY_LOC (Our_Where, STACKLET_HEADER_SIZE); \
Stack_Pointer = Previous_Stack_Pointer(Our_Where); \
}
(STACKLET_SLACK + Stack_Size * (((N) + Stack_Size - 1) / Stack_Size))
#define Get_End_Of_Stacklet() \
- (&(Current_Stacklet[1 + Get_Integer(Current_Stacklet[STACKLET_LENGTH])]))
+ (&(Current_Stacklet[1 + OBJECT_DATUM (Current_Stacklet[STACKLET_LENGTH])]))
\f
#define Apply_Stacklet_Backout() \
Will_Push((2 * CONTINUATION_SIZE) + (STACK_ENV_EXTRA_SLOTS + 2)); \
- Store_Expression(NIL); \
+ Store_Expression(SHARP_F); \
Store_Return(RC_END_OF_COMPUTATION); \
Save_Cont(); \
Push(Val); \
#define Within_Stacklet_Backout() \
{ \
- Pointer Old_Expression; \
+ SCHEME_OBJECT Old_Expression; \
\
Old_Expression = Fetch_Expression(); \
Store_Expression(Previous_Stacklet); \
#define Our_Throw(From_Pop_Return, Stacklet) \
{ \
- Pointer Previous_Stacklet; \
- Pointer *Stacklet_Top; \
+ SCHEME_OBJECT Previous_Stacklet; \
+ SCHEME_OBJECT *Stacklet_Top; \
\
Previous_Stacklet = (Stacklet); \
Stacklet_Top = Current_Stacklet; \
Stacklet_Top[STACKLET_FREE_LIST_LINK] = \
- ((Pointer) Free_Stacklets); \
+ ((SCHEME_OBJECT) Free_Stacklets); \
Free_Stacklets = Stacklet_Top; \
if (!(From_Pop_Return)) \
{ \
Prev_Restore_History_Stacklet = NULL; \
Prev_Restore_History_Offset = 0; \
} \
- if ((Vector_Ref(Previous_Stacklet, STACKLET_REUSE_FLAG)) == NIL) \
+ if ((MEMORY_REF (Previous_Stacklet, STACKLET_REUSE_FLAG)) == SHARP_F) \
{ \
/* We need to copy the stacklet into which we are \
returning. \
*/ \
\
- if (GC_Check(Vector_Length(Previous_Stacklet) + 1)) \
+ if (GC_Check(VECTOR_LENGTH (Previous_Stacklet) + 1)) \
{ \
/* We don't have enough space to copy the stacklet. */ \
\
Free_Stacklets = \
- ((Pointer *) Free_Stacklets[STACKLET_FREE_LIST_LINK]); \
+ ((SCHEME_OBJECT *) Free_Stacklets[STACKLET_FREE_LIST_LINK]); \
Stack_Pointer = Get_End_Of_Stacklet(); \
Prev_Restore_History_Stacklet = NULL; \
Prev_Restore_History_Offset = 0
/* Backout code inserted here by macro user */
\f
#define Our_Throw_Part_2() \
- Request_GC(Vector_Length(Previous_Stacklet) + 1); \
+ Request_GC(VECTOR_LENGTH (Previous_Stacklet) + 1); \
} \
else \
{ \
\
long Unused_Length; \
fast Used_Length; \
- fast Pointer *Old_Stacklet_Top, *temp; \
- Pointer *First_Continuation; \
+ fast SCHEME_OBJECT *Old_Stacklet_Top, *temp; \
+ SCHEME_OBJECT *First_Continuation; \
\
- Old_Stacklet_Top = Get_Pointer(Previous_Stacklet); \
+ Old_Stacklet_Top = OBJECT_ADDRESS (Previous_Stacklet); \
First_Continuation = \
- Nth_Vector_Loc(Previous_Stacklet, \
- ((1 + Vector_Length(Previous_Stacklet)) - \
- CONTINUATION_SIZE)); \
+ MEMORY_LOC (Previous_Stacklet, \
+ ((1 + VECTOR_LENGTH (Previous_Stacklet)) - \
+ CONTINUATION_SIZE)); \
if (Old_Stacklet_Top == Prev_Restore_History_Stacklet) \
{ \
Prev_Restore_History_Stacklet = NULL; \
} \
if (First_Continuation[CONTINUATION_RETURN_CODE] == \
- Make_Non_Pointer(TC_RETURN_CODE, RC_JOIN_STACKLETS)) \
+ MAKE_OBJECT (TC_RETURN_CODE, RC_JOIN_STACKLETS)) \
{ \
- Pointer Older_Stacklet; \
+ SCHEME_OBJECT Older_Stacklet; \
\
Older_Stacklet = First_Continuation[CONTINUATION_EXPRESSION]; \
- Vector_Set(Older_Stacklet, STACKLET_REUSE_FLAG, NIL); \
+ MEMORY_SET (Older_Stacklet, STACKLET_REUSE_FLAG, SHARP_F); \
} \
-\f \
temp = Free; \
Stack_Guard = &(temp[STACKLET_HEADER_SIZE]); \
temp[STACKLET_LENGTH] = Old_Stacklet_Top[STACKLET_LENGTH]; \
Unused_Length = \
- Get_Integer(Old_Stacklet_Top[STACKLET_UNUSED_LENGTH]) + \
+ OBJECT_DATUM (Old_Stacklet_Top[STACKLET_UNUSED_LENGTH]) + \
STACKLET_HEADER_SIZE; \
temp += Unused_Length; \
Stack_Pointer = temp; \
Used_Length = \
- (Get_Integer(Old_Stacklet_Top[STACKLET_LENGTH]) - \
+ (OBJECT_DATUM (Old_Stacklet_Top[STACKLET_LENGTH]) - \
Unused_Length) + 1; \
Old_Stacklet_Top += Unused_Length; \
while (--Used_Length >= 0) \
{ \
/* No need to copy the stacklet we are going into */ \
\
- if (Get_Pointer(Previous_Stacklet)== \
+ if (OBJECT_ADDRESS (Previous_Stacklet)== \
Prev_Restore_History_Stacklet) \
{ \
Prev_Restore_History_Stacklet = NULL; \
Set_Current_Stacklet(Previous_Stacklet); \
} \
}
-\f
+\f
#else /* not USE_STACKLETS */
/*
#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); \
+ (MAKE_OBJECT \
+ (TC_MANIFEST_NM_VECTOR, ((Stack_Pointer - Free_Constant) - 1))); \
+ *Stack_Top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Top); \
Where = Stack_Top; \
}
-#define Get_Current_Stacklet() NIL
+#define Get_Current_Stacklet() SHARP_F
#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)))))
+ (MEMORY_LOC \
+ (Where, \
+ (STACKLET_HEADER_SIZE + \
+ (OBJECT_DATUM (MEMORY_REF (Where, STACKLET_UNUSED_LENGTH))))))
/* Never allocate more space */
#define New_Stacklet_Size(N) 0
#define Our_Throw(From_Pop_Return, P) \
{ \
- Pointer Control_Point; \
- fast Pointer *To_Where, *From_Where; \
+ SCHEME_OBJECT Control_Point; \
+ fast SCHEME_OBJECT *To_Where, *From_Where; \
fast long len, valid, invalid; \
\
Control_Point = (P); \
if (Consistency_Check) \
{ \
- if (OBJECT_TYPE(Control_Point) != TC_CONTROL_POINT) \
+ if (OBJECT_TYPE (Control_Point) != TC_CONTROL_POINT) \
{ \
Microcode_Termination (TERM_BAD_STACK); \
} \
} \
- len = Vector_Length (Control_Point); \
- invalid = ((Get_Integer (Vector_Ref (Control_Point, \
- STACKLET_UNUSED_LENGTH))) + \
+ len = VECTOR_LENGTH (Control_Point); \
+ invalid = ((OBJECT_DATUM (MEMORY_REF (Control_Point, \
+ STACKLET_UNUSED_LENGTH))) + \
STACKLET_HEADER_SIZE); \
valid = ((len + 1) - invalid); \
CLEAR_INTERRUPT(INT_Stack_Overflow); \
To_Where = (Stack_Top - valid); \
- From_Where = Nth_Vector_Loc (Control_Point, invalid); \
+ From_Where = MEMORY_LOC (Control_Point, invalid); \
Stack_Check (To_Where); \
Stack_Pointer = To_Where; \
while (--valid >= 0) \
{ \
*To_Where++ = *From_Where++; \
} \
-\f \
if (Consistency_Check) \
{ \
if ((To_Where != Stack_Top) || \
(From_Where != \
- Nth_Vector_Loc (Control_Point, (1 + len)))) \
+ MEMORY_LOC (Control_Point, (1 + len)))) \
{ \
Microcode_Termination (TERM_BAD_STACK); \
} \
Prev_Restore_History_Stacklet = NULL; \
Prev_Restore_History_Offset = 0; \
if ((!Valid_Fixed_Obj_Vector ()) || \
- (Get_Fixed_Obj_Slot (Dummy_History) == NIL)) \
+ (Get_Fixed_Obj_Slot (Dummy_History) == SHARP_F)) \
{ \
History = Make_Dummy_History (); \
} \
else \
{ \
- History = Get_Pointer (Get_Fixed_Obj_Slot (Dummy_History)); \
+ History = OBJECT_ADDRESS (Get_Fixed_Obj_Slot (Dummy_History)); \
} \
} \
else if (Prev_Restore_History_Stacklet == \
- Get_Pointer (Control_Point)) \
+ OBJECT_ADDRESS (Control_Point)) \
{ \
Prev_Restore_History_Stacklet = NULL; \
} \
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/starbase.c,v 1.2 1989/06/21 11:46:20 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/starbase.c,v 1.3 1989/09/20 23:11:39 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
-#include "flonum.h"
#include <starbase.c.h>
\f
static void
float p1 [3];
float p2 [3];
int cmap_size;
-
inquire_sizes (fildes, physical_limits, resolution, p1, p2, (& cmap_size));
return (cmap_size);
}
#define SB_DEVICE_ARG(arg) (arg_nonnegative_integer (arg))
-
-#define FLONUM_ARG(argno, target) \
-{ \
- fast Pointer argument; \
- fast long fixnum_value; \
- \
- argument = (ARG_REF (argno)); \
- switch (OBJECT_TYPE (argument)) \
- { \
- case TC_FIXNUM: \
- FIXNUM_VALUE (argument, fixnum_value); \
- target = ((float) fixnum_value); \
- break; \
- \
- case TC_BIG_FLONUM: \
- target = ((float) (Get_Float (argument))); \
- break; \
- \
- default: \
- error_wrong_type_arg (argno); \
- } \
-}
\f
DEFINE_PRIMITIVE ("STARBASE-OPEN-DEVICE", Prim_starbase_open_device, 2, 2,
"(STARBASE-OPEN-DEVICE DEVICE-NAME DRIVER-NAME)")
{
- int descriptor;
PRIMITIVE_HEADER (2);
-
- descriptor = (gopen ((STRING_ARG (1)), OUTDEV, (STRING_ARG (2)), 0));
- if (descriptor == (-1))
- PRIMITIVE_RETURN (SHARP_F);
- set_vdc_extent (descriptor, (-1.0), (-1.0), (1.0), (1.0));
- mapping_mode (descriptor, DISTORT);
- set_line_color_index (descriptor, 1);
- line_type (descriptor, 0);
- drawing_mode (descriptor, 3);
- text_alignment
- (descriptor, TA_NORMAL_HORIZONTAL, TA_NORMAL_VERTICAL, (0.0), (0.0));
- interior_style (descriptor, INT_HOLLOW, 1);
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (descriptor));
+ {
+ int descriptor = (gopen ((STRING_ARG (1)), OUTDEV, (STRING_ARG (2)), 0));
+ if (descriptor == (-1))
+ PRIMITIVE_RETURN (SHARP_F);
+ set_vdc_extent (descriptor, (-1.0), (-1.0), (1.0), (1.0));
+ mapping_mode (descriptor, DISTORT);
+ set_line_color_index (descriptor, 1);
+ line_type (descriptor, 0);
+ drawing_mode (descriptor, 3);
+ text_alignment
+ (descriptor, TA_NORMAL_HORIZONTAL, TA_NORMAL_VERTICAL, (0.0), (0.0));
+ interior_style (descriptor, INT_HOLLOW, 1);
+ PRIMITIVE_RETURN (long_to_integer (descriptor));
+ }
}
DEFINE_PRIMITIVE ("STARBASE-CLOSE-DEVICE", Prim_starbase_close_device, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
gclose (SB_DEVICE_ARG (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("STARBASE-FLUSH", Prim_starbase_flush, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
make_picture_current (SB_DEVICE_ARG (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
Uses the Starbase CLEAR_VIEW_SURFACE procedure.")
{
PRIMITIVE_HEADER (1);
-
clear_view_surface (SB_DEVICE_ARG (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
Subsequently move the graphics cursor to those coordinates.\n\
Uses the starbase procedures `move2d' and `draw2d'.")
{
- int descriptor;
- fast float x, y;
PRIMITIVE_HEADER (3);
-
- descriptor = (SB_DEVICE_ARG (1));
- FLONUM_ARG (2, x);
- FLONUM_ARG (3, y);
- move2d (descriptor, x, y);
- draw2d (descriptor, x, y);
+ {
+ int descriptor = (SB_DEVICE_ARG (1));
+ fast float x = (arg_real_number (2));
+ fast float y = (arg_real_number (3));
+ move2d (descriptor, x, y);
+ draw2d (descriptor, x, y);
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
Move the graphics cursor to the given coordinates.\n\
Uses the starbase procedure `move2d'.")
{
- int descriptor;
- fast float x, y;
PRIMITIVE_HEADER (3);
-
- descriptor = (SB_DEVICE_ARG (1));
- FLONUM_ARG (2, x);
- FLONUM_ARG (3, y);
- move2d (descriptor, x, y);
+ move2d ((SB_DEVICE_ARG (1)), (arg_real_number (2)), (arg_real_number (3)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
Subsequently move the graphics cursor to those coordinates.\n\
Uses the starbase procedure `draw2d'.")
{
- int descriptor;
- fast float x, y;
PRIMITIVE_HEADER (3);
-
- descriptor = (SB_DEVICE_ARG (1));
- FLONUM_ARG (2, x);
- FLONUM_ARG (3, y);
- draw2d (descriptor, x, y);
+ draw2d ((SB_DEVICE_ARG (1)), (arg_real_number (2)), (arg_real_number (3)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
Subsequently move the graphics cursor to the end coordinates.\n\
Uses the starbase procedures `move2d' and `draw2d'.")
{
- int descriptor;
- fast float x_start, y_start, x_end, y_end;
PRIMITIVE_HEADER (5);
-
- descriptor = (SB_DEVICE_ARG (1));
- FLONUM_ARG (2, x_start);
- FLONUM_ARG (3, y_start);
- FLONUM_ARG (4, x_end);
- FLONUM_ARG (5, y_end);
- move2d (descriptor, x_start, y_start);
- draw2d (descriptor, x_end, y_end);
+ {
+ int descriptor = (SB_DEVICE_ARG (1));
+ fast float x_start = (arg_real_number (2));
+ fast float y_start = (arg_real_number (3));
+ fast float x_end = (arg_real_number (4));
+ fast float y_end = (arg_real_number (5));
+ move2d (descriptor, x_start, y_start);
+ draw2d (descriptor, x_end, y_end);
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
See the description of the starbase procedure `line_type'.")
{
PRIMITIVE_HEADER (2);
-
line_type ((SB_DEVICE_ARG (1)), (arg_index_integer (2, 8)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
See the description of the starbase procedure `drawing_mode'.")
{
PRIMITIVE_HEADER (2);
-
drawing_mode ((SB_DEVICE_ARG (1)), (arg_index_integer (2, 16)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
float p1 [3];
float p2 [3];
int cmap_size;
- Pointer result;
PRIMITIVE_HEADER (1);
-
inquire_sizes
((SB_DEVICE_ARG (1)), physical_limits, resolution, p1, p2, (& cmap_size));
- result = (allocate_marked_vector (TC_VECTOR, 4, true));
- User_Vector_Set
- (result, 0, (Allocate_Float ((double) (physical_limits [0][0]))));
- User_Vector_Set
- (result, 1, (Allocate_Float ((double) (physical_limits [0][1]))));
- User_Vector_Set
- (result, 2, (Allocate_Float ((double) (physical_limits [1][0]))));
- User_Vector_Set
- (result, 3, (Allocate_Float ((double) (physical_limits [1][1]))));
- PRIMITIVE_RETURN (result);
+ {
+ SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, true));
+ VECTOR_SET (result, 0, (FLOAT_TO_FLONUM (physical_limits[0][0])));
+ VECTOR_SET (result, 1, (FLOAT_TO_FLONUM (physical_limits[0][1])));
+ VECTOR_SET (result, 2, (FLOAT_TO_FLONUM (physical_limits[1][0])));
+ VECTOR_SET (result, 3, (FLOAT_TO_FLONUM (physical_limits[1][1])));
+ PRIMITIVE_RETURN (result);
+ }
}
DEFINE_PRIMITIVE ("STARBASE-SET-VDC-EXTENT", Prim_starbase_set_vdc_extent, 5, 5, 0)
{
- fast float xmin, ymin, xmax, ymax;
PRIMITIVE_HEADER (5);
-
- FLONUM_ARG (2, xmin);
- FLONUM_ARG (3, ymin);
- FLONUM_ARG (4, xmax);
- FLONUM_ARG (5, ymax);
- set_vdc_extent ((SB_DEVICE_ARG (1)), xmin, ymin, xmax, ymax);
+ set_vdc_extent
+ ((SB_DEVICE_ARG (1)),
+ (arg_real_number (2)),
+ (arg_real_number (3)),
+ (arg_real_number (4)),
+ (arg_real_number (5)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
"(STARBASE-RESET-CLIP-RECTANGLE DEVICE)\n\
Undo the clip rectangle. Subsequently, clipping is not affected by it.")
{
- int descriptor;
PRIMITIVE_HEADER (1);
-
- descriptor = (SB_DEVICE_ARG (1));
- clip_indicator (descriptor, CLIP_TO_VDC);
- clear_control (descriptor, CLEAR_VDC_EXTENT);
+ {
+ int descriptor = (SB_DEVICE_ARG (1));
+ clip_indicator (descriptor, CLIP_TO_VDC);
+ clear_control (descriptor, CLEAR_VDC_EXTENT);
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
"(STARBASE-SET-CLIP-RECTANGLE X-LEFT Y-BOTTOM X-RIGHT Y-TOP)\n\
Restrict the graphics drawing primitives to the area in the given rectangle.")
{
- int descriptor;
- fast float x_left, x_right, y_bottom, y_top;
PRIMITIVE_HEADER (5);
-
- descriptor = (SB_DEVICE_ARG (1));
- FLONUM_ARG (2, x_left);
- FLONUM_ARG (3, y_bottom);
- FLONUM_ARG (4, x_right);
- FLONUM_ARG (5, y_top);
- clip_rectangle (descriptor, x_left, x_right, y_bottom, y_top);
- clip_indicator (descriptor, CLIP_TO_RECT);
- clear_control (descriptor, CLEAR_CLIP_RECTANGLE);
+ {
+ int descriptor = (SB_DEVICE_ARG (1));
+ fast float x_left = (arg_real_number (2));
+ fast float y_bottom = (arg_real_number (3));
+ fast float x_right = (arg_real_number (4));
+ fast float y_top = (arg_real_number (5));
+ clip_rectangle (descriptor, x_left, x_right, y_bottom, y_top);
+ clip_indicator (descriptor, CLIP_TO_RECT);
+ clear_control (descriptor, CLEAR_CLIP_RECTANGLE);
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
DEFINE_PRIMITIVE ("STARBASE-DRAW-TEXT", Prim_starbase_draw_text, 4, 4,
"(STARBASE-DRAW-TEXT DEVICE X Y STRING)")
{
- fast float x, y;
PRIMITIVE_HEADER (4);
-
- FLONUM_ARG (2, x);
- FLONUM_ARG (3, y);
- text2d ((SB_DEVICE_ARG (1)), x, y, (STRING_ARG (4)), VDC_TEXT, FALSE);
+ text2d
+ ((SB_DEVICE_ARG (1)),
+ (arg_real_number (2)),
+ (arg_real_number (3)),
+ (STRING_ARG (4)),
+ VDC_TEXT,
+ FALSE);
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-HEIGHT", Prim_starbase_set_text_height, 2, 2,
"(STARBASE-SET-TEXT-HEIGHT DEVICE HEIGHT)")
{
- fast float height;
PRIMITIVE_HEADER (2);
-
- FLONUM_ARG (2, height);
- character_height ((SB_DEVICE_ARG (1)), height);
+ character_height ((SB_DEVICE_ARG (1)), (arg_real_number (2)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-ASPECT", Prim_starbase_set_text_aspect, 2, 2,
"(STARBASE-SET-TEXT-ASPECT DEVICE ASPECT)")
{
- fast float aspect;
PRIMITIVE_HEADER (2);
-
- FLONUM_ARG (2, aspect);
- character_expansion_factor ((SB_DEVICE_ARG (1)), aspect);
+ character_expansion_factor ((SB_DEVICE_ARG (1)), (arg_real_number (2)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-SLANT", Prim_starbase_set_text_slant, 2, 2,
"(STARBASE-SET-TEXT-SLANT DEVICE SLANT)")
{
- fast float slant;
PRIMITIVE_HEADER (2);
-
- FLONUM_ARG (2, slant);
- character_slant ((SB_DEVICE_ARG (1)), slant);
+ character_slant ((SB_DEVICE_ARG (1)), (arg_real_number (2)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-ROTATION", Prim_starbase_set_text_rotation, 2, 2,
"(STARBASE-SET-TEXT-ROTATION DEVICE ANGLE)")
{
- fast float angle;
- fast int path_style;
PRIMITIVE_HEADER (2);
-
- FLONUM_ARG (2, angle);
- if ((angle > 315.0) || (angle <= 45.0))
- path_style = PATH_RIGHT;
- else if ((angle > 45.0) && (angle <= 135.0))
- path_style = PATH_DOWN;
- else if ((angle > 135.0) && (angle <= 225.0))
- path_style = PATH_LEFT;
- else if ((angle > 225.0) && (angle <= 315.0))
- path_style = PATH_UP;
- text_path ((SB_DEVICE_ARG (1)), path_style);
+ {
+ fast float angle = (arg_real_number (2));
+ fast int path_style;
+ if ((angle > 315.0) || (angle <= 45.0))
+ path_style = PATH_RIGHT;
+ else if ((angle > 45.0) && (angle <= 135.0))
+ path_style = PATH_DOWN;
+ else if ((angle > 135.0) && (angle <= 225.0))
+ path_style = PATH_LEFT;
+ else if ((angle > 225.0) && (angle <= 315.0))
+ path_style = PATH_UP;
+ text_path ((SB_DEVICE_ARG (1)), path_style);
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
DEFINE_PRIMITIVE ("STARBASE-COLOR-MAP-SIZE", Prim_starbase_color_map_size, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN
- (C_Integer_To_Scheme_Integer (inquire_cmap_size (SB_DEVICE_ARG (1))));
+ PRIMITIVE_RETURN (long_to_integer (inquire_cmap_size (SB_DEVICE_ARG (1))));
}
DEFINE_PRIMITIVE ("STARBASE-DEFINE-COLOR", Prim_starbase_define_color, 5, 5,
int descriptor;
float colors [1][3];
PRIMITIVE_HEADER (5);
-
descriptor = (SB_DEVICE_ARG (1));
- FLONUM_ARG (3, colors[0][0]);
- FLONUM_ARG (4, colors[0][1]);
- FLONUM_ARG (5, colors[0][2]);
+ (colors [0] [0]) = (arg_real_number (3));
+ (colors [0] [1]) = (arg_real_number (4));
+ (colors [0] [2]) = (arg_real_number (5));
define_color_table
(descriptor,
(arg_index_integer (2, (inquire_cmap_size (descriptor)))),
{
int descriptor;
PRIMITIVE_HEADER (2);
-
descriptor = (SB_DEVICE_ARG (1));
set_line_color_index
(descriptor, (arg_index_integer (2, (inquire_cmap_size (descriptor)))));
If INVERT? is not #F, invert black and white in the output.")
{
PRIMITIVE_HEADER (3);
-
- print_graphics
- ((SB_DEVICE_ARG (2)), (STRING_ARG (2)), ((ARG_REF (3)) != SHARP_F));
+ print_graphics ((SB_DEVICE_ARG (2)), (STRING_ARG (2)), (BOOLEAN_ARG (3)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
inquire_cmap_mask (fildes)
int fildes;
{
- int cmap_size;
-
- cmap_size = (inquire_cmap_size (fildes));
- return (((cmap_size >= 0) && (cmap_size < 8)) ?
- ((1 << cmap_size) - 1) :
- (-1));
+ int cmap_size = (inquire_cmap_size (fildes));
+ return
+ (((cmap_size >= 0) && (cmap_size < 8))
+ ? ((1 << cmap_size) - 1)
+ : (-1));
}
static int
open_dumpfile (dumpname)
char * dumpname;
{
- int dumpfile;
-
- dumpfile = (creat (dumpname, 0666));
+ int dumpfile = (creat (dumpname, 0666));
if (dumpfile == (-1))
{
fprintf (stderr, "\nunable to create graphics dump file.");
+ fflush (stderr);
error_external_return ();
}
dumpfile = (open (dumpname, OUTINDEV));
if (dumpfile == (-1))
{
fprintf (stderr, "\nunable to open graphics dump file.");
+ fflush (stderr);
error_external_return ();
}
return (dumpfile);
char * dumpname;
int inverse_p;
{
- int dumpfile;
-
- dumpfile = (open_dumpfile (dumpname));
-
+ int dumpfile = (open_dumpfile (dumpname));
write (dumpfile, rasres, (strlen (rasres)));
write (dumpfile, rastop, (strlen (rastop)));
write (dumpfile, raslft, (strlen (raslft)));
write (dumpfile, rasbeg, (strlen (rasbeg)));
-
{
- fast unsigned char mask;
+ fast unsigned char mask = (inquire_cmap_mask (descriptor));
int col;
-
- mask = (inquire_cmap_mask (descriptor));
for (col = (1024 - 16); (col >= 0); col = (col - 16))
{
unsigned char pixdata [(16 * 768)];
-
{
- fast unsigned char * p;
- fast unsigned char * pe;
-
- p = (& (pixdata [0]));
- pe = (& (pixdata [sizeof (pixdata)]));
+ fast unsigned char * p = (& (pixdata [0]));
+ fast unsigned char * pe = (& (pixdata [sizeof (pixdata)]));
while (p < pe)
(*p++) = '\0';
}
dcblock_read (descriptor, col, 0, 16, 768, pixdata, 0);
{
int x;
-
for (x = (16 - 1); (x >= 0); x -= 1)
{
unsigned char rasdata [96];
- fast unsigned char * p;
- fast unsigned char * r;
+ fast unsigned char * p = (& (pixdata [x]));
+ fast unsigned char * r = rasdata;
int n;
-
- p = (& (pixdata [x]));
- r = rasdata;
for (n = 0; (n < 96); n += 1)
{
- fast unsigned char c;
+ fast unsigned char c = 0;
int nn;
-
- c = 0;
for (nn = 0; (nn < 8); nn += 1)
{
c <<= 1;
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/starbasx.c,v 1.2 1989/06/21 11:46:12 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/starbasx.c,v 1.3 1989/09/20 23:11:43 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
PRIMITIVE_RETURN
((starbase_filename == ((char *) 0))
? SHARP_F
- : (C_String_To_Scheme_String (starbase_filename)));
+ : (char_pointer_to_string (starbase_filename)));
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/step.c,v 9.26 1989/05/31 01:51:02 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/step.c,v 9.27 1989/09/20 23:11:47 cph Exp $
*
* Support for the stepper
*/
void
Install_Traps(Hunk3, Return_Hook_Too)
- Pointer Hunk3;
+ SCHEME_OBJECT Hunk3;
Boolean Return_Hook_Too;
{
- Pointer Eval_Hook, Apply_Hook, Return_Hook;
+ SCHEME_OBJECT 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);
+ Eval_Hook = MEMORY_REF (Hunk3, HUNK_CXR0);
+ Apply_Hook = MEMORY_REF (Hunk3, HUNK_CXR1);
+ Return_Hook = MEMORY_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))
+ Trapping = ((Eval_Hook != SHARP_F) | (Apply_Hook != SHARP_F));
+ if (Microcode_Does_Stepping && Return_Hook_Too && (Return_Hook != SHARP_F))
{
/* 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
*/
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);
+ *Return_Hook_Address =
+ (MAKE_OBJECT (TC_RETURN_CODE, RC_RETURN_TRAP_POINT));
}
return;
}
DEFINE_PRIMITIVE ("PRIMITIVE-EVAL-STEP", Prim_eval_step, 3, 3, 0)
{
- Primitive_3_Args();
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- Install_Traps(Arg3, false);
- Pop_Primitive_Frame(3);
- Store_Expression(Arg1);
- Store_Env(Arg2);
- PRIMITIVE_ABORT(PRIM_NO_TRAP_EVAL);
+ PRIMITIVE_HEADER (3);
+ {
+ SCHEME_OBJECT expression = (ARG_REF (1));
+ SCHEME_OBJECT environment = (ARG_REF (2));
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ Install_Traps ((ARG_REF (3)), false);
+ Pop_Primitive_Frame (3);
+ Store_Expression (expression);
+ Store_Env (environment);
+ }
+ PRIMITIVE_ABORT (PRIM_NO_TRAP_EVAL);
/*NOTREACHED*/
}
\f
APPLY or return.
Mostly a copy of Prim_Apply, since this, too, must count the space
- required before actually building a frame
-*/
+ required before actually building a frame */
DEFINE_PRIMITIVE ("PRIMITIVE-APPLY-STEP", Prim_apply_step, 3, 3, 0)
{
- Pointer Next_From_Slot, *Next_To_Slot;
- long Number_Of_Args, i;
- Primitive_3_Args();
-
- PRIMITIVE_CANONICALIZE_CONTEXT();
- Arg_3_Type(TC_HUNK3);
- Number_Of_Args = 0;
- Next_From_Slot = Arg2;
- while (Type_Code(Next_From_Slot) == TC_LIST)
+ PRIMITIVE_HEADER (3);
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+ CHECK_ARG (3, HUNK3_P);
{
- Number_Of_Args += 1;
- Next_From_Slot = Vector_Ref(Next_From_Slot, CONS_CDR);
+ SCHEME_OBJECT procedure = (ARG_REF (2));
+ SCHEME_OBJECT argument_list = (ARG_REF (3));
+ fast long number_of_args = 0;
+ {
+ fast SCHEME_OBJECT scan_list;
+ TOUCH_IN_PRIMITIVE (argument_list, scan_list);
+ while (PAIR_P (scan_list))
+ {
+ number_of_args += 1;
+ TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
+ }
+ if (scan_list != EMPTY_LIST)
+ error_wrong_type_arg (2);
+ }
+ Install_Traps ((ARG_REF (3)), true);
+ Pop_Primitive_Frame (3);
+ {
+ fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
+ fast SCHEME_OBJECT scan_list;
+ fast long i;
+ Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1);
+ Stack_Pointer = scan_stack;
+ TOUCH_IN_PRIMITIVE (argument_list, scan_list);
+ for (i = number_of_args; (i > 0); i -= 1)
+ {
+ (*scan_stack++) = (PAIR_CAR (scan_list));
+ TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
+ }
+ Push (procedure);
+ Push (STACK_FRAME_HEADER + number_of_args);
+ Pushed ();
+ }
}
- 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();
- PRIMITIVE_ABORT(PRIM_NO_TRAP_APPLY);
+ PRIMITIVE_ABORT (PRIM_NO_TRAP_APPLY);
/*NOTREACHED*/
}
\f
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!
-*/
+ this is ever changed, be sure to check for COMPILE_STEPPER flag! */
DEFINE_PRIMITIVE ("PRIMITIVE-RETURN-STEP", Prim_return_step, 2, 2, 0)
{
- 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);
- PRIMITIVE_RETURN(Arg1);
+ PRIMITIVE_HEADER (2);
+ if ((MEMORY_REF ((ARG_REF (2)), HUNK_CXR2)) != SHARP_F)
+ error_bad_range_arg (2);
+ Install_Traps ((ARG_REF (2)), false);
+ PRIMITIVE_RETURN (ARG_REF (1));
}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.44 1989/09/20 23:11:51 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.43 1988/08/15 20:55:32 cph Rel $
-
-This file defines the storage for global variables for
-the Scheme Interpreter. */
+/* This file defines the storage for the interpreter's global variables. */
#include "scheme.h"
#include "gctype.c"
/* REGISTERS */
/*************/
-Pointer
- *Ext_History, /* History register */
- *Free, /* Next free word in storage */
- *MemTop, /* Top of free 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 */
- *Constant_Top, /* Top of constant+pure space */
- *Heap_Top, /* Top of current heap */
- *Heap_Bottom, /* Bottom of current heap */
- *Unused_Heap_Top, /* Top of other heap */
- *Unused_Heap, /* Bottom of other heap */
- *Local_Heap_Base, /* Per-processor CONSing area */
- *Heap, /* Bottom of entire heap */
- Current_State_Point = NIL, /* Used by dynamic winder */
- Fluid_Bindings = NIL, /* Fluid bindings AList */
- *last_return_code, /* Address of the most recent return code in the stack.
+SCHEME_OBJECT
+ * Ext_History, /* History register */
+ * Free, /* Next free word in storage */
+ * MemTop, /* Top of free 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 */
+ * Constant_Top, /* Top of constant+pure space */
+ * Heap_Top, /* Top of current heap */
+ * Heap_Bottom, /* Bottom of current heap */
+ * Unused_Heap_Top, /* Top of other heap */
+ * Unused_Heap, /* Bottom of other heap */
+ * Local_Heap_Base, /* Per-processor CONSing area */
+ * Heap, /* Bottom of entire heap */
+ Current_State_Point, /* Used by dynamic winder */
+ Fluid_Bindings, /* Fluid bindings AList */
+ * 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. ***
- */
- Swap_Temp; /* Used by Swap_Pointers in default.h */
-\f
+ *** This must be changed when stacklets are used. */
+
long
IntCode, /* Interrupts requesting */
IntEnb, /* Interrupts enabled */
temp_long, /* temporary for sign extension */
- GC_Reserve = 4500, /* Scheme pointer overflow space in heap */
- GC_Space_Needed = 0, /* Amount of space needed when GC triggered */
+ 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;
char **Saved_argv;
char *OS_Name, *OS_Variant;
-Boolean Photo_Open = false; /* Photo file open */
+Boolean Photo_Open; /* Photo file open */
Boolean Trapping;
-Pointer Old_Return_Code, *Return_Hook_Address;
+SCHEME_OBJECT Old_Return_Code, *Return_Hook_Address;
-Pointer *Prev_Restore_History_Stacklet;
+SCHEME_OBJECT *Prev_Restore_History_Stacklet;
long Prev_Restore_History_Offset;
jmp_buf *Back_To_Eval; /* Buffer for set/longjmp */
long Heap_Size, Constant_Size, Stack_Size;
-Pointer *Highest_Allocated_Address;
+SCHEME_OBJECT *Highest_Allocated_Address;
#ifndef Heap_In_Low_Memory
-Pointer *Memory_Base;
+SCHEME_OBJECT * memory_base;
#endif
\f
Boolean Eval_Debug = false;
Boolean Hex_Input_Debug = false;
Boolean File_Load_Debug = false;
-Boolean Reloc_Debug = false;
+Boolean Reloc_Debug = false;
Boolean Intern_Debug = false;
Boolean Cont_Debug = false;
Boolean Primitive_Debug = false;
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/string.c,v 9.33 1989/09/20 23:11:55 cph Rel $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/string.c,v 9.32 1989/04/28 03:47:37 cph Rel $ */
-
/* String primitives. */
#include "scheme.h"
#include "prims.h"
-#include "char.h"
-#include "string.h"
\f
-Pointer
+SCHEME_OBJECT
allocate_string (nbytes)
fast long nbytes;
{
- fast long count;
- fast Pointer result;
-
- /* Add 1 to nbytes to account for '\0' at end of string.
- Add 1 to count to account for string header words. */
-
- count = ((BYTES_TO_POINTERS (nbytes + 1)) + 1);
- result = (allocate_non_marked_vector (TC_CHARACTER_STRING, count, true));
- set_string_length (result, nbytes);
+ fast long count = (STRING_LENGTH_TO_GC_LENGTH (nbytes));
+ fast SCHEME_OBJECT result =
+ (allocate_non_marked_vector (TC_CHARACTER_STRING, count, true));
+ SET_STRING_LENGTH (result, nbytes);
return (result);
}
-Pointer
+SCHEME_OBJECT
memory_to_string (nbytes, data)
- fast long nbytes;
- fast char *data;
+ long nbytes;
+ fast unsigned char * data;
{
- Pointer result;
- fast char *scan_result;
-
- result = (allocate_string (nbytes));
- scan_result = (string_pointer (result, 0));
- while ((nbytes--) > 0)
+ SCHEME_OBJECT result = (allocate_string (nbytes));
+ fast unsigned char * scan_result = (STRING_LOC (result, 0));
+ fast unsigned char * end_result = (scan_result + nbytes);
+ while (scan_result < end_result)
(*scan_result++) = (*data++);
return (result);
}
+SCHEME_OBJECT
+char_pointer_to_string (char_pointer)
+ unsigned char * char_pointer;
+{
+ unsigned char * scan = char_pointer;
+ while ((*scan++) != '\0')
+ ;
+ return (memory_to_string (((scan - 1) - char_pointer), char_pointer));
+}
+
/* Currently the strings used in symbols have type codes in the length
field. They should be changed to have just longwords there. */
DEFINE_PRIMITIVE ("STRING-ALLOCATE", Prim_string_allocate, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
PRIMITIVE_RETURN (allocate_string (arg_nonnegative_integer (1)));
}
DEFINE_PRIMITIVE ("STRING?", Prim_string_p, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN ((STRING_P (ARG_REF (1))) ? SHARP_T : NIL);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (STRING_P (ARG_REF (1))));
}
\f
DEFINE_PRIMITIVE ("STRING-LENGTH", Prim_string_length, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
CHECK_ARG (1, STRING_P);
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (string_length (ARG_REF (1))));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (STRING_LENGTH (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("STRING-MAXIMUM-LENGTH", Prim_string_maximum_length, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
CHECK_ARG (1, STRING_P);
PRIMITIVE_RETURN
- (Make_Unsigned_Fixnum ((maximum_string_length (ARG_REF (1))) - 1));
+ (LONG_TO_UNSIGNED_FIXNUM (MAXIMUM_STRING_LENGTH (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("SET-STRING-LENGTH!", Prim_set_string_length, 2, 2, 0)
{
- fast Pointer string;
- fast long length;
- fast long result;
PRIMITIVE_HEADER (2);
-
CHECK_ARG (1, STRING_P);
- string = (ARG_REF (1));
- length = (arg_nonnegative_integer (2));
- if (length > (maximum_string_length (string)))
- error_bad_range_arg (2);
-
- result = (string_length (string));
- set_string_length (string, length);
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (result));
+ {
+ fast SCHEME_OBJECT string = (ARG_REF (1));
+ SET_STRING_LENGTH
+ (string,
+ (arg_index_integer (2, ((MAXIMUM_STRING_LENGTH (string)) + 1))));
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("SET-STRING-MAXIMUM-LENGTH!", Prim_set_string_maximum_length, 2, 2, 0)
{
- fast Pointer string;
- fast long length;
PRIMITIVE_HEADER (2);
-
CHECK_ARG (1, STRING_P);
- string = (ARG_REF (1));
- length = (arg_nonnegative_integer (2));
- if (length > (maximum_string_length (string)))
- error_bad_range_arg (2);
-
- Vector_Set (string,
- STRING_HEADER,
- (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR,
- ((BYTES_TO_POINTERS (length + 1)) + 1))));
- set_string_length (string, length);
- PRIMITIVE_RETURN (Make_Non_Pointer (TC_TRUE, 1));
-}
-
-long
-substring_length_min (start1, end1, start2, end2)
- long start1, end1, start2, end2;
-{
- fast long length1, length2;
-
- length1 = (end1 - start1);
- length2 = (end2 - start2);
- return ((length1 < length2) ? length1 : length2);
+ {
+ fast SCHEME_OBJECT string = (ARG_REF (1));
+ fast long length =
+ (arg_index_integer (2, ((MAXIMUM_STRING_LENGTH (string)) + 1)));
+ MEMORY_SET
+ (string,
+ STRING_HEADER,
+ (MAKE_OBJECT
+ (TC_MANIFEST_NM_VECTOR, ((BYTES_TO_WORDS (length + 1)) + 1))));
+ SET_STRING_LENGTH (string, length);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
#define STRING_REF_BODY(process_result) \
- fast Pointer string; \
- fast long index; \
+{ \
PRIMITIVE_HEADER (2); \
- \
CHECK_ARG (1, STRING_P); \
- string = (ARG_REF (1)); \
- index = (arg_index_integer (2, (string_length (string)))); \
- \
- PRIMITIVE_RETURN (process_result (string_ref (string, index)))
+ { \
+ fast SCHEME_OBJECT string = (ARG_REF (1)); \
+ PRIMITIVE_RETURN \
+ (process_result \
+ (STRING_REF \
+ (string, (arg_index_integer (2, (STRING_LENGTH (string))))))); \
+ } \
+}
DEFINE_PRIMITIVE ("STRING-REF", Prim_string_ref, 2, 2, 0)
-{ STRING_REF_BODY (c_char_to_scheme_char); }
+ STRING_REF_BODY (ASCII_TO_CHAR)
DEFINE_PRIMITIVE ("VECTOR-8B-REF", Prim_vec_8b_ref, 2, 2, 0)
-{ STRING_REF_BODY (Make_Unsigned_Fixnum); }
-
-#define STRING_SET_BODY(get_ascii, process_result) \
- fast Pointer string; \
- fast long index; \
- long ascii; \
- char *char_pointer; \
- Pointer result; \
+ STRING_REF_BODY (LONG_TO_UNSIGNED_FIXNUM)
+
+#define STRING_SET_BODY(get_ascii) \
+{ \
PRIMITIVE_HEADER (3); \
- \
CHECK_ARG (1, STRING_P); \
- string = (ARG_REF (1)); \
- index = (arg_index_integer (2, (string_length (string)))); \
- ascii = (get_ascii (3)); \
- \
- char_pointer = (string_pointer (string, index)); \
- result = (char_to_long (*char_pointer)); \
- (*char_pointer) = ascii; \
- PRIMITIVE_RETURN (process_result (result))
+ { \
+ fast SCHEME_OBJECT string = (ARG_REF (1)); \
+ STRING_SET \
+ (string, \
+ (arg_index_integer (2, (STRING_LENGTH (string)))), \
+ (get_ascii (3))); \
+ } \
+ PRIMITIVE_RETURN (UNSPECIFIC); \
+}
DEFINE_PRIMITIVE ("STRING-SET!", Prim_string_set, 3, 3, 0)
-{ STRING_SET_BODY (arg_ascii_char, c_char_to_scheme_char); }
+ STRING_SET_BODY (arg_ascii_char)
DEFINE_PRIMITIVE ("VECTOR-8B-SET!", Prim_vec_8b_set, 3, 3, 0)
-{ STRING_SET_BODY (arg_ascii_integer, MAKE_UNSIGNED_FIXNUM); }
+ STRING_SET_BODY (arg_ascii_integer)
\f
#define SUBSTRING_MOVE_PREFIX() \
long start1, end1, start2, end2, length; \
- fast char *scan1, *scan2; \
+ fast unsigned char *scan1, *scan2, *limit; \
PRIMITIVE_HEADER (5); \
- \
CHECK_ARG (1, STRING_P); \
start1 = (arg_nonnegative_integer (2)); \
end1 = (arg_nonnegative_integer (3)); \
CHECK_ARG (4, STRING_P); \
start2 = (arg_nonnegative_integer (5)); \
- \
- if (end1 > (string_length (ARG_REF (1)))) \
+ length = (end1 - start1); \
+ end2 = (start2 + length); \
+ if (end1 > (STRING_LENGTH (ARG_REF (1)))) \
error_bad_range_arg (2); \
if (start1 > end1) \
error_bad_range_arg (1); \
- length = (end1 - start1); \
- \
- end2 = (start2 + length); \
- if (end2 > (string_length (ARG_REF (4)))) \
+ if (end2 > (STRING_LENGTH (ARG_REF (4)))) \
error_bad_range_arg (3)
DEFINE_PRIMITIVE ("SUBSTRING-MOVE-RIGHT!", Prim_substring_move_right, 5, 5, 0)
{
SUBSTRING_MOVE_PREFIX ();
-
- scan1 = (string_pointer ((ARG_REF (1)), end1));
- scan2 = (string_pointer ((ARG_REF (4)), end2));
- while ((length--) > 0)
+ scan1 = (STRING_LOC ((ARG_REF (1)), end1));
+ scan2 = (STRING_LOC ((ARG_REF (4)), end2));
+ limit = (scan1 - length);
+ while (scan1 > limit)
(*--scan2) = (*--scan1);
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("SUBSTRING-MOVE-LEFT!", Prim_substring_move_left, 5, 5, 0)
{
SUBSTRING_MOVE_PREFIX ();
-
- scan1 = (string_pointer ((ARG_REF (1)), start1));
- scan2 = (string_pointer ((ARG_REF (4)), start2));
- while ((length--) > 0)
+ scan1 = (STRING_LOC ((ARG_REF (1)), start1));
+ scan2 = (STRING_LOC ((ARG_REF (4)), start2));
+ limit = (scan1 + length);
+ while (scan1 < limit)
(*scan2++) = (*scan1++);
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
+
+#define SUBSTRING_MODIFIER(char_map) \
+{ \
+ SCHEME_OBJECT string; \
+ long start, end; \
+ fast long length; \
+ fast unsigned char *scan, temp; \
+ PRIMITIVE_HEADER (3); \
+ CHECK_ARG (1, STRING_P); \
+ string = (ARG_REF (1)); \
+ start = (arg_nonnegative_integer (2)); \
+ end = (arg_nonnegative_integer (3)); \
+ if (end > (STRING_LENGTH (string))) \
+ error_bad_range_arg (3); \
+ if (start > end) \
+ error_bad_range_arg (2); \
+ length = (end - start); \
+ scan = (STRING_LOC (string, start)); \
+ while ((length--) > 0) \
+ { \
+ temp = (*scan); \
+ (*scan++) = (char_map (temp)); \
+ } \
+ PRIMITIVE_RETURN (UNSPECIFIC); \
+}
+
+DEFINE_PRIMITIVE ("SUBSTRING-UPCASE!", Prim_substring_upcase, 3, 3, 0)
+ SUBSTRING_MODIFIER (char_upcase)
+
+DEFINE_PRIMITIVE ("SUBSTRING-DOWNCASE!", Prim_substring_downcase, 3, 3, 0)
+ SUBSTRING_MODIFIER (char_downcase)
\f
#define VECTOR_8B_SUBSTRING_PREFIX() \
long start, end, ascii; \
- fast long length; \
- fast char *scan; \
+ fast unsigned char *string_start, *scan, *limit; \
PRIMITIVE_HEADER (4); \
- \
CHECK_ARG (1, STRING_P); \
+ string_start = (STRING_LOC ((ARG_REF (1)), 0)); \
start = (arg_nonnegative_integer (2)); \
end = (arg_nonnegative_integer (3)); \
ascii = (arg_ascii_integer (4)); \
- \
- if (end > (string_length (ARG_REF (1)))) \
+ if (end > (STRING_LENGTH (ARG_REF (1)))) \
error_bad_range_arg (3); \
if (start > end) \
error_bad_range_arg (2)
+#define VECTOR_8B_SUBSTRING_PREFIX_FORWARD() \
+ VECTOR_8B_SUBSTRING_PREFIX (); \
+ scan = (string_start + start); \
+ limit = (string_start + end);
+
+#define VECTOR_8B_SUBSTRING_PREFIX_BACKWARD() \
+ VECTOR_8B_SUBSTRING_PREFIX (); \
+ scan = (string_start + end); \
+ limit = (string_start + start);
+
DEFINE_PRIMITIVE ("VECTOR-8B-FILL!", Prim_vec_8b_fill, 4, 4, 0)
{
- VECTOR_8B_SUBSTRING_PREFIX ();
-
- length = (end - start);
- scan = (string_pointer ((ARG_REF (1)), start));
- while ((length--) > 0)
+ VECTOR_8B_SUBSTRING_PREFIX_FORWARD ();
+ while (scan < limit)
(*scan++) = ascii;
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("VECTOR-8B-FIND-NEXT-CHAR", Prim_vec_8b_find_next_char, 4, 4, 0)
{
- VECTOR_8B_SUBSTRING_PREFIX ();
-
- scan = (string_pointer ((ARG_REF (1)), start));
- while (start < end)
- {
- if ((char_to_long (*scan++)) == ascii)
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (start));
- start += 1;
- }
- PRIMITIVE_RETURN (NIL);
+ VECTOR_8B_SUBSTRING_PREFIX_FORWARD ();
+ while (scan < limit)
+ if ((*scan++) == ascii)
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan - 1) - string_start));
+ PRIMITIVE_RETURN (SHARP_F);
}
-\f
+
DEFINE_PRIMITIVE ("VECTOR-8B-FIND-PREVIOUS-CHAR", Prim_vec_8b_find_prev_char, 4, 4, 0)
{
- VECTOR_8B_SUBSTRING_PREFIX ();
-
- scan = (string_pointer ((ARG_REF (1)), end));
- while ((end--) > start)
- if ((char_to_long (*--scan)) == ascii)
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (end));
- PRIMITIVE_RETURN (NIL);
+ VECTOR_8B_SUBSTRING_PREFIX_BACKWARD ();
+ while (scan > limit)
+ if ((*--scan) == ascii)
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan - string_start));
+ PRIMITIVE_RETURN (SHARP_F);
}
DEFINE_PRIMITIVE ("VECTOR-8B-FIND-NEXT-CHAR-CI", Prim_vec_8b_find_next_char_ci, 4, 4, 0)
{
- char char1;
- VECTOR_8B_SUBSTRING_PREFIX ();
-
- scan = (string_pointer ((ARG_REF (1)), start));
- char1 = (char_upcase (ascii));
- while (start < end)
- {
+ VECTOR_8B_SUBSTRING_PREFIX_FORWARD ();
+ {
+ fast unsigned char char1 = (char_upcase (ascii));
+ while (scan < limit)
if ((char_upcase (*scan++)) == char1)
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum( start));
- start += 1;
- }
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan - 1) - string_start));
+ }
+ PRIMITIVE_RETURN (SHARP_F);
}
DEFINE_PRIMITIVE ("VECTOR-8B-FIND-PREVIOUS-CHAR-CI", Prim_vec_8b_find_prev_char_ci, 4, 4, 0)
{
- char char1;
- VECTOR_8B_SUBSTRING_PREFIX ();
-
- scan = (string_pointer ((ARG_REF (1)), end));
- char1 = (char_upcase (ascii));
- while ((end--) > start)
- {
+ VECTOR_8B_SUBSTRING_PREFIX_BACKWARD ();
+ {
+ fast unsigned char char1 = (char_upcase (ascii));
+ while (scan > limit)
if ((char_upcase (*--scan)) == char1)
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (end));
- }
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan - string_start));
+ }
+ PRIMITIVE_RETURN (SHARP_F);
}
\f
#define SUBSTR_FIND_CHAR_IN_SET_PREFIX() \
- long start, end, length; \
- char *char_set, *scan; \
+ long start, end; \
+ unsigned char *char_set, *string_start, *scan, *limit; \
PRIMITIVE_HEADER (4); \
- \
CHECK_ARG (1, STRING_P); \
+ string_start = (STRING_LOC ((ARG_REF (1)), 0)); \
start = (arg_nonnegative_integer (2)); \
end = (arg_nonnegative_integer (3)); \
CHECK_ARG (4, STRING_P); \
- \
- if (end > (string_length (ARG_REF (1)))) \
+ char_set = (STRING_LOC ((ARG_REF (4)), 0)); \
+ if (end > (STRING_LENGTH (ARG_REF (1)))) \
error_bad_range_arg (3); \
if (start > end) \
error_bad_range_arg (2); \
- if ((string_length (ARG_REF (4))) != MAX_ASCII) \
+ if ((STRING_LENGTH (ARG_REF (4))) != MAX_ASCII) \
error_bad_range_arg (4)
DEFINE_PRIMITIVE ("SUBSTRING-FIND-NEXT-CHAR-IN-SET", Prim_find_next_char_in_set, 4, 4, 0)
{
SUBSTR_FIND_CHAR_IN_SET_PREFIX ();
-
- char_set = (Scheme_String_To_C_String (ARG_REF (4)));
- scan = (string_pointer ((ARG_REF (1)), start));
- while (start < end)
- {
- if (char_set[(char_to_long (*scan++))] != '\0')
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (start));
- start += 1;
- }
- PRIMITIVE_RETURN (NIL);
+ scan = (string_start + start);
+ limit = (string_start + end);
+ while (scan < limit)
+ if ((char_set [*scan++]) != '\0')
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan - 1) - string_start));
+ PRIMITIVE_RETURN (SHARP_F);
}
DEFINE_PRIMITIVE ("SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET", Prim_find_prev_char_in_set, 4, 4, 0)
{
SUBSTR_FIND_CHAR_IN_SET_PREFIX ();
-
- char_set = Scheme_String_To_C_String(ARG_REF (4));
- scan = (string_pointer ((ARG_REF (1)), end));
- while (end-- > start)
- if (char_set[(char_to_long (*--scan))] != '\0')
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (end));
- PRIMITIVE_RETURN (NIL);
+ scan = (string_start + end);
+ limit = (string_start + start);
+ while (scan > limit)
+ if ((char_set [*--scan]) != '\0')
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan - string_start));
+ PRIMITIVE_RETURN (SHARP_F);
}
\f
-#define SUBSTRING_COMPARE_PREFIX(index1, index2) \
+#define SUBSTRING_COMPARE_PREFIX() \
long start1, end1, start2, end2; \
- fast char *scan1, *scan2; \
+ unsigned char *string1_start, *string2_start; \
PRIMITIVE_HEADER (6); \
- \
CHECK_ARG (1, STRING_P); \
+ string1_start = (STRING_LOC ((ARG_REF (1)), 0)); \
start1 = (arg_nonnegative_integer (2)); \
end1 = (arg_nonnegative_integer (3)); \
CHECK_ARG (4, STRING_P); \
+ string2_start = (STRING_LOC ((ARG_REF (4)), 0)); \
start2 = (arg_nonnegative_integer (5)); \
end2 = (arg_nonnegative_integer (6)); \
- \
- if (end1 > (string_length (ARG_REF (1)))) \
+ if (end1 > (STRING_LENGTH (ARG_REF (1)))) \
error_bad_range_arg (3); \
if (start1 > end1) \
error_bad_range_arg (2); \
- \
- if (end2 > (string_length (ARG_REF (4)))) \
+ if (end2 > (STRING_LENGTH (ARG_REF (4)))) \
error_bad_range_arg (6); \
if (start2 > end2) \
- error_bad_range_arg (5); \
- \
- scan1 = (string_pointer ((ARG_REF (1)), index1)); \
- scan2 = (string_pointer ((ARG_REF (4)), index2))
+ error_bad_range_arg (5)
#define SUBSTRING_EQUAL_PREFIX() \
- long length; \
- SUBSTRING_COMPARE_PREFIX (start1, start2); \
- \
- length = (end1 - start1); \
- if (length != (end2 - start2)) \
- PRIMITIVE_RETURN (NIL);
+ fast unsigned char *scan1, *scan2, *limit; \
+ SUBSTRING_COMPARE_PREFIX (); \
+ if ((end1 - start1) != (end2 - start2)) \
+ PRIMITIVE_RETURN (SHARP_F); \
+ scan1 = (string1_start + start1); \
+ limit = (string1_start + end1); \
+ scan2 = (string2_start + start2)
DEFINE_PRIMITIVE ("SUBSTRING=?", Prim_substring_equal, 6, 6, 0)
{
SUBSTRING_EQUAL_PREFIX ();
-
- while ((length--) > 0)
+ while (scan1 < limit)
if ((*scan1++) != (*scan2++))
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
PRIMITIVE_RETURN (SHARP_T);
}
DEFINE_PRIMITIVE ("SUBSTRING-CI=?", Prim_substring_ci_equal, 6, 6, 0)
{
SUBSTRING_EQUAL_PREFIX ();
-
- while ((length--) > 0)
+ while (scan1 < limit)
if ((char_upcase (*scan1++)) != (char_upcase (*scan2++)))
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
PRIMITIVE_RETURN (SHARP_T);
}
-\f
+
DEFINE_PRIMITIVE ("SUBSTRING<?", Prim_substring_less, 6, 6, 0)
{
- long length, length1, length2;
- SUBSTRING_COMPARE_PREFIX (start1, start2);
-
- length1 = (end1 - start1);
- length2 = (end2 - start2);
- length = ((length1 < length2) ? length1 : length2);
-
- while ((length--) > 0)
- if ((*scan1++) != (*scan2++))
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((scan1 [-1]) < (scan2 [-1])));
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (length1 < length2));
+ SUBSTRING_COMPARE_PREFIX ();
+ {
+ fast unsigned char * scan1 = (string1_start + start1);
+ fast unsigned char * scan2 = (string2_start + start2);
+ long length1 = (end1 - start1);
+ long length2 = (end2 - start2);
+ fast unsigned char * limit =
+ (scan1 + ((length1 < length2) ? length1 : length2));
+ while (scan1 < limit)
+ if ((*scan1++) != (*scan2++))
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((scan1 [-1]) < (scan2 [-1])));
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (length1 < length2));
+ }
}
-
-#define SUBSTRING_MODIFIER(char_map) \
- Pointer string; \
- long start, end; \
- fast long length; \
- fast char *scan, temp; \
- PRIMITIVE_HEADER (3); \
- \
- CHECK_ARG (1, STRING_P); \
- string = (ARG_REF (1)); \
- start = (arg_nonnegative_integer (2)); \
- end = (arg_nonnegative_integer (3)); \
- \
- if (end > (string_length (string))) \
- error_bad_range_arg (3); \
- if (start > end) \
- error_bad_range_arg (2); \
- \
- length = (end - start); \
- scan = (string_pointer (string, start)); \
- while ((length--) > 0) \
- { \
- temp = (*scan); \
- (*scan++) = (char_map (temp)); \
- } \
- PRIMITIVE_RETURN (NIL)
-
-DEFINE_PRIMITIVE ("SUBSTRING-UPCASE!", Prim_substring_upcase, 3, 3, 0)
-{ SUBSTRING_MODIFIER (char_upcase); }
-
-DEFINE_PRIMITIVE ("SUBSTRING-DOWNCASE!", Prim_substring_downcase, 3, 3, 0)
-{ SUBSTRING_MODIFIER (char_downcase); }
\f
-#define SUBSTRING_MATCH_PREFIX(index1, index2) \
- long length, unmatched; \
- SUBSTRING_COMPARE_PREFIX (index1, index2); \
- \
- length = (substring_length_min (start1, end1, start2, end2)); \
- unmatched = length;
+static long
+substring_length_min (start1, end1, start2, end2)
+ long start1, end1, start2, end2;
+{
+ fast long length1 = (end1 - start1);
+ fast long length2 = (end2 - start2);
+ return ((length1 < length2) ? length1 : length2);
+}
+
+#define SUBSTRING_MATCH_PREFIX() \
+ fast unsigned char *scan1, *scan2, *limit; \
+ long length; \
+ unsigned char *scan1_start; \
+ SUBSTRING_COMPARE_PREFIX (); \
+ length = (substring_length_min (start1, end1, start2, end2))
DEFINE_PRIMITIVE ("SUBSTRING-MATCH-FORWARD", Prim_match_forward, 6, 6, 0)
{
- SUBSTRING_MATCH_PREFIX (start1, start2);
-
- while (unmatched-- > 0)
+ SUBSTRING_MATCH_PREFIX ();
+ scan1 = (string1_start + start1);
+ scan2 = (string2_start + start2);
+ limit = (scan1 + length);
+ scan1_start = scan1;
+ while (scan1 < limit)
if ((*scan1++) != (*scan2++))
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (length - (unmatched + 1)));
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (length));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan1 - 1) - scan1_start));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
}
DEFINE_PRIMITIVE ("SUBSTRING-MATCH-FORWARD-CI", Prim_match_forward_ci, 6, 6, 0)
{
- SUBSTRING_MATCH_PREFIX (start1, start2);
-
- while (unmatched-- > 0)
+ SUBSTRING_MATCH_PREFIX ();
+ scan1 = (string1_start + start1);
+ scan2 = (string2_start + start2);
+ limit = (scan1 + length);
+ scan1_start = scan1;
+ while (scan1 < limit)
if ((char_upcase (*scan1++)) != (char_upcase (*scan2++)))
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (length - (unmatched + 1)));
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (length));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan1 - 1) - scan1_start));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
}
DEFINE_PRIMITIVE ("SUBSTRING-MATCH-BACKWARD", Prim_match_backward, 6, 6, 0)
{
- SUBSTRING_MATCH_PREFIX (end1, end2);
-
- while (unmatched-- > 0)
+ SUBSTRING_MATCH_PREFIX ();
+ scan1 = (string1_start + end1);
+ scan2 = (string2_start + end2);
+ limit = (scan1 - length);
+ scan1_start = scan1;
+ while (scan1 > limit)
if ((*--scan1) != (*--scan2))
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (length - (unmatched + 1)));
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (length));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan1_start - (scan1 + 1)));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
}
DEFINE_PRIMITIVE ("SUBSTRING-MATCH-BACKWARD-CI", Prim_match_backward_ci, 6, 6, 0)
{
- SUBSTRING_MATCH_PREFIX (end1, end2);
-
- while (unmatched-- > 0)
+ SUBSTRING_MATCH_PREFIX ();
+ scan1 = (string1_start + end1);
+ scan2 = (string2_start + end2);
+ limit = (scan1 - length);
+ scan1_start = scan1;
+ while (scan1 > limit)
if ((char_upcase (*--scan1)) != (char_upcase (*--scan2)))
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (length - (unmatched + 1)));
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (length));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan1_start - (scan1 + 1)));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/syntax.c,v 1.19 1989/08/28 18:29:24 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/syntax.c,v 1.20 1989/09/20 23:12:00 cph Rel $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
-#include "char.h"
-#include "string.h"
#include "edwin.h"
#include "syntax.h"
\f
/* Indexed by syntax code, give the letter that describes it. */
-char syntax_code_spec[13] =
+unsigned char syntax_code_spec[13] =
{
' ', '.', 'w', '_', '(', ')', '\'', '\"', '$', '\\', '/', '<', '>'
};
DEFINE_PRIMITIVE ("STRING->SYNTAX-ENTRY", Prim_string_to_syntax_entry, 1, 1, 0)
{
long length, c, result;
- char *scan;
+ unsigned char * scan;
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
- length = (string_length (ARG_REF (1)));
- scan = (string_pointer ((ARG_REF (1)), 0));
+ length = (STRING_LENGTH (ARG_REF (1)));
+ scan = (STRING_LOC ((ARG_REF (1)), 0));
if ((length--) > 0)
{
- c = (char_to_long (*scan++));
+ c = (*scan++);
if (c >= 0200) error_bad_range_arg (1);
- result = (char_to_long (syntax_spec_code[c]));
+ result = (syntax_spec_code [c]);
if (result == ILLEGAL) error_bad_range_arg (1);
}
else
if ((length--) > 0)
{
- c = (char_to_long (*scan++));
+ c = (*scan++);
if (c != ' ') result |= (c << 8);
}
default: error_bad_range_arg (1);
}
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (result));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (result));
}
DEFINE_PRIMITIVE ("CHAR->SYNTAX-CODE", Prim_char_to_syntax_code, 2, 2, 0)
{
- Primitive_2_Args ();
-
+ PRIMITIVE_HEADER (2);
CHECK_ARG (1, SYNTAX_TABLE_P);
PRIMITIVE_RETURN
- (c_char_to_scheme_char
+ (ASCII_TO_CHAR
(syntax_code_spec
[((int)
(SYNTAX_ENTRY_CODE
/* Parser Initialization */
#define NORMAL_INITIALIZATION_COMMON(arity) \
- fast Pointer syntax_table; \
- fast Pointer group; \
- fast char *start; \
- char *first_char, *end; \
+ fast SCHEME_OBJECT syntax_table; \
+ fast SCHEME_OBJECT group; \
+ fast unsigned char * start; \
+ unsigned char * first_char, * end; \
long sentry; \
long gap_length; \
PRIMITIVE_HEADER (arity); \
- \
CHECK_ARG (1, SYNTAX_TABLE_P); \
syntax_table = (ARG_REF (1)); \
CHECK_ARG (2, GROUP_P); \
group = (ARG_REF (2)); \
- first_char = (string_pointer ((GROUP_TEXT (group)), 0)); \
+ first_char = (STRING_LOC ((GROUP_TEXT (group)), 0)); \
start = (first_char + (arg_nonnegative_integer (3))); \
end = (first_char + (arg_nonnegative_integer (4))); \
gap_start = (first_char + (GROUP_GAP_START (group))); \
gap_end = (first_char + (GROUP_GAP_END (group)))
#define NORMAL_INITIALIZATION_FORWARD(arity) \
- char *gap_start; \
- fast char *gap_end; \
+ unsigned char * gap_start; \
+ fast unsigned char * gap_end; \
NORMAL_INITIALIZATION_COMMON (arity); \
if (start >= gap_start) \
start += gap_length; \
end += gap_length
#define NORMAL_INITIALIZATION_BACKWARD(arity) \
- fast char *gap_start; \
- char *gap_end; \
+ fast unsigned char * gap_start; \
+ unsigned char * gap_end; \
Boolean quoted; \
NORMAL_INITIALIZATION_COMMON (arity); \
if (start > gap_start) \
#define SCAN_LIST_INITIALIZATION(initialization) \
long depth, min_depth; \
Boolean sexp_flag, ignore_comments, math_exit; \
- char c; \
+ int c; \
initialization (7); \
- CHECK_ARG (5, FIXNUM_P); \
- FIXNUM_VALUE ((ARG_REF (5)), depth); \
+ depth = (arg_integer (5)); \
min_depth = ((depth >= 0) ? 0 : depth); \
- sexp_flag = ((ARG_REF (6)) != NIL); \
- ignore_comments = ((ARG_REF (7)) != NIL); \
+ sexp_flag = (BOOLEAN_ARG (6)); \
+ ignore_comments = (BOOLEAN_ARG (7)); \
math_exit = false
\f
/* Parse Scanning */
#define LOSE_IF(expression) do \
{ \
if (expression) \
- PRIMITIVE_RETURN (NIL); \
+ PRIMITIVE_RETURN (SHARP_F); \
} while (0)
#define LOSE_IF_RIGHT_END(scan) LOSE_IF (RIGHT_END_P (scan))
#define WIN_IF(expression) do \
{ \
if (expression) \
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (SCAN_TO_INDEX (start))); \
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (SCAN_TO_INDEX (start))); \
} while (0)
#define WIN_IF_RIGHT_END(scan) WIN_IF (RIGHT_END_P (scan))
#define RIGHT_QUOTED_P(scan_init, quoted) do \
{ \
- char *scan; \
- \
- scan = (scan_init); \
+ unsigned char * scan = (scan_init); \
RIGHT_QUOTED_P_INTERNAL (scan, quoted); \
} while (0)
#define LEFT_QUOTED_P(scan_init, quoted) do \
{ \
- char *scan; \
- \
- scan = (scan_init); \
+ unsigned char * scan = (scan_init); \
MOVE_LEFT (scan); \
RIGHT_QUOTED_P_INTERNAL (scan, quoted); \
} while (0)
NORMAL_INITIALIZATION_BACKWARD (4);
RIGHT_QUOTED_P (start, quoted);
- PRIMITIVE_RETURN (quoted ? SHARP_T : NIL);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (quoted));
}
/* This is used in conjunction with `scan-list-backward' to find the
/* Partial S-Expression Parser */
#define LEVEL_ARRAY_LENGTH 100
-struct levelstruct { char *last, *previous; };
+struct levelstruct { unsigned char * last, * previous; };
#define DONE_IF(expression) do \
{ \
{
long target_depth;
Boolean stop_before;
- Pointer state_argument;
+ SCHEME_OBJECT state_argument;
long depth;
long in_string; /* -1 or delimiter character */
long in_comment; /* 0, 1, or 2 */
struct levelstruct level_start[LEVEL_ARRAY_LENGTH];
struct levelstruct *level;
struct levelstruct *level_end;
- char c;
- Pointer result;
+ int c;
+ SCHEME_OBJECT result;
NORMAL_INITIALIZATION_FORWARD (7);
- CHECK_ARG (5, FIXNUM_P);
- FIXNUM_VALUE ((ARG_REF (5)), target_depth);
- stop_before = ((ARG_REF (6)) != NIL);
+ target_depth = (arg_integer (5));
+ stop_before = (BOOLEAN_ARG (6));
state_argument = (ARG_REF (7));
level = level_start;
\f
/* Initialize the state variables from the state argument. */
- if (state_argument == NIL)
+ if (state_argument == SHARP_F)
{
depth = 0;
in_string = -1;
in_comment = 0;
quoted = false;
}
- else if (((OBJECT_TYPE (state_argument)) == TC_VECTOR) &&
- (Vector_Length (state_argument)) == 7)
+ else if ((VECTOR_P (state_argument)) &&
+ (VECTOR_LENGTH (state_argument)) == 7)
{
- Pointer temp;
+ SCHEME_OBJECT temp;
- temp = (User_Vector_Ref (state_argument, 0));
+ temp = (VECTOR_REF (state_argument, 0));
if (FIXNUM_P (temp))
- {
- Sign_Extend (temp, depth);
- }
+ depth = (FIXNUM_TO_LONG (temp));
else
error_bad_range_arg (7);
- temp = (User_Vector_Ref (state_argument, 1));
- if (temp == NIL)
+ temp = (VECTOR_REF (state_argument, 1));
+ if (temp == SHARP_F)
in_string = -1;
- else if ((FIXNUM_P (temp)) && ((OBJECT_DATUM (temp)) < MAX_ASCII))
- in_string = (OBJECT_DATUM (temp));
+ else if ((UNSIGNED_FIXNUM_P (temp)) &&
+ ((UNSIGNED_FIXNUM_TO_LONG (temp)) < MAX_ASCII))
+ in_string = (UNSIGNED_FIXNUM_TO_LONG (temp));
else
error_bad_range_arg (7);
- temp = (User_Vector_Ref (state_argument, 2));
- if (temp == NIL)
+ temp = (VECTOR_REF (state_argument, 2));
+ if (temp == SHARP_F)
in_comment = 0;
- else if (temp == (Make_Unsigned_Fixnum (1)))
+ else if (temp == (LONG_TO_UNSIGNED_FIXNUM (1)))
in_comment = 1;
- else if (temp == (Make_Unsigned_Fixnum (2)))
+ else if (temp == (LONG_TO_UNSIGNED_FIXNUM (2)))
in_comment = 2;
else
error_bad_range_arg (7);
- quoted = ((User_Vector_Ref (state_argument, 3)) != NIL);
+ quoted = ((VECTOR_REF (state_argument, 3)) != SHARP_F);
if ((in_comment != 0) && ((in_string != -1) || (quoted != false)))
error_bad_range_arg (7);
}
end_atom:
(level -> previous) = (level -> last);
- break;
+ break;
\f
case syntaxcode_comment:
in_comment = 1;
\f
case syntaxcode_string:
SEXP_START ();
- in_string = (char_to_long (c));
+ in_string = (c);
start_in_string:
while (true)
{
done:
result = (allocate_marked_vector (TC_VECTOR, 7, true));
- (User_Vector_Set(result, 0, (Make_Signed_Fixnum (depth))));
- (User_Vector_Set(result, 1, ((in_string == -1)
- ? NIL
- : (Make_Unsigned_Fixnum (in_string)))));
- (User_Vector_Set(result, 2, ((in_comment == 0)
- ? NIL
- : (Make_Unsigned_Fixnum (in_comment)))));
- (User_Vector_Set(result, 3, ((quoted == false) ? NIL : SHARP_T)));
- (User_Vector_Set(result, 4, (((level -> previous) == NULL)
- ? NIL
- : (Make_Unsigned_Fixnum
- ((SCAN_TO_INDEX (level -> previous))
- - 1)))));
- (User_Vector_Set(result, 5, (((level == level_start)
- || (((level - 1) -> last) == NULL))
- ? NIL
- : (Make_Unsigned_Fixnum
- ((SCAN_TO_INDEX ((level - 1) -> last))
- - 1)))));
- (User_Vector_Set(result, 6, (Make_Unsigned_Fixnum (SCAN_TO_INDEX (start)))));
+ FAST_VECTOR_SET (result, 0, (LONG_TO_FIXNUM (depth)));
+ FAST_VECTOR_SET
+ (result, 1,
+ ((in_string == -1)
+ ? SHARP_F
+ : (LONG_TO_UNSIGNED_FIXNUM (in_string))));
+ FAST_VECTOR_SET
+ (result, 2,
+ ((in_comment == 0)
+ ? SHARP_F
+ : (LONG_TO_UNSIGNED_FIXNUM (in_comment))));
+ FAST_VECTOR_SET (result, 3, (BOOLEAN_TO_OBJECT (quoted)));
+ FAST_VECTOR_SET
+ (result, 4,
+ (((level -> previous) == NULL)
+ ? SHARP_F
+ : (LONG_TO_UNSIGNED_FIXNUM ((SCAN_TO_INDEX (level -> previous)) - 1))));
+ FAST_VECTOR_SET
+ (result, 5,
+ (((level == level_start) || (((level - 1) -> last) == NULL))
+ ? SHARP_F
+ : (LONG_TO_UNSIGNED_FIXNUM
+ ((SCAN_TO_INDEX ((level - 1) -> last)) - 1))));
+ FAST_VECTOR_SET
+ (result, 6, (LONG_TO_UNSIGNED_FIXNUM (SCAN_TO_INDEX (start))));
PRIMITIVE_RETURN (result);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/syntax.h,v 1.6 1989/08/28 18:29:28 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/syntax.h,v 1.7 1989/09/20 23:12:04 cph Rel $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
extern char syntax_spec_code[0200];
#define SYNTAX_TABLE_P(argument) \
- ((VECTOR_P (argument)) && ((Vector_Length (argument)) == 0x100))
+ ((VECTOR_P (argument)) && ((VECTOR_LENGTH (argument)) == 0x100))
-#define SYNTAX_TABLE_TYPE Pointer
+#define SYNTAX_TABLE_TYPE SCHEME_OBJECT
#define SYNTAX_TABLE_REF(table, index) \
- (User_Vector_Ref ((table), ((index) & 0xFF)))
+ (VECTOR_REF ((table), ((index) & 0xFF)))
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sysprim.c,v 9.33 1989/09/20 23:12:08 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sysprim.c,v 9.32 1989/03/27 23:16:05 jinx Rel $
- *
- * Random system primitives. Most are implemented in terms of
- * utilities in os.c
- *
- */
+/* Random system primitives. Most are implemented in terms of
+ utilities in os.c */
+
#include "scheme.h"
#include "prims.h"
\f
DEFINE_PRIMITIVE ("CHECK-AND-CLEAN-UP-INPUT-CHANNEL", Prim_chk_and_cln_input_channel, 2, 2, 0)
{
- extern Boolean OS_Clean_Interrupt_Channel();
+ extern Boolean OS_tty_clean_interrupts();
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
- ((OS_Clean_Interrupt_Channel ((arg_nonnegative_integer (1)),
- (arg_nonnegative_integer (2))))
- ? SHARP_T : NIL);
+ (BOOLEAN_TO_OBJECT
+ (OS_tty_clean_interrupts ((arg_nonnegative_integer (1)),
+ (arg_nonnegative_integer (2)))));
}
DEFINE_PRIMITIVE ("GET-NEXT-INTERRUPT-CHARACTER", Prim_get_next_interrupt_char, 0, 0, 0)
{
int result;
- extern int OS_Get_Next_Interrupt_Character();
+ extern int OS_tty_next_interrupt_char();
PRIMITIVE_HEADER (0);
- result = (OS_Get_Next_Interrupt_Character ());
+ result = (OS_tty_next_interrupt_char ());
if (result == -1)
{
- Primitive_Error (ERR_EXTERNAL_RETURN);
+ error_external_return ();
/*NOTREACHED*/
}
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (result));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (result));
}
\f
/* Time primitives */
DEFINE_PRIMITIVE ("SYSTEM-CLOCK", Prim_system_clock, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (OS_process_clock ()));
+ PRIMITIVE_RETURN (long_to_integer (OS_process_clock ()));
}
DEFINE_PRIMITIVE ("REAL-TIME-CLOCK", Prim_real_time_clock, 0, 0, 0)
{
+ extern long OS_real_time_clock ();
PRIMITIVE_HEADER (0);
-
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (OS_real_time_clock ()));
+ PRIMITIVE_RETURN (long_to_integer (OS_real_time_clock ()));
}
DEFINE_PRIMITIVE ("SETUP-TIMER-INTERRUPT", Prim_setup_timer_interrupt, 2, 2, 0)
{
- extern void Clear_Int_Timer(), Set_Int_Timer();
- Primitive_2_Args();
-
- if ((Arg1 == NIL) && (Arg2==NIL))
- Clear_Int_Timer();
+ extern void Clear_Int_Timer ();
+ extern void Set_Int_Timer ();
+ PRIMITIVE_HEADER (2);
+ if (((ARG_REF (1)) == SHARP_F) && ((ARG_REF (2)) == SHARP_F))
+ 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);
- }
- PRIMITIVE_RETURN(NIL);
+ Set_Int_Timer
+ ((arg_nonnegative_integer (1)), (arg_nonnegative_integer (2)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
+
/* Date and current time primitives */
-#define Date_Primitive(OS_Name) \
+#define DATE_PRIMITIVE(OS_name) \
+{ \
int result; \
- extern int OS_Name(); \
+ extern int OS_name (); \
PRIMITIVE_HEADER (0); \
- \
- result = (OS_Name ()); \
- PRIMITIVE_RETURN ((result == -1) ? NIL : (MAKE_UNSIGNED_FIXNUM (result)))
+ result = (OS_name ()); \
+ PRIMITIVE_RETURN \
+ ((result == -1) ? SHARP_F : (LONG_TO_UNSIGNED_FIXNUM (result))); \
+}
DEFINE_PRIMITIVE ("CURRENT-YEAR", Prim_current_year, 0, 0, 0)
-{ Date_Primitive (OS_Current_Year); }
+ DATE_PRIMITIVE (OS_Current_Year)
DEFINE_PRIMITIVE ("CURRENT-MONTH", Prim_current_month, 0, 0, 0)
-{ Date_Primitive (OS_Current_Month); }
+ DATE_PRIMITIVE (OS_Current_Month)
DEFINE_PRIMITIVE ("CURRENT-DAY", Prim_current_day, 0, 0, 0)
-{ Date_Primitive (OS_Current_Day); }
+ DATE_PRIMITIVE (OS_Current_Day)
DEFINE_PRIMITIVE ("CURRENT-HOUR", Prim_current_hour, 0, 0, 0)
-{ Date_Primitive (OS_Current_Hour); }
+ DATE_PRIMITIVE (OS_Current_Hour)
DEFINE_PRIMITIVE ("CURRENT-MINUTE", Prim_current_minute, 0, 0, 0)
-{ Date_Primitive (OS_Current_Minute); }
+ DATE_PRIMITIVE (OS_Current_Minute)
DEFINE_PRIMITIVE ("CURRENT-SECOND", Prim_current_second, 0, 0, 0)
-{ Date_Primitive (OS_Current_Second); }
+ DATE_PRIMITIVE (OS_Current_Second)
\f
/* Pretty random primitives */
{
extern Boolean Restartable_Exit();
PRIMITIVE_HEADER (0);
-
- PRIMITIVE_RETURN (((Restartable_Exit ()) ? SHARP_T : NIL));
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (Restartable_Exit ()));
}
/* (SET-RUN-LIGHT! OBJECT)
DEFINE_PRIMITIVE ("SET-RUN-LIGHT!", Prim_set_run_light, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
#ifdef RUN_LIGHT_IS_BEEP
{
extern void OS_tty_beep();
OS_tty_beep();
- OS_Flush_Output_Buffer();
+ OS_tty_flush_output();
PRIMITIVE_RETURN (SHARP_T);
}
#else
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
#endif
}
DEFINE_PRIMITIVE ("UNDER-EMACS?", Prim_under_emacs_p, 0, 0, 0)
{
- extern Boolean OS_Under_Emacs();
+ extern Boolean OS_under_emacs_p ();
PRIMITIVE_HEADER (0);
-
- PRIMITIVE_RETURN (((OS_Under_Emacs ()) ? SHARP_T : NIL));
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS_under_emacs_p ()));
}
\f
#define CONVERT_ADDRESS(address) \
- (C_Integer_To_Scheme_Integer ((long) (C_To_Scheme (address))))
+ (long_to_integer (ADDRESS_TO_DATUM (address)))
DEFINE_PRIMITIVE ("GC-SPACE-STATUS", Prim_gc_space_status, 0, 0, 0)
{
- Pointer * constant_low;
- Pointer * constant_free;
- Pointer * constant_high;
- Pointer * heap_low;
- Pointer * heap_free;
- Pointer * heap_limit;
- Pointer * heap_high;
+ SCHEME_OBJECT * constant_low;
+ SCHEME_OBJECT * constant_free;
+ SCHEME_OBJECT * constant_high;
+ SCHEME_OBJECT * heap_low;
+ SCHEME_OBJECT * heap_free;
+ SCHEME_OBJECT * heap_limit;
+ SCHEME_OBJECT * heap_high;
#ifndef USE_STACKLETS
- Pointer * stack_low;
- Pointer * stack_free;
- Pointer * stack_limit;
- Pointer * stack_high;
+ SCHEME_OBJECT * stack_low;
+ SCHEME_OBJECT * stack_free;
+ SCHEME_OBJECT * stack_limit;
+ SCHEME_OBJECT * stack_high;
#endif /* USE_STACKLETS */
- Pointer result;
+ SCHEME_OBJECT result;
PRIMITIVE_HEADER (0);
constant_low = Constant_Space;
stack_high = Stack_Top;
#endif /* USE_STACKLETS */
- result = (make_vector (12, NIL));
- User_Vector_Set (result, 0, (MAKE_UNSIGNED_FIXNUM (sizeof (Pointer))));
- User_Vector_Set (result, 1, (CONVERT_ADDRESS (constant_low)));
- User_Vector_Set (result, 2, (CONVERT_ADDRESS (constant_free)));
- User_Vector_Set (result, 3, (CONVERT_ADDRESS (constant_high)));
- User_Vector_Set (result, 4, (CONVERT_ADDRESS (heap_low)));
- User_Vector_Set (result, 5, (CONVERT_ADDRESS (heap_free)));
- User_Vector_Set (result, 6, (CONVERT_ADDRESS (heap_limit)));
- User_Vector_Set (result, 7, (CONVERT_ADDRESS (heap_high)));
+ result = (make_vector (12, SHARP_F, true));
+ VECTOR_SET (result, 0, (LONG_TO_UNSIGNED_FIXNUM (sizeof (SCHEME_OBJECT))));
+ VECTOR_SET (result, 1, (CONVERT_ADDRESS (constant_low)));
+ VECTOR_SET (result, 2, (CONVERT_ADDRESS (constant_free)));
+ VECTOR_SET (result, 3, (CONVERT_ADDRESS (constant_high)));
+ VECTOR_SET (result, 4, (CONVERT_ADDRESS (heap_low)));
+ VECTOR_SET (result, 5, (CONVERT_ADDRESS (heap_free)));
+ VECTOR_SET (result, 6, (CONVERT_ADDRESS (heap_limit)));
+ VECTOR_SET (result, 7, (CONVERT_ADDRESS (heap_high)));
#ifndef USE_STACKLETS
- User_Vector_Set (result, 8, (CONVERT_ADDRESS (stack_low)));
- User_Vector_Set (result, 9, (CONVERT_ADDRESS (stack_free)));
- User_Vector_Set (result, 10, (CONVERT_ADDRESS (stack_limit)));
- User_Vector_Set (result, 11, (CONVERT_ADDRESS (stack_high)));
+ VECTOR_SET (result, 8, (CONVERT_ADDRESS (stack_low)));
+ VECTOR_SET (result, 9, (CONVERT_ADDRESS (stack_free)));
+ VECTOR_SET (result, 10, (CONVERT_ADDRESS (stack_limit)));
+ VECTOR_SET (result, 11, (CONVERT_ADDRESS (stack_high)));
#endif /* USE_STACKLETS */
PRIMITIVE_RETURN (result);
}
error_bad_range_arg (1);
/*NOTREACHED*/
}
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (result));
+ PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (result));
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/trap.h,v 9.41 1989/08/28 18:29:32 cph Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/trap.h,v 9.42 1989/09/20 23:12:11 cph Rel $ */
\f
/* Kinds of traps:
#define get_trap_kind(variable, what) \
{ \
- variable = OBJECT_DATUM(what); \
+ variable = OBJECT_DATUM (what); \
if (variable > TRAP_MAX_IMMEDIATE) \
- variable = OBJECT_DATUM(Vector_Ref(what, TRAP_TAG)); \
+ variable = OBJECT_DATUM (MEMORY_REF (what, TRAP_TAG)); \
}
\f
/* Common constants */
#endif /* b32 */
#ifndef UNASSIGNED_OBJECT /* Safe version */
-#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED)
-#define DANGEROUS_UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED_DANGEROUS)
-#define UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND)
-#define DANGEROUS_UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND_DANGEROUS)
-#define ILLEGAL_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_ILLEGAL)
-#define DANGEROUS_ILLEGAL_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_ILLEGAL_DANGEROUS)
-#define EXPENSIVE_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_EXPENSIVE)
-#define DANGEROUS_EXPENSIVE_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_EXPENSIVE_DANGEROUS)
+#define UNASSIGNED_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNASSIGNED)
+#define DANGEROUS_UNASSIGNED_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNASSIGNED_DANGEROUS)
+#define UNBOUND_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNBOUND)
+#define DANGEROUS_UNBOUND_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNBOUND_DANGEROUS)
+#define ILLEGAL_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_ILLEGAL)
+#define DANGEROUS_ILLEGAL_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_ILLEGAL_DANGEROUS)
+#define EXPENSIVE_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_EXPENSIVE)
+#define DANGEROUS_EXPENSIVE_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_EXPENSIVE_DANGEROUS)
#endif /* UNASSIGNED_OBJECT */
-#define NOP_OBJECT MAKE_UNSIGNED_FIXNUM(TRAP_NOP)
-#define DANGEROUS_OBJECT MAKE_UNSIGNED_FIXNUM(TRAP_DANGEROUS)
-#define REQUEST_RECACHE_OBJECT DANGEROUS_ILLEGAL_OBJECT
-#define EXPENSIVE_ASSIGNMENT_OBJECT EXPENSIVE_OBJECT
+#define NOP_OBJECT (LONG_TO_UNSIGNED_FIXNUM (TRAP_NOP))
+#define DANGEROUS_OBJECT (LONG_TO_UNSIGNED_FIXNUM (TRAP_DANGEROUS))
+#define REQUEST_RECACHE_OBJECT DANGEROUS_ILLEGAL_OBJECT
+#define EXPENSIVE_ASSIGNMENT_OBJECT EXPENSIVE_OBJECT
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/types.h,v 9.31 1989/09/20 23:12:21 cph Rel $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/types.h,v 9.30 1989/08/28 18:29:35 cph Exp $
- *
- * Type code definitions, numerical order
- *
- */
+/* Type code definitions, numerical order */
\f
/* Name Value Previous Name */
#define TC_LAMBDA 0x17
#define TC_PRIMITIVE 0x18
#define TC_SEQUENCE_2 0x19
-\f
#define TC_FIXNUM 0x1A
#define TC_PCOMB1 0x1B
#define TC_CONTROL_POINT 0x1C
#define TC_COMPILED_CODE_BLOCK 0x3D
/* If you add a new type, don't forget to update gccode.h, gctype.c,
- and the type name table below.
- */
+ and the type name table below. */
#define LAST_TYPE_CODE 0X3D
-
#define MIN_TYPE_CODE_LENGTH 6
#ifdef TYPE_CODE_LENGTH
#define GLOBAL_ENV TC_NULL
#define TC_BIT_STRING TC_VECTOR_1B
#define TC_VECTOR_8B TC_CHARACTER_STRING
-#define TC_ADDRESS TC_FIXNUM
#define TC_HUNK3 TC_HUNK3_B
#define UNMARKED_HISTORY_TYPE TC_HUNK3_A
program text). HDR's standard fields are already correct, except that
this adjustment to the `a_text' field has not yet been made;
thus, the amount of offset can depend on the data in the file.
-
+
* A_TEXT_SEEK(HDR)
If defined, this macro specifies the number of bytes to seek into the
{
close (new);
/* unlink (new_name); /* Failed, unlink new a.out */
- return -1;
+ return -1;
}
close (new);
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/unxutl/Attic/ymkfile,v 1.8 1989/08/03 19:52:19 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/unxutl/Attic/ymkfile,v 1.9 1989/09/20 23:13:36 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
LDFLAGS = LD_SWITCH_SYSTEM LD_SWITCH_MACHINE
-CFLAGS = C_OPTIMIZE_SWITCH C_DEBUG_SWITCH C_SWITCH_MACHINE C_SWITCH_SYSTEM C_SWITCH_FEATURES $(MACHINE_SWITCHES)
+CFLAGS = -DMIT_SCHEME C_OPTIMIZE_SWITCH C_DEBUG_SWITCH C_SWITCH_MACHINE C_SWITCH_SYSTEM C_SWITCH_FEATURES $(MACHINE_SWITCHES)
#ifndef ECHO
#define ECHO echo
SOURCES = \
$(MACHINE_SOURCES) \
+artutl.c \
bignum.c \
+bigprm.c \
bitstr.c \
boot.c \
char.c \
hunk.c \
intern.c \
interp.c \
+intprm.c \
list.c \
lookprm.c \
lookup.c \
primutl.c \
purify.c \
purutl.c \
-random.c \
regex.c \
rgxprim.c \
step.c \
utils.c \
vector.c
-HEAD_FILES = scheme.touch prims.h zones.h locks.h flonum.h bignum.h \
- string.h char.h $(GC_HEAD_FILES) trap.h lookup.h history.h cmpint.h
+HEAD_FILES = scheme.touch prims.h zones.h locks.h bignum.h \
+ $(GC_HEAD_FILES) trap.h lookup.h history.h cmpint.h
CORE_OBJECTS = \
$(MACHINE_OBJECTS) \
+artutl.o \
bignum.o \
+bigprm.o \
bitstr.o \
boot.o \
char.o \
hunk.o \
intern.o \
interp.o \
+intprm.o \
list.o \
lookprm.o \
lookup.o \
prim.o \
primutl.o \
purutl.o \
-random.o \
regex.o \
rgxprim.o \
step.o \
@ECHO "#** Re-linking" $@ because of $?
-mv -f $@ $@.busy
rm -f $@.busy
- $(CC) $(LDFLAGS) -o $@ Wsize.o $(SCHEME_LIB)
+ $(CC) $(LDFLAGS) -o $@ Wsize.o LIB_MATH LIBS_SYSTEM LIBS_MACHINE LIB_DEBUG LIB_STANDARD
Ppband : Ppband.o
@ECHO "#** Re-linking" $@ because of $?
echo "$$ Findprim -o usrdef.c -l [-.vms]usrdef.txt"
$(CC) $(CFLAGS) -c usrdef.c
-/* The usrFOO.c files should depend on SOURCES, but these change
- rarely, so they are left out to be generated by hand.
- use `make primitive_tables scheme' to remake anyway. */
-
-usrdef.c : $(SCHEME_SOURCES) usrdef.touch Findprim xmakefile
+usrdef.c : $(SCHEME_SOURCES) $(SOURCES) usrdef.touch Findprim xmakefile
@ECHO "#** Re-making" $@ because of $?
rm -f usrdef.c
./Findprim $(SCHEME_SOURCES) $(SOURCES) > usrdef.c
gc.h interp.h stack.h futures.h types.h errors.h returns.h \
const.h fixobj.h default.h extern.h prim.h intrpt.h
os.touch : os.c mul.c unix.c vms.c unknown.c scheme.touch zones.h
-psbmap.touch : config.h object.h bignum.h bitstr.h types.h \
- sdata.h const.h char.h missing.c psbmap.h $(GC_HEAD_FILES) \
+psbmap.touch : config.h object.h bignum.h bignumint.h bitstr.h types.h \
+ sdata.h const.h missing.c psbmap.h $(GC_HEAD_FILES) \
comlin.h comlin.c
usrdef.touch : usrdef.h config.h object.h prim.h
+limits.h : hard-params
+ -./hard-params -l > limits.h
+hard-params : hard-params.c
+ $(CC) -DNO_SC $(LDFLAGS) -o hard-params hard-params.c
+
lint.out : $(SOURCES) $(SCHEME_SOURCES) $(CSRC) usrdef.c $(HEAD_FILES)
rm -f lint.out
lint $(CFLAGS) $(SOURCES) $(SCHEME_SOURCES) $(CSRC) usrdef.c > lint.out
interp.o : scheme.touch locks.h trap.h lookup.h history.h cmpint.h zones.h
hooks.o : scheme.touch prims.h winder.h history.h
-utils.o : scheme.touch prims.h flonum.h winder.h history.h cmpint.h
+utils.o : scheme.touch prims.h winder.h history.h cmpint.h
primutl.o : scheme.touch prims.h prename.h
fixnum.o hunk.o list.o step.o vector.o sysprim.o daemon.o prim.o \
- random.o extern.o : scheme.touch prims.h
+ extern.o : scheme.touch prims.h
lookup.o debug.o intern.o : scheme.touch prims.h lookup.h trap.h locks.h
memmag.o gcloop.o purify.o purutl.o comutl.o : scheme.touch prims.h \
$(GC_HEAD_FILES) zones.h
-bignum.o flonum.o generic.o : scheme.touch prims.h flonum.h zones.h \
- bignum.h
+artutl.o : scheme.touch
+bignum.o : scheme.touch bignumint.h
+bigprm.o flonum.o intprm.o generic.o : scheme.touch prims.h zones.h
storage.o : scheme.touch gctype.c
-char.o fileio.o string.o ttyio.o : scheme.touch prims.h string.h char.h
+char.o fileio.o string.o ttyio.o : scheme.touch prims.h
-boot.o : scheme.touch prims.h version.h char.h string.h paths.h
+boot.o : scheme.touch prims.h version.h paths.h
compiler.o : config.h object.h sdata.h types.h errors.h const.h returns.h
os.o : scheme.touch os.touch zones.h
bchmmg.o bchgcl.o bchpur.o : scheme.touch prims.h bchgcc.h $(GC_HEAD_FILES)
bchdmp.o : scheme.touch prims.h bchgcc.h $(GC_HEAD_FILES) fasl.h dump.c
-hooks.o : scheme.touch prims.h winder.h history.h
-utils.o : scheme.touch prims.h flonum.h winder.h history.h cmpint.h
-
-syntax.o : scheme.touch prims.h string.h char.h edwin.h syntax.h
-bitstr.o : scheme.touch prims.h bignum.h bitstr.h
-regex.o : scheme.touch char.h syntax.h regex.h
-rgxprim.o : scheme.touch prims.h string.h char.h edwin.h syntax.h regex.h
-unixprim.o : scheme.touch prims.h string.h
+syntax.o : scheme.touch prims.h edwin.h syntax.h
+bitstr.o : scheme.touch prims.h bitstr.h
+regex.o : scheme.touch syntax.h regex.h
+rgxprim.o : scheme.touch prims.h edwin.h syntax.h regex.h
+unixprim.o : scheme.touch prims.h
-Bintopsb.o : psbmap.touch trap.h fasl.h load.c bltdef.h
+Bintopsb.o : psbmap.touch trap.h fasl.h load.c bltdef.h limits.h
Psbtobin.o : psbmap.touch fasl.h dump.c
Ppband.o : config.h types.h const.h object.h sdata.h fasl.h load.c
dmpwrld.o : unexec.c getpagesize.h
x11base.o x11graph.o x11term.o : scheme.touch prims.h x11.h
-cterm.o : scheme.touch prims.h string.h
-starbase.o : scheme.touch prims.h flonum.h
+cterm.o : scheme.touch prims.h
+starbase.o : scheme.touch prims.h
starbasex.o : scheme.touch prims.h x11.h
Xrep.o : scheme.touch prims.h Xlib.h
-Xlib.o : scheme.touch prims.h string.h Xlib.h
+Xlib.o : scheme.touch prims.h Xlib.h
-Sgraph.o Sgraph_xt.o SgX.o : scheme.touch prims.h flonum.h Sgraph.h
-Sgraph_ar.o : scheme.touch prims.h flonum.h Sgraph.h array.h
-fft.o : scheme.touch prims.h flonum.h zones.h array.h image.h
-array.o image.o : scheme.touch prims.h flonum.h array.h
+Sgraph.o Sgraph_xt.o SgX.o : scheme.touch prims.h Sgraph.h
+Sgraph_ar.o : scheme.touch prims.h Sgraph.h array.h
+fft.o : scheme.touch prims.h zones.h array.h image.h
+array.o image.o : scheme.touch prims.h array.h
cmp68020.s : cmp68020.m4
cmpvax.s : cmpvax.m4
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.44 1989/09/20 23:12:51 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.43 1989/08/28 18:29:38 cph Exp $ */
-
/* This file contains utilities for interrupts, errors, etc. */
#include "scheme.h"
#include "prims.h"
-#include "flonum.h"
#include "winder.h"
#include "history.h"
#include "cmpint.h"
\f
/* Set_Up_Interrupt is called from the Interrupt
- * macro to do all of the setup for calling the user's
- * interrupt routines.
- */
+ 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;
+ SCHEME_OBJECT Int_Vector, Handler;
long i, Int_Number, The_Int_Code, New_Int_Enb;
The_Int_Code = FETCH_INTERRUPT_CODE();
}
/* Handle case where interrupt vector is too small. */
- if (Int_Number >= (Vector_Length (Int_Vector)))
+ if (Int_Number >= (VECTOR_LENGTH (Int_Vector)))
{
fprintf (stderr,
"\nInterrupt out of range: %ld (vector length = %ld)\n",
- Int_Number, (Vector_Length (Int_Vector)));
+ Int_Number, (VECTOR_LENGTH (Int_Vector)));
fprintf (stderr,
"Interrupts = 0x%08lx, Mask = 0x%08lx, Masked = 0x%08lx\n",
FETCH_INTERRUPT_CODE(),
}
Global_Interrupt_Hook ();
- Handler = (User_Vector_Ref (Int_Vector, Int_Number));
+ Handler = (VECTOR_REF (Int_Vector, Int_Number));
/* Setup_Interrupt continues on the next page */
\f
Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 3);
/* Return from interrupt handler will re-enable interrupts */
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
+ Store_Expression(LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
Save_Cont();
/*
There used to be some code here for gc checks, but that is done
* the currently enabled interrupts.
*/
- Push(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
- Push(MAKE_SIGNED_FIXNUM(The_Int_Code));
+ Push(LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
+ Push(LONG_TO_FIXNUM(The_Int_Code));
Push(Handler);
Push(STACK_FRAME_HEADER + 2);
Pushed();
/* Error processing utilities */
void
-err_print(error_code, where)
+err_print (error_code, where)
long error_code;
- FILE *where;
+ FILE * where;
{
- extern char *Error_Names[];
+ extern char * Error_Names [];
if (error_code > MAX_ERROR)
- {
- fprintf(where, "Unknown error code 0x%x.\n", error_code);
- }
+ fprintf (where, "Unknown error code 0x%x.\n", error_code);
else
- {
- fprintf(where, "Error code 0x%x (%s).\n",
- error_code,
- Error_Names[error_code]);
- }
+ fprintf (where, "Error code 0x%x (%s).\n",
+ error_code,
+ (Error_Names [error_code]));
return;
}
long death_blow;
void
-error_death(code, message)
+error_death (code, message)
long code;
- char *message;
+ char * message;
{
death_blow = code;
- fprintf(stderr, "\nMicrocode Error: %s.\n", message);
- err_print(code, stderr);
- fprintf(stderr, "\n**** Stack Trace ****\n\n");
- Back_Trace(stderr);
- Microcode_Termination(TERM_NO_ERROR_HANDLER);
+ fprintf (stderr, "\nMicrocode Error: %s.\n", message);
+ err_print (code, stderr);
+ fprintf (stderr, "\n**** Stack Trace ****\n\n");
+ Back_Trace (stderr);
+ Microcode_Termination (TERM_NO_ERROR_HANDLER);
/*NOTREACHED*/
}
void
-Stack_Death()
+Stack_Death ()
{
- fprintf(stderr, "\nWill_Push vs. Pushed inconsistency.\n");
- Microcode_Termination(TERM_BAD_STACK);
+ fprintf (stderr, "\nWill_Push vs. Pushed inconsistency.\n");
+ Microcode_Termination (TERM_BAD_STACK);
/*NOTREACHED*/
}
\f
/* Back_Out_Of_Primitive sets the registers up so that the backout
- * mechanism in interpret.c will cause the primitive to be
- * restarted if the error/interrupt is proceeded.
- */
+ mechanism in interpret.c will cause the primitive to be
+ restarted if the error/interrupt is proceeded. */
void
Back_Out_Of_Primitive ()
{
long nargs;
- Pointer primitive;
+ SCHEME_OBJECT primitive;
/* Setup a continuation to return to compiled code if the primitive is
- * restarted and completes successfully.
- */
+ restarted and completes successfully. */
- primitive = Regs[REGBLOCK_PRIMITIVE];
- if (OBJECT_TYPE(primitive) != TC_PRIMITIVE)
- {
- fprintf(stderr,
- "\nBack_Out_Of_Primitive backing out when not in primitive!\n");
- Microcode_Termination(TERM_BAD_BACK_OUT);
- }
- nargs = PRIMITIVE_N_ARGUMENTS(primitive);
- if (OBJECT_TYPE(Stack_Ref(nargs)) == TC_COMPILED_ENTRY)
- {
- compiler_apply_procedure(nargs);
- }
-
- Push(primitive);
- Push(STACK_FRAME_HEADER + nargs);
- Store_Env(Make_Non_Pointer(GLOBAL_ENV, END_OF_CHAIN));
- Val = NIL;
- Store_Return(RC_INTERNAL_APPLY);
- Store_Expression(NIL);
- Regs[REGBLOCK_PRIMITIVE] = NIL;
+ primitive = (Regs [REGBLOCK_PRIMITIVE]);
+ if (! (PRIMITIVE_P (primitive)))
+ {
+ fprintf (stderr,
+ "\nBack_Out_Of_Primitive backing out when not in primitive!\n");
+ Microcode_Termination (TERM_BAD_BACK_OUT);
+ }
+ nargs = (PRIMITIVE_N_ARGUMENTS (primitive));
+ if (COMPILED_CODE_ADDRESS_P (Stack_Ref (nargs)))
+ compiler_apply_procedure (nargs);
+ Push (primitive);
+ Push (STACK_FRAME_HEADER + nargs);
+ Store_Env (MAKE_OBJECT (GLOBAL_ENV, END_OF_CHAIN));
+ Val = SHARP_F;
+ Store_Return (RC_INTERNAL_APPLY);
+ Store_Expression (SHARP_F);
+ (Regs [REGBLOCK_PRIMITIVE]) = SHARP_F;
return;
}
\f
-/*
- canonicalize_primitive_context should be used by "unsafe" primitives
- to guarantee that their execution context is the expected one, ie.
- they are called from the interpreter.
- If they are called from compiled code, they should abort to the
- interpreter and reenter.
- Note: This is called only from the macro PRIMITIVE_CANONICALIZE_CONTEXT,
- so that the work can be divided between them if it is an issue.
- */
+/* canonicalize_primitive_context should be used by "unsafe" primitives
+ to guarantee that their execution context is the expected one, ie.
+ they are called from the interpreter.
+ If they are called from compiled code, they should abort to the
+ interpreter and reenter.
+ Note: This is called only from the macro PRIMITIVE_CANONICALIZE_CONTEXT,
+ so that the work can be divided between them if it is an issue. */
-extern void canonicalize_primitive_context();
+extern void canonicalize_primitive_context ();
void
-canonicalize_primitive_context()
+canonicalize_primitive_context ()
{
long nargs;
- Pointer primitive;
+ SCHEME_OBJECT primitive;
- primitive = Regs[REGBLOCK_PRIMITIVE];
- if (OBJECT_TYPE(primitive) != TC_PRIMITIVE)
- {
- fprintf(stderr,
- "\ncanonicalize_primitive_context invoked when not in primitive!\n");
- Microcode_Termination(TERM_BAD_BACK_OUT);
- }
- nargs = PRIMITIVE_N_ARGUMENTS(primitive);
- if ((OBJECT_TYPE(Stack_Ref(nargs))) != TC_COMPILED_ENTRY)
- {
+ primitive = (Regs [REGBLOCK_PRIMITIVE]);
+ if (! (PRIMITIVE_P (primitive)))
+ {
+ fprintf
+ (stderr,
+ "\ncanonicalize_primitive_context invoked when not in primitive!\n");
+ Microcode_Termination (TERM_BAD_BACK_OUT);
+ }
+ nargs = (PRIMITIVE_N_ARGUMENTS (primitive));
+ if (! (COMPILED_CODE_ADDRESS_P (Stack_Ref (nargs))))
return;
- }
/* The primitive has been invoked from compiled code. */
- PRIMITIVE_ABORT(PRIM_REENTER);
+ PRIMITIVE_ABORT (PRIM_REENTER);
/*NOTREACHED*/
}
\f
not before.
This guarantees that the interpreter state is consistent, since the
longjmp restores the relevant registers even if the primitive was
- invoked from compiled code.
- */
-
-extern void
- signal_error_from_primitive(),
- signal_interrupt_from_primitive(),
- error_wrong_type_arg(),
- error_bad_range_arg(),
- error_external_return();
+ invoked from compiled code. */
void
signal_error_from_primitive (error_code)
long error_code;
{
- PRIMITIVE_ABORT(error_code);
+ PRIMITIVE_ABORT (error_code);
/*NOTREACHED*/
}
void
signal_interrupt_from_primitive ()
{
- PRIMITIVE_ABORT(PRIM_INTERRUPT);
+ PRIMITIVE_ABORT (PRIM_INTERRUPT);
/*NOTREACHED*/
}
-\f
+
void
error_wrong_type_arg (n)
int n;
}
\f
long
-arg_fixnum (n)
- int n;
+arg_integer (arg_number)
+ int arg_number;
{
- fast Pointer argument;
-
- argument = (ARG_REF (n));
- if (! (FIXNUM_P (argument)))
- {
- error_wrong_type_arg (n);
- }
- return
- ((FIXNUM_NEGATIVE_P (argument))
- ? ((UNSIGNED_FIXNUM_VALUE (argument)) | (-1 << ADDRESS_LENGTH))
- : (UNSIGNED_FIXNUM_VALUE (argument)));
+ fast SCHEME_OBJECT object = (ARG_REF (arg_number));
+ if (! (INTEGER_P (object)))
+ error_wrong_type_arg (arg_number);
+ if (! (integer_to_long_p (object)))
+ error_bad_range_arg (arg_number);
+ return (integer_to_long (object));
}
long
-arg_nonnegative_integer (n)
- int n;
+arg_nonnegative_integer (arg_number)
+ int arg_number;
{
- fast Pointer argument;
+ fast long result = (arg_integer (arg_number));
+ if (result < 0)
+ error_bad_range_arg (arg_number);
+ return (result);
+}
- argument = (ARG_REF (n));
- if (! (FIXNUM_P (argument)))
- {
- error_wrong_type_arg (n);
- }
- if (FIXNUM_NEGATIVE_P (argument))
- {
- error_bad_range_arg (n);
- }
- return (UNSIGNED_FIXNUM_VALUE (argument));
+long
+arg_index_integer (arg_number, upper_limit)
+ int arg_number;
+ long upper_limit;
+{
+ fast long result = (arg_integer (arg_number));
+ if ((result < 0) || (result >= upper_limit))
+ error_bad_range_arg (arg_number);
+ return (result);
}
-\f
+
long
-arg_index_integer (n, upper_limit)
- int n;
+arg_integer_in_range (arg_number, lower_limit, upper_limit)
+ int arg_number;
+ long lower_limit;
long upper_limit;
{
- fast Pointer argument;
- fast long result;
+ fast long result = (arg_integer (arg_number));
+ if ((result < lower_limit) || (result >= upper_limit))
+ error_bad_range_arg (arg_number);
+ return (result);
+}
+\f
+Boolean
+real_number_to_double_p (x)
+ fast SCHEME_OBJECT x;
+{
+ return ((! (BIGNUM_P (x))) || (BIGNUM_TO_DOUBLE_P (x)));
+}
- argument = (ARG_REF (n));
- if (! (FIXNUM_P (argument)))
- {
- error_wrong_type_arg (n);
- }
- if (FIXNUM_NEGATIVE_P (argument))
- {
- error_bad_range_arg (n);
- }
- result = (UNSIGNED_FIXNUM_VALUE (argument));
- if (result >= upper_limit)
- {
- error_bad_range_arg (n);
- }
+double
+real_number_to_double (x)
+ fast SCHEME_OBJECT x;
+{
+ return
+ ((FIXNUM_P (x))
+ ? (FIXNUM_TO_DOUBLE (x))
+ : (BIGNUM_P (x))
+ ? (bignum_to_double (x))
+ : (FLONUM_TO_DOUBLE (x)));
+}
+
+double
+arg_real_number (arg_number)
+ int arg_number;
+{
+ fast SCHEME_OBJECT number = (ARG_REF (arg_number));
+ if (! (REAL_P (number)))
+ error_wrong_type_arg (arg_number);
+ if (! (real_number_to_double_p (number)))
+ error_bad_range_arg (arg_number);
+ return (real_number_to_double (number));
+}
+
+double
+arg_real_in_range (arg_number, lower_limit, upper_limit)
+ int arg_number;
+ double lower_limit;
+ double upper_limit;
+{
+ fast double result = (arg_real_number (arg_number));
+ if ((result < lower_limit) || (result > upper_limit))
+ error_bad_range_arg (arg_number);
return (result);
}
+\f
+Boolean
+interpreter_applicable_p (object)
+ fast SCHEME_OBJECT object;
+{
+ extern void compiled_entry_type ();
+ tail_recurse:
+ switch (OBJECT_TYPE (object))
+ {
+ case TC_PRIMITIVE:
+ case TC_PROCEDURE:
+ case TC_EXTENDED_PROCEDURE:
+ case TC_CONTROL_POINT:
+ return (true);
+
+ case TC_ENTITY:
+ {
+ object = (MEMORY_REF (object, ENTITY_OPERATOR));
+ goto tail_recurse;
+ }
+ case TC_COMPILED_ENTRY:
+ {
+ long results [3];
+ compiled_entry_type (object, results);
+ return ((results [0]) == 0);
+ }
+ default:
+ return (false);
+ }
+}
\f
/******************/
/* ERROR HANDLING */
long Err;
Boolean From_Pop_Return;
{
- Pointer Error_Vector, Handler;
+ SCHEME_OBJECT Error_Vector, Handler;
if (Consistency_Check)
{
debug_nslots = local_nslots;
debug_slotno = local_slotno;
}
-#endif
+#endif
/* Do_Micro_Error continues on the next page. */
\f
/* Do_Micro_Error, continued */
if ((!Valid_Fixed_Obj_Vector()) ||
- (OBJECT_TYPE((Error_Vector =
+ (OBJECT_TYPE ((Error_Vector =
Get_Fixed_Obj_Slot(System_Error_Vector))) !=
TC_VECTOR))
{
/*NOTREACHED*/
}
- if ((Err < 0) || (Err >= (Vector_Length (Error_Vector))))
+ if ((Err < 0) || (Err >= (VECTOR_LENGTH (Error_Vector))))
{
- if (Vector_Length(Error_Vector) == 0)
+ if (VECTOR_LENGTH (Error_Vector) == 0)
{
error_death(Err, "Empty error handlers vector");
/*NOTREACHED*/
}
- Handler = (User_Vector_Ref (Error_Vector, ERR_BAD_ERROR_CODE));
+ Handler = (VECTOR_REF (Error_Vector, ERR_BAD_ERROR_CODE));
}
else
{
- Handler = (User_Vector_Ref (Error_Vector, Err));
+ Handler = (VECTOR_REF (Error_Vector, Err));
}
\f
/* 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!
- */
+ */
if (From_Pop_Return)
{
Stop_History();
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
+ Store_Expression(LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
Save_Cont();
/* Arg 2: Int. mask */
- Push(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
+ Push(LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
/* Arg 1: Err. No */
if ((Err >= SMALLEST_FIXNUM) && (Err <= BIGGEST_FIXNUM))
{
- Push(Make_Signed_Fixnum(Err));
+ Push (LONG_TO_FIXNUM(Err));
}
else
{
- Push (Make_Unsigned_Fixnum (ERR_BAD_ERROR_CODE));
+ Push (LONG_TO_UNSIGNED_FIXNUM (ERR_BAD_ERROR_CODE));
}
/* Procedure: Handler */
Push(Handler);
return;
}
\f
-extern Pointer *copy_c_string_to_scheme_string();
-
-/* Is supposed to have a null character. */
-static char null_string[] = "";
-
-Pointer *
-copy_c_string_to_scheme_string(source, start, end)
- fast char *source;
- Pointer *start, *end;
-{
- Pointer *saved;
- long char_count, word_count;
- fast char *dest, *limit;
-
- saved = start;
- start += STRING_CHARS;
- dest = ((char *) start);
-
- if (source == ((char *) NULL))
- {
- source = ((char *) &null_string[0]);
- }
- limit = ((char *) end);
- if (dest < limit)
- {
- do
- {
- *dest++ = *source;
- } while ((dest < limit) && (*source++ != '\0'));
- }
- if (dest >= limit)
- {
- while (*source++ != '\0')
- {
- dest += 1;
- }
- }
- char_count = (dest - ((char *) start));
- word_count = ((char_count + (sizeof(Pointer) - 1)) / sizeof(Pointer));
- start += word_count;
- if (start < end)
- {
- saved[STRING_HEADER] = Make_Non_Pointer( TC_MANIFEST_NM_VECTOR,
- (word_count + 1));
- saved[STRING_LENGTH] = ((Pointer) (char_count - 1));
- }
- return (start);
-}
-\f
-/* Make a Scheme string with the characters in C_String. */
-
-Pointer
-C_String_To_Scheme_String (c_string)
- char *c_string;
-{
- Pointer *end, *result, value;
-
- end = &Free[Space_Before_GC()];
- result = copy_c_string_to_scheme_string(c_string, Free, end);
- if (result >= end)
- {
- Primitive_GC(result - Free);
- }
- value = Make_Pointer( TC_CHARACTER_STRING, Free);
- Free = result;
- return (value);
-}
-\f
-Boolean
-Open_File (Name, Mode_String, Handle)
- Pointer Name;
- char *Mode_String;
- FILE **Handle;
-{
- extern FILE *OS_file_open();
-
- *Handle =
- 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;
-}
-
-CRLF ()
-{
- printf( "\n");
-}
-\f
/* HISTORY manipulation */
-Pointer *
+SCHEME_OBJECT *
Make_Dummy_History ()
{
- Pointer *History_Rib = Free;
- Pointer *Result;
+ SCHEME_OBJECT *History_Rib = Free;
+ SCHEME_OBJECT *Result;
- Free[RIB_EXP] = NIL;
- Free[RIB_ENV] = NIL;
+ Free[RIB_EXP] = SHARP_F;
+ Free[RIB_ENV] = SHARP_F;
Free[RIB_NEXT_REDUCTION] =
- Make_Pointer(UNMARKED_HISTORY_TYPE, History_Rib);
+ MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History_Rib);
Free += 3;
Result = Free;
- Free[HIST_RIB] = Make_Pointer(UNMARKED_HISTORY_TYPE, History_Rib);
+ Free[HIST_RIB] = MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History_Rib);
Free[HIST_NEXT_SUBPROBLEM] =
- Make_Pointer(UNMARKED_HISTORY_TYPE, Result);
+ MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, Result);
Free[HIST_PREV_SUBPROBLEM] =
- Make_Pointer(UNMARKED_HISTORY_TYPE, Result);
+ MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, Result);
Free += 3;
return (Result);
}
void
Stop_History ()
{
- Pointer Saved_Expression;
+ SCHEME_OBJECT Saved_Expression;
long Saved_Return_Code;
Saved_Expression = Fetch_Expression();
return;
}
\f
-Pointer *
+SCHEME_OBJECT *
Copy_Rib (Orig_Rib)
- Pointer *Orig_Rib;
+ SCHEME_OBJECT *Orig_Rib;
{
- Pointer *Result, *This_Rib;
+ SCHEME_OBJECT *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]))
+ This_Rib = OBJECT_ADDRESS (This_Rib[RIB_NEXT_REDUCTION]))
{
if (This_Rib == NULL)
{
}
Free[RIB_EXP] = This_Rib[RIB_EXP];
Free[RIB_ENV] = This_Rib[RIB_ENV];
- Free[RIB_NEXT_REDUCTION] = Make_Pointer(UNMARKED_HISTORY_TYPE, Free+3);
+ Free[RIB_NEXT_REDUCTION] =
+ (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, Free+3));
if (HISTORY_MARKED_P(This_Rib[RIB_MARK]))
{
HISTORY_MARK(Free[RIB_MARK]);
}
Free += 3;
}
- Store_Address((Free - 3)[RIB_NEXT_REDUCTION], C_To_Scheme(Result));
+ ((Free - 3) [RIB_NEXT_REDUCTION]) =
+ (OBJECT_NEW_ADDRESS (((Free - 3) [RIB_NEXT_REDUCTION]), Result));
return (Result);
}
Boolean
Restore_History (Hist_Obj)
- Pointer Hist_Obj;
+ SCHEME_OBJECT Hist_Obj;
{
- Pointer *New_History, *Next_Vertebra, *Prev_Vertebra,
+ SCHEME_OBJECT *New_History, *Next_Vertebra, *Prev_Vertebra,
*Orig_Vertebra;
if (Consistency_Check)
/*NOTREACHED*/
}
}
- Orig_Vertebra = Get_Pointer(Hist_Obj);
+ Orig_Vertebra = OBJECT_ADDRESS (Hist_Obj);
\f
for (Next_Vertebra = NULL, Prev_Vertebra = NULL;
Next_Vertebra != Orig_Vertebra;
- Next_Vertebra =
- Get_Pointer(Next_Vertebra[HIST_NEXT_SUBPROBLEM]))
+ Next_Vertebra =
+ OBJECT_ADDRESS (Next_Vertebra[HIST_NEXT_SUBPROBLEM]))
{
- Pointer *New_Rib;
+ SCHEME_OBJECT *New_Rib;
if (Prev_Vertebra == NULL)
{
Next_Vertebra = Orig_Vertebra;
}
- New_Rib = Copy_Rib(Get_Pointer(Next_Vertebra[HIST_RIB]));
+ New_Rib = Copy_Rib(OBJECT_ADDRESS (Next_Vertebra[HIST_RIB]));
if (Prev_Vertebra == NULL)
{
New_History = Free;
else
{
Prev_Vertebra[HIST_NEXT_SUBPROBLEM] =
- Make_Pointer(UNMARKED_HISTORY_TYPE, Free);
+ MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, Free);
}
- Free[HIST_RIB] = Make_Pointer(UNMARKED_HISTORY_TYPE, New_Rib);
- Free[HIST_NEXT_SUBPROBLEM] = NIL;
+ Free[HIST_RIB] = MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, New_Rib);
+ Free[HIST_NEXT_SUBPROBLEM] = SHARP_F;
Free[HIST_PREV_SUBPROBLEM] =
- Make_Pointer(UNMARKED_HISTORY_TYPE, Prev_Vertebra);
+ MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, Prev_Vertebra);
if (HISTORY_MARKED_P(Next_Vertebra[HIST_MARK]))
{
HISTORY_MARK(Free[HIST_MARK]);
return (false);
}
}
- Store_Address(New_History[HIST_PREV_SUBPROBLEM], C_To_Scheme(Free-3));
+ (New_History [HIST_PREV_SUBPROBLEM]) =
+ (OBJECT_NEW_ADDRESS ((New_History [HIST_PREV_SUBPROBLEM]), (Free - 3)));
Prev_Vertebra[HIST_NEXT_SUBPROBLEM] =
- Make_Pointer(UNMARKED_HISTORY_TYPE, New_History);
+ MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, New_History);
if (HISTORY_MARKED_P(Orig_Vertebra[HIST_MARK]))
{
HISTORY_MARK(Prev_Vertebra[HIST_MARK]);
#ifdef ENABLE_DEBUGGING_TOOLS
-Pointer
+SCHEME_OBJECT
Apply_Primitive (primitive)
- Pointer primitive;
+ SCHEME_OBJECT primitive;
{
- Pointer Result, *Saved_Stack;
+ SCHEME_OBJECT Result, *Saved_Stack;
if (Primitive_Debug)
{
void
record_primitive_entry (primitive)
- Pointer primitive;
+ SCHEME_OBJECT primitive;
{
- Pointer table;
+ SCHEME_OBJECT table;
- if ((Fixed_Objects != NIL) &&
- ((table = Get_Fixed_Obj_Slot (Primitive_Profiling_Table)) != NIL))
+ if ((Fixed_Objects != SHARP_F) &&
+ ((table = Get_Fixed_Obj_Slot (Primitive_Profiling_Table)) != SHARP_F))
{
- long index, old_value;
-
- index = (1 + (OBJECT_DATUM (primitive)));
- Scheme_Integer_To_C_Integer ((Vector_Ref (table, index)), &old_value);
- Vector_Set (table, index, (C_Integer_To_Scheme_Integer (1 + old_value)));
+ long index = (1 + (OBJECT_DATUM (primitive)));
+ MEMORY_SET
+ (table,
+ index,
+ (long_to_integer (1 + (integer_to_long (MEMORY_REF (table, index))))));
}
return;
}
#endif /* ENABLE_PRIMITIVE_PROFILING */
\f
-Pointer
-Allocate_Float (F)
- double F;
-{
- Pointer Result;
-
- Align_Float(Free);
- Result = Make_Pointer(TC_BIG_FLONUM, Free);
- *Free = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, FLONUM_SIZE);
- Get_Float(C_To_Scheme(Free)) = F;
- Primitive_GC_If_Needed(FLONUM_SIZE+1);
- Free += (FLONUM_SIZE + 1);
- return (Result);
-}
-\f
#ifdef USE_STACKLETS
/******************/
/* STACKLETS */
Allocate_New_Stacklet (N)
long N;
{
- Pointer Old_Expression, *Old_Stacklet, Old_Return;
+ SCHEME_OBJECT Old_Expression, *Old_Stacklet, Old_Return;
Old_Stacklet = Current_Stacklet;
Terminate_Old_Stacklet();
Microcode_Termination(TERM_STACK_OVERFLOW);
}
}
- Free[STACKLET_LENGTH] = Make_Non_Pointer(TC_MANIFEST_VECTOR, (size - 1));
+ Free[STACKLET_LENGTH] = MAKE_OBJECT (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;
+ SCHEME_OBJECT *New_Stacklet;
New_Stacklet = Free_Stacklets;
- Free_Stacklets = ((Pointer *) Free_Stacklets[STACKLET_FREE_LIST_LINK]);
+ Free_Stacklets =
+ ((SCHEME_OBJECT *) Free_Stacklets[STACKLET_FREE_LIST_LINK]);
Stack_Pointer =
&New_Stacklet[1 + (OBJECT_DATUM (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_Expression(MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Old_Stacklet));
Store_Return(RC_JOIN_STACKLETS);
/*
Will_Push omitted because size calculation includes enough room.
\f
/* Dynamic Winder support code */
-Pointer
+SCHEME_OBJECT
Find_State_Space (State_Point)
- Pointer State_Point;
+ SCHEME_OBJECT State_Point;
{
long How_Far =
- (UNSIGNED_FIXNUM_VALUE
- (Fast_Vector_Ref (State_Point, STATE_POINT_DISTANCE_TO_ROOT)));
+ (UNSIGNED_FIXNUM_TO_LONG
+ (FAST_MEMORY_REF (State_Point, STATE_POINT_DISTANCE_TO_ROOT)));
long i;
- fast Pointer Point = State_Point;
+ fast SCHEME_OBJECT Point = State_Point;
for (i=0; i <= How_Far; i++)
- {
+ {
#ifdef ENABLE_DEBUGGING_TOOLS
- if (Point == NIL)
+ if (Point == SHARP_F)
{
fprintf(stderr,
- "\nState_Point 0x%x wrong: count was %d, NIL at %d\n",
+ "\nState_Point 0x%x wrong: count was %d, #F at %d\n",
State_Point, How_Far, i);
Microcode_Termination(TERM_EXIT);
/*NOTREACHED*/
}
#endif /* ENABLE_DEBUGGING_TOOLS */
- Point = Fast_Vector_Ref(Point, STATE_POINT_NEARER_POINT);
+ Point = FAST_MEMORY_REF (Point, STATE_POINT_NEARER_POINT);
}
return (Point);
}
never contain FUTUREs except possibly as the thunks (which are handled
by the apply code).
- Furthermore:
+ 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
+ #F) 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
+ initial space (#F) 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
\f
void
Translate_To_Point (Target)
- Pointer Target;
+ SCHEME_OBJECT Target;
{
- Pointer State_Space, Current_Location, *Path;
- fast Pointer Path_Point, *Path_Ptr;
+ SCHEME_OBJECT State_Space, Current_Location, *Path;
+ fast SCHEME_OBJECT Path_Point, *Path_Ptr;
long Distance, Merge_Depth, From_Depth, i;
State_Space = Find_State_Space(Target);
Path = Free;
guarantee_state_point();
Distance =
- (UNSIGNED_FIXNUM_VALUE
- (Fast_Vector_Ref (Target, STATE_POINT_DISTANCE_TO_ROOT)));
- if (State_Space == NIL)
+ (UNSIGNED_FIXNUM_TO_LONG
+ (FAST_MEMORY_REF (Target, STATE_POINT_DISTANCE_TO_ROOT)));
+ if (State_Space == SHARP_F)
{
Current_Location = Current_State_Point;
}
else
{
- Current_Location = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT);
+ Current_Location = MEMORY_REF (State_Space, STATE_SPACE_NEAREST_POINT);
}
if (Target == Current_Location)
{
- PRIMITIVE_ABORT(PRIM_POP_RETURN);
+ PRIMITIVE_ABORT (PRIM_POP_RETURN);
/*NOTREACHED*/
}
i++)
{
*Path_Ptr-- = Path_Point;
- Path_Point = Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT);
+ Path_Point = FAST_MEMORY_REF (Path_Point, STATE_POINT_NEARER_POINT);
}
From_Depth =
- (UNSIGNED_FIXNUM_VALUE
- (Fast_Vector_Ref (Current_Location, STATE_POINT_DISTANCE_TO_ROOT)));
+ (UNSIGNED_FIXNUM_TO_LONG
+ (FAST_MEMORY_REF (Current_Location, STATE_POINT_DISTANCE_TO_ROOT)));
\f
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);
+ Path_Point = FAST_MEMORY_REF (Path_Point, STATE_POINT_NEARER_POINT);
}
for (Path_Ptr = (&(Path[Merge_Depth]));
{
break;
}
- Path_Point = Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT);
+ Path_Point = FAST_MEMORY_REF (Path_Point, STATE_POINT_NEARER_POINT);
}
#ifdef ENABLE_DEBUGGING_TOOLS
}
#endif /* ENABLE_DEBUGGING_TOOLS */
- Will_Push(2*CONTINUATION_SIZE + 4);
+ Will_Push(2*CONTINUATION_SIZE + 4);
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
+ Store_Expression(LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
Save_Cont();
- Push(Make_Unsigned_Fixnum((Distance - Merge_Depth)));
+ Push(LONG_TO_UNSIGNED_FIXNUM((Distance - Merge_Depth)));
Push(Target);
- Push(Make_Unsigned_Fixnum((From_Depth - Merge_Depth)));
+ Push(LONG_TO_UNSIGNED_FIXNUM((From_Depth - Merge_Depth)));
Push(Current_Location);
Store_Expression(State_Space);
Store_Return(RC_MOVE_TO_ADJACENT_POINT);
mask = (FETCH_INTERRUPT_MASK() & ((INT_GC << 1) - 1));
SET_INTERRUPT_MASK(mask);
}
- PRIMITIVE_ABORT(PRIM_POP_RETURN);
+ PRIMITIVE_ABORT (PRIM_POP_RETURN);
/*NOTREACHED*/
}
\f
-extern Pointer Compiler_Get_Fixed_Objects();
+extern SCHEME_OBJECT Compiler_Get_Fixed_Objects();
-Pointer
+SCHEME_OBJECT
Compiler_Get_Fixed_Objects()
{
if (Valid_Fixed_Obj_Vector())
}
else
{
- return (NIL);
+ return (SHARP_F);
}
}
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/vector.c,v 9.32 1989/09/20 23:12:56 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/vector.c,v 9.31 1988/08/15 20:57:57 cph Rel $ */
-
-/* This file contains procedures for handling vectors and conversion
- back and forth to lists. */
+/* This file contains procedures for handling vectors. */
#include "scheme.h"
#include "prims.h"
\f
#define ARG_VECTOR(argument_number) \
-((VECTOR_P (ARG_REF (argument_number))) \
- ? (ARG_REF (argument_number)) \
- : ((Pointer) (error_wrong_type_arg (argument_number))))
-
-/* Flush old definition -- we won't use it. */
-#ifdef VECTOR_LENGTH
-#undef VECTOR_LENGTH
-#endif
-
-#define VECTOR_LENGTH(vector) \
-(UNSIGNED_FIXNUM_VALUE (Fast_Vector_Ref ((vector), 0)))
+ ((VECTOR_P (ARG_REF (argument_number))) \
+ ? (ARG_REF (argument_number)) \
+ : ((error_wrong_type_arg (argument_number)), ((SCHEME_OBJECT) 0)))
#define ARG_VECTOR_INDEX(argument_number, vector) \
-(arg_index_integer (argument_number, (Vector_Length (vector))))
-
-#define GC_VECTOR_P(object) ((GC_Type (object)) == GC_Vector)
+ (arg_index_integer (argument_number, (VECTOR_LENGTH (vector))))
#define ARG_GC_VECTOR(argument_number) \
-((GC_VECTOR_P (ARG_REF (argument_number))) \
- ? (ARG_REF (argument_number)) \
- : ((Pointer) (error_wrong_type_arg (argument_number))))
+ ((GC_VECTOR_P (ARG_REF (argument_number))) \
+ ? (ARG_REF (argument_number)) \
+ : ((error_wrong_type_arg (argument_number)), ((SCHEME_OBJECT) 0)))
-/* VECTOR_TOUCH does nothing, this is copied from a previous version
- of this code. Perhaps it should do a touch? -- CPH */
-#define VECTOR_TOUCH(vector)
-#define GC_VECTOR_TOUCH(vector) Touch_In_Primitive (vector, vector)
-
-#define VECTOR_REF(vector, index) (Vector_Ref ((vector), ((index) + 1)))
-#define VECTOR_LOC(vector, index) (Nth_Vector_Loc ((vector), ((index) + 1)))
-\f
-Pointer
+SCHEME_OBJECT
allocate_non_marked_vector (type_code, length, gc_check_p)
int type_code;
fast long length;
Boolean gc_check_p;
{
- fast Pointer result;
+ fast SCHEME_OBJECT result;
if (gc_check_p)
Primitive_GC_If_Needed (length + 1);
- result = (Make_Pointer (type_code, Free));
- (*Free++) = (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, length));
+ result = (MAKE_POINTER_OBJECT (type_code, Free));
+ (*Free++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, length));
Free += length;
return (result);
}
-Pointer
+SCHEME_OBJECT
allocate_marked_vector (type_code, length, gc_check_p)
int type_code;
fast long length;
Boolean gc_check_p;
{
- fast Pointer result;
-
if (gc_check_p)
Primitive_GC_If_Needed (length + 1);
- result = (Make_Pointer (type_code, Free));
- (*Free++) = (Make_Non_Pointer (TC_MANIFEST_VECTOR, length));
- Free += length;
- return (result);
+ {
+ fast SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (type_code, Free));
+ (*Free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, length));
+ Free += length;
+ return (result);
+ }
}
-Pointer
-make_vector (length, contents)
+SCHEME_OBJECT
+make_vector (length, contents, gc_check_p)
fast long length;
- fast Pointer contents;
+ fast SCHEME_OBJECT contents;
+ Boolean gc_check_p;
{
- fast Pointer result;
-
- Primitive_GC_If_Needed (length + 1);
- result = (Make_Pointer (TC_VECTOR, Free));
- (*Free++) = (Make_Non_Pointer (TC_MANIFEST_VECTOR, length));
- while ((length--) > 0)
- (*Free++) = contents;
- return (result);
+ if (gc_check_p)
+ Primitive_GC_If_Needed (length + 1);
+ {
+ fast SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (TC_VECTOR, Free));
+ (*Free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, length));
+ while ((length--) > 0)
+ (*Free++) = contents;
+ return (result);
+ }
}
\f
DEFINE_PRIMITIVE ("VECTOR-CONS", Prim_vector_cons, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
-
PRIMITIVE_RETURN
(make_vector ((arg_nonnegative_integer (1)), (ARG_REF (2))));
}
DEFINE_PRIMITIVE ("VECTOR", Prim_vector, 0, LEXPR, 0)
{
- Pointer result;
- fast Pointer *argument_scan;
- fast Pointer *argument_limit;
- fast Pointer *result_scan;
PRIMITIVE_HEADER (LEXPR);
-
- result = (allocate_marked_vector (TC_VECTOR, (LEXPR_N_ARGUMENTS ()), true));
- argument_scan = (ARG_LOC (1));
- argument_limit = (ARG_LOC ((LEXPR_N_ARGUMENTS ()) + 1));
- result_scan = (VECTOR_LOC (result, 0));
- while (argument_scan != argument_limit)
- (*result_scan++) = (STACK_LOCATIVE_POP (argument_scan));
- PRIMITIVE_RETURN (result);
+ {
+ SCHEME_OBJECT result =
+ (allocate_marked_vector (TC_VECTOR, (LEXPR_N_ARGUMENTS ()), true));
+ fast SCHEME_OBJECT * argument_scan = (ARG_LOC (1));
+ fast SCHEME_OBJECT * argument_limit =
+ (ARG_LOC ((LEXPR_N_ARGUMENTS ()) + 1));
+ fast SCHEME_OBJECT * result_scan = (VECTOR_LOC (result, 0));
+ while (argument_scan != argument_limit)
+ (*result_scan++) = (STACK_LOCATIVE_POP (argument_scan));
+ PRIMITIVE_RETURN (result);
+ }
}
DEFINE_PRIMITIVE ("SYSTEM-VECTOR?", Prim_sys_vector, 1, 1, 0)
{
- fast Pointer object;
+ fast SCHEME_OBJECT object;
PRIMITIVE_HEADER (1);
-
- object = (ARG_REF (1));
- Touch_In_Primitive (object, object);
- PRIMITIVE_RETURN ((GC_VECTOR_P (object)) ? SHARP_T : NIL);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (GC_VECTOR_P (object)));
}
-\f
-#define VECTOR_LENGTH_PRIMITIVE(arg_type, arg_touch) \
- fast Pointer vector; \
+
+#define VECTOR_LENGTH_PRIMITIVE(arg_type) \
+{ \
+ fast SCHEME_OBJECT vector; \
PRIMITIVE_HEADER (1); \
- \
- vector = (arg_type (1)); \
- arg_touch (vector); \
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (VECTOR_LENGTH (vector)))
+ TOUCH_IN_PRIMITIVE ((arg_type (1)), vector); \
+ PRIMITIVE_RETURN (long_to_integer (VECTOR_LENGTH (vector))); \
+}
DEFINE_PRIMITIVE ("VECTOR-LENGTH", Prim_vector_size, 1, 1, 0)
-{ VECTOR_LENGTH_PRIMITIVE (ARG_VECTOR, VECTOR_TOUCH); }
+ VECTOR_LENGTH_PRIMITIVE (ARG_VECTOR)
DEFINE_PRIMITIVE ("SYSTEM-VECTOR-SIZE", Prim_sys_vec_size, 1, 1, 0)
-{ VECTOR_LENGTH_PRIMITIVE (ARG_GC_VECTOR, GC_VECTOR_TOUCH); }
+ VECTOR_LENGTH_PRIMITIVE (ARG_GC_VECTOR)
-#define VECTOR_REF_PRIMITIVE(arg_type, arg_touch) \
- fast Pointer vector; \
+#define VECTOR_REF_PRIMITIVE(arg_type) \
+{ \
+ fast SCHEME_OBJECT vector; \
PRIMITIVE_HEADER (2); \
- \
- vector = (arg_type (1)); \
- arg_touch (vector); \
- PRIMITIVE_RETURN (VECTOR_REF (vector, (ARG_VECTOR_INDEX (2, vector))))
+ TOUCH_IN_PRIMITIVE ((arg_type (1)), vector); \
+ PRIMITIVE_RETURN \
+ (VECTOR_REF (vector, (ARG_VECTOR_INDEX (2, vector)))); \
+}
DEFINE_PRIMITIVE ("VECTOR-REF", Prim_vector_ref, 2, 2, 0)
-{ VECTOR_REF_PRIMITIVE (ARG_VECTOR, VECTOR_TOUCH); }
+ VECTOR_REF_PRIMITIVE (ARG_VECTOR)
DEFINE_PRIMITIVE ("SYSTEM-VECTOR-REF", Prim_sys_vector_ref, 2, 2, 0)
-{ VECTOR_REF_PRIMITIVE (ARG_GC_VECTOR, GC_VECTOR_TOUCH); }
+ VECTOR_REF_PRIMITIVE (ARG_GC_VECTOR)
-#define VECTOR_SET_PRIMITIVE(arg_type, arg_touch) \
- fast Pointer vector; \
- fast Pointer new_value; \
- fast Pointer *locative; \
+#define VECTOR_SET_PRIMITIVE(arg_type) \
+{ \
+ fast SCHEME_OBJECT vector; \
PRIMITIVE_HEADER (3); \
- \
- vector = (arg_type (1)); \
- arg_touch (vector); \
- new_value = (ARG_REF (3)); \
- locative = (VECTOR_LOC (vector, (ARG_VECTOR_INDEX (2, vector)))); \
- Side_Effect_Impurify (vector, new_value); \
- PRIMITIVE_RETURN (Swap_Pointers (locative, new_value))
+ TOUCH_IN_PRIMITIVE ((arg_type (1)), vector); \
+ { \
+ fast SCHEME_OBJECT new_value = (ARG_REF (3)); \
+ SIDE_EFFECT_IMPURIFY (vector, new_value); \
+ VECTOR_SET (vector, (ARG_VECTOR_INDEX (2, vector)), new_value); \
+ } \
+ PRIMITIVE_RETURN (UNSPECIFIC); \
+}
DEFINE_PRIMITIVE ("VECTOR-SET!", Prim_vector_set, 3, 3, 0)
-{ VECTOR_SET_PRIMITIVE (ARG_VECTOR, VECTOR_TOUCH); }
+ VECTOR_SET_PRIMITIVE (ARG_VECTOR)
DEFINE_PRIMITIVE ("SYSTEM-VECTOR-SET!", Prim_sys_vec_set, 3, 3, 0)
-{ VECTOR_SET_PRIMITIVE (ARG_GC_VECTOR, GC_VECTOR_TOUCH); }
+ VECTOR_SET_PRIMITIVE (ARG_GC_VECTOR)
\f
-#define SUBVECTOR_TO_LIST_PRIMITIVE(arg_type, arg_touch) \
- fast Pointer vector; \
+#define SUBVECTOR_TO_LIST_PRIMITIVE(arg_type) \
+{ \
+ fast SCHEME_OBJECT vector; \
fast long start; \
fast long end; \
PRIMITIVE_HEADER (3); \
- \
- vector = (arg_type (1)); \
- arg_touch (vector); \
+ TOUCH_IN_PRIMITIVE ((arg_type (1)), vector); \
start = (arg_nonnegative_integer (2)); \
end = (arg_nonnegative_integer (3)); \
if (end > (VECTOR_LENGTH (vector))) \
error_bad_range_arg (3); \
if (start > end) \
error_bad_range_arg (2); \
- PRIMITIVE_RETURN (subvector_to_list (vector, start, end))
+ PRIMITIVE_RETURN (subvector_to_list (vector, start, end)); \
+}
-static Pointer
+static SCHEME_OBJECT
subvector_to_list (vector, start, end)
- Pointer vector;
+ SCHEME_OBJECT vector;
long start;
long end;
{
- Pointer result;
- fast Pointer *scan;
- fast Pointer *end_scan;
- fast Pointer *pair_scan;
-
+ SCHEME_OBJECT result;
+ fast SCHEME_OBJECT *scan;
+ fast SCHEME_OBJECT *end_scan;
+ fast SCHEME_OBJECT *pair_scan;
if (start == end)
- return (NIL);
+ return (EMPTY_LIST);
Primitive_GC_If_Needed (2 * (end - start));
- result = (Make_Pointer (TC_LIST, Free));
+ result = (MAKE_POINTER_OBJECT (TC_LIST, Free));
scan = (VECTOR_LOC (vector, start));
end_scan = (VECTOR_LOC (vector, (end - 1)));
pair_scan = Free;
while (scan < end_scan)
{
Free += 2;
- (*pair_scan++) = (Fetch (*scan++));
- (*pair_scan++) = (Make_Pointer (TC_LIST, Free));
+ (*pair_scan++) = (MEMORY_FETCH (*scan++));
+ (*pair_scan++) = (MAKE_POINTER_OBJECT (TC_LIST, Free));
}
Free += 2;
- (*pair_scan++) = (Fetch (*scan));
- (*pair_scan) = NIL;
+ (*pair_scan++) = (MEMORY_FETCH (*scan));
+ (*pair_scan) = EMPTY_LIST;
return (result);
}
DEFINE_PRIMITIVE ("SUBVECTOR->LIST", Prim_subvector_to_list, 3, 3, 0)
-{ SUBVECTOR_TO_LIST_PRIMITIVE (ARG_VECTOR, VECTOR_TOUCH); }
+ SUBVECTOR_TO_LIST_PRIMITIVE (ARG_VECTOR)
DEFINE_PRIMITIVE ("SYSTEM-SUBVECTOR-TO-LIST", Prim_sys_subvector_to_list, 3, 3, 0)
-{ SUBVECTOR_TO_LIST_PRIMITIVE (ARG_GC_VECTOR, GC_VECTOR_TOUCH); }
+ SUBVECTOR_TO_LIST_PRIMITIVE (ARG_GC_VECTOR)
\f
-static Pointer
+static SCHEME_OBJECT
list_to_vector (result_type, argument_number)
long argument_number;
long result_type;
{
- fast Pointer list;
+ fast SCHEME_OBJECT list;
fast long count;
- Pointer *result;
+ SCHEME_OBJECT *result;
list = (ARG_REF (argument_number));
- Touch_In_Primitive (list, list);
+ TOUCH_IN_PRIMITIVE (list, list);
count = 0;
result = (Free++);
while (PAIR_P (list))
{
Primitive_GC_If_Needed (0);
count += 1;
- (*Free++) = (Vector_Ref (list, CONS_CAR));
- Touch_In_Primitive ((Vector_Ref (list, CONS_CDR)), list);
+ (*Free++) = (PAIR_CAR (list));
+ TOUCH_IN_PRIMITIVE ((PAIR_CDR (list)), list);
}
- if (list != NIL)
+ if (list != EMPTY_LIST)
error_wrong_type_arg (argument_number);
- (*result) = (Make_Non_Pointer (TC_MANIFEST_VECTOR, count));
- return (Make_Pointer (result_type, result));
+ (*result) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, count));
+ return (MAKE_POINTER_OBJECT (result_type, result));
}
DEFINE_PRIMITIVE ("LIST->VECTOR", Prim_list_to_vector, 1, 1, 0)
\f
/* Primitive vector copy and fill */
-#define subvector_move_prefix() \
- Pointer vector1, vector2; \
+#define SUBVECTOR_MOVE_PREFIX() \
+ SCHEME_OBJECT vector1, vector2; \
long start1, end1, start2, end2; \
fast long length; \
- fast Pointer *scan1, *scan2; \
+ fast SCHEME_OBJECT *scan1, *scan2; \
PRIMITIVE_HEADER (5); \
- \
- vector1 = (ARG_VECTOR (1)); \
- VECTOR_TOUCH (vector1); \
+ TOUCH_IN_PRIMITIVE ((ARG_VECTOR (1)), vector1); \
start1 = (arg_nonnegative_integer (2)); \
end1 = (arg_nonnegative_integer (3)); \
- vector2 = (ARG_VECTOR (4)); \
- VECTOR_TOUCH (vector2); \
+ TOUCH_IN_PRIMITIVE ((ARG_VECTOR (4)), vector2); \
start2 = (arg_nonnegative_integer (5)); \
- \
if (end1 > (VECTOR_LENGTH (vector1))) \
error_bad_range_arg (3); \
if (start1 > end1) \
error_bad_range_arg (2); \
length = (end1 - start1); \
- \
end2 = (start2 + length); \
if (end2 > (VECTOR_LENGTH (vector2))) \
error_bad_range_arg (5); \
- \
- if (Is_Pure (Get_Pointer (vector2))) \
- Primitive_Error (ERR_WRITE_INTO_PURE_SPACE)
+ if (ADDRESS_PURE_P (OBJECT_ADDRESS (vector2))) \
+ signal_error_from_primitive (ERR_WRITE_INTO_PURE_SPACE)
DEFINE_PRIMITIVE ("SUBVECTOR-MOVE-RIGHT!", Prim_subvector_move_right, 5, 5, 0)
{
- subvector_move_prefix ();
-
+ SUBVECTOR_MOVE_PREFIX ();
scan1 = (VECTOR_LOC (vector1, end1));
scan2 = (VECTOR_LOC (vector2, end2));
while ((length--) > 0)
(*--scan2) = (*--scan1);
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("SUBVECTOR-MOVE-LEFT!", Prim_subvector_move_left, 5, 5, 0)
{
- subvector_move_prefix ();
-
+ SUBVECTOR_MOVE_PREFIX ();
scan1 = (VECTOR_LOC (vector1, start1));
scan2 = (VECTOR_LOC (vector2, start2));
while ((length--) > 0)
(*scan2++) = (*scan1++);
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-\f
+
DEFINE_PRIMITIVE ("SUBVECTOR-FILL!", Prim_vector_fill, 4, 4, 0)
{
- Pointer vector;
+ SCHEME_OBJECT vector;
long start, end;
- fast Pointer fill_value;
- fast Pointer *scan;
+ fast SCHEME_OBJECT fill_value;
+ fast SCHEME_OBJECT *scan;
fast long length;
PRIMITIVE_HEADER (4);
-
- vector = (ARG_VECTOR (1));
- VECTOR_TOUCH (1);
+ TOUCH_IN_PRIMITIVE ((ARG_VECTOR (1)), vector);
start = (arg_nonnegative_integer (2));
end = (arg_nonnegative_integer (3));
fill_value = (ARG_REF (4));
-
if (end > (VECTOR_LENGTH (vector)))
error_bad_range_arg (3);
if (start > end)
error_bad_range_arg (2);
length = (end - start);
-
- Side_Effect_Impurify (vector, fill_value);
+ SIDE_EFFECT_IMPURIFY (vector, fill_value);
scan = (VECTOR_LOC (vector, start));
while ((length--) > 0)
(*scan++) = fill_value;
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 10.88 1989/08/28 18:29:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.1 1989/09/20 23:03:51 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
/* Microcode release version */
#ifndef VERSION
-#define VERSION 10
+#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 88
+#define SUBVERSION 1
#endif
#ifndef UCODE_TABLES_FILENAME
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/winder.h,v 9.24 1989/09/20 23:13:09 cph Rel $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/winder.h,v 9.23 1988/08/15 20:58:36 cph Rel $
+/* Header file for dynamic winder. */
+\f
+#define STATE_SPACE_P(object) \
+ ((VECTOR_P (object)) && \
+ ((VECTOR_LENGTH (object)) == STATE_SPACE_LENGTH) && \
+ ((MEMORY_REF ((object), STATE_SPACE_TAG)) == \
+ (Get_Fixed_Obj_Slot (State_Space_Tag))))
+
+#define STATE_SPACE_TAG 1
+#define STATE_SPACE_NEAREST_POINT 2
+#define STATE_SPACE_LENGTH 2
+
+#define STATE_POINT_P(object) \
+ ((VECTOR_P (object)) && \
+ ((VECTOR_LENGTH (object)) == STATE_POINT_LENGTH) && \
+ ((MEMORY_REF ((object), STATE_POINT_TAG)) == \
+ (Get_Fixed_Obj_Slot (State_Point_Tag))))
+
+#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_LENGTH 5
- Header file for dynamic winder.
-*/
-\f
#ifdef butterfly
-#define guarantee_state_point() \
-{ \
- if (Current_State_Point == NIL) \
- Current_State_Point = Get_Fixed_Obj_Slot( State_Space_Root); \
+#define guarantee_state_point() \
+{ \
+ if (Current_State_Point == SHARP_F) \
+ Current_State_Point = (Get_Fixed_Obj_Slot (State_Space_Root)); \
}
#else
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/wsize.c,v 9.27 1989/08/28 18:28:11 cph Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/wsize.c,v 9.28 1989/09/20 23:05:21 cph Exp $ */
\f
#include <stdio.h>
#include <math.h>
#include <errno.h>
#ifndef TYPE_CODE_LENGTH
-/* This MUST match object.h */
+/* This MUST match object.h */
#define TYPE_CODE_LENGTH 8
#endif
if (temp == NULL)
{
confused = true;
- printf("/%c CONFUSION: Could not allocate %d Pointers. %c/\n",
+ printf("/%c CONFUSION: Could not allocate %d Objects. %c/\n",
'*', MEM_SIZE, '*');
printf("/%c Will not assume that the Heap is in Low Memory. %c/\n",
'*', '*');
else
printf("/%c Heap is not in Low Memory. %c/\n", '*', '*');
}
-
+
to_be_shifted = -1;
if ((to_be_shifted >> 1) != to_be_shifted)
{
double_size = (char_size*sizeof(double));
- printf("#define CHAR_SIZE %d\n",
+ printf("#define CHAR_BIT %d\n",
char_size);
printf("#define USHORT_SIZE %d\n",
printf("#define DBFLT_SIZE %d\n\n",
double_size);
-
+
if (sizeof(struct double_probe) == (sizeof(double) + sizeof(long)))
{
printf("/%c Flonums have no special alignment constraints. %c/\n",
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11.h,v 1.3 1989/07/26 04:14:21 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11.h,v 1.4 1989/09/20 23:13:12 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
extern void x_set_mouse_colors ();
extern void x_default_attributes ();
extern struct xwindow * x_make_window ();
-extern Pointer x_window_to_object ();
+extern SCHEME_OBJECT x_window_to_object ();
extern struct xwindow * x_window_to_xw ();
extern Display * x_close_window ();
extern void x_close_display ();
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11base.c,v 1.6 1989/07/26 04:14:06 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11base.c,v 1.7 1989/09/20 23:13:16 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
int arg; \
struct allocation_table * table; \
{ \
- fast Pointer object = (ARG_REF (arg)); \
+ fast SCHEME_OBJECT object = (ARG_REF (arg)); \
\
if (! (FIXNUM_P (object))) \
error_wrong_type_arg (arg); \
{ \
fast int length = (table -> length); \
fast char ** items = (table -> items); \
- fast int index = (UNSIGNED_FIXNUM_VALUE (object)); \
+ fast int index = (UNSIGNED_FIXNUM_TO_LONG (object)); \
if ((index < length) && ((items [index]) != ((char *) 0))) \
return (result); \
} \
return (xw);
}
-Pointer
+SCHEME_OBJECT
x_window_to_object (xw)
struct xwindow * xw;
{
return
- (MAKE_UNSIGNED_FIXNUM
+ (LONG_TO_UNSIGNED_FIXNUM
(x_allocate_table_index ((& x_window_table), ((char *) xw))));
}
\f
XEvent * event;
{
Display * display = (XW_DISPLAY (xw));
- Window window = (XW_WINDOW (xw));
struct xwindow * exw;
while (1)
xw = (WINDOW_ARG (1));
old = (XW_EVENT_FLAGS (xw));
(XW_EVENT_FLAGS (xw)) = 0;
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (old));
+ PRIMITIVE_RETURN (long_to_integer (old));
}
\f
DEFINE_PRIMITIVE ("X-OPEN-DISPLAY", Prim_x_open_display, 1, 1, 0)
{
Display * display;
- int index;
PRIMITIVE_HEADER (1);
display =
XSetIOErrorHandler (x_io_error_handler);
PRIMITIVE_RETURN
- (MAKE_UNSIGNED_FIXNUM
+ (LONG_TO_UNSIGNED_FIXNUM
(x_allocate_table_index ((& x_display_table), ((char *) display))));
}
DEFINE_PRIMITIVE ("X-CLOSE-ALL-DISPLAYS", Prim_x_close_all_displays, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
+
{
Display ** items = ((Display **) (x_display_table . items));
int length = (x_display_table . length);
DEFINE_PRIMITIVE ("X-CLOSE-WINDOW", Prim_x_close_window, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
XFlush (x_close_window (x_allocation_index_arg (1, (& x_window_table))));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("X-WINDOW-X-SIZE", Prim_x_window_x_size, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (XW_X_SIZE (WINDOW_ARG (1))));
+ PRIMITIVE_RETURN (long_to_integer (XW_X_SIZE (WINDOW_ARG (1))));
}
DEFINE_PRIMITIVE ("X-WINDOW-Y-SIZE", Prim_x_window_y_size, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (XW_Y_SIZE (WINDOW_ARG (1))));
+ PRIMITIVE_RETURN (long_to_integer (XW_Y_SIZE (WINDOW_ARG (1))));
}
\f
DEFINE_PRIMITIVE ("X-WINDOW-MAP", Prim_x_window_map, 1, 1, 0)
PRIMITIVE_RETURN
((result == ((char *) 0))
? SHARP_F
- : (C_String_To_Scheme_String (result)));
+ : (char_pointer_to_string (result)));
}
\f
DEFINE_PRIMITIVE ("X-WINDOW-SET-FOREGROUND-COLOR", Prim_x_window_set_foreground_color, 2, 2, 0)
display = (XW_DISPLAY (xw));
screen_number = (DefaultScreen (display));
XMoveWindow
- ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (arg_fixnum (2)), (arg_fixnum (3)));
+ ((XW_DISPLAY (xw)),
+ (XW_WINDOW (xw)),
+ (arg_integer (2)),
+ (arg_integer (3)));
PRIMITIVE_RETURN (UNSPECIFIC);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11graph.c,v 1.3 1989/06/27 10:10:01 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11graph.c,v 1.4 1989/09/20 23:13:22 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
-#include "string.h"
#include "x11.h"
#define RESOURCE_NAME "scheme-graphics"
#define XW_X_CURSOR(xw) ((XW_EXTRA (xw)) -> x_cursor)
#define XW_Y_CURSOR(xw) ((XW_EXTRA (xw)) -> y_cursor)
-#define FLONUM_ARG(argno, target) \
-{ \
- fast Pointer argument; \
- fast long fixnum_value; \
- \
- argument = (ARG_REF (argno)); \
- switch (OBJECT_TYPE (argument)) \
- { \
- case TC_FIXNUM: \
- FIXNUM_VALUE (argument, fixnum_value); \
- target = ((float) fixnum_value); \
- break; \
- \
- case TC_BIG_FLONUM: \
- target = ((float) (Get_Float (argument))); \
- break; \
- \
- default: \
- error_wrong_type_arg (argno); \
- } \
-}
-
#define ROUND_FLOAT(flonum) \
((int) (((flonum) >= 0.0) ? ((flonum) + 0.5) : ((flonum) - 0.5)))
int arg;
struct xwindow * xw;
{
- float virtual_device_x;
- float device_x;
-
- FLONUM_ARG (arg, virtual_device_x);
- device_x = ((XW_X_SLOPE (xw)) * (virtual_device_x - (XW_X_LEFT (xw))));
+ float virtual_device_x = (arg_real_number (arg));
+ float device_x = ((XW_X_SLOPE (xw)) * (virtual_device_x - (XW_X_LEFT (xw))));
return (ROUND_FLOAT (device_x));
}
int arg;
struct xwindow * xw;
{
- float virtual_device_y;
- float device_y;
-
- FLONUM_ARG (arg, virtual_device_y);
- device_y = ((XW_Y_SLOPE (xw)) * (virtual_device_y - (XW_Y_BOTTOM (xw))));
+ float virtual_device_y = (arg_real_number (arg));
+ float device_y =
+ ((XW_Y_SLOPE (xw)) * (virtual_device_y - (XW_Y_BOTTOM (xw))));
return (((XW_Y_SIZE (xw)) - 1) + (ROUND_FLOAT (device_y)));
}
\f
XRectangle rectangles [1];
Display * display = (XW_DISPLAY (xw));
int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
-
if (x_left > x_right)
{
int x = x_left;
{
/* Note that the expression ((XW_c_SIZE (xw)) - 1) guarantees that
both limits of the device coordinates will be inside the window. */
-
(XW_X_SLOPE (xw)) =
(((float) ((XW_X_SIZE (xw)) - 1)) /
((XW_X_RIGHT (xw)) - (XW_X_LEFT (xw))));
"(X-GRAPHICS-SET-VDC-EXTENT WINDOW X-MIN Y-MIN X-MAX Y-MAX)\n\
Set the virtual device coordinates to the given values.")
{
- struct xwindow * xw;
- float x_left;
- float y_bottom;
- float x_right;
- float y_top;
PRIMITIVE_HEADER (5);
-
- xw = (WINDOW_ARG (1));
- FLONUM_ARG (2, x_left);
- FLONUM_ARG (3, y_bottom);
- FLONUM_ARG (4, x_right);
- FLONUM_ARG (5, y_top);
- process_events (xw);
- (XW_X_LEFT (xw)) = x_left;
- (XW_Y_BOTTOM (xw)) = y_bottom;
- (XW_X_RIGHT (xw)) = x_right;
- (XW_Y_TOP (xw)) = y_top;
- reset_virtual_device_coordinates (xw);
+ {
+ struct xwindow * xw = (WINDOW_ARG (1));
+ float x_left = (arg_real_number (2));
+ float y_bottom = (arg_real_number (3));
+ float x_right = (arg_real_number (4));
+ float y_top = (arg_real_number (5));
+ process_events (xw);
+ (XW_X_LEFT (xw)) = x_left;
+ (XW_Y_BOTTOM (xw)) = y_bottom;
+ (XW_X_RIGHT (xw)) = x_right;
+ (XW_Y_TOP (xw)) = y_top;
+ reset_virtual_device_coordinates (xw);
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("X-GRAPHICS-VDC-EXTENT", Prim_x_graphics_vdc_extent, 1, 1, 0)
{
struct xwindow * xw;
- Pointer result;
+ SCHEME_OBJECT result;
PRIMITIVE_HEADER (5);
-
xw = (WINDOW_ARG (1));
process_events (xw);
result = (allocate_marked_vector (TC_VECTOR, 4, true));
- User_Vector_Set (result, 0, (Allocate_Float ((double) (XW_X_LEFT (xw)))));
- User_Vector_Set (result, 1, (Allocate_Float ((double) (XW_Y_BOTTOM (xw)))));
- User_Vector_Set (result, 2, (Allocate_Float ((double) (XW_X_RIGHT (xw)))));
- User_Vector_Set (result, 3, (Allocate_Float ((double) (XW_Y_TOP (xw)))));
+ VECTOR_SET (result, 0, (double_to_flonum ((double) (XW_X_LEFT (xw)))));
+ VECTOR_SET (result, 1, (double_to_flonum ((double) (XW_Y_BOTTOM (xw)))));
+ VECTOR_SET (result, 2, (double_to_flonum ((double) (XW_X_RIGHT (xw)))));
+ VECTOR_SET (result, 3, (double_to_flonum ((double) (XW_Y_TOP (xw)))));
PRIMITIVE_RETURN (result);
}
{
struct xwindow * xw;
PRIMITIVE_HEADER (1);
-
xw = (WINDOW_ARG (1));
process_events (xw);
reset_clip_rectangle (xw);
int x_right;
int y_top;
PRIMITIVE_HEADER (5);
-
xw = (WINDOW_ARG (1));
process_events (xw);
x_left = (arg_x_coordinate (2, xw));
{
int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
XSizeHints size_hints;
-
(size_hints . flags) = (PResizeInc | PMinSize | flags);
(size_hints . x) = x;
(size_hints . y) = y;
#define MAKE_GC(gc, fore, back) \
{ \
XGCValues gcv; \
- \
(gcv . font) = fid; \
(gcv . foreground) = (fore); \
(gcv . background) = (back); \
long flags;
struct xwindow * xw;
PRIMITIVE_HEADER (3);
-
display = (DISPLAY_ARG (1));
screen_number = (DefaultScreen (display));
name = "scheme-graphics";
x_size = 512;
y_size = 384;
{
- char * geometry;
- int result;
-
- geometry =
+ char * geometry =
(((ARG_REF (2)) == SHARP_F)
? (x_get_default
(display, RESOURCE_NAME, "geometry", "Geometry", ((char *) 0)))
: (STRING_ARG (2)));
- result =
+ int result =
(XGeometry (display, screen_number, geometry,
DEFAULT_GEOMETRY, border_width,
1, 1, extra, extra,
flags |=
(((result & WidthValue) && (result & HeightValue)) ? USSize : PSize);
}
-
/* Open the window with the given arguments. */
{
XSetWindowAttributes wattributes;
-
(wattributes . background_pixel) = (attributes . background_pixel);
(wattributes . border_pixel) = (attributes . border_pixel);
(wattributes . backing_store) = Always;
}
if (window == ((Window) 0))
error_external_return ();
-
xw =
(x_make_window
(display,
reset_virtual_device_coordinates (xw);
(XW_X_CURSOR (xw)) = 0;
(XW_Y_CURSOR (xw)) = 0;
-
XSelectInput (display, window, StructureNotifyMask);
wm_set_size_hint (xw, flags, x_pos, y_pos);
XStoreName (display, window, name);
XSetIconName (display, window, name);
-
if ((ARG_REF (3)) == SHARP_F)
{
(XW_VISIBLE_P (xw)) = 1;
XMapWindow (display, window);
XFlush (display);
}
-
PRIMITIVE_RETURN (x_window_to_object (xw));
}
\f
Draw a line from the start coordinates to the end coordinates.\n\
Subsequently move the graphics cursor to the end coordinates.")
{
- struct xwindow * xw;
- int new_x_cursor;
- int new_y_cursor;
- int internal_border_width;
PRIMITIVE_HEADER (5);
-
- xw = (WINDOW_ARG (1));
- new_x_cursor = (arg_x_coordinate (4, xw));
- new_y_cursor = (arg_y_coordinate (5, xw));
- internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
- XDrawLine
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (internal_border_width + (arg_x_coordinate (2, xw))),
- (internal_border_width + (arg_y_coordinate (3, xw))),
- (internal_border_width + new_x_cursor),
- (internal_border_width + new_y_cursor));
- (XW_X_CURSOR (xw)) = new_x_cursor;
- (XW_Y_CURSOR (xw)) = new_y_cursor;
+ {
+ struct xwindow * xw = (WINDOW_ARG (1));
+ int new_x_cursor = (arg_x_coordinate (4, xw));
+ int new_y_cursor = (arg_y_coordinate (5, xw));
+ int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
+ XDrawLine
+ ((XW_DISPLAY (xw)),
+ (XW_WINDOW (xw)),
+ (XW_NORMAL_GC (xw)),
+ (internal_border_width + (arg_x_coordinate (2, xw))),
+ (internal_border_width + (arg_y_coordinate (3, xw))),
+ (internal_border_width + new_x_cursor),
+ (internal_border_width + new_y_cursor));
+ (XW_X_CURSOR (xw)) = new_x_cursor;
+ (XW_Y_CURSOR (xw)) = new_y_cursor;
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
{
struct xwindow * xw;
PRIMITIVE_HEADER (3);
-
xw = (WINDOW_ARG (1));
(XW_X_CURSOR (xw)) = (arg_x_coordinate (2, xw));
(XW_Y_CURSOR (xw)) = (arg_y_coordinate (3, xw));
Draw a line from the graphics cursor to the given coordinates.\n\
Subsequently move the graphics cursor to those coordinates.")
{
- struct xwindow * xw;
- int new_x_cursor;
- int new_y_cursor;
- int internal_border_width;
PRIMITIVE_HEADER (3);
-
- xw = (WINDOW_ARG (1));
- new_x_cursor = (arg_x_coordinate (2, xw));
- new_y_cursor = (arg_y_coordinate (3, xw));
- internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
- XDrawLine
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (internal_border_width + (XW_X_CURSOR (xw))),
- (internal_border_width + (XW_Y_CURSOR (xw))),
- (internal_border_width + new_x_cursor),
- (internal_border_width + new_y_cursor));
- (XW_X_CURSOR (xw)) = new_x_cursor;
- (XW_Y_CURSOR (xw)) = new_y_cursor;
+ {
+ struct xwindow * xw = (WINDOW_ARG (1));
+ int new_x_cursor = (arg_x_coordinate (2, xw));
+ int new_y_cursor = (arg_y_coordinate (3, xw));
+ int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
+ XDrawLine
+ ((XW_DISPLAY (xw)),
+ (XW_WINDOW (xw)),
+ (XW_NORMAL_GC (xw)),
+ (internal_border_width + (XW_X_CURSOR (xw))),
+ (internal_border_width + (XW_Y_CURSOR (xw))),
+ (internal_border_width + new_x_cursor),
+ (internal_border_width + new_y_cursor));
+ (XW_X_CURSOR (xw)) = new_x_cursor;
+ (XW_Y_CURSOR (xw)) = new_y_cursor;
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
Draw one point at the given coordinates.\n\
Subsequently move the graphics cursor to those coordinates.")
{
- struct xwindow * xw;
- int internal_border_width;
PRIMITIVE_HEADER (3);
-
- xw = (WINDOW_ARG (1));
- internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
- XDrawPoint
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (internal_border_width + (arg_x_coordinate (2, xw))),
- (internal_border_width + (arg_y_coordinate (3, xw))));
+ {
+ struct xwindow * xw = (WINDOW_ARG (1));
+ int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
+ XDrawPoint
+ ((XW_DISPLAY (xw)),
+ (XW_WINDOW (xw)),
+ (XW_NORMAL_GC (xw)),
+ (internal_border_width + (arg_x_coordinate (2, xw))),
+ (internal_border_width + (arg_y_coordinate (3, xw))));
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
"(X-GRAPHICS-DRAW-STRING WINDOW X Y STRING)\n\
Draw characters in the current font at the given coordinates.")
{
- struct xwindow * xw;
- int internal_border_width;
- char * s;
PRIMITIVE_HEADER (4);
-
- xw = (WINDOW_ARG (1));
- internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
- s = (STRING_ARG (4));
- XDrawString
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (internal_border_width + (arg_x_coordinate (2, xw))),
- (internal_border_width + (arg_y_coordinate (3, xw))),
- s,
- (string_length (ARG_REF (4))));
+ {
+ struct xwindow * xw = (WINDOW_ARG (1));
+ int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
+ char * s = (STRING_ARG (4));
+ XDrawString
+ ((XW_DISPLAY (xw)),
+ (XW_WINDOW (xw)),
+ (XW_NORMAL_GC (xw)),
+ (internal_border_width + (arg_x_coordinate (2, xw))),
+ (internal_border_width + (arg_y_coordinate (3, xw))),
+ s,
+ (STRING_LENGTH (ARG_REF (4))));
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("X-GRAPHICS-SET-FUNCTION", Prim_x_graphics_set_function, 2, 2, 0)
{
- struct xwindow * xw;
- Display * display;
- int function;
PRIMITIVE_HEADER (2);
-
- xw = (WINDOW_ARG (1));
- display = (XW_DISPLAY (xw));
- function = (arg_index_integer (2, 16));
- XSetFunction (display, (XW_NORMAL_GC (xw)), function);
- XSetFunction (display, (XW_REVERSE_GC (xw)), function);
+ {
+ struct xwindow * xw = (WINDOW_ARG (1));
+ Display * display = (XW_DISPLAY (xw));
+ int function = (arg_index_integer (2, 16));
+ XSetFunction (display, (XW_NORMAL_GC (xw)), function);
+ XSetFunction (display, (XW_REVERSE_GC (xw)), function);
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
DEFINE_PRIMITIVE ("X-GRAPHICS-SET-FILL-STYLE", Prim_x_graphics_set_fill_style, 2, 2, 0)
{
- struct xwindow * xw;
- Display * display;
- int fill_style;
PRIMITIVE_HEADER (2);
-
- xw = (WINDOW_ARG (1));
- display = (XW_DISPLAY (xw));
- fill_style = (arg_index_integer (2, 4));
- XSetFillStyle (display, (XW_NORMAL_GC (xw)), fill_style);
- XSetFillStyle (display, (XW_REVERSE_GC (xw)), fill_style);
+ {
+ struct xwindow * xw = (WINDOW_ARG (1));
+ Display * display = (XW_DISPLAY (xw));
+ int fill_style = (arg_index_integer (2, 4));
+ XSetFillStyle (display, (XW_NORMAL_GC (xw)), fill_style);
+ XSetFillStyle (display, (XW_REVERSE_GC (xw)), fill_style);
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("X-GRAPHICS-SET-LINE-STYLE", Prim_x_graphics_set_line_style, 2, 2, 0)
{
- struct xwindow * xw;
- Display * display;
- int style;
PRIMITIVE_HEADER (2);
-
- xw = (WINDOW_ARG (1));
- display = (XW_DISPLAY (xw));
- style = (arg_index_integer (2, 3));
- XSetLineAttributes
- (display, (XW_NORMAL_GC (xw)), 0, style, CapButt, JoinMiter);
- XSetLineAttributes
- (display, (XW_REVERSE_GC (xw)), 0, style, CapButt, JoinMiter);
+ {
+ struct xwindow * xw = (WINDOW_ARG (1));
+ Display * display = (XW_DISPLAY (xw));
+ int style = (arg_index_integer (2, 3));
+ XSetLineAttributes
+ (display, (XW_NORMAL_GC (xw)), 0, style, CapButt, JoinMiter);
+ XSetLineAttributes
+ (display, (XW_REVERSE_GC (xw)), 0, style, CapButt, JoinMiter);
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("X-GRAPHICS-SET-DASHES", Prim_x_graphics_set_dashes, 3, 3, 0)
{
- struct xwindow * xw;
- Display * display;
- int dash_offset;
- char * dash_list;
- int dash_list_length;
PRIMITIVE_HEADER (3);
-
- xw = (WINDOW_ARG (1));
- display = (XW_DISPLAY (xw));
- dash_list = (STRING_ARG (3));
- dash_list_length = (string_length (ARG_REF (3)));
- dash_offset = (arg_index_integer (2, dash_list_length));
- XSetDashes
- (display, (XW_NORMAL_GC (xw)), dash_offset, dash_list, dash_list_length);
- XSetDashes
- (display, (XW_REVERSE_GC (xw)), dash_offset, dash_list, dash_list_length);
+ {
+ struct xwindow * xw = (WINDOW_ARG (1));
+ Display * display = (XW_DISPLAY (xw));
+ char * dash_list = (STRING_ARG (3));
+ int dash_list_length = (STRING_LENGTH (ARG_REF (3)));
+ int dash_offset = (arg_index_integer (2, dash_list_length));
+ XSetDashes
+ (display, (XW_NORMAL_GC (xw)), dash_offset, dash_list, dash_list_length);
+ XSetDashes
+ (display, (XW_REVERSE_GC (xw)), dash_offset, dash_list,
+ dash_list_length);
+ }
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("X-GRAPHICS-PROCESS-EVENTS", Prim_x_graphics_process_events, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
process_events (WINDOW_ARG (1));
PRIMITIVE_RETURN (UNSPECIFIC);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11term.c,v 1.5 1989/07/01 11:34:16 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11term.c,v 1.6 1989/09/20 23:13:26 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
-#include "string.h"
#include "x11.h"
#define RESOURCE_NAME "edwin"
int y_start = ((y - border) / fheight);
int x_end = ((((x + width) - border) + (fwidth - 1)) / fwidth);
int y_end = ((((y + height) - border) + (fheight - 1)) / fheight);
- int x_width = (x_end - x_start);
- int xi, yi;
+ int yi;
if (x_end > (XW_X_CSIZE (xw))) x_end = (XW_X_CSIZE (xw));
if (y_end > (XW_Y_CSIZE (xw))) y_end = (XW_Y_CSIZE (xw));
? (x_get_default
(display, RESOURCE_NAME, "geometry", "Geometry", ((char *) 0)))
: (STRING_ARG (2)));
- result =
+ result =
(XGeometry (display, screen_number, geometry,
DEFAULT_GEOMETRY, border_width,
fwidth, fheight, extra, extra,
DEFINE_PRIMITIVE ("XTERM-X-SIZE", Prim_xterm_x_size, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (XW_X_CSIZE (WINDOW_ARG (1))));
+ PRIMITIVE_RETURN (long_to_integer (XW_X_CSIZE (WINDOW_ARG (1))));
}
DEFINE_PRIMITIVE ("XTERM-Y-SIZE", Prim_xterm_y_size, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (XW_Y_CSIZE (WINDOW_ARG (1))));
+ PRIMITIVE_RETURN (long_to_integer (XW_Y_CSIZE (WINDOW_ARG (1))));
}
DEFINE_PRIMITIVE ("XTERM-SET-SIZE", Prim_xterm_set_size, 3, 3, 0)
int extra;
XFontStruct * font;
PRIMITIVE_HEADER (3);
-
xw = (WINDOW_ARG (1));
extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
font = (XW_FONT (xw));
DEFINE_PRIMITIVE ("XTERM-BUTTON", Prim_xterm_button, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (XW_BUTTON (WINDOW_ARG (1))));
+ PRIMITIVE_RETURN (long_to_integer (XW_BUTTON (WINDOW_ARG (1))));
}
DEFINE_PRIMITIVE ("XTERM-POINTER-X", Prim_xterm_pointer_x, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN
- (C_Integer_To_Scheme_Integer (XW_POINTER_X (WINDOW_ARG (1))));
+ PRIMITIVE_RETURN (long_to_integer (XW_POINTER_X (WINDOW_ARG (1))));
}
DEFINE_PRIMITIVE ("XTERM-POINTER-Y", Prim_xterm_pointer_y, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
-
- PRIMITIVE_RETURN
- (C_Integer_To_Scheme_Integer (XW_POINTER_Y (WINDOW_ARG (1))));
+ PRIMITIVE_RETURN (long_to_integer (XW_POINTER_Y (WINDOW_ARG (1))));
}
\f
DEFINE_PRIMITIVE ("XTERM-WRITE-CURSOR!", Prim_xterm_write_cursor, 3, 3, 0)
{
struct xwindow * xw;
int x, y;
- Pointer string;
+ SCHEME_OBJECT string;
int start, end;
int hl;
int length;
- char * string_scan;
- char * string_end;
+ unsigned char * string_scan;
+ unsigned char * string_end;
int index;
char * char_start;
char * char_scan;
char * hl_scan;
PRIMITIVE_HEADER (7);
-
xw = (WINDOW_ARG (1));
x = (arg_index_integer (2, (XW_X_CSIZE (xw))));
y = (arg_index_integer (3, (XW_Y_CSIZE (xw))));
CHECK_ARG (4, STRING_P);
string = (ARG_REF (4));
- end = (arg_index_integer (6, ((string_length (string)) + 1)));
+ end = (arg_index_integer (6, ((STRING_LENGTH (string)) + 1)));
start = (arg_index_integer (5, (end + 1)));
hl = (HL_ARG (7));
length = (end - start);
if ((x + length) > (XW_X_CSIZE (xw)))
error_bad_range_arg (2);
- string_scan = (string_pointer (string, start));
- string_end = (string_pointer (string, end));
+ string_scan = (STRING_LOC (string, start));
+ string_end = (STRING_LOC (string, end));
index = (XTERM_CHAR_INDEX (xw, x, y));
char_start = (XTERM_CHAR_LOC (xw, index));
char_scan = char_start;
interval = (time_limit - (OS_real_time_clock ()));
if (interval <= 0)
PRIMITIVE_RETURN (SHARP_F);
- PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (interval));
+ PRIMITIVE_RETURN (long_to_integer (interval));
}
\f
static int
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/xdebug.c,v 9.26 1989/09/20 23:13:32 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/xdebug.c,v 9.25 1989/06/16 09:40:14 cph Rel $
- *
- * This file contains primitives to debug the memory management in the
- * Scheme system.
- *
- */
+/* This file contains primitives to debug memory management. */
#include "scheme.h"
#include "prims.h"
#define ADDRESS_EQ 2
#define DATUM_EQ 3
-static Pointer *
+static SCHEME_OBJECT *
Find_Occurrence(From, To, What, Mode)
- fast Pointer *From, *To;
- Pointer What;
+ fast SCHEME_OBJECT *From, *To;
+ SCHEME_OBJECT What;
int Mode;
{
- fast Pointer Obj;
+ fast SCHEME_OBJECT Obj;
switch (Mode)
{ default:
Obj = What;
for (; From < To; From++)
{
- if (OBJECT_TYPE(*From) == TC_MANIFEST_NM_VECTOR)
+ if (OBJECT_TYPE (*From) == TC_MANIFEST_NM_VECTOR)
{
- From += OBJECT_DATUM(*From);
+ From += OBJECT_DATUM (*From);
}
else if (*From == Obj)
{
case ADDRESS_EQ:
{
- Obj = OBJECT_DATUM(What);
+ Obj = OBJECT_DATUM (What);
for (; From < To; From++)
{
- if (OBJECT_TYPE(*From) == TC_MANIFEST_NM_VECTOR)
+ if (OBJECT_TYPE (*From) == TC_MANIFEST_NM_VECTOR)
{
- From += OBJECT_DATUM(*From);
+ From += OBJECT_DATUM (*From);
}
- else if ((OBJECT_DATUM(*From) == Obj) &&
+ else if ((OBJECT_DATUM (*From) == Obj) &&
(!(GC_Type_Non_Pointer(*From))))
{
return From;
}
case DATUM_EQ:
{
- Obj = OBJECT_DATUM(What);
+ Obj = OBJECT_DATUM (What);
for (; From < To; From++)
{
- if (OBJECT_TYPE(*From) == TC_MANIFEST_NM_VECTOR)
+ if (OBJECT_TYPE (*From) == TC_MANIFEST_NM_VECTOR)
{
- From += OBJECT_DATUM(*From);
+ From += OBJECT_DATUM (*From);
}
- else if (OBJECT_DATUM(*From) == Obj)
+ else if (OBJECT_DATUM (*From) == Obj)
{
return From;
}
#define PRINT_P 1
#define STORE_P 2
-static long
+static long
Find_In_Area(Name, From, To, Obj, Mode, print_p, store_p)
char *Name;
- Pointer *From, *To, Obj;
+ SCHEME_OBJECT *From, *To, Obj;
int Mode;
Boolean print_p, store_p;
{
- fast Pointer *Where;
+ fast SCHEME_OBJECT *Where;
fast long occurrences = 0;
if (print_p)
((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);
- }
+ *Free++ = (LONG_TO_UNSIGNED_FIXNUM (Where));
}
return occurrences;
}
\f
-Pointer
+SCHEME_OBJECT
Find_Who_Points(Obj, Find_Mode, Collect_Mode)
- Pointer Obj;
+ SCHEME_OBJECT Obj;
int Find_Mode, Collect_Mode;
{
long n = 0;
- Pointer *Saved_Free = Free;
+ SCHEME_OBJECT *Saved_Free = Free;
Boolean print_p = (Collect_Mode & PRINT_P);
Boolean store_p = (Collect_Mode & STORE_P);
}
if (store_p)
{
- *Saved_Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, n);
- return Make_Pointer(TC_VECTOR, Saved_Free);
+ *Saved_Free = MAKE_OBJECT (TC_MANIFEST_VECTOR, n);
+ return MAKE_POINTER_OBJECT (TC_VECTOR, Saved_Free);
}
else
{
- return Make_Non_Pointer(TC_FIXNUM, n);
+ return (LONG_TO_FIXNUM (n));
}
}
\f
Print_Memory(Where, How_Many)
- Pointer *Where;
+ SCHEME_OBJECT *Where;
long How_Many;
{
- fast Pointer *End = &Where[How_Many];
+ fast SCHEME_OBJECT *End = &Where[How_Many];
#ifndef b32
printf("\n*** Memory from 0x%x to 0x%x (excluded) ***\n", Where, End);
DEFINE_PRIMITIVE ("DEBUG-SHOW-ENV", Prim_debug_show_env, 1, 1, 0)
{
- Pointer environment;
+ SCHEME_OBJECT environment;
PRIMITIVE_HEADER (1);
environment = (ARG_REF (1));
CHECK_ARG (1, STRING_P);
{
- fast Pointer symbol = (find_symbol (ARG_REF (1)));
+ fast SCHEME_OBJECT symbol = (find_symbol (ARG_REF (1)));
if (symbol == SHARP_F)
printf ("\nNot interned.\n");
else
{
printf ("\nInterned Symbol: 0x%x", symbol);
- Print_Expression (Vector_Ref (symbol, SYMBOL_GLOBAL_VALUE), "Value");
+ Print_Expression (MEMORY_REF (symbol, SYMBOL_GLOBAL_VALUE), "Value");
printf ("\n");
}
}
DEFINE_PRIMITIVE ("DEBUG-PRINT-MEMORY", Prim_debug_print_memory, 2, 2, 0)
{
- Pointer object;
+ SCHEME_OBJECT object;
PRIMITIVE_HEADER (2);
object = (ARG_REF (1));
Print_Memory
(((GC_Type_Non_Pointer (object))
- ? ((Pointer *) (OBJECT_DATUM (object)))
- : (Get_Pointer (object))),
+ ? ((SCHEME_OBJECT *) (OBJECT_DATUM (object)))
+ : (OBJECT_ADDRESS (object))),
(OBJECT_DATUM (ARG_REF (2))));
PRIMITIVE_RETURN (UNSPECIFIC);
}
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.40 1989/09/20 23:04:28 cph Exp $
+
Copyright (c) 1987, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.39 1989/07/25 08:46:06 cph Rel $
- *
- * This File contains the code to translate internal format binary
- * files to portable format.
- *
- */
+/* This File contains the code to translate internal format binary
+ files to portable format. */
\f
/* IO definitions */
#include "psbmap.h"
#include "trap.h"
+#include "limits.h"
#define internal_file input_file
#define portable_file output_file
{
extern int fread();
- return (fread(To_Where, sizeof(Pointer), Count, internal_file));
+ return (fread(To_Where, sizeof(SCHEME_OBJECT), Count, internal_file));
}
#define INHIBIT_FASL_VERSION_CHECK
#define TC_PRIMITIVE_EXTERNAL 0x10
#define STRING_LENGTH_TO_LONG(value) \
-((long) (upgrade_lengths_p ? Get_Integer(value) : (value)))
+ ((long) (upgrade_lengths_p ? (OBJECT_DATUM (value)) : (value)))
static Boolean
allow_compiled_p = false,
Free, Scan, Free_Constant, Scan_Constant,
Objects, Constant_Objects;
-static Pointer
+static SCHEME_OBJECT
*Mem_Base,
*Free_Objects, *Free_Cobjects,
*compiled_entry_table, *compiled_entry_pointer,
}
else
{
- unsigned int x = (((int) c) & ((1 << CHAR_SIZE) - 1));
+ unsigned int x = (((int) c) & ((1 << CHAR_BIT) - 1));
fprintf(stderr,
"%s: %s: File may not be portable: c = 0x%x\n",
program_name, name, x);
return;
}
\f
+#undef MAKE_BROKEN_HEART
+#define MAKE_BROKEN_HEART(offset) (BROKEN_HEART_ZERO + (offset))
+
#define Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, kernel_code) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer((Code), Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_TYPE ((Code), Old_Contents)); \
else \
{ \
kernel_code; \
#define standard_kernel(kernel_code, type, Code, Scn, Obj, FObj) \
{ \
- fast long length; \
- \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- length = Get_Integer(Old_Contents); \
- kernel_code; \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer((type), 0); \
- *(FObj)++ = Old_Contents; \
- while(--length >= 0) \
+ (Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj))); \
{ \
- *(FObj)++ = *Old_Address++; \
+ fast long length = (OBJECT_DATUM (Old_Contents)); \
+ kernel_code; \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Obj)); \
+ (Obj) += 1; \
+ (*(FObj)++) = (MAKE_OBJECT ((type), 0)); \
+ (*(FObj)++) = Old_Contents; \
+ while ((length--) > 0) \
+ (*(FObj)++) = (*Old_Address++); \
} \
}
\f
#define do_string_kernel() \
{ \
NStrings += 1; \
- NChars += pointer_to_char(length - 1); \
+ NChars += (pointer_to_char (length - 1)); \
}
#define do_bignum_kernel() \
{ \
NIntegers += 1; \
- NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
+ NBits += \
+ (((* ((bignum_digit_type *) (Old_Address + 1))) \
+ & BIGNUM_DIGIT_MASK) \
+ * BIGNUM_DIGIT_LENGTH); \
}
#define do_bit_string_kernel() \
{ \
NBitstrs += 1; \
- NBBits += Old_Address[BIT_STRING_LENGTH_OFFSET]; \
+ NBBits += (Old_Address [BIT_STRING_LENGTH_OFFSET]); \
}
#define do_flonum_kernel(Code, Scn, Obj, FObj) \
{ \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
+ (Mem_Base [(Scn)]) = (MAKE_OBJECT ((Code), (Obj))); \
NFlonums += 1; \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Obj)); \
(Obj) += 1; \
- Align_Float(FObj); \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \
- *((double *) (FObj)) = *((double *) Old_Address); \
+ ALIGN_FLOAT (FObj); \
+ (*(FObj)++) = (MAKE_OBJECT (TC_BIG_FLONUM, 0)); \
+ (* ((double *) (FObj))) = (* ((double *) Old_Address)); \
(FObj) += float_to_pointer; \
}
#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, \
- standard_kernel(do_string_kernel(), TC_CHARACTER_STRING, \
- Code, Scn, Obj, FObj))
+ Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
+ standard_kernel (do_string_kernel (), \
+ TC_CHARACTER_STRING, \
+ Code, Scn, Obj, FObj))
#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, \
- standard_kernel(do_bignum_kernel(), TC_BIG_FIXNUM, \
- Code, Scn, Obj, FObj))
+ Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
+ standard_kernel (do_bignum_kernel (), TC_BIG_FIXNUM, \
+ Code, Scn, Obj, FObj))
#define Do_Bit_String(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, \
- standard_kernel(do_bit_string_kernel(), TC_BIT_STRING, \
- Code, Scn, Obj, FObj))
+ Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
+ standard_kernel (do_bit_string_kernel (), TC_BIT_STRING, \
+ Code, Scn, Obj, FObj))
#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
- Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, \
- do_flonum_kernel(Code, Scn, Obj, FObj))
+ Do_Compound (Code, Rel, Fre, Scn, Obj, FObj, \
+ do_flonum_kernel (Code, Scn, Obj, FObj))
\f
void
print_a_fixnum(val)
\f
void
print_a_string(from)
- Pointer *from;
+ SCHEME_OBJECT *from;
{
long len;
long maxlen;
- maxlen = pointer_to_char((Get_Integer(*from++)) - 1);
+ maxlen = pointer_to_char((OBJECT_DATUM (*from++)) - 1);
len = STRING_LENGTH_TO_LONG(*from++);
fprintf(portable_file,
return;
}
\f
-void
-print_a_bignum(from)
- Pointer *from;
+static long
+bignum_length (bignum)
+ SCHEME_OBJECT bignum;
{
- 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)
+ if (BIGNUM_ZERO_P (bignum))
+ return (0);
{
- fprintf(portable_file, "%02x + 0\n",
- (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
+ bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
+ fast bignum_digit_type digit = (BIGNUM_REF (bignum, index));
+ fast long result;
+ if (index >= (LONG_MAX / BIGNUM_DIGIT_LENGTH))
+ goto loser;
+ result = (index * BIGNUM_DIGIT_LENGTH);
+ while (digit > 0)
+ {
+ result += 1;
+ if (result >= LONG_MAX)
+ goto loser;
+ digit >>= 1;
+ }
+ return (result);
}
- 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;
- }
+ loser:
+ fprintf (stderr, "%s: Bignum exceeds representable length.\n",
+ program_name);
+ quit (1);
+ /* NOTREACHED */
+}
\f
- 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)
+void
+print_a_bignum (bignum)
+ SCHEME_OBJECT bignum;
+{
+ if (BIGNUM_ZERO_P (bignum))
{
- tail = SHIFT;
+ fprintf (portable_file, "%02x + 0\n",
+ (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM));
+ return;
}
- 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)
+ {
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ fast long length_in_bits = (bignum_length (bignum));
+ fast int bits_in_digit = 0;
+ fast bignum_digit_type accumulator;
+ fprintf (portable_file, "%02x %c %ld ",
+ (compact_p ? TC_FIXNUM : TC_BIG_FIXNUM),
+ ((BIGNUM_NEGATIVE_P (bignum)) ? '-' : '+'),
+ length_in_bits);
+ accumulator = (*scan++);
+ bits_in_digit =
+ ((length_in_bits < BIGNUM_DIGIT_LENGTH)
+ ? length_in_bits
+ : BIGNUM_DIGIT_LENGTH);
+ while (length_in_bits > 0)
{
- fprintf(portable_file, "%01lx", (temp & 0xf));
- temp = temp >> 4;
+ if (bits_in_digit > 4)
+ {
+ fprintf (portable_file, "%01lx", (accumulator & 0xf));
+ length_in_bits -= 4;
+ accumulator >>= 4;
+ bits_in_digit -= 4;
+ }
+ else if (bits_in_digit == 4)
+ {
+ fprintf (portable_file, "%01lx", accumulator);
+ length_in_bits -= 4;
+ if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
+ {
+ accumulator = (*scan++);
+ bits_in_digit = BIGNUM_DIGIT_LENGTH;
+ }
+ else if (length_in_bits > 0)
+ {
+ accumulator = (*scan++);
+ bits_in_digit = length_in_bits;
+ }
+ else
+ break;
+ }
+ else if (bits_in_digit < length_in_bits)
+ {
+ int carry = accumulator;
+ int diff_bits = (4 - bits_in_digit);
+ accumulator = (*scan++);
+ fprintf (portable_file, "%01lx",
+ (carry |
+ ((accumulator && ((1 << diff_bits) - 1)) <<
+ bits_in_digit)));
+ length_in_bits -= 4;
+ bits_in_digit = (BIGNUM_DIGIT_LENGTH - diff_bits);
+ if (length_in_bits >= bits_in_digit)
+ accumulator >>= diff_bits;
+ else if (length_in_bits > 0)
+ {
+ accumulator >>= diff_bits;
+ bits_in_digit = length_in_bits;
+ }
+ else
+ break;
+ }
+ else
+ {
+ fprintf (portable_file, "%01lx", accumulator);
+ break;
+ }
}
- }
- if (size_in_bits > 0)
- {
- fprintf(portable_file, "%01lx\n", (temp & 0xf));
- }
- else
- {
- fprintf(portable_file, "\n");
- }
}
- return;
+ fprintf (portable_file, "\n");
}
\f
/* The following procedure assumes that a C long is at least 4 bits. */
void
print_a_bit_string(from)
- Pointer *from;
+ SCHEME_OBJECT *from;
{
- Pointer the_bit_string;
+ SCHEME_OBJECT the_bit_string;
fast long bits_remaining, leftover_bits;
- fast Pointer accumulator, next_word, *scan;
+ fast SCHEME_OBJECT accumulator, next_word, *scan;
- the_bit_string = Make_Pointer(TC_BIT_STRING, from);
- bits_remaining = bit_string_length(the_bit_string);
+ the_bit_string = (MAKE_POINTER_OBJECT (TC_BIT_STRING, from));
+ bits_remaining = (BIT_STRING_LENGTH (the_bit_string));
fprintf(portable_file, "%02x %ld", TC_BIT_STRING, bits_remaining);
if (bits_remaining != 0)
{
fprintf(portable_file, " ");
- scan = bit_string_low_ptr(the_bit_string);
+ scan = BIT_STRING_LOW_PTR(the_bit_string);
for (leftover_bits = 0;
bits_remaining > 0;
- bits_remaining -= POINTER_LENGTH)
+ bits_remaining -= OBJECT_LENGTH)
{
- next_word = *(inc_bit_string_ptr(scan));
+ next_word = *(INC_BIT_STRING_PTR(scan));
- if (bits_remaining < POINTER_LENGTH)
- next_word &= low_mask(bits_remaining);
+ if (bits_remaining < OBJECT_LENGTH)
+ next_word &= LOW_MASK(bits_remaining);
if (leftover_bits != 0)
{
- accumulator &= low_mask(leftover_bits);
+ accumulator &= LOW_MASK(leftover_bits);
accumulator |=
- ((next_word & low_mask(4 - leftover_bits)) << leftover_bits);
+ ((next_word & LOW_MASK(4 - leftover_bits)) << leftover_bits);
next_word = (next_word >> (4 - leftover_bits));
- leftover_bits += ((bits_remaining > POINTER_LENGTH) ?
- (POINTER_LENGTH - 4) :
+ leftover_bits += ((bits_remaining > OBJECT_LENGTH) ?
+ (OBJECT_LENGTH - 4) :
(bits_remaining - 4));
fprintf(portable_file, "%01lx", (accumulator & 0xf));
}
else
{
- leftover_bits = ((bits_remaining > POINTER_LENGTH) ?
- POINTER_LENGTH :
+ leftover_bits = ((bits_remaining > OBJECT_LENGTH) ?
+ OBJECT_LENGTH :
bits_remaining);
}
#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
- Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- } \
+ { \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ } \
}
#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
- Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
+ { \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ } \
}
-\f
+
#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
- Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
+ { \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ } \
}
#define Do_Quad(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
- Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
+ { \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ } \
}
\f
#define Copy_Vector(Scn, Fre) \
{ \
- fast long len; \
- \
- len = OBJECT_DATUM(Old_Contents); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- while (--len >= 0) \
- { \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
+ fast long len = (OBJECT_DATUM (Old_Contents)); \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ while ((len--) > 0) \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
}
#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
- Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
- Copy_Vector(Scn, Fre); \
- } \
+ { \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ Copy_Vector (Scn, Fre); \
+ } \
}
-\f
+
/* This is a hack to get the cross compiler to work from vaxen to other
- machines and viceversa.
- */
+ machines and viceversa. */
#define Do_Inverted_Block(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- Mem_Base[(Scn)] = Make_New_Pointer(OBJECT_TYPE(This), \
- Old_Contents); \
- } \
+ Old_Contents = (*Old_Address); \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (Mem_Base [(Scn)]) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- fast long len1, len2; \
- Pointer *Saved; \
- \
- Mem_Base[(Scn)] = Make_Non_Pointer(OBJECT_TYPE(This), (Fre)); \
- \
- len1 = OBJECT_DATUM(Old_Contents); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- if ((OBJECT_TYPE(*Old_Address)) != TC_MANIFEST_NM_VECTOR) \
- { \
- fprintf(stderr, "%s: Bad compiled code block found.\n", \
- program_name); \
- quit(1); \
- } \
- len2 = OBJECT_DATUM(*Old_Address); \
- Mem_Base[(Fre)++] = *Old_Address++; \
- Old_Address += len2; \
- Saved = Old_Address; \
- len1 -= (len2 + 1); \
- while (--len2 >= 0) \
{ \
- Old_Address -= 1; \
- Mem_Base[(Fre)++] = *Old_Address; \
+ fast long len1, len2; \
+ SCHEME_OBJECT * Saved; \
+ (Mem_Base [(Scn)]) = (OBJECT_NEW_DATUM (This, (Fre))); \
+ len1 = (OBJECT_DATUM (Old_Contents)); \
+ (*Old_Address++) = (MAKE_BROKEN_HEART (Fre)); \
+ (Mem_Base [(Fre)++]) = Old_Contents; \
+ if ((OBJECT_TYPE (*Old_Address)) != TC_MANIFEST_NM_VECTOR) \
+ { \
+ fprintf (stderr, "%s: Bad compiled code block found.\n", \
+ program_name); \
+ quit (1); \
+ } \
+ len2 = (OBJECT_DATUM (*Old_Address)); \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
+ Old_Address += len2; \
+ Saved = Old_Address; \
+ len1 -= (len2 + 1); \
+ while ((len2--) > 0) \
+ (Mem_Base [(Fre)++]) = (*--Old_Address); \
+ Old_Address = Saved; \
+ while ((len1--) > 0) \
+ (Mem_Base [(Fre)++]) = (*Old_Address++); \
} \
- Old_Address = Saved; \
- while (--len1 >= 0) \
- { \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
- } \
}
\f
#ifdef CMPGCFILE
#define Do_Compiled_Entry(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
long offset; \
- Pointer *saved; \
- \
+ SCHEME_OBJECT * saved; \
Old_Address += (Rel); \
saved = Old_Address; \
- Get_Compiled_Block(Old_Address, saved); \
- Old_Contents = *Old_Address; \
- \
- Mem_Base[(Scn)] = \
- Make_Non_Pointer(TC_COMPILED_ENTRY, \
- (compiled_entry_pointer - compiled_entry_table)); \
- \
+ Get_Compiled_Block (Old_Address, saved); \
+ Old_Contents = (*Old_Address); \
+ (Mem_Base [(Scn)]) = \
+ (OBJECT_NEW_DATUM \
+ (TC_COMPILED_ENTRY, \
+ (compiled_entry_pointer - compiled_entry_table))); \
offset = (((char *) saved) - ((char *) Old_Address)); \
- *compiled_entry_pointer++ = MAKE_SIGNED_FIXNUM(offset); \
- \
+ (*compiled_entry_pointer++) = (LONG_TO_FIXNUM (offset)); \
/* Base pointer */ \
- \
- if (OBJECT_TYPE(Old_Contents) == TC_BROKEN_HEART) \
- { \
- *compiled_entry_pointer++ = \
- Make_New_Pointer(OBJECT_TYPE(This), Old_Contents); \
- } \
+ if (BROKEN_HEART_P (Old_Contents)) \
+ (*compiled_entry_pointer++) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, Old_Contents)); \
else \
- { \
- *compiled_entry_pointer++ = \
- Make_New_Pointer(OBJECT_TYPE(This), (Fre)); \
- \
- Copy_Vector(Scn, Fre); \
- } \
+ { \
+ (*compiled_entry_pointer++) = \
+ (MAKE_OBJECT_FROM_OBJECTS (This, (Fre))); \
+ Copy_Vector (Scn, Fre); \
+ } \
}
#else /* no CMPGCFILE */
#define Do_Compiled_Entry(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
- fprintf(stderr, \
- "%s: Invoking Do_Compiled_Entry with no compiler support!\n", \
- program_name); \
- quit(1); \
+ fprintf \
+ (stderr, \
+ "%s: Invoking Do_Compiled_Entry with no compiler support!\n", \
+ program_name); \
+ quit (1); \
}
#endif /* CMPGCFILE */
{ \
long the_datum; \
\
- Old_Address = Get_Pointer(This); \
- the_datum = OBJECT_DATUM(This); \
+ Old_Address = (OBJECT_ADDRESS (This)); \
+ the_datum = (OBJECT_DATUM (This)); \
if ((the_datum >= Heap_Base) && \
(the_datum < Dumped_Heap_Top)) \
- { \
- Action(HEAP_CODE, Heap_Relocation, Free, \
- Scn, Objects, Free_Objects); \
- } \
- \
- /* \
- \
- Currently constant space is not supported \
- \
+ { \
+ Action \
+ (HEAP_CODE, Heap_Relocation, Free, \
+ Scn, Objects, Free_Objects); \
+ } \
+ /* Currently constant space is not supported \
else if ((the_datum >= Const_Base) && \
(the_datum < Dumped_Constant_Top)) \
- { \
- Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \
- Scn, Constant_Objects, Free_Cobjects); \
- } \
- \
- */ \
- \
+ { \
+ Action \
+ (CONSTANT_CODE, Constant_Relocation, Free_Constant, \
+ Scn, Constant_Objects, Free_Cobjects); \
+ } \
+ */ \
else \
- { \
- out_of_range_pointer(This); \
- } \
+ { \
+ out_of_range_pointer (This); \
+ } \
(Scn) += 1; \
break; \
}
\f
void
out_of_range_pointer(ptr)
- Pointer ptr;
+ SCHEME_OBJECT ptr;
{
fprintf(stderr,
"%s: The input file is not portable: Out of range pointer.\n",
fprintf(stderr, "Const_Base = 0x%lx;\tConst_Top = 0x%lx\n",
Const_Base, Dumped_Constant_Top);
fprintf(stderr, "ptr = 0x%02x|0x%lx\n",
- OBJECT_TYPE(ptr), OBJECT_DATUM(ptr));
+ OBJECT_TYPE (ptr), OBJECT_DATUM (ptr));
quit(1);
}
-Pointer *
+SCHEME_OBJECT *
relocate(object)
- Pointer object;
+ SCHEME_OBJECT object;
{
long the_datum;
- Pointer *result;
+ SCHEME_OBJECT *result;
- result = Get_Pointer(object);
- the_datum = OBJECT_DATUM(object);
+ result = OBJECT_ADDRESS (object);
+ the_datum = OBJECT_DATUM (object);
if ((the_datum >= Heap_Base) &&
(the_datum < Dumped_Heap_Top))
#define PRIMITIVE_UPGRADE_SPACE 2048
-static Pointer
+static SCHEME_OBJECT
*internal_renumber_table,
*external_renumber_table,
*external_prim_name_table;
static Boolean
found_ext_prims = false;
-Pointer
+SCHEME_OBJECT
upgrade_primitive(prim)
- Pointer prim;
+ SCHEME_OBJECT prim;
{
long the_datum, the_type, new_type, code;
- Pointer new;
+ SCHEME_OBJECT new;
- the_datum = OBJECT_DATUM(prim);
- the_type = OBJECT_TYPE(prim);
+ the_datum = OBJECT_DATUM (prim);
+ the_type = OBJECT_TYPE (prim);
if (the_type != TC_PRIMITIVE_EXTERNAL)
{
code = the_datum;
}
\f
new = internal_renumber_table[code];
- if (new == NIL)
+ if (new == SHARP_F)
{
/*
This does not need to check for overflow because the worst case
was checked in setup_primitive_upgrade;
*/
- new = Make_Non_Pointer(new_type, Primitive_Table_Length);
+ new = (MAKE_OBJECT (new_type, Primitive_Table_Length));
internal_renumber_table[code] = new;
external_renumber_table[Primitive_Table_Length] = prim;
Primitive_Table_Length += 1;
if (the_type == TC_PRIMITIVE_EXTERNAL)
{
NPChars +=
- STRING_LENGTH_TO_LONG((((Pointer *)
+ STRING_LENGTH_TO_LONG((((SCHEME_OBJECT *)
(external_prim_name_table[the_datum]))
- [STRING_LENGTH]));
+ [STRING_LENGTH_INDEX]));
}
else
{
}
else
{
- return (Make_New_Pointer(new_type, new));
+ return (OBJECT_NEW_TYPE (new_type, new));
}
}
\f
-Pointer *
+SCHEME_OBJECT *
setup_primitive_upgrade(Heap)
- Pointer *Heap;
+ SCHEME_OBJECT *Heap;
{
fast long count, length;
- Pointer *old_prims_vector;
-
+ SCHEME_OBJECT *old_prims_vector;
+
internal_renumber_table = &Heap[0];
external_renumber_table =
&internal_renumber_table[PRIMITIVE_UPGRADE_SPACE];
&external_renumber_table[PRIMITIVE_UPGRADE_SPACE];
old_prims_vector = relocate(Ext_Prim_Vector);
- if (*old_prims_vector == NIL)
+ if (*old_prims_vector == SHARP_F)
{
length = 0;
}
else
{
old_prims_vector = relocate(*old_prims_vector);
- length = Get_Integer(*old_prims_vector);
+ length = OBJECT_DATUM (*old_prims_vector);
old_prims_vector += VECTOR_DATA;
for (count = 0; count < length; count += 1)
{
- Pointer *temp;
+ SCHEME_OBJECT *temp;
/* symbol */
temp = relocate(old_prims_vector[count]);
/* string */
temp = relocate(temp[SYMBOL_NAME]);
- external_prim_name_table[count] = ((Pointer) temp);
+ external_prim_name_table[count] = ((SCHEME_OBJECT) temp);
}
}
length += (MAX_BUILTIN_PRIMITIVE + 1);
}
for (count = 0; count < length; count += 1)
{
- internal_renumber_table[count] = NIL;
+ internal_renumber_table[count] = SHARP_F;
}
NPChars = 0;
return (&external_prim_name_table[PRIMITIVE_UPGRADE_SPACE]);
int Code;
fast long *Area, *Bound;
fast long *Obj;
- fast Pointer **FObj;
+ fast SCHEME_OBJECT **FObj;
{
- fast Pointer This, *Old_Address, Old_Contents;
+ fast SCHEME_OBJECT This, *Old_Address, Old_Contents;
while(*Area != *Bound)
{
#ifdef PRIMITIVE_EXTERNAL_REUSED
if (upgrade_primitives_p &&
- (OBJECT_TYPE(This) == TC_PRIMITIVE_EXTERNAL))
+ (OBJECT_TYPE (This) == TC_PRIMITIVE_EXTERNAL))
{
Mem_Base[*Area] = upgrade_primitive(This);
*Area += 1;
{
fast int i;
- i = Get_Integer(This);
+ i = OBJECT_DATUM (This);
*Area += 1;
for ( ; --i >= 0; *Area += 1)
{
- Mem_Base[*Area] = NIL;
+ Mem_Base[*Area] = SHARP_F;
}
break;
}
fprintf(stderr, "%s: File is not portable: NMH found\n",
program_name);
}
- *Area += (1 + OBJECT_DATUM(This));
+ *Area += (1 + OBJECT_DATUM (This));
break;
case TC_BROKEN_HEART:
/* [Broken Heart 0] is the cdr of fasdumped symbols. */
- if (OBJECT_DATUM(This) != 0)
+ if (OBJECT_DATUM (This) != 0)
{
fprintf(stderr, "%s: Broken Heart found in scan.\n",
program_name);
case TC_CHARACTER:
Process_Character:
- Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj);
+ Mem_Base[*Area] = (MAKE_OBJECT (Code, *Obj));
*Obj += 1;
**FObj = This;
*FObj += 1;
{
long kind;
- kind = OBJECT_DATUM(This);
+ kind = OBJECT_DATUM (This);
if (upgrade_traps_p)
{
case TC_FUTURE:
case_simple_Vector:
- if (OBJECT_TYPE(This) == TC_BIT_STRING)
+ if (BIT_STRING_P (This))
{
Do_Pointer(*Area, Do_Bit_String);
}
default:
Bad_Type:
fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
- program_name, OBJECT_TYPE(This));
+ program_name, OBJECT_TYPE (This));
quit(1);
}
}
void
print_external_objects(from, count)
- fast Pointer *from;
+ fast SCHEME_OBJECT *from;
fast long count;
{
while (--count >= 0)
{
- switch(OBJECT_TYPE(*from))
+ switch(OBJECT_TYPE (*from))
{
case TC_FIXNUM:
- {
- long Value;
-
- Sign_Extend(*from++, Value);
- print_a_fixnum(Value);
+ print_a_fixnum (FIXNUM_TO_LONG (*from));
+ from += 1;
break;
- }
case TC_BIT_STRING:
print_a_bit_string(++from);
- from += (1 + OBJECT_DATUM(*from));
+ from += (1 + OBJECT_DATUM (*from));
break;
case TC_BIG_FIXNUM:
- print_a_bignum(++from);
- from += (1 + OBJECT_DATUM(*from));
+ print_a_bignum (*from++);
+ from += (1 + OBJECT_DATUM (*from));
break;
-
+
case TC_CHARACTER_STRING:
print_a_string(++from);
- from += (1 + OBJECT_DATUM(*from));
+ from += (1 + OBJECT_DATUM (*from));
break;
case TC_BIG_FLONUM:
case TC_CHARACTER:
fprintf(portable_file, "%02x %03x\n",
- TC_CHARACTER, (*from & MASK_EXTNDD_CHAR));
+ TC_CHARACTER, (*from & MASK_MIT_ASCII));
from += 1;
break;
#ifdef FLOATING_ALIGNMENT
case TC_MANIFEST_NM_VECTOR:
- if ((OBJECT_DATUM(*from)) == 0)
+ if ((OBJECT_DATUM (*from)) == 0)
{
from += 1;
count += 1;
\f
void
print_objects(from, to)
- fast Pointer *from, *to;
+ fast SCHEME_OBJECT *from, *to;
{
fast long the_datum, the_type;
while(from < to)
{
- the_type = OBJECT_TYPE(*from);
- the_datum = OBJECT_DATUM(*from);
+ the_type = OBJECT_TYPE (*from);
+ the_datum = OBJECT_DATUM (*from);
from += 1;
if (the_type == TC_MANIFEST_NM_VECTOR)
}
else if (the_type == TC_COMPILED_ENTRY)
{
- Pointer base;
+ SCHEME_OBJECT base;
long offset;
- Sign_Extend(compiled_entry_table[the_datum], offset);
+ offset = (FIXNUM_TO_LONG (compiled_entry_table [the_datum]));
base = compiled_entry_table[the_datum + 1];
fprintf(portable_file, "%02x %lx %02x %lx\n",
TC_COMPILED_ENTRY, offset,
- OBJECT_TYPE(base), OBJECT_DATUM(base));
+ OBJECT_TYPE (base), OBJECT_DATUM (base));
}
else
{
void
do_it()
{
- Pointer *Heap;
+ SCHEME_OBJECT *Heap;
long Initial_Free;
/* Load the Data */
(2 * (Heap_Count + Const_Count)) :
0));
- Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE);
+ ALLOCATE_HEAP_SPACE (Size + HEAP_BUFFER_SPACE);
- if (Heap == NULL)
+ if (Heap == ((SCHEME_OBJECT *) 0))
{
fprintf(stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
+ "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
program_name, Size);
quit(1);
}
}
Heap += HEAP_BUFFER_SPACE;
- Initial_Align_Float(Heap);
+ INITIAL_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)));
+ Heap_Relocation = ((&Heap[0]) - (OBJECT_ADDRESS (Heap_Base)));
+ Constant_Relocation = ((&Heap[Heap_Count]) - (OBJECT_ADDRESS (Const_Base)));
\f
/* Setup compiled code and primitive tables. */
}
else
{
- fast Pointer *table;
+ fast SCHEME_OBJECT *table;
fast long count, char_count;
Load_Data(Primitive_Table_Size, primitive_table);
table = primitive_table;
--count >= 0;)
{
- char_count += STRING_LENGTH_TO_LONG(table[1 + STRING_LENGTH]);
- table += (2 + Get_Integer(table[1 + STRING_HEADER]));
+ char_count += STRING_LENGTH_TO_LONG(table[1 + STRING_LENGTH_INDEX]);
+ table += (2 + OBJECT_DATUM (table[1 + STRING_HEADER]));
}
NPChars = char_count;
primitive_table_end = &primitive_table[Primitive_Table_Size];
NFlonums = NIntegers = NStrings = 0;
NBits = NBBits = NChars = 0;
- Mem_Base[0] = Make_New_Pointer(TC_CELL, Dumped_Object);
+ Mem_Base[0] = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object));
Initial_Free = NROOTS;
Scan = 0;
WRITE_HEADER("Constant Base", "%ld", Free_Constant);
WRITE_HEADER("Constant Objects", "%ld", 0);
- WRITE_HEADER("& Dumped Object", "%ld", (OBJECT_DATUM(Mem_Base[0])));
+ WRITE_HEADER("& Dumped Object", "%ld", (OBJECT_DATUM (Mem_Base[0])));
WRITE_HEADER("Number of flonums", "%ld", NFlonums);
WRITE_HEADER("Number of integers", "%ld", NIntegers);
dumped_interface_version);
#if false
WRITE_HEADER("Compiler utilities vector", "%ld",
- OBJECT_DATUM(dumped_utilities));
+ OBJECT_DATUM (dumped_utilities));
#endif
\f
/* External Objects */
-
+
print_external_objects(&Mem_Base[Initial_Free + Heap_Count],
Objects);
-
+
#if false
print_external_objects(&Mem_Base[Pure_Objects_Start],
#if false
print_objects(&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]);
- print_objects(&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
+ print_objects(&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
#endif
\f
/* Primitives */
if (upgrade_primitives_p)
{
- Pointer obj;
- fast Pointer *table;
+ SCHEME_OBJECT obj;
+ fast SCHEME_OBJECT *table;
fast long count, the_datum;
for (count = Primitive_Table_Length,
--count >= 0;)
{
obj = *table++;
- the_datum = OBJECT_DATUM(obj);
- if (OBJECT_TYPE(obj) == TC_PRIMITIVE_EXTERNAL)
+ the_datum = OBJECT_DATUM (obj);
+ if (OBJECT_TYPE (obj) == TC_PRIMITIVE_EXTERNAL)
{
- Pointer *strobj;
+ SCHEME_OBJECT *strobj;
- strobj = ((Pointer *) (external_prim_name_table[the_datum]));
+ strobj = ((SCHEME_OBJECT *) (external_prim_name_table[the_datum]));
print_a_primitive(((long) UNKNOWN_PRIMITIVE_ARITY),
- (STRING_LENGTH_TO_LONG(strobj[STRING_LENGTH])),
+ (STRING_LENGTH_TO_LONG(strobj[STRING_LENGTH_INDEX])),
((char *) &strobj[STRING_CHARS]));
}
else
}
else
{
- fast Pointer *table;
+ fast SCHEME_OBJECT *table;
fast long count;
long arity;
for (count = Primitive_Table_Length, table = primitive_table;
--count >= 0;)
{
- Sign_Extend(*table, arity);
+ arity = (FIXNUM_TO_LONG (*table));
table += 1;
print_a_primitive(arity,
- (STRING_LENGTH_TO_LONG(table[STRING_LENGTH])),
+ (STRING_LENGTH_TO_LONG(table[STRING_LENGTH_INDEX])),
((char *) &table[STRING_CHARS]));
- table += (1 + Get_Integer(table[STRING_HEADER]));
+ table += (1 + OBJECT_DATUM (table[STRING_HEADER]));
}
}
return;
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.34 1989/08/28 18:28:42 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.35 1989/09/20 23:07:12 cph Exp $
*
* Named constants used throughout the interpreter
*
*/
\f
-#if (CHAR_SIZE != 8)
-#define MAX_CHAR ((1<<CHAR_SIZE)-1)
+#if (CHAR_BIT != 8)
+#define MAX_CHAR ((1<<CHAR_BIT)-1)
#else
#define MAX_CHAR 0xFF
#endif
#endif /* b32 */
#ifndef SHARP_F /* Safe version */
-#define SHARP_F Make_Non_Pointer(TC_NULL, 0)
-#define SHARP_T Make_Non_Pointer(TC_TRUE, 0)
-#define UNSPECIFIC Make_Non_Pointer(TC_TRUE, 1)
-#define FIXNUM_ZERO Make_Non_Pointer(TC_FIXNUM, 0)
-#define BROKEN_HEART_ZERO Make_Non_Pointer(TC_BROKEN_HEART, 0)
+#define SHARP_F MAKE_OBJECT (TC_NULL, 0)
+#define SHARP_T MAKE_OBJECT (TC_TRUE, 0)
+#define UNSPECIFIC MAKE_OBJECT (TC_TRUE, 1)
+#define FIXNUM_ZERO MAKE_OBJECT (TC_FIXNUM, 0)
+#define BROKEN_HEART_ZERO MAKE_OBJECT (TC_BROKEN_HEART, 0)
#endif /* SHARP_F */
#define EMPTY_LIST SHARP_F
-#define NIL SHARP_F
-#define TRUTH SHARP_T
#define NOT_THERE -1 /* Command line parser */
\f
/* Assorted sizes used in various places */
#define ILLEGAL_PRIMITIVE -1
/* Last immediate reference trap. */
-
+
#define TRAP_MAX_IMMEDIATE 9
/* For headers in pure / constant area */
#if Are_The_Constants_Incompatible
#include "Error: const.h and types.h disagree"
-#endif
+#endif
/* These are the only entries in Registers[] needed by the microcode.
All other entries are used only by the compiled code interface. */
/* -*-C-*-
-Copyright (c) 1987, 1988 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fasl.h,v 9.30 1989/09/20 23:07:58 cph Exp $
+
+Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fasl.h,v 9.29 1988/08/15 20:46:07 cph Rel $
-
- Contains information relating to the format of FASL files.
+/* Contains information relating to the format of FASL files.
The machine/opsys information is contained in config.h
The processor and compiled code version information is
- contained in the appropriate cmp* file, or compiler.c
-*/
+ contained in the appropriate cmp* file, or compiler.c */
extern long Load_Data(), Write_Data();
extern Boolean Open_Dump_File(), Close_Dump_File();
#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_Version 6 /* FASL format version info. */
#define FASL_Offset_Stack_Top 7 /* Top of stack when dumped */
#define FASL_Offset_Prim_Length 8 /* Number of entries in primitive table */
-#define FASL_Offset_Prim_Size 9 /* Size of primitive table in Pointers */
+#define FASL_Offset_Prim_Size 9 /* Size of primitive table in SCHEME_OBJECTs */
#define FASL_Offset_Ci_Version 10 /* Version number for compiled code interface */
#define FASL_Offset_Ut_Base 11 /* Address of the utilities vector */
/* Version information encoding */
-#define MACHINE_TYPE_LENGTH (POINTER_LENGTH / 2)
+#define MACHINE_TYPE_LENGTH (OBJECT_LENGTH / 2)
#define MACHINE_TYPE_MASK ((1 << MACHINE_TYPE_LENGTH) - 1)
#define The_Machine_Type(P) ((P) & MACHINE_TYPE_MASK)
#define SUBVERSION_LENGTH (MACHINE_TYPE_LENGTH - TYPE_CODE_LENGTH)
#define SUBVERSION_MASK ((1 << SUBVERSION_LENGTH) - 1)
#define The_Sub_Version(P) (((P) >> MACHINE_TYPE_LENGTH) & SUBVERSION_MASK)
-#define The_Version(P) OBJECT_TYPE(P)
+#define The_Version(P) OBJECT_TYPE (P)
#define Make_Version(V, S, M) \
- Make_Non_Pointer((V), (((S) << MACHINE_TYPE_LENGTH) | (M)))
+ MAKE_OBJECT ((V), (((S) << MACHINE_TYPE_LENGTH) | (M)))
-#define CI_MASK ((1 << (ADDRESS_LENGTH / 2)) - 1)
-#define CI_VERSION(P) (((P) >> (ADDRESS_LENGTH / 2)) & CI_MASK)
+#define CI_MASK ((1 << (DATUM_LENGTH / 2)) - 1)
+#define CI_VERSION(P) (((P) >> (DATUM_LENGTH / 2)) & CI_MASK)
#define CI_PROCESSOR(P) ((P) & CI_MASK)
-#define CI_BAND_P(P) (OBJECT_TYPE(P) == TC_TRUE)
+#define CI_BAND_P(P) (OBJECT_TYPE (P) == TC_TRUE)
#define MAKE_CI_VERSION(Band_p, Version, Processor_Type) \
- Make_Non_Pointer(((Band_p) ? TC_TRUE : TC_NULL), \
- (((Version) << (ADDRESS_LENGTH / 2)) | \
+ MAKE_OBJECT (((Band_p) ? TC_TRUE : TC_NULL), \
+ (((Version) << (DATUM_LENGTH / 2)) | \
(Processor_Type)))
#define WRITE_FLAG 1
#define FASL_REFERENCE_TRAP 6
#define FASL_MERGED_PRIMITIVES 7
#define FASL_INTERFACE_VERSION 8
+#define FASL_NEW_BIGNUMS 9
/* Current parameters. Always used on output. */
#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK
-#define FASL_SUBVERSION FASL_INTERFACE_VERSION
+#define FASL_SUBVERSION FASL_NEW_BIGNUMS
/*
The definitions below correspond to the ones above. They usually
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.52 1989/09/20 23:09:32 cph Exp $
+
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.51 1989/06/08 00:23:42 jinx Rel $
- *
- * This file contains the heart of the Scheme Scode
- * interpreter
- *
- */
+/* This file contains the heart of the SCode interpreter. */
-#define In_Main_Interpreter true
+#define In_Main_Interpreter true
#include "scheme.h"
#include "locks.h"
#include "trap.h"
#include "lookup.h"
+#include "winder.h"
#include "history.h"
#include "cmpint.h"
#include "zones.h"
*
* 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
+ * 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.
#define RESULT_OF_PURIFY(success) \
{ \
- Pointer words_free; \
+ SCHEME_OBJECT words_free; \
\
- words_free = (Make_Unsigned_Fixnum (MemTop - Free)); \
- Val = (Make_Pointer (TC_LIST, Free)); \
+ words_free = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free)); \
+ Val = (MAKE_POINTER_OBJECT (TC_LIST, Free)); \
(*Free++) = (success); \
(*Free++) = words_free; \
}
}
#define Reduces_To_Nth(N) \
- Reduces_To(Fast_Vector_Ref(Fetch_Expression(), (N)))
+ Reduces_To(FAST_MEMORY_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))); \
+ Store_Expression(FAST_MEMORY_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))); \
+ Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), (N))); \
Reuse_Subproblem(Fetch_Expression(), Fetch_Env()); \
goto Do_Expression; \
}
-
-#define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT))
\f
/***********************/
/* Macros for Stepping */
/***********************/
#define Fetch_Trapper(field) \
- Vector_Ref(Get_Fixed_Obj_Slot(Stepper_State), (field))
+ MEMORY_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 ARG_TYPE_ERROR(Arg_No, Err_No) \
{ \
- fast Pointer *Arg, Orig_Arg; \
+ fast SCHEME_OBJECT *Arg, Orig_Arg; \
\
Arg = &(Stack_Ref((Arg_No - 1) + STACK_ENV_FIRST_ARG)); \
Orig_Arg = *Arg; \
\
- if (OBJECT_TYPE(*Arg) != TC_FUTURE) \
+ if (OBJECT_TYPE (*Arg) != TC_FUTURE) \
{ \
Pop_Return_Error(Err_No); \
} \
\
- while ((OBJECT_TYPE(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
+ while ((OBJECT_TYPE (*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
{ \
if (Future_Is_Keep_Slot(*Arg)) \
{ \
} \
*Arg = Future_Value(*Arg); \
} \
- if (OBJECT_TYPE(*Arg) != TC_FUTURE) \
+ if (OBJECT_TYPE (*Arg) != TC_FUTURE) \
{ \
goto Apply_Non_Trapping; \
} \
#define Apply_Future_Check(Name, Object) \
{ \
- fast Pointer *Arg, Orig_Answer; \
+ fast SCHEME_OBJECT *Arg, Orig_Answer; \
\
Arg = &(Object); \
Orig_Answer = *Arg; \
\
- while (Type_Code(*Arg) == TC_FUTURE) \
+ while (OBJECT_TYPE (*Arg) == TC_FUTURE) \
{ \
if (Future_Has_Value(*Arg)) \
{ \
else \
{ \
Store_Return(RC_INTERNAL_APPLY); \
- Val = NIL; \
+ Val = SHARP_F; \
TOUCH_SETUP(*Arg); \
*Arg = Orig_Answer; \
goto Internal_Apply; \
#define Pop_Return_Val_Check() \
{ \
- fast Pointer Orig_Val = Val; \
+ fast SCHEME_OBJECT Orig_Val = Val; \
\
- while (OBJECT_TYPE(Val) == TC_FUTURE) \
+ while (OBJECT_TYPE (Val) == TC_FUTURE) \
{ \
if (Future_Has_Value(Val)) \
{ \
Push(Val); \
Save_Env(); \
Store_Return(RC_REPEAT_DISPATCH); \
- Store_Expression(MAKE_SIGNED_FIXNUM(CODE_MAP(Which_Way))); \
+ Store_Expression(LONG_TO_FIXNUM(CODE_MAP(Which_Way))); \
Save_Cont(); \
Pushed(); \
Call_Future_Logging(); \
#else /* not COMPILE_FUTURES */
-#define Pop_Return_Val_Check()
+#define Pop_Return_Val_Check()
#define Apply_Future_Check(Name, Object) Name = (Object)
#define PROCEED_AFTER_PRIMITIVE() \
{ \
- Regs[REGBLOCK_PRIMITIVE] = NIL; \
- LOG_FUTURES(); \
+ (Regs [REGBLOCK_PRIMITIVE]) = SHARP_F; \
+ LOG_FUTURES (); \
}
\f
/*
Boolean dumped_p;
{
long Which_Way;
- fast Pointer *Reg_Block, *Reg_Stack_Pointer, *Reg_History;
+ fast SCHEME_OBJECT *Reg_Block, *Reg_Stack_Pointer, *Reg_History;
extern long enter_compiled_expression();
extern long apply_compiled_procedure();
\f
case PRIM_TOUCH:
{
- Pointer temp;
+ SCHEME_OBJECT temp;
temp = Val;
BACK_OUT_AFTER_PRIMITIVE();
/* fall through */
case CODE_MAP(ERR_ARG_3_WRONG_TYPE):
ARG_TYPE_ERROR(3, ERR_ARG_3_WRONG_TYPE);
-
+
default:
{
if (!CODE_MAPPED_P(Which_Way))
if (Eval_Debug)
{ Print_Expression(Fetch_Expression(), "Eval, expression");
- CRLF();
+ printf ("\n");
}
/* The expression register has an Scode item in it which
* the Expression register, and processing continues at
* Do_Expression.
*/
-\f
+
/* Handling of Eval Trapping.
If we are handling traps and there is an Eval Trap set,
turn off all trapping and then go to Internal_Apply to call the
user supplied eval hook with the expression to be evaluated and the
- environment.
-
-*/
+ 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();
+ if (Microcode_Does_Stepping &&
+ Trapping &&
+ ((Fetch_Eval_Trapper ()) != SHARP_F))
+ {
+ Stop_Trapping ();
+ Will_Push (4);
+ Push (Fetch_Env ());
+ Push (Fetch_Expression ());
+ Push (Fetch_Eval_Trapper ());
+ Push (STACK_FRAME_HEADER + 2);
+ Pushed ();
goto Apply_Non_Trapping;
}
\f
Eval_Non_Trapping:
Eval_Ucode_Hook();
- switch (OBJECT_TYPE(Fetch_Expression()))
+ switch (OBJECT_TYPE (Fetch_Expression()))
{
default:
#if false
case TC_REFERENCE_TRAP:
case TC_RETURN_CODE:
case TC_UNINTERNED_SYMBOL:
- case TC_TRUE:
+ case TC_TRUE:
case TC_VECTOR:
case TC_VECTOR_16B:
case TC_VECTOR_1B:
{
long Array_Length;
- Array_Length = (Vector_Length(Fetch_Expression()) - 1);
+ Array_Length = (VECTOR_LENGTH (Fetch_Expression()) - 1);
#ifdef USE_STACKLETS
/* Save_Env, Finger */
Eval_GC_Check(New_Stacklet_Size(Array_Length + 1 + 1 + CONTINUATION_SIZE));
#endif /* USE_STACKLETS */
Will_Push(Array_Length + 1 + 1 + CONTINUATION_SIZE);
Stack_Pointer = Simulate_Pushing(Array_Length);
- Push(Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Array_Length));
+ Push(MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Array_Length));
/* The finger: last argument number */
Pushed();
if (Array_Length == 0)
Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
Save_Env();
Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1, {});
-
+
case TC_COMBINATION_2:
- Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
+ Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
Save_Env();
Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {});
case TC_COMPILED_ENTRY:
{
- Pointer compiled_expression;
+ SCHEME_OBJECT compiled_expression;
compiled_expression = (Fetch_Expression ());
execute_compiled_setup();
case TC_DELAY:
/* Deliberately omitted: Eval_GC_Check(2); */
- Val = Make_Pointer(TC_DELAYED, Free);
+ Val = MAKE_POINTER_OBJECT (TC_DELAYED, Free);
Free[THUNK_ENVIRONMENT] = Fetch_Env();
- Free[THUNK_PROCEDURE] =
- Fast_Vector_Ref(Fetch_Expression(), DELAY_OBJECT);
+ Free[THUNK_PROCEDURE] =
+ FAST_MEMORY_REF (Fetch_Expression(), DELAY_OBJECT);
Free += 2;
- break;
+ break;
case TC_DISJUNCTION:
Will_Push(CONTINUATION_SIZE + 1);
case TC_EXTENDED_LAMBDA: /* Close the procedure */
/* Deliberately omitted: Eval_GC_Check(2); */
- Val = Make_Pointer(TC_EXTENDED_PROCEDURE, Free);
+ Val = MAKE_POINTER_OBJECT (TC_EXTENDED_PROCEDURE, Free);
Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
Free += 2;
#ifdef COMPILE_FUTURES
case TC_FUTURE:
if (Future_Has_Value(Fetch_Expression()))
- { Pointer Future = Fetch_Expression();
+ { SCHEME_OBJECT Future = Fetch_Expression();
if (Future_Is_Keep_Slot(Future)) Log_Touch_Of_Future(Future);
Reduces_To_Nth(FUTURE_VALUE);
}
case TC_LAMBDA: /* Close the procedure */
case TC_LEXPR:
/* Deliberately omitted: Eval_GC_Check(2); */
- Val = Make_Pointer(TC_PROCEDURE, Free);
+ Val = MAKE_POINTER_OBJECT (TC_PROCEDURE, Free);
Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
Free += 2;
case TC_PCOMB0:
Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
- Store_Expression(Make_New_Pointer(TC_PRIMITIVE, Fetch_Expression()));
+ Store_Expression (OBJECT_NEW_TYPE (TC_PRIMITIVE, (Fetch_Expression ())));
goto Primitive_Internal_Apply;
case TC_PCOMB1:
Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {});
case TC_SCODE_QUOTE:
- Val = Fast_Vector_Ref(Fetch_Expression(), SCODE_QUOTE_OBJECT);
+ Val = FAST_MEMORY_REF (Fetch_Expression(), SCODE_QUOTE_OBJECT);
break;
case TC_SEQUENCE_2:
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
-
+
case TC_VARIABLE:
{
long temp;
#ifndef No_In_Line_Lookup
- fast Pointer *cell;
+ fast SCHEME_OBJECT *cell;
Set_Time_Zone(Zone_Lookup);
- cell = Get_Pointer(Fetch_Expression());
+ cell = OBJECT_ADDRESS (Fetch_Expression());
lookup(cell, Fetch_Env(), cell, repeat_variable_lookup);
lookup_end_restart:
- Val = Fetch(cell[0]);
- if (Type_Code(Val) != TC_REFERENCE_TRAP)
+ Val = MEMORY_FETCH (cell[0]);
+ if (OBJECT_TYPE (Val) != TC_REFERENCE_TRAP)
{
Set_Time_Zone(Zone_Working);
goto Pop_Return;
case TRAP_UNASSIGNED_DANGEROUS:
case TRAP_FLUID_DANGEROUS:
case TRAP_COMPILER_CACHED_DANGEROUS:
- cell = Get_Pointer(Fetch_Expression());
+ cell = OBJECT_ADDRESS (Fetch_Expression());
temp =
deep_lookup_end(deep_lookup(Fetch_Env(),
cell[VARIABLE_SYMBOL],
goto Pop_Return;
case TRAP_COMPILER_CACHED:
- cell = Nth_Vector_Loc(Fast_Vector_Ref(Val, TRAP_EXTRA),
+ cell = MEMORY_LOC (FAST_MEMORY_REF (Val, TRAP_EXTRA),
TRAP_EXTENSION_CELL);
goto lookup_end_restart;
*/
Pop_Return:
- Pop_Return_Ucode_Hook();
+ Pop_Return_Ucode_Hook();
Restore_Cont();
if (Consistency_Check &&
- (Type_Code(Fetch_Return()) != TC_RETURN_CODE))
+ (OBJECT_TYPE (Fetch_Return()) != TC_RETURN_CODE))
{ Push(Val); /* For possible stack trace */
Save_Cont();
Export_Registers();
if (Eval_Debug)
{ Print_Return("Pop_Return, return code");
Print_Expression(Val, "Pop_Return, value");
- CRLF();
+ printf ("\n");
};
/* Dispatch on the return code. A BREAK here will cause
* common occurrence.
*/
- switch (Get_Integer(Fetch_Return()))
+ switch (OBJECT_DATUM (Fetch_Return()))
{
case RC_COMB_1_PROCEDURE:
Restore_Env();
Push(Val); /* Arg. 1 */
- Push(NIL); /* Operator */
+ Push(SHARP_F); /* Operator */
Push(STACK_FRAME_HEADER + 1);
Finished_Eventual_Pushing(CONTINUATION_SIZE);
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN);
case RC_COMB_2_PROCEDURE:
Restore_Env();
Push(Val); /* Arg 1, just calculated */
- Push(NIL); /* Function */
+ Push(SHARP_F); /* Function */
Push(STACK_FRAME_HEADER + 2);
Finished_Eventual_Pushing(CONTINUATION_SIZE);
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN);
{ long Arg_Number;
Restore_Env();
- Arg_Number = Get_Integer(Stack_Ref(STACK_COMB_FINGER))-1;
+ Arg_Number = OBJECT_DATUM (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);
+ Stack_Ref(STACK_COMB_FINGER) =
+ MAKE_OBJECT (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! */
+ the stack parser may create them with #F 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 */
+ Push(FAST_MEMORY_REF (Fetch_Expression(), 0)); /* Frame Size */
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
}
Pop_Return_Val_Check();
End_Subproblem();
Restore_Env();
- Reduces_To_Nth((Val==NIL)? COND_ALTERNATIVE : COND_CONSEQUENT);
+ Reduces_To_Nth ((Val == SHARP_F) ? COND_ALTERNATIVE : COND_CONSEQUENT);
case RC_DISJUNCTION_DECIDE:
- /* Return predicate if it isn't NIL; else do ALTERNATIVE */
+ /* Return predicate if it isn't #F; else do ALTERNATIVE */
Pop_Return_Val_Check();
End_Subproblem();
Restore_Env();
- if (Val != NIL) goto Pop_Return;
+ if (Val != SHARP_F) 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:
/* Should be called RC_REDO_EVALUATION. */
Store_Env(Pop());
case RC_EXECUTE_ACCESS_FINISH:
{
long Result;
- Pointer value;
+ SCHEME_OBJECT value;
Pop_Return_Val_Check();
value = Val;
- if (Environment_P(Val))
+ if (ENVIRONMENT_P (Val))
{ Result = Symbol_Lex_Ref(value,
- Fast_Vector_Ref(Fetch_Expression(),
+ FAST_MEMORY_REF (Fetch_Expression(),
ACCESS_NAME));
Import_Val();
if (Result == PRIM_DONE)
case RC_EXECUTE_ASSIGNMENT_FINISH:
{
long temp;
- Pointer value;
+ SCHEME_OBJECT value;
Lock_Handle set_serializer;
#ifndef No_In_Line_Lookup
- Pointer bogus_unassigned;
- fast Pointer *cell;
+ SCHEME_OBJECT bogus_unassigned;
+ fast SCHEME_OBJECT *cell;
Set_Time_Zone(Zone_Lookup);
Restore_Env();
- cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
+ cell = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME));
lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup);
value = Val;
Val = *cell;
- if (Type_Code(*cell) != TC_REFERENCE_TRAP)
+ if (OBJECT_TYPE (*cell) != TC_REFERENCE_TRAP)
{
normal_assignment_done:
*cell = value;
case TRAP_FLUID_DANGEROUS:
case TRAP_COMPILER_CACHED_DANGEROUS:
remove_lock(set_serializer);
- cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
+ cell = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME));
temp =
deep_assignment_end(deep_lookup(Fetch_Env(),
cell[VARIABLE_SYMBOL],
case TRAP_COMPILER_CACHED:
{
- Pointer extension, references;
+ SCHEME_OBJECT extension, references;
- extension = Fast_Vector_Ref(Val, TRAP_EXTRA);
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
+ extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
- if (Fast_Vector_Ref(references, TRAP_REFERENCES_OPERATOR) != NIL)
+ if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
+ != SHARP_F)
{
/* There are uuo links.
false);
goto external_assignment_return;
}
- cell = Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL);
+ cell = MEMORY_LOC (extension, TRAP_EXTENSION_CELL);
update_lock(set_serializer, cell);
goto assignment_end_after_lock;
- }
+ }
/* Interpret() continues on the next page */
\f
if (value == UNASSIGNED_OBJECT)
value = bogus_unassigned;
-
+
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
Set_Time_Zone(Zone_Lookup);
Restore_Env();
temp = Lex_Set(Fetch_Env(),
- Vector_Ref(Fetch_Expression(), ASSIGN_NAME),
+ MEMORY_REF (Fetch_Expression(), ASSIGN_NAME),
value);
Import_Val();
- if (temp == PRIM_DONE)
+ if (temp == PRIM_DONE)
{
End_Subproblem();
Set_Time_Zone(Zone_Working);
value);
Interrupt(PENDING_INTERRUPTS());
}
-
+
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
case RC_EXECUTE_DEFINITION_FINISH:
{
- Pointer value;
+ SCHEME_OBJECT value;
long result;
value = Val;
Restore_Env();
Export_Registers();
result = Local_Set(Fetch_Env(),
- Fast_Vector_Ref(Fetch_Expression(), DEFINE_NAME),
+ FAST_MEMORY_REF (Fetch_Expression(), DEFINE_NAME),
Val);
Import_Registers();
if (result == PRIM_DONE)
case RC_EXECUTE_IN_PACKAGE_CONTINUE:
Pop_Return_Val_Check();
- if (Environment_P(Val))
+ if (ENVIRONMENT_P (Val))
{
End_Subproblem();
Store_Env(Val);
{
/* This just reinvokes the handler */
- Pointer info, handler;
+ SCHEME_OBJECT info, handler;
info = (STACK_REF (0));
Save_Cont();
\f
/* Internal_Apply, the core of the application mechanism.
- Branch here to perform a function application.
+ Branch here to perform a function application.
At this point the top of the stack contains an application frame
which consists of the following elements (see sdata.h):
#define Prepare_Apply_Interrupt() \
{ \
Store_Return(RC_INTERNAL_APPLY); \
- Store_Expression(NIL); \
+ Store_Expression(SHARP_F); \
Save_Cont(); \
}
-
+
#define Apply_Error(N) \
{ \
Store_Return(RC_INTERNAL_APPLY); \
- Store_Expression(NIL); \
- Val = NIL; \
+ Store_Expression(SHARP_F); \
+ Val = SHARP_F; \
Pop_Return_Error(N); \
}
case RC_INTERNAL_APPLY:
Internal_Apply:
- if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Apply_Trapper() != NIL))
+ if (Microcode_Does_Stepping &&
+ Trapping &&
+ ((Fetch_Apply_Trapper ()) != SHARP_F))
{
long Count;
- Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER));
+ Count = OBJECT_DATUM (Stack_Ref(STACK_ENV_HEADER));
Top_Of_Stack() = Fetch_Apply_Trapper();
Push(STACK_FRAME_HEADER + Count);
Stop_Trapping();
- }
+ }
Apply_Non_Trapping:
long Interrupts;
Interrupts = (PENDING_INTERRUPTS());
- Store_Expression(NIL);
- Val = NIL;
+ Store_Expression(SHARP_F);
+ Val = SHARP_F;
Prepare_Apply_Interrupt();
Interrupt(Interrupts);
}
Apply_Ucode_Hook();
- {
- fast Pointer Function;
+ {
+ fast SCHEME_OBJECT Function;
Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION));
- switch(Type_Code(Function))
- {
+ switch(OBJECT_TYPE (Function))
+ {
case TC_ENTITY:
{
*/
nargs = Pop();
- Push(Fast_Vector_Ref(Function, ENTITY_OPERATOR));
+ Push(FAST_MEMORY_REF (Function, ENTITY_OPERATOR));
Push(nargs + 1);
/* This must be done to prevent an infinite push loop by
an entity whose handler is the entity itself or some
{
fast long nargs;
- nargs = Get_Integer(Pop());
- Function = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR);
+ nargs = OBJECT_DATUM (Pop());
+ Function = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR);
{
- fast Pointer formals;
+ fast SCHEME_OBJECT formals;
Apply_Future_Check(formals,
- Fast_Vector_Ref(Function, LAMBDA_FORMALS));
+ FAST_MEMORY_REF (Function, LAMBDA_FORMALS));
- if ((nargs != Vector_Length(formals)) &&
- ((Type_Code(Function) != TC_LEXPR) ||
- (nargs < Vector_Length(formals))))
+ if ((nargs != VECTOR_LENGTH (formals)) &&
+ ((OBJECT_TYPE (Function) != TC_LEXPR) ||
+ (nargs < VECTOR_LENGTH (formals))))
{
Push(STACK_FRAME_HEADER + nargs - 1);
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
}
- if (Eval_Debug)
+ if (Eval_Debug)
{
- Print_Expression(Make_Unsigned_Fixnum(nargs),
+ Print_Expression(LONG_TO_UNSIGNED_FIXNUM(nargs),
"APPLY: Number of arguments");
}
}
{
- fast Pointer *scan;
+ fast SCHEME_OBJECT *scan;
scan = Free;
- Store_Env(Make_Pointer(TC_ENVIRONMENT, scan));
- *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, nargs);
+ Store_Env(MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan));
+ *scan++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, nargs);
while(--nargs >= 0)
*scan++ = Pop();
Free = scan;
- Reduces_To(Fast_Vector_Ref(Function, LAMBDA_SCODE));
+ Reduces_To(FAST_MEMORY_REF (Function, LAMBDA_SCODE));
}
}
case TC_CONTROL_POINT:
{
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
+ if (OBJECT_DATUM (Stack_Ref(STACK_ENV_HEADER)) !=
STACK_ENV_FIRST_ARG)
{
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
*/
case TC_PRIMITIVE:
- {
+ {
fast long nargs;
if (!IMPLEMENTED_PRIMITIVE_P(Function))
}
/* Note that the first test below will fail for lexpr primitives. */
-
- nargs = ((OBJECT_DATUM(Stack_Ref(STACK_ENV_HEADER))) -
+
+ nargs = ((OBJECT_DATUM (Stack_Ref(STACK_ENV_HEADER))) -
(STACK_ENV_FIRST_ARG - 1));
if (nargs != PRIMITIVE_ARITY(Function))
{
{
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
- Regs[REGBLOCK_LEXPR_ACTUALS] = ((Pointer) nargs);
+ Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) nargs);
}
Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
case TC_EXTENDED_PROCEDURE:
{
- Pointer lambda;
+ SCHEME_OBJECT lambda;
long nargs, nparams, formals, params, auxes,
rest_flag, size;
fast long i;
- fast Pointer *scan;
+ fast SCHEME_OBJECT *scan;
- nargs = Get_Integer(Pop()) - STACK_FRAME_HEADER;
+ nargs = OBJECT_DATUM (Pop()) - STACK_FRAME_HEADER;
- if (Eval_Debug)
+ if (Eval_Debug)
{
- Print_Expression(Make_Unsigned_Fixnum(nargs+STACK_FRAME_HEADER),
+ Print_Expression(LONG_TO_UNSIGNED_FIXNUM(nargs+STACK_FRAME_HEADER),
"APPLY: Number of arguments");
}
- lambda = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR);
+ lambda = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR);
Apply_Future_Check(Function,
- Fast_Vector_Ref(lambda, ELAMBDA_NAMES));
- nparams = Vector_Length(Function) - 1;
+ FAST_MEMORY_REF (lambda, ELAMBDA_NAMES));
+ nparams = VECTOR_LENGTH (Function) - 1;
Apply_Future_Check(Function, Get_Count_Elambda(lambda));
formals = Elambda_Formals_Count(Function);
/* Interpret(), continued */
scan = Free;
- Store_Env(Make_Pointer(TC_ENVIRONMENT, scan));
- *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, size);
+ Store_Env(MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan));
+ *scan++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, size);
if (nargs <= params)
{
for (i = (params - nargs); --i >= 0; )
*scan++ = UNASSIGNED_OBJECT;
if (rest_flag)
- *scan++ = NIL;
+ *scan++ = EMPTY_LIST;
for (i = auxes; --i >= 0; )
*scan++ = UNASSIGNED_OBJECT;
}
else
{
/* rest_flag must be true. */
- Pointer list;
-
- list = Make_Pointer(TC_LIST, (scan + size));
+ SCHEME_OBJECT list;
+
+ list = MAKE_POINTER_OBJECT (TC_LIST, (scan + size));
for (i = (params + 1); --i >= 0; )
*scan++ = Pop();
*scan++ = list;
for (i = auxes; --i >= 0; )
*scan++ = UNASSIGNED_OBJECT;
- /* Now scan == Get_Pointer(list) */
+ /* Now scan == OBJECT_ADDRESS (list) */
for (i = (nargs - params); --i >= 0; )
{
*scan++ = Pop();
- *scan = Make_Pointer(TC_LIST, (scan + 1));
+ *scan = MAKE_POINTER_OBJECT (TC_LIST, (scan + 1));
scan += 1;
}
- scan[-1] = NIL;
+ scan[-1] = EMPTY_LIST;
}
Free = scan;
case TC_COMPILED_ENTRY:
{
apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
- Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
+ OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));
Export_Registers();
Which_Way = apply_compiled_procedure();
case PRIM_APPLY:
{
- compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS +
- Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
+ compiler_apply_procedure
+ (STACK_ENV_EXTRA_SLOTS +
+ OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));
goto Internal_Apply;
}
*/
execute_compiled_backout();
- Val = Make_Non_Pointer( TC_COMPILED_ENTRY,
- Fetch_Expression());
+ Val =
+ (OBJECT_NEW_TYPE (TC_COMPILED_ENTRY, (Fetch_Expression ())));
Pop_Return_Error( Which_Way);
}
system without compiler support.
*/
- Store_Expression(NIL);
+ Store_Expression(SHARP_F);
Store_Return(RC_REENTER_COMPILED_CODE);
Pop_Return_Error(Which_Way);
}
/* Expression contains the space in which we are moving */
{
long From_Count;
- Pointer Thunk, New_Location;
+ SCHEME_OBJECT Thunk, New_Location;
- From_Count = Get_Integer(Stack_Ref(TRANSLATE_FROM_DISTANCE));
+ From_Count =
+ (UNSIGNED_FIXNUM_TO_LONG (Stack_Ref (TRANSLATE_FROM_DISTANCE)));
if (From_Count != 0)
- { Pointer Current = Stack_Ref(TRANSLATE_FROM_POINT);
- Stack_Ref(TRANSLATE_FROM_DISTANCE) = Make_Unsigned_Fixnum((From_Count - 1));
- Thunk = Fast_Vector_Ref(Current, STATE_POINT_AFTER_THUNK);
- New_Location = Fast_Vector_Ref(Current, STATE_POINT_NEARER_POINT);
+ { SCHEME_OBJECT Current = Stack_Ref(TRANSLATE_FROM_POINT);
+ Stack_Ref(TRANSLATE_FROM_DISTANCE) =
+ (LONG_TO_UNSIGNED_FIXNUM (From_Count - 1));
+ Thunk = FAST_MEMORY_REF (Current, STATE_POINT_AFTER_THUNK);
+ New_Location = FAST_MEMORY_REF (Current, STATE_POINT_NEARER_POINT);
Stack_Ref(TRANSLATE_FROM_POINT) = New_Location;
if ((From_Count == 1) &&
- (Stack_Ref(TRANSLATE_TO_DISTANCE) == Make_Unsigned_Fixnum(0)))
+ (Stack_Ref(TRANSLATE_TO_DISTANCE) == LONG_TO_UNSIGNED_FIXNUM(0)))
Stack_Pointer = Simulate_Popping(4);
else Save_Cont();
}
else
{
long To_Count;
- fast Pointer To_Location;
+ fast SCHEME_OBJECT To_Location;
fast long i;
- To_Count = (Get_Integer(Stack_Ref(TRANSLATE_TO_DISTANCE))- 1);
+ To_Count =
+ (UNSIGNED_FIXNUM_TO_LONG (Stack_Ref (TRANSLATE_TO_DISTANCE)) - 1);
To_Location = Stack_Ref(TRANSLATE_TO_POINT);
for (i = 0; i < To_Count; i++)
{
- To_Location = Fast_Vector_Ref(To_Location, STATE_POINT_NEARER_POINT);
+ To_Location =
+ (FAST_MEMORY_REF (To_Location, STATE_POINT_NEARER_POINT));
}
- Thunk = Fast_Vector_Ref(To_Location, STATE_POINT_BEFORE_THUNK);
+ Thunk = FAST_MEMORY_REF (To_Location, STATE_POINT_BEFORE_THUNK);
New_Location = To_Location;
- Stack_Ref(TRANSLATE_TO_DISTANCE) = Make_Unsigned_Fixnum(To_Count);
- if (To_Count == 0)
+ Stack_Ref(TRANSLATE_TO_DISTANCE) = LONG_TO_UNSIGNED_FIXNUM(To_Count);
+ if (To_Count == 0)
{
Stack_Pointer = Simulate_Popping(4);
}
Save_Cont();
}
}
- if (Fetch_Expression() != NIL)
+ if ((Fetch_Expression ()) != SHARP_F)
{
- Vector_Set(Fetch_Expression(), STATE_SPACE_NEAREST_POINT, New_Location);
+ MEMORY_SET
+ ((Fetch_Expression ()), STATE_SPACE_NEAREST_POINT, New_Location);
}
else
{
End_Subproblem();
Push(Val); /* Argument value */
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB1_FN_SLOT));
+ Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB1_FN_SLOT));
Primitive_Internal_Apply:
- if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Apply_Trapper() != NIL))
+ if (Microcode_Does_Stepping &&
+ Trapping &&
+ ((Fetch_Apply_Trapper ()) != SHARP_F))
{
/* Does this work in the stacklet case?
We may have a non-contiguous frame. -- Jinx
*/
- Will_Push(3);
+ Will_Push(3);
Push(Fetch_Expression());
Push(Fetch_Apply_Trapper());
Push(STACK_FRAME_HEADER + 1 +
*/
{
- fast Pointer primitive;
+ fast SCHEME_OBJECT primitive;
primitive = Fetch_Expression();
Export_Regs_Before_Primitive();
End_Subproblem();
Push(Val); /* Value of arg. 1 */
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB2_FN_SLOT));
+ Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB2_FN_SLOT));
goto Primitive_Internal_Apply;
case RC_PCOMB2_DO_1:
End_Subproblem();
Push(Val); /* Save value of arg. 1 */
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB3_FN_SLOT));
+ Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB3_FN_SLOT));
goto Primitive_Internal_Apply;
/* Interpret() continues on the next page */
case RC_PCOMB3_DO_1:
{
- Pointer Temp;
+ SCHEME_OBJECT Temp;
Temp = Pop(); /* Value of arg. 3 */
Restore_Env();
case RC_PURIFY_GC_1:
{
- Pointer GC_Daemon_Proc, Result;
+ SCHEME_OBJECT GC_Daemon_Proc, Result;
RENAME_CRITICAL_SECTION ("purify pass 2");
Export_Registers();
Result = Purify_Pass_2(Fetch_Expression());
Import_Registers();
- if (Result == NIL)
+ if (Result == SHARP_F)
{
/* 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. */
- RESULT_OF_PURIFY (NIL);
+ RESULT_OF_PURIFY (SHARP_F);
EXIT_CRITICAL_SECTION ({ Export_Registers(); });
break;
}
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
- if (GC_Daemon_Proc == NIL)
+ if (GC_Daemon_Proc == SHARP_F)
{
RESULT_OF_PURIFY (SHARP_T);
EXIT_CRITICAL_SECTION ({ Export_Registers(); });
break;
}
RENAME_CRITICAL_SECTION( "purify daemon 2");
- Store_Expression(NIL);
+ Store_Expression(SHARP_F);
Store_Return(RC_PURIFY_GC_2);
Save_Cont();
Will_Push(2);
break;
case RC_REPEAT_DISPATCH:
- Sign_Extend(Fetch_Expression(), Which_Way);
+ Which_Way = (FIXNUM_TO_LONG (Fetch_Expression ()));
Restore_Env();
Val = Pop();
Restore_Cont();
case RC_RESTORE_DONT_COPY_HISTORY:
{
- Pointer Stacklet;
+ SCHEME_OBJECT Stacklet;
- Prev_Restore_History_Offset = Get_Integer(Pop());
+ Prev_Restore_History_Offset = OBJECT_DATUM (Pop());
Stacklet = Pop();
- History = Get_Pointer(Fetch_Expression());
+ History = OBJECT_ADDRESS (Fetch_Expression());
if (Prev_Restore_History_Offset == 0)
{
Prev_Restore_History_Stacklet = NULL;
}
- else if (Stacklet == NIL)
+ else if (Stacklet == SHARP_F)
{
Prev_Restore_History_Stacklet = NULL;
}
else
{
- Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ Prev_Restore_History_Stacklet = OBJECT_ADDRESS (Stacklet);
}
break;
}
case RC_RESTORE_HISTORY:
{
- Pointer Stacklet;
+ SCHEME_OBJECT Stacklet;
Export_Registers();
if (! Restore_History(Fetch_Expression()))
Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1));
}
Import_Registers();
- Prev_Restore_History_Offset = Get_Integer(Pop());
+ Prev_Restore_History_Offset = OBJECT_DATUM (Pop());
Stacklet = Pop();
if (Prev_Restore_History_Offset == 0)
Prev_Restore_History_Stacklet = NULL;
else
- { if (Stacklet == NIL)
+ { if (Stacklet == SHARP_F)
{ Prev_Restore_History_Stacklet = NULL;
Get_End_Of_Stacklet()[-Prev_Restore_History_Offset] =
- Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
+ MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_HISTORY);
}
else
- { Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ { Prev_Restore_History_Stacklet = OBJECT_ADDRESS (Stacklet);
Prev_Restore_History_Stacklet[-Prev_Restore_History_Offset] =
- Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
+ MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_HISTORY);
}
}
break;
case RC_RESTORE_FLUIDS:
Fluid_Bindings = Fetch_Expression();
- /* Why is this here? -- Jinx */
+ /* Why is this here? -- Jinx */
COMPILER_SETUP_INTERRUPT();
break;
- case RC_RESTORE_INT_MASK:
- SET_INTERRUPT_MASK(Get_Integer(Fetch_Expression()));
+ case RC_RESTORE_INT_MASK:
+ SET_INTERRUPT_MASK (UNSIGNED_FIXNUM_TO_LONG (Fetch_Expression()));
break;
/* Interpret() continues on the next page */
/* Interpret(), continued */
case RC_RESTORE_TO_STATE_POINT:
- { Pointer Where_To_Go = Fetch_Expression();
+ { SCHEME_OBJECT Where_To_Go = Fetch_Expression();
Will_Push(CONTINUATION_SIZE);
/* Restore the contents of Val after moving to point */
Store_Expression(Val);
/* Interpret(), continued */
case RC_SNAP_NEED_THUNK:
- Vector_Set(Fetch_Expression(), THUNK_SNAPPED, SHARP_T);
- Vector_Set(Fetch_Expression(), THUNK_VALUE, Val);
+ MEMORY_SET (Fetch_Expression(), THUNK_SNAPPED, SHARP_T);
+ MEMORY_SET (Fetch_Expression(), THUNK_VALUE, Val);
break;
case RC_AFTER_MEMORY_UPDATE:
/* -*-C-*-
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/lookup.c,v 9.41 1988/09/29 04:59:45 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/lookup.c,v 9.42 1989/09/20 23:10:03 cph Exp $
*
* This file contains symbol lookup and modification routines. See
* Hal Abelson for a paper describing and justifying the algorithm.
/* Useful constants. */
/* This is returned by various procedures to cause a Scheme
- unbound variable error to be signalled.
+ unbound variable error to be signalled.
*/
-Pointer unbound_trap_object[] = { UNBOUND_OBJECT };
+SCHEME_OBJECT unbound_trap_object[] = { UNBOUND_OBJECT };
/* This is returned by lookup to force a deep lookup when the variable
needs to be recompiled.
*/
-Pointer uncompiled_trap_object[] = { DANGEROUS_UNBOUND_OBJECT };
+SCHEME_OBJECT uncompiled_trap_object[] = { DANGEROUS_UNBOUND_OBJECT };
/* This is returned by lookup to cause a Scheme broken compiled
variable error to be signalled.
*/
-Pointer illegal_trap_object[] = { ILLEGAL_OBJECT };
+SCHEME_OBJECT illegal_trap_object[] = { ILLEGAL_OBJECT };
/* This is passed to deep_lookup as the variable to compile when
we don't really have a variable.
*/
-Pointer fake_variable_object[3];
+SCHEME_OBJECT fake_variable_object[3];
\f
/* scan_frame searches a frame for a given name.
If it finds the names, it stores into hunk the path by which it was
cell if the variable was not found in this frame.
*/
-extern Pointer *scan_frame();
+extern SCHEME_OBJECT *scan_frame();
-Pointer *
+SCHEME_OBJECT *
scan_frame(frame, sym, hunk, depth, unbound_valid_p)
- Pointer frame, sym, *hunk;
+ SCHEME_OBJECT frame, sym, *hunk;
long depth;
Boolean unbound_valid_p;
{
Lock_Handle compile_serializer;
- fast Pointer *scan, temp;
+ fast SCHEME_OBJECT *scan, temp;
fast long count;
- temp = Vector_Ref(frame, ENVIRONMENT_FUNCTION);
+ temp = MEMORY_REF (frame, ENVIRONMENT_FUNCTION);
- if (OBJECT_TYPE(temp) == AUX_LIST_TYPE)
+ if (OBJECT_TYPE (temp) == AUX_LIST_TYPE)
{
/* Search for an auxiliary binding. */
- Pointer *start;
+ SCHEME_OBJECT *start;
- scan = Get_Pointer(temp);
+ scan = OBJECT_ADDRESS (temp);
start = scan;
count = Lexical_Offset(scan[AUX_LIST_COUNT]);
scan += AUX_LIST_FIRST;
while (--count >= 0)
{
- if (Fast_Vector_Ref(*scan, CONS_CAR) == sym)
+ if (FAST_PAIR_CAR (*scan) == sym)
{
- Pointer *cell;
+ SCHEME_OBJECT *cell;
- cell = Nth_Vector_Loc(*scan, CONS_CDR);
- if (Fetch(cell[0]) == DANGEROUS_UNBOUND_OBJECT)
+ cell = PAIR_CDR_LOC (*scan);
+ if (MEMORY_FETCH (cell[0]) == DANGEROUS_UNBOUND_OBJECT)
{
/* A dangerous unbound object signals that
a definition here must become dangerous,
but is not a real bining.
*/
- return (unbound_valid_p ? (cell) : ((Pointer *) NULL));
+ return (unbound_valid_p ? (cell) : ((SCHEME_OBJECT *) NULL));
}
setup_lock(compile_serializer, hunk);
- hunk[VARIABLE_COMPILED_TYPE] = Make_Non_Pointer(AUX_REF, depth);
+ hunk[VARIABLE_COMPILED_TYPE] = MAKE_OBJECT (AUX_REF, depth);
hunk[VARIABLE_OFFSET] = Make_Local_Offset(scan - start);
remove_lock(compile_serializer);
return (cell);
}
- scan += 1;
+ scan += 1;
}
- temp = Vector_Ref(temp, ENV_EXTENSION_PROCEDURE);
+ temp = MEMORY_REF (temp, ENV_EXTENSION_PROCEDURE);
}
\f
/* Search for a formal parameter. */
- temp = Fast_Vector_Ref(Fast_Vector_Ref(temp, PROCEDURE_LAMBDA_EXPR),
+ temp = FAST_MEMORY_REF (FAST_MEMORY_REF (temp, PROCEDURE_LAMBDA_EXPR),
LAMBDA_FORMALS);
- for (count = Vector_Length(temp) - 1,
- scan = Nth_Vector_Loc(temp, VECTOR_DATA + 1);
+ for (count = VECTOR_LENGTH (temp) - 1,
+ scan = MEMORY_LOC (temp, VECTOR_DATA + 1);
count > 0;
count -= 1,
scan += 1)
{
fast long offset;
- offset = 1 + Vector_Length(temp) - count;
+ offset = 1 + VECTOR_LENGTH (temp) - count;
setup_lock(compile_serializer, hunk);
if (depth != 0)
{
- hunk[VARIABLE_COMPILED_TYPE] = Make_Non_Pointer(FORMAL_REF, depth);
+ hunk[VARIABLE_COMPILED_TYPE] = MAKE_OBJECT (FORMAL_REF, depth);
hunk[VARIABLE_OFFSET] = Make_Local_Offset(offset);
}
else
{
hunk[VARIABLE_COMPILED_TYPE] = Make_Local_Offset(offset);
- hunk[VARIABLE_OFFSET] = NIL;
+ hunk[VARIABLE_OFFSET] = SHARP_F;
}
remove_lock(compile_serializer);
- return (Nth_Vector_Loc(frame, offset));
+ return (MEMORY_LOC (frame, offset));
}
}
- return ((Pointer *) NULL);
+ return ((SCHEME_OBJECT *) NULL);
}
\f
/* The lexical lookup procedure.
deep_lookup searches env for an occurrence of sym. When it finds
it, it stores into hunk the path by which it was found, so that
future references do not spend the time to find it again.
- It returns a pointer to the value cell, or a bogus value cell if
+ It returns a pointer to the value cell, or a bogus value cell if
the variable was unbound.
*/
-Pointer *
+SCHEME_OBJECT *
deep_lookup(env, sym, hunk)
- Pointer env, sym, *hunk;
+ SCHEME_OBJECT env, sym, *hunk;
{
Lock_Handle compile_serializer;
- fast Pointer frame;
+ fast SCHEME_OBJECT frame;
fast long depth;
for (depth = 0, frame = env;
- OBJECT_TYPE(frame) != GLOBAL_ENV;
+ OBJECT_TYPE (frame) != GLOBAL_ENV;
depth += 1,
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION),
+ frame = FAST_MEMORY_REF (MEMORY_REF (frame, ENVIRONMENT_FUNCTION),
PROCEDURE_ENVIRONMENT))
{
- fast Pointer *cell;
+ fast SCHEME_OBJECT *cell;
cell = scan_frame(frame, sym, hunk, depth, false);
- if (cell != ((Pointer *) NULL))
+ if (cell != ((SCHEME_OBJECT *) NULL))
{
return (cell);
}
/* The reference is global. */
- if (OBJECT_DATUM(frame) != GO_TO_GLOBAL)
+ if (OBJECT_DATUM (frame) != GO_TO_GLOBAL)
{
return (unbound_trap_object);
}
setup_lock(compile_serializer, hunk);
- hunk[VARIABLE_COMPILED_TYPE] = Make_New_Pointer(TC_UNINTERNED_SYMBOL, sym);
- hunk[VARIABLE_OFFSET] = NIL;
+ hunk[VARIABLE_COMPILED_TYPE] = (OBJECT_NEW_TYPE (TC_UNINTERNED_SYMBOL, sym));
+ hunk[VARIABLE_OFFSET] = SHARP_F;
remove_lock(compile_serializer);
- return (Nth_Vector_Loc(sym, SYMBOL_GLOBAL_VALUE));
+ return (MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE));
}
\f
/* Shallow lookup performed "out of line" by various procedures.
It takes care of invoking deep_lookup when necessary.
*/
-extern Pointer *lookup_cell();
+extern SCHEME_OBJECT *lookup_cell();
-Pointer *
+SCHEME_OBJECT *
lookup_cell(hunk, env)
- Pointer *hunk, env;
+ SCHEME_OBJECT *hunk, env;
{
- Pointer *cell, value;
+ SCHEME_OBJECT *cell, value;
long trap_kind;
lookup(cell, env, hunk, repeat_lookup_cell);
- value = Fetch(cell[0]);
+ value = MEMORY_FETCH (cell[0]);
- if (OBJECT_TYPE(value) != TC_REFERENCE_TRAP)
+ if (OBJECT_TYPE (value) != TC_REFERENCE_TRAP)
{
return (cell);
}
long
deep_lookup_end(cell, hunk)
- Pointer *cell;
- Pointer *hunk;
+ SCHEME_OBJECT *cell;
+ SCHEME_OBJECT *hunk;
{
long trap_kind, return_value;
Boolean repeat_p;
do {
repeat_p = false;
- Val = Fetch(cell[0]);
- FUTURE_VARIABLE_SPLICE (((Pointer) cell), 0, Val);
+ Val = MEMORY_FETCH (cell[0]);
+ FUTURE_VARIABLE_SPLICE (((SCHEME_OBJECT) cell), 0, Val);
if (!(REFERENCE_TRAP_P(Val)))
{
return (PRIM_DONE);
\f
case TRAP_DANGEROUS:
{
- Pointer trap_value;
+ SCHEME_OBJECT trap_value;
trap_value = Val;
- Val = (Vector_Ref (trap_value, TRAP_EXTRA));
+ Val = (MEMORY_REF (trap_value, TRAP_EXTRA));
FUTURE_VARIABLE_SPLICE (trap_value, TRAP_EXTRA, Val);
return_value = PRIM_DONE;
break;
case TRAP_COMPILER_CACHED:
case TRAP_COMPILER_CACHED_DANGEROUS:
- cell = Nth_Vector_Loc(Vector_Ref(Val, TRAP_EXTRA),
- TRAP_EXTENSION_CELL);
+ cell = MEMORY_LOC (MEMORY_REF (Val, TRAP_EXTRA), TRAP_EXTENSION_CELL);
repeat_p = true;
if (trap_kind == TRAP_COMPILER_CACHED)
continue;
setup_lock(compile_serializer, hunk);
hunk[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- hunk[VARIABLE_OFFSET] = NIL;
+ hunk[VARIABLE_OFFSET] = SHARP_F;
remove_lock(compile_serializer);
}
long
lookup_end(cell, env, hunk)
- Pointer *cell, env, *hunk;
+ SCHEME_OBJECT *cell, env, *hunk;
{
long trap_kind;
lookup_end_restart:
- Val = Fetch(cell[0]);
- FUTURE_VARIABLE_SPLICE (((Pointer) cell), 0, Val);
+ Val = MEMORY_FETCH (cell[0]);
+ FUTURE_VARIABLE_SPLICE (((SCHEME_OBJECT) cell), 0, Val);
if (!(REFERENCE_TRAP_P(Val)))
{
hunk));
case TRAP_COMPILER_CACHED:
- cell = Nth_Vector_Loc(Vector_Ref(Val, TRAP_EXTRA),
- TRAP_EXTENSION_CELL);
+ cell = MEMORY_LOC (MEMORY_REF (Val, TRAP_EXTRA), TRAP_EXTENSION_CELL);
goto lookup_end_restart;
case TRAP_FLUID:
long
deep_assignment_end(cell, hunk, value, force)
- fast Pointer *cell;
- Pointer *hunk, value;
+ fast SCHEME_OBJECT *cell;
+ SCHEME_OBJECT *hunk, value;
Boolean force;
{
Lock_Handle set_serializer;
long trap_kind, return_value;
- Pointer bogus_unassigned, extension, saved_extension, saved_value;
+ SCHEME_OBJECT bogus_unassigned, extension, saved_extension, saved_value;
Boolean repeat_p, uncompile_p, fluid_lock_p;
/* State variables */
- saved_extension = NIL;
+ saved_extension = SHARP_F;
uncompile_p = false;
fluid_lock_p = false;
\f
switch(trap_kind)
{
case TRAP_DANGEROUS:
- Val = Vector_Ref(Val, TRAP_EXTRA);
+ Val = MEMORY_REF (Val, TRAP_EXTRA);
if (value == UNASSIGNED_OBJECT)
{
*cell = DANGEROUS_UNASSIGNED_OBJECT;
}
else
{
- Do_Store_No_Lock ((Nth_Vector_Loc (*cell, TRAP_EXTRA)), value);
+ Do_Store_No_Lock ((MEMORY_LOC (*cell, TRAP_EXTRA)), value);
}
UNCOMPILE(PRIM_DONE);
UNCOMPILE(ERR_UNBOUND_VARIABLE)
}
/* Fall through */
-
+
case TRAP_UNASSIGNED:
Val = bogus_unassigned;
*cell = value;
Val = bogus_unassigned;
if (value != UNASSIGNED_OBJECT)
{
- Pointer result;
+ SCHEME_OBJECT result;
if (GC_allocate_test(2))
{
Request_GC(2);
ABORT(PRIM_INTERRUPT);
}
- result = Make_Pointer(TC_REFERENCE_TRAP, Free);
+ result = MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free);
*Free++ = DANGEROUS_OBJECT;
*Free++ = value;
*cell = result;
/* Fall through */
case TRAP_COMPILER_CACHED:
- extension = Fast_Vector_Ref(Val, TRAP_EXTRA);
+ extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
compiler_cache_assignment:
{
- Pointer references;
+ SCHEME_OBJECT references;
/* Unlock and lock at the new value cell. */
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
- cell = Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
+ cell = MEMORY_LOC (extension, TRAP_EXTENSION_CELL);
update_lock(set_serializer, cell);
- if (Fast_Vector_Ref(references, TRAP_REFERENCES_OPERATOR) != NIL)
+ if (FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR) != SHARP_F)
{
- if (saved_extension != NIL)
+ if (saved_extension != SHARP_F)
{
ABORT(ERR_BROKEN_VARIABLE_CACHE);
}
UNCOMPILE(ERR_ILLEGAL_REFERENCE_TRAP);
}
} while (repeat_p);
-\f
- if (saved_extension != NIL)
+\f
+ if (saved_extension != SHARP_F)
{
long recache_uuo_links();
*/
update_lock(set_serializer,
- Nth_Vector_Loc(saved_extension, TRAP_EXTENSION_CELL));
+ MEMORY_LOC (saved_extension, TRAP_EXTENSION_CELL));
}
/* NOTE:
recache_uuo_links can take an arbitrary amount of time since
there may be an internal lock and the code may have to uncache
arbitrarily many links.
- Deadlock should not occur since both locks are always acquired
+ Deadlock should not occur since both locks are always acquired
in the same order.
*/
setup_lock(compile_serializer, hunk);
hunk[VARIABLE_COMPILED_TYPE] = UNCOMPILED_VARIABLE;
- hunk[VARIABLE_OFFSET] = NIL;
+ hunk[VARIABLE_OFFSET] = SHARP_F;
remove_lock(compile_serializer);
}
long
assignment_end(cell, env, hunk, value)
- fast Pointer *cell;
- Pointer env, *hunk, value;
+ fast SCHEME_OBJECT *cell;
+ SCHEME_OBJECT env, *hunk, value;
{
Lock_Handle set_serializer;
- Pointer bogus_unassigned;
+ SCHEME_OBJECT bogus_unassigned;
long temp;
bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
\f
case TRAP_COMPILER_CACHED:
{
- Pointer extension, references;
+ SCHEME_OBJECT extension, references;
- extension = Fast_Vector_Ref(Val, TRAP_EXTRA);
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
+ extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
- if (Fast_Vector_Ref(references, TRAP_REFERENCES_OPERATOR) != NIL)
+ if (FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR) != SHARP_F)
{
/* There are uuo links.
wimp out and let deep_assignment_end handle it.
remove_lock(set_serializer);
return (deep_assignment_end(cell, hunk, value, false));
}
- cell = Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL);
+ cell = MEMORY_LOC (extension, TRAP_EXTENSION_CELL);
update_lock(set_serializer, cell);
goto assignment_end_after_lock;
}
this processor's fluid "binding" list. It is just like ASSQ.
*/
-Pointer *
+SCHEME_OBJECT *
lookup_fluid(trap)
- fast Pointer trap;
+ fast SCHEME_OBJECT trap;
{
- fast Pointer fluids, *this_pair;
+ fast SCHEME_OBJECT fluids, *this_pair;
fluids = Fluid_Bindings;
while (PAIR_P(fluids))
{
- this_pair = Get_Pointer(Fast_Vector_Ref(fluids, CONS_CAR));
+ this_pair = OBJECT_ADDRESS (FAST_PAIR_CAR (fluids));
if (this_pair[CONS_CAR] == trap)
{
return (&this_pair[CONS_CDR]);
}
- fluids = Fast_Vector_Ref(fluids, CONS_CDR);
+ fluids = FAST_PAIR_CDR (fluids);
}
/* Not found in fluid binding alist, so use default. */
fprintf(stderr, "Fluid not found, using default.\n");
}
- return (Nth_Vector_Loc(trap, TRAP_EXTRA));
+ return (MEMORY_LOC (trap, TRAP_EXTRA));
}
\f
/* Utilities for definition.
long
definition(cell, value, shadowed_p)
- Pointer *cell, value;
+ SCHEME_OBJECT *cell, value;
Boolean shadowed_p;
{
if (shadowed_p)
return (redefinition(cell, value));
}
}
-}
+}
\f
long
dangerize(cell, sym)
- fast Pointer *cell;
- Pointer sym;
+ fast SCHEME_OBJECT *cell;
+ SCHEME_OBJECT sym;
{
Lock_Handle set_serializer;
fast long temp;
- Pointer trap;
+ SCHEME_OBJECT trap;
setup_lock(set_serializer, cell);
if (!(REFERENCE_TRAP_P(*cell)))
Request_GC(2);
return (PRIM_INTERRUPT);
}
- trap = Make_Pointer(TC_REFERENCE_TRAP, Free);
+ trap = MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free);
*Free++ = DANGEROUS_OBJECT;
*Free++ = *cell;
*cell = trap;
case TRAP_COMPILER_CACHED:
Do_Store_No_Lock
- ((Nth_Vector_Loc (*cell, TRAP_TAG)),
- (Make_Unsigned_Fixnum (TRAP_COMPILER_CACHED_DANGEROUS)));
+ ((MEMORY_LOC (*cell, TRAP_TAG)),
+ (LONG_TO_UNSIGNED_FIXNUM (TRAP_COMPILER_CACHED_DANGEROUS)));
/* Fall through */
case TRAP_COMPILER_CACHED_DANGEROUS:
case TRAP_FLUID:
Do_Store_No_Lock
- ((Nth_Vector_Loc (*cell, TRAP_TAG)),
- (Make_Unsigned_Fixnum (TRAP_FLUID_DANGEROUS)));
+ ((MEMORY_LOC (*cell, TRAP_TAG)),
+ (LONG_TO_UNSIGNED_FIXNUM (TRAP_FLUID_DANGEROUS)));
break;
case TRAP_UNBOUND:
long
extend_frame(env, sym, value, original_frame, recache_p)
- Pointer env, sym, value, original_frame;
+ SCHEME_OBJECT env, sym, value, original_frame;
Boolean recache_p;
{
Lock_Handle extension_serializer;
- Pointer extension, the_procedure;
- fast Pointer *scan;
+ SCHEME_OBJECT extension, the_procedure;
+ fast SCHEME_OBJECT *scan;
long aux_count;
- if (OBJECT_TYPE(env) == GLOBAL_ENV)
+ if (OBJECT_TYPE (env) == GLOBAL_ENV)
{
/* *UNDEFINE*: If undefine is ever implemented, this code need not
change: There are no shadowed bindings that need to be
recached.
*/
- if (OBJECT_DATUM(env) != GO_TO_GLOBAL)
+ if (OBJECT_DATUM (env) != GO_TO_GLOBAL)
{
return ((env == original_frame) ? ERR_BAD_FRAME : PRIM_DONE);
}
else if (env == original_frame)
{
- return (redefinition(Nth_Vector_Loc(sym, SYMBOL_GLOBAL_VALUE),
+ return (redefinition(MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE),
value));
}
else
{
- return (dangerize(Nth_Vector_Loc(sym, SYMBOL_GLOBAL_VALUE), sym));
+ return (dangerize(MEMORY_LOC (sym, SYMBOL_GLOBAL_VALUE), sym));
}
}
\f
- the_procedure = Vector_Ref(env, ENVIRONMENT_FUNCTION);
- if (OBJECT_TYPE(the_procedure) == AUX_LIST_TYPE)
- the_procedure = Vector_Ref(the_procedure, ENV_EXTENSION_PROCEDURE);
+ the_procedure = MEMORY_REF (env, ENVIRONMENT_FUNCTION);
+ if (OBJECT_TYPE (the_procedure) == AUX_LIST_TYPE)
+ the_procedure = MEMORY_REF (the_procedure, ENV_EXTENSION_PROCEDURE);
/* Search the formals. */
{
fast long count;
- Pointer formals;
+ SCHEME_OBJECT formals;
- formals = Fast_Vector_Ref(Fast_Vector_Ref(the_procedure,
+ formals = FAST_MEMORY_REF (FAST_MEMORY_REF (the_procedure,
PROCEDURE_LAMBDA_EXPR),
LAMBDA_FORMALS);
- for (count = Vector_Length(formals) - 1,
- scan = Nth_Vector_Loc(formals, VECTOR_DATA + 1);
+ for (count = VECTOR_LENGTH (formals) - 1,
+ scan = MEMORY_LOC (formals, VECTOR_DATA + 1);
count > 0;
count -= 1)
{
{
long offset;
- offset = 1 + Vector_Length(formals) - count;
+ offset = 1 + VECTOR_LENGTH (formals) - count;
if (env == original_frame)
{
- return (redefinition(Nth_Vector_Loc(env, offset), value));
+ return (redefinition(MEMORY_LOC (env, offset), value));
}
else
{
- return (dangerize(Nth_Vector_Loc(env, offset), sym));
+ return (dangerize(MEMORY_LOC (env, offset), sym));
}
}
}
redo_aux_lookup:
- setup_lock(extension_serializer, Get_Pointer(env));
- extension = Fast_Vector_Ref(env, ENVIRONMENT_FUNCTION);
- if (OBJECT_TYPE(extension) != AUX_LIST_TYPE)
+ setup_lock(extension_serializer, OBJECT_ADDRESS (env));
+ extension = FAST_MEMORY_REF (env, ENVIRONMENT_FUNCTION);
+ if (OBJECT_TYPE (extension) != AUX_LIST_TYPE)
{
fast long i;
return (PRIM_INTERRUPT);
}
scan = Free;
- extension = Make_Pointer(AUX_LIST_TYPE, scan);
+ extension = MAKE_POINTER_OBJECT (AUX_LIST_TYPE, scan);
scan[ENV_EXTENSION_HEADER] =
- Make_Non_Pointer(TC_MANIFEST_VECTOR, (AUX_LIST_INITIAL_SIZE - 1));
+ MAKE_OBJECT (TC_MANIFEST_VECTOR, (AUX_LIST_INITIAL_SIZE - 1));
scan[ENV_EXTENSION_PARENT_FRAME] =
- Vector_Ref(the_procedure, PROCEDURE_ENVIRONMENT);
+ MEMORY_REF (the_procedure, PROCEDURE_ENVIRONMENT);
scan[ENV_EXTENSION_PROCEDURE] = the_procedure;
for (i = AUX_CHUNK_SIZE, scan += AUX_LIST_FIRST;
--i >= 0;)
- *scan++ = NIL;
+ *scan++ = SHARP_F;
Free = scan;
- Do_Store_No_Lock ((Nth_Vector_Loc (env, ENVIRONMENT_FUNCTION)), extension);
+ Do_Store_No_Lock ((MEMORY_LOC (env, ENVIRONMENT_FUNCTION)), extension);
}
- aux_count = Lexical_Offset(Fast_Vector_Ref(extension, AUX_LIST_COUNT));
+ aux_count = Lexical_Offset(FAST_MEMORY_REF (extension, AUX_LIST_COUNT));
remove_lock(extension_serializer);
\f
/* Search the aux list. */
{
fast long count;
- scan = Get_Pointer(extension);
+ scan = OBJECT_ADDRESS (extension);
count = aux_count;
scan += AUX_LIST_FIRST;
while (--count >= 0)
{
- if (Fast_Vector_Ref(*scan, CONS_CAR) == sym)
+ if (FAST_PAIR_CAR (*scan) == sym)
{
- scan = Nth_Vector_Loc(*scan, CONS_CDR);
+ scan = PAIR_CDR_LOC (*scan);
/* This is done only because of compiler cached variables.
In their absence, this conditional is unnecessary.
of bindings if undefine is ever implemented. See the
comments above.
*/
- if (Fetch(scan[0]) == DANGEROUS_UNBOUND_OBJECT)
+ if (MEMORY_FETCH (scan[0]) == DANGEROUS_UNBOUND_OBJECT)
{
long temp;
-
+
temp =
compiler_uncache
- (deep_lookup(Fast_Vector_Ref(extension,
+ (deep_lookup(FAST_MEMORY_REF (extension,
ENV_EXTENSION_PARENT_FRAME),
sym,
fake_variable_object),
return (dangerize(scan, sym));
}
}
- scan += 1;
+ scan += 1;
}
}
\f
fast long temp;
temp =
- extend_frame(Fast_Vector_Ref(extension, ENV_EXTENSION_PARENT_FRAME),
- sym, NIL, original_frame, recache_p);
+ extend_frame(FAST_MEMORY_REF (extension, ENV_EXTENSION_PARENT_FRAME),
+ sym, SHARP_F, original_frame, recache_p);
if (temp != PRIM_DONE)
{
something in the meantime in this frame.
*/
- setup_lock(extension_serializer, Get_Pointer(env));
- temp = Lexical_Offset(Fast_Vector_Ref(extension, AUX_LIST_COUNT));
+ setup_lock(extension_serializer, OBJECT_ADDRESS (env));
+ temp = Lexical_Offset(FAST_MEMORY_REF (extension, AUX_LIST_COUNT));
- if ((extension != Fast_Vector_Ref(env, ENVIRONMENT_FUNCTION)) ||
+ if ((extension != FAST_MEMORY_REF (env, ENVIRONMENT_FUNCTION)) ||
(temp != aux_count))
{
remove_lock(extension_serializer);
goto redo_aux_lookup;
}
-\f
- scan = Get_Pointer(extension);
+\f
+ scan = OBJECT_ADDRESS (extension);
- if ((temp + (AUX_LIST_FIRST - 1)) == Get_Integer(scan[VECTOR_LENGTH]))
+ if ((temp + (AUX_LIST_FIRST - 1)) == (VECTOR_LENGTH (extension)))
{
fast long i;
- fast Pointer *fast_free;
+ fast SCHEME_OBJECT *fast_free;
i = ((2 * temp) + AUX_LIST_FIRST);
i -= 1;
scan += 1;
- *fast_free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, i);
+ *fast_free++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, i);
for (i = (temp + (AUX_LIST_FIRST - 1)); --i >= 0; )
*fast_free++ = *scan++;
for (i = temp; --i >= 0; )
- *fast_free++ = NIL;
+ *fast_free++ = SHARP_F;
scan = Free;
Free = fast_free;
Do_Store_No_Lock
- ((Nth_Vector_Loc (env, ENVIRONMENT_FUNCTION)),
- (Make_Pointer (AUX_LIST_TYPE, scan)));
+ ((MEMORY_LOC (env, ENVIRONMENT_FUNCTION)),
+ (MAKE_POINTER_OBJECT (AUX_LIST_TYPE, scan)));
}
-\f
+\f
if (GC_allocate_test(2))
{
remove_lock(extension_serializer);
}
{
- Pointer result;
+ SCHEME_OBJECT result;
- result = Make_Pointer(TC_LIST, Free);
+ result = MAKE_POINTER_OBJECT (TC_LIST, Free);
*Free++ = sym;
*Free++ = DANGEROUS_UNBOUND_OBJECT;
long
Lex_Ref(env, var)
- Pointer env, var;
+ SCHEME_OBJECT env, var;
{
- fast Pointer *cell;
- Pointer *hunk;
+ fast SCHEME_OBJECT *cell;
+ SCHEME_OBJECT *hunk;
- hunk = Get_Pointer(var);
+ hunk = OBJECT_ADDRESS (var);
lookup(cell, env, hunk, repeat_lex_ref_lookup);
return (lookup_end(cell, env, hunk));
}
long
Symbol_Lex_Ref(env, sym)
- Pointer env, sym;
+ SCHEME_OBJECT env, sym;
{
return (deep_lookup_end(deep_lookup(env, sym, fake_variable_object),
fake_variable_object));
long
Lex_Set(env, var, value)
- Pointer env, var, value;
+ SCHEME_OBJECT env, var, value;
{
- fast Pointer *cell;
- Pointer *hunk;
+ fast SCHEME_OBJECT *cell;
+ SCHEME_OBJECT *hunk;
- hunk = Get_Pointer(var);
+ hunk = OBJECT_ADDRESS (var);
lookup(cell, env, hunk, repeat_lex_set_lookup);
return (assignment_end(cell, env, hunk, value));
}
long
Symbol_Lex_Set(env, sym, value)
- Pointer env, sym, value;
+ SCHEME_OBJECT env, sym, value;
{
return (deep_assignment_end(deep_lookup(env, sym, fake_variable_object),
fake_variable_object,
\f
long
Local_Set(env, sym, value)
- Pointer env, sym, value;
+ SCHEME_OBJECT env, sym, value;
{
long result;
{
fprintf(stderr,
"\n;; Local_Set: defining %s.",
- Scheme_String_To_C_String(Vector_Ref(sym, SYMBOL_NAME)));
+ (STRING_LOC ((MEMORY_REF (sym, SYMBOL_NAME)), 0)));
}
result = extend_frame(env, sym, value, env, true);
Val = sym;
long
safe_lex_ref (env, var)
- Pointer env, var;
+ SCHEME_OBJECT env, var;
{
return (safe_reference_transform (Lex_Ref (env, var)));
}
long
safe_symbol_lex_ref (env, sym)
- Pointer env, sym;
+ SCHEME_OBJECT env, sym;
{
return (safe_reference_transform (Symbol_Lex_Ref (env, sym)));
}
case ERR_UNBOUND_VARIABLE:
case PRIM_DONE:
- Val = NIL;
+ Val = SHARP_F;
return (PRIM_DONE);
default:
long
Symbol_Lex_unassigned_p( frame, symbol)
- Pointer frame, symbol;
+ SCHEME_OBJECT frame, symbol;
{
return (unassigned_p_transform (Symbol_Lex_Ref (frame, symbol)));
}
long
Symbol_Lex_unbound_p( frame, symbol)
- Pointer frame, symbol;
+ SCHEME_OBJECT frame, symbol;
{
long result;
case ERR_UNASSIGNED_VARIABLE:
case PRIM_DONE:
{
- Val = NIL;
+ Val = SHARP_F;
return (PRIM_DONE);
}
used, but is provided for completeness.
*/
-Pointer *
+SCHEME_OBJECT *
force_definition(env, symbol, message)
- fast Pointer env;
- Pointer symbol;
+ fast SCHEME_OBJECT env;
+ SCHEME_OBJECT symbol;
long *message;
{
- fast Pointer previous;
+ fast SCHEME_OBJECT previous;
- if (OBJECT_TYPE(env) == GLOBAL_ENV)
+ if (OBJECT_TYPE (env) == GLOBAL_ENV)
{
- return ((Pointer *) NULL);
+ return ((SCHEME_OBJECT *) NULL);
}
do
{
previous = env;
- env = Fast_Vector_Ref(Vector_Ref(env, ENVIRONMENT_FUNCTION),
+ env = FAST_MEMORY_REF (MEMORY_REF (env, ENVIRONMENT_FUNCTION),
PROCEDURE_ENVIRONMENT);
- } while (OBJECT_TYPE(env) != GLOBAL_ENV);
+ } while (OBJECT_TYPE (env) != GLOBAL_ENV);
*message = Local_Set(previous, symbol, UNASSIGNED_OBJECT);
if (*message != PRIM_DONE)
- return ((Pointer *) NULL);
+ return ((SCHEME_OBJECT *) NULL);
return
deep_lookup(previous, symbol, fake_variable_object);
}
if needed, and stores it or a related object in the location
specified by (block, offset). It adds this reference to the
appropriate reference list for further updating.
-
+
If the reference is a lookup reference, the cache itself is stored.
If the reference is an assignment reference, there are two possibilities:
assignment references cached, and no fake cache had been installed,
a fake cache is created and all the assignment references are
updated to point to it.
- */
+ */
\f
#ifndef PARALLEL_PROCESSOR
#define compiler_cache_consistency_check() \
{ \
- Pointer *new_cell; \
+ SCHEME_OBJECT *new_cell; \
\
compiler_cache_variable[VARIABLE_SYMBOL] = name; \
new_cell = lookup_cell(compiler_cache_variable, env); \
#endif /* PARALLEL_PROCESSOR */
-extern Pointer compiler_cache_variable[];
+extern SCHEME_OBJECT compiler_cache_variable[];
extern long compiler_cache();
-Pointer compiler_cache_variable[3];
+SCHEME_OBJECT compiler_cache_variable[3];
\f
long
compiler_cache(cell, env, name, block, offset, kind, first_time)
- fast Pointer *cell;
- Pointer env, name, block;
+ fast SCHEME_OBJECT *cell;
+ SCHEME_OBJECT env, name, block;
long offset, kind;
Boolean first_time;
{
long cache_reference_end();
Lock_Handle set_serializer;
- fast Pointer trap, references, extension;
- Pointer trap_value, store_trap_tag, store_extension;
+ fast SCHEME_OBJECT trap, references, extension;
+ SCHEME_OBJECT trap_value, store_trap_tag, store_extension;
long trap_kind, return_value;
- store_trap_tag = NIL;
- store_extension = NIL;
+ store_trap_tag = SHARP_F;
+ store_extension = SHARP_F;
trap_kind = TRAP_COMPILER_CACHED;
compiler_cache_retry:
break;
case TRAP_DANGEROUS:
- trap_value = Fast_Vector_Ref(trap, TRAP_EXTRA);
+ trap_value = FAST_MEMORY_REF (trap, TRAP_EXTRA);
trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
break;
break;
case TRAP_FLUID_DANGEROUS:
- store_trap_tag = Make_Unsigned_Fixnum(TRAP_FLUID);
+ store_trap_tag = LONG_TO_UNSIGNED_FIXNUM(TRAP_FLUID);
trap_kind = TRAP_COMPILER_CACHED_DANGEROUS;
break;
case TRAP_COMPILER_CACHED:
case TRAP_COMPILER_CACHED_DANGEROUS:
- extension = Fast_Vector_Ref(trap, TRAP_EXTRA);
+ extension = FAST_MEMORY_REF (trap, TRAP_EXTRA);
update_lock(set_serializer,
- Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL));
- trap_value = Fast_Vector_Ref(extension, TRAP_EXTENSION_CELL);
+ MEMORY_LOC (extension, TRAP_EXTENSION_CELL));
+ trap_value = FAST_MEMORY_REF (extension, TRAP_EXTENSION_CELL);
trap_kind = -1;
break;
if (trap_kind != -1)
{
- Pointer new_trap, list;
+ SCHEME_OBJECT new_trap;
#if false
/* This is included in the check above. */
}
#endif
- new_trap = Make_Pointer(TC_REFERENCE_TRAP, Free);
- *Free++ = Make_Unsigned_Fixnum(trap_kind);
- extension = Make_Pointer(TRAP_EXTENSION_TYPE, (Free + 1));
+ new_trap = MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free);
+ *Free++ = LONG_TO_UNSIGNED_FIXNUM(trap_kind);
+ extension = MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, (Free + 1));
*Free++ = extension;
*Free++ = trap_value;
*Free++ = name;
- *Free++ = NIL;
- references = Make_Pointer(TRAP_REFERENCES_TYPE, (Free + 1));
+ *Free++ = SHARP_F;
+ references = MAKE_POINTER_OBJECT (TRAP_REFERENCES_TYPE, (Free + 1));
*Free++ = references;
- *Free++ = NIL;
- *Free++ = NIL;
- *Free++ = NIL;
+ *Free++ = EMPTY_LIST;
+ *Free++ = EMPTY_LIST;
+ *Free++ = EMPTY_LIST;
*cell = new_trap; /* Do_Store_No_Lock ? */
- if (store_trap_tag != NIL)
+ if (store_trap_tag != SHARP_F)
{
/* Do_Store_No_Lock ? */
- Fast_Vector_Set(trap, TRAP_TAG, store_trap_tag);
+ FAST_MEMORY_SET (trap, TRAP_TAG, store_trap_tag);
}
update_lock(set_serializer,
- Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL));
+ MEMORY_LOC (extension, TRAP_EXTENSION_CELL));
}
- if (block == NIL)
+ if (block == SHARP_F)
{
/* It is not really from compiled code.
The environment linking stuff wants a cc cache instead.
}
\f
/* There already is a compiled code cache.
- Maybe this should clean up all the cache lists?
+ Maybe this should clean up all the cache lists?
*/
{
void fix_references();
long add_reference();
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
if (((kind == TRAP_REFERENCES_ASSIGNMENT) &&
- (Fast_Vector_Ref(references, TRAP_REFERENCES_OPERATOR) != NIL)) ||
+ ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
+ != EMPTY_LIST)) ||
((kind == TRAP_REFERENCES_OPERATOR) &&
- (Fast_Vector_Ref(references, TRAP_REFERENCES_ASSIGNMENT) != NIL)))
+ ((FAST_MEMORY_REF (references, TRAP_REFERENCES_ASSIGNMENT))
+ != EMPTY_LIST)))
{
- store_extension = Fast_Vector_Ref(extension, TRAP_EXTENSION_CLONE);
- if (store_extension == NIL)
+ store_extension = FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE);
+ if (store_extension == SHARP_F)
{
#if false
/* This is included in the check above. */
return (PRIM_INTERRUPT);
}
#endif
- store_extension = Make_Pointer(TRAP_EXTENSION_TYPE, Free);
+ store_extension = MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free);
*Free++ = EXPENSIVE_ASSIGNMENT_OBJECT;
- *Free++ = Fast_Vector_Ref(extension, TRAP_EXTENSION_NAME);
+ *Free++ = FAST_MEMORY_REF (extension, TRAP_EXTENSION_NAME);
*Free++ = extension;
*Free++ = references;
- Fast_Vector_Set(extension, TRAP_EXTENSION_CLONE, store_extension);
+ FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, store_extension);
if (kind == TRAP_REFERENCES_OPERATOR)
{
- fix_references(Nth_Vector_Loc(references,
+ fix_references(MEMORY_LOC (references,
TRAP_REFERENCES_ASSIGNMENT),
store_extension);
}
}
}
-
- return_value = add_reference(Nth_Vector_Loc(references, kind),
+
+ return_value = add_reference(MEMORY_LOC (references, kind),
block,
- Make_Unsigned_Fixnum(offset));
+ LONG_TO_UNSIGNED_FIXNUM(offset));
if (return_value != PRIM_DONE)
{
compiler_cache_epilog();
cache_reference_end(kind, extension, store_extension,
block, offset, value)
long kind, offset;
- Pointer extension, store_extension, block, value;
+ SCHEME_OBJECT extension, store_extension, block, value;
{
extern void
store_variable_cache();
{
default:
case TRAP_REFERENCES_ASSIGNMENT:
- if (store_extension != NIL)
+ if (store_extension != SHARP_F)
{
store_variable_cache(store_extension, block, offset);
return (PRIM_DONE);
long
compiler_cache_reference(env, name, block, offset, kind, first_time)
- Pointer env, name, block;
+ SCHEME_OBJECT env, name, block;
long offset, kind;
Boolean first_time;
{
- Pointer *cell;
+ SCHEME_OBJECT *cell;
cell = deep_lookup(env, name, compiler_cache_variable);
if (cell == unbound_trap_object)
\f
/* This procedure updates all the references in the cached reference
list pointed at by slot to hold value. It also eliminates "empty"
- pairs (pairs whose weakly held block has vanished).
+ pairs (pairs whose weakly held block has vanished).
*/
void
fix_references(slot, extension)
- fast Pointer *slot, extension;
+ fast SCHEME_OBJECT *slot, extension;
{
- fast Pointer pair, block;
+ fast SCHEME_OBJECT pair, block;
- while (*slot != NIL)
+ while (*slot != EMPTY_LIST)
{
- pair = Fast_Vector_Ref(*slot, CONS_CAR);
- block = Fast_Vector_Ref(pair, CONS_CAR);
- if (block == NIL)
+ pair = FAST_PAIR_CAR (*slot);
+ block = FAST_PAIR_CAR (pair);
+ if (block == SHARP_F)
{
- *slot = Fast_Vector_Ref(*slot, CONS_CDR);
+ *slot = FAST_PAIR_CDR (*slot);
}
else
{
store_variable_cache(extension,
block,
- Get_Integer(Fast_Vector_Ref(pair, CONS_CDR)));
- slot = Nth_Vector_Loc(*slot, CONS_CDR);
+ OBJECT_DATUM (FAST_PAIR_CDR (pair)));
+ slot = PAIR_CDR_LOC (*slot);
}
}
return;
long
add_reference(slot, block, offset)
- fast Pointer *slot;
- Pointer block, offset;
+ fast SCHEME_OBJECT *slot;
+ SCHEME_OBJECT block, offset;
{
- fast Pointer pair;
+ fast SCHEME_OBJECT pair;
- while (*slot != NIL)
+ while (*slot != EMPTY_LIST)
{
- pair = Fast_Vector_Ref(*slot, CONS_CAR);
- if (Fast_Vector_Ref(pair, CONS_CAR) == NIL)
+ pair = FAST_PAIR_CAR (*slot);
+ if (FAST_PAIR_CAR (pair) == SHARP_F)
{
- Fast_Vector_Set(pair, CONS_CAR, block);
- Fast_Vector_Set(pair, CONS_CDR, offset);
+ FAST_SET_PAIR_CAR (pair, block);
+ FAST_SET_PAIR_CDR (pair, offset);
return (PRIM_DONE);
}
- slot = Nth_Vector_Loc(*slot, CONS_CDR);
+ slot = PAIR_CDR_LOC (*slot);
}
if (GC_allocate_test(4))
return (PRIM_INTERRUPT);
}
- *slot = Make_Pointer(TC_LIST, Free);
- *Free = Make_Pointer(TC_WEAK_CONS, (Free + 2));
+ *slot = MAKE_POINTER_OBJECT (TC_LIST, Free);
+ *Free = MAKE_POINTER_OBJECT (TC_WEAK_CONS, (Free + 2));
Free += 1;
- *Free++ = NIL;
+ *Free++ = EMPTY_LIST;
*Free++ = block;
*Free++ = offset;
return (PRIM_DONE);
}
\f
-extern Pointer compiled_block_environment();
+extern SCHEME_OBJECT compiled_block_environment();
static long
trap_map_table[] = {
long
compiler_uncache_slot(slot, sym, kind)
- fast Pointer *slot;
- Pointer sym;
+ fast SCHEME_OBJECT *slot;
+ SCHEME_OBJECT sym;
long kind;
{
- fast Pointer temp, pair;
- Pointer block, offset, new_extension;
+ fast SCHEME_OBJECT temp, pair;
+ SCHEME_OBJECT block, offset, new_extension;
- for (temp = *slot; temp != NIL; temp = *slot)
+ for (temp = *slot; temp != EMPTY_LIST; temp = *slot)
{
- pair = Fast_Vector_Ref(temp, CONS_CAR);
- block = Fast_Vector_Ref(pair, CONS_CAR);
- if (block != NIL)
+ pair = FAST_PAIR_CAR (temp);
+ block = FAST_PAIR_CAR (pair);
+ if (block != SHARP_F)
{
- offset = Fast_Vector_Ref(pair, CONS_CDR);
+ offset = FAST_PAIR_CDR (pair);
if (GC_allocate_test(4))
{
Request_GC(4);
return (PRIM_INTERRUPT);
}
- new_extension = Make_Pointer(TRAP_EXTENSION_TYPE, Free);
+ new_extension = MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free);
*Free++ = REQUEST_RECACHE_OBJECT;
*Free++ = sym;
*Free++ = block;
result = make_fake_uuo_link(new_extension,
block,
- Get_Integer(offset));
+ OBJECT_DATUM (offset));
if (result != PRIM_DONE)
return (result);
}
{
extern void store_variable_cache();
- store_variable_cache(new_extension, block, Get_Integer(offset));
+ store_variable_cache(new_extension, block, OBJECT_DATUM (offset));
}
}
- *slot = Fast_Vector_Ref(temp, CONS_CDR);
+ *slot = FAST_PAIR_CDR (temp);
}
return (PRIM_DONE);
}
long
compiler_uncache(value_cell, sym)
- Pointer *value_cell, sym;
+ SCHEME_OBJECT *value_cell, sym;
{
Lock_Handle set_serializer;
- Pointer val, extension, references;
+ SCHEME_OBJECT val, extension, references;
long trap_kind, temp, i, index;
setup_lock(set_serializer, value_cell);
compiler_uncache_prolog();
- extension = Fast_Vector_Ref(val, TRAP_EXTRA);
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
- update_lock(set_serializer, Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL));
+ extension = FAST_MEMORY_REF (val, TRAP_EXTRA);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
+ update_lock(set_serializer, MEMORY_LOC (extension, TRAP_EXTENSION_CELL));
/* Uncache all of the lists. */
for (i = TRAP_MAP_TABLE_SIZE; --i >= 0; )
{
index = trap_map_table[i];
- temp = compiler_uncache_slot(Nth_Vector_Loc(references, index),
+ temp = compiler_uncache_slot(MEMORY_LOC (references, index),
sym, index);
if (temp != PRIM_DONE)
{
/* Remove the clone extension if there is one. */
- Fast_Vector_Set(extension, TRAP_EXTENSION_CLONE, NIL);
+ FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, SHARP_F);
compiler_uncache_epilog();
remove_lock(set_serializer);
return (PRIM_DONE);
recaches (at the definition point) all the references that need to
point to the new cell.
- It does this in two phases:
+ It does this in two phases:
- First (by means of compiler_recache_split) it splits all
references into those that need to be updated and those that do
/* Required by compiler_uncache macro. */
-Pointer *shadowed_value_cell = ((Pointer *) NULL);
+SCHEME_OBJECT *shadowed_value_cell = ((SCHEME_OBJECT *) NULL);
/* Each extension is a hunk4. */
Boolean
environment_ancestor_or_self_p(ancestor, descendant)
- fast Pointer ancestor, descendant;
+ fast SCHEME_OBJECT ancestor, descendant;
{
- while (OBJECT_TYPE(descendant) != GLOBAL_ENV)
+ while (OBJECT_TYPE (descendant) != GLOBAL_ENV)
{
if (descendant == ancestor)
return (true);
- descendant = Fast_Vector_Ref(Vector_Ref(descendant,
- ENVIRONMENT_FUNCTION),
- PROCEDURE_ENVIRONMENT);
+ descendant = FAST_MEMORY_REF (MEMORY_REF (descendant,
+ ENVIRONMENT_FUNCTION),
+ PROCEDURE_ENVIRONMENT);
}
return (descendant == ancestor);
}
long
compiler_recache_split(slot, sym, definition_env, memoize_cell)
- fast Pointer *slot;
- Pointer sym, definition_env, **memoize_cell;
+ fast SCHEME_OBJECT *slot;
+ SCHEME_OBJECT sym, definition_env, **memoize_cell;
{
fast long count;
- Pointer weak_pair, block, reference_env, invalid_head;
- fast Pointer *last_invalid;
+ SCHEME_OBJECT weak_pair, block, reference_env, invalid_head;
+ fast SCHEME_OBJECT *last_invalid;
count = 0;
last_invalid = &invalid_head;
- while (*slot != NIL)
+ while (*slot != EMPTY_LIST)
{
- weak_pair = Fast_Vector_Ref(*slot, CONS_CAR);
- block = Fast_Vector_Ref(weak_pair, CONS_CAR);
- if (block == NIL)
+ weak_pair = FAST_PAIR_CAR (*slot);
+ block = FAST_PAIR_CAR (weak_pair);
+ if (block == SHARP_F)
{
- *slot = Fast_Vector_Ref(*slot, CONS_CDR);
+ *slot = FAST_PAIR_CDR (*slot);
continue;
}
reference_env = compiled_block_environment(block);
if (!environment_ancestor_or_self_p(definition_env, reference_env))
{
- slot = Nth_Vector_Loc(*slot, CONS_CDR);
+ slot = PAIR_CDR_LOC (*slot);
}
else
{
count += 1;
*last_invalid = *slot;
- last_invalid = Nth_Vector_Loc(*slot, CONS_CDR);
+ last_invalid = PAIR_CDR_LOC (*slot);
*slot = *last_invalid;
}
}
- *last_invalid = NIL;
+ *last_invalid = EMPTY_LIST;
*memoize_cell = slot;
*slot = invalid_head;
return (count);
}
\f
/* This recaches the entries pointed out by cell and adds them
- to the list in slot. It also sets to NIL the contents
+ to the list in slot. It also sets to #F the contents
of cell.
Note that this reuses the pairs and weak pairs that used to be
long
compiler_recache_slot(extension, sym, kind, slot, cell, value)
- Pointer extension, sym, value;
- fast Pointer *slot, *cell;
+ SCHEME_OBJECT extension, sym, value;
+ fast SCHEME_OBJECT *slot, *cell;
long kind;
{
- fast Pointer pair, weak_pair;
- Pointer clone, tail;
+ fast SCHEME_OBJECT pair, weak_pair;
+ SCHEME_OBJECT clone, tail;
long result;
- /* This is NIL if there isn't one.
+ /* This is #F if there isn't one.
This makes cache_reference_end do the right thing.
*/
- clone = Fast_Vector_Ref(extension, TRAP_EXTENSION_CLONE);
+ clone = FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE);
tail = *slot;
for (pair = *cell; pair != NULL; pair = *cell)
{
- weak_pair = Fast_Vector_Ref(pair, CONS_CAR);
+ weak_pair = FAST_PAIR_CAR (pair);
result = cache_reference_end(kind, extension, clone,
- Fast_Vector_Ref(weak_pair, CONS_CAR),
- Get_Integer(Fast_Vector_Ref(weak_pair,
- CONS_CDR)),
+ FAST_PAIR_CAR (weak_pair),
+ OBJECT_DATUM (FAST_PAIR_CDR (weak_pair)),
value);
if (result != PRIM_DONE)
{
}
*slot = pair;
- slot = Nth_Vector_Loc(pair, CONS_CDR);
+ slot = PAIR_CDR_LOC (pair);
*cell = *slot;
}
*slot = tail;
long
compiler_recache(old_value_cell, new_value_cell, env, sym, value,
shadowed_p, link_p)
- Pointer *old_value_cell, *new_value_cell, env, sym, value;
+ SCHEME_OBJECT *old_value_cell, *new_value_cell, env, sym, value;
Boolean shadowed_p, link_p;
{
Lock_Handle set_serializer_1, set_serializer_2;
- Pointer
+ SCHEME_OBJECT
old_value, references, extension, new_extension, new_trap,
*trap_info_table[TRAP_MAP_TABLE_SIZE];
long
trap_kind, temp, i, index, total_size, total_count, conflict_count;
-
+
setup_locks(set_serializer_1, old_value_cell,
set_serializer_2, new_value_cell);
-
+
if ((!link_p) && (*new_value_cell != DANGEROUS_UNBOUND_OBJECT))
{
/* Another processor has redefined this word in the meantime.
compiler_recache_prolog();
- extension = Fast_Vector_Ref(old_value, TRAP_EXTRA);
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
+ extension = FAST_MEMORY_REF (old_value, TRAP_EXTRA);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
update_lock(set_serializer_1,
- Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL));
+ MEMORY_LOC (extension, TRAP_EXTENSION_CELL));
\f
/*
Split each slot and compute the amount to allocate.
for (i = TRAP_MAP_TABLE_SIZE; --i >= 0; )
{
index = trap_map_table[i];
- temp = compiler_recache_split(Nth_Vector_Loc(references, index),
+ temp = compiler_recache_split(MEMORY_LOC (references, index),
sym, env, &trap_info_table[i]);
-
+
if (temp != 0)
{
conflict_count += trap_conflict_table[i];
if ((conflict_count == 2) &&
((!link_p) ||
- (new_value_cell[TRAP_EXTENSION_CLONE] == NIL)))
+ (new_value_cell[TRAP_EXTENSION_CLONE] == SHARP_F)))
{
total_size += SPACE_PER_EXTENSION;
}
if (link_p)
{
- new_extension = Make_Pointer(TRAP_EXTENSION_TYPE, new_value_cell);
+ new_extension = MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, new_value_cell);
references = new_value_cell[TRAP_EXTENSION_REFERENCES];
}
else
skip this binding.
*/
- references = Make_Pointer(TRAP_REFERENCES_TYPE, Free);
+ references = MAKE_POINTER_OBJECT (TRAP_REFERENCES_TYPE, Free);
- *Free++ = NIL;
- *Free++ = NIL;
- *Free++ = NIL;
+ *Free++ = EMPTY_LIST;
+ *Free++ = EMPTY_LIST;
+ *Free++ = EMPTY_LIST;
- new_extension = Make_Pointer(TRAP_EXTENSION_TYPE, Free);
+ new_extension = MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free);
*Free++ = value;
*Free++ = sym;
- *Free++ = NIL;
+ *Free++ = SHARP_F;
*Free++ = references;
- new_trap = Make_Pointer(TC_REFERENCE_TRAP, Free);
- *Free++ = Make_Unsigned_Fixnum((shadowed_p ?
+ new_trap = MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Free);
+ *Free++ = LONG_TO_UNSIGNED_FIXNUM((shadowed_p ?
TRAP_COMPILER_CACHED_DANGEROUS :
TRAP_COMPILER_CACHED));
*Free++ = new_extension;
}
-
+
if ((conflict_count == 2) &&
- (Vector_Ref(new_extension, TRAP_EXTENSION_CLONE) == NIL))
+ (MEMORY_REF (new_extension, TRAP_EXTENSION_CLONE) == SHARP_F))
{
- Pointer clone;
+ SCHEME_OBJECT clone;
- clone = Make_Pointer(TRAP_EXTENSION_TYPE, Free);
+ clone = MAKE_POINTER_OBJECT (TRAP_EXTENSION_TYPE, Free);
*Free++ = EXPENSIVE_ASSIGNMENT_OBJECT;
*Free++ = sym;
*Free++ = new_extension;
*Free++ = references;
- Fast_Vector_Set(new_extension, TRAP_EXTENSION_CLONE, clone);
+ FAST_MEMORY_SET (new_extension, TRAP_EXTENSION_CLONE, clone);
}
\f
/*
{
index = trap_map_table[i];
temp = compiler_recache_slot(new_extension, sym, index,
- Nth_Vector_Loc(references, index),
+ MEMORY_LOC (references, index),
trap_info_table[i],
value);
if (temp != PRIM_DONE)
{
- extern char *Abort_Names[], *Error_Names[];
+ extern char *Abort_Names[];
/* We've lost BIG. */
long
recache_uuo_links(extension, old_value)
- Pointer extension, old_value;
+ SCHEME_OBJECT extension, old_value;
{
long update_uuo_links();
- Pointer value;
+ SCHEME_OBJECT value;
long return_value;
- value = Fast_Vector_Ref(extension, TRAP_EXTENSION_CELL);
+ value = FAST_MEMORY_REF (extension, TRAP_EXTENSION_CELL);
if (REFERENCE_TRAP_P(value))
{
if (REFERENCE_TRAP_P(old_value))
so it is safe to "revert" the value.
*/
- Fast_Vector_Set(extension, TRAP_EXTENSION_CELL, old_value);
+ FAST_MEMORY_SET (extension, TRAP_EXTENSION_CELL, old_value);
}
return (return_value);
}
long
make_recache_uuo_link(value, extension, block, offset)
- Pointer value, extension, block;
+ SCHEME_OBJECT value, extension, block;
long offset;
{
extern long make_fake_uuo_link();
\f
long
update_uuo_links(value, extension, handler)
- Pointer value, extension;
+ SCHEME_OBJECT value, extension;
long (*handler)();
{
- Pointer references, pair, block;
- fast Pointer *slot;
+ SCHEME_OBJECT references, pair, block;
+ fast SCHEME_OBJECT *slot;
long return_value;
update_uuo_prolog();
- references = Fast_Vector_Ref(extension, TRAP_EXTENSION_REFERENCES);
- slot = Nth_Vector_Loc(references, TRAP_REFERENCES_OPERATOR);
+ references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
+ slot = MEMORY_LOC (references, TRAP_REFERENCES_OPERATOR);
- while (*slot != NIL)
+ while (*slot != EMPTY_LIST)
{
- pair = Fast_Vector_Ref(*slot, CONS_CAR);
- block = Fast_Vector_Ref(pair, CONS_CAR);
- if (block == NIL)
+ pair = FAST_PAIR_CAR (*slot);
+ block = FAST_PAIR_CAR (pair);
+ if (block == SHARP_F)
{
- *slot = Fast_Vector_Ref(*slot, CONS_CDR);
+ *slot = FAST_PAIR_CDR (*slot);
}
else
{
return_value =
(*handler)(value, extension, block,
- Get_Integer(Fast_Vector_Ref(pair, CONS_CDR)));
+ OBJECT_DATUM (FAST_PAIR_CDR (pair)));
if (return_value != PRIM_DONE)
{
update_uuo_epilog();
return (return_value);
}
- slot = Nth_Vector_Loc(*slot, CONS_CDR);
+ slot = PAIR_CDR_LOC (*slot);
}
}
/* If there are no uuo links left, and there is an extension clone,
remove it, and make assignment references point to the real value
- cell.
+ cell.
*/
-
- if ((Fast_Vector_Ref(references, TRAP_REFERENCES_OPERATOR) == NIL) &&
- (Fast_Vector_Ref(extension, TRAP_EXTENSION_CLONE) != NIL))
+
+ if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR) == EMPTY_LIST) &&
+ (FAST_MEMORY_REF (extension, TRAP_EXTENSION_CLONE) != SHARP_F))
{
- Fast_Vector_Set(extension, TRAP_EXTENSION_CLONE, NIL);
- fix_references(Nth_Vector_Loc(references, TRAP_REFERENCES_ASSIGNMENT),
+ FAST_MEMORY_SET (extension, TRAP_EXTENSION_CLONE, SHARP_F);
+ fix_references(MEMORY_LOC (references, TRAP_REFERENCES_ASSIGNMENT),
extension);
}
update_uuo_epilog();
long
compiler_reference_trap(extension, kind, handler)
- Pointer extension;
+ SCHEME_OBJECT extension;
long kind;
long (*handler)();
{
long offset, temp;
- Pointer block;
+ SCHEME_OBJECT block;
try_again:
- if (Vector_Ref(extension, TRAP_EXTENSION_CELL) != REQUEST_RECACHE_OBJECT)
+ if (MEMORY_REF (extension, TRAP_EXTENSION_CELL) != REQUEST_RECACHE_OBJECT)
{
- return ((*handler)(Nth_Vector_Loc(extension, TRAP_EXTENSION_CELL),
+ return ((*handler)(MEMORY_LOC (extension, TRAP_EXTENSION_CELL),
fake_variable_object));
}
- block = Fast_Vector_Ref(extension, TRAP_EXTENSION_BLOCK);
- offset = Get_Integer(Fast_Vector_Ref(extension, TRAP_EXTENSION_OFFSET));
+ block = FAST_MEMORY_REF (extension, TRAP_EXTENSION_BLOCK);
+ offset = OBJECT_DATUM (FAST_MEMORY_REF (extension, TRAP_EXTENSION_OFFSET));
compiler_trap_prolog();
- temp =
+ temp =
compiler_cache_reference(compiled_block_environment(block),
- Fast_Vector_Ref(extension, TRAP_EXTENSION_NAME),
+ FAST_MEMORY_REF (extension, TRAP_EXTENSION_NAME),
block, offset, kind, false);
compiler_trap_epilog();
if (temp != PRIM_DONE)
value.
*/
- extern Pointer extract_uuo_link();
+ extern SCHEME_OBJECT extract_uuo_link();
Val = extract_uuo_link(block, offset);
return (PRIM_DONE);
case TRAP_REFERENCES_LOOKUP:
default:
{
- extern Pointer extract_variable_cache();
+ extern SCHEME_OBJECT extract_variable_cache();
extension = extract_variable_cache(block, offset);
/* This is paranoid on a single processor, but it does not hurt.
long
compiler_cache_lookup(name, block, offset)
- Pointer name, block;
+ SCHEME_OBJECT name, block;
long offset;
{
return (compiler_cache_reference(compiled_block_environment(block),
long
compiler_cache_assignment(name, block, offset)
- Pointer name, block;
+ SCHEME_OBJECT name, block;
long offset;
{
return (compiler_cache_reference(compiled_block_environment(block),
long
compiler_cache_operator(name, block, offset)
- Pointer name, block;
+ SCHEME_OBJECT name, block;
long offset;
{
return (compiler_cache_reference(compiled_block_environment(block),
}
\f
extern long complr_operator_reference_trap();
-extern Pointer compiler_var_error();
+extern SCHEME_OBJECT compiler_var_error();
long
complr_operator_reference_trap(frame_slot, extension)
- Pointer *frame_slot, extension;
+ SCHEME_OBJECT *frame_slot, extension;
{
long temp;
return (PRIM_DONE);
}
-Pointer
+SCHEME_OBJECT
compiler_var_error(extension, environment)
- Pointer extension, environment;
+ SCHEME_OBJECT extension, environment;
{
- return (Vector_Ref(extension, TRAP_EXTENSION_NAME));
+ return (MEMORY_REF (extension, TRAP_EXTENSION_NAME));
}
/* Utility for compiler_assignment_trap, below.
- Necessary because C lacks lambda. Argh!
+ Necessary because C lacks lambda. Argh!
*/
-static Pointer saved_compiler_assignment_value;
+static SCHEME_OBJECT saved_compiler_assignment_value;
long
compiler_assignment_end(cell, hunk)
- Pointer *cell, *hunk;
+ SCHEME_OBJECT *cell, *hunk;
{
return (deep_assignment_end(cell, hunk,
saved_compiler_assignment_value, false));
long
compiler_lookup_trap(extension)
- Pointer extension;
+ SCHEME_OBJECT extension;
{
return (compiler_reference_trap(extension,
TRAP_REFERENCES_LOOKUP,
long
compiler_safe_lookup_trap (extension)
- Pointer extension;
+ SCHEME_OBJECT extension;
{
return (safe_reference_transform (compiler_lookup_trap (extension)));
}
long
compiler_unassigned_p_trap (extension)
- Pointer extension;
+ SCHEME_OBJECT extension;
{
return (unassigned_p_transform (compiler_lookup_trap (extension)));
}
long
compiler_assignment_trap(extension, value)
- Pointer extension, value;
+ SCHEME_OBJECT extension, value;
{
saved_compiler_assignment_value = value;
return (compiler_reference_trap(extension,
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/lookup.h,v 9.44 1989/09/20 23:10:10 cph Rel $
+
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/lookup.h,v 9.43 1989/08/28 18:29:03 cph Exp $ */
-
/* Macros and declarations for the variable lookup code. */
-extern Pointer
+extern SCHEME_OBJECT
*deep_lookup(),
*lookup_fluid(),
*force_definition();
deep_lookup_end(),
deep_assignment_end();
-extern Pointer
+extern SCHEME_OBJECT
unbound_trap_object[],
uncompiled_trap_object[],
illegal_trap_object[],
#endif /* b32 */
#ifndef UNCOMPILED_VARIABLE /* Safe version */
-#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0)
+#define UNCOMPILED_VARIABLE MAKE_OBJECT (UNCOMPILED_REF, 0)
#endif
/* Macros for speedy variable reference. */
#if (LOCAL_REF == 0)
#define Lexical_Offset(Ind) ((long) (Ind))
-#define Make_Local_Offset(Ind) ((Pointer) (Ind))
+#define Make_Local_Offset(Ind) ((SCHEME_OBJECT) (Ind))
#else
-#define Lexical_Offset(Ind) OBJECT_DATUM(Ind)
-#define Make_Local_Offset(Ind) Make_Non_Pointer(LOCAL_REF, Ind)
+#define Lexical_Offset(Ind) OBJECT_DATUM (Ind)
+#define Make_Local_Offset(Ind) MAKE_OBJECT (LOCAL_REF, Ind)
#endif
\f
#include "error: lookup.h inconsistency detected."
#endif
-#define get_offset(hunk) Lexical_Offset(Fetch(hunk[VARIABLE_OFFSET]))
+#define get_offset(hunk) Lexical_Offset(MEMORY_FETCH (hunk[VARIABLE_OFFSET]))
#ifdef PARALLEL_PROCESSOR
#define verify(type_code, variable, code, label) \
{ \
variable = code; \
- if (OBJECT_TYPE(Fetch(hunk[VARIABLE_COMPILED_TYPE])) != \
+ if (OBJECT_TYPE (MEMORY_FETCH (hunk[VARIABLE_COMPILED_TYPE])) != \
type_code) \
goto label; \
}
#define verified_offset(variable, code) variable
-/* Unlike Lock_Cell, cell must be (Pointer *). This currently does
+/* Unlike Lock_Cell, cell must be (SCHEME_OBJECT *). This currently does
not matter, but might on a machine with address mapping.
*/
#define Future_Variable_Splice(Vbl, Ofs, Val)
#endif
\f
-/* Pointer *cell, env, *hunk; */
+/* SCHEME_OBJECT *cell, env, *hunk; */
#define lookup(cell, env, hunk, label) \
{ \
- fast Pointer frame; \
- long offset; \
+ fast SCHEME_OBJECT frame; \
\
label: \
\
- frame = Fetch(hunk[VARIABLE_COMPILED_TYPE]); \
+ frame = (MEMORY_FETCH (hunk [VARIABLE_COMPILED_TYPE])); \
\
- switch (OBJECT_TYPE(frame)) \
+ switch (OBJECT_TYPE (frame)) \
{ \
case GLOBAL_REF: \
/* frame is a pointer to the same symbol. */ \
- cell = Nth_Vector_Loc(frame, SYMBOL_GLOBAL_VALUE); \
+ cell = MEMORY_LOC (frame, SYMBOL_GLOBAL_VALUE); \
break; \
\
case LOCAL_REF: \
- cell = Nth_Vector_Loc(env, Lexical_Offset(frame)); \
+ cell = MEMORY_LOC (env, Lexical_Offset(frame)); \
break; \
\
case FORMAL_REF: \
/* Done here rather than in a separate case because of \
peculiarities of the bobcat compiler. \
*/ \
- cell = ((OBJECT_TYPE(frame) == UNCOMPILED_REF) ? \
+ cell = ((OBJECT_TYPE (frame) == UNCOMPILED_REF) ? \
uncompiled_trap_object : \
illegal_trap_object); \
break; \
frame = env; \
while(--depth >= 0) \
{ \
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
+ frame = FAST_MEMORY_REF (MEMORY_REF (frame, ENVIRONMENT_FUNCTION), \
PROCEDURE_ENVIRONMENT); \
} \
\
- cell = Nth_Vector_Loc(frame, \
+ cell = MEMORY_LOC (frame, \
verified_offset(offset, get_offset(hunk))); \
\
break; \
frame = env; \
while(--depth >= 0) \
{ \
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
+ frame = FAST_MEMORY_REF (MEMORY_REF (frame, ENVIRONMENT_FUNCTION), \
PROCEDURE_ENVIRONMENT); \
} \
\
- frame = Vector_Ref(frame, ENVIRONMENT_FUNCTION); \
- if (OBJECT_TYPE(frame) != AUX_LIST_TYPE) \
+ frame = MEMORY_REF (frame, ENVIRONMENT_FUNCTION); \
+ if (OBJECT_TYPE (frame) != AUX_LIST_TYPE) \
{ \
cell = uncompiled_trap_object; \
break; \
} \
depth = verified_offset(offset, get_offset(hunk)); \
- if (depth > Vector_Length(frame)) \
+ if (depth > VECTOR_LENGTH (frame)) \
{ \
cell = uncompiled_trap_object; \
break; \
} \
- frame = Vector_Ref(frame, depth); \
- if ((frame == NIL) || \
- (Fast_Vector_Ref(frame, CONS_CAR) != hunk[VARIABLE_SYMBOL])) \
+ frame = MEMORY_REF (frame, depth); \
+ if ((frame == SHARP_F) || \
+ (FAST_PAIR_CAR (frame) != hunk[VARIABLE_SYMBOL])) \
{ \
cell = uncompiled_trap_object; \
break; \
} \
- cell = Nth_Vector_Loc(frame, CONS_CDR); \
+ cell = PAIR_CDR_LOC (frame); \
break; \
}
\f
extern long compiler_recache();
-extern Pointer *shadowed_value_cell;
+extern SCHEME_OBJECT *shadowed_value_cell;
#define compiler_uncache(cell, sym) \
(shadowed_value_cell = cell, PRIM_DONE)
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/mul.c,v 9.27 1989/09/20 23:10:22 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/mul.c,v 9.26 1989/02/19 17:51:47 jinx Rel $
- *
- * This file contains the fixnum multiplication procedure.
- * Returns NIL if the result does not fit in a fixnum.
- * Note: The portable version has only been tried on machines with
- * long = 32 bits. This file is included in the appropriate os file.
- */
+/* This file contains the fixnum multiplication procedure. Returns
+ SHARP_F if the result does not fit in a fixnum. Note: The portable
+ version has only been tried on machines with long = 32 bits. This
+ file is included in the appropriate os file. */
\f
-extern Pointer Mul();
+extern SCHEME_OBJECT Mul ();
+
+#if (TYPE_CODE_LENGTH == 8)
#if defined(vax) && defined(bsd)
coded in assembly language. -- JINX
*/
-Pointer
+SCHEME_OBJECT
Mul(Arg1, Arg2)
- Pointer Arg1, Arg2;
+ SCHEME_OBJECT Arg1, Arg2;
{
register long A, B, C;
- Sign_Extend(Arg1, A);
- Sign_Extend(Arg2, B);
+ A = (FIXNUM_TO_LONG (Arg1));
+ B = (FIXNUM_TO_LONG (Arg2));
asm(" emul r11,r10,$0,r10"); /* A is in 11, B in 10 */
C = A;
A = B; /* What is all this shuffling? -- JINX */
if (((B == 0) && (A & (-1 << 23)) == 0) ||
((B == -1) && (A & (-1 << 23)) == (-1 << 23)))
{
- return (MAKE_SIGNED_FIXNUM(A));
+ return (LONG_TO_FIXNUM(A));
}
else
{
- return (NIL);
+ return (SHARP_F);
}
}
-#endif
+#endif /* vax+bsd */
\f
/* 68k family code. Uses hp9000s200 conventions for the new compiler. */
* for the compiler.
*/
-#if (NIL != 0) || (TC_FIXNUM != 0x1A)
+#if (SHARP_F != 0) || (TC_FIXNUM != 0x1A)
#include "Error: types changed. Change assembly language appropriately"
#endif
#endif /* not MC68020 */
#endif /* hp9000s200 */
\f
+#endif /* (TYPE_CODE_LENGTH == 8) */
+
#ifndef MUL_HANDLED
-#define HALF_WORD_SIZE ((sizeof(long)*CHAR_SIZE)/2)
+#define HALF_WORD_SIZE ((sizeof(long)*CHAR_BIT)/2)
#define HALF_WORD_MASK (1<<HALF_WORD_SIZE)-1
-#define MAX_MIDDLE (1<<((ADDRESS_LENGTH-1)-HALF_WORD_SIZE))
-#define MAX_FIXNUM (1<<ADDRESS_LENGTH)
+#define MAX_MIDDLE (1<<((DATUM_LENGTH-1)-HALF_WORD_SIZE))
+#define MAX_FIXNUM (1<<DATUM_LENGTH)
#define ABS(x) (((x) < 0) ? -(x) : (x))
-Pointer
+SCHEME_OBJECT
Mul(Arg1, Arg2)
- Pointer Arg1, Arg2;
+ SCHEME_OBJECT Arg1, Arg2;
{
long A, B, C;
fast unsigned long Hi_A, Hi_B, Lo_A, Lo_B, Lo_C, Middle_C;
Boolean Sign;
- Sign_Extend(Arg1, A);
- Sign_Extend(Arg2, B);
+ A = (FIXNUM_TO_LONG (Arg1));
+ B = (FIXNUM_TO_LONG (Arg2));
Sign = ((A < 0) == (B < 0));
A = ABS(A);
B = ABS(B);
Hi_A = ((A >> HALF_WORD_SIZE) & HALF_WORD_MASK);
Hi_B = ((B >> HALF_WORD_SIZE) & HALF_WORD_MASK);
if ((Hi_A > 0) && (Hi_B > 0))
- return (NIL);
+ return (SHARP_F);
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);
+ return (SHARP_F);
Middle_C = (Lo_A * Hi_B) + (Hi_A * Lo_B);
if (Middle_C >= MAX_MIDDLE)
- return (NIL);
+ return (SHARP_F);
C = Lo_C + (Middle_C << HALF_WORD_SIZE);
- if (Fixnum_Fits(C))
+ if (LONG_TO_FIXNUM_P(C))
{
if (Sign || (C == 0))
- return (MAKE_UNSIGNED_FIXNUM(C));
+ return (LONG_TO_UNSIGNED_FIXNUM(C));
else
- return (MAKE_UNSIGNED_FIXNUM(MAX_FIXNUM - C));
+ return (LONG_TO_UNSIGNED_FIXNUM(MAX_FIXNUM - C));
}
- return (NIL);
+ return (SHARP_F);
}
#endif /* not MUL_HANDLED */
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 9.32 1989/09/20 23:10:26 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 9.31 1989/08/28 18:29:10 cph Exp $ */
-
-/* This file contains definitions pertaining to the C view of
- Scheme pointers: widths of fields, extraction macros, pre-computed
- extraction masks, etc. */
+/* This file defines the macros which define and manipulate Scheme
+ objects. This is the lowest level of abstraction in this program. */
\f
-/* The C type Pointer is defined at the end of config.h
- The definition of POINTER_LENGTH here assumes that Pointer is the same
- as unsigned long. If that ever changes, this definition must also.
- POINTER_LENGTH is defined this way to make it available to
- the preprocessor. */
-
-/* The value in Wsize.c for TYPE_CODE_LENGTH must match this!! */
-
+/* The value in "Wsize.c" for `TYPE_CODE_LENGTH' must match this!! */
#ifndef TYPE_CODE_LENGTH
-#define TYPE_CODE_LENGTH 8
-#endif
-
-#if (TYPE_CODE_LENGTH == 8)
-#define MAX_TYPE_CODE 0xFF
-#endif
-
-#if (TYPE_CODE_LENGTH == 6)
-#define MAX_TYPE_CODE 0x3F
+#define TYPE_CODE_LENGTH 8
#endif
#ifdef MIN_TYPE_CODE_LENGTH
#include ";; inconsistency between object.h and types.h: MIN_TYPE_CODE_LENGTH"
#endif
#endif
-
-#ifndef MAX_TYPE_CODE
-#define MAX_TYPE_CODE ((1 << TYPE_CODE_LENGTH) - 1)
-#endif
-#define POINTER_LENGTH ULONG_SIZE
-
#ifdef b32 /* 32 bit word versions */
-
#if (TYPE_CODE_LENGTH == 8)
-#define ADDRESS_LENGTH 24
-#define ADDRESS_MASK 0x00FFFFFF
-#define TYPE_CODE_MASK 0xFF000000
+#define MAX_TYPE_CODE 0xFF
+#define DATUM_LENGTH 24
#define FIXNUM_LENGTH 23
#define FIXNUM_SIGN_BIT 0x00800000
#define SIGN_MASK 0xFF800000
#define SMALLEST_FIXNUM ((long) 0xFF800000)
#define BIGGEST_FIXNUM ((long) 0x007FFFFF)
-#define HALF_ADDRESS_LENGTH 12
-#define HALF_ADDRESS_MASK 0x00000FFF
-#endif /* (TYPE_CODE_LENGTH == 8) */
+#define HALF_DATUM_LENGTH 12
+#define HALF_DATUM_MASK 0x00000FFF
+#ifndef OBJECT_MASKS_DEFINED
+#define DATUM_MASK 0x00FFFFFF
+#define TYPE_CODE_MASK 0xFF000000
+#endif /* not OBJECT_MASKS_DEFINED */
+
+#endif /* (TYPE_CODE_LENGTH == 8) */
#if (TYPE_CODE_LENGTH == 6)
-#define ADDRESS_LENGTH 26
-#define ADDRESS_MASK 0x03FFFFFF
-#define TYPE_CODE_MASK 0XFC000000
+
+#define MAX_TYPE_CODE 0x3F
+#define DATUM_LENGTH 26
#define FIXNUM_LENGTH 25
#define FIXNUM_SIGN_BIT 0x02000000
#define SIGN_MASK 0xFE000000
#define SMALLEST_FIXNUM ((long) 0xFE000000)
#define BIGGEST_FIXNUM ((long) 0x01FFFFFF)
-#define HALF_ADDRESS_LENGTH 13
-#define HALF_ADDRESS_MASK 0x00001FFF
-#endif /* (TYPE_CODE_LENGTH == 6) */
+#define HALF_DATUM_LENGTH 13
+#define HALF_DATUM_MASK 0x00001FFF
+
+#ifndef OBJECT_MASKS_DEFINED
+#define DATUM_MASK 0x03FFFFFF
+#define TYPE_CODE_MASK 0XFC000000
+#endif /* not OBJECT_MASKS_DEFINED */
+#endif /* (TYPE_CODE_LENGTH == 6) */
#endif /* b32 */
+#ifndef DATUM_LENGTH /* Safe versions */
-#ifndef ADDRESS_LENGTH /* Safe versions */
-#define ADDRESS_LENGTH (POINTER_LENGTH-TYPE_CODE_LENGTH)
-#define ADDRESS_MASK ((1 << ADDRESS_LENGTH) - 1)
-#define TYPE_CODE_MASK (~ADDRESS_MASK)
+#define MAX_TYPE_CODE ((1 << TYPE_CODE_LENGTH) - 1)
+#define DATUM_LENGTH (OBJECT_LENGTH - TYPE_CODE_LENGTH)
/* FIXNUM_LENGTH does NOT include the sign bit! */
-#define FIXNUM_LENGTH (ADDRESS_LENGTH - 1)
+#define FIXNUM_LENGTH (DATUM_LENGTH - 1)
#define FIXNUM_SIGN_BIT (1 << FIXNUM_LENGTH)
-#define SIGN_MASK (TYPE_CODE_MASK | FIXNUM_SIGN_BIT)
+#define SIGN_MASK ((long) (-1 << FIXNUM_LENGTH))
#define SMALLEST_FIXNUM ((long) (-1 << FIXNUM_LENGTH))
-#define BIGGEST_FIXNUM ((long) (~(-1 << FIXNUM_LENGTH)))
-#define HALF_ADDRESS_LENGTH (ADDRESS_LENGTH / 2)
-#define HALF_ADDRESS_MASK ((1 << HALF_ADDRESS_LENGTH) - 1)
-#endif /* ADDRESS_LENGTH */
+#define BIGGEST_FIXNUM ((1 << FIXNUM_LENGTH) - 1)
+#define HALF_DATUM_LENGTH (DATUM_LENGTH / 2)
+#define HALF_DATUM_MASK ((1 << HALF_DATUM_LENGTH) - 1)
+
+#ifndef OBJECT_MASKS_DEFINED
+#define DATUM_MASK ((1 << DATUM_LENGTH) - 1)
+#define TYPE_CODE_MASK (~ DATUM_MASK)
+#endif /* not OBJECT_MASKS_DEFINED */
+
+#endif /* DATUM_LENGTH */
\f
+/* Basic object structure */
+
#ifndef OBJECT_TYPE
-#ifndef UNSIGNED_SHIFT /* Portable version */
-#define OBJECT_TYPE(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE)
-#else /* Faster for logical shifts */
-#define OBJECT_TYPE(P) ((P) >> ADDRESS_LENGTH)
+#ifdef UNSIGNED_SHIFT
+/* Faster for logical shifts */
+#define OBJECT_TYPE(object) ((object) >> DATUM_LENGTH)
+#else
+/* Portable version */
+#define OBJECT_TYPE(object) (((object) >> DATUM_LENGTH) & MAX_TYPE_CODE)
#endif
-#endif /* OBJECT_TYPE */
-
-#ifndef OBJECT_DATUM
-#define OBJECT_DATUM(P) ((P) & ADDRESS_MASK)
#endif
-#ifndef MAKE_OBJECT
-#define MAKE_OBJECT(TC, D) \
- ((((unsigned) (TC)) << ADDRESS_LENGTH) | (OBJECT_DATUM (D)))
-#endif
+#define OBJECT_DATUM(object) ((object) & DATUM_MASK)
+#define OBJECT_ADDRESS(object) (DATUM_TO_ADDRESS ((object) & DATUM_MASK))
-/* compatibility definitions */
-#define Type_Code(P) (OBJECT_TYPE (P))
-#define Datum(P) (OBJECT_DATUM (P))
-\f
-#ifndef Heap_In_Low_Memory /* Portable version */
+#define MAKE_OBJECT(type, datum) \
+ ((((unsigned int) (type)) << DATUM_LENGTH) | (datum))
-typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */
+#define OBJECT_NEW_DATUM(type_object, datum) \
+ (((type_object) & TYPE_CODE_MASK) | (datum))
-extern Pointer *Memory_Base;
+#define OBJECT_NEW_TYPE(type, datum_object) \
+ (MAKE_OBJECT ((type), (OBJECT_DATUM (datum_object))))
-/* The "-1" in the value returned is a guarantee that there is one
- word reserved exclusively for use by the garbage collector. */
+#define MAKE_OBJECT_FROM_OBJECTS(type_object, datum_object) \
+ (((type_object) & TYPE_CODE_MASK) | ((datum_object) & DATUM_MASK))
-#define Allocate_Heap_Space(space) \
- (Memory_Base = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \
- Heap = Memory_Base, \
- ((Memory_Base + (space)) - 1))
+#define MAKE_POINTER_OBJECT(type, address) \
+ (MAKE_OBJECT ((type), (ADDRESS_TO_DATUM (address))))
-#define Get_Pointer(P) ((Pointer *) (Memory_Base + (OBJECT_DATUM (P))))
-#define C_To_Scheme(P) ((Pointer) ((P) - Memory_Base))
+#define OBJECT_NEW_ADDRESS(object, address) \
+ (OBJECT_NEW_DATUM ((object), (ADDRESS_TO_DATUM (address))))
-#else /* not Heap_In_Low_Memory */
-/* Storing absolute addresses */
+#ifdef Heap_In_Low_Memory /* Storing absolute addresses */
typedef long relocation_type; /* Used to relocate pointers on fasload */
-#define Allocate_Heap_Space(space) \
- (Heap = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \
+/* The "-1" in the value returned is a guarantee that there is one
+ word reserved exclusively for use by the garbage collector. */
+#define ALLOCATE_HEAP_SPACE(space) \
+ (Heap = \
+ ((SCHEME_OBJECT *) (malloc ((sizeof (SCHEME_OBJECT)) * (space)))), \
((Heap + (space)) - 1))
-#define Get_Pointer(P) ((Pointer *) (OBJECT_DATUM (P)))
-#define C_To_Scheme(P) ((Pointer) (P))
+#define DATUM_TO_ADDRESS(datum) ((SCHEME_OBJECT *) (datum))
+#define ADDRESS_TO_DATUM(address) ((SCHEME_OBJECT) (address))
-#endif /* Heap_In_Low_Memory */
-\f
-#define Make_Pointer(TC, A) MAKE_OBJECT((TC), C_To_Scheme(A))
-#define Make_Non_Pointer(TC, D) MAKE_OBJECT(TC, ((Pointer) (D)))
+#else /* not Heap_In_Low_Memory (portable version) */
-/* (Make_New_Pointer (TC, A)) may be more efficient than
- (Make_Pointer (TC, (Get_Pointer (A)))) */
+/* Used to relocate pointers on fasload */
+typedef SCHEME_OBJECT * relocation_type;
+extern SCHEME_OBJECT * memory_base;
-#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) | (OBJECT_DATUM ((Pointer) (A))))
-
-#define Address(P) (OBJECT_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) (OBJECT_DATUM (Fast_Vector_Ref((P), 0)))
+/* The "-1" in the value returned is a guarantee that there is one
+ word reserved exclusively for use by the garbage collector. */
+#define ALLOCATE_HEAP_SPACE(space) \
+ (memory_base = \
+ ((SCHEME_OBJECT *) (malloc ((sizeof (SCHEME_OBJECT)) * (space)))), \
+ Heap = memory_base, \
+ ((memory_base + (space)) - 1))
-/* General case vector handling requires atomicity for parallel processors */
+#define DATUM_TO_ADDRESS(datum) ((SCHEME_OBJECT *) ((datum) + memory_base))
+#define ADDRESS_TO_DATUM(address) ((SCHEME_OBJECT) ((address) - memory_base))
-#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)
+#endif /* Heap_In_Low_Memory */
\f
+/* Lots of type predicates */
+
#define FIXNUM_P(object) ((OBJECT_TYPE (object)) == TC_FIXNUM)
#define BIGNUM_P(object) ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM)
#define FLONUM_P(object) ((OBJECT_TYPE (object)) == TC_BIG_FLONUM)
#define PAIR_P(object) ((OBJECT_TYPE (object)) == TC_LIST)
#define WEAK_PAIR_P(object) ((OBJECT_TYPE (object)) == TC_WEAK_CONS)
#define VECTOR_P(object) ((OBJECT_TYPE (object)) == TC_VECTOR)
+#define BOOLEAN_P(object) (((object) == SHARP_T) || ((object) == SHARP_F))
#define REFERENCE_TRAP_P(object) ((OBJECT_TYPE (object)) == TC_REFERENCE_TRAP)
+#define PRIMITIVE_P(object) ((OBJECT_TYPE (object)) == TC_PRIMITIVE)
+#define FUTURE_P(object) ((OBJECT_TYPE (object)) == TC_FUTURE)
+#define PROMISE_P(object) ((OBJECT_TYPE (object)) == TC_DELAYED)
+#define APPARENT_LIST_P(object) (((object) == EMPTY_LIST) || (PAIR_P (object)))
+#define CONTROL_POINT_P(object) ((OBJECT_TYPE (object)) == TC_CONTROL_POINT)
+#define BROKEN_HEART_P(object) ((OBJECT_TYPE (object)) == TC_BROKEN_HEART)
+#define GC_NON_POINTER_P(object) ((GC_Type (object)) == GC_Non_Pointer)
+#define GC_CELL_P(object) ((GC_Type (object)) == GC_Cell)
+#define GC_PAIR_P(object) ((GC_Type (object)) == GC_Pair)
+#define GC_TRIPLE_P(object) ((GC_Type (object)) == GC_Triple)
+#define GC_QUADRUPLE_P(object) ((GC_Type (object)) == GC_Quadruple)
+#define GC_VECTOR_P(object) ((GC_Type (object)) == GC_Vector)
+
+#define COMPILED_CODE_ADDRESS_P(object) \
+ ((OBJECT_TYPE (object)) == TC_COMPILED_ENTRY)
+
+#define STACK_ADDRESS_P(object) \
+ ((OBJECT_TYPE (object)) == TC_STACK_ENVIRONMENT)
#define NON_MARKED_VECTOR_P(object) \
((OBJECT_TYPE (object)) == TC_NON_MARKED_VECTOR)
((OBJECT_TYPE (object)) == TC_COMPLEX))
#define HUNK3_P(object) \
- (((OBJECT_TYPE(object)) == TC_HUNK3_A) || \
- ((OBJECT_TYPE(object)) == TC_HUNK3_B))
+ (((OBJECT_TYPE (object)) == TC_HUNK3_A) || \
+ ((OBJECT_TYPE (object)) == TC_HUNK3_B))
+
+#define INTERPRETER_APPLICABLE_P interpreter_applicable_p
+
+#define ENVIRONMENT_P(env) \
+ ((OBJECT_TYPE (env) == TC_ENVIRONMENT) || \
+ (OBJECT_TYPE (env) == GLOBAL_ENV))
\f
-#define MAKE_FIXNUM(N) (Make_Non_Pointer (TC_FIXNUM, (N)))
-#define FIXNUM_NEGATIVE_P(fixnum) (((fixnum) & FIXNUM_SIGN_BIT) != 0)
-#define MAKE_UNSIGNED_FIXNUM(N) (FIXNUM_ZERO + (N))
-#define UNSIGNED_FIXNUM_VALUE OBJECT_DATUM
-#define MAKE_SIGNED_FIXNUM MAKE_FIXNUM
-#define NONNEGATIVE_FIXNUM_P(x) ((FIXNUM_P (x)) && (! (FIXNUM_NEGATIVE_P (x))))
+/* Memory Operations */
+
+/* The FAST_ operations are used only where the object is known to be
+ immutable. On a parallel processor they don't require atomic
+ references. */
+
+#define FAST_MEMORY_REF(object, offset) \
+ ((OBJECT_ADDRESS (object)) [(offset)])
+
+#define FAST_MEMORY_SET(object, offset, value) \
+ ((OBJECT_ADDRESS (object)) [(offset)]) = (value)
+
+#define MEMORY_LOC(object, offset) \
+ (& ((OBJECT_ADDRESS (object)) [(offset)]))
+
+/* General case memory access requires atomicity for parallel processors. */
+
+#define MEMORY_REF(object, offset) \
+ (MEMORY_FETCH ((OBJECT_ADDRESS (object)) [(offset)]))
+
+#define MEMORY_SET(object, offset, value) \
+ MEMORY_STORE (((OBJECT_ADDRESS (object)) [(offset)]), (value))
+
+/* Pair Operations */
+
+#define FAST_PAIR_CAR(pair) (FAST_MEMORY_REF ((pair), CONS_CAR))
+#define FAST_PAIR_CDR(pair) (FAST_MEMORY_REF ((pair), CONS_CDR))
+#define FAST_SET_PAIR_CAR(pair, car) FAST_MEMORY_SET ((pair), CONS_CAR, (car))
+#define FAST_SET_PAIR_CDR(pair, cdr) FAST_MEMORY_SET ((pair), CONS_CDR, (cdr))
+#define PAIR_CAR_LOC(pair) (MEMORY_LOC ((pair), CONS_CAR))
+#define PAIR_CDR_LOC(pair) (MEMORY_LOC ((pair), CONS_CDR))
-#define FIXNUM_VALUE(fixnum, target) \
-do \
+#define PAIR_CAR(pair) (MEMORY_REF ((pair), CONS_CAR))
+#define PAIR_CDR(pair) (MEMORY_REF ((pair), CONS_CDR))
+#define SET_PAIR_CAR(pair, car) MEMORY_SET ((pair), CONS_CAR, (car))
+#define SET_PAIR_CDR(pair, cdr) MEMORY_SET ((pair), CONS_CDR, (cdr))
+
+/* Vector Operations */
+
+#define VECTOR_LENGTH(vector) (OBJECT_DATUM (FAST_MEMORY_REF ((vector), 0)))
+
+#define SET_VECTOR_LENGTH(vector, length) \
+ FAST_MEMORY_SET \
+ ((vector), \
+ 0, \
+ (OBJECT_NEW_DATUM ((FAST_MEMORY_REF ((vector), 0)), (length))));
+
+#define FAST_VECTOR_REF(vector, index) \
+ (FAST_MEMORY_REF ((vector), ((index) + 1)))
+
+#define FAST_VECTOR_SET(vector, index, value) \
+ FAST_MEMORY_SET ((vector), ((index) + 1), (value))
+
+#define VECTOR_LOC(vector, index) (MEMORY_LOC ((vector), ((index) + 1)))
+#define VECTOR_REF(vector, index) (MEMORY_REF ((vector), ((index) + 1)))
+
+#define VECTOR_SET(vector, index, value) \
+ MEMORY_SET ((vector), ((index) + 1), (value))
+\f
+/* String Operations */
+
+/* Add 1 byte to length to account for '\0' at end of string.
+ Add 1 word to length to account for string header word. */
+#define STRING_LENGTH_TO_GC_LENGTH(length) \
+ ((BYTES_TO_WORDS ((length) + 1)) + 1)
+
+#define STRING_LENGTH(string) \
+ ((long) (MEMORY_REF ((string), STRING_LENGTH_INDEX)))
+
+#define SET_STRING_LENGTH(string, length) do \
{ \
- (target) = (UNSIGNED_FIXNUM_VALUE (fixnum)); \
- if (FIXNUM_NEGATIVE_P (target)) \
- (target) |= (-1 << ADDRESS_LENGTH); \
+ MEMORY_SET ((string), STRING_LENGTH_INDEX, (length)); \
+ STRING_SET ((string), (length), '\0'); \
} while (0)
-/* Compatibility */
-#define Make_Unsigned_Fixnum MAKE_UNSIGNED_FIXNUM
-#define Make_Signed_Fixnum MAKE_FIXNUM
-#define Get_Integer OBJECT_DATUM
-#define Sign_Extend FIXNUM_VALUE
+/* Subtract 1 to account for the fact that we maintain a '\0'
+ at the end of the string. */
+#define MAXIMUM_STRING_LENGTH(string) \
+ ((long) ((((VECTOR_LENGTH (string)) - 1) * (sizeof (SCHEME_OBJECT))) - 1))
-#define BOOLEAN_TO_OBJECT(expression) ((expression) ? SHARP_T : SHARP_F)
+#define SET_MAXIMUM_STRING_LENGTH(string, length) \
+ SET_VECTOR_LENGTH ((string), (STRING_LENGTH_TO_GC_LENGTH (length)))
+
+#define STRING_LOC(string, index) \
+ (((unsigned char *) (MEMORY_LOC (string, STRING_CHARS))) + (index))
+
+#define STRING_REF(string, index) \
+ ((int) (* (STRING_LOC ((string), (index)))))
+
+#define STRING_SET(string, index, c_char) \
+ (* (STRING_LOC ((string), (index)))) = (c_char)
+
+/* Character Operations */
+
+#define ASCII_LENGTH CHAR_BIT /* CHAR_BIT in config.h - 8 for unix */
+#define CODE_LENGTH 7
+#define BITS_LENGTH 5
+#define MIT_ASCII_LENGTH 12
+
+#define CHAR_BITS_META 01
+#define CHAR_BITS_CONTROL 02
+#define CHAR_BITS_CONTROL_META 03
+
+#define MAX_ASCII (1 << ASCII_LENGTH)
+#define MAX_CODE (1 << CODE_LENGTH)
+#define MAX_BITS (1 << BITS_LENGTH)
+#define MAX_MIT_ASCII (1 << MIT_ASCII_LENGTH)
+
+#define MASK_ASCII (MAX_ASCII - 1)
+#define CHAR_MASK_CODE (MAX_CODE - 1)
+#define CHAR_MASK_BITS (MAX_BITS - 1)
+#define MASK_MIT_ASCII (MAX_MIT_ASCII - 1)
+
+#define ASCII_TO_CHAR(ascii) (MAKE_OBJECT (TC_CHARACTER, (ascii)))
+#define CHAR_TO_ASCII_P(object) ((OBJECT_DATUM (object)) < MAX_ASCII)
+#define CHAR_TO_ASCII(object) ((object) & MASK_ASCII)
+
+#define MAKE_CHAR(bucky_bits, code) \
+ (MAKE_OBJECT \
+ (TC_CHARACTER, \
+ (((unsigned long) (bucky_bits)) << (CODE_LENGTH)) | (code)))
+
+#define CHAR_BITS(chr) \
+ ((((unsigned long) (OBJECT_DATUM (chr))) >> CODE_LENGTH) & CHAR_MASK_BITS)
+
+#define CHAR_CODE(chr) ((OBJECT_DATUM (chr)) & CHAR_MASK_CODE)
+\f
+/* Fixnum Operations */
+
+#define FIXNUM_ZERO_P(fixnum) ((OBJECT_DATUM (fixnum)) == 0)
+#define FIXNUM_NEGATIVE_P(fixnum) (((fixnum) & FIXNUM_SIGN_BIT) != 0)
+#define UNSIGNED_FIXNUM_P(x) ((FIXNUM_P (x)) && (! (FIXNUM_NEGATIVE_P (x))))
+#define FIXNUM_EQUAL_P(x, y) ((OBJECT_DATUM (x)) == (OBJECT_DATUM (y)))
+#define FIXNUM_LESS_P(x, y) ((FIXNUM_TO_LONG (x)) < (FIXNUM_TO_LONG (y)))
+
+#define FIXNUM_POSITIVE_P(fixnum) \
+ (! ((FIXNUM_ZERO_P (fixnum)) || (FIXNUM_NEGATIVE_P (fixnum))))
+
+#define UNSIGNED_FIXNUM_TO_LONG(fixnum) ((long) (OBJECT_DATUM (fixnum)))
+#define LONG_TO_UNSIGNED_FIXNUM_P(value) (((value) & SIGN_MASK) == 0)
+#define LONG_TO_UNSIGNED_FIXNUM(value) (FIXNUM_ZERO + (value))
+#define LONG_TO_FIXNUM(value) (OBJECT_NEW_TYPE (TC_FIXNUM, (value)))
-#define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N))
-#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1))))
+#define LONG_TO_FIXNUM_P(value) \
+ ((((value) & SIGN_MASK) == 0) || (((value) & SIGN_MASK) == SIGN_MASK))
-#define Fixnum_Fits(x) \
- ((((x) & SIGN_MASK) == 0) || \
- (((x) & SIGN_MASK) == SIGN_MASK))
+#if 0
+/* #ifdef __GNUC__
+ Still doesn't compile correctly as of GCC 1.35! */
-#define BYTES_TO_POINTERS(nbytes) \
- (((nbytes) + ((sizeof (Pointer)) - 1)) / (sizeof (Pointer)))
+#define FIXNUM_TO_LONG(fixnum) \
+ ({ \
+ long _temp = ((long) (OBJECT_DATUM (fixnum))); \
+ (((_temp & FIXNUM_SIGN_BIT) != 0) \
+ ? (_temp | (-1 << DATUM_LENGTH)) \
+ : _temp); \
+ })
-#define Is_Constant(address) \
+#else
+
+#define FIXNUM_TO_LONG(fixnum) \
+ ((FIXNUM_NEGATIVE_P (fixnum)) \
+ ? (((long) (OBJECT_DATUM (fixnum))) | ((long) (-1 << DATUM_LENGTH))) \
+ : ((long) (OBJECT_DATUM (fixnum))))
+
+#endif
+
+#define FIXNUM_TO_DOUBLE(fixnum) ((double) (FIXNUM_TO_LONG (fixnum)))
+
+#define DOUBLE_TO_FIXNUM_P(number) \
+ (((number) > (((double) SMALLEST_FIXNUM) - 0.5)) && \
+ ((number) < (((double) BIGGEST_FIXNUM) + 0.5)))
+
+#ifdef HAVE_DOUBLE_TO_LONG_BUG
+#define DOUBLE_TO_FIXNUM double_to_fixnum
+#else
+#define DOUBLE_TO_FIXNUM(number) (LONG_TO_FIXNUM ((long) (number)))
+#endif
+\f
+/* Bignum Operations */
+
+#define BIGNUM_ZERO_P(bignum) \
+ ((bignum_test (bignum)) == bignum_comparison_equal)
+
+#define BIGNUM_NEGATIVE_P(bignum) \
+ ((bignum_test (bignum)) == bignum_comparison_less)
+
+#define BIGNUM_POSITIVE_P(bignum) \
+ ((bignum_test (bignum)) == bignum_comparison_greater)
+
+#define BIGNUM_LESS_P(x, y) \
+ ((bignum_compare ((x), (y))) == bignum_comparison_less)
+
+#define BIGNUM_TO_LONG_P(bignum) \
+ (bignum_fits_in_word_p ((bignum), ((sizeof (long)) * CHAR_BIT), 1))
+
+/* If precision should not be lost,
+ compare to FLONUM_MANTISSA_BITS instead. */
+#define BIGNUM_TO_DOUBLE_P(bignum) \
+ (bignum_fits_in_word_p ((bignum), MAX_FLONUM_EXPONENT, 0))
+
+/* Flonum Operations */
+
+#define FLONUM_TO_DOUBLE(object) \
+ (* ((double *) (MEMORY_LOC ((object), 1))))
+
+#define FLOAT_TO_FLONUM(expression) \
+ (double_to_flonum ((double) (expression)))
+
+#define FLONUM_TRUNCATE(object) \
+ (double_to_flonum (double_truncate (FLONUM_TO_DOUBLE (object))))
+
+/* Numeric Type Conversions */
+
+#define BIGNUM_TO_FIXNUM_P(bignum) \
+ (bignum_fits_in_word_p ((bignum), (FIXNUM_LENGTH + 1), 1))
+
+#define FIXNUM_TO_BIGNUM(fixnum) (long_to_bignum (FIXNUM_TO_LONG (fixnum)))
+#define FIXNUM_TO_FLONUM(fixnum) (double_to_flonum (FIXNUM_TO_DOUBLE (fixnum)))
+#define BIGNUM_TO_FIXNUM(bignum) (LONG_TO_FIXNUM (bignum_to_long (bignum)))
+#define BIGNUM_TO_FLONUM_P BIGNUM_TO_DOUBLE_P
+#define BIGNUM_TO_FLONUM(bignum) (double_to_flonum (bignum_to_double (bignum)))
+#define FLONUM_TO_BIGNUM(flonum) (double_to_bignum (FLONUM_TO_DOUBLE (flonum)))
+#define FLONUM_TO_INTEGER(x) (double_to_integer (FLONUM_TO_DOUBLE (x)))
+#define INTEGER_TO_FLONUM_P integer_to_double_p
+#define INTEGER_TO_FLONUM(n) (double_to_flonum (integer_to_double (n)))
+\f
+#define BOOLEAN_TO_OBJECT(expression) ((expression) ? SHARP_T : SHARP_F)
+#define OBJECT_TO_BOOLEAN(object) ((object) != SHARP_F)
+
+#define MAKE_BROKEN_HEART(address) \
+ (BROKEN_HEART_ZERO + (ADDRESS_TO_DATUM (address)))
+
+#define BYTES_TO_WORDS(nbytes) \
+ (((nbytes) + ((sizeof (SCHEME_OBJECT)) - 1)) / (sizeof (SCHEME_OBJECT)))
+
+#define ADDRESS_CONSTANT_P(address) \
(((address) >= Constant_Space) && ((address) < Free_Constant))
-#define Is_Pure(address) \
- ((Is_Constant (address)) && (Pure_Test (address)))
+#define ADDRESS_PURE_P(address) \
+ ((ADDRESS_CONSTANT_P (address)) && (Pure_Test (address)))
-#define Side_Effect_Impurify(Old_Pointer, Will_Contain) \
-if ((Is_Constant (Get_Pointer (Old_Pointer))) && \
+#define SIDE_EFFECT_IMPURIFY(Old_Pointer, Will_Contain) \
+if ((ADDRESS_CONSTANT_P (OBJECT_ADDRESS (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); \
-\f
+ (! (ADDRESS_CONSTANT_P (OBJECT_ADDRESS (Will_Contain)))) && \
+ (Pure_Test (OBJECT_ADDRESS (Old_Pointer)))) \
+ signal_error_from_primitive (ERR_WRITE_INTO_PURE_SPACE); \
+
#ifdef FLOATING_ALIGNMENT
#define FLOATING_BUFFER_SPACE \
- ((FLOATING_ALIGNMENT + 1)/sizeof(Pointer))
+ ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT)))
#define HEAP_BUFFER_SPACE \
(TRAP_MAX_IMMEDIATE + 1 + FLOATING_BUFFER_SPACE)
/* The space is there, find the correct position. */
-#define Initial_Align_Float(Where) \
+#define INITIAL_ALIGN_FLOAT(Where) \
{ \
while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
Where -= 1; \
}
-#define Align_Float(Where) \
+#define ALIGN_FLOAT(Where) \
{ \
while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
- *Where++ = (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, 0)); \
+ *Where++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); \
}
#else not FLOATING_ALIGNMENT
#define HEAP_BUFFER_SPACE (TRAP_MAX_IMMEDIATE + 1)
-#define Initial_Align_Float(Where)
-#define Align_Float(Where)
+#define INITIAL_ALIGN_FLOAT(Where)
+#define ALIGN_FLOAT(Where)
#endif FLOATING_ALIGNMENT
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.34 1989/08/28 18:28:03 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.35 1989/09/20 23:04:42 cph Exp $
Copyright (c) 1987, 1989 Massachusetts Institute of Technology
\f
/* These are needed by load.c */
-static Pointer *Memory_Base;
+static SCHEME_OBJECT * memory_base;
long
Load_Data(Count, To_Where)
{
extern int fread();
- return (fread(To_Where, sizeof(Pointer), Count, stdin));
+ return (fread(To_Where, sizeof(SCHEME_OBJECT), Count, stdin));
}
long
#ifdef Heap_In_Low_Memory
#ifdef spectrum
-#define File_To_Pointer(P) ((((long) (P)) & ADDRESS_MASK) / sizeof(Pointer))
+#define File_To_Pointer(P) \
+ ((((long) (P)) & DATUM_MASK) / sizeof(SCHEME_OBJECT))
#else
-#define File_To_Pointer(P) ((P) / sizeof(Pointer))
+#define File_To_Pointer(P) ((P) / sizeof(SCHEME_OBJECT))
#endif /* spectrum */
#else
-#define File_To_Pointer(P) (P)
+#define File_To_Pointer(P) (P)
#endif
#ifndef Conditional_Bug
#define Relocate(P) (Relocate_Into(Relocate_Temp, P), Relocate_Temp)
#endif
-static Pointer *Data, *end_of_memory;
+static SCHEME_OBJECT *Data, *end_of_memory;
Boolean
scheme_string(From, Quoted)
Chars = ((char *) &Data[From + STRING_CHARS]);
if (Chars < ((char *) end_of_memory))
{
- Count = ((long) (Data[From + STRING_LENGTH]));
+ Count = ((long) (Data[From + STRING_LENGTH_INDEX]));
if (&Chars[Count] < ((char *) end_of_memory))
{
if (Quoted)
return (false);
}
-#define via(File_Address) Relocate(OBJECT_DATUM(Data[File_Address]))
+#define via(File_Address) Relocate(OBJECT_DATUM (Data[File_Address]))
void
scheme_symbol(From)
long From;
{
- Pointer *symbol;
+ SCHEME_OBJECT *symbol;
symbol = &Data[From+SYMBOL_NAME];
if ((symbol >= end_of_memory) ||
long Points_To;
printf("%5lx: %2lx|%6lx ", Location, Type, The_Datum);
- Points_To = Relocate((Pointer *) The_Datum);
+ Points_To = Relocate((SCHEME_OBJECT *) The_Datum);
switch (Type)
{ /* "Strange" cases */
case TC_NULL:
if (The_Datum == 0)
{
- printf("NIL\n");
+ printf("#F\n");
return;
}
NON_POINTER("NULL");
case TC_TRUE:
if (The_Datum == 0)
{
- printf("TRUE\n");
+ printf("#T\n");
return;
}
/* fall through */
scheme_symbol(Points_To);
return;
- case TC_UNINTERNED_SYMBOL:
+ case TC_UNINTERNED_SYMBOL:
PRINT_OBJECT("UNINTERNED-SYMBOL", Points_To);
printf(" = ");
scheme_symbol(Points_To);
case TC_FIXNUM:
PRINT_OBJECT("FIXNUM", The_Datum);
- Sign_Extend(The_Datum, Points_To);
+ Points_To = (FIXNUM_TO_LONG (The_Datum));
printf(" = %ld\n", Points_To);
return;
return;
}
\f
-Pointer *
+SCHEME_OBJECT *
show_area(area, start, end, name)
- fast Pointer *area;
+ fast SCHEME_OBJECT *area;
long start;
fast long end;
char *name;
printf("\n%s contents:\n\n", name);
for (i = start; i < end; area++, i++)
{
- if ((OBJECT_TYPE(*area) == TC_MANIFEST_NM_VECTOR) ||
- (OBJECT_TYPE(*area) == TC_MANIFEST_CLOSURE) ||
- (OBJECT_TYPE(*area) == TC_LINKAGE_SECTION))
+ if ((OBJECT_TYPE (*area) == TC_MANIFEST_NM_VECTOR) ||
+ (OBJECT_TYPE (*area) == TC_MANIFEST_CLOSURE) ||
+ (OBJECT_TYPE (*area) == TC_LINKAGE_SECTION))
{
fast long j, count;
count =
- ((OBJECT_TYPE(*area) == TC_LINKAGE_SECTION)
+ ((OBJECT_TYPE (*area) == TC_LINKAGE_SECTION)
? (READ_CACHE_LINKAGE_COUNT (*area))
: (OBJECT_DATUM (*area)));
- Display(i, OBJECT_TYPE(*area), OBJECT_DATUM(*area));
+ Display(i, OBJECT_TYPE (*area), OBJECT_DATUM (*area));
area += 1;
for (j = 0; j < count ; j++, area++)
{
printf(" %02lx%06lx\n",
- OBJECT_TYPE(*area), OBJECT_DATUM(*area));
+ OBJECT_TYPE (*area), OBJECT_DATUM (*area));
}
i += count;
area -= 1;
}
else
{
- Display(i, OBJECT_TYPE(*area), OBJECT_DATUM(*area));
+ Display(i, OBJECT_TYPE (*area), OBJECT_DATUM (*area));
}
}
return (area);
int argc;
char **argv;
{
- fast Pointer *Next;
+ fast SCHEME_OBJECT *Next;
long total_length, load_length;
if (argc == 1)
sscanf(argv[3], "%d", &Heap_Count);
printf("Heap Base = 0x%lx; Constant Base = 0x%lx; Heap Count = %ld\n",
Heap_Base, Const_Base, Heap_Count);
- }
+ }
\f
load_length = (Heap_Count + Const_Count + Primitive_Table_Size);
- Data = ((Pointer *) malloc(sizeof(Pointer) * (load_length + 4)));
+ Data = ((SCHEME_OBJECT *) malloc(sizeof(SCHEME_OBJECT) * (load_length + 4)));
if (Data == NULL)
{
fprintf(stderr, "Allocation of %ld words failed.\n", (load_length + 4));
fast long entries, count;
/* This is done in case the file is short. */
- end_of_memory[0] = ((Pointer) 0);
- end_of_memory[1] = ((Pointer) 0);
- end_of_memory[2] = ((Pointer) 0);
- end_of_memory[3] = ((Pointer) 0);
+ end_of_memory[0] = ((SCHEME_OBJECT) 0);
+ end_of_memory[1] = ((SCHEME_OBJECT) 0);
+ end_of_memory[2] = ((SCHEME_OBJECT) 0);
+ end_of_memory[3] = ((SCHEME_OBJECT) 0);
entries = Primitive_Table_Length;
printf("\nPrimitive table: number of entries = %ld\n\n", entries);
((count < entries) && (Next < end_of_memory));
count += 1)
{
- Sign_Extend(*Next++, arity);
+ arity = (FIXNUM_TO_LONG (*Next));
+ Next += 1;
size = (OBJECT_DATUM (*Next));
printf("Number = %3lx; Arity = %2ld; Name = ", count, arity);
scheme_string((Next - Data), true);
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbmap.h,v 9.29 1989/09/20 23:10:51 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbmap.h,v 9.28 1989/08/28 18:29:21 cph Exp $
- *
- * This file contains macros and declarations for Bintopsb.c
- * and Psbtobin.c
- *
- */
+/* This file contains macros and declarations for "Bintopsb.c"
+ and "Psbtobin.c". */
\f
/* These definitions insure that the appropriate code is extracted
from the included files.
#include "types.h"
#include "object.h"
#include "bignum.h"
+#include "bignumint.h"
#include "bitstr.h"
#include "sdata.h"
#include "const.h"
#include "gccode.h"
-#include "char.h"
#ifdef HAS_FREXP
extern double frexp(), ldexp();
#define NROOTS 1
-/* Types to recognize external object references. Any occurrence of these
+/* 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 HEAP_CODE TC_CHARACTER
#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)
-/*
- 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 to_pointer(size) \
- (((size) + (sizeof(Pointer) - 1)) / sizeof(Pointer))
-
-#define bigdigit_to_pointer(ndig) \
- to_pointer((ndig) * sizeof(bigdigit))
+#define to_pointer BYTES_TO_WORDS
#define float_to_pointer \
- to_pointer(sizeof(double))
+ BYTES_TO_WORDS(sizeof(double))
#define flonum_to_pointer(nchars) \
((nchars) * (1 + float_to_pointer))
#define char_to_pointer(nchars) \
- to_pointer(nchars)
+ BYTES_TO_WORDS(nchars)
#define pointer_to_char(npoints) \
- ((npoints) * sizeof(Pointer))
+ ((npoints) * sizeof(SCHEME_OBJECT))
\f
/* Status flags */
/* Global data */
#ifndef Heap_In_Low_Memory
-static Pointer *Memory_Base;
+static SCHEME_OBJECT * memory_base;
#endif
static long
compiler_processor_type = 0,
compiler_interface_version = 0;
-static Pointer
- compiler_utilities = NIL;
+static SCHEME_OBJECT
+ compiler_utilities = SHARP_F;
\f
/* Utilities */
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.36 1989/09/20 23:04:46 cph Exp $
+
Copyright (c) 1987, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.35 1989/08/28 18:28:07 cph Exp $
- *
- * This File contains the code to translate portable format binary
- * files to internal format.
- *
- */
+/* This file contains the code to translate portable format binary
+ files to internal format. */
\f
/* Cheap renames */
Dumped_Pure_Base, Pure_Objects, Pure_Count,
Primitive_Table_Length;
-static Pointer
+static SCHEME_OBJECT
*Heap,
*Heap_Base, *Heap_Table, *Heap_Object_Base, *Free,
*Constant_Base, *Constant_Table,
long
Write_Data(Count, From_Where)
long Count;
- Pointer *From_Where;
+ SCHEME_OBJECT *From_Where;
{
extern int fwrite();
- return (fwrite(((char *) From_Where), sizeof(Pointer),
+ return (fwrite(((char *) From_Where), sizeof(SCHEME_OBJECT),
Count, internal_file));
}
}
}
\f
-Pointer *
+SCHEME_OBJECT *
read_a_string_internal(To, maxlen)
- Pointer *To;
+ SCHEME_OBJECT *To;
long maxlen;
{
long ilen, Pointer_Count;
Pointer_Count = STRING_CHARS + char_to_pointer(maxlen);
To[STRING_HEADER] =
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1));
- To[STRING_LENGTH] = ((Pointer) len);
+ MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1));
+ To[STRING_LENGTH_INDEX] = ((SCHEME_OBJECT) len);
/* Space */
return (To + Pointer_Count);
}
-Pointer *
+SCHEME_OBJECT *
read_a_string(To, Slot)
- Pointer *To, *Slot;
+ SCHEME_OBJECT *To, *Slot;
{
long maxlen;
- *Slot = Make_Pointer(TC_CHARACTER_STRING, To);
+ *Slot = MAKE_POINTER_OBJECT(TC_CHARACTER_STRING, To);
fscanf(portable_file, "%ld", &maxlen);
return (read_a_string_internal(To, maxlen));
}
#endif
\f
-Pointer *
+SCHEME_OBJECT *
read_an_integer(The_Type, To, Slot)
int The_Type;
- Pointer *To;
- Pointer *Slot;
+ SCHEME_OBJECT *To;
+ SCHEME_OBJECT *Slot;
{
Boolean negative;
- long size_in_bits;
+ fast long length_in_bits;
getc(portable_file); /* Space */
negative = ((getc(portable_file)) == '-');
- fscanf(portable_file, "%ld", &size_in_bits);
- if ((size_in_bits <= fixnum_to_bits) &&
+ {
+ long l;
+ fscanf (portable_file, "%ld", (&l));
+ length_in_bits = l;
+ }
+ if ((length_in_bits <= fixnum_to_bits) &&
(The_Type == TC_FIXNUM))
{
fast long Value = 0;
fast long ndigits;
long digit;
- if (size_in_bits != 0)
+ if (length_in_bits != 0)
{
for(Normalization = 0,
- ndigits = hex_digits(size_in_bits);
+ ndigits = hex_digits(length_in_bits);
--ndigits >= 0;
Normalization += 4)
{
{
Value = -Value;
}
- *Slot = MAKE_SIGNED_FIXNUM(Value);
+ *Slot = LONG_TO_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))
+ else if (length_in_bits == 0)
{
- fprintf(stderr,
- "%s: Fixnum too large, coercing to bignum.\n",
- program_name);
+ SCHEME_OBJECT bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, To));
+ long gc_length = (BIGNUM_LENGTH_TO_GC_LENGTH (0));
+ (*To) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, gc_length));
+ BIGNUM_SET_HEADER (bignum, 0, 0);
+ (*Slot) = bignum;
+ return (To + gc_length + 1);
}
- 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;
- )
+ else
{
- for ( ;
- (nbits < SHIFT) && (ndigits > 0);
- ndigits -= 1, nbits += 4)
- {
- long digit;
-
- read_hex_digit(digit);
- Temp |= (((unsigned long) digit) << nbits);
- }
- *The_Bignum++ = Rem_Radix(Temp);
- Temp = Div_Radix(Temp);
- nbits -= SHIFT;
+ SCHEME_OBJECT bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, To));
+ bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (length_in_bits));
+ long gc_length = (BIGNUM_LENGTH_TO_GC_LENGTH (length));
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ fast bignum_digit_type accumulator = 0;
+ fast int bits_in_digit =
+ ((length_in_bits < BIGNUM_DIGIT_LENGTH)
+ ? length_in_bits
+ : BIGNUM_DIGIT_LENGTH);
+ fast int position = 0;
+ int hex_digit;
+ while (length_in_bits > 0)
+ {
+ read_hex_digit (hex_digit);
+ if (bits_in_digit > 4)
+ {
+ accumulator |= (hex_digit << position);
+ length_in_bits -= 4;
+ position += 4;
+ bits_in_digit -= 4;
+ }
+ else if (bits_in_digit == 4)
+ {
+ (*scan++) = (accumulator | (hex_digit << position));
+ accumulator = 0;
+ position = 0;
+ length_in_bits -= 4;
+ bits_in_digit =
+ ((length_in_bits < BIGNUM_DIGIT_LENGTH)
+ ? length_in_bits
+ : BIGNUM_DIGIT_LENGTH);
+ }
+ else
+ {
+ (*scan++) =
+ (accumulator |
+ ((hex_digit & ((1 << bits_in_digit) - 1)) << position));
+ accumulator = (hex_digit >> bits_in_digit);
+ position = (4 - bits_in_digit);
+ length_in_bits -= 4;
+ if (length_in_bits >= BIGNUM_DIGIT_LENGTH)
+ bits_in_digit = BIGNUM_DIGIT_LENGTH;
+ else if (length_in_bits > 0)
+ bits_in_digit = length_in_bits;
+ else
+ {
+ (*scan) = accumulator;
+ break;
+ }
+ }
+ }
+ (*To) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, gc_length));
+ BIGNUM_SET_HEADER (bignum, length, negative);
+ (*Slot) = bignum;
+ return (To + gc_length + 1);
}
- *Slot = Make_Pointer(TC_BIG_FIXNUM, To);
- return (To + Length);
- }
}
\f
-Pointer *
+SCHEME_OBJECT *
read_a_bit_string(To, Slot)
- Pointer *To, *Slot;
+ SCHEME_OBJECT *To, *Slot;
{
long size_in_bits, size_in_words;
- Pointer the_bit_string;
+ SCHEME_OBJECT the_bit_string;
fscanf(portable_file, "%ld", &size_in_bits);
- size_in_words = (1 + bits_to_pointers (size_in_bits));
+ size_in_words = (1 + (BIT_STRING_LENGTH_TO_GC_LENGTH (size_in_bits)));
- the_bit_string = Make_Pointer(TC_BIT_STRING, To);
- *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, size_in_words);
+ the_bit_string = MAKE_POINTER_OBJECT (TC_BIT_STRING, To);
+ *To++ = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, size_in_words);
*To = size_in_bits;
To += size_in_words;
if (size_in_bits != 0)
{
unsigned long temp;
- fast Pointer *scan;
+ fast SCHEME_OBJECT *scan;
fast long bits_remaining, bits_accumulated;
- fast Pointer accumulator, next_word;
+ fast SCHEME_OBJECT accumulator, next_word;
accumulator = 0;
bits_accumulated = 0;
- scan = bit_string_low_ptr(the_bit_string);
+ scan = BIT_STRING_LOW_PTR(the_bit_string);
for(bits_remaining = size_in_bits;
bits_remaining > 0;
bits_remaining -= 4)
{
read_hex_digit(temp);
- if ((bits_accumulated + 4) > POINTER_LENGTH)
+ if ((bits_accumulated + 4) > OBJECT_LENGTH)
{
accumulator |=
- ((temp & low_mask(POINTER_LENGTH - bits_accumulated)) <<
+ ((temp & LOW_MASK(OBJECT_LENGTH - bits_accumulated)) <<
bits_accumulated);
- *(inc_bit_string_ptr(scan)) = accumulator;
- accumulator = (temp >> (POINTER_LENGTH - bits_accumulated));
- bits_accumulated -= (POINTER_LENGTH - 4);
- temp &= low_mask(bits_accumulated);
+ *(INC_BIT_STRING_PTR(scan)) = accumulator;
+ accumulator = (temp >> (OBJECT_LENGTH - bits_accumulated));
+ bits_accumulated -= (OBJECT_LENGTH - 4);
+ temp &= LOW_MASK(bits_accumulated);
}
else
{
}
if (bits_accumulated != 0)
{
- *(inc_bit_string_ptr(scan)) = accumulator;
+ *(INC_BIT_STRING_PTR(scan)) = accumulator;
}
}
*Slot = the_bit_string;
#define dflmin() 0.0 /* Cop out */
#define dflmax() ((the_max == 0.0) ? compute_max() : the_max)
-double
+double
compute_max()
{
fast double Result;
return (Result);
}
\f
-double
+double
read_a_flonum()
{
Boolean negative;
return (Result);
}
\f
-Pointer *
+SCHEME_OBJECT *
Read_External(N, Table, To)
long N;
- fast Pointer *Table, *To;
+ fast SCHEME_OBJECT *Table, *To;
{
- fast Pointer *Until = &Table[N];
+ fast SCHEME_OBJECT *Until = &Table[N];
int The_Type;
while (Table < Until)
getc(portable_file); /* Space */
VMS_BUG(the_char_code = 0);
fscanf( portable_file, "%3lx", &the_char_code);
- *Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
+ *Table++ = MAKE_OBJECT (TC_CHARACTER, the_char_code);
continue;
}
\f
{
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));
+ ALIGN_FLOAT (To);
+ *Table++ = MAKE_POINTER_OBJECT (TC_BIG_FLONUM, To);
+ *To++ = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (float_to_pointer));
*((double *) To) = The_Flonum;
To += float_to_pointer;
continue;
void
Move_Memory(From, N, To)
- fast Pointer *From, *To;
+ fast SCHEME_OBJECT *From, *To;
long N;
{
- fast Pointer *Until;
+ fast SCHEME_OBJECT *Until;
Until = &From[N];
while (From < Until)
void
Relocate_Objects(from, how_many, disp)
- fast Pointer *from;
+ fast SCHEME_OBJECT *from;
fast long disp;
long how_many;
{
- fast Pointer *Until;
+ fast SCHEME_OBJECT *Until;
Until = &from[how_many];
while (from < Until)
{
- switch(OBJECT_TYPE(*from))
+ switch(OBJECT_TYPE (*from))
{
case TC_FIXNUM:
case TC_CHARACTER:
case TC_BIG_FIXNUM:
case TC_BIG_FLONUM:
case TC_CHARACTER_STRING:
- *from++ == MAKE_OBJECT(OBJECT_TYPE(*from), (disp + OBJECT_DATUM(*from)));
+ *from++ ==
+ (OBJECT_NEW_DATUM ((*from), (disp + OBJECT_DATUM (*from))));
break;
default:
fprintf(stderr,
"%s: Unknown External Object Reference with Type 0x%02x",
program_name,
- OBJECT_TYPE(*from));
+ OBJECT_TYPE (*from));
inconsistency();
}
}
#else
-static Pointer *Relocate_Temp;
+static SCHEME_OBJECT *Relocate_Temp;
#define Relocate(Addr) \
(Relocate_Into(Relocate_Temp, Addr), Relocate_Temp)
#endif
\f
-Pointer *
+SCHEME_OBJECT *
Read_Pointers_and_Relocate(how_many, to)
fast long how_many;
- fast Pointer *to;
+ fast SCHEME_OBJECT *to;
{
int The_Type;
long The_Datum;
#if false
- Align_Float(to);
+ ALIGN_FLOAT (to);
#endif
while (--how_many >= 0)
case CONSTANT_CODE:
*to++ = Constant_Table[The_Datum];
continue;
-
+
case HEAP_CODE:
*to++ = Heap_Table[The_Datum];
continue;
-
+
case TC_MANIFEST_NM_VECTOR:
- *to++ = Make_Non_Pointer(The_Type, The_Datum);
+ *to++ = MAKE_OBJECT (The_Type, The_Datum);
{
fast long count;
-
+
count = The_Datum;
how_many -= count;
while (--count >= 0)
\f
case TC_COMPILED_ENTRY:
{
- Pointer *temp;
+ SCHEME_OBJECT *temp;
long base_type, base_datum;
fscanf(portable_file, "%02x %lx", &base_type, &base_datum);
temp = Relocate(base_datum);
- *to++ = Make_Pointer(base_type,
- ((Pointer *) (&(((char *) temp)[The_Datum]))));
+ *to++ =
+ (MAKE_POINTER_OBJECT
+ (base_type, ((SCHEME_OBJECT *) (&(((char *) temp)[The_Datum])))));
break;
}
case TC_PRIMITIVE:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case_simple_Non_Pointer:
- *to++ = Make_Non_Pointer(The_Type, The_Datum);
+ *to++ = MAKE_OBJECT (The_Type, The_Datum);
continue;
case TC_MANIFEST_CLOSURE:
case TC_REFERENCE_TRAP:
if (The_Datum <= TRAP_MAX_IMMEDIATE)
{
- *to++ = Make_Non_Pointer(The_Type, The_Datum);
+ *to++ = MAKE_OBJECT (The_Type, The_Datum);
continue;
}
/* It is a pointer, fall through. */
default:
/* Should be stricter */
- *to++ = Make_Pointer(The_Type, Relocate(The_Datum));
+ *to++ = MAKE_POINTER_OBJECT (The_Type, Relocate(The_Datum));
continue;
}
}
#if false
- Align_Float(to);
+ ALIGN_FLOAT (to);
#endif
return (to);
}
\f
static Boolean primitive_warn = false;
-Pointer *
+SCHEME_OBJECT *
read_primitives(how_many, where)
fast long how_many;
- fast Pointer *where;
+ fast SCHEME_OBJECT *where;
{
long arity;
{
primitive_warn = true;
}
- *where++ = MAKE_SIGNED_FIXNUM(arity);
+ *where++ = LONG_TO_FIXNUM(arity);
where = read_a_string_internal(where, ((long) -1));
}
return (where);
void
print_external_objects(area_name, Table, N)
char *area_name;
- fast Pointer *Table;
+ fast SCHEME_OBJECT *Table;
fast long N;
{
- fast Pointer *Table_End = &Table[N];
+ fast SCHEME_OBJECT *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))
+ switch (OBJECT_TYPE (*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);
+ (FIXNUM_TO_LONG (*Table)));
break;
}
case TC_CHARACTER:
fprintf(stderr,
"Table[%6d] = string \"%s\"\n",
(N - (Table_End - Table)),
- ((char *) Nth_Vector_Loc(*Table, STRING_CHARS)));
+ ((char *) MEMORY_LOC (*Table, STRING_CHARS)));
break;
\f
case TC_BIG_FIXNUM:
fprintf(stderr,
"Table[%6d] = Flonum %lf\n",
(N - (Table_End - Table)),
- (* ((double *) Nth_Vector_Loc(*Table, 1))));
+ (* ((double *) MEMORY_LOC (*Table, 1))));
break;
default:
READ_HEADER("Heap Count", "%ld", Heap_Count);
READ_HEADER("Dumped Heap Base", "%ld", Dumped_Heap_Base);
READ_HEADER("Heap Objects", "%ld", Heap_Objects);
-
+
READ_HEADER("Constant Count", "%ld", Constant_Count);
READ_HEADER("Dumped Constant Base", "%ld", Dumped_Constant_Base);
READ_HEADER("Constant Objects", "%ld", Constant_Objects);
-
+
READ_HEADER("Pure Count", "%ld", Pure_Count);
READ_HEADER("Dumped Pure Base", "%ld", Dumped_Pure_Base);
READ_HEADER("Pure Objects", "%ld", Pure_Objects);
-
+
READ_HEADER("& Dumped Object", "%ld", Dumped_Object_Addr);
-
+
READ_HEADER("Number of flonums", "%ld", NFlonums);
READ_HEADER("Number of integers", "%ld", NIntegers);
READ_HEADER("Number of bits in integers", "%ld", NBits);
READ_HEADER("Number of bits in bit strings", "%ld", NBBits);
READ_HEADER("Number of character strings", "%ld", NStrings);
READ_HEADER("Number of characters in strings", "%ld", NChars);
-
+
READ_HEADER("Primitive Table Length", "%ld", Primitive_Table_Length);
READ_HEADER("Number of characters in primitives", "%ld", NPChars);
-
+
READ_HEADER("CPU type", "%ld", compiler_processor_type);
READ_HEADER("Compiled code interface version", "%ld",
compiler_interface_version);
Constant_Count + Constant_Objects +
Pure_Count + Pure_Objects +
flonum_to_pointer(NFlonums) +
- ((NIntegers * (1 + bignum_header_to_pointer)) +
- (bigdigit_to_pointer(bits_to_bigdigit(NBits)))) +
+ ((NIntegers * (2 + (BYTES_TO_WORDS (sizeof (bignum_digit_type))))) +
+ (BYTES_TO_WORDS (BIGNUM_BITS_TO_DIGITS (NBits)))) +
((NStrings * (1 + STRING_CHARS)) +
(char_to_pointer(NChars))) +
((NBitstrs * (1 + BIT_STRING_FIRST_WORD)) +
- (bits_to_pointers(NBBits))) +
+ (BIT_STRING_LENGTH_TO_GC_LENGTH(NBBits))) +
((Primitive_Table_Length * (2 + STRING_CHARS)) +
(char_to_pointer(NPChars))));
-
- Allocate_Heap_Space(Size);
+
+ ALLOCATE_HEAP_SPACE (Size);
if (Heap == NULL)
{
fprintf(stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
+ "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
program_name, Size);
quit(1);
}
Heap += HEAP_BUFFER_SPACE;
- Initial_Align_Float(Heap);
+ INITIAL_ALIGN_FLOAT(Heap);
return (Size - HEAP_BUFFER_SPACE);
}
\f
void
do_it()
{
- Pointer *primitive_table_end;
+ SCHEME_OBJECT *primitive_table_end;
Boolean result;
long Size;
Heap_Base = &Heap_Table[Heap_Objects];
Heap_Object_Base =
Read_External(Heap_Objects, Heap_Table, Heap_Base);
-
+
/* The various 2s below are for SNMV headers. */
Pure_Table = &Heap_Object_Base[Heap_Count];
Constant_Base = &Pure_Object_Base[Pure_Count + 2];
Constant_Object_Base =
Read_External(Constant_Objects, Constant_Table, Constant_Base);
-
+
primitive_table = &Constant_Object_Base[Constant_Count + 2];
WHEN((primitive_table > Constant_Table),
primitive_table_end can be well below Constant_Table, since
the memory allocation is conservative (it rounds up), and all
the slack ends up between them.
- */
+ */
WHEN((primitive_table_end > Constant_Table),
"primitive_table_end overran Constant_Table");
/* Dump the objects */
{
- Pointer *Dumped_Object;
+ SCHEME_OBJECT *Dumped_Object;
Relocate_Into(Dumped_Object, Dumped_Object_Addr);
Pure_Length = (Constant_Base - Pure_Base) + 1;
Total_Length = (Free_Constant - Pure_Base) + 4;
Pure_Base[-2] =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, (Pure_Length - 1));
+ MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, (Pure_Length - 1));
Pure_Base[-1] =
- Make_Non_Pointer(PURE_PART, Total_Length);
+ MAKE_OBJECT (PURE_PART, Total_Length);
Constant_Base[-2] =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
Constant_Base[-1] =
- Make_Non_Pointer(CONSTANT_PART, (Pure_Length - 1));
+ MAKE_OBJECT (CONSTANT_PART, (Pure_Length - 1));
Free_Constant[0] =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
Free_Constant[1] =
- Make_Non_Pointer(END_OF_BLOCK, Total_Length);
+ MAKE_OBJECT (END_OF_BLOCK, Total_Length);
result = Write_File(Dumped_Object,
(Free - Heap_Base), Heap_Base,
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.36 1989/09/20 23:11:10 cph Exp $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.35 1989/03/27 23:16:00 jinx Rel $
- *
- * Return codes. These are placed in Return when an
- * interpreter operation needs to operate in several
- * phases. This must correspond with UTABMD.SCM
- *
- */
+/* Return codes. These are placed in Return when an
+ interpreter operation needs to operate in several phases. */
\f
/* These names are also in storage.c.
- * Please maintain consistency.
- * Names should not exceed 31 characters.
- */
+ Please maintain consistency.
+ Names should not exceed 31 characters. */
#define RC_END_OF_COMPUTATION 0x00
/* formerly RC_RESTORE_CONTROL_POINT 0x01 */
#define RC_PCOMB3_DO_2 0x19
#define RC_PCOMB3_DO_1 0x1A
#define RC_PCOMB3_APPLY 0x1B
-\f
#define RC_SNAP_NEED_THUNK 0x1C
#define RC_REENTER_COMPILED_CODE 0x1D
/* formerly RC_GET_CHAR_REPEAT 0x1E */
#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
/* formerly #define RC_REPEAT_PRIMITIVE 0x42 */
-#define RC_COMP_INTERRUPT_RESTART 0x43
+#define RC_COMP_INTERRUPT_RESTART 0x43
/* formerly RC_COMP_RECURSION_GC 0x44 */
#define RC_RESTORE_INT_MASK 0x45
#define RC_HALT 0x46
/* 0x25 */ "RESTARTABLE_EXIT", \
/* 0x26 */ "", \
/* 0x27 */ "", \
-\f \
/* 0x28 */ "COMP_ASSIGNMENT_RESTART", \
/* 0x29 */ "POP_FROM_COMPILED_CODE", \
/* 0x2A */ "RETURN_TRAP_POINT", \
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/trap.h,v 9.41 1989/08/28 18:29:32 cph Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/trap.h,v 9.42 1989/09/20 23:12:11 cph Rel $ */
\f
/* Kinds of traps:
#define get_trap_kind(variable, what) \
{ \
- variable = OBJECT_DATUM(what); \
+ variable = OBJECT_DATUM (what); \
if (variable > TRAP_MAX_IMMEDIATE) \
- variable = OBJECT_DATUM(Vector_Ref(what, TRAP_TAG)); \
+ variable = OBJECT_DATUM (MEMORY_REF (what, TRAP_TAG)); \
}
\f
/* Common constants */
#endif /* b32 */
#ifndef UNASSIGNED_OBJECT /* Safe version */
-#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED)
-#define DANGEROUS_UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED_DANGEROUS)
-#define UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND)
-#define DANGEROUS_UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND_DANGEROUS)
-#define ILLEGAL_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_ILLEGAL)
-#define DANGEROUS_ILLEGAL_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_ILLEGAL_DANGEROUS)
-#define EXPENSIVE_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_EXPENSIVE)
-#define DANGEROUS_EXPENSIVE_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_EXPENSIVE_DANGEROUS)
+#define UNASSIGNED_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNASSIGNED)
+#define DANGEROUS_UNASSIGNED_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNASSIGNED_DANGEROUS)
+#define UNBOUND_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNBOUND)
+#define DANGEROUS_UNBOUND_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_UNBOUND_DANGEROUS)
+#define ILLEGAL_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_ILLEGAL)
+#define DANGEROUS_ILLEGAL_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_ILLEGAL_DANGEROUS)
+#define EXPENSIVE_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_EXPENSIVE)
+#define DANGEROUS_EXPENSIVE_OBJECT MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_EXPENSIVE_DANGEROUS)
#endif /* UNASSIGNED_OBJECT */
-#define NOP_OBJECT MAKE_UNSIGNED_FIXNUM(TRAP_NOP)
-#define DANGEROUS_OBJECT MAKE_UNSIGNED_FIXNUM(TRAP_DANGEROUS)
-#define REQUEST_RECACHE_OBJECT DANGEROUS_ILLEGAL_OBJECT
-#define EXPENSIVE_ASSIGNMENT_OBJECT EXPENSIVE_OBJECT
+#define NOP_OBJECT (LONG_TO_UNSIGNED_FIXNUM (TRAP_NOP))
+#define DANGEROUS_OBJECT (LONG_TO_UNSIGNED_FIXNUM (TRAP_DANGEROUS))
+#define REQUEST_RECACHE_OBJECT DANGEROUS_ILLEGAL_OBJECT
+#define EXPENSIVE_ASSIGNMENT_OBJECT EXPENSIVE_OBJECT
/* -*-C-*-
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/types.h,v 9.31 1989/09/20 23:12:21 cph Rel $
+
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/types.h,v 9.30 1989/08/28 18:29:35 cph Exp $
- *
- * Type code definitions, numerical order
- *
- */
+/* Type code definitions, numerical order */
\f
/* Name Value Previous Name */
#define TC_LAMBDA 0x17
#define TC_PRIMITIVE 0x18
#define TC_SEQUENCE_2 0x19
-\f
#define TC_FIXNUM 0x1A
#define TC_PCOMB1 0x1B
#define TC_CONTROL_POINT 0x1C
#define TC_COMPILED_CODE_BLOCK 0x3D
/* If you add a new type, don't forget to update gccode.h, gctype.c,
- and the type name table below.
- */
+ and the type name table below. */
#define LAST_TYPE_CODE 0X3D
-
#define MIN_TYPE_CODE_LENGTH 6
#ifdef TYPE_CODE_LENGTH
#define GLOBAL_ENV TC_NULL
#define TC_BIT_STRING TC_VECTOR_1B
#define TC_VECTOR_8B TC_CHARACTER_STRING
-#define TC_ADDRESS TC_FIXNUM
#define TC_HUNK3 TC_HUNK3_B
#define UNMARKED_HISTORY_TYPE TC_HUNK3_A
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 10.88 1989/08/28 18:29:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.1 1989/09/20 23:03:51 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
/* Microcode release version */
#ifndef VERSION
-#define VERSION 10
+#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 88
+#define SUBVERSION 1
#endif
#ifndef UCODE_TABLES_FILENAME
projects / mit-scheme.git / commitdiff