/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 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.32 1988/07/10 03:35:49 pas Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/array.c,v 9.33 1988/08/15 20:35:29 cph Exp $ */
/* ARRAY =
sequence of REAL(float or double numbers) with a tag on the front */
\f
#include "scheme.h"
-#include "primitive.h"
+#include "prims.h"
#include "flonum.h"
#include "array.h"
#include <math.h>
/*__________________begin__________________*/
/* I think this is not needed, can be done at s-code ...
-Define_Primitive(Prim_Array_Predicate, 1, "ARRAY?")
+DEFINE_PRIMITIVE ("ARRAY?", Prim_array_predicate, 1, 1, 0)
{ Primitive_1_Args();
- if (Type_Code(Arg1)==TC_ARRAY) return TRUE;
- else return NIL;
+ if (Type_Code(Arg1)==TC_ARRAY) return SHARP_F;
+ else return SHARP_F;
}
*/
-Define_Primitive(Prim_Vector_To_Array, 1, "VECTOR->ARRAY")
+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);
}
-Define_Primitive(Prim_Array_To_Vector, 1, "ARRAY->VECTOR")
+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);
}
-Define_Primitive(Prim_Array_Cons, 2, "ARRAY-CONS")
+DEFINE_PRIMITIVE ("ARRAY-CONS", Prim_array_cons, 2, 2, 0)
{ long Length, i, allocated_cells;
REAL Init_Value, *Next;
int Error_Number;
return Result;
}
-Define_Primitive(Prim_Array_Cons_Reals, 3, "ARRAY-CONS-REALS")
+DEFINE_PRIMITIVE ("ARRAY-CONS-REALS", Prim_array_cons_reals, 3, 3, 0)
{ long i, Length, allocated_cells;
REAL *a, from, dt;
Pointer Result;
return Result;
}
-Define_Primitive(Prim_Array_Length, 1, "ARRAY-LENGTH")
+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));
}
-Define_Primitive(Prim_Array_Ref, 2, "ARRAY-REF")
+DEFINE_PRIMITIVE ("ARRAY-REF", Prim_array_ref, 2, 2, 0)
{ long Index;
REAL *Array, value;
Primitive_2_Args();
Reduced_Flonum_Result((double) value);
}
-Define_Primitive(Prim_Array_Set, 3, "ARRAY-SET!")
+DEFINE_PRIMITIVE ("ARRAY-SET!", Prim_array_set, 3, 3, 0)
{ long Index;
REAL *Array, Old_Value;
int Error_Number;
Reduced_Flonum_Result((double) Old_Value);
}
-Define_Primitive(Prim_Array_Copy, 1, "ARRAY-COPY")
+DEFINE_PRIMITIVE ("ARRAY-COPY", Prim_array_copy, 1, 1, 0)
{ long Length, i, allocated_cells;
REAL *To_Array, *From_Array;
SCHEME_ARRAY Result;
ascii and 2bint formats
________________________________________________*/
-Define_Primitive(Prim_Array_Read_Ascii_File, 2, "ARRAY-READ-ASCII-FILE")
+DEFINE_PRIMITIVE ("ARRAY-READ-ASCII-FILE", Prim_array_read_ascii_file, 2, 2, 0)
{ FILE *fp;
long Length, allocated_cells;
REAL *a;
for (i=0; i<N; i++) {
if ( (fscanf(fp, "%lf", &(a[i]))) != 1)
{ printf("Not enough values read ---\n Last Point was %d with value % .16e \n", i, a[i-1]);
- return NIL; }}
+ return SHARP_F; }}
Close_File(fp);
}
-Define_Primitive(Prim_Array_Write_Ascii_File, 2, "ARRAY-WRITE-ASCII-FILE")
+DEFINE_PRIMITIVE ("ARRAY-WRITE-ASCII-FILE", Prim_array_write_ascii_file, 2, 2, 0)
{ FILE *fp;
long Length;
REAL *a;
printf("Writing ascii file ...\n"); fflush(stdout);
a = Scheme_Array_To_C_Array(Arg1);
C_Array_Write_Ascii_File(a,Length,fp);
- return NIL;
+ 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 NIL; }
+ return SHARP_F; }
fprintf(fp, "% .16e \n", a[i]); }
Close_File(fp);
}
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(Prim_Array_Read_2bint_File, 2, "ARRAY-READ-2BINT-FILE")
+DEFINE_PRIMITIVE ("ARRAY-READ-2BINT-FILE", Prim_array_read_2bint_file, 2, 2, 0)
{ FILE *fp;
long Length, allocated_cells;
REAL *a;
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 NIL; }
+ return SHARP_F; }
foo1=getc(fp); foo2=getc(fp); /* Read 2BYTE INT FORMAT */
a[i] = ((REAL)
((foo1<<8) ^ foo2) ); /* put together the integer */
is not implemented yet, don't have the time to to it now. */
\f
-Define_Primitive(Prim_SubArray, 3, "SUBARRAY")
+DEFINE_PRIMITIVE ("SUBARRAY", Prim_subarray, 3, 3, 0)
{ long Length, i, allocated_cells, Start, End, New_Length;
REAL *To_Here, *From_Here;
Pointer Result;
return Result;
}
-Define_Primitive(Prim_Array_Set_SubArray, 4, "ARRAY-SET-SUBARRAY!")
+DEFINE_PRIMITIVE ("ARRAY-SET-SUBARRAY!", Prim_array_set_subarray, 4, 4, 0)
{ long Length, i, Start, End, New_Length;
REAL *To_Here, *From_Here;
Pointer Result;
return Arg1;
}
-Define_Primitive(Prim_Array_Append, 2, "ARRAY-APPEND")
+DEFINE_PRIMITIVE ("ARRAY-APPEND", Prim_array_append, 2, 2, 0)
{ long Length, Length1, Length2, i, allocated_cells;
REAL *To_Here, *From_Here;
Pointer Result;
return Result;
}
-Define_Primitive(Prim_Array_Reverse, 1, "ARRAY-REVERSE!")
+DEFINE_PRIMITIVE ("ARRAY-REVERSE!", Prim_array_reverse, 1, 1, 0)
{ long Length, i,j, Half_Length;
REAL *Array, Temp;
Primitive_1_Args();
return Arg1;
}
-Define_Primitive(Prim_Array_Scale, 2, "ARRAY-SCALE!")
+DEFINE_PRIMITIVE ("ARRAY-SCALE!", Prim_array_scale, 2, 2, 0)
{ long Length, i;
REAL *To_Here, *From_Here, Scale;
Pointer Result;
#define MAX_ARRAY_FUNCTC 17
-Define_Primitive(Prim_Array_Unary_Function, 2, "ARRAY-UNARY-FUNCTION!")
+DEFINE_PRIMITIVE ("ARRAY-UNARY-FUNCTION!", Prim_array_unary_function, 2, 2, 0)
{ long Length, i, allocated_cells;
REAL *a,*b;
SCHEME_ARRAY Result;
/* The following is accumulate of + and *
code numbers are 0 1
*/
-Define_Primitive(Prim_Array_Accumulate, 2, "ARRAY-ACCUMULATE")
+DEFINE_PRIMITIVE ("ARRAY-ACCUMULATE", Prim_array_accumulate, 2, 2, 0)
{ long Length, i;
REAL *a, result;
long functc;
starting from index=from in array.
Returns first index where match occurs. -- (useful for finding zeros)
*/
-Define_Primitive(Prim_Array_Search_Value_Tolerance_From, 4, "ARRAY-SEARCH-VALUE-TOLERANCE-FROM")
+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 */
if (tolerance >= (fabs(((double) (a[i]-value)))))
return Make_Pointer(TC_FIXNUM, i);
else
- return NIL;
+ return SHARP_F;
}
-Define_Primitive(Prim_Array_Min_Max_Index, 1, "ARRAY-MIN-MAX-INDEX")
+DEFINE_PRIMITIVE ("ARRAY-MIN-MAX-INDEX", Prim_array_min_max_index, 1, 1, 0)
{ long Length, nmin, nmax;
Pointer Result, *Orig_Free;
REAL *Array;
*Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nmin);
*Orig_Free++ = Make_Pointer(TC_LIST, Orig_Free+1);
*Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nmax);
- *Orig_Free=NIL;
+ *Orig_Free=EMPTY_LIST;
return Result;
}
void C_Array_Find_Min_Max(x, n, nmin, nmax) REAL *x; long n, *nmax, *nmin;
/* The following becomes obsolete.
Done using array-reduce + divide by array-length
*/
-Define_Primitive(Prim_Array_Find_Average, 1, "ARRAY-AVERAGE")
+DEFINE_PRIMITIVE ("ARRAY-AVERAGE", Prim_array_find_average, 1, 1, 0)
{ long Length; REAL average;
Primitive_1_Args();
Arg_1_Type(TC_ARRAY);
*pAverage = average_n;
}
-Define_Primitive(Prim_Array_Make_Histogram, 2, "ARRAY-MAKE-HISTOGRAM")
+DEFINE_PRIMITIVE ("ARRAY-MAKE-HISTOGRAM", Prim_array_make_histogram, 2, 2, 0)
{ long Length, npoints, allocated_cells;
REAL *Array, *Histogram;
Pointer Result;
Histogram[index] += 1.0; }
}
-Define_Primitive(Prim_Array_Clip_Min_Max, 3, "ARRAY-CLIP-MIN-MAX!")
+DEFINE_PRIMITIVE ("ARRAY-CLIP-MIN-MAX!", Prim_array_clip_min_max, 3, 3, 0)
{ long Length, i; /* , allocated_cells; */
REAL *To_Here, *From_Here, xmin, xmax;
Pointer Result;
return Result;
}
-Define_Primitive(Prim_Array_Make_Polar, 2, "ARRAY-MAKE-POLAR!")
+DEFINE_PRIMITIVE ("ARRAY-MAKE-POLAR!", Prim_array_make_polar, 2, 2, 0)
{ long Length, i;
REAL *To_Here_Mag, *To_Here_Phase;
REAL *From_Here_Real, *From_Here_Imag;
*Free = Make_Pointer(TC_LIST, Free+1);
Free += 1;
*Free++ = Result_Phase;
- *Free++ = NIL;
+ *Free++ = EMPTY_LIST;
return answer;
}
-Define_Primitive(Prim_Array_Find_Magnitude, 2, "ARRAY-FIND-MAGNITUDE")
+DEFINE_PRIMITIVE ("ARRAY-FIND-MAGNITUDE", Prim_array_find_magnitude, 2, 2, 0)
{ long Length, i, allocated_cells;
REAL *From_Here_Real, *From_Here_Imag, *To_Here;
Pointer Result;
Sum += (X[mi] * Y[N_minus_mi]); \
(Result)=Sum; \
}
-Define_Primitive(Prim_Convolution_Point, 3, "CONVOLUTION-POINT")
+DEFINE_PRIMITIVE ("CONVOLUTION-POINT", Prim_convolution_point, 3, 3, 0)
{ long Length1, Length2, N;
REAL *Array1, *Array2;
REAL C_Result;
Reduced_Flonum_Result(C_Result);
}
-Define_Primitive(Prim_Array_Convolution, 2, "ARRAY-CONVOLUTION")
+DEFINE_PRIMITIVE ("ARRAY-CONVOLUTION", Prim_array_convolution, 2, 2, 0)
{ long Endpoint1, Endpoint2, allocated_cells, i;
/* ASSUME A SIGNAL FROM INDEX 0 TO ENDPOINT=LENGTH-1 */
long Resulting_Length;
return Result;
}
-Define_Primitive(Prim_Array_Multiplication_Into_Second_One, 2, "ARRAY-MULTIPLICATION-INTO-SECOND-ONE!")
+DEFINE_PRIMITIVE ("ARRAY-MULTIPLICATION-INTO-SECOND-ONE!", Prim_array_multiplication_into_second_one, 2, 2, 0)
{ long Length, i;
REAL *To_Here;
REAL *From_Here_1, *From_Here_2;
return Result;
}
-Define_Primitive(Prim_Array_Complex_Multiplication_Into_Second_One, 4, "ARRAY-COMPLEX-MULTIPLICATION-INTO-SECOND-ONE!")
+DEFINE_PRIMITIVE ("ARRAY-COMPLEX-MULTIPLICATION-INTO-SECOND-ONE!", Prim_array_complex_multiplication_into_second_one, 4, 4, 0)
{ long Length, i;
REAL *To_Here_1, *To_Here_2;
REAL *From_Here_1, *From_Here_2, *From_Here_3, *From_Here_4;
From_Here_3++ ;
From_Here_4++ ;
}
- return NIL;
+ return SHARP_F;
}
void C_Array_Complex_Multiply_Into_First_One(a,b,c,d, length)
REAL *a,*b,*c,*d; long length;
}
-Define_Primitive(Prim_Array_Division_Into_First_One, 3, "ARRAY-DIVISION-INTO-FIRST-ONE!")
+DEFINE_PRIMITIVE ("ARRAY-DIVISION-INTO-FIRST-ONE!", Prim_array_division_into_first_one, 3, 3, 0)
{ long Length, i;
SCHEME_ARRAY scheme_result;
REAL *x,*y,*result;
return scheme_result;
}
-Define_Primitive(Prim_Array_Division_Into_Second_One, 3, "ARRAY-DIVISION-INTO-SECOND-ONE!")
+DEFINE_PRIMITIVE ("ARRAY-DIVISION-INTO-SECOND-ONE!", Prim_array_division_into_second_one, 3, 3, 0)
{ long Length, i;
SCHEME_ARRAY scheme_result;
REAL *x,*y,*result;
return scheme_result;
}
-Define_Primitive(Prim_Array_Complex_Multiplication_Into_First_One, 5, "ARRAY-COMPLEX-DIVISION-INTO-FIRST-ONE!")
+DEFINE_PRIMITIVE ("ARRAY-COMPLEX-DIVISION-INTO-FIRST-ONE!", Prim_array_complex_multiplication_into_first_one, 5, 5, 0)
{ long Length, i;
SCHEME_ARRAY scheme_result_r, scheme_result_i;
REAL *x_r,*x_i, *y_r,*y_i, *result_r,*result_i;
result_r[i] = Temp / radius;
}
}
- return NIL;
+ return SHARP_F;
}
-Define_Primitive(Prim_Array_Linear_Superposition_Into_Second_One, 4, "ARRAY-LINEAR-SUPERPOSITION-INTO-SECOND-ONE!")
+DEFINE_PRIMITIVE ("ARRAY-LINEAR-SUPERPOSITION-INTO-SECOND-ONE!", Prim_array_linear_superposition_into_second_one, 4, 4, 0)
{ long Length, i;
REAL *To_Here, Coeff1, Coeff2;
REAL *From_Here_1, *From_Here_2;
/* m_pi = 3.14159265358979323846264338327950288419716939937510;
*/
-Define_Primitive(Prim_Sample_Periodic_Function, 4, "SAMPLE-PERIODIC-FUNCTION")
+DEFINE_PRIMITIVE ("SAMPLE-PERIODIC-FUNCTION", Prim_sample_periodic_function, 4, 4, 0)
{ long N, i, allocated_cells, Function_Number;
double Signal_Frequency, Sampling_Frequency, DT, DTi;
double twopi = 6.28318530717958;
else return (-((twopi-t_bar)/pi));
}
-Define_Primitive(Prim_Array_Hanning, 2, "ARRAY-HANNING")
+DEFINE_PRIMITIVE ("ARRAY-HANNING", Prim_array_hanning, 2, 2, 0)
{ long length, hanning_power, allocated_cells;
SCHEME_ARRAY answer;
void C_Array_Make_Hanning();
/* The following should go away.
Better done using ARRAY-CONS-INTEGERS, and ARRAY-UNARY-FUNCTION
*/
-Define_Primitive(Prim_Sample_Aperiodic_Function, 3, "SAMPLE-APERIODIC-FUNCTION")
+DEFINE_PRIMITIVE ("SAMPLE-APERIODIC-FUNCTION", Prim_sample_aperiodic_function, 3, 3, 0)
{ long N, i, allocated_cells, Function_Number;
double Sampling_Frequency, DT, DTi;
double twopi = 6.28318530717958;
return Result;
}
-Define_Primitive(Prim_Array_Periodic_Downsample, 2, "ARRAY-PERIODIC-DOWNSAMPLE")
+DEFINE_PRIMITIVE ("ARRAY-PERIODIC-DOWNSAMPLE", Prim_array_periodic_downsample, 2, 2, 0)
{ long Length, Pseudo_Length, Sampling_Ratio;
REAL *Array, *To_Here;
Pointer Result;
/* Shift is not done in place (no side-effects).
*/
-Define_Primitive(Prim_Array_Periodic_Shift, 2, "ARRAY-PERIODIC-SHIFT")
+DEFINE_PRIMITIVE ("ARRAY-PERIODIC-SHIFT", Prim_array_periodic_shift, 2, 2, 0)
{ long Length, Shift;
REAL *Array, *To_Here;
Pointer Result;
}
/* This is done here because array-map is very slow */
-Define_Primitive(Prim_Array_Aperiodic_Downsample, 2, "ARRAY-APERIODIC-DOWNSAMPLE")
+DEFINE_PRIMITIVE ("ARRAY-APERIODIC-DOWNSAMPLE", Prim_array_aperiodic_downsample, 2, 2, 0)
{ long Length, New_Length, Sampling_Ratio;
REAL *Array, *To_Here;
Pointer Result;
From the Fortran procedure in Strang.
*/
-Define_Primitive(Prim_Gaussian_Elimination, 2, "SOLVE-SYSTEM")
+DEFINE_PRIMITIVE ("SOLVE-SYSTEM", Prim_gaussian_elimination, 2, 2, 0)
{ REAL *A, *B, *X;
long Length, allocated_cells;
Pointer Result;
/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 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.h,v 9.27 1988/07/09 11:20:42 pas Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/array.h,v 9.28 1988/08/15 20:35:46 cph Exp $ */
\f
#define REAL float
*Free++ = pointer2; \
*Free++ = Make_Pointer(TC_LIST, Free+1); \
*Free++ = pointer3; \
- *Free++ = NIL; }
+ *Free++ = EMPTY_LIST; }
#define Float_Range_Check(variable, Scheme_Pointer, Low, High, Error_Message) \
{ REAL value; \
/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 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.42 1988/03/21 21:09:06 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.43 1988/08/15 20:35:56 cph Exp $ */
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
*/
#include "scheme.h"
-#include "primitive.h"
+#include "prims.h"
#include "trap.h"
#include "lookup.h" /* UNCOMPILED_VARIABLE */
#define In_Fasdump
fasdump_normal_setup();
*To++ = *Old;
*To++ = UNCOMPILED_VARIABLE;
- *To++ = NIL;
+ *To++ = SHARP_F;
fasdump_transport_end(3);
fasdump_normal_end();
}
Dump an object into a file so that it can be loaded using
BINARY-FASLOAD. A spare heap is required for this operation. The
first argument is the object to be dumped. The second is the
- filename and the third a flag. The flag, if #!TRUE, means that the
+ filename and the third a flag. The flag, if #T, means that the
object is to be dumped for reloading into constant space. If the
- flag is NIL, it means that it will be reloaded into the heap. This
- flag is currently ignored. The primitive returns #!TRUE or NIL
+ flag is #F, it means that it will be reloaded into the heap. This
+ flag is currently ignored. The primitive returns #T or #F
indicating whether it successfully dumped the object (it can fail
- on an object that is too large).
-*/
+ on an object that is too large). */
-DEFINE_PRIMITIVE("PRIMITIVE-FASDUMP", Prim_Prim_Fasdump, 3)
+DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0)
{
Boolean success;
long value, length, hlength, tlength, tsize;
fasdump_exit(0);
if (value == PRIM_INTERRUPT)
{
- PRIMITIVE_RETURN(NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
else
{
if (!success)
{
fasdump_exit(0);
- PRIMITIVE_RETURN(NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
length = (Free - dumped_object);
(write(gc_file, ((char *) &table_start[0]), hlength) != hlength))
{
fasdump_exit(0);
- PRIMITIVE_RETURN(NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
hlength = (sizeof(Pointer) * FASL_HEADER_LENGTH);
(write(gc_file, ((char *) &header[0]), hlength) != hlength))
{
fasdump_exit(0);
- PRIMITIVE_RETURN(NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
PRIMITIVE_RETURN(fasdump_exit((sizeof(Pointer) *
(length + tsize)) + hlength) ?
- TRUTH : NIL);
+ SHARP_T : SHARP_F);
}
\f
/* (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)
+DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0)
{
extern Pointer compiler_utilities;
Pointer Combination, *table_start, *table_end, *saved_free;
saved_free = Free;
Combination = Make_Pointer(TC_COMBINATION_1, Free);
Free[COMB_1_FN] = Arg1;
- Free[COMB_1_ARG_1] = NIL;
+ Free[COMB_1_ARG_1] = SHARP_F;
Free += 2;
*Free++ = Combination;
*Free++ = compiler_utilities;
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);
Free = saved_free;
if (result)
{
- PRIMITIVE_RETURN(TRUTH);
+ PRIMITIVE_RETURN(SHARP_T);
}
else
{
extern int unlink();
unlink(Scheme_String_To_C_String(Arg2));
- PRIMITIVE_RETURN(NIL);
+ PRIMITIVE_RETURN(SHARP_F);
}
}
/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 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.32 1988/03/21 21:09:28 jinx Rel $ */
+/* $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
/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 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.33 1988/03/21 21:09:41 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcl.c,v 9.34 1988/08/15 20:36:15 cph Exp $ */
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 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/bchmmg.c,v 9.41 1988/03/21 21:09:57 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.42 1988/08/15 20:36:24 cph Exp $ */
\f
/* Memory management top level. Garbage collection to disk.
*/
#include "scheme.h"
-#include "primitive.h"
+#include "prims.h"
#include "bchgcc.h"
/* Exports */
initialize_new_space_buffer();
Low_Constant = Constant_Space;
- while (Weak_Chain != NIL)
+ while (Weak_Chain != EMPTY_LIST)
{
Old_Weak_Cell = Get_Pointer(Weak_Chain);
Scan = guarantee_in_memory(Get_Pointer(*Old_Weak_Cell++));
/* Normal pointer types, the broken heart is in the first word.
Note that most special types are treated normally here.
The BH code updates *Scan if the object has been relocated.
- Otherwise it falls through and we replace it with a full NIL.
+ Otherwise it falls through and we replace it with a full #F.
Eliminating this assignment would keep old data (pl. of datum).
*/
case GC_Cell:
*Scan = Make_New_Pointer(OBJECT_TYPE(Temp), *Old);
continue;
}
- *Scan = NIL;
+ *Scan = SHARP_F;
continue;
case GC_Compiled:
continue;
}
Compiled_BH(false, continue);
- *Scan = NIL;
+ *Scan = SHARP_F;
continue;
case GC_Undefined:
Terminate_Constant_Space(end_of_constant_area);
Root = Free;
The_Precious_Objects = Get_Fixed_Obj_Slot(Precious_Objects);
- Set_Fixed_Obj_Slot(Precious_Objects, NIL);
- Set_Fixed_Obj_Slot(Lost_Objects_Base, NIL);
+ Set_Fixed_Obj_Slot(Precious_Objects, SHARP_F);
+ Set_Fixed_Obj_Slot(Lost_Objects_Base, SHARP_F);
*free_buffer++ = Fixed_Objects;
*free_buffer++ = Make_Pointer(UNMARKED_HISTORY_TYPE, History);
*free_buffer++ = Undefined_Primitives_Arity;
*free_buffer++ = Get_Current_Stacklet();
*free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ?
- NIL :
+ SHARP_F :
Make_Pointer(TC_CONTROL_POINT,
Prev_Restore_History_Stacklet));
*free_buffer++ = Current_State_Point;
Set_Current_Stacklet(*Root);
Root += 1;
- if (*Root == NIL)
+ if (*Root == SHARP_F)
{
Prev_Restore_History_Stacklet = NULL;
Root += 1;
the GC daemon if there is one.
*/
-DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_Garbage_Collect, 1)
+DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0)
{
extern unsigned long gc_counter;
Pointer GC_Daemon_Proc;
}
gc_counter += 1;
GC_Reserve = Get_Integer(Arg1);
- GC(NIL);
+ GC(EMPTY_LIST);
CLEAR_INTERRUPT(INT_GC);
Pop_Primitive_Frame(1);
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
- if (GC_Daemon_Proc == NIL)
+ if (GC_Daemon_Proc == SHARP_F)
{
Will_Push(CONTINUATION_SIZE);
Store_Return(RC_NORMAL_GC_DONE);
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.40 1988/05/06 09:09:44 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.41 1988/08/15 20:36:35 cph Exp $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 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 "primitive.h"
+#include "prims.h"
#include "bchgcc.h"
#ifdef FLOATING_ALIGNMENT
long length, pure_length;
Pointer value, *Result, *free_buffer, *block_start;
- Weak_Chain = NIL;
+ Weak_Chain = EMPTY_LIST;
free_buffer = initialize_free_buffer();
block_start = Free_Constant;
dump_and_reset_free_buffer((free_buffer - free_buffer_top), NULL);
}
- if (flag == TRUTH)
+ if (flag == SHARP_T)
{
Result = purifyloop(initialize_scan_buffer(),
&free_buffer, &Free_Constant,
free_buffer = purify_header_overflow(free_buffer);
}
\f
- if (flag == TRUTH)
+ if (flag == SHARP_T)
{
Result = purifyloop(initialize_scan_buffer(),
&free_buffer, &Free_Constant,
*block_start = Make_Non_Pointer(PURE_PART, (length - 1));
GC(Weak_Chain);
Set_Pure_Top();
- return (TRUTH);
+ return (SHARP_T);
}
/* Stub. Not needed by this version. Terminates Scheme if invoked. */
the interpreter because some of its cached registers (eg. History)
have changed. */
-DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_Primitive_Purify, 3)
+DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0)
{
Pointer object, daemon;
Pointer result;
Primitive_3_Args();
- if ((Arg2 != TRUTH) && (Arg2 != NIL))
+ if ((Arg2 != SHARP_T) && (Arg2 != SHARP_F))
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
Arg_3_Type(TC_FIXNUM);
Touch_In_Primitive(Arg1, object);
}
Pop_Primitive_Frame(3);
daemon = Get_Fixed_Obj_Slot(GC_Daemon);
- if (daemon == NIL)
+ if (daemon == SHARP_F)
{
Val = result;
PRIMITIVE_ABORT(PRIM_POP_RETURN);
/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 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.c,v 9.25 1987/11/17 08:06:58 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bignum.c,v 9.26 1988/08/15 20:36:45 cph Rel $
This file contains the procedures for handling BIGNUM Arithmetic.
*/
#include "scheme.h"
#include <math.h>
-#include "primitive.h"
+#include "prims.h"
#include "bignum.h"
#include "flonum.h"
#include "zones.h"
Returns its argument if FIXNUM isn't a fixnum. Otherwise
it returns the corresponding bignum.
*/
-Built_In_Primitive(Prim_Fix_To_Big, 1, "COERCE-FIXNUM-TO-BIGNUM", 0x67)
-Define_Primitive(Prim_Fix_To_Big, 1, "COERCE-FIXNUM-TO-BIGNUM")
+DEFINE_PRIMITIVE ("COERCE-FIXNUM-TO-BIGNUM", Prim_fix_to_big, 1, 1, 0)
{
Primitive_1_Arg();
one. If BIGNUM is out of range, or isn't a bignum, returns
BIGNUM. */
-Built_In_Primitive (Prim_Big_To_Fix, 1, "COERCE-BIGNUM-TO-FIXNUM", 0x68)
-Define_Primitive (Prim_Big_To_Fix, 1, "COERCE-BIGNUM-TO-FIXNUM")
+DEFINE_PRIMITIVE ("COERCE-BIGNUM-TO-FIXNUM", Prim_big_to_fix, 1, 1, 0)
{
Primitive_1_Arg ();
Returns a list of numbers, in the range 0 through RADIX-1, which
represent the BIGNUM in that radix.
*/
-Built_In_Primitive(Prim_Listify_Bignum, 2, "LISTIFY-BIGNUM", 0x50)
-Define_Primitive(Prim_Listify_Bignum, 2, "LISTIFY-BIGNUM")
+DEFINE_PRIMITIVE ("LISTIFY-BIGNUM", Prim_listify_bignum, 2, 2, 0)
{
fast bigdigit *TOP1, *size;
quick Pointer *RFree;
{
Primitive_GC_If_Needed(2);
*Free++ = Make_Unsigned_Fixnum(0);
- *Free++ = NIL;
+ *Free++ = EMPTY_LIST;
return Make_Pointer(TC_LIST, Free-2);
}
Sign_Extend(Arg2, pradix);
TOP1--;
}
}
- Free[CONS_CDR] = NIL;
+ Free[CONS_CDR] = EMPTY_LIST;
Free = RFree;
return Make_Pointer(TC_LIST, RFree-2);
}
return Result; \
}
-Built_In_Primitive(Prim_Plus_Bignum, 2, "PLUS-BIGNUM", 0x4C)
-Define_Primitive(Prim_Plus_Bignum, 2, "PLUS-BIGNUM")
+DEFINE_PRIMITIVE ("PLUS-BIGNUM", Prim_plus_bignum, 2, 2, 0)
Binary_Primitive(plus_signed_bignum)
-Built_In_Primitive(Prim_Minus_Bignum, 2, "MINUS-BIGNUM", 0x4D)
-Define_Primitive(Prim_Minus_Bignum, 2, "MINUS-BIGNUM")
+DEFINE_PRIMITIVE ("MINUS-BIGNUM", Prim_minus_bignum, 2, 2, 0)
Binary_Primitive(minus_signed_bignum)
-Built_In_Primitive(Prim_Multiply_Bignum, 2, "MULTIPLY-BIGNUM", 0x4E)
-Define_Primitive(Prim_Multiply_Bignum, 2, "MULTIPLY-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.
*/
-Built_In_Primitive(Prim_Divide_Bignum, 2, "DIVIDE-BIGNUM", 0x4F)
-Define_Primitive(Prim_Divide_Bignum, 2, "DIVIDE-BIGNUM")
+DEFINE_PRIMITIVE ("DIVIDE-BIGNUM", Prim_divide_bignum, 2, 2, 0)
{
Pointer Result, *End_Of_First, *First, *Second, *Orig_Free=Free;
Primitive_2_Args();
return Make_Unsigned_Fixnum(((Test) ? 1 : 0)); \
}
-Built_In_Primitive(Prim_Zero_Bignum, 1, "ZERO-BIGNUM?", 0x6F)
-Define_Primitive(Prim_Zero_Bignum, 1, "ZERO-BIGNUM?")
+DEFINE_PRIMITIVE ("ZERO-BIGNUM?", Prim_zero_bignum, 1, 1, 0)
Unary_Predicate(LEN(ARG) == 0)
-Built_In_Primitive(Prim_Positive_Bignum, 1, "POSITIVE-BIGNUM?", 0x53)
-Define_Primitive(Prim_Positive_Bignum, 1, "POSITIVE-BIGNUM?")
+DEFINE_PRIMITIVE ("POSITIVE-BIGNUM?", Prim_positive_bignum, 1, 1, 0)
Unary_Predicate((LEN(ARG) != 0) && POS_BIGNUM(ARG))
-Built_In_Primitive(Prim_Negative_Bignum, 1, "NEGATIVE-BIGNUM?", 0x80)
-Define_Primitive(Prim_Negative_Bignum, 1, "NEGATIVE-BIGNUM?")
+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
return Make_Unsigned_Fixnum(result); \
}
-Built_In_Primitive(Prim_Equal_Bignum, 2, "EQUAL-BIGNUM?", 0x51)
-Define_Primitive(Prim_Equal_Bignum, 2, "EQUAL-BIGNUM?")
+DEFINE_PRIMITIVE ("EQUAL-BIGNUM?", Prim_equal_bignum, 2, 2, 0)
Binary_Predicate(EQUAL)
-Built_In_Primitive(Prim_Greater_Bignum, 2, "GREATER-THAN-BIGNUM?", 0x82)
-Define_Primitive(Prim_Greater_Bignum, 2, "GREATER-THAN-BIGNUM?")
+DEFINE_PRIMITIVE ("GREATER-THAN-BIGNUM?", Prim_greater_bignum, 2, 2, 0)
Binary_Predicate(ONE_BIGGER)
-Built_In_Primitive(Prim_Less_Bignum, 2, "LESS-THAN-BIGNUM?", 0x52)
-Define_Primitive(Prim_Less_Bignum, 2, "LESS-THAN-BIGNUM?")
+DEFINE_PRIMITIVE ("LESS-THAN-BIGNUM?", Prim_less_bignum, 2, 2, 0)
Binary_Predicate(TWO_BIGGER)
/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 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.23 1987/04/11 15:17:09 jinx Rel $
+/* $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 $
Head file for bignums. This is shared by bignum.c and generic.c.
*/
/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 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.37 1988/06/08 16:05:31 jrm Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.c,v 9.38 1988/08/15 20:37:15 cph Exp $
Bit string primitives.
*/
#include "scheme.h"
-#include "primitive.h"
+#include "prims.h"
#include "bignum.h"
#include "bitstr.h"
\f
/* (BIT-STRING-ALLOCATE length)
Returns an uninitialized bit string of the given length. */
-DEFINE_PRIMITIVE ("BIT-STRING-ALLOCATE", Prim_bit_string_allocate, 1)
+DEFINE_PRIMITIVE ("BIT-STRING-ALLOCATE", Prim_bit_string_allocate, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
/* (BIT-STRING? object)
Returns true iff object is a bit string. */
-DEFINE_PRIMITIVE ("BIT-STRING?", Prim_bit_string_p, 1)
+DEFINE_PRIMITIVE ("BIT-STRING?", Prim_bit_string_p, 1, 1, 0)
{
fast Pointer object;
PRIMITIVE_HEADER (1);
object = (ARG_REF (1));
Touch_In_Primitive (object, object);
- PRIMITIVE_RETURN ((BIT_STRING_P (object)) ? TRUTH : NIL);
+ PRIMITIVE_RETURN ((BIT_STRING_P (object)) ? SHARP_T : NIL);
}
\f
void
Returns a bit string of the specified size with all the bits
set to zero if the initialization is false, one otherwise. */
-DEFINE_PRIMITIVE ("MAKE-BIT-STRING", Prim_make_bit_string, 2)
+DEFINE_PRIMITIVE ("MAKE-BIT-STRING", Prim_make_bit_string, 2, 2, 0)
{
Pointer result;
PRIMITIVE_HEADER (2);
Fills the bit string with zeros if the initialization is false,
otherwise fills it with ones. */
-DEFINE_PRIMITIVE ("BIT-STRING-FILL!", Prim_bit_string_fill_x, 2)
+DEFINE_PRIMITIVE ("BIT-STRING-FILL!", Prim_bit_string_fill_x, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
/* (BIT-STRING-LENGTH bit-string)
Returns the number of bits in BIT-STRING. */
-DEFINE_PRIMITIVE ("BIT-STRING-LENGTH", Prim_bit_string_length, 1)
+DEFINE_PRIMITIVE ("BIT-STRING-LENGTH", Prim_bit_string_length, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
/* (BIT-STRING-REF bit-string index)
Returns the boolean value of the indexed bit. */
-DEFINE_PRIMITIVE ("BIT-STRING-REF", Prim_bit_string_ref, 2)
+DEFINE_PRIMITIVE ("BIT-STRING-REF", Prim_bit_string_ref, 2, 2, 0)
{
REF_INITIALIZATION ();
- PRIMITIVE_RETURN ((((bit_string_word (ptr)) & mask) == 0) ? NIL : TRUTH);
+ PRIMITIVE_RETURN ((((bit_string_word (ptr)) & mask) == 0) ? NIL : SHARP_T);
}
/* (BIT-STRING-CLEAR! bit-string index)
Sets the indexed bit to zero, returning its previous value
as a boolean. */
-DEFINE_PRIMITIVE ("BIT-STRING-CLEAR!", Prim_bit_string_clear_x, 2)
+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;
- PRIMITIVE_RETURN (TRUTH);
+ PRIMITIVE_RETURN (SHARP_T);
}
/* (BIT-STRING-SET! bit-string index)
Sets the indexed bit to one, returning its previous value
as a boolean. */
-DEFINE_PRIMITIVE ("BIT-STRING-SET!", Prim_bit_string_set_x, 2)
+DEFINE_PRIMITIVE ("BIT-STRING-SET!", Prim_bit_string_set_x, 2, 2, 0)
{
REF_INITIALIZATION ();
if (((bit_string_word (ptr)) & mask) != 0)
- PRIMITIVE_RETURN (TRUTH);
+ PRIMITIVE_RETURN (SHARP_T);
((bit_string_word (ptr))) |= mask;
PRIMITIVE_RETURN (NIL);
}
for (i = (length / POINTER_LENGTH); (i > 0); i -= 1) \
if ((* (dec_bit_string_ptr (scan))) != 0) \
PRIMITIVE_RETURN (NIL); \
- PRIMITIVE_RETURN (TRUTH); \
+ PRIMITIVE_RETURN (SHARP_T); \
}
/* (BIT-STRING-ZERO? bit-string)
Returns true the argument has no "set" bits. */
-DEFINE_PRIMITIVE ("BIT-STRING-ZERO?", Prim_bit_string_zero_p, 1)
+DEFINE_PRIMITIVE ("BIT-STRING-ZERO?", Prim_bit_string_zero_p, 1, 1, 0)
{
fast Pointer bit_string;
fast Pointer *scan;
if ((* (dec_bit_string_ptr (scan1))) != \
(* (dec_bit_string_ptr (scan2)))) \
PRIMITIVE_RETURN (NIL); \
- PRIMITIVE_RETURN (TRUTH); \
+ PRIMITIVE_RETURN (SHARP_T); \
}
/* (BIT-STRING=? bit-string-1 bit-string-2)
Returns true iff the two bit strings contain the same bits. */
-DEFINE_PRIMITIVE ("BIT-STRING=?", Prim_bit_string_equal_p, 2)
+DEFINE_PRIMITIVE ("BIT-STRING=?", Prim_bit_string_equal_p, 2, 2, 0)
{
Pointer bit_string_1, bit_string_2;
long length;
#define bit_string_andc_x_action() &= ~
#define bit_string_xor_x_action() ^=
-DEFINE_PRIMITIVE ("BIT-STRING-MOVE!", Prim_bit_string_move_x, 2)
+DEFINE_PRIMITIVE ("BIT-STRING-MOVE!", Prim_bit_string_move_x, 2, 2, 0)
{ BITWISE_OP (bit_string_move_x_action); }
-DEFINE_PRIMITIVE ("BIT-STRING-MOVEC!", Prim_bit_string_movec_x, 2)
+DEFINE_PRIMITIVE ("BIT-STRING-MOVEC!", Prim_bit_string_movec_x, 2, 2, 0)
{ BITWISE_OP (bit_string_movec_x_action); }
-DEFINE_PRIMITIVE ("BIT-STRING-OR!", Prim_bit_string_or_x, 2)
+DEFINE_PRIMITIVE ("BIT-STRING-OR!", Prim_bit_string_or_x, 2, 2, 0)
{ BITWISE_OP (bit_string_or_x_action); }
-DEFINE_PRIMITIVE ("BIT-STRING-AND!", Prim_bit_string_and_x, 2)
+DEFINE_PRIMITIVE ("BIT-STRING-AND!", Prim_bit_string_and_x, 2, 2, 0)
{ BITWISE_OP (bit_string_and_x_action); }
-DEFINE_PRIMITIVE ("BIT-STRING-ANDC!", Prim_bit_string_andc_x, 2)
+DEFINE_PRIMITIVE ("BIT-STRING-ANDC!", Prim_bit_string_andc_x, 2, 2, 0)
{ BITWISE_OP (bit_string_andc_x_action); }
-DEFINE_PRIMITIVE ("BIT-STRING-XOR!", Prim_bit_string_xor_x, 2)
+DEFINE_PRIMITIVE ("BIT-STRING-XOR!", Prim_bit_string_xor_x, 2, 2, 0)
{ BITWISE_OP (bit_string_xor_x_action); }
\f
/* (BIT-SUBSTRING-MOVE-RIGHT! source start1 end1 destination start2)
MSB to the LSB (which only matters when SOURCE and DESTINATION
are the same). */
-DEFINE_PRIMITIVE ("BIT-SUBSTRING-MOVE-RIGHT!", Prim_bit_substring_move_right_x, 5)
+DEFINE_PRIMITIVE ("BIT-SUBSTRING-MOVE-RIGHT!", Prim_bit_substring_move_right_x, 5, 5, 0)
{
fast Pointer bit_string_1, bit_string_2;
long start1, end1, start2, end2, nbits;
a bit-string of length LENGTH. If INTEGER is too large, an
error is signalled. */
-DEFINE_PRIMITIVE ("UNSIGNED-INTEGER->BIT-STRING", Prim_unsigned_to_bit_string, 2)
+DEFINE_PRIMITIVE ("UNSIGNED-INTEGER->BIT-STRING", Prim_unsigned_to_bit_string, 2, 2, 0)
{
fast long length;
fast Pointer object;
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)
+DEFINE_PRIMITIVE ("BIT-STRING->UNSIGNED-INTEGER", Prim_bit_string_to_unsigned, 1, 1, 0)
{
fast Pointer bit_string, *scan;
long nwords, nbits, word;
Read the contents of memory at the address (POINTER,OFFSET)
into BIT-STRING. */
-DEFINE_PRIMITIVE ("READ-BITS!", Prim_read_bits_x, 3)
+DEFINE_PRIMITIVE ("READ-BITS!", Prim_read_bits_x, 3, 3, 0)
{
READ_BITS_INITIALIZE ();
Write the contents of BIT-STRING in memory at the address
(POINTER,OFFSET). */
-DEFINE_PRIMITIVE ("WRITE-BITS!", Prim_write_bits_x, 3)
+DEFINE_PRIMITIVE ("WRITE-BITS!", Prim_write_bits_x, 3, 3, 0)
{
READ_BITS_INITIALIZE ();
} \
}
\f
-DEFINE_PRIMITIVE ("BIT-SUBSTRING-FIND-NEXT-SET-BIT", Prim_bitstr_find_next_set_bit, 3)
+DEFINE_PRIMITIVE ("BIT-SUBSTRING-FIND-NEXT-SET-BIT", Prim_bitstr_find_next_set_bit, 3, 3, 0)
{
SUBSTRING_FIND_NEXT_INITIALIZE ();
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.h,v 1.4 1987/08/17 19:32:28 jinx Rel $
+$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 $
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 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.21 1987/01/22 14:16:33 jinx Rel $
+/* $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.
/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 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.24 1987/12/04 22:13:56 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.25 1988/08/15 20:37:43 cph Exp $
*
* This file contains breakpoint utilities.
* Disabled when not debugging the interpreter.
/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/findprim.c,v 9.34 1988/08/15 20:31:50 cph Exp $
+
+Copyright (c) 1987, 1988 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/findprim.c,v 9.33 1987/12/23 04:48:05 cph Rel $
- *
- * Preprocessor to find and declare defined primitives.
- *
- */
+/* Preprocessor to find and declare defined primitives. */
\f
/*
* This program searches for a particular token which tags primitive
#include <stdio.h>
/* For macros toupper, isalpha, etc,
- supposedly on the standard library.
-*/
+ supposedly on the standard library. */
#include <ctype.h>
-extern int strcmp(), strlen();
+extern int strcmp ();
+extern int strlen ();
typedef int boolean;
#define TRUE 1
#ifdef vms
/* VMS version 3 has no void. */
/* #define void */
-#define normal_exit() return
+#define NORMAL_EXIT() return
#else
-#define normal_exit() exit(0)
+#define NORMAL_EXIT() exit(0)
#endif
/* The 4.2 bsd vax compiler has a bug which forces the following. */
-#define pseudo_void int
+#define pseudo_void int
+
+char *
+xmalloc (length)
+ int length;
+{
+ char * result;
+ extern char * malloc ();
+
+ result = (malloc (length));
+ if (result == NULL)
+ {
+ fprintf (stderr, "malloc: unable to allocate %d bytes\n", length);
+ exit (1);
+ }
+ return (result);
+}
+
+char *
+xrealloc (ptr, length)
+ char * ptr;
+ int length;
+{
+ char * result;
+ extern char * realloc ();
+
+ result = (realloc (ptr, length));
+ if (result == NULL)
+ {
+ fprintf (stderr, "realloc: unable to allocate %d bytes\n", length);
+ exit (1);
+ }
+ return (result);
+}
-#define error_exit(do_it) \
+#define FIND_INDEX_LENGTH(index, size) \
{ \
- if (do_it) \
- dump(TRUE); \
- exit(1); \
+ char index_buffer [64]; \
+ \
+ sprintf (index_buffer, "%x", (index)); \
+ (size) = (strlen (index_buffer)); \
}
-void dump();
-\f
#ifdef DEBUGGING
#define dprintf(one, two) fprintf(stderr, one, two)
#else
#define dprintf(one, two)
#endif
-
+\f
/* Maximum number of primitives that can be handled. */
-#ifndef BUFFER_SIZE
-#define BUFFER_SIZE 0x400
-#endif
+boolean built_in_p;
-static boolean Built_in_p;
-static long Built_in_table_size;
+char * token_array [4];
+char default_token [] = "Define_Primitive";
+char default_token_alternate [] = "DEFINE_PRIMITIVE";
+char built_in_token [] = "Built_In_Primitive";
+char external_token [] = "Define_Primitive";
-static char *token_array[4];
-static char Default_Token[] = "Define_Primitive";
-static char default_token_alternate[] = "DEFINE_PRIMITIVE";
-static char Built_in_Token[] = "Built_In_Primitive";
-static char External_Token[] = "Define_Primitive";
+typedef pseudo_void (* TOKEN_PROCESSOR) ();
+TOKEN_PROCESSOR token_processors [4];
-typedef pseudo_void (*TOKEN_PROCESSOR) ();
-static TOKEN_PROCESSOR token_processors[4];
+char * the_kind;
+char default_kind [] = "Primitive";
+char built_in_kind [] = "Primitive";
+char external_kind [] = "External";
-static char *The_Kind;
-static char Default_Kind[] = "Primitive";
-static char Built_in_Kind[] = "Primitive";
-static char External_Kind[] = "External";
+char * the_variable;
+char default_variable [] = "MAX_PRIMITIVE";
+char built_in_variable [] = "MAX_PRIMITIVE";
+char external_variable [] = "MAX_EXTERNAL_PRIMITIVE";
-static char *The_Variable;
-static char Default_Variable[] = "MAX_PRIMITIVE";
-static char Built_in_Variable[] = "MAX_PRIMITIVE";
-static char External_Variable[] = "MAX_EXTERNAL_PRIMITIVE";
+FILE * input;
+FILE * output;
+char * name;
+char * file_name;
-static FILE *input, *output;
-static char *name;
-static char *file_name;
+struct descriptor
+ {
+ char * c_name; /* The C name of the function */
+ char * arity; /* Number of arguments */
+ char * scheme_name; /* Scheme name of the primitive */
+ char * documentation; /* Documentation string */
+ char * file_name; /* File where found. */
+ };
+
+int buffer_index;
+int buffer_length;
+struct descriptor (* data_buffer) [];
+struct descriptor ** result_buffer;
+
+int max_scheme_name_length;
+int max_c_name_length;
+int max_arity_length;
+int max_documentation_length;
+int max_file_name_length;
+int max_index_length;
+
+struct descriptor dummy_entry =
+ {"Dummy_Primitive", "0", "DUMMY-PRIMITIVE", "", "Findprim.c"};
+
+char dummy_error_string [] =
+ "Microcode_Termination (TERM_BAD_PRIMITIVE)";
+
+struct descriptor inexistent_entry =
+ {"Prim_inexistent", "0", "INEXISTENT-PRIMITIVE", "", "Findprim.c"};
+
+char inexistent_error_string [] =
+ "signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE)";
+
+/* forward references */
+
+TOKEN_PROCESSOR scan ();
+boolean whitespace ();
+int compare_descriptors ();
+int read_index ();
+pseudo_void create_alternate_entry ();
+pseudo_void create_builtin_entry ();
+pseudo_void create_normal_entry ();
+void dump ();
+void grow_data_buffer ();
+void grow_token_buffer ();
+void initialize_builtin ();
+void initialize_data_buffer ();
+void initialize_default ();
+void initialize_external ();
+void initialize_token_buffer ();
+void mergesort ();
+void print_procedure ();
+void print_primitives ();
+void print_spaces ();
+void print_entry ();
+void process ();
+void process_argument ();
+void scan_to_token_start ();
+void skip_token ();
+void sort ();
+void update_from_entry ();
\f
-main(argc, argv)
+void
+main (argc, argv)
int argc;
- char *argv[];
+ char * argv [];
{
- void process_argument(), sort();
- FILE *fopen();
-
name = argv[0];
/* Check for specified output file */
- if ((argc >= 2) && (strcmp("-o", argv[1]) == 0))
- {
- if ((output = fopen(argv[2], "w")) == NULL)
+ if ((argc >= 2) && ((strcmp ("-o", argv[1])) == 0))
{
- fprintf(stderr, "Error: %s can't open %s\n", name, argv[2]);
- error_exit(FALSE);
+ output = (fopen (argv[2], "w"));
+ if (output == NULL)
+ {
+ fprintf(stderr, "Error: %s can't open %s\n", name, argv[2]);
+ exit (1);
+ }
+ argv += 2;
+ argc -= 2;
}
- argv += 2;
- argc -= 2;
- }
else
output = stdout;
+ initialize_data_buffer ();
+ initialize_token_buffer ();
+
/* Check whether to produce the built-in table instead.
The argument after the option letter is the size of the
- table to build.
- */
-
- if ((argc >= 2) && (strcmp("-b", argv[1]) == 0))
- {
- void initialize_builtin();
+ table to build. */
- initialize_builtin(argv[2]);
- argv += 2;
- argc -= 2;
- }
- else if ((argc >= 2) && (strcmp("-e", argv[1]) == 0))
- {
- void initialize_external();
-
- initialize_external();
- }
+ if ((argc >= 2) && ((strcmp ("-b", argv[1])) == 0))
+ {
+ initialize_builtin (argv[2]);
+ argv += 2;
+ argc -= 2;
+ }
+ else if ((argc >= 1) && ((strcmp ("-e", argv[1])) == 0))
+ {
+ initialize_external ();
+ argv += 1;
+ argc -= 1;
+ }
else
- {
- void initialize_default();
+ initialize_default ();
- initialize_default();
- }
-\f
/* Check whether there are any files left. */
-
if (argc == 1)
- {
- dump(FALSE);
- normal_exit();
- }
-
- if ((argc >= 2) && (strcmp("-l", argv[1]) == 0))
- {
- /* The list of files is stored in another file. */
-
- char fn[100];
- FILE *file_list_file;
-
- if ((file_list_file = fopen(argv[2], "r")) == NULL)
{
- fprintf(stderr, "Error: %s can't open %s\n", name, argv[2]);
- error_exit(TRUE);
+ dump (FALSE);
+ goto done;
}
- else
+
+ if ((argc >= 2) && ((strcmp ("-l", argv[1])) == 0))
{
- while (fgets(fn, 100, file_list_file) != NULL)
- {
- int i;
+ /* The list of files is stored in another file. */
+
+ char fn [1024];
+ FILE * file_list_file;
- i = strlen(fn) - 1;
- if (i >=0 && fn[i] == '\n')
+ file_list_file = (fopen (argv[2], "r"));
+ if (file_list_file == NULL)
{
- fn[i] = '\0';
- i--;
+ fprintf (stderr, "Error: %s can't open %s\n", name, argv[2]);
+ dump (TRUE);
+ exit (1);
+ }
+ while ((fgets (fn, 1024, file_list_file)) != NULL)
+ {
+ int i;
+
+ i = (strlen (fn)) - 1;
+ if ((i >= 0) && (fn[i] == '\n'))
+ {
+ fn[i] = '\0';
+ i -= 1;
+ }
+ if ((i > 0) && (fn[0] != ';'))
+ {
+ char * arg;
+
+ arg = (xmalloc ((strlen (fn)) + 1));
+ strcpy (arg, fn);
+ process_argument (arg);
+ }
}
- if (i > 0 && fn[0] != ';')
- process_argument(fn);
- }
- fclose(file_list_file);
+ fclose (file_list_file);
}
- }
else
- {
/* The list of files is in the argument list. */
+ while ((--argc) > 0)
+ process_argument (*++argv);
- while (--argc > 0)
+ if (! built_in_p)
{
- process_argument(*++argv);
+ dprintf ("About to sort %s\n", "");
+ sort ();
}
- }
- if (!Built_in_p)
- {
- dprintf("About to sort %s\n", "");
- sort();
- }
- dprintf("About to dump %s\n", "");
- dump(TRUE);
+ dprintf ("About to dump %s\n", "");
+ dump (TRUE);
+
+ done:
if (output != stdout)
- {
- fclose(output);
- }
- normal_exit();
+ fclose (output);
+ NORMAL_EXIT ();
}
-
-void process_argument(fn)
- char *fn;
+\f
+void
+process_argument (fn)
+ char * fn;
{
- void process();
-
file_name = fn;
- if (strcmp("-", file_name)==0)
- {
- input = stdin;
- file_name = "stdin";
- dprintf("About to process %s\n", "STDIN");
- process();
- }
- else if ((input = fopen(file_name, "r")) == NULL)
- {
- fprintf(stderr, "Error: %s can't open %s\n", name, file_name);
- error_exit(TRUE);
- }
+ if ((strcmp ("-", file_name)) == 0)
+ {
+ input = stdin;
+ file_name = "stdin";
+ dprintf ("About to process %s\n", "STDIN");
+ process ();
+ }
+ else if ((input = (fopen (file_name, "r"))) == NULL)
+ {
+ fprintf (stderr, "Error: %s can't open %s\n", name, file_name);
+ dump (TRUE);
+ exit (1);
+ }
else
- {
- dprintf("About to process %s\n", file_name);
- process();
- fclose(input);
- }
+ {
+ dprintf ("About to process %s\n", file_name);
+ process ();
+ fclose (input);
+ }
+ return;
}
-\f
+
/* Search for tokens and when found, create primitive entries. */
void
-process()
+process ()
{
- TOKEN_PROCESSOR scan();
TOKEN_PROCESSOR processor;
while (TRUE)
{
processor = (scan ());
- if (processor == NULL)
- break;
- dprintf("Process: place found.%s\n", "");
- (*processor)();
+ if (processor == NULL) break;
+ dprintf ("Process: place found.%s\n", "");
+ (* processor) ();
}
return;
}
-
+\f
/* Search for token and stop when found. If you hit open comment
* character, read until you hit close comment character.
* *** FIX *** : It is not a complete C parser, thus it may be fooled,
* currently the token must always begin a line.
-*/
+ */
TOKEN_PROCESSOR
scan ()
{
register int c;
- char compare_buffer[1024];
+ char compare_buffer [1024];
c = '\n';
- while(c != EOF)
- {
- switch(c)
- { case '/':
- if ((c = getc(input)) == '*')
+ while (c != EOF)
+ {
+ switch (c)
{
- c = getc(input);
- while (TRUE)
- { while (c != '*')
- { if (c == EOF)
- { fprintf(stderr,
- "Error: EOF in comment in file %s, or %s confused\n",
- file_name, name);
- error_exit(TRUE);
- }
- c = getc(input);
+ case '/':
+ if ((c = (getc (input))) == '*')
+ {
+ c = (getc (input));
+ while (TRUE)
+ {
+ while (c != '*')
+ {
+ if (c == EOF)
+ {
+ fprintf (stderr,
+ "Error: EOF in comment in file %s, or %s confused\n",
+ file_name, name);
+ dump (TRUE);
+ exit (1);
+ }
+ c = (getc (input));
+ }
+ c = (getc (input));
+ if (c == '/') break;
+ }
}
- if ((c = getc(input)) == '/') break;
- }
- }
- else if (c != '\n') break;
+ else if (c != '\n') break;
- case '\n':
- {
+ case '\n':
{
- register char *scan_buffer;
-
- scan_buffer = (& (compare_buffer [0]));
- while (TRUE)
- {
- c = (getc (input));
- if (c == EOF)
- return (NULL);
- else if ((isalnum (c)) || (c == '_'))
- (*scan_buffer++) = c;
- else
- {
- ungetc (c, input);
- (*scan_buffer++) = '\0';
- break;
- }
- }
+ {
+ register char * scan_buffer;
+
+ scan_buffer = (& (compare_buffer [0]));
+ while (TRUE)
+ {
+ c = (getc (input));
+ if (c == EOF)
+ return (NULL);
+ else if ((isalnum (c)) || (c == '_'))
+ (*scan_buffer++) = c;
+ else
+ {
+ ungetc (c, input);
+ (*scan_buffer++) = '\0';
+ break;
+ }
+ }
+ }
+ {
+ register char **scan_tokens;
+
+ for (scan_tokens = (& (token_array [0]));
+ ((* scan_tokens) != NULL);
+ scan_tokens += 1)
+ if ((strcmp ((& (compare_buffer [0])), (* scan_tokens))) == 0)
+ return (token_processors [scan_tokens - token_array]);
+ }
+ break;
}
- {
- register char **scan_tokens;
- for (scan_tokens = (& (token_array [0]));
- ((*scan_tokens) != NULL);
- scan_tokens += 1)
- if ((strcmp ((& (compare_buffer [0])), (*scan_tokens))) == 0)
- return (token_processors [(scan_tokens - token_array)]);
- }
- break;
+ default: {}
}
-
- default: {}
+ c = (getc (input));
}
- c = getc(input);
- }
return (NULL);
}
\f
-boolean
-whitespace(c)
- int c;
-{
- switch(c)
- { case ' ':
- case '\t':
- case '\n':
- case '(':
- case ')':
- case ',': return TRUE;
- default: return FALSE;
- }
-}
+/* Output Routines */
void
-scan_to_token_start()
+dump (check)
+ boolean check;
{
- int c;
+ register int max_index;
+ register int count;
+
+ FIND_INDEX_LENGTH (buffer_index, max_index_length);
+ max_index = (buffer_index - 1);
+
+ /* Print header. */
+ fprintf (output, "/%c Emacs: This is -*- C -*- code. %c/\n\n", '*', '*');
+ fprintf (output, "/%c %s primitive declarations %c/\n\n",
+ '*', ((built_in_p) ? "Built in" : "User defined" ), '*');
+ fprintf (output, "#include \"usrdef.h\"\n\n");
+ fprintf (output,
+ "long %s = %d; /%c = 0x%x %c/\n\n",
+ the_variable, max_index, '*', max_index, '*');
+
+ if (built_in_p)
+ fprintf (output,
+ "/%c The number of implemented primitives is %d. %c/\n\n",
+ '*', buffer_index, '*');
+
+ if (buffer_index == 0)
+ {
+ if (check)
+ fprintf (stderr, "No primitives found!\n");
+
+ /* C does not understand the empty array, thus it must be faked. */
+ fprintf (output, "/%c C does not understand the empty array, ", '*');
+ fprintf (output, "thus it must be faked. %c/\n\n", '*');
+
+ /* Dummy entry */
+ (result_buffer [0]) = (& dummy_entry);
+ update_from_entry (& dummy_entry);
+ print_procedure (output, (& dummy_entry), (& (dummy_error_string [0])));
+ fprintf (output, "\n");
+ }
+ else
+ {
+ /* Print declarations. */
+ fprintf (output, "extern Pointer\n");
+ for (count = 0; (count < max_index); count += 1)
+ fprintf (output, " %s (),\n",
+ (((* data_buffer) [count]) . c_name));
+ fprintf (output, " %s ();\n\n",
+ (((* data_buffer) [max_index]) . c_name));
+ }
- while (whitespace(c = getc(input))) {};
- ungetc(c, input);
+ print_procedure
+ (output, (& inexistent_entry), (& (inexistent_error_string [0])));
+ print_primitives (output, buffer_index);
return;
}
-/* *** FIX *** This should check for field overflow (n too small) */
-
void
-copy_token(s, size)
- char s[];
- int *size;
+print_procedure (output, primitive_descriptor, error_string)
+ FILE * output;
+ struct descriptor * primitive_descriptor;
+ char * error_string;
{
- register int c, n;
-
- n = 0;
- while (!(whitespace(c = getc(input))))
- {
- s[n++] = c;
- }
- s[n] = '\0';
- if (n > *size)
- {
- *size = n;
- }
+ fprintf (output, "Pointer\n");
+ fprintf (output, "%s ()\n", (primitive_descriptor -> c_name));
+ fprintf (output, "{\n");
+ fprintf (output, " PRIMITIVE_HEADER (%s);\n",
+ (primitive_descriptor -> arity));
+ fprintf (output, "\n");
+ fprintf (output, " %s;\n", error_string);
+ fprintf (output, " /%cNOTREACHED%c/\n", '*', '*');
+ fprintf (output, "}\n");
return;
}
-\f
-void
-copy_symbol(s, size)
- char s[];
- int *size;
-{
- register int c, n;
- n = 0;
- c = getc(input);
- if (c != '\"')
- {
- }
- while ((!(whitespace(c = getc(input)))) && (c != '\"'))
- {
- s[n++] = ((isalpha(c) && islower(c)) ? toupper(c) : c);
- }
- s[n] = '\0';
- if (n > *size)
- {
- *size = n;
- }
- return;
+#define TABLE_NEWLINE() \
+{ \
+ if (count != last) \
+ fprintf (output, ",\n"); \
+ else \
+ fprintf (output, "\n};\n"); \
}
void
-copy_string(is, s, size)
- register char *is;
- char s[];
- int *size;
+print_primitives (output, limit)
+ FILE * output;
+ register int limit;
{
- register int c, n;
-
- n = 0;
- while ((c = *is++) != '\0')
- {
- s[n++] = c;
- }
- s[n] = '\0';
- if (n > *size)
- {
- *size = n;
- }
- return;
-}
-\f
-#define STRING_SIZE 80
-#define ARITY_SIZE 6
+ register int last;
+ register int count;
+ register char * table_entry;
-typedef struct dsc
-{
- char C_Name[STRING_SIZE]; /* The C name of the function */
- char Arity[ARITY_SIZE]; /* Number of arguments */
- char Scheme_Name[STRING_SIZE]; /* Scheme name of the primitive */
- char File_Name[STRING_SIZE]; /* File where found. */
-} descriptor;
+ last = (limit - 1);
-/*
- * *** FIX ***
- * This should really be malloced incrementally, but for the time being ...
- *
- */
+ /* Print the procedure table. */
+ fprintf (output, "\f\nPointer (* (%s_Procedure_Table [])) () = {\n",
+ the_kind);
+ for (count = 0; (count < limit); count += 1)
+ {
+ print_entry (output, count, (result_buffer [count]));
+ fprintf (output, ",\n");
+ }
+ print_entry (output, (-1), (& inexistent_entry));
+ fprintf (output, "\n};\n");
-static int buffer_index = 0;
-descriptor Data_Buffer[BUFFER_SIZE];
-descriptor *Result_Buffer[BUFFER_SIZE];
-descriptor *Temp_Buffer[BUFFER_SIZE];
+ /* Print the names table. */
+ fprintf (output, "\f\nchar * %s_Name_Table [] = {\n", the_kind);
+ for (count = 0; (count < limit); count += 1)
+ {
+ fprintf (output, " \"%s\"", ((result_buffer [count]) -> scheme_name));
+ TABLE_NEWLINE ();
+ }
-static descriptor Dummy_Entry =
-{
- "Dummy_Primitive",
- "0",
- "DUMMY-PRIMITIVE",
- "Findprim.c"
-};
+ /* Print the documentation table. */
+ fprintf (output, "\f\nchar * %s_Documentation_Table [] = {\n", the_kind);
+ for (count = 0; (count < limit); count += 1)
+ {
+ fprintf (output, " ");
+ table_entry = ((result_buffer [count]) -> documentation);
+ if ((table_entry [0]) == '\0')
+ fprintf (output, "((char *) 0)");
+ else
+ fprintf (output, "\"%s\"", table_entry);
+ TABLE_NEWLINE ();
+ }
-static char Dummy_Error_String[] =
- "Microcode_Termination(TERM_BAD_PRIMITIVE)";
+ /* Print the arity table. */
+ fprintf (output, "\f\nint %s_Arity_Table [] = {\n", the_kind);
+ for (count = 0; (count < limit); count += 1)
+ {
+ fprintf (output, " %s", ((result_buffer [count]) -> arity));
+ TABLE_NEWLINE ();
+ }
-static descriptor Inexistent_Entry =
-{
- "Prim_Inexistent",
- "0",
- "INEXISTENT-PRIMITIVE",
- "Findprim.c"
-};
-
-static char Inexistent_Error_String[] =
- "Primitive_Error(ERR_UNIMPLEMENTED_PRIMITIVE)";
-\f
-static int C_Size = 0;
-static int A_Size = 0;
-static int S_Size = 0;
-static int F_Size = 0;
+ /* Print the counts table. */
+ fprintf (output, "\f\nint %s_Count_Table [] = {\n", the_kind);
+ for (count = 0; (count < limit); count += 1)
+ {
+ fprintf (output,
+ " (%s * sizeof(Pointer))",
+ ((result_buffer [count]) -> arity));
+ TABLE_NEWLINE ();
+ }
-void
-update_from_entry(primitive_descriptor)
- descriptor *primitive_descriptor;
-{
- int temp;
- temp = strlen(primitive_descriptor->C_Name);
- if (temp > C_Size)
- {
- C_Size = temp;
- }
- temp = strlen(primitive_descriptor->Arity);
- if (temp > A_Size)
- {
- A_Size = temp;
- }
- temp = strlen(primitive_descriptor->Scheme_Name);
- if (temp > S_Size)
- {
- S_Size = temp;
- }
- temp = strlen(primitive_descriptor->File_Name);
- if (temp > F_Size)
- {
- F_Size = temp;
- }
return;
}
void
-copy_arity_token (s, size)
- char s[];
- int *size;
+print_entry (output, index, primitive_descriptor)
+ FILE * output;
+ int index;
+ struct descriptor * primitive_descriptor;
{
- char buffer [ARITY_SIZE];
- int buffer_size;
-
- buffer_size = (*size);
- copy_token (buffer, (& buffer_size));
- if ((strcmp (buffer, "LEXPR")) == 0)
+ int index_length;
+
+ fprintf (output, " %-*s ",
+ max_c_name_length, (primitive_descriptor -> c_name));
+ fprintf (output, "/%c ", '*');
+ fprintf (output, "%*s %-*s",
+ max_arity_length, (primitive_descriptor -> arity),
+ max_scheme_name_length, (primitive_descriptor -> scheme_name));
+ fprintf (output, " %s ", the_kind);
+ if (index >= 0)
{
- strcpy (buffer, "-1");
- buffer_size = 2;
+ FIND_INDEX_LENGTH (index, index_length);
+ print_spaces (output, (max_index_length - index_length));
+ fprintf (output, "0x%x", index);
}
- strcpy (s, buffer);
- if ((*size) < buffer_size)
- (*size) = buffer_size;
- return;
-}
-\f
-pseudo_void
-create_normal_entry()
-{
- if (buffer_index >= BUFFER_SIZE)
- {
- fprintf(stderr, "Error: %s cannot handle so many primitives.\n", name);
- fprintf(stderr, "Recompile %s with BUFFER_SIZE larger than %d.\n",
- name, BUFFER_SIZE);
- error_exit(FALSE);
- }
- scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).C_Name, &C_Size);
- scan_to_token_start();
- copy_arity_token((Data_Buffer[buffer_index]).Arity, &A_Size);
- scan_to_token_start();
- copy_symbol((Data_Buffer[buffer_index]).Scheme_Name, &S_Size);
- copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, &F_Size);
- Result_Buffer[buffer_index] = &Data_Buffer[buffer_index];
- buffer_index++;
+ else
+ {
+ print_spaces (output, (max_index_length - 1));
+ fprintf (output, "???");
+ }
+ fprintf (output, " in %s %c/", (primitive_descriptor -> file_name), '*');
return;
}
-pseudo_void
-create_alternate_entry()
+void
+print_spaces (output, how_many)
+ FILE * output;
+ register int how_many;
{
- if (buffer_index >= BUFFER_SIZE)
- {
- fprintf(stderr, "Error: %s cannot handle so many primitives.\n", name);
- fprintf(stderr, "Recompile %s with BUFFER_SIZE larger than %d.\n",
- name, BUFFER_SIZE);
- error_exit(FALSE);
- }
- scan_to_token_start();
- copy_symbol((Data_Buffer[buffer_index]).Scheme_Name, &S_Size);
- scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).C_Name, &C_Size);
- scan_to_token_start();
- copy_arity_token((Data_Buffer[buffer_index]).Arity, &A_Size);
- copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, &F_Size);
- Result_Buffer[buffer_index] = &Data_Buffer[buffer_index];
- buffer_index++;
+ while ((--how_many) >= 0)
+ putc (' ', output);
return;
}
\f
+/* Input Parsing */
+
+char * token_buffer;
+int token_buffer_length;
+
void
-initialize_external()
+initialize_token_buffer ()
{
- Built_in_p = FALSE;
- (token_array [0]) = &External_Token[0];
- (token_array [1]) = NULL;
- (token_processors [0]) = create_normal_entry;
- (token_processors [1]) = NULL;
- The_Kind = &External_Kind[0];
- The_Variable = &External_Variable[0];
- update_from_entry(&Inexistent_Entry);
+ token_buffer_length = 80;
+ token_buffer = (xmalloc (token_buffer_length));
return;
}
void
-initialize_default()
+grow_token_buffer ()
{
- Built_in_p = FALSE;
- (token_array [0]) = &Default_Token[0];
- (token_array [1]) = (& (default_token_alternate [0]));
- (token_array [2]) = NULL;
- (token_processors [0]) = create_normal_entry;
- (token_processors [1]) = create_alternate_entry;
- (token_processors [2]) = NULL;
- The_Kind = &Default_Kind[0];
- The_Variable = &Default_Variable[0];
- update_from_entry(&Inexistent_Entry);
+ token_buffer_length *= 2;
+ token_buffer = (xrealloc (token_buffer, token_buffer_length));
return;
}
-\f
-int
-read_index(arg)
- char *arg;
-{
- int result = 0;
- if ((arg[0] == '0') && (arg[1] == 'x'))
- sscanf(&arg[2], "%x", &result);
- else
- sscanf(&arg[0], "%d", &result);
- return result;
-}
+#define TOKEN_BUFFER_DECLS() \
+ register char * TOKEN_BUFFER_scan; \
+ register char * TOKEN_BUFFER_end
-pseudo_void
-create_builtin_entry()
-{
- static char index_buffer[STRING_SIZE];
- int index = 0;
+#define TOKEN_BUFFER_START() \
+{ \
+ TOKEN_BUFFER_scan = token_buffer; \
+ TOKEN_BUFFER_end = (token_buffer + token_buffer_length); \
+}
- scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).C_Name, &C_Size);
- scan_to_token_start();
- copy_arity_token((Data_Buffer[buffer_index]).Arity, &A_Size);
- scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).Scheme_Name, &S_Size);
- copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, &F_Size);
- scan_to_token_start();
- copy_token(index_buffer, &index);
- index = read_index(index_buffer);
- if (index >= Built_in_table_size)
- {
- fprintf(stderr, "%s: Table size = %d; Found Primitive %d.\n",
- name, Built_in_table_size, index);
- error_exit(FALSE);
- }
- if (Result_Buffer[index] != &Inexistent_Entry)
- {
- void print_entry(), initialize_index_size();
-
- fprintf(stderr, "%s: redefinition of primitive %d.\n", name, index);
- fprintf(stderr, "previous definition:\n");
- initialize_index_size();
- output = stderr,
- print_entry(index, Result_Buffer[index]);
- fprintf(stderr, "\n");
- fprintf(stderr, "new definition:\n");
- print_entry(index, &Data_Buffer[buffer_index]);
- fprintf(stderr, "\n");
- error_exit(FALSE);
- }
- Result_Buffer[index] = &Data_Buffer[buffer_index];
- buffer_index++;
- return;
+#define TOKEN_BUFFER_WRITE(c) \
+{ \
+ if (TOKEN_BUFFER_scan == TOKEN_BUFFER_end) \
+ { \
+ int n; \
+ \
+ n = (TOKEN_BUFFER_scan - token_buffer); \
+ grow_token_buffer (); \
+ TOKEN_BUFFER_scan = (token_buffer + n); \
+ TOKEN_BUFFER_end = (token_buffer + token_buffer_length); \
+ } \
+ (*TOKEN_BUFFER_scan++) = (c); \
}
-void
-initialize_builtin(arg)
- char *arg;
-{
- register int index;
+#define TOKEN_BUFFER_OVERWRITE(s) \
+{ \
+ int TOKEN_BUFFER_n; \
+ \
+ TOKEN_BUFFER_n = ((strlen (s)) + 1); \
+ while (TOKEN_BUFFER_n > token_buffer_length) \
+ { \
+ grow_token_buffer (); \
+ TOKEN_BUFFER_end = (token_buffer + token_buffer_length); \
+ } \
+ strcpy (token_buffer, s); \
+ TOKEN_BUFFER_scan = (token_buffer + TOKEN_BUFFER_n); \
+}
- Built_in_p = TRUE;
- Built_in_table_size = read_index(arg);
- if (Built_in_table_size > BUFFER_SIZE)
- {
- fprintf(stderr, "%s: built_in_table_size > BUFFER_SIZE.\n", name);
- fprintf(stderr, "Recompile with a larger value of BUFFER_SIZE.\n");
- error_exit(FALSE);
- }
- (token_array [0]) = &Built_in_Token[0];
- (token_array [1]) = NULL;
- (token_processors [0]) = create_builtin_entry;
- (token_processors [1]) = NULL;
- The_Kind = &Built_in_Kind[0];
- The_Variable = &Built_in_Variable[0];
- for (index = Built_in_table_size; --index >= 0; )
- {
- Result_Buffer[index] = &Inexistent_Entry;
- }
- update_from_entry(&Inexistent_Entry);
- return;
+#define TOKEN_BUFFER_FINISH(target, size) \
+{ \
+ int TOKEN_BUFFER_n; \
+ char * TOKEN_BUFFER_result; \
+ \
+ TOKEN_BUFFER_n = (TOKEN_BUFFER_scan - token_buffer); \
+ TOKEN_BUFFER_result = (xmalloc (TOKEN_BUFFER_n)); \
+ strcpy (TOKEN_BUFFER_result, token_buffer); \
+ (target) = TOKEN_BUFFER_result; \
+ TOKEN_BUFFER_n -= 1; \
+ if ((size) < TOKEN_BUFFER_n) \
+ (size) = TOKEN_BUFFER_n; \
}
\f
-int
-compare_descriptors(d1, d2)
- descriptor *d1, *d2;
-{
- int value;
-
- dprintf("comparing \"%s\"", d1->Scheme_Name);
- dprintf(" and \"%s\".\n", d2->Scheme_Name);
- value = strcmp(d1->Scheme_Name, d2->Scheme_Name);
- if (value > 0)
- {
- return 1;
- }
- else if (value < 0)
+enum tokentype
{
- return -1;
- }
- else
- {
- return 0;
- }
-}
+ tokentype_integer,
+ tokentype_identifier,
+ tokentype_string,
+ tokentype_string_upcase
+ };
void
-mergesort(low, high, array, temp_array)
- int low;
- register int high;
- register descriptor **array, **temp_array;
+copy_token (target, size, token_type)
+ char ** target;
+ int * size;
+ register enum tokentype token_type;
{
- void print_entry(), initialize_index_size();
- register int index, low1, low2;
- int high1, high2;
-
- dprintf("mergesort: low = %d", low);
- dprintf("; high = %d", high);
-
- if (high <= low)
- {
- dprintf("; done.%s\n", "");
- return;
- }
-
- low1 = low;
- high1 = ((low + high) / 2);
- low2 = (high1 + 1);
- high2 = high;
-
- dprintf("; high1 = %d\n", high1);
-
- mergesort(low, high1, temp_array, array);
- mergesort(low2, high, temp_array, array);
-\f
- dprintf("mergesort: low1 = %d", low1);
- dprintf("; high1 = %d", high1);
- dprintf("; low2 = %d", low2);
- dprintf("; high2 = %d\n", high2);
-
- for (index = low; index <= high; index += 1)
- {
- dprintf("index = %d", index);
- dprintf("; low1 = %d", low1);
- dprintf("; low2 = %d\n", low2);
+ register int c;
+ TOKEN_BUFFER_DECLS ();
- if (low1 > high1)
+ TOKEN_BUFFER_START ();
+ c = (getc (input));
+ if (c == '\"')
{
- array[index] = temp_array[low2];
- low2 += 1;
+ while (1)
+ {
+ c = (getc (input));
+ if (c == '\"') break;
+ TOKEN_BUFFER_WRITE
+ ((c == '\\')
+ ? (getc (input))
+ : (((token_type == tokentype_string_upcase) &&
+ (isalpha (c)) &&
+ (islower (c)))
+ ? (toupper (c))
+ : c));
+ }
+ TOKEN_BUFFER_WRITE ('\0');
}
- else if (low2 > high2)
+ else
{
- array[index] = temp_array[low1];
- low1 += 1;
+ TOKEN_BUFFER_WRITE (c);
+ while (1)
+ {
+ c = (getc (input));
+ if (whitespace (c)) break;
+ TOKEN_BUFFER_WRITE (c);
+ }
+ TOKEN_BUFFER_WRITE ('\0');
+ if ((strcmp (token_buffer, "LEXPR")) == 0)
+ {
+ TOKEN_BUFFER_OVERWRITE ("-1");
+ }
+ else if ((token_type == tokentype_string) &&
+ ((strcmp (token_buffer, "0")) == 0))
+ TOKEN_BUFFER_OVERWRITE ("");
}
- else
+ TOKEN_BUFFER_FINISH ((* target), (* size));
+ return;
+}
+
+boolean
+whitespace (c)
+ register int c;
+{
+ switch (c)
{
- switch(compare_descriptors(temp_array[low1], temp_array[low2]))
- {
- case -1:
- array[index] = temp_array[low1];
- low1 += 1;
- break;
+ case ' ':
+ case '\t':
+ case '\n':
+ case '(':
+ case ')':
+ case ',': return TRUE;
+ default: return FALSE;
+ }
+}
- case 1:
- array[index] = temp_array[low2];
- low2 += 1;
- break;
-\f
- default:
- fprintf(stderr, "Error: bad comparison.\n");
- goto comparison_abort;
+void
+scan_to_token_start ()
+{
+ register int c;
- case 0:
- {
- fprintf(stderr, "Error: repeated primitive.\n");
-comparison_abort:
- initialize_index_size();
- output = stderr;
- fprintf(stderr, "definition 1:\n");
- print_entry(low1, temp_array[low1]);
- fprintf(stderr, "\ndefinition 2:\n");
- print_entry(low2, temp_array[low2]);
- fprintf(stderr, "\n");
- error_exit(FALSE);
- break;
- }
- }
- }
- }
+ while (whitespace (c = (getc (input)))) ;
+ ungetc (c, input);
return;
}
void
-sort()
+skip_token ()
{
- register int count;
- if (buffer_index <= 0)
- return;
-
- for (count = (buffer_index - 1); count >= 0; count -= 1)
- {
- Temp_Buffer[count] = Result_Buffer[count];
- }
- mergesort(0, (buffer_index - 1), Result_Buffer, Temp_Buffer);
+ register int c;
+
+ while (! (whitespace (c = (getc (input))))) ;
+ ungetc (c, input);
return;
}
\f
-static int max, max_index_size;
-static char index_buffer[STRING_SIZE];
+void
+initialize_data_buffer ()
+{
+ buffer_length = 0x200;
+ buffer_index = 0;
+ data_buffer =
+ ((struct descriptor (*) [])
+ (xmalloc (buffer_length * (sizeof (struct descriptor)))));
+ result_buffer =
+ ((struct descriptor **)
+ (xmalloc (buffer_length * (sizeof (struct descriptor *)))));
+
+ max_c_name_length = 0;
+ max_arity_length = 0;
+ max_scheme_name_length = 0;
+ max_documentation_length = 0;
+ max_file_name_length = 0;
+ update_from_entry (& inexistent_entry);
-#define find_index_size(index, size) \
-{ \
- sprintf(index_buffer, "%x", (index)); \
- size = strlen(index_buffer); \
+ return;
}
void
-initialize_index_size()
+grow_data_buffer ()
{
- if (Built_in_p)
- {
- max = Built_in_table_size;
- }
- else
- {
- max = buffer_index;
- }
- find_index_size(max, max_index_size);
- max -= 1;
+ buffer_length *= 2;
+ data_buffer =
+ ((struct descriptor (*) [])
+ (xrealloc (data_buffer, (buffer_length * (sizeof (struct descriptor))))));
+ result_buffer =
+ ((struct descriptor **)
+ (xrealloc (result_buffer,
+ (buffer_length * (sizeof (struct descriptor *))))));
return;
}
+
+#define MAYBE_GROW_BUFFER() \
+{ \
+ if (buffer_index == buffer_length) \
+ grow_data_buffer (); \
+}
+
+#define COPY_SCHEME_NAME(desc) \
+{ \
+ scan_to_token_start (); \
+ copy_token ((& ((desc) . scheme_name)), \
+ (& max_scheme_name_length), \
+ tokentype_string_upcase); \
+}
+
+#define COPY_C_NAME(desc) \
+{ \
+ scan_to_token_start (); \
+ copy_token ((& ((desc) . c_name)), \
+ (& max_c_name_length), \
+ tokentype_identifier); \
+}
+
+#define COPY_ARITY(desc) \
+{ \
+ scan_to_token_start (); \
+ copy_token ((& ((desc) . arity)), \
+ (& max_arity_length), \
+ tokentype_integer); \
+}
+
+#define COPY_DOCUMENTATION(desc) \
+{ \
+ scan_to_token_start (); \
+ copy_token ((& ((desc) . documentation)), \
+ (& max_documentation_length), \
+ tokentype_string); \
+}
+
+#define DEFAULT_DOCUMENTATION(desc) \
+{ \
+ ((desc) . documentation) = ""; \
+}
+
+#define COPY_FILE_NAME(desc) \
+{ \
+ int length; \
+ \
+ ((desc) . file_name) = file_name; \
+ length = (strlen (file_name)); \
+ if (max_file_name_length < length) \
+ max_file_name_length = length; \
+}
\f
void
-print_spaces(how_many)
- register int how_many;
+initialize_default ()
{
- for(; --how_many >= 0;)
- {
- putc(' ', output);
- }
+ built_in_p = FALSE;
+ (token_array [0]) = (& (default_token [0]));
+ (token_array [1]) = (& (default_token_alternate [0]));
+ (token_array [2]) = NULL;
+ (token_processors [0]) = create_normal_entry;
+ (token_processors [1]) = create_alternate_entry;
+ (token_processors [2]) = NULL;
+ the_kind = (& (default_kind [0]));
+ the_variable = (& (default_variable [0]));
return;
}
void
-print_entry(index, primitive_descriptor)
- int index;
- descriptor *primitive_descriptor;
+initialize_external ()
{
- int index_size;
-
- fprintf(output, " %s ", (primitive_descriptor->C_Name));
- print_spaces(C_Size - (strlen(primitive_descriptor->C_Name)));
- fprintf(output, "/%c ", '*');
- print_spaces(A_Size - (strlen(primitive_descriptor->Arity)));
- fprintf(output,
- "%s \"%s\"",
- (primitive_descriptor->Arity),
- (primitive_descriptor->Scheme_Name));
- print_spaces(S_Size-(strlen(primitive_descriptor->Scheme_Name)));
- fprintf(output, " %s ", The_Kind);
- if (index >= 0)
- {
- find_index_size(index, index_size);
- print_spaces(max_index_size - index_size);
- fprintf(output, "0x%x", index);
- }
- else
- {
- print_spaces(max_index_size - 1);
- fprintf(output, "???");
- }
- fprintf(output, " in %s %c/", (primitive_descriptor->File_Name), '*');
+ built_in_p = FALSE;
+ (token_array [0]) = (& (external_token [0]));
+ (token_array [1]) = NULL;
+ (token_processors [0]) = create_normal_entry;
+ (token_processors [1]) = NULL;
+ the_kind = (& (external_kind [0]));
+ the_variable = (& (external_variable [0]));
return;
}
void
-print_procedure(primitive_descriptor, error_string)
- descriptor *primitive_descriptor;
- char *error_string;
+initialize_builtin (arg)
+ char * arg;
{
- fprintf(output, "Pointer\n");
- fprintf(output, "%s()\n", (primitive_descriptor->C_Name));
- fprintf(output, "{\n");
- fprintf(output, " Primitive_%s_Args();\n", (primitive_descriptor->Arity));
- fprintf(output, "\n");
- fprintf(output, " %s;\n", error_string);
- fprintf(output, " /%cNOTREACHED%c/\n", '*', '*');
- fprintf(output, "}\n");
+ register int length;
+ register int index;
+
+ built_in_p = TRUE;
+ length = (read_index (arg, "built_in_table_size"));
+ while (buffer_length < length)
+ grow_data_buffer ();
+ for (index = 0; (index < buffer_length); index += 1)
+ (result_buffer [index]) = NULL;
+ buffer_index = length;
+ (token_array [0]) = (& (built_in_token [0]));
+ (token_array [1]) = NULL;
+ (token_processors [0]) = create_builtin_entry;
+ (token_processors [1]) = NULL;
+ the_kind = (& (built_in_kind [0]));
+ the_variable = (& (built_in_variable [0]));
return;
}
-\f
+
void
-print_primitives(last)
- register int last;
+update_from_entry (primitive_descriptor)
+ register struct descriptor * primitive_descriptor;
{
+ register int temp;
- register int count;
+ temp = (strlen (primitive_descriptor -> scheme_name));
+ if (max_scheme_name_length < temp)
+ max_scheme_name_length = temp;
- /* Print the procedure table. */
+ temp = (strlen (primitive_descriptor -> c_name));
+ if (max_c_name_length < temp)
+ max_c_name_length = temp;
- fprintf(output, "Pointer (*(%s_Procedure_Table[]))() = {\n", The_Kind);
+ temp = (strlen (primitive_descriptor -> arity));
+ if (max_arity_length < temp)
+ max_arity_length = temp;
- for (count = 0; count <= last; count++)
- {
- print_entry(count, Result_Buffer[count]);
- fprintf(output, ",\n");
- }
- print_entry(-1, &Inexistent_Entry);
- fprintf(output, "\n};\n\f\n");
+ temp = (strlen (primitive_descriptor -> documentation));
+ if (max_documentation_length < temp)
+ max_documentation_length = temp;
- /* Print the names table. */
-
- fprintf(output, "char *%s_Name_Table[] = {\n", The_Kind);
+ temp = (strlen (primitive_descriptor -> file_name));
+ if (max_file_name_length < temp)
+ max_file_name_length = temp;
- for (count = 0; count < last; count++)
- {
- fprintf(output, " \"%s\",\n", ((Result_Buffer[count])->Scheme_Name));
- }
- fprintf(output, " \"%s\"\n", ((Result_Buffer[last])->Scheme_Name));
- fprintf(output, "};\n\f\n");
-\f
- /* Print the arity table. */
-
- fprintf(output, "int %s_Arity_Table[] = {\n", The_Kind);
-
- for (count = 0; count < last; count++)
- {
- fprintf(output, " %s,\n", ((Result_Buffer[count])->Arity));
- }
- fprintf(output, " %s\n", ((Result_Buffer[last])->Arity));
- fprintf(output, "};\n\f\n");
-
- /* Print the counts table. */
-
- fprintf(output, "int %s_Count_Table[] = {\n", The_Kind);
+ return;
+}
- for (count = 0; count < last; count++)
- {
- fprintf(output,
- " (%s * sizeof(Pointer)),\n",
- ((Result_Buffer[count])->Arity));
- }
- fprintf(output,
- " (%s * sizeof(Pointer))\n",
- ((Result_Buffer[last])->Arity));
- fprintf(output, "};\n\n");
+pseudo_void
+create_normal_entry ()
+{
+ MAYBE_GROW_BUFFER ();
+ COPY_C_NAME ((* data_buffer) [buffer_index]);
+ COPY_ARITY ((* data_buffer) [buffer_index]);
+ COPY_SCHEME_NAME ((* data_buffer) [buffer_index]);
+ DEFAULT_DOCUMENTATION ((* data_buffer) [buffer_index]);
+ COPY_FILE_NAME ((* data_buffer) [buffer_index]);
+ (result_buffer [buffer_index]) = (& ((* data_buffer) [buffer_index]));
+ buffer_index += 1;
+ return;
+}
+pseudo_void
+create_alternate_entry ()
+{
+ MAYBE_GROW_BUFFER ();
+ COPY_SCHEME_NAME ((* data_buffer) [buffer_index]);
+ COPY_C_NAME ((* data_buffer) [buffer_index]);
+ scan_to_token_start ();
+ skip_token (); /* min_args */
+ COPY_ARITY ((* data_buffer) [buffer_index]);
+ COPY_DOCUMENTATION ((* data_buffer) [buffer_index]);
+ COPY_FILE_NAME ((* data_buffer) [buffer_index]);
+ (result_buffer [buffer_index]) = (& ((* data_buffer) [buffer_index]));
+ buffer_index += 1;
return;
}
-\f
-/* Produce C source. */
-void
-dump(check)
- boolean check;
+pseudo_void
+create_builtin_entry ()
{
- register int count, end;
+ struct descriptor desc;
+ register int length;
+ int index;
+ char * index_buffer;
+
+ COPY_C_NAME (desc);
+ COPY_ARITY (desc);
+ COPY_SCHEME_NAME (desc);
+ DEFAULT_DOCUMENTATION (desc);
+ COPY_FILE_NAME (desc);
+ index = 0;
+ scan_to_token_start();
+ copy_token ((& index_buffer), (& index), tokentype_integer);
+ index = (read_index (index_buffer, "index"));
+ length = (index + 1);
+ if (buffer_length < length)
+ {
+ register int i;
- initialize_index_size();
+ while (buffer_length < length)
+ grow_data_buffer ();
+ for (i = buffer_index; (i < buffer_length); i += 1)
+ (result_buffer [i]) = NULL;
+ }
+ if (buffer_index < length)
+ buffer_index = length;
+ if ((result_buffer [index]) != NULL)
+ {
+ fprintf (stderr, "%s: redefinition of primitive %d.\n", name, index);
+ fprintf (stderr, "previous definition:\n");
+ FIND_INDEX_LENGTH (buffer_index, max_index_length);
+ print_entry (stderr, index, (result_buffer [index]));
+ fprintf (stderr, "\n");
+ fprintf (stderr, "new definition:\n");
+ print_entry (stderr, index, (& ((* data_buffer) [index])));
+ fprintf (stderr, "\n");
+ exit (1);
+ }
+ ((* data_buffer) [index]) = desc;
+ (result_buffer [index]) = (& ((* data_buffer) [index]));
+ return;
+}
- /* Print header. */
+int
+read_index (arg, identification)
+ char * arg;
+ char * identification;
+{
+ int result;
- fprintf(output, "/%c Emacs: This is -*- C -*- code. %c/\n\n", '*', '*');
+ result = 0;
+ if (((arg [0]) == '0') && ((arg [1]) == 'x'))
+ sscanf ((& (arg [2])), "%x", (& result));
+ else
+ sscanf ((& (arg [0])), "%d", (& result));
+ if (result < 0)
+ {
+ fprintf (stderr, "%s: %s == %d\n", identification, result);
+ exit (1);
+ }
+ return (result);
+}
+\f
+/* Sorting */
- fprintf(output, "/%c %s primitive declarations %c/\n\n",
- '*', ((Built_in_p) ? "Built in" : "User defined" ), '*');
+void
+sort ()
+{
+ register struct descriptor ** temp_buffer;
+ register int count;
- fprintf(output, "#include \"usrdef.h\"\n\n");
+ if (buffer_index <= 0)
+ return;
+ temp_buffer =
+ ((struct descriptor **)
+ (xmalloc (buffer_index * (sizeof (struct descriptor *)))));
+ for (count = 0; (count < buffer_index); count += 1)
+ (temp_buffer [count]) = (result_buffer [count]);
+ mergesort (0, (buffer_index - 1), result_buffer, temp_buffer);
+ free (temp_buffer);
+ return;
+}
- fprintf(output,
- "long %s = %d; /%c = 0x%x %c/\n\n",
- The_Variable, max, '*', max, '*');
+void
+mergesort (low, high, array, temp_array)
+ int low;
+ register int high;
+ register struct descriptor ** array;
+ register struct descriptor ** temp_array;
+{
+ register int index;
+ register int low1;
+ register int low2;
+ int high1;
+ int high2;
- if (Built_in_p)
- {
- fprintf(output,
- "/%c The number of implemented primitives is %d. %c/\n\n",
- '*', buffer_index, '*');
- }
+ dprintf ("mergesort: low = %d", low);
+ dprintf ("; high = %d", high);
- if (max < 0)
- {
- if (check)
+ if (high <= low)
{
- fprintf(stderr, "No primitives found!\n");
+ dprintf ("; done.%s\n", "");
+ return;
}
- /* C does not understand the empty array, thus it must be faked. */
-
- fprintf(output, "/%c C does not understand the empty array, ", '*');
- fprintf(output, "thus it must be faked. %c/\n\n", '*');
+ low1 = low;
+ high1 = ((low + high) / 2);
+ low2 = (high1 + 1);
+ high2 = high;
- /* Dummy entry */
+ dprintf ("; high1 = %d\n", high1);
- Result_Buffer[0] = &Dummy_Entry;
- update_from_entry(&Dummy_Entry);
- print_procedure(&Dummy_Entry, &Dummy_Error_String[0]);
- fprintf(output, "\n");
- }
-\f
- else
- {
- /* Print declarations. */
+ mergesort (low, high1, temp_array, array);
+ mergesort (low2, high, temp_array, array);
- fprintf(output, "extern Pointer\n");
+ dprintf ("mergesort: low1 = %d", low1);
+ dprintf ("; high1 = %d", high1);
+ dprintf ("; low2 = %d", low2);
+ dprintf ("; high2 = %d\n", high2);
- end = (Built_in_p ? buffer_index : max);
- for (count = 0; count < end; count++)
+ for (index = low; (index <= high); index += 1)
{
- fprintf(output, " %s(),\n", &(Data_Buffer[count].C_Name)[0]);
+ dprintf ("index = %d", index);
+ dprintf ("; low1 = %d", low1);
+ dprintf ("; low2 = %d\n", low2);
+
+ if (low1 > high1)
+ {
+ (array [index]) = (temp_array [low2]);
+ low2 += 1;
+ }
+ else if (low2 > high2)
+ {
+ (array [index]) = (temp_array [low1]);
+ low1 += 1;
+ }
+ else
+ {
+ switch (compare_descriptors ((temp_array [low1]),
+ (temp_array [low2])))
+ {
+ case (-1):
+ (array [index]) = (temp_array [low1]);
+ low1 += 1;
+ break;
+
+ case 1:
+ (array [index]) = (temp_array [low2]);
+ low2 += 1;
+ break;
+
+ default:
+ fprintf (stderr, "Error: bad comparison.\n");
+ goto comparison_abort;
+
+ case 0:
+ {
+ fprintf (stderr, "Error: repeated primitive.\n");
+ comparison_abort:
+ FIND_INDEX_LENGTH (buffer_index, max_index_length);
+ output = stderr;
+ fprintf (stderr, "definition 1:\n");
+ print_entry (output, low1, (temp_array [low1]));
+ fprintf (stderr, "\ndefinition 2:\n");
+ print_entry (output, low2, (temp_array [low2]));
+ fprintf (stderr, "\n");
+ exit (1);
+ break;
+ }
+ }
+ }
}
+ return;
+}
- fprintf(output, " %s();\n\n", &(Data_Buffer[end].C_Name)[0]);
- }
+int
+compare_descriptors (d1, d2)
+ struct descriptor * d1;
+ struct descriptor * d2;
+{
+ int value;
- print_procedure(&Inexistent_Entry, &Inexistent_Error_String[0]);
- fprintf(output, "\f\n");
- print_primitives((max < 0) ? 0 : max);
- return;
+ dprintf ("comparing \"%s\"", (d1 -> scheme_name));
+ dprintf(" and \"%s\".\n", (d2 -> scheme_name));
+ value = (strcmp ((d1 -> scheme_name), (d2 -> scheme_name)));
+ if (value > 0)
+ return (1);
+ else if (value < 0)
+ return (-1);
+ else
+ return (0);
}
/* -*-C-*-
-Copyright (c) 1987 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988 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.4 1988/08/10 05:45:38 pas Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/sgraph_a.c,v 1.5 1988/08/15 20:33:45 cph Exp $ */
#include "scheme.h"
-#include "primitive.h"
+#include "prims.h"
#include "flonum.h"
#include "Sgraph.h"
#include "array.h"
float Color_Table[STARBASE_COLOR_TABLE_SIZE][3];
\f
-Define_Primitive(Prim_Plot_Array_In_Box, 3, "PLOT-ARRAY-IN-BOX")
+DEFINE_PRIMITIVE ("PLOT-ARRAY-IN-BOX", Prim_plot_array_in_box, 3, 3, 0)
{
float Plotting_Box[4]; /* x_min, y_min, x_max, y_max */
long Length; int fill_with_lines;
Orig_Free++;
My_Store_Reduced_Flonum_Result(Scale, *Orig_Free);
Orig_Free++;
- *Orig_Free = NIL;
+ *Orig_Free = EMPTY_LIST;
PRIMITIVE_RETURN(Answer);
}
\f
-Define_Primitive(Prim_Plot_Array_In_Box_With_Offset_Scale, 5, "PLOT-ARRAY-IN-BOX-WITH-OFFSET-SCALE")
+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;
Orig_Free++;
My_Store_Reduced_Flonum_Result(Scale, *Orig_Free);
Orig_Free++;
- *Orig_Free = NIL;
+ *Orig_Free = EMPTY_LIST;
PRIMITIVE_RETURN(Answer);
}
\f
ERR_ARG_2_WRONG_TYPE);
Touch_In_Primitive( Vector_Ref(List, CONS_CDR), List );
}
- if (List != NIL)
+ if (List != EMPTY_LIST)
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
}
\f
make_picture_current(screen_handle);
}
\f
-Define_Primitive(Prim_Clear_Box, 1, "CLEAR-BOX")
+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(NIL);
+ PRIMITIVE_RETURN(SHARP_F);
}
\f
C_Clear_Rectangle(Box)
clip_rectangle(screen_handle, sb_xmin, sb_xmax, sb_ymin, sb_ymax);
}
\f
-Define_Primitive(Prim_Box_Move, 2, "BOX-MOVE")
+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];
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(NIL);
+ PRIMITIVE_RETURN(SHARP_F);
}
\f
-Define_Primitive(Prim_Box_Rotate_Move, 2, "BOX-ROTATE-MOVE")
+DEFINE_PRIMITIVE ("BOX-ROTATE-MOVE", Prim_box_rotate_move, 2, 2, 0)
{
float From_Box[4];
float To_Box[4];
block_read(screen_handle, x_source, y_source, ((int) x_length), ((int) y_length),
x_dest, y_dest);
- PRIMITIVE_RETURN(NIL);
+ PRIMITIVE_RETURN(SHARP_F);
}
\f
;; They call C_image_psam_atxy_wmm to do the actual drawing.
*/
-Define_Primitive(Prim_image_psam_atxy_wmm, 5, "IMAGE-PSAM-ATXY-WMM")
+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;
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 (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 */
C_image_psam_atxy_wmm(Array, pdata, nrows, ncols,
((float) x_at), ((float) y_at),
Min, Max);
- PRIMITIVE_RETURN(TRUTH);
+ PRIMITIVE_RETURN(SHARP_T);
}
-Define_Primitive(Prim_image_psam_atxy_womm, 5, "IMAGE-PSAM-ATXY-WOMM")
+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;
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 (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 */
C_image_psam_atxy_womm(Array, pdata, nrows, ncols,
((float) x_at), ((float) y_at),
Min, Max);
- PRIMITIVE_RETURN(TRUTH);
+ PRIMITIVE_RETURN(SHARP_T);
}
-Define_Primitive(Prim_image_ht_od_atxy_wmm, 7, "IMAGE-HT-OD-ATXY-WMM")
+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;
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 (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 */
C_image_ht_od_atxy_wmm(Array, pdata, nrows,ncols,
((float) x_at), ((float) y_at), Min,Max,
HG,ODmethod);
- PRIMITIVE_RETURN(TRUTH);
+ PRIMITIVE_RETURN(SHARP_T);
}
-Define_Primitive(Prim_image_ht_bn_atxy_wmm, 7, "IMAGE-HT-BN-ATXY-WMM")
+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;
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 (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 */
C_image_ht_bn_atxy_wmm(Array, pdata, nrows,ncols,
((float) x_at), ((float) y_at), Min,Max,
HG,BNmethod, er_rows);
- PRIMITIVE_RETURN(TRUTH);
+ PRIMITIVE_RETURN(SHARP_T);
}
#define MINTEGER long
-Define_Primitive(Prim_image_ht_ibn_atxy_wmm, 8, "IMAGE-HT-IBN-ATXY-WMM")
+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;
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 (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 */
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(TRUTH);
+ PRIMITIVE_RETURN(SHARP_T);
}
\f
/* ARGS = (image x_at y_at magnification) magnification can be 1, 2, or 3
*/
-Define_Primitive(Prim_Draw_Magnify_Image_At_XY, 4, "DRAW-MAGNIFY-IMAGE-AT-XY")
+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;
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 (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 */
((float) x_at), ((float) y_at),
Offset, Scale,
Magnification);
- PRIMITIVE_RETURN(TRUTH);
+ PRIMITIVE_RETURN(SHARP_T);
}
}
\f
-Define_Primitive(Prim_Draw_Magnify_Image_At_XY_With_Min_Max, 6, "DRAW-MAGNIFY-IMAGE-AT-XY-WITH-MIN-MAX")
+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;
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 (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 */
((float) x_at), ((float) y_at),
Offset, Scale,
Magnification);
- PRIMITIVE_RETURN(TRUTH);
+ PRIMITIVE_RETURN(SHARP_T);
}
\f
-Define_Primitive(Prim_Draw_Magnify_Image_At_XY_Only_Between_Min_Max, 6, "DRAW-MAGNIFY-IMAGE-AT-XY-ONLY-BETWEEN-MIN-MAX")
+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;
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 (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 */
((float) x_at), ((float) y_at),
Offset, Scale,
Magnification);
- PRIMITIVE_RETURN(TRUTH);
+ PRIMITIVE_RETURN(SHARP_T);
}
\f
\f
/*_______________________ Grey Level Manipulations _____________________ */
-Define_Primitive(Prim_New_Color, 4, "NEW-COLOR")
+DEFINE_PRIMITIVE ("NEW-COLOR", Prim_new_color, 4, 4, 0)
{ int i, err;
long index;
float red, green, blue;
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(TRUTH);
+ PRIMITIVE_RETURN(SHARP_T);
}
\f
-Define_Primitive(Prim_Inquire_Colors, 0, "INQUIRE-COLORS")
+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(TRUTH);
+ PRIMITIVE_RETURN(SHARP_T);
}
-Define_Primitive(Prim_Inquire_Color, 1, "INQUIRE-COLOR")
+DEFINE_PRIMITIVE ("INQUIRE-COLOR", Prim_inquire_color, 1, 1, 0)
{ int i; int index;
Pointer Answer, *Orig_Free;
REAL red, green, blue;
Orig_Free++;
My_Store_Reduced_Flonum_Result(blue, *Orig_Free);
Orig_Free++;
- *Orig_Free = NIL;
+ *Orig_Free = EMPTY_LIST;
PRIMITIVE_RETURN(Answer);
}
\f
-Define_Primitive(Prim_Read_Colors_From_File, 1, "READ-COLORS-FROM-FILE")
+DEFINE_PRIMITIVE ("READ-COLORS-FROM-FILE", Prim_read_colors_from_file, 1, 1, 0)
{ long i;
FILE *fopen(), *fp;
char *file_string;
Close_File(fp); /* fflush(stdout); */
define_color_table(screen_handle, STARBASE_COLOR_TABLE_START,
STARBASE_COLOR_TABLE_SIZE, Color_Table);
- PRIMITIVE_RETURN(TRUTH);
+ PRIMITIVE_RETURN(SHARP_T);
}
-Define_Primitive(Prim_Save_Colors_In_File, 1, "SAVE-COLORS-IN-FILE")
+DEFINE_PRIMITIVE ("SAVE-COLORS-IN-FILE", Prim_save_colors_in_file, 1, 1, 0)
{ long i;
FILE *fopen(), *fp;
char *file_string;
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(TRUTH);
+ PRIMITIVE_RETURN(SHARP_T);
}
/* END */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/sgx.c,v 1.3 1988/07/19 20:04:12 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/sgx.c,v 1.4 1988/08/15 20:33:25 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
#include <X/Xlib.h>
#include <X/Xhp.h>
#include "scheme.h"
-#include "primitive.h"
+#include "prims.h"
#include "flonum.h"
#include "Sgraph.h"
\f
error_external_return ();
}
\f
-/* (X-GRAPHICS-OPEN-DISPLAY display-name)
+DEFINE_PRIMITIVE ("X-GRAPHICS-OPEN-DISPLAY", Prim_x_graphics_open_display, 1, 1,
+ "Opens display DISPLAY-NAME. DISPLAY-NAME may be #F, in which case the
+default display is opened (based on the DISPLAY environment
+variable). Returns #T if the open succeeds, #F otherwise.
- Opens the named display. The name may be #F, in which case the
- default display is opened (based on the DISPLAY environment
- variable). Returns #T if the open succeeds, #F otherwise.
-
- This primitive is additionally useful for determining whether the
- X server is running on the named display. */
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-OPEN-DISPLAY", Prim_x_graphics_open_display, 1)
+This primitive is additionally useful for determining whether the
+X server is running on the named display.")
{
PRIMITIVE_HEADER (1);
XErrorHandler (x_error_handler);
XIOErrorHandler (x_io_error_handler);
- display = (XOpenDisplay (((ARG_REF (1)) == NIL) ? NULL : (STRING_ARG (1))));
+ display =
+ (XOpenDisplay (((ARG_REF (1)) == SHARP_F) ? NULL : (STRING_ARG (1))));
window = 0;
(filename [0]) = '\0';
raster_state = 0;
- PRIMITIVE_RETURN ((display == NULL) ? NIL : TRUTH);
+ PRIMITIVE_RETURN ((display != NULL) ? SHARP_T : SHARP_F);
}
-DEFINE_PRIMITIVE ("X-GRAPHICS-CLOSE-DISPLAY", Prim_x_graphics_close_display, 0)
+DEFINE_PRIMITIVE ("X-GRAPHICS-CLOSE-DISPLAY", Prim_x_graphics_close_display, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
close_display ();
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
static void
on the current display. If another window was previously opened
using this primitive, it is closed. */
-DEFINE_PRIMITIVE ("X-GRAPHICS-OPEN-WINDOW", Prim_x_graphics_open_window, 5)
+DEFINE_PRIMITIVE ("X-GRAPHICS-OPEN-WINDOW", Prim_x_graphics_open_window, 5, 5, 0)
{
XhpArgItem arglist [7];
PRIMITIVE_HEADER (5);
PRIMITIVE_RETURN (C_String_To_Scheme_String (& (filename [0])));
}
-DEFINE_PRIMITIVE ("X-GRAPHICS-CLOSE-WINDOW", Prim_x_graphics_close_window, 0)
+DEFINE_PRIMITIVE ("X-GRAPHICS-CLOSE-WINDOW", Prim_x_graphics_close_window, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
close_window ();
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
static void
return;
}
\f
-DEFINE_PRIMITIVE ("X-GRAPHICS-MAP-WINDOW", Prim_x_graphics_map_window, 0)
+DEFINE_PRIMITIVE ("X-GRAPHICS-MAP-WINDOW", Prim_x_graphics_map_window, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
GUARANTEE_WINDOW ();
XMapWindow (window);
XFlush ();
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
-DEFINE_PRIMITIVE ("X-GRAPHICS-UNMAP-WINDOW", Prim_x_graphics_unmap_window, 0)
+DEFINE_PRIMITIVE ("X-GRAPHICS-UNMAP-WINDOW", Prim_x_graphics_unmap_window, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
GUARANTEE_WINDOW ();
XUnmapWindow (window);
XFlush ();
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
-DEFINE_PRIMITIVE ("X-GRAPHICS-RAISE-WINDOW", Prim_x_graphics_raise_window, 0)
+DEFINE_PRIMITIVE ("X-GRAPHICS-RAISE-WINDOW", Prim_x_graphics_raise_window, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
GUARANTEE_WINDOW ();
XRaiseWindow (window);
XFlush ();
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
-DEFINE_PRIMITIVE ("X-GRAPHICS-LOWER-WINDOW", Prim_x_graphics_lower_window, 0)
+DEFINE_PRIMITIVE ("X-GRAPHICS-LOWER-WINDOW", Prim_x_graphics_lower_window, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
GUARANTEE_WINDOW ();
XLowerWindow (window);
XFlush ();
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
-DEFINE_PRIMITIVE ("X-GRAPHICS-CONFIGURE-WINDOW", Prim_x_graphics_configure_window, 4)
+DEFINE_PRIMITIVE ("X-GRAPHICS-CONFIGURE-WINDOW", Prim_x_graphics_configure_window, 4, 4, 0)
{
PRIMITIVE_HEADER (4);
(arg_nonnegative_integer (3)),
(arg_nonnegative_integer (4)));
XFlush ();
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
\f
/* Routines to control the backup raster. */
-DEFINE_PRIMITIVE ("X-GRAPHICS-CREATE-RASTER", Prim_x_graphics_create_raster, 0)
+DEFINE_PRIMITIVE ("X-GRAPHICS-CREATE-RASTER", Prim_x_graphics_create_raster, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
XhpRetainWindow (window, XhpCREATE_RASTER);
XFlush ();
raster_state = 1;
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
-DEFINE_PRIMITIVE ("X-GRAPHICS-DELETE-RASTER", Prim_x_graphics_delete_raster, 0)
+DEFINE_PRIMITIVE ("X-GRAPHICS-DELETE-RASTER", Prim_x_graphics_delete_raster, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
GUARANTEE_WINDOW ();
delete_raster ();
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
static void
return;
}
-DEFINE_PRIMITIVE ("X-GRAPHICS-START-RETAIN", Prim_x_graphics_start_retain, 0)
+DEFINE_PRIMITIVE ("X-GRAPHICS-START-RETAIN", Prim_x_graphics_start_retain, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
GUARANTEE_RASTER ();
XhpRetainWindow (window, XhpSTART_RETAIN);
XFlush ();
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
-DEFINE_PRIMITIVE ("X-GRAPHICS-STOP-RETAIN", Prim_x_graphics_stop_retain, 0)
+DEFINE_PRIMITIVE ("X-GRAPHICS-STOP-RETAIN", Prim_x_graphics_stop_retain, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
GUARANTEE_RASTER ();
XhpRetainWindow (window, XhpSTOP_RETAIN);
XFlush ();
- PRIMITIVE_RETURN (NIL);
+ PRIMITIVE_RETURN (SHARP_F);
}
projects / mit-scheme.git / commitdiff